1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
|
## ----------------------------------------------------------------------------
# Auto::FetchTitle::Plugin::2ch.
# -----------------------------------------------------------------------------
# Mastering programmed by YAMASHINA Hio
#
# Copyright 2008 YAMASHINA Hio
# -----------------------------------------------------------------------------
# $Id: 2ch.pm 15314 2008-07-06 15:32:46Z hio $
# -----------------------------------------------------------------------------
package Auto::FetchTitle::Plugin::2ch;
use strict;
use warnings;
use base 'Auto::FetchTitle::Plugin';
our $DEBUG;
*DEBUG = \$Auto::FetchTitle::DEBUG;
1;
# -----------------------------------------------------------------------------
# $pkg->new(\%config).
#
sub new
{
my $pkg = shift;
my $this = $pkg->SUPER::new(@_);
$this;
}
# -----------------------------------------------------------------------------
# $obj->register($context).
#
sub register
{
my $this = shift;
my $context = shift;
$context->register_hook($this, {
name => '2ch',
'filter.prereq' => \&filter_prereq,
'filter.response' => \&filter_response,
});
}
# -----------------------------------------------------------------------------
# $this->filter_prereq($ctx, $arg);
# (impl:fetchtitle-filter)
# 2ch/prereq.
#
sub filter_prereq
{
my $this = shift;
my $ctx = shift;
my $arg = shift;
my $req =$arg->{req};
if( $req->{url} =~ m{^http://(\w+)\.2ch\.net/test/read\.(?:html|cgi)/(\w+)/(\d+)/} )
{
$req->{redirect} = "http://$1.2ch.net/$2/dat/$3.dat";
}
$this;
}
# -----------------------------------------------------------------------------
# $this->filter_response($ctx, $arg).
# (impl:fetchtitle-filter)
# 2ch/response.
#
sub filter_response
{
my $this = shift;
my $ctx = shift;
my $arg = shift;
my $req = $arg->{req};
my $response = $req->{response};
if( !ref($response) )
{
$DEBUG and $ctx->_debug($req, "debug: - - skip/not ref");
return;
}
if( $req->{result}{status_code}!=200 )
{
$DEBUG and $ctx->_debug($req, "debug: - - skip/not success:$req->{result}{status_code}");
return;
}
if( $req->{url} !~ m{^http://\w+\.2ch\.net/\w+/dat/\d+\.dat\z} )
{
$DEBUG and $ctx->_debug($req, "debug: - - skip/not 2ch.dat");
return;
}
my ($line) = $req->{result}{decoded_content} =~ /(.*)/ ? $1 : '';
my ($name, $email, $date_id, $text, $title) = split(/<>/, $line);
my ($date, $id) = $date_id && $date_id =~ /(.*) (.*)/ ? ($1, $2) : ($date_id, '');
$title or return;
$req->{result}{result} = $title;
}
# -----------------------------------------------------------------------------
# End of Module.
# -----------------------------------------------------------------------------
# -----------------------------------------------------------------------------
# End of File.
# -----------------------------------------------------------------------------
__END__
=encoding utf8
=for stopwords
YAMASHINA
Hio
ACKNOWLEDGEMENTS
AnnoCPAN
CPAN
RT
|
