view release on metacpan or  search on metacpan

lib/Perl6/Binding.pm  view on Meta::CPAN

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);
		OUTER: while (1) {
			do {
				if ($need_line) {
					$status = filter_read();
					$need_line = 0;
					croak "unexpected EOF or error" if $status <= 0;
				}
				s/^(\s*)//;
				$recovery .= $1;
				if (/^(my|undef)\b(.*)$/s
				 || /^(\(|\)|\*|\@|\$|%|:=|,|;)(.*)$/s) {
					$token = $1;
					$value = undef;
					$_ = $2;
					$recovery .= $1;
				} elsif (/^(\w+)(.*)$/s) {
					$token = 'identifier';
					$value = $1;
					$_ = $2;
					$recovery .= $1;
				} elsif (/^[{\[]/) {
					my $text;
					do {
						$text = extract_bracketed($_, '[{"\'q}]');
					} while (!$text && ($status = filter_read()) > 0);
					if ($text ne '') {
						$token = substr($text, 0, 1) eq '{'
							? 'bracexpr' : 'brackexpr';
						$value = $text;
						$recovery .= $text;
					} else {
						$_ = $prior. $recovery . $_;
						return $status;
					}
				} elsif (/^#/) {
					$recovery .= $_;
					$need_line = 1;
				} elsif (!/^$/) {