http://qs1969.pair.com?node_id=213193

=head1 NAME XML::Twig::Handlers - promoting laziness through magic =head1 DESCRIPTION An XML::Twig subclass which you subclass, so you don't have to write twig_handlers => { blah=>\&blah_handler, ... }, explicitly. =head1 SYNOPSIS So if you had package MyTwiggy; require XML::Twig::Handlers; use base qw( XML::Twig::Handlers ); sub blah_handler { } Creating a C<new MyTwiggy> would essentially be the same as my $t = MyTwiggy->new( twig_handlers => { blah=>\&blah_handler } ); You could also have sub blah_root { } which would magically translate to twig_roots => { blah => \&blah_root; } =head1 CAVEAT B<BEWARE>!!! There really is no reason for you to write sub blah_handler { ... } sub blah_root { ... } It is sufficient to write sub blah_h sub blah_r { ... } Because # this is the regex i use to match methods /^[^_]+_[hHrR]/ You will get no warnings about possible conflicts, for example sub blah_h { ... } sub blah_H { ... } =head1 BUGS _all_ and _default_ are not supported because I keep getting "unrecognized expression in handler" carped by XML::Twig. Hopefully this will be resolved in the next version. =cut package XML::Twig::Handlers; use vars qw( $VERSION @ISA ); require XML::Twig; @ISA = qw( XML::Twig ); $VERSION = 0.01; # now ripping off # Devel::GetSymbols::symbols; # no strict 'refs'; sub _symbols { my ($type, $package) = @_; $package = (caller)[0] unless defined $package; # croak 'Usage: symbols(type[, package])' unless defined $type; grep defined *{"${package}::$_"}{$type}, keys %{"${package}::"} } sub _handlers { my $pack = shift or (caller)[0]; return map { my($r) = split/_/,$_,2; ( $r => \&{"${pack}::$_"} ); } grep { /^[^_]+_[hH]/ # /^(?:_all|_default|[^_]+)_[hH]/ } _symbols('CODE',$pack); } sub _roots { my $pack = shift or (caller)[0]; return map { my($r) = split/_/,$_,2; ( $r => \&{"${pack}::$_"} ); } grep { /^[^_]+_[rR]/ # /^(?:_all|_default|[^_]+)_[rR]/ } _symbols('CODE',$pack); } use strict; BEGIN{eval q{use warnings;};} # only if we got'em sub new { my( $pack, @options ) = @_; my @Handlers = _handlers($pack); my @Roots = _roots($pack); push @options, twig_roots => { @Roots } if @Roots; push @options, twig_handlers => { @Handlers } if @Handlers; return $pack->SUPER::new(@options); } 1;
This is the example, and it'll be run automatically if you downloaded this module using the "d/l code" link and then ran the file through perl.
################################ ## The Example package MyTwiggy; use vars qw( @ISA ); eval q{require XML::Twig::Handlers;}; # just in case @ISA = qw( XML::Twig::Handlers ); sub Doc_root { my( $t, $doc)= @_; $doc->print; print "\n",'x'x69,"\n"; } sub foo_h { my( $t, $foo) = @_; print "\n\t\t## saw foo ##\n"; } 1; package main; my $t = MyTwiggy->new(); print "$t\n"; $t->parse(\*DATA); __END__ <Stream> <Doc> <foo>hey man</foo> <foo>hey man2</foo> </Doc> <Doc> <bar>hey man, how's it goin'?</bar> </Doc> <Doc> <baz>pretty right on.</baz> </Doc> </Stream>

____________________________________________________
** The Third rule of perl club is a statement of fact: pod is sexy.