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

523066680

该网站的文章页面有手机版的，体积比PC端页面小一半以上，可以减少数据量。
全部下载完 7-8个G左右

=info
    523066680/vicyang
    2018-12
=cut

use Encode;
use Modern::Perl;
use File::Slurp;
use Mojo::UserAgent;
use File::Path qw/mkpath/;
use Try::Tiny;
STDOUT->autoflush(1);

our $ua = Mojo::UserAgent->new();
our $main = "http://www.52shici.com";
our $wdir = "D:/temp/52shici_mobile";
mkpath $wdir unless -e $wdir;

#获取主类
my $max;
my $route;
my $item;
my $res = $ua->get( $main )->result;
for my $e ($res->dom->find(".works-type-list a")->each )
{
    $route = $e->attr("href");
    $item = encode('gbk', $e->text);
    printf "%s %s\n", $route, $item; 
    $max = get_max_pgcode( "${main}/${route}" );
    get_article( "${main}/${route}", $max, $item );
}

sub get_article
{
    our ($main, $wdir);
    my ( $link, $max, $item ) = @_;
    my $res;
    my $detail;
    my $path = "${wdir}/${item}";
    my $file;
    my $target;

    mkpath $path unless -e $path;
    chdir $path;

    # 遍历所有页码
    for my $code ( 1 .. $max )
    {
        printf "%s, Page code: %d/%d\n", $item, $code, $max;
        $res = try_to_get( "${link}&page=${code}" );

        my $count = 1;
        # 每一篇文章
        for my $e ( $res->dom->find(".l a")->each )
        {
            # URL中的请求部分
            $e->attr('href') =~/\?(.*)&/;
            $file = $1 .".html";
            $target = $main ."/". $e->attr('href');
            $target =~s/&.*$//;
            $target =~s/www\./m\./;

            next if -e $file;
            $detail = try_to_get( $target );
            write_file( $file , $detail->body );
        }
    }
}

sub get_max_pgcode
{
    my ( $link ) = @_;
    my $res = $ua->get( $link )->result;
    my $keyword = $res->dom->at(".mt")->text;
    if ($keyword =~/1\/(\d+)/) { return $1; } 
    else { printf "Failed to get max page code\n"; return undef }
}

sub try_to_get
{
    our ($ua);
    my ($link) = @_;
    my $res;
    my $times = 0;

    while (1)
    {
        try { $res = $ua->get( $link )->result; }
        catch { printf "Error %s, retry: %d\n", $_, $times; };
        $times++;
        last if (defined $res and $res->is_success);
        exit if ( $times > 5 );
    }
    return $res;
}
复制代码

523066680

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

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

523066680

在处理的时候又遇到“彩蛋”了：

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

523066680

提取正文的代码，Mojo::DOM 解析HTML，提取元素。
保存的文件名格式为 ：作者+标题+诗歌类型+页面ID

=info
    523066680/vicyang
    2018-12
=cut

use Mojo::DOM;
use File::Slurp;
use Encode;
use File::Path;
use Try::Tiny;
use File::Basename qw/basename/;
use Win32API::File qw(:ALL);
STDOUT->autoflush(1);

our $src = "D:/temp/52shici_mobile";
our $dst = "D:/temp/52shici_extract";
my $item;
my (@files, %already, $pgname, $dirlist);
my ($rate, $prev);

for my $subdir ( glob "${src}/*" )
{
    printf "%s\n", $subdir;
    $item = basename($subdir);
    mkpath "${dst}/${item}" unless -e "${dst}/${item}";

    # 需要处理的文件列表
    @files = glob "${subdir}/*";

    # 创建现有名单哈希表
    %already = ();
    my $dirlist = decode("utf16-le", `cmd /U /C dir /b \"${dst}/${item}\"`);
    grep { $_=~/(works_id=\d+)/; $already{$1} = 1; } split("\r\n", $dirlist);

    ($rate, $prev) = (0.0, 0.0);
    for my $id ( 0 .. $#files )
    {
        # 显示进度，百分率
        $rate = $id / $#files * 100.0;
        if ( ($rate-$prev) >= 1.0 ) {
            printf "%d\% ", $rate;
            $prev = $rate;
        }
        $pgname = basename($files[$id], ".html");
        next if exists $already{$pgname};
        abstract( "${dst}/${item}", $item, $files[$id] );
    }
    printf "\n";

    exit;
}

sub abstract
{
    my ($path, $item, $page) = @_;
    my $html = read_file( $page );
    $html=~s/\ //g;
    #$html=~s/<script>.*$//es;

    my $dom = Mojo::DOM->new( $html );
    my $buff = "";
    my ($fname, $head) = ("", "");
    my $id = basename($page, ".html");

    # 作者 标题 类型 日期
    my $author = $dom->at(".works-author a")->text;
    my $title  = $dom->at(".works-title")->text;
    my $type   = $dom->at(".works-type")->text;
    my $date   = $dom->at(".works-author")->text;

    $author =~s/^\s+//;  # 去掉开头space
    $date =~s/:/./g;
    $head  = join(" ", $author, $title, $type, $date );
    $fname = join(" ", $author, $title, $type, $id );
    #printf "%s %s\n", utf2gbk($fname), $page;

    $buff .= $head;
    $buff .= $dom->at("#content_box")->all_text;

    $buff=~s/\r?\n([ \t]+)?/#MARK/g;
    $buff=~s/ {2,}/ /sge;               # 合并连续空格
    $buff=~s/(#MARK){2,}/#MARK#MARK/g;  # 合并超过两行的换行
    $buff=~s/#MARK/\r\n/g;
    
    #write_file( "${path}/${title}.txt", {binmode => ":raw"}, $buff );
    $path = decode('gbk', $path);
    $fname = decode('utf8', $fname);

    #去掉控制字符（某些文章标题就出现了<0x08>,<0x03>），并且是在Unicode编码下替换
    $fname =~s/\p{IsCntrl}//g;
    create_with_unicode_fname( $path, $fname, \$buff );
}

sub create_with_unicode_fname
{
    my ($path, $title, $buff) = @_;
    $title =~s/[\Q*?":<>|\\\/\E]/ /g;     # 去掉windows文件名敏感字符
    $path .= "/". $title .".txt\0\0";  # 合并路径，追加 \0\0
    $path = encode('utf16-le', $path);

    my $F = CreateFileW( $path, GENERIC_WRITE, 0, [], OPEN_ALWAYS, 0, 0);

    # 这里 FILE 句柄不支持 $FILE 变量形式
    try {
        OsFHandleOpen(FILE, $F, "w") or die "Cannot open file";
    } catch { printf "\nCan't create file: %s\n", encode('gbk', $title); return; };
    binmode FILE;
    print FILE $$buff;
    close(FILE);
}

sub utf2gbk { return encode('gbk', decode('utf8', $_[0] )); }
复制代码

523066680

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

523066680

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

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

flashercs

perl真好用,支持DOM操作.

flashercs

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

523066680

回复 8# flashercs

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