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