home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _55d191448473a0c6b7974214a1de5c59 < prev    next >
Encoding:
Text File  |  2004-06-01  |  10.7 KB  |  428 lines
  1. #=============================================================================
  2. # Package: PPM::PPD
  3. # Purpose: Exposes a simple, object-oriented interfaces to PPDs.
  4. # Notes:
  5. # Author:  Neil Watkiss
  6. #=============================================================================
  7. package PPM::PPD;
  8.  
  9. use strict;
  10. use Data::Dumper;
  11. use XML::Simple ();
  12.  
  13. $PPM::PPD::VERSION = '3.05';
  14.  
  15. sub new {
  16.     my $this = shift;
  17.     my $ppd  = shift;
  18.     my $rep  = shift;    # the repository object that retrieved this PPD
  19.     my $id   = shift;    # the unique key in the repository of this PPD
  20.     die "Error: PPM::PPD constructor called with undef ppd\n" .
  21.       Dumper(caller(0))
  22.         unless defined $ppd;
  23.     my $class = ref($this) || $this;
  24.     my $self = bless {
  25.     rep => $rep,
  26.     id  => $id,
  27.     from => 'unknown',
  28.     }, $class;
  29.     $self->init($ppd);
  30.     return $self;
  31. }
  32.  
  33. sub repository {
  34.     my $o = shift;
  35.     $o->{rep};
  36. }
  37. sub id {
  38.     my $o = shift;
  39.     $o->{id};
  40. }
  41.  
  42. # Whenever PPM::Repository or a subclass creates a PPM::PPD object, it sets
  43. # 'from' to "Repository". This allows the client to decide whether a PPM::PPD
  44. # object is the result of a query, a search, or a describe. Etc.
  45. sub from {
  46.     my $o = shift;
  47.     $o->{from};
  48. }
  49.  
  50. sub is_complete {
  51.     my $o = shift;
  52.     $o->{is_complete};
  53. }
  54.  
  55. sub find_impl_raw {
  56.     my $o = shift;
  57.     my $target = shift;
  58.     for my $impl ($o->implementations) {
  59.     my $match = 1;
  60.     for my $field (keys %$impl) {
  61.         next if ref($impl->{$field});
  62.         my $value = $target->config_get($field);
  63.         if ($value && ref($value) && eval { $value->isa("PPM::Result") }) {
  64.         next unless $value->is_success;
  65.         $match &&= ($value->result eq $impl->{$field});
  66.         }
  67.         else {
  68.         next unless defined $value;
  69.         $match &&= ($value eq $impl->{$field});
  70.         }
  71.     }
  72.     return $impl if $match == 1;
  73.     }
  74.     return undef;
  75. }
  76.  
  77. sub find_impl {
  78.     my $o = shift;
  79.     my $target = shift;
  80.     my $impl = $o->find_impl_raw($target);
  81.     # We must not 'use' this, because the ppminst code also uses PPM::PPD, and
  82.     # it doesn't have PPM::Result available.
  83.     require PPM::Result;
  84.     return PPM::Result::Ok($impl) if $impl;
  85.     PPM::Result::Error("no suitable implementation found for '"
  86.                . $o->name . "'.");
  87. }
  88.  
  89. sub name {
  90.     my $o = shift;
  91.     my $r = $o->{parsed}{NAME};
  92.     return defined $r ? $r : "";
  93. }
  94.  
  95. sub title {
  96.     my $o = shift;
  97.     my $r = $o->{parsed}{TITLE};
  98.     return defined $r ? $r : "";
  99. }
  100.  
  101. sub version_osd {
  102.     my $o = shift;
  103.     my $r = $o->{parsed}{VERSION};
  104.     return defined $r ? $r : "";
  105. }
  106.  
  107. sub version {
  108.     my $o = shift;
  109.     my $v = $o->version_osd;
  110.     printify($v);
  111. }
  112.  
  113. sub printify {
  114.     my $v = shift;
  115.     $v =~ s/(?:[\.,]0)*$//;
  116.     $v .= '.0' unless ($v =~ /[\.,]/ or $v eq '');
  117.     $v = "(any version)" if $v eq '';
  118.     $v =~ tr/,/./;
  119.     $v;
  120. }
  121.  
  122. # This sub returns 1 if $ver is >= to $o->version. It returns 0 otherwise.
  123. # Note: this is only used if the repository doesn't know how to compare
  124. # version numbers. The PPM3Server knows how to do it, the others don't.
  125. sub uptodate {
  126.     my $o = shift;
  127.     my $ver = shift;
  128.  
  129.     return 1 if $ver eq $o->version_osd; # shortcut
  130.  
  131.     my @required = split /[\.,]/, $o->version_osd;
  132.     my @proposed = split /[\.,]/, $ver;
  133.  
  134.     for (my $i=0; $i<@required; $i++) {
  135.     no warnings;
  136.     return 0 if $proposed[$i] < $required[$i];    # too old
  137.     return 1 if $proposed[$i] > $required[$i];    # even newer
  138.     }
  139.     return 1; # They're equal
  140. }
  141.  
  142. sub abstract {
  143.     my $o = shift;
  144.     my $r = $o->{parsed}{ABSTRACT};
  145.     return defined $r ? $r : "";
  146. }
  147.  
  148. sub author {
  149.     my $o = shift;
  150.     my $r = $o->{parsed}{AUTHOR};
  151.     return defined $r ? $r : "";
  152. }
  153.  
  154. sub implementations {
  155.     my $o = shift;
  156.     return @{$o->{parsed}{IMPLEMENTATION} || []};
  157. }
  158.  
  159. sub ppd {
  160.     my $o = shift;
  161.     return $o->{ppd};
  162. }
  163.  
  164. sub init {
  165.     my $o = shift;
  166.     my $ppd = shift;
  167.  
  168.     if ($ppd =~ /<SOFTPKG/) {
  169.     $o->{ppd} = $ppd;
  170.     $o->{source} = caller;
  171.     }
  172.     elsif ($ppd !~ m![\n]! && -f $ppd) {
  173.     $o->loadfile($ppd);
  174.     $o->{source} = $ppd;
  175.     }
  176.     else {
  177.     die "PPM::PPD::init: not a PPD and not a file:\n$ppd";
  178.     }
  179.  
  180.     $o->parse;
  181. }
  182.  
  183. sub loadfile {
  184.     my $o = shift;
  185.     my $file = shift;
  186.     open FILE, $file        || die "can't read $file: $!";
  187.     $o->{ppd} = do { local $/; <FILE> };
  188.     close FILE            || die "can't close $file: $!";
  189. }
  190.  
  191. sub parse {
  192.     my $o = shift;
  193.     my $parser = XML::Simple->new(
  194.     forcearray    => 1,
  195.     forcecontent    => 1,
  196.     keyattr        => [],
  197.     suppressempty    => undef,
  198.     );
  199.     my $tree = eval { $parser->XMLin($o->{ppd}) };
  200.     die "error: can't parse $o->{ppd}: $@" if $@;
  201.  
  202.     # First: SOFTPKG attributes:
  203.     $o->{parsed}{NAME}        = $o->conv($tree->{NAME});
  204.     $o->{parsed}{VERSION}    = $o->conv($tree->{VERSION});
  205.  
  206.     # Next: childless elements:
  207.     $o->{parsed}{ABSTRACT}    = $o->conv($tree->{ABSTRACT}[0]{content});
  208.     $o->{parsed}{AUTHOR}    = $o->conv($tree->{AUTHOR}[0]{content});
  209.     $o->{parsed}{TITLE}        = $o->conv($tree->{TITLE}[0]{content});
  210.  
  211.     # Next: IMPLEMENTATION:
  212.     my @impls;
  213.     for my $impl (@{$tree->{IMPLEMENTATION}}) {
  214.     my $i = PPM::PPD::Implementation->new({});
  215.     for my $key (keys %$impl) {
  216.         # Next: DEPENDENCY:
  217.         if ($key eq 'DEPENDENCY') {
  218.         my @deps = @{$impl->{$key}};
  219.         $i->{DEPENDENCY} = 
  220.           [map { PPM::PPD::Dependency->new($_) } @deps];
  221.         next;
  222.         }
  223.         # Next: LANGUAGE:
  224.         if ($key eq 'LANGUAGE') {
  225.         my $v = $impl->{$key}[0];
  226.         my $lang = {
  227.             NAME    => $o->conv($v->{NAME}),
  228.             VERSION    => $o->conv(
  229.             $v->{COMPAT}[0]{VERSION} || $v->{VERSION}
  230.             ),
  231.             TYPE    => $o->conv($v->{COMPAT}[0]{TYPE}),
  232.         };
  233.         $i->{LANGUAGE} = PPM::PPD::Language->new($lang);
  234.         next;
  235.         }
  236.         # Next: INSTALL or UNINSTALL.
  237.         if ($key eq 'INSTALL' or $key eq 'UNINSTALL') {
  238.         my $v = $impl->{$key}[0];
  239.         $i->{"${key}_SCRIPT"} = PPM::PPD::Script->new({
  240.             EXEC    => $o->conv($v->{EXEC}),
  241.             HREF    => $o->conv($v->{HREF}),
  242.             SCRIPT    => $o->conv($v->{content}),
  243.         });
  244.         }
  245.         # Next: CODEBASE, OS, OSVERSION, etc.
  246.         my @keys = qw(NAME VALUE);
  247.         push @keys, qw(HREF) if $key eq 'CODEBASE';
  248.         for (@keys) {
  249.         next unless exists $impl->{$key}[0]{$_};
  250.         $i->{$key} = $o->conv($impl->{$key}[0]{$_});
  251.         last;
  252.         }
  253.     }
  254.     push @impls, $i;
  255.     }
  256.     $o->{parsed}{IMPLEMENTATION} = \@impls;
  257.     $o->{is_complete} = @impls;
  258. }
  259.  
  260. sub conv {
  261.     use Unicode::String qw(utf8);
  262.     my $o = shift;
  263.     my $u = utf8(shift(@_) || '');
  264.     my $use_utf8 = 0;
  265.     for my $env (qw(LC_ALL LC_CTYPE LANG PPM_LANG)) {
  266.     $use_utf8 = 1, last if $ENV{$env} and $ENV{$env} =~ /UTF-8/;
  267.     }
  268.     # silence "Data outside latin1 range" warnings
  269.     local $SIG{__WARN__} = sub {};
  270.     $u->stringify_as('latin1') unless $use_utf8;
  271.     "$u";
  272. }
  273.  
  274. package PPM::PPD::Base;
  275.  
  276. sub new {
  277.     my $cls = shift;
  278.     my $obj = shift;
  279.     bless $obj, $cls;
  280. }
  281.  
  282. sub AUTOLOAD {
  283.     my $method = $PPM::PPD::Base::AUTOLOAD;
  284.     $method =~ s/^.+:://;
  285.     my $o = shift;
  286.     my $r = $o->{uc($method)};
  287.     defined $r ? $r : '';
  288. }
  289.  
  290. sub version_printable { die }
  291. sub osversion_printable { die }
  292.  
  293. #=============================================================================
  294. # PPM::PPD::Implementation.
  295. # Exposes the following methods:
  296. #
  297. # architecture
  298. # codebase
  299. # os
  300. # osversion_osd
  301. # osversion
  302. # perlcore
  303. # install_script
  304. # uninstall_script
  305. # pythoncore
  306. # 
  307. # prereqs    # returns a list of PPM::PPD::Dependency objects
  308. # language    # returns a PPM::PPD::Language object
  309. #=============================================================================
  310. package PPM::PPD::Implementation;
  311. our @ISA = qw(PPM::PPD::Base);
  312.  
  313. sub osversion_osd {
  314.     my $o = shift;
  315.     my $r = $o->{OSVERSION};
  316.     defined $r ? $r : '';
  317. }
  318.  
  319. sub osversion {
  320.     my $o = shift;
  321.     my $r = $o->osversion_osd;
  322.     PPM::PPD::printify($r);
  323. }
  324.  
  325. sub prereqs {
  326.     my $o = shift;
  327.     return @{$o->{DEPENDENCY} || []};
  328. }
  329.  
  330. sub language {
  331.     my $o = shift;
  332.     $o->{LANGUAGE};
  333. }
  334.  
  335. #=============================================================================
  336. # PPM::PPD::Script
  337. # Exposes the following methods:
  338. #
  339. # exec            # a shell/interpreter to use to run the script
  340. # href            # a script to download
  341. # script        # the content of the script (if href not specified)
  342. #=============================================================================
  343. package PPM::PPD::Script;
  344. our @ISA = qw(PPM::PPD::Base);
  345.  
  346. #=============================================================================
  347. # PPM::PPD::Language.
  348. # Exposes the following methods:
  349. #
  350. # name
  351. # version        # no OSD version for LANGUAGE tag
  352. # type            # one of 'SYNTAX' or 'BINARY'
  353. #
  354. # matches_target($target)    # returns 1 if $target can install PPD, else 0
  355. #=============================================================================
  356. package PPM::PPD::Language;
  357. our @ISA = qw(PPM::PPD::Base);
  358.  
  359. sub matches_target {
  360.     my $o = shift;
  361.     my $t = shift;
  362.     $t->can_install($o->name, $o->version, $o->type);
  363. }
  364.  
  365. #=============================================================================
  366. # PPM::PPD::Dependency.
  367. # Exposes the following methods:
  368. #
  369. # name
  370. # version
  371. # version_osd
  372. # 
  373. # uptodate($ppd)    # returns 1 if the given PPM::PPD object satisfies the
  374. #             # dependency, or 0 otherwise.
  375. #=============================================================================
  376. package PPM::PPD::Dependency;
  377. our @ISA = qw(PPM::PPD::Base);
  378.  
  379. sub version_osd {
  380.     my $o = shift;
  381.     my $r = $o->{VERSION};
  382.     defined $r ? $r : '';
  383. }
  384.  
  385. sub version {
  386.     goto &PPM::PPD::version;
  387. }
  388.  
  389. sub uptodate {
  390.     goto &PPM::PPD::uptodate;
  391. }
  392.  
  393. package PPM::PPD::Search;
  394. @PPM::PPD::Search::ISA = 'PPM::Search';
  395.  
  396. use Data::Dumper;
  397.  
  398. sub matchimpl {
  399.     my $self = shift;
  400.     my ($impl, $field, $re) = @_;
  401.     if ($field eq 'OS')            { return $impl->os =~ $re }
  402.     elsif ($field eq 'OSVERSION')    { return $impl->osversion =~ $re }
  403.     elsif ($field eq 'ARCHITECTURE')    { return $impl->architecture =~ $re}
  404.     elsif ($field eq 'CODEBASE')    { return $impl->codebase =~ $re }
  405.     elsif ($field eq 'PYTHONCORE')    { return $impl->pythoncore =~ $re }
  406.     elsif ($field eq 'PERLCORE')    { return $impl->perlcore =~ $re }
  407.     else {
  408.     warn "unknown search field '$field'" if $^W;
  409.     }
  410. }
  411.  
  412. sub match {
  413.     my $self = shift;
  414.     my ($ppd, $field, $match) = @_;
  415.     my $re = qr/$match/;
  416.     $field = uc($field);
  417.     if ($field eq 'NAME')     { return $ppd->name =~ $re }
  418.     if ($field eq 'AUTHOR')      { return $ppd->author =~ $re }
  419.     if ($field eq 'ABSTRACT')    { return $ppd->abstract =~ $re }
  420.     if ($field eq 'TITLE')       { return $ppd->title =~ $re }
  421.     if ($field eq 'VERSION')     { return $ppd->version_printable =~ $re }
  422.     return (grep { $_ }
  423.         map { $self->matchimpl($_, $field, $re) }
  424.         $ppd->implementations);
  425. }
  426.  
  427. 1;
  428.