1package DateTime::Format::Builder;
2# $Id: Builder.pm 4400 2010-03-14 15:49:10Z autarch $
3
4=begin comments
5
6Note: there is no API documentation in this file. You want F<Builder.pod> instead.
7
8=cut
9
10use strict;
11use 5.005;
12use Carp;
13use DateTime 0.12;
14use Params::Validate qw(
15    validate SCALAR ARRAYREF HASHREF SCALARREF CODEREF GLOB GLOBREF UNDEF
16);
17use vars qw( $VERSION %dispatch_data );
18
19my $parser = 'DateTime::Format::Builder::Parser';
20$VERSION = '0.80';
21
22# Developer oriented methods
23
24=pod
25
26C<verbose()> sets the logging.
27
28=cut
29
30sub verbose
31{
32    warn "Use of verbose() deprecated for the interim.";
33    1;
34}
35
36=pod
37
38C<import()> merely exists to save typing. class is specified after C<@_>
39in order to override it. We really don't want to know about
40any class they specify. We'd leave it empty, but C<create_class()>
41uses C<caller()> to determine where the code came from.
42
43=cut
44
45sub import
46{
47    my $class = shift;
48    $class->create_class( @_, class => (caller)[0] ) if @_;
49}
50
51=pod
52
53Populates C<$class::VERSION>, C<$class::new> and writes any
54of the methods.
55
56=cut
57
58sub create_class
59{
60    my $class = shift;
61    my %args = validate( @_, {
62	class	=> { type => SCALAR, default => (caller)[0] },
63	version => { type => SCALAR, optional => 1 },
64	verbose	=> { type => SCALAR|GLOBREF|GLOB, optional => 1 },
65	parsers	=> { type => HASHREF },
66	groups  => { type => HASHREF, optional => 1 },
67	constructor => { type => UNDEF|SCALAR|CODEREF, optional => 1 },
68    });
69
70    verbose( $args{verbose} ) if exists $args{verbose};
71
72    my $target = $args{class}; # where we're writing our methods and such.
73
74    # Create own lovely new package
75    {
76	no strict 'refs';
77
78
79	${"${target}::VERSION"} = $args{version} if exists $args{version};
80
81	$class->create_constructor(
82	    $target, exists $args{constructor}, $args{constructor} );
83
84	# Turn groups of parser specs in to groups of parsers
85	{
86	    my $specs = $args{groups};
87	    my %groups;
88
89	    for my $label ( keys %$specs )
90	    {
91		my $parsers = $specs->{$label};
92		my $code = $class->create_parser( $parsers );
93		$groups{$label} = $code;
94	    }
95
96	    $dispatch_data{$target} = \%groups;
97	}
98
99	# Write all our parser methods, creating parsers as we go.
100	while (my ($method, $parsers) = each %{ $args{parsers} })
101	{
102	    my $globname = $target."::$method";
103 	    croak "Will not override a preexisting method $method()" if defined &{$globname};
104	    *$globname = $class->create_end_parser( $parsers );
105	}
106    }
107
108}
109
110sub create_constructor
111{
112    my $class = shift;
113    my ( $target, $intended, $value ) = @_;
114
115    my $new = $target."::new";
116    $value = 1 unless $intended;
117
118    return unless $value;
119    return if not $intended and defined &$new;
120    croak "Will not override a preexisting constructor new()" if defined &$new;
121
122    no strict 'refs';
123
124    return *$new = $value if ref $value eq 'CODE';
125    return *$new = sub {
126	my $class = shift;
127 	croak "${class}->new takes no parameters." if @_;
128
129	my $self = bless {}, ref($class)||$class;
130	# If called on an object, clone, but we've nothing to
131	# clone
132
133	$self;
134    };
135}
136
137=pod
138
139This creates the parser coderefs. Coderefs return undef on
140bad parses, return C<DateTime> objects on good parse. Used
141by C<parser()> and C<create_class()>.
142
143=cut
144
145sub create_parser
146{
147    my $class = shift;
148    my @common = ( maker => $class );
149    if (@_ == 1)
150    {
151	my $parsers = shift;
152	my @parsers = (
153	    (ref $parsers eq 'HASH' ) ? %$parsers :
154	    ( ( ref $parsers eq 'ARRAY' ) ? @$parsers : $parsers)
155	);
156	$parser->create_parser( \@common, @parsers );
157    }
158    else
159    {
160	$parser->create_parser( \@common, @_ );
161    }
162}
163
164=pod
165
166This creates the end methods. Coderefs die on bad parses,
167return C<DateTime> objects on good parse.
168
169=cut
170
171sub create_end_parser
172{
173    my ($class, $parsers) = @_;
174    $class->create_method( $class->create_parser( $parsers ) );
175}
176
177=pod
178
179C<create_method()> simply takes a parser and returns a coderef suitable
180to act as a method.
181
182=cut
183
184sub create_method
185{
186    my ($class, $parser) = @_;
187    return sub {
188	my $self = shift;
189	$parser->parse( $self, @_);
190    }
191}
192
193=pod
194
195This is the method used when a parse fails. Subclass and override
196this if you like.
197
198=cut
199
200sub on_fail
201{
202    my ($class, $input) = @_;
203
204    my $pkg;
205    my $i = 0;
206    while (($pkg) = caller($i++)) {
207        last if (!UNIVERSAL::isa($pkg, 'DateTime::Format::Builder') &&
208            !UNIVERSAL::isa($pkg, 'DateTime::Format::Builder::Parser'));
209    }
210    local $Carp::CarpLevel = $i;
211    croak "Invalid date format: $input";
212}
213
214#
215# User oriented methods
216#
217
218=pod
219
220These methods don't need explaining. They're pretty much
221boiler plate stuff.
222
223=cut
224
225sub new
226{
227    my $class = shift;
228    croak "Constructor 'new' takes no parameters" if @_;
229    my $self = bless {
230	parser => sub { croak "No parser set." }
231    }, ref($class)||$class;
232    if (ref $class)
233    {
234	# If called on an object, clone
235	$self->set_parser( $class->get_parser );
236	# and that's it. we don't store that much info per object
237    }
238    return $self;
239}
240
241sub parser
242{
243    my $class = shift;
244    my $parser = $class->create_end_parser( \@_ );
245
246    # Do we need to instantiate a new object for return,
247    # or are we modifying an existing object?
248    my $self;
249    $self = ref $class ? $class : $class->new();
250
251    $self->set_parser( $parser );
252
253    $self;
254}
255
256sub clone
257{
258    my $self = shift;
259    croak "Calling object method as class method!" unless ref $self;
260    return $self->new();
261}
262
263sub set_parser
264{
265    my ($self, $parser) = @_;
266    croak "set_parser given something other than a coderef" unless $parser
267	and ref $parser eq 'CODE';
268    $self->{parser} = $parser;
269    $self;
270}
271
272sub get_parser
273{
274    my ($self) = @_;
275    return $self->{parser};
276}
277
278sub parse_datetime
279{
280    my $self = shift;
281    croak "parse_datetime is an object method, not a class method."
282        unless ref $self and $self->isa( __PACKAGE__ );
283    croak "No date specified." unless @_;
284    return $self->{parser}->( $self, @_ );
285}
286
287sub format_datetime
288{
289    croak __PACKAGE__."::format_datetime not implemented.";
290}
291
292require DateTime::Format::Builder::Parser;
293
294
295=pod
296
297Create the single parser. Delegation stops here!
298
299=cut
300
3011;
302