view release on metacpan or  search on metacpan

Tokens.pm  view on Meta::CPAN

package Parse::Tokens;

# $Id: Tokens.pm,v 1.5 2001/11/28 01:14:55 steve Exp $

# Copyright 2000-2001 by Steve McKay. All rights reserved.
# This library is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

use strict;
use vars qw( $VERSION  );

$VERSION = 0.27;

sub new
{
	my ( $proto, $params ) = @_;
	my $class = ref($proto) || $proto;
	my $self = {
		debug => undef,
		text => undef,
		autoflush => undef,
		loose_paring => undef,
		pre_callback => undef,
		post_callback => undef,
		token_callback => undef,
		ether_callback => undef,
		delimiters => [],
		delim_index => {},
	};
	bless( $self, $class );
	$self->init( $params );
	$self;
}

sub init
{
    my( $self, @args ) = @_;
	no strict 'refs';
	$self->_msg( "Processing initialization arguments." );
	for ( keys %{$args[0]} )
	{
		my $ref = lc $_;
		$self->$ref( $args[0]->{$_} );
	}
	use strict;
}

sub debug
{
	my( $self, @args ) = @_;
	$self->_msg( "Storing 'debug' prefs." );
	$self->{'debug'} = $args[0] if defined $args[0];
	return $self->{'debug'};
}

sub token_callback
{
	my( $self, @args ) = @_;
	$self->_msg( "Storing 'token_callback' prefs." );
	$self->{'token_callback'} = $args[0] if defined $args[0];
	return $self->{'token_callback'};
}

sub ether_callback
{
	my( $self, @args ) = @_;
	$self->_msg( "Storing 'ether_callback' prefs." );
	$self->{'ether_callback'} = $args[0] if defined $args[0];
	return $self->{'ether_callback'};
}

sub pre_callback
{
	my( $self, @args ) = @_;
	$self->_msg( "Storing 'pre_callback' prefs." );
	$self->{'pre_callback'} = $args[0] if defined $args[0];
	return $self->{'pre_callback'};
}

sub post_callback
{
	my( $self, @args ) = @_;
	$self->_msg( "Storing 'post_callback' prefs." );
	$self->{'post_callback'} = $args[0] if defined $args[0];
	return $self->{'post_callback'};
}

sub loose_paring
{
	my( $self, @args ) = @_;
	$self->_msg( "Storing 'loose_paring' prefs." );
	$self->{'loose_paring'} = $args[0] if defined $args[0];
	return $self->{'loose_paring'};
}

sub autoflush
{
	my( $self, @args ) = @_;
	$self->_msg( "Storing 'autoflush' prefs." );
	$self->{'autoflush'} = $args[0] if defined $args[0];
	return $self->{'autoflush'};
}

sub text
{
	my( $self, @args ) = @_;
	$self->_msg( "Storing 'text'." );
	$self->flush();
	$self->{'text'} = $args[0] if defined $args[0];
	return $self->{'text'};
}

sub delimiters
{
	my( $self, @args ) = @_;
	# we currently support both a ref to an array of delims
	# as well as an ref to an array of array refs with delims
	if ( ref($args[0]) eq 'ARRAY' )
	{
		# wipe our existing delimiters
		$self->{'delimiters'} = [];
		# we have multiple arrays
		if( ref($args[0]->[0]) eq 'ARRAY' )
		{
			for( @{$args[0]} )
			{
				$self->push_delimiters( $_ );
			}	
		}
		# we have only this array ref
		else
		{
			$self->push_delimiters( $args[0] );
		}
	}
	return @{$self->{'delimiters'}};
}

*add_delimiters = \&push_delimiters;
sub push_delimiters
{ 
	# add a delim pair (real and quoted) to the delimiters array
	my( $self, @args ) = @_;
	$self->_msg( "Adding delimiter pair." );
	if( ref($args[0]) eq 'ARRAY' )
	{
		push(
			@{$self->{'delimiters'}}, {
				real	=> $args[0],
				quoted	=> [
					quotemeta($args[0]->[0]),
					quotemeta($args[0]->[1])
				]
			}
		);
		$self->{'delim_index'}->{$args[0]->[0]} = $#{$self->{delimiters}};
		$self->{'delim_index'}->{$args[0]->[1]} = $#{$self->{delimiters}};
	}
	else