#!/usr/bin/perl -w

# make a CPAN autobundle for your server over the WWW

BEGIN { print(q[Content-Type: text/plain; charset=ISO-8859-1] . qq[\012\012]) }

use strict;
use POSIX qw( :sys_wait_h );
use Time::HiRes qw( usleep );

my($reminder)  = '';
my($debugging) = 1;
my($deamon)    = 0;
my($remaining) = 0;
my($attempted) = 0;
my($alarm)     = 15;
my($wait)      = 0;
my($inc)       = 5;
my($now)       = time();
my($n)         = qq[\n];


# %=%=%=%=%=%=%=%=%=%=%= FORKING =%=%=%=%=%=%=%=%=%=%=%=%=%=%=%=%=%=%=%=%=%=%=

# HACK! HACK! HACK! HACK! /------------------------------
use CPAN qw( autobundle );

package CPAN::Shell::autobundle;

sub autobundle {

   my($self) = shift;
   my($todir) = './logs';

   CPAN::Config->load unless $CPAN::Config_loaded++;

   my(@bundle) = CPAN::Shell::autobundle->_u_r_common("a",@_);


   my($y,$m,$d) =  (localtime)[5,4,3];

   $y+=1900; $m++;
   my($c) = 0;
   my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
   my($to) = MM->catfile($todir,"$me.pm");

   while (-f $to) {

      $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
      $to = MM->catfile($todir,"$me.pm");
   }

   my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";

   $fh->print(
        "package Bundle::$me;\n\n",
        "\$VERSION = '0.01';\n\n",
        "1;\n\n",
        "__END__\n\n",
        "=head1 NAME\n\n",
        "Bundle::$me - Snapshot of installation on ",
        $Config::Config{'myhostname'},
        " on ",
        scalar(localtime),
        "\n\n=head1 SYNOPSIS\n\n",
        "perl -MCPAN -e 'install Bundle::$me'\n\n",
        "=head1 CONTENTS\n\n",
        join("\n", @bundle),
        "\n\n=head1 CONFIGURATION\n\n",
        Config->myconfig,
        "\n\n=head1 AUTHOR\n\n",
        "This Bundle has been generated automatically ",
        "by the autobundle routine in CPAN.pm.\n",
       );

   $fh->close;

   $CPAN::Frontend->myprint("\nWrote bundle file $to\n\n");
}


# end ------------------/ HACK! HACK! HACK! HACK!

package main;
{

   # fork-o-rama!  -man I hate this.
   my($pid) = fork; ++$|;

   die(qq[I ($$) Can't fork $!] . $n x 2) if (!defined($pid));

   if (!$pid) {

      # child proc

      print(qq[ making parent wait on me ($$).$n]);

      print(autobundle);

      local(*FH);

      open(FH, '>./logs/donefile') or die(qq[problem writing to pwd. $!]);

      close(FH);

      exit;
   }
   else {

      # parent proc
      {
         print(q[<!-- Please Don`t Time Out! -->], $n);

         usleep(500_000); # .5 seconds (2.5 seconds = 2_500_000 microseconds)

         redo unless (-e './logs/donefile')
      }

      unlink('donefile') or warn('could not unlink donefile');

      # waitpid( $pid, &POSIX::WNOHANG() )
      # and print(qq[ done waiting on child ($pid).$n]);
      waitpid( $pid, 0 ) and print(qq[ ($$) done waiting on child ($pid).$n]);
   }
}

# %=%=%=%=%=%=%=%=%=%=%= DONE FORKING =%=%=%=%=%=%=%=%=%=%=%=%=%=%=%=%=%=%=%=


# proc handlers
BEGIN { warn(qq[\n\nproc $$ beginning now.\n\n]) }
END { warn(qq[\n\nproc $$ exiting now.\n\n]) }

# signal handlers
BEGIN {

   foreach (keys(%SIG)) {

      my($key) = $_;

      $SIG{$key} = sub {

         $key = '??' unless (defined($key) and length($key));

         warn(scalar(localtime), qq[ -- Got SIG $key\012])
      }
   }

   undef($!)
}

# internal logging; redirect STDERR to a log
BEGIN {

   local(*EL); open(EL,'>>./tmp-error.log') and open(STDERR,'>&EL');

   my($stdout) = select(STDERR); ++$| and select($stdout)
}


=TWO WAYS TO waitpid

   NORMAL WAY TO USE waitpid
      waitpid( $pid, 0 ) and print(qq[ done waiting on $pid.]);

   NO HANG WAY TO USE waitpid
      use POSIX qw( :sys_wait_h );
      waitpid( $pid, &POSIX::WNOHANG() ) and print(qq[ done waiting on $pid.]);

=cut

=SIGS (on *my* current system)

1) SIGHUP       2) SIGINT       3) SIGQUIT      4) SIGILL
5) SIGTRAP      6) SIGABRT      7) SIGEMT       8) SIGFPE
9) SIGKILL     10) SIGBUS      11) SIGSEGV     12) SIGSYS
13) SIGPIPE     14) SIGALRM     15) SIGTERM     16) SIGURG
17) SIGSTOP     18) SIGTSTP     19) SIGCONT     20) SIGCHLD
21) SIGTTIN     22) SIGTTOU     23) SIGIO       24) SIGXCPU
25) SIGXFSZ     26) SIGVTALRM   27) SIGPROF     28) SIGWINCH
29) SIGLOST     30) SIGUSR1     31) SIGUSR2

=cut