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