Board logo

标题: [原创代码] [Perl]抓取句子大全的网页 [打印本页]
作者: 523066680    时间: 2018-10-4 16:28     标题: [Perl]抓取句子大全的网页

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

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

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

抓取的 HTML 保存在 D:/temp/句子大全 文件夹
  1. =info

  2.     523066680/vicyang

  3.     2018-10

  4. =cut

  5. 

  6. use utf8;

  7. use Encode;

  8. use File::Path;

  9. use File::Slurp;

  10. use LWP::UserAgent;

  11. use File::Path;

  12. use File::Basename qw/basename/;

  13. use Mojo::DOM;

  14. STDOUT->autoflush(1);

  15. 

  16. our $wdir = encode('gbk', "D:/temp/句子大全");

  17. mkpath $wdir unless -e $wdir;

  18. our $main = "http://www.1juzi.com";

  19. our $ua = LWP::UserAgent->new( keep_alive => 1, timemout => 8 );

  20. my $res = $ua->get($main);

  21. my $html = $res->content();

  22. my $dom = Mojo::DOM->new($html);

  23. 

  24. my (@urls, @dirs);

  25. get_item($dom, \@urls, \@dirs);

  26. 

  27. my $tdir;

  28. for my $id ( 0 .. $#urls )

  29. {

  30.     printf "%s\n", $dirs[$id];

  31.     next if -e $dirs[$id];                 # Skip when this folder exists

  32.     $tdir = $dirs[$id] ."_";

  33.     mkpath $tdir unless -e $tdir;

  34.     get_alist( $main .$urls[$id], $tdir );

  35.     rename( $tdir , $dirs[$id] );          # Restore name

  36. }

  37. 

  38. sub get_item

  39. {

  40.     our $wdir;

  41.     my ($dom, $urls, $dirs) = @_;

  42.     my $menu = $dom->at(".header-menu");

  43. 

  44.     for my $e ( $menu->find("ul li a")->each )

  45.     {

  46.         push @$urls, $e->attr("href");

  47.         push @$dirs, sprintf "%s/%s/%s", $wdir, $e->parent->parent->previous->text, $e->text;

  48.     }

  49. }

  50. 

  51. sub get_alist

  52. {

  53.     our $main;

  54.     my ($url, $dir) = @_;

  55.     my $res = $ua->get( $url );

  56.     my $dom = Mojo::DOM->new( $res->content );

  57.     my @links;

  58.     @links = @{ $dom->at(".alist")->find("a")->map(attr=>"href") };

  59. 

  60.     #get_page

  61.     my $retry;

  62.     for my $link ( @links )

  63.     {

  64.         printf "    %s\n", $link;

  65.         $retry = 0;

  66.         do 

  67.         {

  68.             $res = $ua->get( $main .$link );

  69.             $retry++;

  70.             print "retry times: $retry\n" if ($retry > 1 );

  71.         }

  72.         until ( $res->is_success() );

  73. 

  74.         write_file( $dir ."/". basename($link), $res->content );

  75.     }

  76. }
复制代码
作者: 523066680    时间: 2018-10-4 16:49     标题: 第二段代码，从本地的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. 

  6. use utf8;

  7. use Encode;

  8. use File::Slurp;

  9. use Mojo::DOM;

  10. STDOUT->autoflush(1);

  11. 

  12. our $wdir = encode('gbk', "D:/Temp/句子大全");

  13. chdir $wdir or warn "$!";

  14. 

  15. my $buff;

  16. my @files;

  17. my @dirs = `dir "$wdir" /ad /s /b`;

  18. grep { s/\r?\n//; } @dirs;

  19. 

  20. for my $dir ( @dirs )

  21. {

  22.     printf "%s\n", $dir;

  23.     chdir $dir or die "$!";

  24.     @files = glob "*.html";

  25.     next unless $#files >= 0;

  26.     $buff = "";

  27.     grep { $buff .= article( $_ ) } sort { substr($b, 0, -5) <=> substr($a, 0, -5) } @files;

  28.     write_file( "${dir}.txt", $buff );

  29. }

  30. 

  31. sub article

  32. {

  33.     my $file = shift;

  34.     my $html = decode('gbk', scalar(read_file( $file )) );

  35.     $html =~s/&nbsp;//g;

  36. 

  37.     $dom = Mojo::DOM->new( $html );

  38.     # remove tags: <script>, <u>, and next/prev page 

  39.     grep { $_->remove } $dom->at(".content")->find("script")->each;

  40.     grep { $_->remove } $dom->at(".content")->find("u")->each;

  41.     $dom->at(".page")->remove;

  42.     my $title = $dom->at("h1")->all_text;

  43.     my $text  = $dom->at(".content")->all_text;

  44. 

  45.     $text =~s/(\d+、)/\n$1/g;

  46.     $text =~s/\Q$title\E//;

  47.     $text =~s/[\r\n]+/\n/g;

  48.     $text =~s/^\n//;

  49. 

  50.     my $str;

  51.     $str  = sprintf "%s\n", encode('gbk', $title );

  52.     $str .= sprintf "%s\n", $file;

  53.     $str .= sprintf "%s\n", encode('gbk', $text);

  54.     return $str;

  55. }
复制代码
作者: 523066680    时间: 2018-10-4 17:18

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

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

句子大全_text.zip

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

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

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

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

--补充2
运行了一下脚本，发现更新了，146342了
作者: 523066680    时间: 2018-10-5 16:13

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


迭代页码($iter变量)并尝试获取网页，失败5次以后判断为结束。已经存在的网页会略过。
  1. =info

  2.     523066680/vicyang

  3.     2018-10

  4. =cut

  5. 

  6. use Modern::Perl;

  7. use utf8;

  8. use Encode;

  9. use File::Path;

  10. use File::Slurp;

  11. use LWP::UserAgent;

  12. use Mojo::DOM;

  13. use threads;

  14. use threads::shared;

  15. use Time::HiRes qw/sleep time/;

  16. STDOUT->autoflush(1);

  17. 

  18. our $idx = 0;

  19. our @ths;

  20. our $iter   :shared;

  21. our $failed :shared;

  22. 

  23. our $main = "http://www.1juzi.com";

  24. our $wdir = encode('gbk', "D:/temp/句子大全_byNo.");

  25. mkpath $wdir unless -e $wdir;

  26. chdir $wdir;

  27. 

  28. $iter = 1;

  29. $failed = 0;

  30. #创建线程

  31. grep { push @ths, threads->create( \&func, $_ ) } ( 0 .. 3 );

  32. 

  33. while ( $failed <= 5 ) { sleep 1.0; }

  34. 

  35. #线程终结和分离

  36. grep { $_->detach() } threads->list(threads::all);

  37. 

  38. sub func

  39. {

  40.     our ($main, $failed, $iter);

  41.     my $idx = shift;

  42.     my ($link, $file);

  43.     my $ua = LWP::UserAgent->new( keep_alive => 1, timemout => 6 );

  44. 

  45.     $SIG{'BREAK'} = sub { threads->exit() };

  46. 

  47.     my $res;

  48.     my $retry;

  49.     my $task;

  50. 

  51.     while (1)

  52.     {

  53.         {

  54.             lock($iter);

  55.             $task = $iter++;

  56.         }

  57. 

  58.         $link = "${main}/new/${task}.html";

  59.         $file = "${task}.html";

  60.         if ( -e $file ) { printf "%s exists\n", $file; next; }

  61. 

  62.         printf "%s\n", $file;

  63.         $retry = 0;

  64.         do 

  65.         {

  66.             $res = $ua->get( $link );

  67.             if ($retry > 0) 

  68.             {

  69.                 printf "[%d]%s%s, retry times: %d\n", $idx, "  "x($idx+1), $file, $retry;

  70.                 sleep 0.5; 

  71.             }

  72.             $retry++;

  73.         }

  74.         until ( $res->is_success() or ($retry > 3) );

  75. 

  76.         if ( $res->is_success ) { write_file( $file, $res->content ); } 

  77.         else { $failed++; }

  78.     }

  79. }
复制代码
作者: 523066680    时间: 2018-10-5 16:25

  1. =info

  2.     523066680/vicyang

  3.     2018-10

  4. =cut

  5. 

  6. use utf8;

  7. use Encode;

  8. use File::Path;

  9. use File::Slurp;

  10. use Mojo::DOM;

  11. STDOUT->autoflush(1);

  12. 

  13. our $wdir = encode('gbk', "D:/Temp/句子大全_byNo");

  14. chdir $wdir or warn "$!";

  15. 

  16. our %FH;

  17. my @files = `dir "$wdir" /a-d /b`;

  18. grep { s/\r?\n// } @files;

  19. @files = sort { substr($a, 0, -5) <=> substr($b, 0, -5) } @files;

  20. 

  21. grep { 

  22.     article($_); 

  23.     printf "%s\n", $_;

  24. } @files;

  25. 

  26. for my $v (values %FH) { close $v }

  27. 

  28. sub article

  29. {

  30.     our %FH;

  31.     my $page = shift;

  32.     my $html = decode('gbk', scalar(read_file( $page )) );

  33.     $html =~s/&nbsp;//g;

  34. 

  35.     $dom = Mojo::DOM->new( $html );

  36.     # path

  37.     my @path = @{ $dom->at(".path")->find("a")->map("text") };

  38.     grep { $_ = encode("gbk", $_) } @path;

  39. 

  40.     my $path = "../". join("/", @path[0,1]);

  41.     my $file = "${path}/${path[-1]}.txt";

  42.     mkpath $path unless -e $path;

  43. 

  44.     unless ( exists $FH{$file} )

  45.     {

  46.         printf "create %s\n", $file;

  47.         open $FH{$file}, ">:raw:crlf", $file;

  48.         $FH{$file}->autoflush(1);

  49.     }

  50. 

  51.     # remove tags: <script>, <u>, and next/prev page 

  52.     grep { $_->remove } $dom->at(".content")->find("script")->each;

  53.     grep { $_->remove } $dom->at(".content")->find("u")->each;

  54.     $dom->at(".page")->remove;

  55.     my $title = $dom->at("h1")->all_text;

  56.     my $text  = $dom->at(".content")->all_text;

  57. 

  58.     $text =~s/(\d+、)/\n$1/g;

  59.     $text =~s/\Q$title\E//;

  60.     $text =~s/[\r\n]+/\n/g;

  61.     $text =~s/^\n//;

  62. 

  63.     my $str;

  64.     $str  = sprintf "%s\n", encode('gbk', $title );

  65.     $str .= sprintf "%s\n", $page;

  66.     $str .= sprintf "%s\n", encode('gbk', $text);

  67. 

  68.     print { $FH{$file} } $str;

  69. }
复制代码
作者: 523066680    时间: 2018-10-6 08:18

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



欢迎光临 批处理之家 (http://www.bathome.net/) Powered by Discuz! 7.2