1package Class::Tangram::Generator; 2 3use strict 'vars', 'subs'; 4use Set::Object qw(reftype refaddr blessed); 5use Carp; 6use Class::Tangram::Generator::Stub; 7 8use IO::Handle; 9 10use vars qw($VERSION $singleton $stub); 11$VERSION = 0.02; 12 13BEGIN { 14 no warnings; 15} 16 17# to re-define at run-time, use: 18# *{Class::Tangram::Generator::DEBUG}=sub{1} 19use constant DEBUG => 0; 20 21sub debug_out { 22 print STDERR __PACKAGE__."[$$]: @_\n"; 23} 24 25$stub = $INC{'Class/Tangram/Generator/Stub.pm'}; 26 27sub DESTROY { 28 my $self = shift; 29 @INC = grep { defined and 30 (!ref($_) or refaddr($_) ne refaddr($self)) } 31 @INC; 32} 33 34sub new { 35 36 my ($class, $self) = (shift, undef); 37 38 unless ( ref $class ) { 39 40 # build a new Class::Tangram::Generator 41 $self = {}; 42 $self->{_schema} = shift or croak "Must supply schema!"; 43 44 # find out what base class they want to use: 45 $self->{_base} = $self->{_schema}->{Base} || 46 shift(@_) || 'Class::Tangram'; 47 48 eval "require $self->{_base}"; 49 croak $@ if $@; 50 51 # now extract the schema itself: 52 $self->{_schema} = ($self->{_schema}->{classes} || 53 $self->{_schema}->{Schema}->{classes} || {} 54 ) if reftype $self->{_schema} eq "HASH"; 55 56 # convert arrayref into a hashref if necessary: 57 $self->{_schema} = { @{$self->{_schema}} } 58 if ref $self->{_schema} eq "ARRAY"; 59 60 # create load-on-demand new() constructors 61 #for my $class (grep {!ref} @{ $self->{_schema} }) { 62 while (my $class = each %{ $self->{_schema} }) { 63 (DEBUG>1) && debug_out("Setting up generator for $class"); 64 my $ref = "${class}::new"; 65 *{ $ref } = sub { 66 shift; 67 (DEBUG) && do { 68 my ($pkg,$file,$line)=caller(); 69 debug_out("tripped $class->new() ($pkg" 70 ." [$file:$line])"); 71 }; 72 undef *{ $class }; # avoid warnings 73 $self->load_class($class); 74 unless (blessed $_ and $_->isa(__PACKAGE__)) { 75 unshift @_, $self, $class; 76 #my $coderef = $self->can("new"); 77 goto \&new; 78 } 79 } unless defined &{ $ref }; 80 *{ $ref } = \42; 81 } 82 83 # hash to list already handled classes 84 $self->{_done} = {}; 85 86 bless $self, $class; 87 88 unshift @INC, $self; 89 $singleton = $self; 90 91 return $self; 92 93 } else { 94 95 # setup and build a new $class object. 96 ($self, $class) = ($class, shift); 97 98 unless ($class) { 99 croak "Must supply a classname or schema!"; 100 } 101 102 # make a new C::T::Gen with new schema 103 if(ref $class eq 'HASH') { 104 return __PACKAGE__->new($class, @_); 105 } 106 107 exists $self->{_schema}->{$class} or croak "Unknown class: $class"; 108 $self->load_class($class) unless $self->{_done}->{$class}; 109 110 my $coderef = $class->can("new"); 111 unshift @_, $class; 112 goto $coderef; 113 } 114} 115 116sub load_class { 117 118 my ($self, $class, $skip_use) = @_; 119 120 exists $self->{_schema}->{$class} or croak "Unknown class: $class"; 121 unless($self->{_done}->{$class}) { 122 123 (DEBUG) && debug_out("load_class $class"); 124 no strict 'refs'; 125 undef *{ $class."::new" }; # avoid warnings 126 127 for my $base (@{$self->{_schema}->{$class}->{bases} || []}) { 128 unless ($self->{_done}->{$base}) { 129 $self->load_class($base) ; 130 } 131 (DEBUG>1) && debug_out("pushing $base on to \@{ ${class}::ISA }"); 132 push @{"${class}::ISA"}, $base 133 unless UNIVERSAL::isa($class, $base); 134 } 135 136 if (defined $skip_use) { 137 if ($skip_use) { 138 #print STDERR "skip_use is $skip_use\n"; 139 (DEBUG) && debug_out("loading $class from $skip_use"); 140 open GEN, "<$skip_use" or die $!; 141 my $code = join "", <GEN>; 142 close GEN; 143 eval $code; 144 die $@ if $@; 145 (DEBUG) && debug_out 146 ("symbols loaded: " 147 .join (" ", map { 148 (defined &{ $class."::$_" } ? "&" : "") 149 .(defined ${ $class."::$_" } ? "\$" : "") 150 .(defined @{ $class."::$_" } ? "\@" : "") 151 .(defined %{ $class."::$_" } ? "\%" : "") 152 ."$_" 153 } keys %{ $class."::" })); 154 (DEBUG) && debug_out 155 ("ISA is now: ".join(" ", @{ $class."::ISA" })); 156 } 157 } else { 158 (my $filename = $class) =~ s{::}{/}g; 159 $filename .= ".pm"; 160 if ( exists $INC{$filename} ) { 161 (DEBUG) && debug_out("not loading $filename - already" 162 ." loaded"); 163 } else { 164 (DEBUG>1) && debug_out("loading class via `use $class'"); 165 eval "use $class"; 166 #warn "Got a warning: $@" if $@; 167 croak __PACKAGE__.": auto-include $class failed; $@" 168 if ($@ && $@ !~ /^Can't locate \Q$filename.pm\E/); 169 (DEBUG>1 && $@) && debug_out("no module for $class"); 170 } 171 } 172 173 $self->post_load($class); 174 } 175} 176 177sub post_load { 178 my $self = shift; 179 my $class = shift; 180 181 push @{"${class}::ISA"}, $self->{_base}; 182 ${"${class}::schema"} = $self->{_schema}->{$class} 183 unless defined ${"${class}::schema"}; 184 185 # import subroutine methods defined in schema, BEFORE 186 # Class::Tangram defines accessor methods. 187 while ( my ($name, $sub) = 188 each %{ $self->{_schema}->{$class}->{methods} || {} } ) { 189 (DEBUG>1) 190 && debug_out("inserting method into ${class}::${name}"); 191 *{"${class}::${name}"} = $sub 192 unless defined &{"${class}::${name}"} 193 } 194 195 &{"$self->{_base}::import_schema"}($class); 196 197 $self->{_done}->{$class}++; 198} 199 200sub Class::Tangram::Generator::INC { 201 my $self = shift; 202 my $fn = shift; 203 204 (my $pkg = $fn) =~ s{/}{::}g; 205 $pkg =~ s{.pm$}{}; 206 207 (DEBUG>1) && debug_out "saw include for $pkg"; 208 209 if ($self->{_schema}->{$pkg}) { 210 211 my $file = ""; 212 for my $path (@INC) { 213 next if ref $path; 214 if (-f "$path/$fn") { 215 $file = "$path/$fn"; 216 last; 217 } 218 } 219 220 $self->load_class($pkg, $file); 221 222 # OK, this is getting into some pretty kooky magic, but 223 # essentially GENERATOR_HANDLE returns the file intact, but 224 # places a hoook on the end to finish up Class::Tangram 225 226 #print STDERR "Generator: returning dummy to Perl\n"; 227 228 open DEVNULL, "<$stub" or die $!; 229 return \*DEVNULL; 230 231 } else { 232 #print STDERR "Generator: not one of mine, ignoring\n"; 233 return undef; 234 } 235} 236 237#BEGIN { 238 #${__PACKAGE__."::INC"} = \&FOOINC; 239#} 240 241sub READLINE { 242 my $self = shift; 243 if (wantarray) { 244 my @rv; 245 my $val; 246 while (defined ($val = $self->READLINE)) { 247 push @rv, $val; 248 } 249 return @rv; 250 } 251 252 if (!$self->{fh} && $self->{source}) { 253 open GENERATOR_PM, "<$self->{source}" or die $!; 254 $self->{source} = IO::Handle->new_from_fd("GENERATOR_PM", "r"); 255 *GENERATOR_PM = *GENERATOR_PM if 0; 256 } 257 258 my $retval; 259 260 AGAIN: 261 if (!$self->{state}) { 262 263 # the package 264 265 $self->{state} = "Package"; 266 $retval = "package $self->{package};\n"; 267 268 } elsif ($self->{state} =~ m/Package/ && $self->{fh}) { 269 270 # their code 271 272 my $line = $self->{fh}->getline; 273 if ($line =~ m/^__END__/) { 274 $self->{state} = m/postamble/; 275 goto AGAIN; 276 } 277 if (defined($line)) { 278 $retval = $line; 279 } else { 280 $self->{state} = "postamble"; 281 goto AGAIN; 282 } 283 284 } elsif ($self->{state} =~ m/Package|postamble/) { 285 286 # extra stuff normally done by load_class 287 $self->{state} = "END"; 288 $retval =("\$Class::Tangram::Generator::singleton->post_load" 289 ."('$self->{package}');\n"); 290 291 } elsif ($self->{state} =~ m/END/) { 292 293 $self->{fh}->close() if $self->{fh}; 294 $retval = undef; 295 296 } 297 298 return $retval; 299} 300 301sub GETC { 302 my $self = shift; 303 die "No getc!"; 304} 305 306sub TIEHANDLE { 307 my $class = shift; 308 my $package = shift; 309 return bless { package => $package }, $class; 310} 311 312sub SOURCE { 313 my $self = shift; 314 $self->{source} = shift; 315} 316 317sub READ { 318 my $self = shift; 319 die "No read!"; 320} 321 322 3231; 324__END__ 325 326=head1 NAME 327 328Class::Tangram::Generator - Generate Class::Tangram-based objects at runtime. 329 330=head1 SYNOPSIS 331 332 use Class::Tangram::Generator; 333 334 my $schema = { ... }; # a Tangram schema definition hashref, 335 # including all classes 336 my $gen = new Class::Tangram::Generator $schema; 337 338 my $orange = $gen->new('Orange'); 339 $orange->juicyness(10); # $orange is a Class::Tangram-based Orange object 340 341=head1 DESCRIPTION 342 343The purpose of Class::Tangram::Generator is to facilitate the rapid 344development of L<Class::Tangram|Class::Tangram>-based objects in the 345L<Tangram|Tangram> framework. Instead of having to write class 346modules for all your L<Tangram|Tangram> objects, many of which only 347inherit from L<Class::Tangram|Class::Tangram> for accessor and 348constraint checking, you use Class::Tangram::Generator to dynamically 349instantiate each class as necessary, at runtime. This also alleviates 350the long litany of 'use Orange; use Apple; ... ' statements in all of 351your scripts. 352 353=head1 METHODS 354 355=over 4 356 357=item new($schema, [$base]) [ Class method ] 358 359=item new( { Schema => $schema, Base => $base } ) [ Class method ] 360 361Initialize and return a new Class::Tangram::Generator object, using 362the L<Tangram> schema hashref provided. Newly generated objects will 363have "Class::Tangram" added to their @ISA variable, unless an 364alternative base class is specified in $base (that way you can 365subclass L<Class::Tangram|Class::Tangram> and still use 366Class::Tangram::Generator). 367 368=item new($classname) [ Object method ] 369 370Obtain a new object of the provided class. Additional arguments are 371passed to L<Class::Tangram|Class::Tangram>'s new function (for 372attribute manipulation). Any errors thrown by 373L<Class::Tangram|Class::Tangram> will be propagated by 374Class::Tangram::Generator. 375 376=back 377 378=head1 DISCUSSION 379 380=head2 Tangram Schema Extensions 381 382To provide custom methods for each class, add subroutine references to 383the 'methods' key in the schema: 384 385 Orange => { 386 fields => { int => [ qw(juicyness ripeness) ] }, 387 methods => { 388 squeeze => sub { 389 my $self = shift; 390 $self->juicyness($self->juicyness() - 1); 391 }, 392 eviscerate => sub { 393 my $self = shift; 394 $self->juicyness(0); 395 } 396 } 397 } 398 399The subroutines will be automatically installed into the class's 400namespace. 401 402=head2 Interoperation with existing package files 403 404If a .pm module file corresponding to the requested class can be found 405by Perl (looking in the usual places defined by @INC, PERL5LIB, etc.), 406it will be loaded before Class::Tangram::Generator has finished 407dynamically generating the package. This means that any schema and/or 408methods found in the .pm module file will be overriden by those 409specified in the schema given to Class::Tangram::Generator. For 410example, there may be an Orange.pm module file that looks like: 411 412 package Orange; 413 414 sub rehydrate { shift->juicyness(10) } 415 416 1; 417 418This allows the addition of more lengthy subroutines without filling 419up the schema with lots of code. But a "rehydrate" method specified 420in the schema would entirely replace this subroutine (and it would not 421be available via SUPER). 422 423=head1 EXPORT 424 425Class::Tangram::Generator does not have any methods to export. 426 427=head1 HISTORY 428 429=over 4 430 431=item 0.01 432 433Initial release 434 435=back 436 437=head1 AUTHOR 438 439Aaron J Mackey E<lt>amackey@virginia.eduE<gt> 440 441=head1 SEE ALSO 442 443L<Class::Tangram>, L<Tangram>, L<Class::Object>, L<perl>. 444 445=cut 446