File Coverage

blib/lib/DateTime/Format/Builder/Parser.pm

Criterion	Covered	Total	%
statement	173	184	94.0
branch	61	76	80.2
condition	7	15	46.6
subroutine	32	34	94.1
pod	9	20	45.0
total	282	329	85.7

package DateTime::Format::Builder::Parser;
{
  $DateTime::Format::Builder::Parser::VERSION = '0.81';
}
use strict;
use warnings;
use Carp qw( croak );
use Params::Validate qw(
    validate SCALAR CODEREF UNDEF ARRAYREF
);
use Scalar::Util qw( weaken );




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 1.6;

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

1;

# ABSTRACT: Parser creation

__END__