# $Id: toSAX.pm,v 1.1.1.1 2004/11/04 12:38:36 mrodrigu Exp $

use strict;
use warnings;

package HTML::TreeBuilder::toSAX;
use List::Util qw( first);
import HTML::Element::toSAX;

use vars qw($VERSION @ISA);
$VERSION = '0.01';

@ISA= qw( HTML::TreeBuilder HTML::Element::toSAX); 

my $qs= qr{(?:"[^"]*"|'[^']*')}; # matches a quoted string (captures the quotes also)

sub new
  { my $class = shift;
    $class = ref($class) || $class;
    
    my $self= HTML::TreeBuilder->new();
    $self->{_element_class}= 'HTML::Element::toSAX';
    bless $self, $class;
    
    return $self;
  }

sub toSAX1
  { my( $tree, $handler)= @_;
    $tree->_toSAX( $handler, \&HTML::Element::toSAX::_start_tag_data_SAX1,
                             \&HTML::Element::toSAX::_end_tag_data_SAX1
                 );
  }

sub toSAX2
  { my( $tree, $handler)= @_;
    $tree->_toSAX( $handler, \&HTML::Element::toSAX::_start_tag_data_SAX2,
                             \&HTML::Element::toSAX::_end_tag_data_SAX2
                 );
  }


sub _toSAX
  { my( $tree, $handler, $start_tag_data, $end_tag_data) = @_;

    if( my $start_document =  $handler->can( 'start_document'))
      { $start_document->( $handler); }
    
      $tree->_prolog_toSAX( $handler);
    
      $tree->SUPER::_elt_toSAX( $handler, $start_tag_data, $end_tag_data);

    if( my $end_document =  $handler->can( 'end_document'))
      { $end_document->( $handler); }
  }

sub _prolog_toSAX
  { my( $tree, $handler)= @_;
    my $content= $tree->{_content};
    if( my $xmldecl= first { ref( $_) && ($_->tag eq '~pi') && ($_->attr( 'text')=~ m{^xml }) } @$content)
      { if( my $xmldecl_handler= $handler->can( 'xml_decl'))
          { my( $version, $encoding, $standalone)= ($xmldecl->attr( 'text')=~ m{       ^xml 
                                                                                    \s+ version    \s* = \s* ($qs)
                                                                                (?: \s+ encoding   \s* = \s* ($qs))?
                                                                                (?: \s+ standalone \s* = \s* ($qs))?
                                                                                    \s*?$
                                                                               }x
                                                   );
        
            my $data= { Version    => $version    && substr( $version,    1, -1), 
                        Encoding   => $encoding   && substr( $encoding,   1, -1), 
                        Standalone => $standalone && substr( $standalone, 1, -1), 
                      };
            $xmldecl_handler->( $handler, $data);
          }
        $xmldecl->{_xmldecl}= 1; # mark this pi-looking element so it is not emitted later 
      }
      
    if( my $doctype= first { ref( $_) && ($_->tag eq '~declaration') } @$content)
      { #warn "found doctype: '", $doctype->{text}, "'";
        my( $name, $pub, $sysid)= ($doctype->attr( 'text')=~ m{^ \s* DOCTYPE \s+ ([^\s]*)
                                                                 (?: \s+ PUBLIC \s+ ($qs) )?
                                                                 (?: (?:\s+ SYSTEM)? \s+ ($qs))?
                                                                 (?: \s* \[ \s* \])? \s* $
                                                      }x
                                   );
        #warn "doctype for: '$name'";
        my $data= { Name     =>         $name,
                    PublicId => $pub   && substr( $pub,   1, -1),
                    SystemId => $sysid && substr( $sysid, 1, -1),,
                  };

        if( my $start_dtd= $handler->can( 'start_dtd')) { $start_dtd->( $handler, $data); }
        if( my $end_dtd= $handler->can( 'end_dtd'))     { $end_dtd->( $handler); }

      }
      
  }

package HTML::Element::toSAX;

use base( 'HTML::Element');

my %special_tag    = ( comment => '~comment', pi => '~pi', declaration => '~declaration' );
my %is_special_tag = map { $special_tag{$_} => $_ } keys %special_tag;
my $XMLNS_URI = 'http://www.w3.org/2000/xmlns/';


sub toSAX1
  { my( $elt, $handler)= @_;
    $elt->_elt_toSAX( $handler, \&_start_tag_data_SAX1, \&_end_tag_data_SAX1); 
  }

sub toSAX2
  { my( $elt, $handler)= @_;
    $elt->_elt_toSAX( $handler, \&_start_tag_data_SAX2, \&_end_tag_data_SAX2); 
  }

sub _elt_toSAX
  { my( $elt, $handler, $start_tag_data, $end_tag_data)= @_;
    my $tag= $elt->tag;
    if( $is_special_tag{$tag})
      { if( ($elt->tag eq $special_tag{comment}) && (my $comment= $handler->can( 'comment')))
          { $comment->( $handler, { Data => $elt->attr( 'text') }); }
        elsif( ($elt->tag eq $special_tag{pi})  && !$elt->{_xmldecl} && (my $pi= $handler->can( 'processing_instruction')))
          { my $text= substr( $elt->attr( 'text'), 0, -1); # remove the trailing '?'
            my( $target, $data)= split( /\s+/, $text, 2); 
            $pi->( $handler, { Target =>$target, Data => $data });  
          }
        elsif( ($elt->tag eq $special_tag{declaration})  && (my $declaration= $handler->can( 'doctype')))
          { # TODO
          }
      }
    else 
      { my $data= $start_tag_data->( $elt);
        _start_prefix_mapping( $elt, $handler, $data);
        if( $data && (my $start_element = $handler->can( 'start_element')))
          { $start_element->( $handler, $data); }
  
        foreach my $child ($elt->content_list)
          { if( UNIVERSAL::isa( $child, 'HTML::Element') )
              { # this is higly hack-ish, but HTML::TreeBuilder creates HTML::Element objects even when I 
                # tell it to create HTML::Element::toSAX
                bless $child, 'HTML::Element::toSAX';
                $child->_elt_toSAX( $handler, $start_tag_data, $end_tag_data);
              }
            elsif( my $characters= $handler->can( 'characters'))
              {  $characters->( $handler, { Data => $child }); } 
          }

        if( (my $data= $end_tag_data->( $elt)) && (my $end_element = $handler->can( 'end_element')) )
          { $end_element->( $handler, $data); }
        _end_prefix_mapping( $elt, $handler);
      }
  }
  
sub _start_tag_data_SAX1
  { my( $elt)= @_;
    my $name= $elt->tag;
    my %attributes= $elt->all_external_attr;
    delete $attributes{'/'};
    my $data= { Name => $name, Attributes => \%attributes};
    return $data;
  }

sub _end_tag_data_SAX1
  { my( $elt)= @_;
    return  { Name => $elt->tag };
  } 
  
sub _start_tag_data_SAX2
  { my( $elt)= @_;
    my $data={};
    
    my $name= $elt->tag;
    $data->{Name}         = $name;
    $data->{Prefix}       = $elt->ns_prefix; 
    $data->{LocalName}    = $elt->local_name;
    $data->{NamespaceURI} = $elt->namespace;

    # save a copy of the data so we can re-use it for the end tag
    my %sax2_data= %$data;
    # the key name needs to start with '_' for all_external_attr to ignore it
    $elt->{_elt_SAX2_data}= \%sax2_data; 
   
    # add the attributes
    $data->{Attributes}= $elt->_atts_to_SAX2;

    return $data;
  }

sub _atts_to_SAX2
  { my $elt= shift;
    my $SAX2_atts= {};
    my %atts= $elt->all_external_attr();
    delete $atts{'/'};
    foreach my $att ( sort keys %atts)
      { my $SAX2_att={};
        $SAX2_att->{Name}         = $att;
        $SAX2_att->{Prefix}       = _ns_prefix( $att); 
        $SAX2_att->{LocalName}    = _local_name( $att);
        $SAX2_att->{NamespaceURI} = $elt->namespace( $SAX2_att->{Prefix});
        $SAX2_att->{Value}        = $elt->attr( $att);
        my $SAX2_att_name= "{$SAX2_att->{NamespaceURI}}$SAX2_att->{LocalName}";

        $SAX2_atts->{$SAX2_att_name}= $SAX2_att;
      }
    return $SAX2_atts;
  }

sub _start_prefix_mapping
  { my( $elt, $handler, $data)= @_;
    if( my $start_prefix_mapping= $handler->can( 'start_prefix_mapping')
        and my @new_prefix_mappings= grep { /^\{[^}]*\}xmlns/ || /^\{$XMLNS_URI\}/ } keys %{$data->{Attributes}}
      )
      { foreach my $prefix (@new_prefix_mappings)
          { my $prefix_string= $data->{Attributes}->{$prefix}->{LocalName};
            if( $prefix_string eq 'xmlns') { $prefix_string=''; }
            my $prefix_data=
              {  Prefix       => $prefix_string,
                 NamespaceURI => $data->{Attributes}->{$prefix}->{Value}
              };
            $start_prefix_mapping->( $handler, $prefix_data);
            $elt->{_end_prefix_mapping} ||= [];
            push @{$elt->{_end_prefix_mapping}}, $prefix_string;
          }
      }
  }

sub _end_prefix_mapping
  { my( $elt, $handler)= @_;
    if( my $end_prefix_mapping= $handler->can( 'end_prefix_mapping'))
      { foreach my $prefix (@{$elt->{_end_prefix_mapping}})
          { $end_prefix_mapping->( $handler, { Prefix => $prefix} ); }
      }
  }
             
sub _end_tag_data_SAX2
  { my( $elt)= @_;
    return delete $elt->{_elt_SAX2_data};
  } 


sub local_name 
  { my $elt= shift;
    return _local_name( $elt->tag);
  }

sub ns_prefix
  { my $elt= shift;
    return _ns_prefix( $elt->tag);
  }

sub _ns_prefix
  { my $qname= shift;
    if( $qname=~ m{^([^:]*):})
      { return $1; }
    else
      { return( ''); } # should it be '' ?
  }

# local name for any qname (can be used for elements or attributes)
sub _local_name
  { my $qname= shift;
    (my $local= $qname)=~ s{^[^:]*:}{};
    return $local;
  }

INIT 
  { my %DEFAULT_NS= ( xml   => "http://www.w3.org/XML/1998/namespace",
                      xmlns => "http://www.w3.org/2000/xmlns/",
                    );
 
    sub namespace
      { my $elt= shift;
        my $prefix= defined $_[0] ? shift() : $elt->ns_prefix;
        my $ns_att= $prefix ? "xmlns:$prefix" : "xmlns";
        my $expanded= $DEFAULT_NS{$prefix} || $elt->inherit_att( $ns_att) || '';
        return $expanded;
      }
  }

sub inherit_att
  { my( $elt, $att)= @_;
    do { return $elt->attr( $att) if( defined $elt->attr( $att)); } while( $elt= $elt->parent);
    return undef;
  }

1;

package HTML::TreeBuilder::toSAX::Dump;

BEGIN
{
foreach my $event ( qw( start_document end_document xml_decl doctype start_dtd end_dtd 
                        start_prefix_mapping end_prefix_mapping
                        start_element end_element characters
                        processing_instruction comment
                       )
                  )
  { no strict 'refs';
    *{$event}= sub { print {$_[0]->{fh}} dump_event( $event => $_[1]), "\n"; };
  }
}

sub new
  { my( $class, $fh)= @_;
    return bless { fh => $fh };
  }


sub dump_event
  { my( $event, $data)= @_;
    return "$event: ", dump_hashref( $data);
  }
      
sub dump_hashref
  { my $hashref= shift;
    return join( ' - ', 
                 map { my $val= $hashref->{$_};
                       my $dump_val= ref $val ?  "{ " . dump_hashref( $val) . " }" : "'$val'";
                       "$_: $dump_val"
                     }
                       sort keys %$hashref
               );
  };

1;
      
__END__
# Below is stub documentation for your module. You'd better edit it!

=head1 NAME

HTML::TreeBuilder::toSAX - SAX export of HTML::TreeBuilder trees

=head1 SYNOPSIS

  use HTML::TreeBuilder::toSAX;
  
  my $tree= HTML::TreeBuilder::toSAX->new();
  $tree->parse_file( 'example.html');

  # write using a SAX1 writer
  use XML::Handler::YAWriter;
  my $writer1 = XML::Handler::YAWriter->new( AsFile => '-', Pretty => $pretty);
  $tree->toSAX1( $writer1);
  
  # write using a SAX2 writer
  use XML::SAX::Writer;
  my $writer2 = XML::SAX::Writer->new( );
  $tree->toSAX2( $writer2);

  

=head1 DESCRIPTION

C<HTML::TreeBuilder::toSAX> is a subclass of L<HTML::TreeBuilder> that allows
SAX export for a tree.

The tree itself is subclassed as an C<HTML::TreeBuilder::toSAX>  object, and 
its elements are subclassed as C<HTML::Element::toSAX> instead of the normal
L<HTML::Element>

=head2 METHODS

=over 4

=item toSAX1

SAX1 export of a tree

=item toSAX2

SAX2 export of a tree

=back

=head1 BUGS, CAVEATS, TODO

=over 4

=item *

the code for parsing the XML declaration, if present, and the document
(C<< <!DOCTYPE ... >>) declaration is very crude and most likely buggy

=item *

with the current (3.13) version of HTML::TreeBuilder some of the elements
are not properly subclassed as C<HTML::Element::toSAX> until B<after>
the tree has been exported using a C<toSAXn> method

=item *

with the current (3.13) version of HTML::TreeBuilder you cannot use the 
C<elementify> method on a tree prior to exporting with a C<toSAXn> method

=item *

more tests are (always!) needed, especially SAX1 tests

=back

=head1 SEE ALSO

L<HTML::TreeBuilder>

Perl SAX

=head1 AUTHOR

Michel Rodriguez, E<lt>mirod@cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2004 by Michel Rodriguez

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.4 or,
at your option, any later version of Perl 5 you may have available.

=cut
