##################
package HTML::TokeParser::Simple;
##################
use strict;
use Carp;
use HTML::TokeParser;
use vars qw/ @ISA $VERSION $AUTOLOAD /;
$VERSION = '1.3';
@ISA = qw/ HTML::TokeParser /;

use constant GET_TAG     => 1;
use constant GET_TOKEN   => 0;
use constant START_TAG   => 'S';
use constant END_TAG     => 'E';
use constant TEXT        => 'T';
use constant COMMENT     => 'C';
use constant DECLARATION => 'D';
use constant PROCESS_INSTRUCTION => 'PI';

my %token = (
	S => {
		_name   => 'START_TAG',
		tag     => 1,
		attr    => 2,
		attrseq => 3,
		text    => 4
	},
	E => {
		_name => 'END_TAG',
		tag   => 1,
		text  => 2
	},
	T => {
		_name => 'TEXT',
		text  => 1
	},
	C => {
		_name => 'COMMENT',
		text  => 1
	},
	D => {
		_name => 'DECLARATION',
		text  => 1
	},
	PI => {
		_name  => 'PROCESS_INSTRUCTION',
		token0 => 1,
		text   => 2
	}
);

# constructors

sub get_token {
	my $self = shift;
	my ( @args ) = @_;
	my $token = $self->SUPER::get_token( @args );
	return if ! defined $token;
	bless $token, ref $self;
}

sub get_tag {
	my $self = shift;
	my ( @args ) = @_;
	my $token = $self->SUPER::get_tag( @args );
	return if ! defined $token;
	bless $token, ref $self;
}

# return_foo methods

sub return_text {
	my ( $self, $method ) = _synch_arrays( shift );
	my $type = $self->[0];
	my $text = $self->[ $token{ $type }{ text } ];
	shift @$self if $method == GET_TAG;
	return $text;
}

sub return_tag {
	my $self = shift;
	if ( $self->_is( START_TAG ) or $self->_is( END_TAG ) ) {
		my $type = $self->[0];
		return $self->[ $token{ $type }{ tag } ];
	}
	return '';
}

sub return_token0 {
	my $self = shift;
	if ( $self->is_process_instruction ) {
		return $self->[ $token{ +PROCESS_INSTRUCTION }{ token0 } ];
	}
	return '';
}

sub return_attr {
	my $self = shift;
	$self->_attr_handler( 'attr' );
}

sub return_attrseq {
	my $self = shift;
	$self->_attr_handler( 'attrseq' );
}

# is_foo methods

sub is_declaration {
	my $self = shift;
	return $self->_is( DECLARATION );
}

sub is_text {
	my $self = shift;
	return $self->_is( TEXT );
}

sub is_process_instruction {
	my $self = shift;
	return $self->_is( PROCESS_INSTRUCTION );
}

sub is_comment {
	my $self = shift;
	return $self->_is( COMMENT );
}

sub is_tag {
	my $self = shift;
	return $self->is_start_tag( @_ ) || $self->is_end_tag( @_ );
}

sub is_start_tag {
	my ( $self, $method ) = _synch_arrays( shift );
	my $tag = shift || '';
	return $self->_start_end_handler( START_TAG, $tag );
}

sub is_end_tag {
	my ( $self, $method ) = _synch_arrays( shift );
	my $tag = shift || '';
	return $self->_start_end_handler( END_TAG, $tag );
}

# private methods

sub _start_end_handler {
	my ( $self, $requested_type, $tag ) = @_;
	my $result = $self->_is( $requested_type );
	return $result if ! $tag or ! $result;
	$tag = lc $tag;
	# strip leading / if they supplied it
	$tag =~ s{^/}{};
	return $self->[$token{ $requested_type }{ tag }] =~ m{^/?$tag$};
}

sub _is {
	my ( $self, $method ) = _synch_arrays( shift );
	my $type   = shift;
	my $result = $self->[0] eq $type;
	# if token was created with something like $p->get_tag, then we
	# unshifted the tag type on the array to synchronize indices with
	# return value of $p->get_token
	shift @$self if $method == GET_TAG;
	return $result;
}

sub _attr_handler {
	my ( $self, $method ) = _synch_arrays( shift );
	my $request = shift;
	my $attr = '';
	if ( $self->_is( START_TAG ) ) {
		$attr = $self->[ $token{ +START_TAG }{ $request } ];
	}
	shift @$self if $method == GET_TAG;
	return $attr;
}

sub _synch_arrays {
	# if the method is called from a token generated by the get_tag() method,
	# the returned array reference will be identical to a start or end tag
	# token returned by get_token() *except* the first element in the reference
	# will not be an identifier like 'S' or 'E'
	
	my $array_ref = shift;
	my $tag_func = GET_TOKEN;

	if ( ! grep { $array_ref->[0] eq $_ } keys %token ) {
		# created with get_tag() method, so we need
		# to munge the array to match the get_token() array
		# After this is called, and before the method returns, you must
		# use something like the following:
		# shift @$self if $method == GET_TAG;
		$tag_func = GET_TAG;
		if ( '/' ne substr $array_ref->[0], 0, 1 ) {
			unshift @$array_ref, 'S';
		}
		else {
			unshift @$array_ref, 'E';
		}
	}
	return ( $array_ref, $tag_func );
}

1;
__END__

=head1 NAME

HTML::TokeParser::Simple - easy to use HTML::TokeParser interface

=head1 SYNOPSIS

 use HTML::TokeParser::Simple;
 my $p = HTML::TokeParser::Simple->new( $somefile );

 while ( my $token = $p->get_token ) {
     # This prints all text in an HTML doc (i.e., it strips the HTML)
     next if ! $token->is_text;
     print $token->return_text;
 }


=head1 DESCRIPTION

C<HTML::TokeParser> is a fairly common method of parsing HTML.  However, the
tokens returned are not exactly intuitive to parse:

 ["S",  $tag, $attr, $attrseq, $text]
 ["E",  $tag, $text]
 ["T",  $text, $is_data]
 ["C",  $text]
 ["D",  $text]
 ["PI", $token0, $text]

To simplify this, C<HTML::TokeParser::Simple> allows the user ask more
intuitive (read: more self-documenting) questions about the tokens returned.
Specifically, there are 7 C<is_foo> type methods and 5 C<return_bar> type
methods.  The C<is_> methods allow you to determine the token type and the
C<return_> methods get the data that you need.

Since this is a subclass of C<HTML::TokeParser>, all C<HTML::TokeParser>
methods are available.  To truly appreciate the power of this module, please
read the documentation for C<HTML::TokeParser> and C<HTML::Parser>.

The following will be brief descriptions of the available methods followed by
examples.

=head1 C<is_> Methods

=over 4

=item * C<is_start_tag>

Use this to determine if you have a start tag.  An optional "tag type" may be
passed.  This will allow you to match if it's a I<particular> start tag.  The
supplied tag is case-insensitive.

 if ( $token->is_start_tag( 'font' ) ) { ... }

=item * C<is_end_tag.>

Use this to determine if you have an end tag.  An optional "tag type" may be
passed.  This will allow you to match if it's a I<particular> end tag.  The
supplied tag is case-insensitive.

When testing for an end tag, the forward slash on the tag is optional.

 while ( $token = $p->get_token ) {
   if ( $token->is_end_tag( 'form' ) ) { ... }
 }

Or:

 while ( $token = $p->get_token ) {
   if ( $token->is_end_tag( '/form' ) ) { ... }
 }

=item * C<is_tag>

Use this to determine if you have any tag.  An optional "tag type" may be
passed.  This will allow you to match if it's a I<particular> tag.  The
supplied tag is case-insensitive.

 if ( $token->is_tag ) { ... }

=item * C<is_text>

Use this to determine if you have text.  Note that this is I<not> to be
confused with the C<return_text> method described below!  C<is_text> will
identify text that the user typically sees display in the Web browser.

=item * C<is_comment>

Are you still reading this?  Nobody reads POD.  Don't you know you're supposed
to go to CLPM, ask a question that's answered in the POD and get flamed?  It's
a rite of passage.

Really.

C<is_comment> is used to identify comments.  See the HTML::Parser documentation
for more information about comments.  There's more than you might think.

=item * C<is_declaration>

This will match the DTD at the top of your HTML. (You I<do> use DTD's, don't
you?)

=item * C<is_process_instruction>

Process Instructions are from XML.  This is very handy if you need to parse out
PHP and similar things with a parser.

=back

=head1 The C<return_> methods

=head2 Note:

In case it's not blindingly obvious (I've been bitten by this myself when
writing the tests), you should generally test what type of token you have
B<before> you call some C<return_> methods.  For example, if you have an end
tag, there is no point in calling the C<return_attrseq> method.  Calling an
innapropriate method will return an empty string.

As noted for the C<is_> methods, these methods are case-insensitive after the
C<return_> part.

=over 4

=item * C<return_tag>

Do you have a start tag or end tag?  This will return the type (lower case).

=item * C<return_attr>

If you have a start tag, this will return a hash ref with the attribute names
as keys and the values as the values.

=item * C<return_attrseq>

For a start tag, this is an array reference with the sequence of the
attributes, if any.

=item * C<return_text>

This is the exact text of whatever the token is representing.

=item * C<return_token0>

For processing instructions, this will return the token found immediately after
the opening tag.  Example:  For <?php, "php" will be the start of the returned
string.

=back

=head1 Examples

=head2 Finding comments

For some strange reason, your Pointy-Haired Boss (PHB) is convinced that the
graphics department is making fun of him by embedding rude things about him in
HTML comments.  You need to get all HTML comments from the HTML.

 use strict;
 use HTML::TokeParser::Simple;

 my @html_docs = glob( "*.html" );

 open PHB, "> phbreport.txt" or die "Cannot open phbreport for writing: $!";

 foreach my $doc ( @html_docs ) {
     print "Processing $doc\n";
     my $p = HTML::TokeParser::Simple->new( $doc );
     while ( my $token = $p->get_token ) {
         next if ! $token->is_comment;
         print PHB $token->return_text, "\n";
     }
 }

 close PHB;

=head2 Stripping Comments

Uh oh.  Turns out that your PHB was right for a change.  Many of the comments
in the HTML weren't very polite.  Since your entire graphics department was
just fired, it falls on you need to strip those comments from the HTML.

 use strict;
 use HTML::TokeParser::Simple;

 my $new_folder = 'no_comment/';
 my @html_docs  = glob( "*.html" );

 foreach my $doc ( @html_docs ) {
     print "Processing $doc\n";
     my $new_file = "$new_folder$doc";

     open PHB, "> $new_file" or die "Cannot open $new_file for writing: $!";

     my $p = HTML::TokeParser::Simple->new( $doc );
     while ( my $token = $p->get_token ) {
         next if $token->is_comment;
         print PHB $token->return_text;
     }
     close PHB;
 }

=head2 Changing form tags

Your company was foo.com and now is bar.com.  Unfortunately, whoever wrote your
HTML decided to hardcode "http://www.foo.com/" into the C<action> attribute of
the form tags.  You need to change it to "http://www.bar.com/".

 use strict;
 use HTML::TokeParser::Simple;

 my $new_folder = 'new_html/';
 my @html_docs  = glob( "*.html" );

 foreach my $doc ( @html_docs ) {
     print "Processing $doc\n";
     my $new_file = "$new_folder$doc";

     open FILE, "> $new_file" or die "Cannot open $new_file for writing: $!";

     my $p = HTML::TokeParser::Simple->new( $doc );
     while ( my $token = $p->get_token ) {
         if ( $token->is_start_tag( 'form' ) ) {
             my $form_tag = new_form_tag( 
                $token->return_attr, 
                $token->return_attrseq 
             );
             print FILE $form_tag;
         }
         else {
             print FILE $token->return_text;
         }
     }
     close FILE;
 }

 sub new_form_tag {
     my ( $attr, $attrseq ) = @_;
     if ( exists $attr->{ action } ) {
         $attr->{ action } =~ s/www\.foo\.com/www.bar.com/;
     }
     my $tag = '';
     foreach ( @$attrseq ) {
         $tag .= "$_=\"$attr->{ $_ }\" ";
     }
     $tag = "<form $tag>";
     return $tag;
 }

=head1 COPYRIGHT

Copyright (c) 2001 Curtis "Ovid" Poe.  All rights reserved.  This program is
free software; you may redistribute it and/or modify it under the same terms as
Perl itself

=head1 AUTHOR

Curtis "Ovid" Poe L<poec@yahoo.com>

=head1 BUGS

Use of C<$HTML::Parser::VERSION> which is less than 3.25 may result in
incorrect behavior as older versions do not always handle XHTML correctly.  It
is the programmer's responsibility to verify that the behavior of this code
matches the programmer's needs.

Address bug reports and comments to: L<poec@yahoo.com>.  When sending bug
reports, please provide the version of C<HTML::Parser>, C<HTML::TokeParser>,
C<HTML::TokeParser::Simple>, the version of Perl, and the version of the
operating system you are using.

=cut
