Perl - 抓取文学网站文章

There's more than one way to do it!
https://metacpan.org http://perlmonks.org
头像
523066680
Administrator
Administrator
帖子: 404
注册时间: 2016年07月19日 12:14
拥有现金: 锁定
储蓄: 锁定
Has thanked: 38 times
Been thanked: 52 times
联系:

Perl - 抓取文学网站文章

帖子 #1 523066680 » 2018年10月04日 11:04

分两步,第一步抓取HTML到本地,第二部提取HTML到明文

Code: [全选] [展开/收缩] [Download] (get_HTML.pl)
  1. =info
  2.     523066680/vicyang
  3.     2018-10
  4. =cut
  5.  
  6. use utf8;
  7. use Encode;
  8. use LWP::UserAgent;
  9. use File::Path;
  10. use File::Slurp;
  11. use File::Basename qw/basename/;
  12. use Mojo::DOM;
  13. STDOUT->autoflush(1);
  14.  
  15. our $wdir = encode('gbk', "D:/temp/力成文学");
  16. mkpath $wdir unless -e $wdir;
  17. our $main = "http://www.ceasm.com";
  18. our $ua = LWP::UserAgent->new( keep_alive => 1, timemout => 8 );
  19. my $res = $ua->get($main);
  20. my $html = $res->content();
  21. my $dom = Mojo::DOM->new($html);
  22.  
  23. my ($url, $dir, $buff, $item );
  24. my (@sUrl, @sItem, @list, $article);
  25.  
  26. # 一级栏目
  27. for my $e ( $dom->at(".menu")->find("[target]")->each )
  28. {
  29.     $url = $e->attr("href");
  30.     $item = $e->text;
  31.     printf "%s\n", $e->text;
  32.  
  33.     # 二级栏目
  34.     get_subitem( $url, \@sUrl, \@sItem );
  35.     for my $id ( 0 .. $#sUrl )
  36.     {
  37.         printf "    %s\n", $sItem[$id];
  38.         $dir = "${wdir}/${item}/${sItem[$id]}/";
  39.         mkpath $dir unless -e $dir;
  40.  
  41.         # 所有文章链接
  42.         @list = list( $main . $sUrl[$id] );
  43.         for my $link ( @list )
  44.         {
  45.             printf "        %s\n", $link;
  46.             $buff = article($main . $link);
  47.             write_file( $dir . basename($link), $buff );    
  48.         }
  49.     }
  50. }
  51.  
  52. # 二级栏目
  53. sub get_subitem
  54. {
  55.     my ( $url, $links, $names ) = @_;
  56.     my $res = $ua->get( $url );
  57.     $dom = Mojo::DOM->new( $res->content() );
  58.     @$links = map { $_->attr("href") } ( $dom->at(".keywords")->find("[target]")->each );
  59.     @$names = map { $_->text } ( $dom->at(".keywords")->find("[target]")->each );
  60. }
  61.  
  62. # 文段列表
  63. sub list
  64. {
  65.     my $link = shift;
  66.     my $res = $ua->get( $link );
  67.     $dom = Mojo::DOM->new( $res->content() );
  68.     # 获取最大页面值
  69.     $dom->at(".pagelist")->find("a")->last =~ /(\d+)/;
  70.     my $max = $1;
  71.     my @list;
  72.  
  73.     for my $id ( 1 .. $max )
  74.     {
  75.         $res = $ua->get( $link ."list${id}.html" );
  76.         $dom = Mojo::DOM->new( $res->content() );
  77.         push @list, map { $_->attr("href") } $dom->at(".dedelist")->find("h4 [target]")->each;
  78.     }
  79.  
  80.     return @list;
  81. }
  82.  
  83. sub article
  84. {
  85.     my $link = shift;
  86.     my $res;
  87.     do {  $res = $ua->get( $link ); } until ( length($res->content) > 2000 );
  88.  
  89.     return $res->content;
  90. }


文章提取以及导出

Code: [全选] [展开/收缩] [Download] (HTML_to_Text.pl)
  1. =info
  2.     523066680/vicyang
  3.     2018-10
  4. =cut
  5.  
  6. use utf8;
  7. use Encode;
  8. use File::Slurp;
  9. use LWP::UserAgent;
  10. use Mojo::DOM;
  11. STDOUT->autoflush(1);
  12.  
  13. our $main = "http://www.ceasm.com";
  14. our $ua = LWP::UserAgent->new( keep_alive => 1, timemout => 8 );
  15. our $wdir = encode('gbk', "D:/Temp/力成文学");
  16. chdir $wdir or warn "$!";
  17.  
  18. my $buff;
  19. my @files;
  20. my @dirs = `dir "$wdir" /ad /s /b`;
  21. grep { s/\r?\n//; } @dirs;
  22.  
  23. for my $dir ( @dirs )
  24. {
  25.     printf "%s\n", $dir;
  26.     chdir $dir or die "$!";
  27.     @files = glob "*.html";
  28.     next unless $#files >= 0;
  29.     $buff = "";
  30.     grep { $buff .= article( $_ ) } sort { substr($b, 0, -5) <=> substr($a, 0, -5) } @files;
  31.     write_file( "${dir}.txt", $buff );
  32. }
  33.  
  34. sub article
  35. {
  36.     my $file = shift;
  37.     my $html = decode('gbk', scalar(read_file( $file )) );
  38.     $html =~s/&nbsp;/#CRLF/g;
  39.     $html =~s/\n/#CRLF/g;                     # ------> 1
  40.  
  41.     $dom = Mojo::DOM->new( $html );
  42.     my $title = $dom->at("h2")->all_text;
  43.     my $text  = $dom->at(".text")->all_text;
  44.  
  45.     $text =~s/\s//g;                          # ------> 2 去掉所有空白符号包括 space tab \r \n 全角空白符
  46.     $text =~s/(\d+、)/\n$1/g;
  47.     $text =~s/\Q$title\E//;
  48.     $text =~s/#CRLF/\n/g;
  49.     $text =~s/[\r\n]+/\n/g;
  50.     $text =~s/^\n//;
  51.  
  52.     my $str;
  53.     #标题
  54.     $str  = sprintf "%s\n", encode('gbk', $title );
  55.     $str .= sprintf "%s\n", $file;
  56.     $str .= sprintf "%s\n\n", encode('gbk', $text);
  57.     return $str;
  58. }
  59.  
  60. sub xcode
  61. {
  62.     $_[1]='x' if (not defined $_[1]);
  63.  
  64.     for my $v ( split(//,$_[0]) )
  65.     {
  66.         print sprintf ("%02$_[1] ",ord($v));    
  67.     }
  68.     print "\n\n";
  69. }

zzz19760225
渐入佳境
渐入佳境
帖子: 41
注册时间: 2017年12月25日 11:12
拥有现金: 锁定
储蓄: 锁定
Has thanked: 37 times
Been thanked: 1 time
联系:

Re: Perl - 抓取文学网站文章

帖子 #2 zzz19760225 » 2018年10月05日 11:47

ε=(´ο`*)))唉,只能默默的摸摸代码的头,然后继续该睡觉睡觉。

头像
523066680
Administrator
Administrator
帖子: 404
注册时间: 2016年07月19日 12:14
拥有现金: 锁定
储蓄: 锁定
Has thanked: 38 times
Been thanked: 52 times
联系:

Re: Perl - 抓取文学网站文章

帖子 #3 523066680 » 2018年10月05日 16:28

zzz19760225 写了:ε=(´ο`*)))唉,只能默默的摸摸代码的头,然后继续该睡觉睡觉。


哇,论坛挂了两个月,想不到还有人过来光顾,真不容易。

也不知道是不是服务商要搞我,说访问流量超过了,把网站给关了,还建议升级VPS。 明明没多少人访问来着。

zzz19760225
渐入佳境
渐入佳境
帖子: 41
注册时间: 2017年12月25日 11:12
拥有现金: 锁定
储蓄: 锁定
Has thanked: 37 times
Been thanked: 1 time
联系:

Re: Perl - 抓取文学网站文章

帖子 #4 zzz19760225 » 2018年10月05日 21:28

523066680 写了:
哇,论坛挂了两个月,想不到还有人过来光顾,真不容易。

也不知道是不是服务商要搞我,说访问流量超过了,把网站给关了,还建议升级VPS。 明明没多少人访问来着。



专业方向,加上个体兴趣加成,内涵蛮多的。
只是看看,没办法入手,浪费时间,急啊(心里还要不住的说,稳住稳住)!
----------------------------------------------------------
也许那位云流量账号的测试造成的吧,
要不就是杀熟,该宰几只了,放些血,解解渴。
跟百度搞到后面所谓的商业化一样。

头像
523066680
Administrator
Administrator
帖子: 404
注册时间: 2016年07月19日 12:14
拥有现金: 锁定
储蓄: 锁定
Has thanked: 38 times
Been thanked: 52 times
联系:

Re: Perl - 抓取文学网站文章

帖子 #5 523066680 » 2018年10月05日 21:46

zzz19760225 写了:专业方向,加上个体兴趣加成,内涵蛮多的。
只是看看,没办法入手,浪费时间,急啊(心里还要不住的说,稳住稳住)!
----------------------------------------------------------
也许那位云流量账号的测试造成的吧,
要不就是杀熟,该宰几只了,放些血,解解渴。
跟百度搞到后面所谓的商业化一样。


话说你关注/从事哪个方向?

zzz19760225
渐入佳境
渐入佳境
帖子: 41
注册时间: 2017年12月25日 11:12
拥有现金: 锁定
储蓄: 锁定
Has thanked: 37 times
Been thanked: 1 time
联系:

Re: Perl - 抓取文学网站文章

帖子 #6 zzz19760225 » 2018年10月10日 18:55

523066680 写了:
话说你关注/从事哪个方向?
[/quote]

关注:
最好是直接从GB18030汉字标准为计算机指令集的机器硬件制作, (国产开关逻辑门或其他实现可能,保持长期稳定生长)
其次是一个硬件中间过渡的GB18030类汉字标准实现,
最后是底层硬件软件接口部分的实现。
(不知道行业外门外汉的理解表达,这样算表达好了没有)

用这些内容做的小玩具,类似过去的小霸王学习机,做成计算器和手掌机玩,最好能简单联网的增加乐趣。


回到 “Perl”

在线用户

用户浏览此论坛: 没有注册用户 和 1 访客