line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package URL::Transform::using::HTML::Parser; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
=head1 NAME |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
URL::Transform::using::HTML::Parser - HTML::Parse parsing of the html/xml for url transformation |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
=head1 SYNOPSIS |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
my $urlt = URL::Transform::using::HTML::Parser->new( |
10
|
|
|
|
|
|
|
'output_function' => sub { $output .= "@_" }, |
11
|
|
|
|
|
|
|
'transform_function' => sub { return (join '|', @_) }, |
12
|
|
|
|
|
|
|
); |
13
|
|
|
|
|
|
|
$urlt->parse_file($Bin.'/data/URL-Transform-01.html'); |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
print "and this is the output: ", $output; |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
=head1 DESCRIPTION |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
Using this module you can performs an url transformation on the HTML/XML documents. |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
This module is used by L. |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
The url matching algorithm is taken from L/eg/hrefsub example |
25
|
|
|
|
|
|
|
script. |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
=cut |
28
|
|
|
|
|
|
|
|
29
|
1
|
|
|
1
|
|
1790
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
34
|
|
30
|
1
|
|
|
1
|
|
4
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
38
|
|
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
our $VERSION = '0.01'; |
33
|
|
|
|
|
|
|
|
34
|
1
|
|
|
1
|
|
1171
|
use HTML::Parser (); |
|
1
|
|
|
|
|
6918
|
|
|
1
|
|
|
|
|
59
|
|
35
|
1
|
|
|
1
|
|
9
|
use Carp::Clan; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
9
|
|
36
|
1
|
|
|
1
|
|
174
|
use English '$EVAL_ERROR'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
7
|
|
37
|
|
|
|
|
|
|
|
38
|
1
|
|
|
1
|
|
124
|
use URL::Transform (); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
43
|
|
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
# Construct a hash of tag names that may have links. |
42
|
|
|
|
|
|
|
my $_link_tags = URL::Transform::link_tags(); |
43
|
|
|
|
|
|
|
my $_js_attributes = URL::Transform::js_attributes(); |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
|
46
|
1
|
|
|
1
|
|
6
|
use base 'Class::Accessor::Fast'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
1075
|
|
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
=head1 PROPERTIES |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
output_function |
51
|
|
|
|
|
|
|
transform_function |
52
|
|
|
|
|
|
|
parser_for |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
_html_parser |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
=cut |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
__PACKAGE__->mk_accessors(qw{ |
59
|
|
|
|
|
|
|
output_function |
60
|
|
|
|
|
|
|
transform_function |
61
|
|
|
|
|
|
|
parser_for |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
_html_parser |
64
|
|
|
|
|
|
|
}); |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
=head1 METHODS |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
=cut |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
=head2 new |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
Object constructor. |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
Requires: |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
output_function |
78
|
|
|
|
|
|
|
transform_function |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
Optional: |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
parser_for |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
=cut |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
sub new { |
87
|
5
|
|
|
5
|
1
|
102
|
my $class = shift; |
88
|
|
|
|
|
|
|
|
89
|
5
|
|
|
|
|
35
|
my $self = $class->SUPER::new({ @_ }); |
90
|
|
|
|
|
|
|
|
91
|
5
|
|
|
|
|
74
|
my $output_function = $self->output_function; |
92
|
5
|
|
|
|
|
38
|
my $transform_function = $self->transform_function; |
93
|
|
|
|
|
|
|
|
94
|
5
|
50
|
|
|
|
34
|
croak 'pass print function' |
95
|
|
|
|
|
|
|
if not (ref $output_function eq 'CODE'); |
96
|
|
|
|
|
|
|
|
97
|
5
|
50
|
|
|
|
14
|
croak 'pass transform url function' |
98
|
|
|
|
|
|
|
if not (ref $transform_function eq 'CODE'); |
99
|
|
|
|
|
|
|
|
100
|
5
|
|
|
26
|
|
23
|
$transform_function = sub { $self->transform_function_wrapper(@_) }; |
|
26
|
|
|
|
|
57
|
|
101
|
|
|
|
|
|
|
|
102
|
5
|
|
|
|
|
43
|
my $html_parser = HTML::Parser->new(api_version => 3); |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
# The default is to print everything as it is. |
105
|
|
|
|
|
|
|
$html_parser->handler( |
106
|
|
|
|
|
|
|
default => sub { |
107
|
15
|
|
|
15
|
|
659
|
$output_function->(@_); |
108
|
5
|
|
|
|
|
199
|
}, "text" |
109
|
|
|
|
|
|
|
); |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
# cleanup current tag on every end tag |
112
|
|
|
|
|
|
|
# should work fine for our purpouse as we are not interrested in nested tags |
113
|
5
|
|
|
|
|
10
|
my $current_tag = ''; |
114
|
|
|
|
|
|
|
$html_parser->handler( |
115
|
|
|
|
|
|
|
end => sub { |
116
|
47
|
|
|
47
|
|
308
|
$current_tag = ''; |
117
|
47
|
|
|
|
|
64
|
my $text = shift; |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
# rename to in case javascript is removed |
120
|
47
|
50
|
|
|
|
118
|
if ($self->parser_for->('application/x-javascript') eq 'Remove') { |
121
|
47
|
100
|
|
|
|
117
|
$text = '' if $text =~ m{^
|
122
|
|
|
|
|
|
|
} |
123
|
|
|
|
|
|
|
|
124
|
47
|
|
|
|
|
171
|
$output_function->($text); |
125
|
5
|
|
|
|
|
56
|
}, "text" |
126
|
|
|
|
|
|
|
); |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
# Links inside the text of the tag (just |