home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2004 July / APC0407D2.iso / workshop / apache / files / ActivePerl-5.6.1.638-MSWin32-x86.msi / _fe3572da52942b0f2f46aa43752b6ec3 < prev    next >
Encoding:
Text File  |  2004-04-13  |  6.7 KB  |  224 lines
  1. package PPM::Compat;
  2. $VERSION = '3.00';
  3.  
  4. use strict;
  5. use Data::Dumper;
  6. use XML::Parser;
  7.  
  8. use constant PPM_PORT_PERL => 14533;
  9.  
  10. sub read_ppm_xml {
  11.     my ($file, $conf, $reps, $inst, $cmd, $extra) = @_;
  12.     my $parser = XML::Parser->new(Style => 'Tree');
  13.     my $tree   = $parser->parsefile($file);
  14.  
  15.     die "Error: node PPMCONFIG not found in ppm.xml"
  16.       unless $tree->[0] eq 'PPMCONFIG';
  17.     $tree = $tree->[1];
  18.  
  19.     my $parse_elem = sub {
  20.         my $ref = shift;
  21.         my $tree = shift;
  22.         my $key = shift;
  23.         my $req = shift;
  24.         my $content = shift; $content = 2 unless defined $content;
  25.         my $cref = shift;
  26.         my $i;
  27.         for ($i=0; $i<@$tree; $i++) { last if $tree->[$i] eq $key }
  28.         die "error: missing $key element in ppm.xml"
  29.       if $req && $i >= @$tree;
  30.         return if $i >= @$tree;
  31.         $cref->($ref, $key, $content, $tree->[$i+1]) if $cref;
  32.         $ref->{$key} = $tree->[$i+1][$content] unless $cref;
  33.     };
  34.  
  35.     my $parse_attr = sub {
  36.         my $ref = shift;
  37.         my $tree = shift;
  38.         my $key = shift;
  39.         my $req = shift;
  40.         my $keephash = shift;
  41.         my $cref = shift;
  42.         die "error: missing $key attribute in ppm.xml" 
  43.           if $req && not exists $tree->[0]{$key};
  44.         $cref->($ref, $key, $keephash, $tree->[0]{$key}) if $cref;
  45.         $ref->{$key} = $keephash ? $tree->[0] : $tree->[0]{$key} unless $cref;
  46.     };
  47.  
  48.     $inst->{PPMPRECIOUS} = [];
  49.     $parse_elem->($inst, $tree, 'PPMPRECIOUS', 0);
  50.     for (split ';', $inst->{PPMPRECIOUS}) {
  51.     push @{$inst->{precious}}, $_;
  52.     }
  53.     delete $inst->{PPMPRECIOUS};
  54.  
  55.     for (my $i=0; $i<@$tree; $i++) {
  56.     my $k = $tree->[$i];
  57.     my $v = $tree->[$i+1];
  58.     if ($k eq 'OPTIONS') {
  59.         my $tmp = $^O eq 'MSWin32' ? 'C:\Temp' : '/tmp';
  60.         my @opts = qw(BUILDDIR DOWNLOADSTATUS REBUILDHTML);
  61.         @$conf{@opts} = ($tmp, 16384, 0);
  62.         $parse_attr->($conf, $v, 'BUILDDIR', 0);
  63.         $parse_attr->($conf, $v, 'DOWNLOADSTATUS', 0);
  64.         $parse_attr->($conf, $v, 'REBUILDHTML', 0);
  65.         @$conf{qw(tempdir downloadbytes rebuildhtml)} = @$conf{@opts};
  66.         delete @$conf{@opts};
  67.  
  68.         $cmd->{IGNORECASE} = 1;
  69.         $parse_attr->($cmd, $v, 'IGNORECASE', 0);
  70.         $cmd->{'case-sensitivity'} = $cmd->{IGNORECASE} ? '0' : '1';
  71.         delete $cmd->{IGNORECASE};
  72.  
  73.         $inst->{ROOT} = '';
  74.         $parse_attr->($inst, $v, 'ROOT', 0);
  75.         $inst->{root} = $inst->{ROOT} if $inst->{ROOT};
  76.         delete $inst->{ROOT};
  77.  
  78.         $parse_attr->($extra, $v, 'CLEAN', 0);
  79.         $parse_attr->($extra, $v, 'CONFIRM', 0);
  80.         $parse_attr->($extra, $v, 'FORCEINSTALL', 0);
  81.         $parse_attr->($extra, $v, 'MORE', 0);
  82.         $parse_attr->($extra, $v, 'TRACE', 0);
  83.         $parse_attr->($extra, $v, 'TRACEFILE', 0);
  84.         $parse_attr->($extra, $v, 'VERBOSE', 0);
  85.     }
  86.     elsif ($k eq 'PLATFORM') {
  87.         @$inst{qw(CPU OSVALUE OSVERSION)} = ('x86', $^O, '0,0,0,0');
  88.         $parse_attr->($inst, $v, 'CPU', 0);
  89.         $parse_attr->($inst, $v, 'OSVALUE', 1);
  90.         $parse_attr->($inst, $v, 'OSVERSION', 0);
  91.     }
  92.     elsif ($k eq 'REPOSITORY') {
  93.         my %r;
  94.         $parse_attr->(\%r, $v, 'LOCATION', 1);
  95.         $parse_attr->(\%r, $v, 'NAME', 1);
  96.         $parse_attr->(\%r, $v, 'USERNAME', 0);
  97.         $parse_attr->(\%r, $v, 'PASSWORD', 0);
  98.         fix_location(\$r{LOCATION});
  99.         
  100.         $reps->{$r{NAME}} = {
  101.         url => $r{LOCATION},
  102.         (defined $r{USERNAME} ? (username => $r{USERNAME}) : ()),
  103.         (defined $r{PASSWORD} ? (password => $r{PASSWORD}) : ()),
  104.         };
  105.     }
  106.     elsif ($k eq 'PACKAGE') {
  107.         my %r;
  108.         $parse_attr->(\%r, $v, 'NAME', 1);
  109.         $parse_elem->(\%r, $v, 'LOCATION', 1);
  110.         $parse_elem->(\%r, $v, 'INSTPACKLIST', 1);
  111.         $parse_elem->(\%r, $v, 'INSTROOT', 1);
  112.         $parse_elem->(\%r, $v, 'INSTDATE', 1);
  113.         fix_location(\$r{LOCATION});
  114.  
  115.         # Regenerates the PPD: I wish XML::Parser could do this...
  116.         my $cb = sub {
  117.         my ($ref, $key, $index, $tree) = @_;
  118.         my $i;
  119.         for ($i=0; $i<@$tree; $i++) { last if $tree->[$i] eq 'SOFTPKG' }
  120.             my $ppd = generate_ppd($tree->[$i], $tree->[$i+1]);
  121.         $ref->{ppd} = $ppd if $ppd;
  122.         };
  123.         $parse_elem->(\%r, $v, 'INSTPPD', 1, 2, $cb);
  124.         next if ($r{NAME} eq 'libwin32' and $^O ne 'MSWin32');
  125.         $inst->{$r{NAME}} = \%r;
  126.     }
  127.     }
  128. }
  129.  
  130. sub repository {
  131.     my $rep  = shift;
  132.     my $ver = $^V ? sprintf("%vd", substr($^V,0,2)) : $];
  133.  
  134.     my $ppm3 = "http://ppm.ActiveState.com/PPM/ppmserver%s.plex?urn:/PPM/Server/SQL";
  135.     my $ppm2 = "http://ppm.ActiveState.com/cgibin/PPM/ppmserver%s.pl?urn:/PPMServer";
  136.     my $www  = "http://ppm.ActiveState.com/PPMPackages/%s";
  137.  
  138.     my $verplat1 = "";
  139.     my $verplat2 = $ver;
  140.  
  141.     if ($^V and $^V ge v5.8.0) {
  142.     my %osmap = (MSWin32 => "windows");
  143.     my $plat = $osmap{$^O} || $^O;
  144.     $verplat1 = "-$ver-$plat";
  145.     $verplat2 = "$ver-$plat";
  146.     }
  147.     my %reps = (
  148.     ppm3 => sprintf($ppm3, $verplat1),
  149.     ppm2 => sprintf($ppm2, $verplat1),
  150.     www  => sprintf($www, $verplat2),
  151.     );
  152.     return $reps{$rep};
  153. }
  154.  
  155. sub fix_location {
  156.     my $ref = shift;
  157.     if ($$ref =~ m{^soap://}i and $$ref =~ m{ActiveState}) {
  158.     $$ref = repository('www');
  159.     }
  160.     $$ref =~ s{soap://}{http://}i;
  161.     if ($$ref =~ m[ActiveState.com/cgibin/PPM/ppmserver.pl\?]i) {
  162.     $$ref = repository('ppm3');
  163.     }
  164. }
  165.  
  166. sub generate_ppd {
  167.     my $tagname = shift;
  168.     my $tree    = shift;
  169.     my $ppd     = _generate_ppd($tagname, $tree);
  170.     return qq{<?xml version="1.0" encoding="UTF-8"?>\n$ppd};
  171. }
  172. sub _generate_ppd {
  173.     my $tagname = shift;
  174.     my $tree    = shift;
  175.     return undef unless $tagname;
  176.     my @lines;
  177.     my $line = '<' . $tagname;
  178.     if (%{$tree->[0] || {}}) {
  179.     for my $key (keys %{$tree->[0]}) {
  180.         my $val = $tree->[0]{$key};
  181.         $line .= qq{ $key="$val"};
  182.     }
  183.     }
  184.     $line .= '>';
  185.     $line .= xml_encode(ref($tree->[2]) ? "\n" : $tree->[2]);
  186.     push @lines, $line;
  187.     my $start = ref($tree->[2]) ? 1 : 3;
  188.     for (my $j=$start; $j<@$tree; $j++) {
  189.         next unless $tree->[$j] =~ /^[A-Z]+$/;
  190.     push @lines, _generate_ppd($tree->[$j], $tree->[$j+1]);
  191.     }
  192.     push @lines, "</$tagname>\n";
  193.     wantarray ? @lines : join '', @lines;
  194. }
  195.  
  196. sub xml_encode {
  197.     local $_ = shift || '';
  198.     s/&/&/g;
  199.     s/</</g;
  200.     s/>/>/g;
  201.     $_;
  202. }
  203.  
  204. sub batchify {
  205.     my $exe = shift;
  206.     my $perl = shift || $^X;
  207.     my $batch = $exe;
  208.     $batch =~ s/\.PL$//;
  209.     $batch =~ s/\.pl$//;
  210.     if ($^O eq 'MSWin32') {
  211.         $batch .= '.bat';
  212.     }
  213.     # A bug in system() forces us to convert $exe to an 8.3 pathname on
  214.     # Windows. Presumably there is no workaround in Unix.
  215.     if ($^O eq 'MSWin32') {
  216.         require Win32;
  217.         $exe = Win32::GetShortPathName($exe);
  218.     }
  219.     system($perl, $exe, @_);
  220.     unlink($exe) || die "can't delete $exe: $!";
  221.     return $batch;
  222. }
  223.  
  224.