[新手上路]批处理新手入门导读[视频教程]批处理基础视频教程[视频教程]VBS基础视频教程[批处理精品]批处理版照片整理器
[批处理精品]纯批处理备份&还原驱动[批处理精品]CMD命令50条不能说的秘密[在线下载]第三方命令行工具[在线帮助]VBScript / JScript 在线参考
返回列表 发帖

[原创代码] [Perl]抓取句子大全的网页

本帖最后由 523066680 于 2018-10-4 16:32 编辑

[Perl]抓取句子大全的网页

分两步,第一步先提取网页,然后再本地提取文本。
可以中途终止脚本,重新打开后会略过已经完成的条目。

抓取的 HTML 保存在 D:/temp/句子大全 文件夹
  1. =info
  2.     523066680/vicyang
  3.     2018-10
  4. =cut
  5. use utf8;
  6. use Encode;
  7. use File::Path;
  8. use File::Slurp;
  9. use LWP::UserAgent;
  10. use File::Path;
  11. use File::Basename qw/basename/;
  12. use Mojo::DOM;
  13. STDOUT->autoflush(1);
  14. our $wdir = encode('gbk', "D:/temp/句子大全");
  15. mkpath $wdir unless -e $wdir;
  16. our $main = "http://www.1juzi.com";
  17. our $ua = LWP::UserAgent->new( keep_alive => 1, timemout => 8 );
  18. my $res = $ua->get($main);
  19. my $html = $res->content();
  20. my $dom = Mojo::DOM->new($html);
  21. my (@urls, @dirs);
  22. get_item($dom, \@urls, \@dirs);
  23. my $tdir;
  24. for my $id ( 0 .. $#urls )
  25. {
  26.     printf "%s\n", $dirs[$id];
  27.     next if -e $dirs[$id];                 # Skip when this folder exists
  28.     $tdir = $dirs[$id] ."_";
  29.     mkpath $tdir unless -e $tdir;
  30.     get_alist( $main .$urls[$id], $tdir );
  31.     rename( $tdir , $dirs[$id] );          # Restore name
  32. }
  33. sub get_item
  34. {
  35.     our $wdir;
  36.     my ($dom, $urls, $dirs) = @_;
  37.     my $menu = $dom->at(".header-menu");
  38.     for my $e ( $menu->find("ul li a")->each )
  39.     {
  40.         push @$urls, $e->attr("href");
  41.         push @$dirs, sprintf "%s/%s/%s", $wdir, $e->parent->parent->previous->text, $e->text;
  42.     }
  43. }
  44. sub get_alist
  45. {
  46.     our $main;
  47.     my ($url, $dir) = @_;
  48.     my $res = $ua->get( $url );
  49.     my $dom = Mojo::DOM->new( $res->content );
  50.     my @links;
  51.     @links = @{ $dom->at(".alist")->find("a")->map(attr=>"href") };
  52.     #get_page
  53.     my $retry;
  54.     for my $link ( @links )
  55.     {
  56.         printf "    %s\n", $link;
  57.         $retry = 0;
  58.         do
  59.         {
  60.             $res = $ua->get( $main .$link );
  61.             $retry++;
  62.             print "retry times: $retry\n" if ($retry > 1 );
  63.         }
  64.         until ( $res->is_success() );
  65.         write_file( $dir ."/". basename($link), $res->content );
  66.     }
  67. }
复制代码

部分结果 在我的网盘 http://523066680.ys168.com/
临时/网页提取

TOP


  • 内容提取 分类汇总
  1. =info
  2.     523066680/vicyang
  3.     2018-10
  4. =cut
  5. use utf8;
  6. use Encode;
  7. use File::Path;
  8. use File::Slurp;
  9. use Mojo::DOM;
  10. STDOUT->autoflush(1);
  11. our $wdir = encode('gbk', "D:/Temp/句子大全_byNo");
  12. chdir $wdir or warn "$!";
  13. our %FH;
  14. my @files = `dir "$wdir" /a-d /b`;
  15. grep { s/\r?\n// } @files;
  16. @files = sort { substr($a, 0, -5) <=> substr($b, 0, -5) } @files;
  17. grep {
  18.     article($_);
  19.     printf "%s\n", $_;
  20. } @files;
  21. for my $v (values %FH) { close $v }
  22. sub article
  23. {
  24.     our %FH;
  25.     my $page = shift;
  26.     my $html = decode('gbk', scalar(read_file( $page )) );
  27.     $html =~s/&nbsp;//g;
  28.     $dom = Mojo::DOM->new( $html );
  29.     # path
  30.     my @path = @{ $dom->at(".path")->find("a")->map("text") };
  31.     grep { $_ = encode("gbk", $_) } @path;
  32.     my $path = "../". join("/", @path[0,1]);
  33.     my $file = "${path}/${path[-1]}.txt";
  34.     mkpath $path unless -e $path;
  35.     unless ( exists $FH{$file} )
  36.     {
  37.         printf "create %s\n", $file;
  38.         open $FH{$file}, ">:raw:crlf", $file;
  39.         $FH{$file}->autoflush(1);
  40.     }
  41.     # remove tags: <script>, <u>, and next/prev page
  42.     grep { $_->remove } $dom->at(".content")->find("script")->each;
  43.     grep { $_->remove } $dom->at(".content")->find("u")->each;
  44.     $dom->at(".page")->remove;
  45.     my $title = $dom->at("h1")->all_text;
  46.     my $text  = $dom->at(".content")->all_text;
  47.     $text =~s/(\d+、)/\n$1/g;
  48.     $text =~s/\Q$title\E//;
  49.     $text =~s/[\r\n]+/\n/g;
  50.     $text =~s/^\n//;
  51.     my $str;
  52.     $str  = sprintf "%s\n", encode('gbk', $title );
  53.     $str .= sprintf "%s\n", $page;
  54.     $str .= sprintf "%s\n", encode('gbk', $text);
  55.     print { $FH{$file} } $str;
  56. }
复制代码

TOP

本帖最后由 523066680 于 2018-10-5 16:25 编辑


  • 多线程抓取HTML

迭代页码($iter变量)并尝试获取网页,失败5次以后判断为结束。已经存在的网页会略过。
  1. =info
  2.     523066680/vicyang
  3.     2018-10
  4. =cut
  5. use Modern::Perl;
  6. use utf8;
  7. use Encode;
  8. use File::Path;
  9. use File::Slurp;
  10. use LWP::UserAgent;
  11. use Mojo::DOM;
  12. use threads;
  13. use threads::shared;
  14. use Time::HiRes qw/sleep time/;
  15. STDOUT->autoflush(1);
  16. our $idx = 0;
  17. our @ths;
  18. our $iter   :shared;
  19. our $failed :shared;
  20. our $main = "http://www.1juzi.com";
  21. our $wdir = encode('gbk', "D:/temp/句子大全_byNo.");
  22. mkpath $wdir unless -e $wdir;
  23. chdir $wdir;
  24. $iter = 1;
  25. $failed = 0;
  26. #创建线程
  27. grep { push @ths, threads->create( \&func, $_ ) } ( 0 .. 3 );
  28. while ( $failed <= 5 ) { sleep 1.0; }
  29. #线程终结和分离
  30. grep { $_->detach() } threads->list(threads::all);
  31. sub func
  32. {
  33.     our ($main, $failed, $iter);
  34.     my $idx = shift;
  35.     my ($link, $file);
  36.     my $ua = LWP::UserAgent->new( keep_alive => 1, timemout => 6 );
  37.     $SIG{'BREAK'} = sub { threads->exit() };
  38.     my $res;
  39.     my $retry;
  40.     my $task;
  41.     while (1)
  42.     {
  43.         {
  44.             lock($iter);
  45.             $task = $iter++;
  46.         }
  47.         $link = "${main}/new/${task}.html";
  48.         $file = "${task}.html";
  49.         if ( -e $file ) { printf "%s exists\n", $file; next; }
  50.         printf "%s\n", $file;
  51.         $retry = 0;
  52.         do
  53.         {
  54.             $res = $ua->get( $link );
  55.             if ($retry > 0)
  56.             {
  57.                 printf "[%d]%s%s, retry times: %d\n", $idx, "  "x($idx+1), $file, $retry;
  58.                 sleep 0.5;
  59.             }
  60.             $retry++;
  61.         }
  62.         until ( $res->is_success() or ($retry > 3) );
  63.         if ( $res->is_success ) { write_file( $file, $res->content ); }
  64.         else { $failed++; }
  65.     }
  66. }
复制代码

TOP

本帖最后由 523066680 于 2018-10-5 15:55 编辑

在写多线程按页码抓,估计几个G ……

--补充1
扒完了,146157页,2.76G。
提取出来的文本,800MB  不想上传了(逃

--补充2
运行了一下脚本,发现更新了,146342了

TOP

本帖最后由 523066680 于 2018-10-4 17:40 编辑

整理结果保存到网盘了 http://523066680.ys168.com/ -> 临时 -> 网页提取 -> 句子大全_text.zip

句子大全_text.zip

问题
1. 剔除空格会把英语单词之间的空格替换掉,已改
2. 这个网站每个条目下的文章列表并不是完整列表,有很多是没有直接展示的。通过上一页下一页会翻到一些其他文章。

TOP

第二段代码,从本地的HTML提取正文,汇总到TXT

本帖最后由 523066680 于 2018-10-4 21:59 编辑

话说这个网站是不是被攻击了?
文章夹杂各种 <script> 例如
  1. <script>Baidu_A_D("b1");</script>
  2. <script type="text/javascript">news1();</script>
复制代码
做了remove处理
  1. =info
  2.     523066680/vicyang
  3.     2018-10
  4. =cut
  5. use utf8;
  6. use Encode;
  7. use File::Slurp;
  8. use Mojo::DOM;
  9. STDOUT->autoflush(1);
  10. our $wdir = encode('gbk', "D:/Temp/句子大全");
  11. chdir $wdir or warn "$!";
  12. my $buff;
  13. my @files;
  14. my @dirs = `dir "$wdir" /ad /s /b`;
  15. grep { s/\r?\n//; } @dirs;
  16. for my $dir ( @dirs )
  17. {
  18.     printf "%s\n", $dir;
  19.     chdir $dir or die "$!";
  20.     @files = glob "*.html";
  21.     next unless $#files >= 0;
  22.     $buff = "";
  23.     grep { $buff .= article( $_ ) } sort { substr($b, 0, -5) <=> substr($a, 0, -5) } @files;
  24.     write_file( "${dir}.txt", $buff );
  25. }
  26. sub article
  27. {
  28.     my $file = shift;
  29.     my $html = decode('gbk', scalar(read_file( $file )) );
  30.     $html =~s/&nbsp;//g;
  31.     $dom = Mojo::DOM->new( $html );
  32.     # remove tags: <script>, <u>, and next/prev page
  33.     grep { $_->remove } $dom->at(".content")->find("script")->each;
  34.     grep { $_->remove } $dom->at(".content")->find("u")->each;
  35.     $dom->at(".page")->remove;
  36.     my $title = $dom->at("h1")->all_text;
  37.     my $text  = $dom->at(".content")->all_text;
  38.     $text =~s/(\d+、)/\n$1/g;
  39.     $text =~s/\Q$title\E//;
  40.     $text =~s/[\r\n]+/\n/g;
  41.     $text =~s/^\n//;
  42.     my $str;
  43.     $str  = sprintf "%s\n", encode('gbk', $title );
  44.     $str .= sprintf "%s\n", $file;
  45.     $str .= sprintf "%s\n", encode('gbk', $text);
  46.     return $str;
  47. }
复制代码

TOP

返回列表