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

[原创代码] [Perl]Mojo::UserAgent 抓取52shici页面

本帖最后由 523066680 于 2018-12-7 18:47 编辑

该网站的文章页面有手机版的,体积比PC端页面小一半以上,可以减少数据量。
全部下载完 7-8个G左右
  1. =info
  2.     523066680/vicyang
  3.     2018-12
  4. =cut
  5. use Encode;
  6. use Modern::Perl;
  7. use File::Slurp;
  8. use Mojo::UserAgent;
  9. use File::Path qw/mkpath/;
  10. use Try::Tiny;
  11. STDOUT->autoflush(1);
  12. our $ua = Mojo::UserAgent->new();
  13. our $main = "http://www.52shici.com";
  14. our $wdir = "D:/temp/52shici_mobile";
  15. mkpath $wdir unless -e $wdir;
  16. #获取主类
  17. my $max;
  18. my $route;
  19. my $item;
  20. my $res = $ua->get( $main )->result;
  21. for my $e ($res->dom->find(".works-type-list a")->each )
  22. {
  23.     $route = $e->attr("href");
  24.     $item = encode('gbk', $e->text);
  25.     printf "%s %s\n", $route, $item;
  26.     $max = get_max_pgcode( "${main}/${route}" );
  27.     get_article( "${main}/${route}", $max, $item );
  28. }
  29. sub get_article
  30. {
  31.     our ($main, $wdir);
  32.     my ( $link, $max, $item ) = @_;
  33.     my $res;
  34.     my $detail;
  35.     my $path = "${wdir}/${item}";
  36.     my $file;
  37.     my $target;
  38.     mkpath $path unless -e $path;
  39.     chdir $path;
  40.     # 遍历所有页码
  41.     for my $code ( 1 .. $max )
  42.     {
  43.         printf "%s, Page code: %d/%d\n", $item, $code, $max;
  44.         $res = try_to_get( "${link}&page=${code}" );
  45.         my $count = 1;
  46.         # 每一篇文章
  47.         for my $e ( $res->dom->find(".l a")->each )
  48.         {
  49.             # URL中的请求部分
  50.             $e->attr('href') =~/\?(.*)&/;
  51.             $file = $1 .".html";
  52.             $target = $main ."/". $e->attr('href');
  53.             $target =~s/&.*$//;
  54.             $target =~s/www\./m\./;
  55.             next if -e $file;
  56.             $detail = try_to_get( $target );
  57.             write_file( $file , $detail->body );
  58.         }
  59.     }
  60. }
  61. sub get_max_pgcode
  62. {
  63.     my ( $link ) = @_;
  64.     my $res = $ua->get( $link )->result;
  65.     my $keyword = $res->dom->at(".mt")->text;
  66.     if ($keyword =~/1\/(\d+)/) { return $1; }
  67.     else { printf "Failed to get max page code\n"; return undef }
  68. }
  69. sub try_to_get
  70. {
  71.     our ($ua);
  72.     my ($link) = @_;
  73.     my $res;
  74.     my $times = 0;
  75.     while (1)
  76.     {
  77.         try { $res = $ua->get( $link )->result; }
  78.         catch { printf "Error %s, retry: %d\n", $_, $times; };
  79.         $times++;
  80.         last if (defined $res and $res->is_success);
  81.         exit if ( $times > 5 );
  82.     }
  83.     return $res;
  84. }
复制代码

本帖最后由 523066680 于 2018-12-7 19:07 编辑

文本提取的基本可以了,本来想用标题做文件名,做了Unicode文件名的支持。

遇到过的问题:
windows禁用的文件名符号: 山樵 - 古风<中秋感赋〉 - 诗词吾爱
控制符号:
物理老师 《少时听鼓词、初雪》 (<0x08>阮郎归)
潮落潮起 《尼斯事件与圣彼得堡国际马拉松》 (<0x03><0x03><0x03><0x03>)

TOP

在处理的时候又遇到“彩蛋”了:
《今恨爱多余》(巫山一段)
还我年华  2017-06-20 10:19
尊敬的广大诗友们,大家好! 今天我以一位普通的吾爱网诗友向广大的诗友们揭露一件令人感到愤慨的事件:有位网名叫"舞雨"的人,完全盗窃了香港沧浪诗苑首席版主和吾爱网著名诗人炎凉居先生在2015年10月17日创作的《风入松-十四韵完整版》14首作品。并以"舞雨"网名在桃源诗社微刊N053,于2016年间发表。其中每句、每行、每字都和炎凉居的作品完全一样!难道只是巧合吗?答案是否定的!其完全盗窃了炎凉居先生的作品,手段卑鄙无耻,令人发指!

TOP

本帖最后由 523066680 于 2018-12-7 20:07 编辑

提取正文的代码,Mojo::DOM 解析HTML,提取元素。
保存的文件名格式为 :作者+标题+诗歌类型+页面ID
  1. =info
  2.     523066680/vicyang
  3.     2018-12
  4. =cut
  5. use Mojo::DOM;
  6. use File::Slurp;
  7. use Encode;
  8. use File::Path;
  9. use Try::Tiny;
  10. use File::Basename qw/basename/;
  11. use Win32API::File qw(:ALL);
  12. STDOUT->autoflush(1);
  13. our $src = "D:/temp/52shici_mobile";
  14. our $dst = "D:/temp/52shici_extract";
  15. my $item;
  16. my (@files, %already, $pgname, $dirlist);
  17. my ($rate, $prev);
  18. for my $subdir ( glob "${src}/*" )
  19. {
  20.     printf "%s\n", $subdir;
  21.     $item = basename($subdir);
  22.     mkpath "${dst}/${item}" unless -e "${dst}/${item}";
  23.     # 需要处理的文件列表
  24.     @files = glob "${subdir}/*";
  25.     # 创建现有名单哈希表
  26.     %already = ();
  27.     my $dirlist = decode("utf16-le", `cmd /U /C dir /b \"${dst}/${item}\"`);
  28.     grep { $_=~/(works_id=\d+)/; $already{$1} = 1; } split("\r\n", $dirlist);
  29.     ($rate, $prev) = (0.0, 0.0);
  30.     for my $id ( 0 .. $#files )
  31.     {
  32.         # 显示进度,百分率
  33.         $rate = $id / $#files * 100.0;
  34.         if ( ($rate-$prev) >= 1.0 ) {
  35.             printf "%d\% ", $rate;
  36.             $prev = $rate;
  37.         }
  38.         $pgname = basename($files[$id], ".html");
  39.         next if exists $already{$pgname};
  40.         abstract( "${dst}/${item}", $item, $files[$id] );
  41.     }
  42.     printf "\n";
  43.     exit;
  44. }
  45. sub abstract
  46. {
  47.     my ($path, $item, $page) = @_;
  48.     my $html = read_file( $page );
  49.     $html=~s/\&nbsp;//g;
  50.     #$html=~s/<script>.*$//es;
  51.     my $dom = Mojo::DOM->new( $html );
  52.     my $buff = "";
  53.     my ($fname, $head) = ("", "");
  54.     my $id = basename($page, ".html");
  55.     # 作者 标题 类型 日期
  56.     my $author = $dom->at(".works-author a")->text;
  57.     my $title  = $dom->at(".works-title")->text;
  58.     my $type   = $dom->at(".works-type")->text;
  59.     my $date   = $dom->at(".works-author")->text;
  60.     $author =~s/^\s+//;  # 去掉开头space
  61.     $date =~s/:/./g;
  62.     $head  = join(" ", $author, $title, $type, $date );
  63.     $fname = join(" ", $author, $title, $type, $id );
  64.     #printf "%s %s\n", utf2gbk($fname), $page;
  65.     $buff .= $head;
  66.     $buff .= $dom->at("#content_box")->all_text;
  67.     $buff=~s/\r?\n([ \t]+)?/#MARK/g;
  68.     $buff=~s/ {2,}/ /sge;               # 合并连续空格
  69.     $buff=~s/(#MARK){2,}/#MARK#MARK/g;  # 合并超过两行的换行
  70.     $buff=~s/#MARK/\r\n/g;
  71.    
  72.     #write_file( "${path}/${title}.txt", {binmode => ":raw"}, $buff );
  73.     $path = decode('gbk', $path);
  74.     $fname = decode('utf8', $fname);
  75.     #去掉控制字符(某些文章标题就出现了<0x08>,<0x03>),并且是在Unicode编码下替换
  76.     $fname =~s/\p{IsCntrl}//g;
  77.     create_with_unicode_fname( $path, $fname, \$buff );
  78. }
  79. sub create_with_unicode_fname
  80. {
  81.     my ($path, $title, $buff) = @_;
  82.     $title =~s/[\Q*?":<>|\\\/\E]/ /g;     # 去掉windows文件名敏感字符
  83.     $path .= "/". $title .".txt\0\0";  # 合并路径,追加 \0\0
  84.     $path = encode('utf16-le', $path);
  85.     my $F = CreateFileW( $path, GENERIC_WRITE, 0, [], OPEN_ALWAYS, 0, 0);
  86.     # 这里 FILE 句柄不支持 $FILE 变量形式
  87.     try {
  88.         OsFHandleOpen(FILE, $F, "w") or die "Cannot open file";
  89.     } catch { printf "\nCan't create file: %s\n", encode('gbk', $title); return; };
  90.     binmode FILE;
  91.     print FILE $$buff;
  92.     close(FILE);
  93. }
  94. sub utf2gbk { return encode('gbk', decode('utf8', $_[0] )); }
复制代码

TOP

处理结果,提取后压缩 80MB 以内
http://523066680.ys168.com/
位置:临时/52shici

TOP

本帖最后由 523066680 于 2018-12-7 21:11 编辑

转换速度对比:
固态硬盘,D:\Temp\52shici_mobile\爱恨情仇,8828 个文件
Mojo::DOM 提取 耗时 48秒,
正则表达式提取 耗时 12秒。

正则提取,普通硬盘,350156 个文件, 980秒

TOP

perl真好用,支持DOM操作.

TOP

普通硬盘,正则提取1个文件,perl 2.7ms; powershell 7.8ms(还是在运行过一次后,内存中有文件缓存的情况下的结果)
perl的性能优化真好.

TOP

回复 8# flashercs

    适合处理文本,骆驼Perl在这方面经久耐用。不过差不多销声匿迹了,
我也只是“情怀”,几乎不向人推荐 Perl,自己玩就好。

TOP

返回列表