cpan/cpan-lib.pl

   1 # cpan-lib.pl
   2 # Functions for getting information about perl modules
   3
   4 BEGIN { push(@INC, ".."); };
   5 use WebminCore;
   6 &init_config();
   7 use Config;
   8 $packages_file = "$module_config_directory/packages.txt.gz";
   9 $available_packages_cache = "$module_config_directory/available-cache";
  10
  11 # Get the paths to perl and perldoc
  12 $perl_path = &get_perl_path();
  13 if (&has_command("perldoc")) {
  14         $perl_doc = &has_command("perldoc");
  15         }
  16 else {
  17         $perl_path =~ /^(.*)\/[^\/]+$/;
  18         if (-x "$1/perldoc") {
  19                 $perl_doc = "$1/perldoc";
  20                 }
  21         }
  22 if ($perl_doc && $] >= 5.006) {
  23         $perl_doc = "$perl_path -T $perl_doc";
  24         }
  25
  26 # list_perl_modules([master-name])
  27 # Returns a list of all installed perl modules, by reading .packlist files
  28 sub list_perl_modules
  29 {
  30 local ($limit) = @_;
  31 local (@rv, %done, $d, %donedir, %donemod);
  32 foreach $d (&expand_usr64($Config{'privlib'}),
  33             &expand_usr64($Config{'sitelib_stem'} ? $Config{'sitelib_stem'} :
  34                                                     $Config{'sitelib'}),
  35             &expand_usr64($Config{'sitearch_stem'} ? $Config{'sitearch_stem'} :
  36                                                     $Config{'sitearch'}),
  37             &expand_usr64($Config{'vendorlib_stem'} ? $Config{'vendorlib_stem'} :
  38                                                       $Config{'vendorlib'}),
  39             &expand_usr64($Config{'installprivlib'})) {
  40         next if (!$d);
  41         next if ($donedir{$d});
  42         local $f;
  43         open(FIND, "find ".quotemeta($d)." -name .packlist -print |");
  44         print STDERR "find ".quotemeta($d)." -name .packlist -print\n";
  45         while($f = <FIND>) {
  46                 chop($f);
  47                 local @st = stat($f);
  48                 next if ($done{$st[0],$st[1]}++);
  49                 local @st = stat($f);
  50                 local $mod = { 'date' => scalar(localtime($st[9])),
  51                                'time' => $st[9],
  52                                'packfile' => $f,
  53                                'index' => scalar(@rv) };
  54                 $f =~ /\/(([A-Z][^\/]*\/)*[^\/]+)\/.packlist$/;
  55                 $mod->{'name'} = $1;
  56                 $mod->{'name'} =~ s/\//::/g;
  57                 next if ($limit && $mod->{'name'} ne $limit);
  58                 next if ($donemod{$mod->{'name'}}++);
  59
  60                 # Add the files in the .packlist
  61                 local (%donefile, $l);
  62                 open(FILE, $f);
  63                 while($l = <FILE>) {
  64                         chop($l);
  65                         $l =~ s/^\/tmp\/[^\/]+//;
  66                         $l =~ s/^\/var\/tmp\/[^\/]+//;
  67                         next if ($donefile{$l}++);
  68                         if ($l =~ /\/((([A-Z][^\/]*\/)([^\/]+\/)?)?[^\/]+)\.pm$/) {
  69                                 local $mn = $1;
  70                                 $mn =~ s/\//::/g;
  71                                 push(@{$mod->{'mods'}}, $mn);
  72                                 push(@{$mod->{'files'}}, $l);
  73                                 }
  74                         elsif ($l =~ /^([^\/]+)\.pm$/) {
  75                                 # Module name only, with no path! Damn redhat..
  76                                 local @rpath;
  77                                 open(FIND2, "find ".quotemeta($d).
  78                                             " -name '$l' -print |");
  79                                 print STDERR "find ".quotemeta($d).
  80                                             " -name '$l' -print\n";
  81                                 while(<FIND2>) {
  82                                         chop;
  83                                         push(@rpath, $_);
  84                                         }
  85                                 close(FIND2);
  86                                 @rpath = sort { length($a) cmp length($b) } @rpath;
  87                                 if (@rpath) {
  88                                         $rpath[0] =~ /\/(([A-Z][^\/]*\/)*[^\/]+)\.pm$/;
  89                                         local $mn = $1;
  90                                         $mn =~ s/\//::/g;
  91                                         push(@{$mod->{'mods'}}, $mn);
  92                                         push(@{$mod->{'files'}}, $rpath[0]);
  93                                         $mod->{'noremove'} = 1;
  94                                         $mod->{'noupgrade'} = 1;
  95                                         }
  96                                 }
  97                         push(@{$mod->{'packlist'}}, $l);
  98                         }
  99                 close(FILE);
 100                 local $mi = &indexof($mod->{'name'}, @{$mod->{'mods'}});
 101                 $mod->{'master'} = $mi < 0 ? 0 : $mi;
 102                 push(@rv, $mod) if (@{$mod->{'mods'}});
 103                 }
 104         close(FIND);
 105         }
 106
 107 # Look for RPMs or Debs for Perl modules
 108 if (&foreign_check("software") && $config{'incpackages'}) {
 109         &foreign_require("software", "software-lib.pl");
 110         if ($software::config{'package_system'} eq "rpm") {
 111                 local $n = &software::list_packages();
 112                 local $i;
 113                 for($i=0; $i<$n; $i++) {
 114                         # Create the module object
 115                         next if ($software::packages{$i,'name'} !~
 116                                  /^perl-([A-Z].*)$/ &&
 117                                  $software::packages{$i,'name'} !~
 118                                  /^([A-Z].*)-[pP]erl$/i);
 119                         local $mod = { 'index' => scalar(@rv),
 120                                        'pkg' => $software::packages{$i,'name'},
 121                                        'pkgtype' => 'rpm',
 122                                        'noupgrade' => 1,
 123                                        'version' =>
 124                                           $software::packages{$i,'version'} };
 125                         $mod->{'name'} = $1;
 126                         $mod->{'name'} =~ s/\-/::/g;
 127                         next if ($limit && $mod->{'name'} ne $limit);
 128                         next if ($donemod{$mod->{'name'}}++);
 129
 130                         # Add the files in the RPM
 131                         # XXX call rpm -ql only, avoid -V step
 132                         # XXX same for Debian
 133                         # XXX list_package_files function, returns an array
 134                         foreach my $l (&software::package_files(
 135                                         $software::packages{$i,'name'},
 136                                         $software::packages{$i,'version'})) {
 137                                 if ($l =~ /\/((([A-Z][^\/]*\/)([^\/]+\/)?)?[^\/]+)\.pm$/) {
 138                                         local $mn = $1;
 139                                         $mn =~ s/\//::/g;
 140                                         push(@{$mod->{'mods'}}, $mn);
 141                                         push(@{$mod->{'files'}}, $l);
 142                                         }
 143                                 push(@{$mod->{'packlist'}}, $l);
 144                                 if (!$mod->{'date'}) {
 145                                         local @st = stat($l);
 146                                         $mod->{'date'} = scalar(localtime($st[9]));
 147                                         $mod->{'time'} = $st[9];
 148                                         }
 149                                 }
 150
 151                         local $mi = &indexof($mod->{'name'}, @{$mod->{'mods'}});
 152                         $mod->{'master'} = $mi < 0 ? 0 : $mi;
 153                         push(@rv, $mod) if (@{$mod->{'mods'}});
 154                         }
 155                 }
 156         elsif ($software::config{'package_system'} eq "debian") {
 157                 # Look for Debian packages of Perl modules
 158                 local $n = &software::list_packages();
 159                 local $i;
 160                 for($i=0; $i<$n; $i++) {
 161                         # Create the module object
 162                         next if ($software::packages{$i,'name'} !~
 163                                  /^lib(\S+)-perl$/);
 164                         local $mod = { 'index' => scalar(@rv),
 165                                        'pkg' => $software::packages{$i,'name'},
 166                                        'pkgtype' => 'debian',
 167                                        'noupgrade' => 1,
 168                                        'version' =>
 169                                           $software::packages{$i,'version'} };
 170
 171                         # Add the files in the RPM
 172                         foreach my $l (&software::package_files(
 173                                         $software::packages{$i,'name'})) {
 174                                 if ($l =~ /\/((([A-Z][^\/]*\/)([^\/]+\/)?)?[^\/]+)\.pm$/) {
 175                                         local $mn = $1;
 176                                         $mn =~ s/\//::/g;
 177                                         push(@{$mod->{'mods'}}, $mn);
 178                                         push(@{$mod->{'files'}}, $l);
 179                                         }
 180                                 push(@{$mod->{'packlist'}}, $l);
 181                                 if (!$mod->{'date'}) {
 182                                         local @st = stat($l);
 183                                         $mod->{'date'} = scalar(localtime($st[9]));
 184                                         $mod->{'time'} = $st[9];
 185                                         }
 186                                 }
 187                         next if (!@{$mod->{'mods'}});
 188
 189                         # Work out the name
 190                         foreach my $m (@{$mod->{'mods'}}) {
 191                                 local $pn = lc($m);
 192                                 $pn =~ s/::/-/g;
 193                                 $pn = "lib".$pn."-perl";
 194                                 if ($pn eq $mod->{'pkg'}) {
 195                                         $mod->{'name'} = $m;
 196                                         last;
 197                                         }
 198                                 }
 199                         $mod->{'name'} ||= $mod->{'mods'}->[0];
 200                         next if ($limit && $mod->{'name'} ne $limit);
 201                         next if ($donemod{$mod->{'name'}}++);
 202
 203                         local $mi = &indexof($mod->{'name'}, @{$mod->{'mods'}});
 204                         $mod->{'master'} = $mi < 0 ? 0 : $mi;
 205                         push(@rv, $mod) if (@{$mod->{'mods'}});
 206                         }
 207
 208                 }
 209         }
 210
 211 return @rv;
 212 }
 213
 214 # expand_usr64(dir)
 215 # If a directory is like /usr/lib and /usr/lib64 exists, return them both
 216 sub expand_usr64
 217 {
 218 if ($_[0] =~ /^(\/usr\/lib\/|\/usr\/local\/lib\/)(.*)$/) {
 219         local ($dir, $dir64, $rest) = ($1, $1, $2);
 220         $dir64 =~ s/\/lib\//\/lib64\//;
 221         return -d $dir64 ? ( $dir.$rest, $dir64.$rest ) : ( $dir.$rest );
 222         }
 223 else {
 224         return ( $_[0] );
 225         }
 226 }
 227
 228 # module_desc(&mod, index)
 229 # Returns a one-line description for some module, and a version number
 230 sub module_desc
 231 {
 232 local ($in_name, $desc);
 233 local $f = $_[0]->{'files'}->[$_[1]];
 234 local $pf = $f;
 235 local $ver = $_[0]->{'version'};
 236 $pf =~ s/\.pm$/\.pod/;
 237 local ($got_version, $got_name);
 238 open(MOD, $pf) || open(MOD, $f);
 239 while(<MOD>) {
 240         if (/^=head1\s+name/i && !$got_name) {
 241                 $in_name = 1;
 242                 }
 243         elsif (/^=/ && $in_name) {
 244                 $got_name++;
 245                 $in_name = 0;
 246                 }
 247         elsif ($in_name) {
 248                 $desc .= $_;
 249                 }
 250         if (/^\s*(our\s+)?\$VERSION\s*=\s*"([0-9\.]+)"/ ||
 251             /^\s*(our\s+)?\$VERSION\s*=\s*'([0-9\.]+)'/ ||
 252             /^\s*(our\s+)?\$VERSION\s*=\s*([0-9\.]+)/) {
 253                 $ver = $2;
 254                 $got_version++;
 255                 }
 256         last if ($got_version && $got_name);
 257         }
 258 close(MOD);
 259 local $name = $_[0]->{'mods'}->[$_[1]];
 260 $desc =~ s/^\s*$name\s+\-\s+// ||
 261         $desc =~ s/^\s*\S*<$name>\s+\-\s+//;
 262 $desc =~ s/\$Id:.*\$//;
 263 return wantarray ? ($desc, $ver) : $desc;
 264 }
 265
 266 # download_packages_file(&callback)
 267 sub download_packages_file
 268 {
 269 $config{'packages'} =~ /^http:\/\/([^\/]+)(\/.*)$/ ||
 270         &error($text{'download_epackages'});
 271 local ($host, $page, $port) = ($1, $2, 80);
 272 if ($host =~ /^(.*):(\d+)$/) { $host = $1; $port = $2; }
 273 &http_download($host, $port, $page, $packages_file, undef, $_[0]);
 274 }
 275
 276 # remove_module(&module)
 277 # Delete some perl module, and all sub-modules
 278 sub remove_module
 279 {
 280 local ($mod) = @_;
 281 if ($mod->{'pkg'}) {
 282         &foreign_require("software", "software-lib.pl");
 283         return &software::delete_package($mod->{'pkg'});
 284         }
 285 else {
 286         unlink(@{$mod->{'packlist'}});
 287         unlink($mod->{'packfile'});
 288         return undef;
 289         }
 290 }
 291
 292 # get_recommended_modules()
 293 # Returns a list of Perl modules used by other Webmin modules
 294 sub get_recommended_modules
 295 {
 296 local (@rv, %done);
 297 foreach my $m (&get_all_module_infos()) {
 298         next if (!$m->{'cpan'});
 299         next if (!&foreign_installed($m->{'dir'}));
 300         local $mdir = &module_root_directory($m->{'dir'});
 301         next if (!-r "$mdir/cpan_modules.pl");
 302         &foreign_require($m->{'dir'}, "cpan_modules.pl");
 303         foreach my $c (&foreign_call($m->{'dir'}, "cpan_recommended")) {
 304                 if (!$done{$c}++) {
 305                         push(@rv, [ $c, $m ]);
 306                         }
 307                 }
 308         }
 309 return sort { $a->[0] cmp $b->[0] } @rv;
 310 }
 311
 312 # can_list_packaged_modules()
 313 # Returns 1 if we can install Perl modules from APT or YUM
 314 sub can_list_packaged_modules
 315 {
 316 return 0 if (!&foreign_check("software") || !$config{'incpackages'});
 317 &foreign_require("software", "software-lib.pl");
 318 return 0 if (!$software::update_system);
 319 return 1;
 320 }
 321
 322 # list_packaged_modules([refresh])
 323 # Returns a list of Perl modules that can be installed from the system's
 324 # package update service (ie YUM or APT).
 325 sub list_packaged_modules
 326 {
 327 local ($refresh) = @_;
 328 return ( ) if (!&foreign_check("software") || !$config{'incpackages'});
 329 &foreign_require("software", "software-lib.pl");
 330 return (  ) if (!$software::update_system);
 331 local @avail;
 332 local @st = stat($available_packages_cache);
 333 if ($refresh || !@st || $st[9] < time()-24*60*60) {     # Keep cache for a day
 334         # Need to refresh
 335         @avail = &software::update_system_available();
 336         open(CACHE, ">$available_packages_cache");
 337         print CACHE &serialise_variable(\@avail);
 338         close(CACHE);
 339         }
 340 else {
 341         # Can use cache
 342         local $avail = &unserialise_variable(
 343                         &read_file_contents($available_packages_cache));
 344         @avail = @$avail;
 345         }
 346 local @rv;
 347 foreach my $a (@avail) {
 348         if ($a->{'name'} =~ /^lib(\S+)-perl$/ ||        # Debian
 349             $a->{'name'} =~ /^perl-(\S+)$/) {           # Redhat
 350                 local $mod = $1;
 351                 $mod =~ s/-/::/g;
 352                 if ($mod eq "LDAP") {
 353                         # Special case for redhat-ish systems
 354                         $mod = "Net::LDAP";
 355                         }
 356                 push(@rv, { 'mod' => $mod,
 357                             'package' => $a->{'name'},
 358                             'version' => $a->{'version'}, });
 359                 }
 360         }
 361 return @rv;
 362 }
 363
 364 # shared_perl_root()
 365 # Returns 1 if Perl is shared with the root zone, indicating that Perl modules
 366 # cannot be installed.
 367 sub shared_perl_root
 368 {
 369 return 0 if (!&running_in_zone());
 370 local $pp = &get_perl_path();
 371 if (&foreign_exists("mount")) {
 372         &foreign_require("mount", "mount-lib.pl");
 373         local @rst = stat($pp);
 374         local $m;
 375         foreach $m (&mount::list_mounted()) {
 376                 local @mst = stat($m->[0]);
 377                 if ($mst[0] == $rst[0] &&
 378                     &is_under_directory($m->[0], $pp)) {
 379                         # Found the mount!
 380                         if ($m->[2] eq "lofs" || $m->[2] eq "nfs") {
 381                                 return 1;
 382                                 }
 383                         }
 384                 }
 385         }
 386 return 0;
 387 }
 388
 389 # get_nice_perl_version()
 390 # Returns the Perl version is human-readable format
 391 sub get_nice_perl_version
 392 {
 393 local $ver = $^V;
 394 if ($ver =~ /^v/) {
 395         return $ver;
 396         }
 397 else {
 398         return join(".", map { ord($_) } split(//, $^V));
 399         }
 400 }
 401
 402 1;
 403