DateTime::Format::Builder::Parser - Parser creation

    my $class = 'DateTime::Format::Builder::Parser';
    my $parser = $class->create_single_parser( %specs );

    my $params = $self->params();
    validate( @_, $params );

    my $all_params = $self->params_all();

    __PACKAGE__->valid_params( %params );

    my $class = whose_params( $key );

   DateTime::Format::Builder::Parser->valid_params(
       params => { type => ARRAYREF },
       Regex  => { type => SCALARREF, callbacks => {
          'is a regex' => sub { ref(shift) eq 'Regexp' }
       }}
   );

    http://perl.dellah.org/rt/dtbuilder
    bug-datetime-format-builder@rt.cpan.org

package DateTime::Format::Builder::Parser;
use strict;
use vars qw( $VERSION );
use Carp qw( croak );
use Params::Validate qw(
    validate SCALAR CODEREF UNDEF ARRAYREF
);
use Scalar::Util qw( weaken );

$VERSION = '0.77';

sub on_fail
{
    my ($self, $input, $parent) = @_;
    my $maker = $self->maker;
    if ( $maker and $maker->can( 'on_fail' ) ) {
        $maker->on_fail( $input );
    } else {
        croak __PACKAGE__.": Invalid date format: $input";
    }
}

sub no_parser
{
    croak "No parser set for this parser object.";
}

sub new
{
    my $class = shift;
    $class = ref($class)||$class;
    my $i = 0;
    my $self = bless {
        on_fail => \&on_fail,
        parser => \&no_parser,
    }, $class;

    return $self;
}

sub maker { $_[0]->{maker} }

sub set_maker
{
    my $self  = shift;
    my $maker = shift;

    $self->{maker} = $maker;
    weaken $self->{maker}
        if ref $self->{maker};

    return $self;
}

sub fail
{
    my ($self, $parent, $input) = @_;
    $self->{on_fail}->( $self, $input, $parent );
}

sub parse
{
    my ( $self, $parent, $input, @args ) = @_;
    my $r = $self->{parser}->( $parent, $input, @args );
    $self->fail( $parent, $input ) unless defined $r;
    $r;
}

sub set_parser
{
    my ($self, $parser) = @_;
    $self->{parser} = $parser;
    $self;
}

sub set_fail
{
    my ($self, $fail) = @_;
    $self->{on_fail} = $fail;
    $self;
}

my @callbacks = qw( on_match on_fail postprocess preprocess );

{

    my %params = (
	common => {
	    length	=> {
		type      => SCALAR|ARRAYREF,
		optional  => 1,
		callbacks => {
		    'is an int' => sub { ref $_[0] ? 1 : $_[0] !~ /\D/ },
		    'not empty' => sub { ref $_[0] ? @{$_[0]} >= 1 : 1 },
		}
	    },

	    # Stuff used by callbacks
	    label	=> { type => SCALAR,	optional => 1 },
	    ( map { $_ => { type => CODEREF|ARRAYREF, optional => 1 } } @callbacks ),
	},
    );

    sub params
    {
	my $self = shift;
	my $caller = ref $self || $self;
	return { map { %$_ } @params{ $caller, 'common' } }
    }

    my $all_params;
    sub params_all
    {
	return $all_params if defined $all_params;
	my %all_params = map { %$_ } values %params;
	$_->{optional} = 1 for values %all_params;
	$all_params = \%all_params;
    }

    my %inverse;
    sub valid_params
    {
	my $self = shift;
	my $from = (caller)[0];
	my %args = @_;
	$params{ $from } = \%args;
	for (keys %args)
	{
	    # %inverse contains keys matching all the
	    # possible params; values are the class if and
	    # only if that class is the only one that uses
	    # the given param.
	    $inverse{$_} = exists $inverse{$_} ? undef : $from;
	}
	undef $all_params;
	1;
    }

    sub whose_params
    {
	my $param = shift;
	return $inverse{$param};
    }
}

sub create_single_object
{
    my ( $self ) = shift;
    my $obj = $self->new;
    my $parser = $self->create_single_parser( @_ );

    $obj->set_parser( $parser );
}

sub create_single_parser
{
    my $class = shift;
    return $_[0] if ref $_[0] eq 'CODE'; # already code
    @_ = %{ $_[0] } if ref $_[0] eq 'HASH'; # turn hashref into hash
    # ordinary boring sort
    my %args = validate( @_, params_all() );

    # Determine variables for ease of reference.
    for (@callbacks)
    {
	$args{$_} = $class->merge_callbacks( $args{$_} ) if $args{$_};
    }

    # Determine parser class
    my $from;
    for ( keys %args )
    {
	$from = whose_params( $_ );
	next if (not defined $from) or ($from eq 'common');
	last;
    }
    croak "Could not identify a parsing module to use." unless $from;

    # Find and call parser creation method
    my $method = $from->can( "create_parser" )
	or croak "Can't create a $_ parser (no appropriate create_parser method)";
    my @args = %args;
    %args = validate( @args, $from->params() );
    $from->$method( %args );
}

sub merge_callbacks
{
    my $self = shift;

    return unless @_; # No arguments
    return unless $_[0]; # Irrelevant argument
    my @callbacks = @_;
    if (@_ == 1)
    {
	return $_[0] if ref $_[0] eq 'CODE';
	@callbacks = @{ $_[0] } if ref $_[0] eq 'ARRAY';
    }
    return unless @callbacks;

    for (@callbacks)
    {
	croak "All callbacks must be coderefs!" unless ref $_ eq 'CODE';
    }

    return sub {
	my $rv;
	my %args = @_;
	for my $cb (@callbacks)
	{
	    $rv = $cb->( %args );
	    return $rv unless $rv;
	    # Ugh. Symbiotic. All but postprocessor return the date.
	    $args{input} = $rv unless $args{parsed};
	}
	$rv;
    };
}

sub create_multiple_parsers
{
    my $class = shift;
    my ($options, @specs) = @_;

    my $obj = $class->new;

    # Organise the specs, and transform them into parsers.
    my ($lengths, $others) = $class->sort_parsers( $options, \@specs );

    # Merge callbacks if any.
    for ( 'preprocess' ) {
	$options->{$_} = $class->merge_callbacks(
	    $options->{$_}
	) if $options->{$_};
    }
    # Custom fail method?
    $obj->set_fail( $options->{on_fail} ) if exists $options->{on_fail};
    # Who's our maker?
    $obj->set_maker( $options->{maker} ) if exists $options->{maker};

    # We don't want to save the whole options hash as a closure, since
    # that can cause a circular reference when $options->{maker} is
    # set.
    my $preprocess = $options->{preprocess};

    # These are the innards of a multi-parser.
    my $parser = sub {
	my ($self, $date, @args) = @_;
	return unless defined $date;

	# Parameters common to the callbacks. Pre-prepared.
	my %param = (
	    self => $self,
	    ( @args ? (args => \@args) : () ),
	);

	my %p;
	# Preprocess and potentially fill %p
	if ($preprocess)
	{
	    $date = $preprocess->(
		input => $date, parsed => \%p, %param
	    );
	}

	# Find length parser
	if (%$lengths)
	{
	    my $length = length $date;
	    my $parser = $lengths->{$length};
	    if ($parser)
	    {
		# Found one, call it with _copy_ of %p
		my $dt = $parser->( $self, $date, { %p }, @args );
		return $dt if defined $dt;
	    }
	}
	# Or calls all others, with _copy_ of %p
	for my $parser (@$others)
	{
	    my $dt = $parser->( $self, $date, { %p }, @args );
	    return $dt if defined $dt;
	}
	# Failed, return undef.
	return;
    };
    $obj->set_parser( $parser );
}

sub sort_parsers
{
    my $class = shift;
    my ($options, $specs) = @_;
    my (%lengths, @others);

    for my $spec (@$specs)
    {
	# Put coderefs straight into the 'other' heap.
	if (ref $spec eq 'CODE')
	{
	    push @others, $spec;
	}
	# Specifications...
	elsif (ref $spec eq 'HASH')
	{
	    if (exists $spec->{length})
	    {
		my $code = $class->create_single_parser( %$spec );
		my @lengths = ref $spec->{length}
		    ? @{ $spec->{length} }
		    : ( $spec->{length} );
		for my $length ( @lengths )
		{
		    push @{ $lengths{$length} }, $code;
		}
	    }
	    else
	    {
		push @others, $class->create_single_parser( %$spec );
	    }
	}
	# Something else
	else
	{
	    croak "Invalid specification in list.";
	}
    }

    while (my ($length, $parsers) = each %lengths)
    {
	$lengths{$length} = $class->chain_parsers( $parsers );
    }

    return ( \%lengths, \@others );
}

sub chain_parsers
{
    my ($self, $parsers) = @_;
    return $parsers->[0] if @$parsers == 1;
    return sub {
	my $self = shift;
	for my $parser (@$parsers)
	{
	    my $rv = $self->$parser( @_ );
	    return $rv if defined $rv;
	}
	return undef;
    };
}

sub create_parser
{
    my $class = shift;
    if (not ref $_[0])
    {
	# Simple case of single specification as a hash
	return $class->create_single_object( @_ )
    }

    # Let's see if we were given an options block
    my %options;
    while ( ref $_[0] eq 'ARRAY' )
    {
	my $options = shift;
	%options = ( %options, @$options );
    }

    # Now, can we create a multi-parser out of the remaining arguments?
    if (ref $_[0] eq 'HASH' or ref $_[0] eq 'CODE')
    {
	return $class->create_multiple_parsers( \%options, @_ );
    }
    else
    {
	# If it wasn't a HASH or CODE, then it was (ideally)
        # a list of pairs describing a single specification.
        return $class->create_multiple_parsers( \%options, { @_ } );
    }
}

# Find all our workers
{
    use Class::Factory::Util;

    foreach my $worker ( __PACKAGE__->subclasses )
    {
        eval "use DateTime::Format::Builder::Parser::$worker;";
        die $@ if $@;
    }
}

1;

__END__