view release on metacpan or  search on metacpan

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

package DateTime::Format::Builder;

use strict;
use warnings;

our $VERSION = '0.83';

use Carp;
use DateTime 1.00;
use Params::Validate 0.72 qw(
    validate SCALAR ARRAYREF HASHREF SCALARREF CODEREF GLOB GLOBREF UNDEF
);
our %dispatch_data;

my $parser = 'DateTime::Format::Builder::Parser';

sub verbose {
    warn "Use of verbose() deprecated for the interim.";
    1;
}

sub import {
    my $class = shift;
    $class->create_class( @_, class => (caller)[0] ) if @_;
}

sub create_class {
    my $class = shift;
    my %args  = validate(
        @_,
        {
            class   => { type => SCALAR, default  => (caller)[0] },
            version => { type => SCALAR, optional => 1 },
            verbose => { type => SCALAR | GLOBREF | GLOB, optional => 1 },
            parsers => { type => HASHREF },
            groups  => { type => HASHREF, optional => 1 },
            constructor =>
                { type => UNDEF | SCALAR | CODEREF, optional => 1 },
        }
    );

    verbose( $args{verbose} ) if exists $args{verbose};

    my $target = $args{class};    # where we're writing our methods and such.

    # Create own lovely new package
    {
        no strict 'refs';

        ${"${target}::VERSION"} = $args{version} if exists $args{version};

        $class->create_constructor(
            $target, exists $args{constructor},
            $args{constructor}
        );

        # Turn groups of parser specs in to groups of parsers
        {
            my $specs = $args{groups};
            my %groups;

            for my $label ( keys %$specs ) {
                my $parsers = $specs->{$label};
                my $code    = $class->create_parser($parsers);
                $groups{$label} = $code;
            }

            $dispatch_data{$target} = \%groups;
        }

        # Write all our parser methods, creating parsers as we go.
        while ( my ( $method, $parsers ) = each %{ $args{parsers} } ) {
            my $globname = $target . "::$method";
            croak "Will not override a preexisting method $method()"
                if defined &{$globname};
            *$globname = $class->create_end_parser($parsers);
        }
    }

}

sub create_constructor {
    shift;
    my ( $target, $intended, $value ) = @_;

    my $new = $target . "::new";
    $value = 1 unless $intended;

    return unless $value;
    return if not $intended and defined &$new;
    croak "Will not override a preexisting constructor new()"
        if defined &$new;