[Perl]P站视频下载

There's more than one way to do it!
https://metacpan.org http://perlmonks.org
回复
头像
523066680
Administrator
Administrator
帖子: 573
注册时间: 2016年07月19日 12:14
联系:

[Perl]P站视频下载

帖子 523066680 »

P站大家懂的 :confidence

用到的模块:
JE (Javascript解析库)
Mojolicious (网络)

使用方法,将指定视频网址末尾15位的keyword复制放到 @list 数组中。以及找到Agent的地址更新到proxy设置

代码: 全选

use utf8;
use Encode;
use JE;
use Modern::Perl;
use File::Slurp;
use Mojo::UserAgent;
use Win32::Unicode::File;
use JSON qw/from_json to_json/;
STDOUT->autoflush(1);

my $JE = new JE;
my $ua = Mojo::UserAgent->new();
init_ua();

my %headers;
init_headers(\%headers);

# 这里放准备下载的 keyword 清单
my @list = qw/
ph60e6662d3221e
ph5dc9ba7f1b...
/;

grep { getVideo($_) } @list;

sub getVideo
{
    my $viewkey = shift;
    my $url = "https://cn.pornhub.com/view_video.php?viewkey=${viewkey}";

    my $res = $ua->get( $url )->result;
    #print $html->body;
    my $js = $res->dom->at(".video-wrapper script")->all_text;
    my $id = $res->dom->at("#player")->attr("data-video-id");
    my $title = $res->dom->at("title")->text; #unicode
    $title =~s/\s+- Pornhub\.com//i;
    $title =~s/[\\\/:*?"<>|]/ /g; #替换部分windows文件名不支持的字符
    printf "%s %s\n", $id, gbk($title);

    my $file = "E:/迅雷下载/${viewkey} ${title}.mp4";
    if ( file_type( 'e' => $file ) ) {
        printf "%s: file already exists\n", $viewkey;
        return;
    }

    write_file("src.js", $js);

    $JE->eval( $js );
    my $x = $JE->value;
    # 第三个节点对应 720P,->value 转换为Perl字符串
    my $videolink = $x->{"qualityItems_${id}"}[2]{"url"}->value;
    say $videolink;

    my $tx = $ua->get( $videolink );
    print $tx->error ? "\nDownloading failed: ".$tx->error->{message} : "\nDownloading finished!\n";
    my $fh = Win32::Unicode::File->new("wb", $file);
    $fh->write( $tx->result->body );
    $fh->close();
}

sub init_headers
{
    my $ref = shift;
    %$ref =  
    (
    'accept' => 'text/html,application/xhtml+xml,application/xml;q=0.9,image/avif,image/webp,image/apng',
    'accept-encoding' => 'gzip, deflate, br',
    'accept-language' => 'zh-CN,zh;q=0.9,zh-TW;q=0.8',
    'user-agent' => 'Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/93.0.4577.82 Safari/537.36',
    );
}

sub init_ua
{
    $ua = $ua->max_redirects(5);
    $ua = $ua->connect_timeout(10);

    # Proxy server to use for HTTPS and WebSocket requests.
    # https://docs.mojolicious.org/Mojo/UserAgent/Proxy#https
    $ua->proxy->https("http://sri:secret\@127.0.0.1:10809")->http("http://sri:secret\@127.0.0.1:10809");
    # 代理的具体地址,在代理工具设置、菜单中寻找

    # 进度显示
    $ua->on(start => sub {
        my ($ua, $tx) = @_;
        $tx->req->once(finish => sub {
            $tx->res->on(progress => sub {
                state $prev = 0;
                my $msg = shift;
                return unless my $len = $msg->headers->content_length;
                my $size = $msg->content->progress;
                my $progress = int($size / ($len / 100));
                if ( $progress ne $prev ) {
                    printf "%d%%\t", $progress;
                }
                $prev = $progress;
            });
        });
    });
}


sub gbk { encode('gbk', $_[0]) }
sub utf8 { encode('utf8', $_[0]) }
sub u2gbk { encode('gbk', decode('utf8', $_[0])) }
sub uni { decode('utf8', $_[0]) }
头像
523066680
Administrator
Administrator
帖子: 573
注册时间: 2016年07月19日 12:14
联系:

Re: [Perl]P站视频下载

帖子 523066680 »

众所周知P站是一个学习网站

图片
头像
523066680
Administrator
Administrator
帖子: 573
注册时间: 2016年07月19日 12:14
联系:

Re: [Perl]P站视频下载

帖子 523066680 »

avatar_origami_cat120X.jpg
(2.26 KiB) 已下载 8 次
回复

在线用户

正浏览此版面之用户: 没有注册用户 和 0 访客