view release on metacpan or  search on metacpan

lib/DateTime/Format/Builder/Parser.pm  view on Meta::CPAN

package DateTime::Format::Builder::Parser;

use strict;
use warnings;

our $VERSION = '0.83';

use Carp qw( croak );
use Params::Validate qw(
    validate SCALAR CODEREF UNDEF ARRAYREF
);
use Scalar::Util qw( weaken );

sub on_fail {
    my ( $self, $input ) = @_;
    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 $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;