File Coverage

blib/lib/HTML/Display/Common.pm

Criterion	Covered	Total	%
statement	80	80	100.0
branch	21	24	87.5
condition	11	13	84.6
subroutine	13	15	86.6
pod	2	2	100.0
total	127	134	94.7

package HTML::Display::Common;

=head1 NAME

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

=cut

use strict;
use HTML::TokeParser;
use URI::URL;
use vars qw($VERSION);
$VERSION='0.40';
use Carp qw( croak );

=head2 __PACKAGE__-Enew %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

sub new {
  my ($class) = shift;
  #croak "Odd number" if @_ % 2;
  my $self = { @_ };
  bless $self,$class;
  $self;
};

=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 = "Hello world!";
  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_,"Hello world!","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 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 = '';
  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 gets output");
  $main::_STDOUT_ = "";
  $browser->display( html => $html, location => 'http://www.google.com' );
  is( $main::_STDOUT_,
  	'',
  	"HTML gets output");

=cut

sub display {
  my ($self) = shift;
  my %args;
  if (scalar @_ == 1) {
    %args = ( html => $_[0] );
  } else {
    %args = @_;
  };

  if ($args{file}) {
    my $filename = delete $args{file};
    local $/;
    local *FILE;
    open FILE, "<", $filename
      or croak "Couldn't read $filename";
    $args{html} = ;
  };

  $args{base} = delete $args{location}
    if (! exists $args{base} and exists $args{location});

  my $new_html;
  if (exists $args{base}) {
    # trim to directory create BASE HREF
    # We are carefull to not trim if we just have http://domain.com
    my $location = URI::URL->new( $args{base} );
    my $path = $location->path;
    $path =~ s%(?
    $location = sprintf "%s://%s%s", $location->scheme, $location->authority , $path;

    require HTML::TokeParser::Simple;
    my $p = HTML::TokeParser::Simple->new(\$args{html}) || die 'could not create HTML::TokeParser::Simple object';
    my ($has_head,$has_base);
    while (my $token = $p->get_token) {
      if ( $token->is_start_tag('head') ) {
        $has_head++;
      } elsif ( $token->is_start_tag('base')) {
        $has_base++;
        last;
      };
    };

    # restart parsing
    $p = HTML::TokeParser::Simple->new(\$args{html}) || die 'could not create HTML::TokeParser::Simple object';
    while (my $token = $p->get_token) {
      if ( $token->is_start_tag('html') and not $has_head) {
        $new_html .= $token->as_is . qq{};
      } elsif ( $token->is_start_tag('head') and not $has_base) {
        # handle an empty  :
        if ($token->as_is =~ m!^<\s*head\s*/>$!i) {
          $new_html .= qq{}
        } else {
          $new_html .= $token->as_is . qq{};
        };
      } elsif ( $token->is_start_tag('base') ) {
        # If they already have a , give up
        if ($token->return_attr->{href}) {
          $new_html = $args{html};
          last;
        } else {
          $token->set_attr('href',$location);
          $new_html .= $token->as_is;
        };
      } else {
        $new_html .= $token->as_is;
      }
    };
  } else {
    $new_html = $args{html};
  };

  $self->display_html($new_html);
};

=head1 AUTHOR

Copyright (c) 2004-2013 Max Maischein C<<  >>

=head1 LICENSE

This module is released under the same terms as Perl itself.

=cut


1;