home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _0ebd492523aa70f2fde0b71926c5b256 < prev    next >
Encoding:
Text File  |  2004-06-01  |  8.1 KB  |  310 lines
  1. package PPM::Installer;
  2.  
  3. use strict;
  4. use Socket;
  5. use Data::Dumper;
  6. use PPM::Result qw(Error Warning Ok List);
  7.  
  8. my %connections;
  9. sub new {
  10.     my ($class, $name, $targ) = @_;
  11.  
  12.     my @ret;
  13.     my $pkg  = "PPM::Installer::$targ->{type}";
  14.  
  15.     # Let the type decide which subclass to use:
  16.     eval "require $pkg";
  17.     if (not $@) {
  18.     no strict 'refs';
  19.     $connections{$name} = &{"${pkg}::new"}($pkg, $targ, $name);
  20.     $connections{$name}->init;
  21.     @ret = $connections{$name};
  22.     }
  23.     else {
  24.     @ret = (undef, "Unsupported installer type '$targ->{type}'");
  25.     }
  26.     @ret;
  27. }
  28.  
  29. sub DESTROY {
  30.     my $o = shift;
  31.     $o->fini;
  32. }
  33.  
  34. #=============================================================================
  35. # API methods -- simple fetch routines.
  36. #=============================================================================
  37. sub name {
  38.     my $inst = shift;
  39.     $inst->{name};
  40. }
  41.  
  42. sub port {
  43.     my $inst = shift;
  44.     $inst->{port};
  45. }
  46.  
  47. sub type {
  48.     my $inst = shift;
  49.     $inst->{type};
  50. }
  51.  
  52. sub ckeys { qw(port type) }
  53. sub cvals {
  54.     my $o = shift;
  55.     map { $o->$_ } $o->ckeys;
  56. }
  57.  
  58. #=============================================================================
  59. # Methods which determine which version of the API the backend is running.
  60. #=============================================================================
  61. # We remember here what methods were supported under protocol version 1.
  62. my %HAS = map { $_ => 1 } qw(
  63.     query
  64.     properties
  65.     remove
  66.     precious
  67.     bundled
  68.     dependents
  69.     config_info
  70.     config_keys
  71.     config_get
  72.     config_set
  73.     error_str
  74.     install
  75.     upgrade
  76.     pkginit
  77.     pkgfini
  78.     transmit
  79.     stop
  80. );
  81.  
  82. sub has {
  83.     my $inst = shift;
  84.     my $method = shift;
  85.     return $inst->_has($method) if $inst->protocol >= 2;
  86.     return $HAS{$method} ? 1 : 0;
  87. }
  88.  
  89. sub _has {
  90.     my $inst = shift;
  91.     my $method = shift;
  92.     my $send = $inst->encode_record("HAS", $method);
  93.     $inst->sendmsg($send);
  94.     my $msg = $inst->recvmsg;
  95.     return 0 if $msg and $msg eq 'NOK';
  96.     return 1;
  97. }
  98.  
  99. #=============================================================================
  100. # API methods which probably should be overridden in subclasses.
  101. #=============================================================================
  102. sub init { }
  103. sub fini { }
  104.  
  105. # Transmit files to the backend installer agent. This is used for remote
  106. # installers, which must copy the files to the remote machine in order to
  107. # install them. Local installers can just use the local copy.
  108. sub pkginit  { Ok() }    # creates any temporary directory needed
  109. sub transmit { Ok() }    # transmits files (into the temp dir)
  110. sub pkgfini  { Ok() }    # removes the temporary directory
  111.  
  112. #=============================================================================
  113. # API methods which _may_ be overridden in subclasses.
  114. #=============================================================================
  115. sub connect_to {
  116.     my $inst = shift;
  117.     my $addr = shift;
  118.     my $port = shift;
  119.     my ($iaddr, $paddr, $proto);
  120.     $iaddr = inet_aton($addr)
  121.       or return Error("no host: $addr");
  122.     $paddr = sockaddr_in($port, $iaddr);
  123.     $proto = getprotobyname('tcp');
  124.     socket($inst->{SOCK}, PF_INET, SOCK_STREAM, $proto)
  125.       or return Error("socket: $!");
  126.     connect($inst->{SOCK}, $paddr)
  127.       or return Error("connect: $!");
  128.     select((select($inst->{SOCK}), $| = 1)[0]);
  129.     Ok();
  130. }
  131.  
  132. sub query {
  133.     my $inst = shift;
  134.     $inst->sendmsg($inst->encode_record("QUERY", @_));
  135.     my $msg = $inst->recvmsg;
  136.     return Error($inst->error_str) if $msg eq 'NOK';
  137.     my@l = map { PPM::PPD->new($_) } 
  138.        map { chomp; $inst->decode_record($_) }    # flattens fields
  139.        split(/^/, $msg);
  140.     List(@l);
  141. }
  142.  
  143. sub properties {
  144.     my $inst = shift;
  145.     $inst->sendmsg($inst->encode_record("PROPERTIES", @_));
  146.     my $recv = $inst->recvmsg;
  147.     if ($recv eq 'NOK') {
  148.     return Error($inst->error_str);
  149.     }
  150.     my ($ppd, @other) = $inst->decode_record($recv);
  151.     return List(PPM::PPD->new($ppd), @other);
  152. }
  153.  
  154. sub precious {
  155.     my $inst = shift;
  156.     $inst->sendmsg("PRECIOUS");
  157.     List($inst->decode_record($inst->recvmsg));
  158. }
  159.  
  160. sub bundled {
  161.     my $inst = shift;
  162.     $inst->sendmsg("BUNDLED");
  163.     List($inst->decode_record($inst->recvmsg));
  164. }
  165.  
  166. sub dependents {
  167.     my $inst = shift;
  168.     $inst->sendmsg($inst->encode_record("DEPENDENTS", @_));
  169.     my $recv = $inst->recvmsg;
  170.     return Error($inst->error_str) if $recv eq 'NOK';
  171.     return List() if not defined (($inst->decode_record($recv))[0]);
  172.     return List($inst->decode_record($recv));
  173. }
  174.  
  175. sub remove {
  176.     my $inst = shift;
  177.     $inst->sendmsg($inst->encode_record("REMOVE", @_));
  178.     return Ok() if $inst->recvmsg eq 'OK';
  179.     return Error($inst->error_str);
  180. }
  181.  
  182. sub install {
  183.     my $inst = shift;
  184.     $inst->sendmsg($inst->encode_record("INSTALL", @_));
  185.     return Ok() if $inst->recvmsg eq 'OK';
  186.     return Error($inst->error_str);
  187. }
  188.  
  189. sub upgrade {
  190.     my $inst = shift;
  191.     $inst->sendmsg($inst->encode_record("UPGRADE", @_));
  192.     return Ok() if $inst->recvmsg eq 'OK';
  193.     return Error($inst->error_str);
  194. }
  195.  
  196. sub config_info {
  197.     my $inst = shift;
  198.     $inst->sendmsg("CONFIG_INFO");
  199.     my %info = map { chomp; $inst->decode_record } split /^/, $inst->recvmsg;
  200.     return List(map { [$_, $info{$_}] } sort keys %info);
  201. }
  202.  
  203. sub config_keys {
  204.     my $inst = shift;
  205.     $inst->sendmsg("CONFIG_KEYS");
  206.     my %keys = map { chomp; $inst->decode_record } split /^/, $inst->recvmsg;
  207.     return List(map { [$_, $keys{$_}] } sort keys %keys);
  208. }
  209.  
  210. sub config_get {
  211.     my $inst = shift;
  212.     $inst->sendmsg($inst->encode_record("CONFIG_GET", @_));
  213.     my $value = $inst->recvmsg;
  214.     return Error($inst->error_str)
  215.       if $value eq 'NOK';
  216.     return Ok($value);
  217. }
  218.  
  219. sub config_set {
  220.     my $inst = shift;
  221.     $inst->sendmsg($inst->encode_record("CONFIG_SET", @_));
  222.     return Ok() if $inst->recvmsg eq 'OK';
  223.     return Error($inst->error_str);
  224. }
  225.  
  226. sub protocol {
  227.     my $inst = shift;
  228.     my $v = $inst->config_get("PROTOCOL");
  229.     return $v->result if $v->ok;
  230.     return 1; # version 1 didn't expose the PROTOCOL variable.
  231. }
  232.  
  233. # This method was not supported in the first version of the PPM3 backend. To
  234. # compensate, we'll do a lousy emulation: if the languages are the same, and
  235. # the required version is lexically less than the PERLCORE exposed by the
  236. # backend, we'll allow the installation to proceed.
  237. sub can_install {
  238.     my $inst = shift;
  239.     unless ($inst->has('can_install')) {
  240.     my ($lang, $version, $compat) = @_;
  241.     return Ok(1) if (
  242.         lc $lang eq lc $inst->config_get("TARGET_TYPE")->result and
  243.         lc $version lt lc $inst->config_get("PERLCORE")->result
  244.     );
  245.     return Ok(0);
  246.     }
  247.     $inst->sendmsg($inst->encode_record("CAN_INSTALL", @_));
  248.     my $result = $inst->recvmsg;
  249.     return Error($inst->error_str) if $result eq 'NOK';
  250.     return Ok($result);
  251. }
  252.  
  253. sub error_str {
  254.     my $inst = shift;
  255.     $inst->sendmsg("ERROR_STR");
  256.     $inst->recvmsg;
  257. }
  258.  
  259. #=============================================================================
  260. # Non-API methods. Touch not, lest ye be smacked.
  261. #=============================================================================
  262. use constant FIELD_SEP => "\001";
  263. use constant FIELD_UNDEF => "\002";
  264. my $EOL = "\015\012";
  265. sub sendmsg {
  266.     my $inst = shift;
  267.     my $msg = shift;
  268.     my $fd = $inst->{SOCK};
  269.     {
  270.     local $\ = "$EOL.$EOL";
  271.     print $fd $msg;
  272.     }
  273. }
  274.  
  275. sub recvmsg {
  276.     my $inst = shift;
  277.     local $/ = "$EOL.$EOL";
  278.     my $fd = $inst->{SOCK};
  279.     chomp(my $msg = <$fd>);
  280.     return $msg;
  281. }
  282.  
  283. sub qmeta {
  284.     local $_ = shift || $_;
  285.     s{([^A-Za-z0-9])}{sprintf('\x%.2X',ord($1))}eg;
  286.     $_;
  287. }
  288.  
  289. sub uqmeta {
  290.     local $_ = shift || $_;
  291.     $_ = eval qq{qq{$_}};
  292.     warn $@ if $@;
  293.     $_;
  294. }
  295.  
  296. sub encode_record {
  297.     my $o = shift;
  298.     my @fields = map { my $a = defined $_ ? $_ : FIELD_UNDEF; qmeta($a) } @_;
  299.     join FIELD_SEP, @fields;
  300. }
  301.  
  302. sub decode_record {
  303.     my $o = shift;
  304.     my $t = shift || $_;
  305.     return map { $_ = &uqmeta; $_ = undef if $_ eq FIELD_UNDEF; $_ }
  306.        split(FIELD_SEP, $t, -1);
  307. }
  308.  
  309. 1;
  310.