File Coverage

File:blib/lib/HTML/Display/Common.pm
Coverage:0.0%

linestmtbrancondsubpodtimecode
1package HTML::Display::Common;
2
3 - 7
=head1 NAME

HTML::Display::Common - routines common to all HTML::Display subclasses

=cut
8
9use strict;
10use HTML::TokeParser;
11use URI::URL;
12use vars qw($VERSION);
13$VERSION='0.38';
14use 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
51sub 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
128sub 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
2021;