一个安装cpan模块的脚本

hp_truth

CPAN命令好像是用Net::FTP来获取下载地址的，但是我的ftp端口被禁了，所以不能用cpan命令来安装了，不过http端口可以用，以前都是一个一个下载安装，最近觉得有必要自己写一个自动安装的脚本。 到目前为止还比较好使，大家感兴趣的可以试一下)

1. 
   
2. #!/usr/local/bin/perl5
   
3. 
   
4. use warnings;
   
5. use strict;
   
6. 
   
7. use WWW::Mechanize;
   
8. use HTML::TreeBuilder;
   
9. use HTML::Query 'query';
   
10. use Cwd;
    
11. use File::Basename;
    
12. 
    
13. die "Usage: $0 module_name\n" unless @ARGV;
    
14. my ($module) = @ARGV;
    
15. 
    
16. my $prefix  = "~/perl5";
    
17. my $tmp_dir = "~/test";
    
18. my $http_proxy = "http://proxy.com:80";
    
19. 
    
20. my $mech = WWW::Mechanize->new(autocheck=>1);
    
21. $mech->stack_depth(0);
    
22. $mech->proxy(['http'], $http_proxy) if (! $ENV{http_proxy});
    
23. 
    
24. print "you want to install $module...\n";
    
25. &install($module);
    
26. 
    
27. ###########################
    
28. sub get_url_from_cpan {
    
29.     my $module = shift;
    
30.     my $cpan_url = "http://search.cpan.org";
    
31.     print "get search_page ...\nurl=$cpan_url\n";
    
32.     # search the module in CPAN main page
    
33.     $mech->get($cpan_url);
    
34.     $mech->set_fields(query => $module);
    
35.     $mech->submit();
    
36.     my $search_page_content = $mech->content();
    
37. 
    
38.     # parse the search page to find the url of this module
    
39.     my $tree = HTML::TreeBuilder->new;
    
40.     my $success = $tree->parse($search_page_content);
    
41.     $success    = $tree->eof();
    
42.     die "parse search_page_content failed: $!\n" unless $success;
    
43. 
    
44.     my $h2s = $tree->query('h2.sr'); #<h2> with sr class
    
45.     my $href;
    
46.     for my $h2 (@$h2s) {
    
47.         my $module_name = $h2->query('a[href]')->as_trimmed_text->[0];
    
48.         print "module_name: $module_name, module: $module\n";
    
49.         if ($module_name eq $module) {
    
50.             $href = $h2->query('a[href]')->attr('href')->[0];
    
51.             last;
    
52.         }
    
53.     }
    
54. 
    
55.     # fetch the page of this module from CPAN
    
56.     my $module_url = $cpan_url . $href;
    
57.     print "get module_page ...\nurl=$module_url\n";
    
58.     $mech->get($module_url);
    
59.     my $module_page_content = $mech->content();
    
60.     undef $tree;
    
61.     $tree = HTML::TreeBuilder->new;
    
62.     $success = $tree->parse($module_page_content);
    
63.     $success = $tree->eof();
    
64.     die "parse module_page_content failed: $!\n" unless $success;
    
65. 
    
66.     # find the download url for this module
    
67.     my $ps = $tree->query("p[style]");
    
68.     for my $p (@$ps) {
    
69.         if ($p->as_trimmed_text =~ m/Download:/) {
    
70.             my $href = $p->query('a[href]')->attr('href')->[0];
    
71.             print "Path = " . $cpan_url . $href . "\n";
    
72.             return $cpan_url . $href;
    
73.         }
    
74.     }
    
75.     return undef; # fail if reach here
    
76. }
    
77. 
    
78. sub install {
    
79.     my $module = shift;
    
80.     my @suffixlist = (".tar.gz", ".tgz");
    
81.     my $suffix = ".tar.gz";
    
82.     my $path;
    
83. 
    
84.     my $cur_dir = getcwd;
    
85.     chdir($tmp_dir);
    
86.     print "cur_dir: $cur_dir, chidr to: " . getcwd . "\n";
    
87. 
    
88.     # judge if file already exists.
    
89.     # for example, file A-B.tar.gz for module A::B
    
90.     my @files = grep {-f $_} <*>;
    
91.     my $dir = $module;
    
92.     $dir =~ s/::/-/g;
    
93.     @files = grep /^$dir-(\d.)+/, @files;
    
94.     print "files=@files\n";
    
95. 
    
96.     # if module.tar.gz does not exists, we wget it from CPAN
    
97.     # else use it directly
    
98.     unless (@files) {
    
99.         my $url = &get_url_from_cpan($module);
    
100.         ($dir, $path, $suffix) = fileparse($url, @suffixlist);
     
101.         system("wget $url 1>/dev/null 2>&1");
     
102.     }
     
103.     else {
     
104.         ($dir, $path ,$suffix) = fileparse($files[0], @suffixlist);
     
105.     }
     
106. 
     
107.     # unpack the module.tar.gz file
     
108.     # and chdir to the related dir
     
109.     print "dir = $dir\n";
     
110.     system("gunzip < $dir$suffix|tar -xf -");
     
111.     chdir($dir);
     
112. 
     
113.     # start to install this module
     
114.     # 1. perl5 Makefile.PL prefix=$prefix
     
115.     # 2. make
     
116.     # 3. make install
     
117.     # If there is dependency, we should install them first
     
118.     # until all dependency are installed.
     
119.     my $dependency = 1;
     
120.     while ($dependency) {
     
121.         my $mf_result = `perl5 Makefile.PL prefix=$prefix 2>&1`;
     
122.         if ($mf_result =~ m/Warning: prerequisite (\S*) .* not found/) {
     
123.             my ($new_module) = $1 ;
     
124.             $new_module =~ s/-(\d.)+$//;
     
125.             $new_module =~ s/-/::/g;
     
126.             print ">" x 30 . "\n";
     
127.             print "$new_module shoulde be installed first\n";
     
128.             system("~/bin/cpan_install.pl",  $new_module);
     
129.         }
     
130.         else {
     
131.             $dependency = 0;
     
132.         }
     
133.     }
     
134.     system("make && make install");
     
135. 
     
136.     chdir($cur_dir);
     
137. }
     

复制代码

wfnh

呵呵··不错~~

hp_truth

回复 2# wfnh


    谢谢， 就是觉得HTML:uery挺好用的，所以拿来当作练习了。 应该还有别的方法可以下载的。

liyangole

赞，我们内部网络也是不能CPAN，正好试试这个！

dugu072_cu

cpan 有配置文件的，可以设置 ftp、http proxy的，看你设置了，我这边看到，经常都是 lwp 下载的嘛