home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _567bb08195098bf74c78d591715500f4 < prev    next >
Text File  |  2004-06-01  |  3KB  |  97 lines
  1. package PPM::Repository::Local;
  2.  
  3. use strict;
  4. use PPM::PPD;
  5. use PPM::Search;
  6. use PPM::Result qw(Ok Warning Error List);
  7. use URI; # not actually needed -- that base class requires it.
  8. use Cwd qw(cwd);
  9.  
  10. use Data::Dumper;
  11.  
  12. use base qw(PPM::Repository::WWW);
  13. use vars qw($VERSION);
  14. $VERSION = '3.05';
  15.  
  16. sub init {
  17.     my $o = shift;
  18.  
  19.     # $o->{location} is set to what the base class thinks is a local
  20.     # directory. Verify that it is an existing directory, then set up a URL
  21.     # for searching through it.
  22.     $o->{errmsg}=<<END and return unless -d $o->{location};
  23. Can't initialize repository at '$o->{location}': $!
  24. END
  25.  
  26.     # $o->{location} is a directory!
  27.     my $d = $o->{dir} = $o->{location};
  28.  
  29.     # Now, try to create a URL for it, so we can use the base class' search
  30.     # methods. We also need it for "absolutizing" the PPM package locations:
  31.     my $url = URI->new;
  32.     $url->scheme('file');
  33.  
  34.     if ($^O eq 'MSWin32') {
  35.     $d =~ s#\\#/#g; # make the regular expressions tolerable
  36.  
  37.     # UNC path:
  38.     if ($d =~ m#^//([^/]+)/(.*)#) {
  39.         my ($host, $path) = ($1, $2);
  40.         $url->host($host);
  41.         $url->path($path);
  42.     }
  43.  
  44.     # Pathname with drive letter:
  45.     elsif ($d =~ m#^[A-Z]:/#i) {
  46.         $d =~ s/:/|/; # replace the drive's colon with a pipe. Weird.
  47.         $url->host('localhost');
  48.         $url->path($d);
  49.     }
  50.  
  51.     # other cases will be caught be the non-windows cases.
  52.     }
  53.  
  54.     unless ($url->path) {
  55.     # Make sure it's absolute by prepending $cwd to it:
  56.     if ($d !~ m#^/#) {
  57.         my $cwd = cwd;
  58.  
  59.         # Fixup the drive letter and backslashes on Windows:
  60.         if ($^O eq 'MSWin32') {
  61.         $o->{location} = $o->{dir} = "$cwd/$o->{dir}";
  62.         $cwd =~ s#^([A-Z]):#$1|#;
  63.         $cwd =~ s#\\#/#g;
  64.         }
  65.         else {
  66.         $o->{location} = $o->{dir} = "$cwd\\$o->{dir}";
  67.         }
  68.  
  69.         chop $cwd if substr($cwd, -1) eq '/';
  70.         $d = "$cwd/$d";
  71.         }
  72.  
  73.     $url->host('localhost');
  74.     $url->path($d);
  75.     }
  76.     $o->{url} = $o->{url_base} = $url;
  77.     $o->{url_base} .= '/' unless $o->{url_base} =~ m#/$#;
  78.     1;
  79. }
  80.  
  81. sub describe {
  82.     my $o = shift;
  83.     my $target = shift;
  84.     my $pkg = shift;
  85.     return Ok($o->{ppds}{$pkg})
  86.     if exists $o->{ppds}{$pkg} and $o->{ppds}{$pkg}->is_complete;
  87.     my $file = $o->{dir} =~ m,[\\/]$, ? "$o->{dir}$pkg" : "$o->{dir}/$pkg";
  88.     $file .= ".ppd" unless $file =~ /\.ppd$/i;
  89.     return Error("Package '$pkg' not found. Please 'search' for it first.")
  90.         unless -f $file;
  91.     $o->{ppds}{$pkg} = PPM::PPD->new($file, $o, $pkg);
  92.     $o->{ppds}{$pkg}{from} = 'repository';
  93.     Ok($o->{ppds}{$pkg});
  94. }
  95.  
  96. sub type_printable { "Local directory" }
  97.