line | stmt | bran | cond | sub | pod | time | code |
1 | | | | | | | package HTML::Display::Common; |
2 | |
3 - 7 | | =head1 NAME
HTML::Display::Common - routines common to all HTML::Display subclasses
=cut |
8 | |
9 | | | | | | | use strict; |
10 | | | | | | | use HTML::TokeParser; |
11 | | | | | | | use URI::URL; |
12 | | | | | | | use vars qw($VERSION); |
13 | | | | | | | $VERSION='0.38'; |
14 | | | | | | | use Carp qw( croak ); |
15 | |
16 - 49 | | =head2 __PACKAGE__-E<gt>new %ARGS
Creates a new object as a blessed hash. The passed arguments are stored within
the hash. If you need to do other things in your constructor, remember to call
this constructor as well :
=for example
no warnings 'redefine';
*HTML::Display::WhizBang::display_html = sub {};
=for example begin
package HTML::Display::WhizBang;
use parent 'HTML::Display::Common';
sub new {
my ($class) = shift;
my %args = @_;
my $self = $class->SUPER::new(%args);
# do stuff
$self;
};
=for example end
=for example_testing
package main;
use HTML::Display;
my $browser = HTML::Display->new( class => "HTML::Display::WhizBang");
isa_ok($browser,"HTML::Display::Common");
=cut |
50 | |
51 | | | | | | | sub new { |
52 | | | | | | | my ($class) = shift; |
53 | | | | | | | #croak "Odd number" if @_ % 2; |
54 | | | | | | | my $self = { @_ }; |
55 | | | | | | | bless $self,$class; |
56 | | | | | | | $self; |
57 | | | | | | | }; |
58 | |
59 - 126 | | =head2 $display->display %ARGS
This is the routine used to display the HTML to the user. It takes the
following parameters :
html => SCALAR containing the HTML
file => SCALAR containing the filename of the file to be displayed
base => optional base url for the HTML, so that relative links still work
location (synonymous to base)
=head3 Basic usage :
=for example
no warnings 'redefine';
*HTML::Display::new = sub {
my $class = shift;
require HTML::Display::Dump;
return HTML::Display::Dump->new(@_);
};
=for example begin
my $html = "<html><body><h1>Hello world!</h1></body></html>";
my $browser = HTML::Display->new();
$browser->display( html => $html );
=for example end
=for example_testing
isa_ok($browser, "HTML::Display::Dump","The browser");
is( $main::_STDOUT_,"<html><body><h1>Hello world!</h1></body></html>","HTML gets output");
=head3 Location parameter :
If you fetch a page from a remote site but still want to display
it to the user, the C<location> parameter comes in very handy :
=for example
no warnings 'redefine';
*HTML::Display::new = sub {
my $class = shift;
require HTML::Display::Dump;
return HTML::Display::Dump->new(@_);
};
=for example begin
my $html = '<html><body><img src="/images/hp0.gif"></body></html>';
my $browser = HTML::Display->new();
# This will display part of the Google logo
$browser->display( html => $html, base => 'http://www.google.com' );
=for example end
=for example_testing
isa_ok($browser, "HTML::Display::Dump","The browser");
is( $main::_STDOUT_,
'<html><head><base href="http://www.google.com/" /></head><body><img src="/images/hp0.gif"></body></html>',
"HTML gets output");
$main::_STDOUT_ = "";
$browser->display( html => $html, location => 'http://www.google.com' );
is( $main::_STDOUT_,
'<html><head><base href="http://www.google.com/" /></head><body><img src="/images/hp0.gif"></body></html>',
"HTML gets output");
=cut |
127 | |
128 | | | | | | | sub display { |
129 | | | | | | | my ($self) = shift; |
130 | | | | | | | my %args; |
131 | | | | | | | if (scalar @_ == 1) { |
132 | | | | | | | %args = ( html => $_[0] ); |
133 | | | | | | | } else { |
134 | | | | | | | %args = @_; |
135 | | | | | | | }; |
136 | |
137 | | | | | | | if ($args{file}) { |
138 | | | | | | | my $filename = delete $args{file}; |
139 | | | | | | | local $/; |
140 | | | | | | | local *FILE; |
141 | | | | | | | open FILE, "<", $filename |
142 | | | | | | | or croak "Couldn't read $filename"; |
143 | | | | | | | $args{html} = <FILE>; |
144 | | | | | | | }; |
145 | |
146 | | | | | | | $args{base} = delete $args{location} |
147 | | | | | | | if (! exists $args{base} and exists $args{location}); |
148 | |
149 | | | | | | | my $new_html; |
150 | | | | | | | if (exists $args{base}) { |
151 | | | | | | | # trim to directory create BASE HREF |
152 | | | | | | | # We are carefull to not trim if we just have http://domain.com |
153 | | | | | | | my $location = URI::URL->new( $args{base} ); |
154 | | | | | | | my $path = $location->path; |
155 | | | | | | | $path =~ s%(?<!/)/[^/]*$%/%; |
156 | | | | | | | $location = sprintf "%s://%s%s", $location->scheme, $location->authority , $path; |
157 | |
158 | | | | | | | require HTML::TokeParser::Simple; |
159 | | | | | | | my $p = HTML::TokeParser::Simple->new(\$args{html}) || die 'could not create HTML::TokeParser::Simple object'; |
160 | | | | | | | my ($has_head,$has_base); |
161 | | | | | | | while (my $token = $p->get_token) { |
162 | | | | | | | if ( $token->is_start_tag('head') ) { |
163 | | | | | | | $has_head++; |
164 | | | | | | | } elsif ( $token->is_start_tag('base')) { |
165 | | | | | | | $has_base++; |
166 | | | | | | | last; |
167 | | | | | | | }; |
168 | | | | | | | }; |
169 | |
170 | | | | | | | # restart parsing |
171 | | | | | | | $p = HTML::TokeParser::Simple->new(\$args{html}) || die 'could not create HTML::TokeParser::Simple object'; |
172 | | | | | | | while (my $token = $p->get_token) { |
173 | | | | | | | if ( $token->is_start_tag('html') and not $has_head) { |
174 | | | | | | | $new_html .= $token->as_is . qq{<head><base href="$location" /></head>}; |
175 | | | | | | | } elsif ( $token->is_start_tag('head') and not $has_base) { |
176 | | | | | | | # handle an empty <head /> : |
177 | | | | | | | if ($token->as_is =~ m!^<\s*head\s*/>$!i) { |
178 | | | | | | | $new_html .= qq{<head><base href="$location" /></head>} |
179 | | | | | | | } else { |
180 | | | | | | | $new_html .= $token->as_is . qq{<base href="$location" />}; |
181 | | | | | | | }; |
182 | | | | | | | } elsif ( $token->is_start_tag('base') ) { |
183 | | | | | | | # If they already have a <base href>, give up |
184 | | | | | | | if ($token->return_attr->{href}) { |
185 | | | | | | | $new_html = $args{html}; |
186 | | | | | | | last; |
187 | | | | | | | } else { |
188 | | | | | | | $token->set_attr('href',$location); |
189 | | | | | | | $new_html .= $token->as_is; |
190 | | | | | | | }; |
191 | | | | | | | } else { |
192 | | | | | | | $new_html .= $token->as_is; |
193 | | | | | | | } |
194 | | | | | | | }; |
195 | | | | | | | } else { |
196 | | | | | | | $new_html = $args{html}; |
197 | | | | | | | }; |
198 | |
199 | | | | | | | $self->display_html($new_html); |
200 | | | | | | | }; |
201 | |
202 | | | | | | | 1; |