view release on metacpan or  search on metacpan

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

    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;