home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _97fff96783d15d159433089b308acbfa < prev    next >
Encoding:
Text File  |  2004-06-01  |  8.0 KB  |  357 lines
  1. package PPM::InstallerClient;
  2.  
  3. use strict;
  4. use Socket;
  5. use Cwd qw(cwd);
  6. use File::Basename qw(dirname basename);
  7. use File::Path qw(mkpath rmtree);
  8.  
  9. use Data::Dumper;
  10. use vars qw($VERSION %handlers);
  11.  
  12. use constant PROTOCOL => 2;
  13. $VERSION = '3.0';
  14.  
  15. #=============================================================================
  16. # API:
  17. #=============================================================================
  18. sub new {
  19.     my ($pkg, $port) = @_;
  20.     my $o = bless {}, ref($pkg) || $pkg;
  21.     $o->init($port);
  22. }
  23.  
  24. sub init {
  25.     my ($inst, $ppm_port) = @_;
  26.     my ($paddr, $proto, $msg);
  27.  
  28.     # Set up a temporary socket server and waits for the frontend to connect
  29.     # to it.
  30.     # TODO: put this in a big while(1) loop, and keep a list of connected
  31.     # frontends. That way, we can service multiple front-ends at once, which
  32.     # prevents multiple instances of the same target from clobbering each
  33.     # other's changes.
  34.     $proto = getprotobyname('tcp');
  35.     socket(SERVER, PF_INET, SOCK_STREAM, $proto)    || die "socket: $!";
  36.     setsockopt(SERVER, SOL_SOCKET, SO_REUSEADDR,
  37.            pack('l', 1))                || die "setsockopt: $!";
  38.     bind(SERVER, sockaddr_in($ppm_port, INADDR_ANY))    || die "bind: $!";
  39.     listen(SERVER, SOMAXCONN);
  40.     $paddr = accept(CLIENT, SERVER);
  41.     my ($port, $iaddr) = sockaddr_in($paddr);
  42.     my $name = gethostbyaddr($iaddr, AF_INET);
  43.     select((select(CLIENT), $| = 1)[0]);
  44.     $inst->{fd} = \*CLIENT;
  45.     close(SERVER);
  46.  
  47.     $inst->{cwd} = cwd;
  48.  
  49.     # Read commands from the socket:
  50.     while ($msg = $inst->recvmsg) {
  51.     my ($cmd, @args) = decode_record($msg);
  52.     my $h = $handlers{lc($cmd)};
  53.     if (defined $h) {
  54.         last unless $inst->$h($cmd, @args);
  55.     }
  56.     else {
  57.         die "Unrecognized command: $cmd";
  58.     }
  59.     }
  60. }
  61.  
  62. %handlers = (
  63.     has        => sub {
  64.     my ($inst, undef, @args) = @_;
  65.     my $cmd = $args[0];
  66.     if (exists $handlers{lc($cmd)}) {
  67.         $inst->sendmsg("OK");
  68.     }
  69.     else {
  70.         $inst->sendmsg("NOK");
  71.     }
  72.     },
  73.     query    => sub {
  74.     my ($inst, $cmd, @args) = @_;
  75.     my @ppds = $inst->query(@args);
  76.     if (not $ppds[0]) {
  77.         $inst->sendmsg("NOK");
  78.     }
  79.     else {
  80.         my @records = map { encode_record($_) } @ppds[1..$#ppds];
  81.         local $" = "\n";
  82.         $inst->sendmsg("@records");
  83.     }
  84.     1;
  85.     },
  86.     properties    => sub {
  87.     my ($inst, $cmd, @args) = @_;
  88.     my @fields = $inst->properties(@args);
  89.     if (@fields) {
  90.         $inst->sendmsg(encode_record(@fields));
  91.     }
  92.     else {
  93.         $inst->sendmsg("NOK");
  94.     }
  95.     1;
  96.     },
  97.     remove    => sub {
  98.     my ($inst, $cmd, @args) = @_;
  99.     my $ret = $inst->remove(@args);
  100.     if ($ret) {
  101.         $inst->sendmsg("OK");
  102.     }
  103.     else {
  104.         $inst->sendmsg("NOK");
  105.     }
  106.     1;
  107.     },
  108.     precious    => sub {
  109.     my ($inst, $cmd, @args) = @_;
  110.     my @ret = $inst->precious();
  111.     $inst->sendmsg(encode_record(@ret));
  112.     1;
  113.     },
  114.     bundled    => sub {
  115.     my ($inst, $cmd, @args) = @_;
  116.     my @ret = $inst->bundled();
  117.     $inst->sendmsg(encode_record(@ret));
  118.     },
  119.     dependents    => sub {
  120.     my ($inst, $cmd, @args) = @_;
  121.     my @ret = $inst->dependents(@args);
  122.     if (@ret == 1 and not defined $ret[0]) {
  123.         $inst->sendmsg('NOK');
  124.     }
  125.     elsif (@ret == 0) {
  126.         $inst->sendmsg(encode_record(undef));
  127.     }
  128.     else {
  129.         $inst->sendmsg(encode_record(@ret));
  130.     }
  131.     1;
  132.     },
  133.     config_info    => sub {
  134.     my ($inst, $cmd, @args) = @_;
  135.     my @ret = $inst->config_info;
  136.     if (@ret) {
  137.         my @records = map { encode_record(@$_) } @ret;
  138.         local $" = "\n";
  139.         $inst->sendmsg("@records");
  140.     }
  141.     else {
  142.         $inst->sendmsg("NOK");
  143.     }
  144.     1;
  145.     },
  146.     config_keys    => sub {
  147.     my ($inst, $cmd, @args) = @_;
  148.     my @ret = $inst->config_keys;
  149.     if (@ret) {
  150.         my @records = map { encode_record(@$_) } @ret;
  151.         local $" = "\n";
  152.         $inst->sendmsg("@records");
  153.     }
  154.     else {
  155.         $inst->sendmsg("NOK");
  156.     }
  157.     1;
  158.     },
  159.     config_get    => sub {
  160.     my ($inst, $cmd, @args) = @_;
  161.     # Because I don't want the actual installer reporting this key, I
  162.     # will override it here, in the client library. The C version will do
  163.     # this.
  164.     if ($args[0] eq 'PROTOCOL') {
  165.         $inst->sendmsg(PROTOCOL);
  166.         return 1;
  167.     }
  168.     my $ret = $inst->config_get(@args);
  169.     if ($ret) {
  170.         $inst->sendmsg($ret);
  171.     }
  172.     else {
  173.         $inst->sendmsg("NOK");
  174.     }
  175.     1;
  176.     },
  177.     config_set    => sub {
  178.     my ($inst, $cmd, @args) = @_;
  179.     if ($inst->config_set(@args)) {
  180.         $inst->sendmsg("OK");
  181.     } 
  182.     else {
  183.         $inst->sendmsg("NOK");
  184.     }
  185.     1;
  186.     },
  187.     error_str    => sub {
  188.     my ($inst, $cmd, @args) = @_;
  189.     $inst->sendmsg($inst->error_str);
  190.     1;
  191.     },
  192.     can_install    => sub {
  193.     my ($inst, $cmd, @args) = @_;
  194.     # The following line is for reference:
  195.     # my ($lang, $version, $compat_type) = @args;
  196.     my $ret = $inst->can_install(@args);
  197.     if (defined $ret) {
  198.         $inst->sendmsg($ret);
  199.     }
  200.     else {
  201.         sendmsg('NOK');
  202.     }
  203.     1;
  204.     },
  205.     install    => sub {
  206.     my ($inst, $cmd, @args) = @_;
  207.     # The following line is for reference:
  208.     # my ($pkg, $ppmpath, $ppd, $repos, $ppmpath) = @args;
  209.     $args[1] = $inst->{tmpdirs}{$args[0]}
  210.       if exists $inst->{tmpdirs}{$args[0]};
  211.  
  212.     my $ret = $inst->install(@args);
  213.     if ($ret) {
  214.         $inst->sendmsg("OK");
  215.     }
  216.     else {
  217.         $inst->sendmsg("NOK");
  218.     }
  219.     1;
  220.     },
  221.     upgrade    => sub {
  222.     my ($inst, $cmd, @args) = @_;
  223.     # The following line is for reference:
  224.     # my ($pkg, $ppmpath, $ppd, $repos, $ppmpath) = @args;
  225.     $args[1] = $inst->{tmpdirs}{$args[0]}
  226.       if exists $inst->{tmpdirs}{$args[0]};
  227.  
  228.     my $ret = $inst->upgrade(@args);
  229.     if ($ret) {
  230.         $inst->sendmsg("OK");
  231.     }
  232.     else {
  233.         $inst->sendmsg("NOK");
  234.     }
  235.     1;
  236.     },
  237.     pkginit    => sub {
  238.     my ($inst, $cmd, @args) = @_;
  239.     my $pkg = shift @args;
  240.     my $tmpdir = $inst->config_get("tempdir");
  241.     unless ($tmpdir and -w $tmpdir) {
  242.         $inst->sendmsg(encode_record(
  243.         'NOK', "Backend tempdir '$tmpdir' not writeable"
  244.         ));
  245.         return 1;
  246.     }
  247.     $tmpdir .= "/$pkg-$$";
  248.     mkpath($tmpdir);
  249.     $inst->{tmpdirs}{$pkg} = $tmpdir;
  250.     $inst->sendmsg('OK');
  251.     1;
  252.     },
  253.     pkgfini    => sub {
  254.     my ($inst, $cmd, @args) = @_;
  255.     my $pkg = shift @args;
  256.     my $path = $inst->{tmpdirs}{$pkg} or do {
  257.         $inst->sendmsg(
  258.         encode_record('NOK', 'pkgfini() without pkginit()')
  259.         );
  260.         return 1;
  261.     };
  262.     rmtree($path);
  263.     delete $inst->{tmpdirs}{$pkg};
  264.     $inst->sendmsg('OK');
  265.     1;
  266.     },
  267.     transmit    => sub {
  268.     my ($inst, $cmd, @args) = @_;
  269.     my $pkg  = shift @args;
  270.     my $tmpdir = $inst->{tmpdirs}{$pkg};
  271.     my $file = shift @args;
  272.     my $dir  = dirname($file);
  273.  
  274.     chdir($tmpdir);
  275.     mkpath($dir);
  276.  
  277.     eval {
  278.         open(FILE, "> $file")    || die "can't write $file: $!";
  279.         binmode(FILE)        || die "can't binmode $file: $!";
  280.     };
  281.     if ($@) {
  282.         $inst->sendmsg(encode_record('NOK', "$@"));
  283.         return 1;
  284.     }
  285.     $inst->sendmsg('OK');
  286.     my $msg;
  287.     while ($msg = $inst->recvmsg) {
  288.         my ($flag, $data) = decode_record($msg);
  289.         last if $flag eq 'EOT';
  290.         print FILE $data;
  291.     }
  292.     eval {
  293.         close(FILE)            || die "can't close $file: $!";
  294.     };
  295.     if ($@) {
  296.         $inst->sendmsg(encode_record('NOK', "$@"));
  297.         return 1;
  298.     }
  299.     $inst->sendmsg('OK');
  300.     chdir($inst->{cwd});
  301.     1;
  302.     },
  303.     stop    => sub {
  304.     my ($inst, $cmd, @args) = @_;
  305.     close(CLIENT);
  306.     0;
  307.     },
  308. );
  309.  
  310. #=============================================================================
  311. # Private functions!
  312. #=============================================================================
  313.  
  314. use constant FIELD_SEP => "\001";
  315. use constant FIELD_UNDEF => "\002";
  316. my $EOL = "\015\012";
  317.  
  318. sub sendmsg {
  319.     my $o = shift;
  320.     my $fd = $o->{fd};
  321.     my $msg = shift;
  322.     local $\ = "$EOL.$EOL";
  323.     print $fd $msg;
  324. }
  325.  
  326. sub recvmsg {
  327.     my $o = shift;
  328.     my $fd = $o->{fd};
  329.     local $/ = "$EOL.$EOL";
  330.     my $msg = <$fd>;
  331.     chomp $msg if $msg;
  332.     return $msg;
  333. }
  334.  
  335. sub qmeta {
  336.     local $_ = shift || $_;
  337.     s{([^A-Za-z0-9])}{sprintf('\x%.2X',ord($1))}eg;
  338.     $_;
  339. }
  340.  
  341. sub uqmeta {
  342.     local $_ = shift || $_;
  343.     eval qq{qq{$_}};
  344. }
  345.  
  346. sub encode_record {
  347.     my @fields = map { my $a = defined $_ ? $_ : FIELD_UNDEF; qmeta($a) } @_;
  348.     join FIELD_SEP, @fields;
  349. }
  350.  
  351. sub decode_record {
  352.     my $t = shift || $_;
  353.     return map { $_ = &uqmeta; $_ = undef if $_ eq FIELD_UNDEF; $_ }
  354.        split(FIELD_SEP, $t, -1);
  355. }
  356.  
  357.