| Variable-Eject documentation | Contained in the Variable-Eject distribution. |
Variable::Eject - Eject variables from hash to current namespace
Version 0.02
use Variable::Eject;
my $hash = {
scalar => 'scalar value',
array => [1..3],
hash => { my => 'value' },
};
# Now, eject vars from hash
eject(
$hash => $scalar, @array, %hash,
);
# Let's look
say $scalar;
say @array;
say keys %hash;
# Let's modify (source will be modified)
$scalar .= ' modified';
shift @array;
$hash{another} = 1;
A list of functions that can be exported. You can delete this section if you don't export anything, such as for a purely object-oriented module.
Mons Anderson, <mons at cpan.org>
Please report any bugs or feature requests to bug-variable-eject at rt.cpan.org, or through
the web interface at http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Variable-Eject. I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.
Copyright 2009 Mons Anderson, all rights reserved.
This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
| Variable-Eject documentation | Contained in the Variable-Eject distribution. |
package Variable::Eject;
our $VERSION = '0.02';
use uni::perl; m{ use strict; use warnings; }x; use Devel::Declare (); use Lexical::Alias (); our @CARP_NOT = qw(Devel::Declare); our $SUBNAME = 'eject'; sub import{ my $class = shift; my $caller = caller; Devel::Declare->setup_for( $caller, { $SUBNAME => { const => \&parse } } ); { no strict 'refs'; *{$caller.'::'.$SUBNAME } = sub (@_) { warn "this shouldn't be called - report your case to author\n" }; } } sub parse { my $parser = Variable::Eject->new($_[1]); return if $parser->get_word() ne $SUBNAME; $parser->process(); } package # hide Variable::Eject; use uni::perl; our @CARP_NOT = qw(Variable::Eject Devel::Declare); sub DEBUG () { 0 } sub new { my ($class, $offset) = @_; #print STDERR "new called at $offset\n" if DEBUG; bless \$offset, $class; } sub whereami { my $self = shift; my $line = Devel::Declare::get_linestr; warn "..>".substr($line,$$self); } sub process { my $self = shift; $self->whereami if DEBUG; $$self+=Devel::Declare::toke_move_past_token($$self); $self->whereami if DEBUG; $self->skip_spaces(); my $args = $self->extract_args(); $args =~ s/(\r|\n)//go; my @args = split /\s*(?:,|=>)\s*/, $args; @args > 1 or croak( 'Usage: '.$Variable::Eject::SUBNAME.'( $source_hash => $scalar, @array, %hash, ... )' ); my $from = shift @args; #warn "Have args $args: $from => [ @args ]"; my $inj; for (@args) { #warn "arg = >$_<\n"; s{(?:^\s+|\s+$)}{}sg; # ' $var ' => '$var' my $type = substr($_,0,1,''); s{^\s+}{}s; # ' { var } ' => '{ var }' s{^\s*\{?\s*|\s*\}?\s*$}{}sg; #$_ = '{'.$_.'}' unless m/^\{.+\}$/; if ($type eq '$') { $inj .= 'Lexical::Alias::alias( '.$from.'->{'.$_.'} => my $'.$_.' );'; #$inj .= 'Lexical::Alias::alias( '.$from.'->'.$_.' => my $'.$_.' );'; } else { $inj .= 'Lexical::Alias::alias( '.$type.'{'.$from.'->{'.$_.'}} => my '.$type.$_.' );'; #$inj .= 'Lexical::Alias::alias( '.$type.'{'.$from.'->'.$_.'} => my '.$type.$_.' );'; } #warn "$inj"; } $self->whereami if DEBUG; $self->inject("() if 0; $inj"); return; } sub get_word { my $self = shift; print STDERR "get_word called at $$self\n" if DEBUG; if (my $len = Devel::Declare::toke_scan_word($$self, 1)) { return substr(Devel::Declare::get_linestr(), $$self, $len); } return ''; } sub skip_spaces { my $self = shift; print STDERR "skip_spaces called at $$self\n" if DEBUG; $$self += Devel::Declare::toke_skipspace($$self); } sub extract_args { my $self = shift; print STDERR "extract_args called at $$self\n" if DEBUG; my $linestr = Devel::Declare::get_linestr(); if (substr($linestr, $$self, 1) eq '(') { my $length = Devel::Declare::toke_scan_str($$self); my $proto = Devel::Declare::get_lex_stuff(); Devel::Declare::clear_lex_stuff(); $linestr = Devel::Declare::get_linestr(); if ( $length < 0 || $$self + $length > length($linestr) ){ require Carp; Carp::croak("Unbalanced text supplied for assert"); } substr($linestr, $$self, $length) = ''; Devel::Declare::set_linestr($linestr); return $proto; } else { croak "Can't use '.$Variable::Eject::SUBNAME.' without brackets. Use '.$Variable::Eject::SUBNAME.'(...)"; } return ''; } sub inject{ my ($self, $inject) = @_; print STDERR "inject called at $$self for '$inject'\n" if DEBUG; my $linestr = Devel::Declare::get_linestr; if ($$self > length($linestr)){ croak("Parser tried to inject data outside program source, stopping"); } substr($linestr, $$self, 0) = $inject; Devel::Declare::set_linestr($linestr); $$self += length($inject); }
1; # End of Variable::Eject