home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _76d2c82d0acffc445a378cc682d16275 < prev    next >
Encoding:
Text File  |  2004-06-01  |  2.3 KB  |  98 lines
  1. package PPM::Installer::Local;
  2. @PPM::Installer::Local::ISA = qw(PPM::Installer);
  3.  
  4. use strict;
  5. use Data::Dumper;
  6. use PPM::PPD;
  7. use PPM::Result qw(Ok Warning Error List);
  8.  
  9. sub new {
  10.     my $class = shift;
  11.     my $targ = shift;
  12.     my $name = shift;
  13.     my $inst = bless {
  14.     name => $name,
  15.     path => $targ->{path},
  16.     type => $targ->{type},
  17.     port => $targ->{port},
  18.     }, $class;
  19.     return $inst;
  20. }
  21.  
  22. sub init {
  23.     my $inst = shift;
  24.  
  25.     # First, check if the process is already running. If so, use that.
  26.     my $ok = $inst->connect_to('localhost', $inst->{port});
  27.  
  28.     # If it isn't, try to launch it ourselves, _then_ connect. Because
  29.     # spawning a process is fairly slow, we have to try to connect for a
  30.     # little while, to give the child time to set up the server.
  31.     do {
  32.     $inst->spawn;
  33.     for (1 .. 10) {
  34.         $ok = $inst->connect_to('localhost', $inst->{port});
  35.         last if $ok->ok;
  36.         # let the CPU swap out to the child process.
  37.         defined &Win32::Sleep ? Win32::Sleep(250) : sleep 1;
  38.     }
  39.     die $ok->msg unless $ok->ok;
  40.     } unless $ok->ok;
  41.     $ok;
  42. }
  43.  
  44. sub fini {
  45.     my $o = shift;
  46.     $o->sendmsg('STOP');
  47. }
  48.  
  49. sub spawn {
  50.     my $inst = shift;
  51.  
  52.     $ENV{PPM_PORT} = $inst->port;
  53.  
  54.     # Note: $inst->{path} must be an executable, but Windows
  55.     # does not support an executable permission bit, checking
  56.     # for .bat or .exe files instead. This isn't suitable
  57.     # for scripts, so we only make this check on non-Windows boxes
  58.     die "$0: error: '$inst->{path}' is not executable"
  59.       unless ((-x $inst->{path}) or ($^O eq 'MSWin32'));
  60.     if ($^O eq 'MSWin32') {
  61.     $inst->{path} =~ s,/,\\,g;
  62.  
  63.     # We don't want the child to inherit our STDOUT because that
  64.     # would break things like `ppm query * > modlist`.
  65.     # XXX Unfortunately this also silences all output from
  66.     # XXX post-install scripts. :(  Disabled for now...
  67.     #open(MYSTDOUT, ">&STDOUT") or die $!;
  68.     #close(STDOUT);
  69.     #open(STDOUT, ">nul") or die $!;
  70.  
  71.     $inst->{pid} = system(1, $inst->{path});
  72.  
  73.     #open(STDOUT, ">&MYSTDOUT") or die $!;
  74.     #close(MYSTDOUT);
  75.     }
  76.     else {
  77.     $inst->{pid} = fork();
  78.     if (defined $inst->{pid} and $inst->{pid} == 0) {
  79.         exec $inst->{path};
  80.         exit 1;
  81.     }
  82.     }
  83. }
  84.  
  85. sub ckeys {
  86.     my $o = shift;
  87.     ($o->SUPER::ckeys,
  88.      qw(path),
  89.     );
  90. }
  91.  
  92. sub path {
  93.     my $o = shift;
  94.     $o->{path};
  95. }
  96.  
  97. 1;
  98.