lib/Sepia/CPAN.pm

   1 package Sepia::CPAN;
   2 use CPAN ();
   3
   4 sub init
   5 {
   6       CPAN::HandleConfig->load;
   7       CPAN::Shell::setup_output;
   8       CPAN::Index->reload;
   9 }
  10
  11 sub interesting_parts
  12 {
  13     my $mod = shift;
  14     # XXX: stupid CPAN.pm functions die for some modules...
  15     +{ map {
  16         $_ => scalar eval { $mod->$_ }
  17     } qw(id cpan_version inst_version fullname cpan_file)};
  18 }
  19
  20 # Only list the "root" module of each package, meaning either (1) the
  21 # module matching the dist name or (2) the module with the shortest
  22 # name, whichever comes first.
  23
  24 # XXX: this is hacky.
  25 sub group_by_dist
  26 {
  27     my %h;
  28     for (@_) {
  29         my $cf = $_->{cpan_file};
  30         if (!exists $h{$cf}) {
  31             $h{$_->{cpan_file}} = $_;
  32         } else {
  33             (my $tmp = $cf) =~ s/-/::/g;
  34             if ($tmp =~ /^\Q$h{$cf}{id}\E/) {
  35                 next;           # already perfect
  36             } elsif ($tmp =~ /^\Q$_->{id}\E/) {
  37                 $h{$cf} = $_;   # perfect
  38             } # elsif (length $h{$cf}{id} > length $_->{id}) {
  39             #     $h{$cf} = $_;   # short, at least...
  40             # }
  41         }
  42     }
  43     sort { $a->{id} cmp $b->{id} } values %h;
  44 }
  45
  46 sub _list
  47 {
  48     CPAN::Shell->expand('Module', shift || '/./');
  49 }
  50
  51 sub list
  52 {
  53     group_by_dist map { interesting_parts $_ } _list @_
  54 }
  55
  56 sub _ls
  57 {
  58     my $want = shift;
  59     grep {
  60         # XXX: key to test in this order, because inst_file is slow.
  61         $_->userid eq $want
  62     } CPAN::Shell->expand('Module', '/./')
  63 }
  64
  65 sub ls
  66 {
  67     group_by_dist map { interesting_parts $_ } _ls @_
  68 }
  69
  70 sub _desc
  71 {
  72     my $pat = qr/$_[0]/i;
  73     grep {
  74         $_->description &&
  75         ($_->description =~ /$pat/ || $_->id =~ /$pat/)
  76     } CPAN::Shell->expand('Module', '/./');
  77 }
  78
  79 sub desc
  80 {
  81     group_by_dist map { interesting_parts $_ } _desc @_;
  82 }
  83
  84 sub outdated
  85 {
  86     grep !$_->uptodate, list @_;
  87 }
  88
  89 ## stolen from CPAN::Shell...
  90 sub readme
  91 {
  92     my $dist = CPAN::Shell->expand('Module', shift);
  93     return unless $dist;
  94     my $wantfile = shift;
  95     $dist = $dist->cpan_file;
  96     # my ($dist) = $self->id;
  97     my ($sans, $suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
  98     my ($local_file);
  99     my ($local_wanted) = File::Spec->catfile(
 100         $CPAN::Config->{keep_source_where}, "authors", "id",
 101         split(/\//,"$sans.readme"));
 102     $local_file = CPAN::FTP->localize("authors/id/$sans.readme", $local_wanted);
 103     ## Return filename rather than contents to avoid Elisp reader issues...
 104     if ($wantfile) {
 105         $local_file;
 106     } else {
 107         local (*IN, $/);
 108         open IN, $local_wanted;
 109         my $ret = <IN>;
 110         close IN;
 111         $ret;
 112     }
 113 }
 114
 115 sub perldoc
 116 {
 117     eval { use LWP::Simple; };
 118     if ($@) {
 119         print STDERR "Can't get perldocs: LWP::Simple not installed.\n";
 120         "Can't get perldocs: LWP::Simple not installed.\n";
 121     } else {
 122         *perldoc = sub { get($CPAN::Defaultdocs . shift) };
 123         goto &perldoc;
 124     }
 125 }
 126
 127 sub install
 128 {
 129     my $dist = CPAN::Shell->expand('Module', shift);
 130     $dist->install if $dist;
 131 }
 132
 133 # Based on CPAN::Shell::_u_r_common
 134 sub _recommend
 135 {
 136     my $pat = shift || '/./';
 137     my (@result, %seen, %need);
 138     $version_undefs = $version_zeroes = 0;
 139     for my $module (CPAN::Shell->expand('Module',$pat)) {
 140         my $file  = $module->cpan_file;
 141         next unless defined $file && $module->inst_file;
 142         $file =~ s!^./../!!;
 143         my $latest = $module->cpan_version;
 144         my $have = $module->inst_version;
 145         local ($^W) = 0;
 146         next unless CPAN::Version->vgt($latest, $have);
 147         push @result, $module;
 148         next if $seen{$file}++;
 149         $need{$module->id}++;
 150     }
 151     @result;
 152 }
 153
 154 sub recommend
 155 {
 156     group_by_dist map { interesting_parts $_ } _recommend @_;
 157 }
 158
 159 1;