Perl6-Binding
view release on metacpan or search on metacpan
lib/Perl6/Binding.pm view on Meta::CPAN
##==============================================================================
## Perl6::Binding - implement Perl6 aliasing features
##==============================================================================
## $Id: Binding.pm,v 1.1 2004/05/23 01:54:13 kevin Exp $
##==============================================================================
require 5.006;
package Perl6::Binding;
use strict;
use warnings;
our $VERSION = '0.601';
require XSLoader;
XSLoader::load('Perl6::Binding', $VERSION);
use Filter::Util::Call;
use Text::Balanced qw(extract_bracketed);
use PadWalker;
use Carp;
our %INSTALLED;
=head1 NAME
Perl6::Binding - implement Perl6 aliasing features
=head1 SYNOPSIS
use Perl6::Binding;
my ($foo, @bar, %baz) := @hash{qw/foo bar baz/};
my ($foo, @bar, %baz) := *%hash;
my ($foo, @bar, %baz) := *@array;
my @array1 := @array2;
=head1 DESCRIPTION
This module creates lexical aliases to items that can be either lexical or
dynamic using the C<:=> operator. The left side of C<:=> is a variable or a list
of variable names in parentheses. The right side is a list of items to which the
items on the left should should refer. Each item on the left side is made an
alias to the corresponding item on the right.
=head2 What's an Alias?
An I<alias> is a way of making the same value have more than one way to get at
it. For example, after the statement:
my $foo := $array[2];
anyplace you refer to C<$foo>, you are actually referring to C<$array[2]>.
Changing either one is the same as changing the other. If you take a reference
to each of them, you'll discover that the references are identical.
The example above may not look that useful, but something like this could be:
my %hash := %{$parameter->{index}->{option}};
Now you can type C<$hash{foo}> instead of C<<
$parameter->{index}->{option}->{foo} >>. Not only does this save typing, but it
should execute slighly faster as well.
Perl automatically creates aliases to the items in the C<@_> array when a
function is called, and to the variable in a B<foreach> statement. So, after a
statement like
my ($foo, @bar, %baz) := *@_;
the items are aliases to the actual parameters passed to the function. Changing
the value of C<$foo> changes the value of the item that was passed as the first
parameter.
The C<*> on the right side of C<:=> indicates that the item it prefixes is to be
I<flattened>. That is, the contents are considered as if they had been added to
the list explicitly. The following two lines are equivalent, except that the
second one requires less typing:
my ($foo, @bar, %baz) := ($array[0], @{$array[1]}, %{$array[2]});
lib/Perl6/Binding.pm view on Meta::CPAN
my ($foo, @bar, %baz) := @hash{qw/foo bar baz/};
my ($foo, @bar, %baz) := *%hash;
You can also do something like this:
my ($name, *@parameters) := *@_;
This says that C<$name> is to be an alias to C<$_[0]>, while the rest of the
contents of C<@_> are copied to C<@parameters>, which becomes a "real" array
rather than an alias. Changing the items in C<@parameters> does I<not> affect
the values passed to the function. The C<*> on the left side says "throw
everything else into this variable." It may only be used on the last item (or
rather, anything after it in the list will neither become an alias to anything
nor have a value assigned to it).
If the variable prefixed by C<*> is a scalar, it receives the count of the
remaining items rather than any of the items themselves.
The type of the left item and the type of the right item must match. The
following statements are invalid:
my @foo := %bar;
my $baz := @foobar;
This module works both at compile time (via a source filter) and at runtime.
=head1 NOTES
=over 4
=item *
It's possible that the source filter might find something that looks like the
statements it handles in odd locations, such as within a string. If this
happens, use C<no Perl6::Binding> to turn off the filter where necessary. Don't
forget to turn it back on afterwards!
=item *
This is currently alpha software. It seems to work, but I am sure there are odd
bugs lurking in the woodwork. Please let me know if you find them.
=item *
Version 0.6 fixes a long-standing problem in that bindings in recursive
subroutines did not work. Now they do.
=item *
Version 0.601 is an update to 0.6 that puts the dependencies back into the Makefile.PL.
=back
=head1 REQUIRED MODULES
L<Filter::Util::Call|Filter::Util::Call>
L<Text::Balanced|Text::Balanced>
L<PadWalker|PadWalker>
=head1 BUGS
Under Perl 5.8.x, it is not possible to create aliases at the root level
of the program due to a problem in PadWalker 0.09 and 0.10 (see the README
for PadWalker). Aliases created in subroutines continue to work, however.
=head1 ACKNOWLEDGEMENTS
Some code was taken from Devel::LexAlias and Devel::Caller, both by Richard
Clamp.
The name Perl6::Binding was suggested by Benjamin Goldberg.
=head1 AUTHOR
Kevin Michael Vail <F<kevin>@F<vaildc>.F<net>>
=head1 COPYRIGHT AND LICENSE
Copyright 2003 by Kevin Michael Vail
This library is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.
=cut
##==============================================================================
## import - install the filter
##==============================================================================
sub import {
my $caller = (caller)[1];
unless ($INSTALLED{$caller}) {
shift;
filter_add({ @_ });
$INSTALLED{$caller} = 1;
}
}
##==============================================================================
## unimport - uninstall the filter
##==============================================================================
sub unimport {
my $caller = (caller)[1];
if ($INSTALLED{$caller}) {
filter_del();
delete $INSTALLED{$caller};
}
}
##==============================================================================
## filter - do the actual work
##==============================================================================
sub filter {
my ($f) = @_;
my $status = filter_read();
return $status if $status <= 0 || /^\s*#/;
if (/^(.*)\b(my\b.*)$/s) {
my $prior = $1;
$_ = $2;
my $recovery = '';
my $parser = $f->_parser;
my $newline_count = 0;
my $need_line = 0;
my ($token, $value);
lib/Perl6/Binding.pm view on Meta::CPAN
map { $_->[1] } grep { $_->[0] ne 'undef' } @$left
)
. '); ';
$result .= 'Perl6::Binding::alias(['
. join(
', ',
map {
$_->[0] eq 'var'
? qq{[ 0, '@{[$_->[1]]}', \\@{[$_->[1]]} ]}
: $_->[0] eq 'flatten'
? qq{[ 1, '@{[$_->[1]]}', \\@{[$_->[1]]} ]}
: 'undef';
} @$left
)
. '], '
. join(
', ',
map {
$_->[0] eq 'var'
? qq{[ 0, @{[$_->[1]]} ]}
: $_->[0] eq 'flatten'
? qq{[ 1, @{[$_->[1]]} ]}
: qq{[ 2, @{[$_->[1]]} ]};
} @$right
)
. ');';
return $result;
}
##==============================================================================
## _parser - return parser object, creating if necessary
##==============================================================================
sub _parser {
my ($f) = @_;
unless (exists $f->{parser}) {
$f->{parser} = new Perl6::Binding::Grammar;
}
$f->{parser}->reset;
return $f->{parser};
}
##==============================================================================
## alias(\@left, @right);
## Create the actual aliases. The left side is a reference to an array of
## array references or undef values. The array reference has three elements.
## The first is either 0 for the normal case or 1 for the "flattened" case.
## The second is a string containing the name of the variable.
## The third is a reference to the variable.
## The right side is an actual array (not a reference) containing array
## references. Each of these contains two or more elements. The first is 0
## for the normal case or 1 for a flattened case, or 2 if the original item
## is a hash or array slice. If the first element is 0 or 1, the second element
## is a single reference to the target item. If the first element is 2, there
## will be one or more references to scalars (or references to references if
## the element in the slice is itself a hash or array reference).
## This routine is called at runtime.
##==============================================================================
sub alias {
my $left = shift;
my $cx = PadWalker::_upcontext(1);
my $cv = $cx ? _context_cv($cx) : 0;
my ($rtype, $rpos, @rrefs);
foreach (@$left) {
##----------------------------------------------------------------------
## Create an alias to the next element on the right side if this item
## is defined.
##----------------------------------------------------------------------
if (defined $_) {
my ($flattened, $varname, $varref) = @$_;
my ($vartype, $varid) = unpack('a1a*', $varname);
##------------------------------------------------------------------
## If flattened, just assign what's left in @_ to the variable in
## question. A scalar gets the count of the items left.
##------------------------------------------------------------------
if ($flattened) {
if ($vartype eq '$') {
$$varref = @_;
} elsif ($vartype eq '@') {
@$varref = @_;
} elsif ($vartype eq '%') {
%$varref = @_;
} else {
die "internal error: invalid vartype '$vartype'";
}
last; ## no sense in continuing!
}
##------------------------------------------------------------------
## Not flattened. Actually get the next element from the right
## side and create an alias to it in the element on the left side.
##------------------------------------------------------------------
elsif (@_) {
unless (defined $rtype) {
($rtype, @rrefs) = @{$_[0]};
$rpos = 0;
}
##--------------------------------------------------------------
## If this is a normal alias (type 0), the item in $varref
## simply becomes an alias to the item in $rcurrent.
##--------------------------------------------------------------
if ($rtype == 0) {
my $value = $rrefs[0];
_lexalias($cv, $varname, $value);
undef $rtype;
shift;
}
##--------------------------------------------------------------
## If this is a flattened alias (type 1), decode the item in
## $rcurrent so that it becomes a list of items. For a hash,
## we can't actually do this since the aliased items depend on
## the names of the variables on the left side.
##--------------------------------------------------------------
elsif ($rtype == 1) {
my $rref = $rrefs[0];
if (UNIVERSAL::isa($rref, 'HASH')) {
croak "key '$varid' doesn't exist"
unless exists $rref->{$varid};
if ((ref $rref->{$varid}) =~ /^ARRAY|HASH$/
&& $vartype ne '$') {
my $value = $rref->{$varid};
( run in 0.555 second using v1.01-cache-2.11-cpan-e1769b4cff6 )