Beefy Boxes and Bandwidth Generously Provided by pair Networks
Your skill will accomplish
what the force of many cannot
 
PerlMonks  

Re: getting more from __DATA__

by Ctrl-z (Friar)
on Mar 25, 2005 at 17:54 UTC ( [id://442382] : note . print w/replies, xml ) Need Help??


in reply to getting more from __DATA__

ok, heres the code as it stands. Some outstanding issues:

  • Would supporting segments as handles be worthwhile?
  • I removed the :subs option and replaced with the probably more useful :cdata. Any other ideas for likely defaults?
  • Currently the code croak()s if any attempt at modifying %DATA is made. Too strict?
  • The regexes are fairly simple-minded, any advice is welcome

cheers,

package Tie::DATA; use strict; use warnings; use Carp; my %modules = (); my %regexen = (); my %callbacks = (); my %handles = (); my $reserved = undef; ## # Default handlers for parsing DATA segments # NB: these can be code refs that return a list of key/value pairs, # default is to use as regex in split() call. # my %defaults = ( ':ini' => '(?:\r?\n)*[\[\]](?:\r?\n)*', ':underscore' => '\s*__(\S+)__\s*', ':define' => '\s*#define\s+(\w+)\s+', ':cdata' => sub{$_ = shift or return; return(m#\s*<!\[(\w+?)\[(.*?)\]\]>\s*#sgoi); }, ':xml' => sub{$_ = shift or return; return(m#\s*<(\w+)>([^<]*?)</\1>\s*#sgoi); }, ); $defaults{':default'} = $defaults{':underscore'}; $reserved = join('|', keys %defaults); ## # parse arguments and tie callers %DATA # sub import { my $package = shift; my $regex = shift; my $cback = shift; my $caller = caller; $regex = $defaults{$regex} if($regex && $regex =~ /^$reserved$ +/); $regex = $defaults{':default'} unless $regex; if(!exists $modules{$caller}) { no strict 'refs'; # fix stringy code ref...allow relative or absolute naming if($cback && !ref($cback)) { $cback = ($cback =~ /\:\:/go) ? \&{$cback} : \&{$caller."\::".$cback}; } *{"$caller\::DATA"} = {}; tie %{"$caller\::DATA"}, $package, $caller; $handles{$caller} = \*{$caller."::DATA"}; $modules{$caller} = undef; $regexen{$caller} = (ref $regex) ? $regex : qr($regex); $callbacks{$caller} = $cback; } } ## # read DATA handle # cant do during import as perl hasnt parsed that far by then # sub _read_data { my $self = shift; if(! defined $modules{$$self}) { my (@data, $data, $tell, $rex, $code); $rex = delete $regexen{$$self}; $code = delete $callbacks{$$self}; $data = delete $handles{$$self}; { # slurp and split... no warnings; local $/ = undef; $tell = tell($data); Carp::croak("Error: $$self has no __DATA__ section") if ($tell < 0); @data = (ref($rex) eq "CODE") ? $rex->(<$data>) : split(/$rex/, <$data>); $modules{$$self} = {} and return unless @data; } # remove empty elements...depends on syntax used shift @data if $data[0] =~ /^\s*$/o; pop @data if $data[-1] =~ /^\s*$/o; Carp::croak("Error: \%$$self\::DATA - bad key/value pairs\n") if (@data% 2); # trim keys and invoke any callbacks... for(my $i=0; $i<@data; $i+=2) { $data[$i] =~ s#^\s*(.*?)\s*$#$1#sgoi; next unless $data[$i]; if($code) { ($data[$i], $data[$i+1]) = $code->($data[$i], $data[$i ++1]); } } $modules{$$self} = {@data}; # coerce into hashref seek($data, $tell,0); # cover our tracks } } ## # TIE HASH interface (read-only) # not much to see here... # sub TIEHASH { my $class = shift; my $caller = shift; return bless \$caller, $class; } sub FETCH { my $self = shift; my $key = shift; $self->_read_data if(! defined $modules{$$self}); return $modules{$$self}{$key}; } sub EXISTS { my $self = shift; my $key = shift; $self->_read_data if(! defined $modules{$$self}); return exists $modules{$$self}{$key}; } sub FIRSTKEY { my $self = shift; $self->_read_data if(! defined $modules{$$self}); my $a = keys %{$modules{$$self}}; return each %{$modules{$$self}}; } sub NEXTKEY { my $self = shift; $self->_read_data if(! defined $modules{$$self}); return each %{ $modules{$$self} } } sub DESTROY { my $self = shift; $modules{$$self} = undef; } sub STORE { my $self = shift; my $k = shift; my $v = shift; #$self->_read_data if(! defined $modules{$$self}); Carp::croak("Attempt to store key ($k) in read-only hash %".$$self +."::DATA"); } sub DELETE { my $self = shift; my $k = shift; #$self->_read_data if(! defined $modules{$$self}); Carp::croak("Attempt to delete key ($k) from read-only hash %".$$s +elf."::DATA"); } sub CLEAR { my $self = shift; #$self->_read_data if(! defined $modules{$$self}); Carp::croak("Attempt to clear read-only hash %".$$self."::DATA"); } 1;



time was, I could move my arms like a bird and...