perlmeditation
PodMaster
<CODE>
=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;
</CODE>
<READMORE>
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.
<CODE>
################################
## 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>
</CODE>
<p>
<font size=1><TT>____________________________________________________</TT><BR>** The Third rule of perl club is a statement of fact: pod <I>is</I> sexy.</font>