lib/Class/Template.pm

   1 package Class::Template;
   2 require 5.000;
   3 require Exporter;
   4
   5 @ISA = qw(Exporter);
   6 @EXPORT = qw(members struct);
   7 use strict;
   8
   9 # Template.pm   --- struct/member template builder
  10 #   12mar95
  11 #   Dean Roehrich
  12 #
  13 # changes/bugs fixed since 28nov94 version:
  14 #  - podified
  15 # changes/bugs fixed since 21nov94 version:
  16 #  - Fixed examples.
  17 # changes/bugs fixed since 02sep94 version:
  18 #  - Moved to Class::Template.
  19 # changes/bugs fixed since 20feb94 version:
  20 #  - Updated to be a more proper module.
  21 #  - Added "use strict".
  22 #  - Bug in build_methods, was using @var when @$var needed.
  23 #  - Now using my() rather than local().
  24 #
  25 # Uses perl5 classes to create nested data types.
  26 # This is offered as one implementation of Tom Christiansen's "structs.pl"
  27 # idea.
  28
  29 =head1 NAME
  30
  31 Class::Template - struct/member template builder
  32
  33 =head1 EXAMPLES
  34
  35 =item * Example 1
  36
  37         use Class::Template;
  38
  39         struct( rusage => {
  40                 ru_utime => timeval,
  41                 ru_stime => timeval,
  42         });
  43
  44         struct( timeval => [
  45                 tv_secs  => '$',
  46                 tv_usecs => '$',
  47         ]);
  48
  49         my $s = new rusage;
  50
  51 =item * Example 2
  52
  53         package OBJ;
  54         use Class::Template;
  55
  56         members OBJ {
  57                 'a'     => '$',
  58                 'b'     => '$',
  59         };
  60
  61         members OBJ2 {
  62                 'd'     => '@',
  63                 'c'     => '$',
  64         };
  65
  66         package OBJ2; @ISA = (OBJ);
  67
  68         sub new {
  69                 my $r = InitMembers( &OBJ::InitMembers() );
  70                 bless $r;
  71         }
  72
  73 =head1 NOTES
  74
  75 Use '%' if the member should point to an anonymous hash.  Use '@' if the
  76 member should point to an anonymous array.
  77
  78 When using % and @ the method requires one argument for the key or index
  79 into the hash or array.
  80
  81 Prefix the %, @, or $ with '*' to indicate you want to retrieve pointers to
  82 the values rather than the values themselves.
  83
  84 =cut
  85
  86 Var: {
  87         $Class::Template::print = 0;
  88         sub printem { $Class::Template::print++ }
  89 }
  90
  91
  92 sub struct {
  93         my( $struct, $ref ) = @_;
  94         my @methods = ();
  95         my %refs = ();
  96         my %arrays = ();
  97         my %hashes = ();
  98         my $out = '';
  99
 100         $out = "{\n  package $struct;\n  sub new {\n";
 101         parse_fields( $ref, \$out, \@methods, \%refs, \%arrays, \%hashes, 0 );
 102         $out .= "      bless \$r;\n  }\n";
 103         build_methods( $ref, \$out, \@methods, \%refs, \%arrays, \%hashes );
 104         $out .= "}\n1;\n";
 105
 106         ( $Class::Template::print ) ? print( $out ) : eval $out;
 107 }
 108
 109 sub members {
 110         my( $pkg, $ref ) = @_;
 111         my @methods = ();
 112         my %refs = ();
 113         my %arrays = ();
 114         my %hashes = ();
 115         my $out = '';
 116
 117         $out = "{\n  package $pkg;\n  sub InitMembers {\n";
 118         parse_fields( $ref, \$out, \@methods, \%refs, \%arrays, \%hashes, 1 );
 119         $out .= "      bless \$r;\n  }\n";
 120         build_methods( $ref, \$out, \@methods, \%refs, \%arrays, \%hashes );
 121         $out .= "}\n1;\n";
 122
 123         ( $Class::Template::print ) ? print( $out ) : eval $out;
 124 }
 125
 126
 127 sub parse_fields {
 128         my( $ref, $out, $methods, $refs, $arrays, $hashes, $member ) = @_;
 129         my $type = ref $ref;
 130         my @keys;
 131         my $val;
 132         my $cnt = 0;
 133         my $idx = 0;
 134         my( $cmt, $n );
 135
 136         if( $type eq 'HASH' ){
 137                 if( $member ){
 138                         $$out .= "      my(\$r) = \@_ ? shift : {};\n";
 139                 }
 140                 else{
 141                         $$out .= "      my(\$r) = {};\n";
 142                 }
 143                 @keys = keys %$ref;
 144                 foreach (@keys){
 145                         $val = $ref->{$_};
 146                         if( $val =~ /^\*(.)/ ){
 147                                 $refs->{$_}++;
 148                                 $val = $1;
 149                         }
 150                         if( $val eq '@' ){
 151                                 $$out .= "      \$r->{'$_'} = [];\n";
 152                                 $arrays->{$_}++;
 153                         }
 154                         elsif( $val eq '%' ){
 155                                 $$out .= "      \$r->{'$_'} = {};\n";
 156                                 $hashes->{$_}++;
 157                         }
 158                         elsif( $val ne '$' ){
 159                                 $$out .= "      \$r->{'$_'} = \&${val}::new();\n";
 160                         }
 161                         else{
 162                                 $$out .= "      \$r->{'$_'} = undef;\n";
 163                         }
 164                         push( @$methods, $_ );
 165                 }
 166         }
 167         elsif( $type eq 'ARRAY' ){
 168                 if( $member ){
 169                         $$out .= "      my(\$r) = \@_ ? shift : [];\n";
 170                 }
 171                 else{
 172                         $$out .= "      my(\$r) = [];\n";
 173                 }
 174                 while( $idx < @$ref ){
 175                         $n = $ref->[$idx];
 176                         push( @$methods, $n );
 177                         $val = $ref->[$idx+1];
 178                         $cmt = "# $n";
 179                         if( $val =~ /^\*(.)/ ){
 180                                 $refs->{$n}++;
 181                                 $val = $1;
 182                         }
 183                         if( $val eq '@' ){
 184                                 $$out .= "      \$r->[$cnt] = []; $cmt\n";
 185                                 $arrays->{$n}++;
 186                         }
 187                         elsif( $val eq '%' ){
 188                                 $$out .= "      \$r->[$cnt] = {}; $cmt\n";
 189                                 $hashes->{$n}++;
 190                         }
 191                         elsif( $val ne '$' ){
 192                                 $$out .= "      \$r->[$cnt] = \&${val}::new();\n";
 193                         }
 194                         else{
 195                                 $$out .= "      \$r->[$cnt] = undef; $cmt\n";
 196                         }
 197                         ++$cnt;
 198                         $idx += 2;
 199                 }
 200         }
 201 }
 202
 203
 204 sub build_methods {
 205         my( $ref, $out, $methods, $refs, $arrays, $hashes ) = @_;
 206         my $type = ref $ref;
 207         my $elem = '';
 208         my $cnt = 0;
 209         my( $pre, $pst, $cmt, $idx );
 210
 211         foreach (@$methods){
 212                 $pre = $pst = $cmt = $idx = '';
 213                 if( defined $refs->{$_} ){
 214                         $pre = "\\(";
 215                         $pst = ")";
 216                         $cmt = " # returns ref";
 217                 }
 218                 $$out .= "  sub $_ {$cmt\n      my \$r = shift;\n";
 219                 if( $type eq 'ARRAY' ){
 220                         $elem = "[$cnt]";
 221                         ++$cnt;
 222                 }
 223                 elsif( $type eq 'HASH' ){
 224                         $elem = "{'$_'}";
 225                 }
 226                 if( defined $arrays->{$_} ){
 227                         $$out .= "      my \$i;\n";
 228                         $$out .= "      \@_ ? (\$i = shift) : return \$r->$elem;\n";
 229                         $idx = "->[\$i]";
 230                 }
 231                 elsif( defined $hashes->{$_} ){
 232                         $$out .= "      my \$i;\n";
 233                         $$out .= "      \@_ ? (\$i = shift) : return \$r->$elem;\n";
 234                         $idx = "->{\$i}";
 235                 }
 236                 $$out .= "      \@_ ? (\$r->$elem$idx = shift) : $pre\$r->$elem$idx$pst;\n";
 237                 $$out .= "  }\n";
 238         }
 239 }
 240
 241 1;