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

<script>Baidu_A_D("b1");</script>
<script type="text/javascript">news1();</script>COPY

=info
    523066680/vicyang
    2018-10
=cut
 
use utf8;
use Encode;
use File::Slurp;
use Mojo::DOM;
STDOUT->autoflush(1);
 
our $wdir = encode('gbk', "D:/Temp/句子大全");
chdir $wdir or warn "$!";
 
my $buff;
my @files;
my @dirs = `dir "$wdir" /ad /s /b`;
grep { s/\r?\n//; } @dirs;
 
for my $dir ( @dirs )
{
    printf "%s\n", $dir;
    chdir $dir or die "$!";
    @files = glob "*.html";
    next unless $#files >= 0;
    $buff = "";
    grep { $buff .= article( $_ ) } sort { substr($b, 0, -5) <=> substr($a, 0, -5) } @files;
    write_file( "${dir}.txt", $buff );
}
 
sub article
{
    my $file = shift;
    my $html = decode('gbk', scalar(read_file( $file )) );
    $html =~s/&nbsp;//g;
 
    $dom = Mojo::DOM->new( $html );
    # remove tags: <script>, <u>, and next/prev page 
    grep { $_->remove } $dom->at(".content")->find("script")->each;
    grep { $_->remove } $dom->at(".content")->find("u")->each;
    $dom->at(".page")->remove;
    my $title = $dom->at("h1")->all_text;
    my $text  = $dom->at(".content")->all_text;
 
    $text =~s/(\d+、)/\n$1/g;
    $text =~s/\Q$title\E//;
    $text =~s/[\r\n]+/\n/g;
    $text =~s/^\n//;
 
    my $str;
    $str  = sprintf "%s\n", encode('gbk', $title );
    $str .= sprintf "%s\n", $file;
    $str .= sprintf "%s\n", encode('gbk', $text);
    return $str;
}COPY

• 多线程抓取HTML
  

=info
    523066680/vicyang
    2018-10
=cut
 
use Modern::Perl;
use utf8;
use Encode;
use File::Path;
use File::Slurp;
use LWP::UserAgent;
use Mojo::DOM;
use threads;
use threads::shared;
use Time::HiRes qw/sleep time/;
STDOUT->autoflush(1);
 
our $idx = 0;
our @ths;
our $iter   :shared;
our $failed :shared;
 
our $main = "http://www.1juzi.com";
our $wdir = encode('gbk', "D:/temp/句子大全_byNo.");
mkpath $wdir unless -e $wdir;
chdir $wdir;
 
$iter = 1;
$failed = 0;
#创建线程
grep { push @ths, threads->create( \&func, $_ ) } ( 0 .. 3 );
 
while ( $failed <= 5 ) { sleep 1.0; }
 
#线程终结和分离
grep { $_->detach() } threads->list(threads::all);
 
sub func
{
    our ($main, $failed, $iter);
    my $idx = shift;
    my ($link, $file);
    my $ua = LWP::UserAgent->new( keep_alive => 1, timemout => 6 );
 
    $SIG{'BREAK'} = sub { threads->exit() };
 
    my $res;
    my $retry;
    my $task;
 
    while (1)
    {
        {
            lock($iter);
            $task = $iter++;
        }
 
        $link = "${main}/new/${task}.html";
        $file = "${task}.html";
        if ( -e $file ) { printf "%s exists\n", $file; next; }
 
        printf "%s\n", $file;
        $retry = 0;
        do 
        {
            $res = $ua->get( $link );
            if ($retry > 0) 
            {
                printf "[%d]%s%s, retry times: %d\n", $idx, "  "x($idx+1), $file, $retry;
                sleep 0.5; 
            }
            $retry++;
        }
        until ( $res->is_success() or ($retry > 3) );
 
        if ( $res->is_success ) { write_file( $file, $res->content ); } 
        else { $failed++; }
    }
}COPY

• 内容提取 分类汇总
  

=info
    523066680/vicyang
    2018-10
=cut
 
use utf8;
use Encode;
use File::Path;
use File::Slurp;
use Mojo::DOM;
STDOUT->autoflush(1);
 
our $wdir = encode('gbk', "D:/Temp/句子大全_byNo");
chdir $wdir or warn "$!";
 
our %FH;
my @files = `dir "$wdir" /a-d /b`;
grep { s/\r?\n// } @files;
@files = sort { substr($a, 0, -5) <=> substr($b, 0, -5) } @files;
 
grep { 
    article($_); 
    printf "%s\n", $_;
} @files;
 
for my $v (values %FH) { close $v }
 
sub article
{
    our %FH;
    my $page = shift;
    my $html = decode('gbk', scalar(read_file( $page )) );
    $html =~s/&nbsp;//g;
 
    $dom = Mojo::DOM->new( $html );
    # path
    my @path = @{ $dom->at(".path")->find("a")->map("text") };
    grep { $_ = encode("gbk", $_) } @path;
 
    my $path = "../". join("/", @path[0,1]);
    my $file = "${path}/${path[-1]}.txt";
    mkpath $path unless -e $path;
 
    unless ( exists $FH{$file} )
    {
        printf "create %s\n", $file;
        open $FH{$file}, ">:raw:crlf", $file;
        $FH{$file}->autoflush(1);
    }
 
    # remove tags: <script>, <u>, and next/prev page 
    grep { $_->remove } $dom->at(".content")->find("script")->each;
    grep { $_->remove } $dom->at(".content")->find("u")->each;
    $dom->at(".page")->remove;
    my $title = $dom->at("h1")->all_text;
    my $text  = $dom->at(".content")->all_text;
 
    $text =~s/(\d+、)/\n$1/g;
    $text =~s/\Q$title\E//;
    $text =~s/[\r\n]+/\n/g;
    $text =~s/^\n//;
 
    my $str;
    $str  = sprintf "%s\n", encode('gbk', $title );
    $str .= sprintf "%s\n", $page;
    $str .= sprintf "%s\n", encode('gbk', $text);
 
    print { $FH{$file} } $str;
}COPY