package YATT::Lite::Types; use strict; use warnings qw(FATAL all NONFATAL misc); use parent qw(YATT::Lite::Object); use Carp; require YATT::Lite::Inc; sub Desc () {'YATT::Lite::Types::TypeDesc'} { package YATT::Lite::Types::TypeDesc; sub Desc () {__PACKAGE__} use parent qw(YATT::Lite::Object); BEGIN { our %FIELDS = map {$_ => 1} qw/cf_name cf_ns cf_fields cf_overloads cf_alias cf_base cf_eval fullname cf_no_require cf_constants cf_export_default/ } sub pkg { my Desc $self = shift; join '::', $self->{cf_ns}, $self->{cf_name}; } } use YATT::Lite::Util qw(globref look_for_globref lexpand ckeval pkg2pm define_const ); sub import { my $pack = shift; my $callpack = caller; $pack->buildns($callpack, @_) } sub create { my $pack = shift; my $callpack = shift; my Desc $root = $pack->Desc->new(ns => $callpack); while (@_ >= 2 and not ref $_[0]) { $root->configure(splice @_, 0, 2); } wantarray ? ($root, $pack->parse_desc($root, @_)) : $root; } sub buildns { (my Desc $root, my @desc) = shift->create(@_); my $debug = $ENV{DEBUG_YATT_TYPES}; my (@script, @task); my $export_ok = do { my $sym = globref($$root{cf_ns}, 'EXPORT_OK'); *{$sym}{ARRAY} // (*$sym = []); }; if (my $sub = $$root{cf_ns}->can('export_ok')) { push @$export_ok, $sub->($$root{cf_ns}); } { my $sym = globref($$root{cf_ns}, 'export_ok'); *$sym = sub { @$export_ok } unless *{$sym}{CODE}; } foreach my Desc $obj (@desc) { push @$export_ok, $obj->{cf_name}; $obj->{fullname} = join '::', $$root{cf_ns}, $obj->{cf_name}; $INC{pkg2pm($obj->{fullname})} = 1; # To make require happy. push @script, qq|package $obj->{fullname};|; push @script, q|use YATT::Lite::Inc;|; my $base = $obj->{cf_base} || $root->{cf_base} || safe_invoke($$root{cf_ns}, $obj->{cf_name}) || 'YATT::Lite::Object'; # # I finally found base::has_fields() is broken # so there is no merit for fields mania to use base.pm over parent.pm. # push @script, sprintf q|use parent qw(%s);|, $base; push @script, sprintf q|use YATT::Lite::MFields %s;|, do { if ($obj->{cf_fields}) { sprintf(q|qw(%s)|, join " ", @{$obj->{cf_fields}}); } else { # To avoid generating 'use YATT::Lite::MFields qw()'; ''; } }; push @script, sprintf q|use overload qw(%s);| , join " ", @{$obj->{cf_overloads}} if $obj->{cf_overloads}; push @script, $obj->{cf_eval} if $obj->{cf_eval}; push @script, "\n"; push @task, [\&add_alias, $$root{cf_ns}, $obj->{cf_name}, $obj->{cf_name}]; foreach my $alias (lexpand($obj->{cf_alias})) { push @task, [\&add_alias, $$root{cf_ns}, $alias, $obj->{cf_name}]; push @$export_ok, $alias; } foreach my $spec (lexpand($obj->{cf_constants})) { push @task, [\&add_const, $obj->{fullname}, @$spec]; } } my $script = join(" ", @script, "; 1"); print $script, "\n" if $debug; ckeval($script); foreach my $task (@task) { my ($sub, @args) = @$task; $sub->(@args); } if ($root->{cf_export_default}) { my $export = do { my $sym = globref($$root{cf_ns}, 'EXPORT'); *{$sym}{ARRAY} // (*$sym = []); }; @$export = @$export_ok; } foreach my Desc $obj (@desc) { my $sym = look_for_globref($obj->{fullname}, 'FIELDS'); if ($sym and my $fields = *{$sym}{HASH}) { print "Fields in type $obj->{fullname}: " , join(" ", sort keys %$fields), "\n" if $debug; } elsif ($obj->{cf_fields}) { croak "Failed to define type fields for '$obj->{fullname}': " . join(" ", @{$obj->{cf_fields}}); } } } sub add_alias { my ($pack, $alias, $name) = @_; add_const($pack, $alias, join('::', $pack, $name)); } sub add_const { my ($pack, $alias, $const) = @_; define_const(globref($pack, $alias), $const); } sub safe_invoke { my ($obj, $method) = splice @_, 0, 2; my $sub = $obj->can($method) or return; $sub->($obj, @_); } sub parse_desc { (my $pack, my Desc $parent) = splice @_, 0, 2; my (@desc); while (@_) { unless (defined (my $item = shift)) { croak "Undefined type desc!"; } elsif (ref $item) { my @base = (base => $parent->pkg) if $parent->{cf_name}; push @desc, my Desc $sub = $pack->Desc->new (name => shift @$item, ns => $parent->{cf_ns}, @base); push @desc, $pack->parse_desc($sub, @$item); } elsif (@_) { $item =~ s/^-//; $parent->configure($item, shift); } else { croak "Missing parameter for type desc $item"; } } @desc; } 1; __END__ =head1 NAME YATT::Lite::Types - define inner types at compile time. =head1 SYNOPSIS In module I<MyClass.pm>: package MyClass; use YATT::Lite::Types (base => 'MyBaseClass' , [Album => fields => [qw/albumid artist title/]] , [CD => fields => [qw/cdid artist title/]] , [Track => fields => [qw/trackid cd title/]] ); # Now you have MyClass::Album, MyClass::CD and MyClass::Track. # also, alias (constant sub) of them are defined. my Album $album = Album->new; # my Albumm $album; # => No such class Albumm my CD $cd = CD->new; # $cd->{artistt}; # => No such class field "artistt" in variable $cd of type MyClass::CD my Track $track = {}; $track->{cd} = $cd; # $track->{cdd} = $cd; # => No such class field "cdd" in variable $track of type MyClass::Track 1; =head1 DESCRIPTION YATT::Lite::Types is a class builder, especially suitable to defining many inner classes at once. Basic usage is like this: use YATT::Lite::Types (OPTION => VALUE, ... , [SPEC] , [SPEC] , : ); where SPEC array for single type is written (TYPENAME + OPT VAL pair list) as: [TYPENAME => OPTION => VALUE, ...] Also you can write type hierachy in nested style as: [BASETYPE => OPT => VAL, ... , [SUBTYPE1 => OPT => VAL, ...] , [SUBTYPE2 => OPT => VAL, ... , [SUBSUBTYPE1 => OPT => VAL, ...] , [SUBSUBTYPE2 => OPT => VAL, ...] ] ] =head2 options =over 4 =item * base Base class for newly created type. This name is preloaded before type definition (unless you specify C<< no_require => 1 >>). =item * no_require =item * alias To define alias(synonym) too, use this. =head1 SEE ALSO L<fields>