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 SYNOPSIS
  34
  35     use Class::Template;
  36     struct(name => { key1 => type1, key2 => type2 });
  37
  38     package Myobj;
  39     use Class::Template;
  40     members Myobj { key1 => type1, key2 => type2 };
  41
  42 =head1 DESCRIPTION
  43
  44 This module uses perl5 classes to create nested data types.
  45
  46 =head1 EXAMPLES
  47
  48 =item * Example 1
  49
  50         use Class::Template;
  51
  52         struct( rusage => {
  53                 ru_utime => timeval,
  54                 ru_stime => timeval,
  55         });
  56
  57         struct( timeval => [
  58                 tv_secs  => '$',
  59                 tv_usecs => '$',
  60         ]);
  61
  62         my $s = new rusage;
  63
  64 =item * Example 2
  65
  66         package OBJ;
  67         use Class::Template;
  68
  69         members OBJ {
  70                 'a'     => '$',
  71                 'b'     => '$',
  72         };
  73
  74         members OBJ2 {
  75                 'd'     => '@',
  76                 'c'     => '$',
  77         };
  78
  79         package OBJ2; @ISA = (OBJ);
  80
  81         sub new {
  82                 my $r = InitMembers( &OBJ::InitMembers() );
  83                 bless $r;
  84         }
  85
  86 =head1 NOTES
  87
  88 Use '%' if the member should point to an anonymous hash.  Use '@' if the
  89 member should point to an anonymous array.
  90
  91 When using % and @ the method requires one argument for the key or index
  92 into the hash or array.
  93
  94 Prefix the %, @, or $ with '*' to indicate you want to retrieve pointers to
  95 the values rather than the values themselves.
  96
  97 =cut
  98
  99 Var: {
 100         $Class::Template::print = 0;
 101         sub printem { $Class::Template::print++ }
 102 }
 103
 104
 105 sub struct {
 106         my( $struct, $ref ) = @_;
 107         my @methods = ();
 108         my %refs = ();
 109         my %arrays = ();
 110         my %hashes = ();
 111         my $out = '';
 112
 113         $out = "{\n  package $struct;\n  sub new {\n";
 114         parse_fields( $ref, \$out, \@methods, \%refs, \%arrays, \%hashes, 0 );
 115         $out .= "      bless \$r;\n  }\n";
 116         build_methods( $ref, \$out, \@methods, \%refs, \%arrays, \%hashes );
 117         $out .= "}\n1;\n";
 118
 119         ( $Class::Template::print ) ? print( $out ) : eval $out;
 120 }
 121
 122 sub members {
 123         my( $pkg, $ref ) = @_;
 124         my @methods = ();
 125         my %refs = ();
 126         my %arrays = ();
 127         my %hashes = ();
 128         my $out = '';
 129
 130         $out = "{\n  package $pkg;\n  sub InitMembers {\n";
 131         parse_fields( $ref, \$out, \@methods, \%refs, \%arrays, \%hashes, 1 );
 132         $out .= "      bless \$r;\n  }\n";
 133         build_methods( $ref, \$out, \@methods, \%refs, \%arrays, \%hashes );
 134         $out .= "}\n1;\n";
 135
 136         ( $Class::Template::print ) ? print( $out ) : eval $out;
 137 }
 138
 139
 140 sub parse_fields {
 141         my( $ref, $out, $methods, $refs, $arrays, $hashes, $member ) = @_;
 142         my $type = ref $ref;
 143         my @keys;
 144         my $val;
 145         my $cnt = 0;
 146         my $idx = 0;
 147         my( $cmt, $n );
 148
 149         if( $type eq 'HASH' ){
 150                 if( $member ){
 151                         $$out .= "      my(\$r) = \@_ ? shift : {};\n";
 152                 }
 153                 else{
 154                         $$out .= "      my(\$r) = {};\n";
 155                 }
 156                 @keys = keys %$ref;
 157                 foreach (@keys){
 158                         $val = $ref->{$_};
 159                         if( $val =~ /^\*(.)/ ){
 160                                 $refs->{$_}++;
 161                                 $val = $1;
 162                         }
 163                         if( $val eq '@' ){
 164                                 $$out .= "      \$r->{'$_'} = [];\n";
 165                                 $arrays->{$_}++;
 166                         }
 167                         elsif( $val eq '%' ){
 168                                 $$out .= "      \$r->{'$_'} = {};\n";
 169                                 $hashes->{$_}++;
 170                         }
 171                         elsif( $val ne '$' ){
 172                                 $$out .= "      \$r->{'$_'} = \&${val}::new();\n";
 173                         }
 174                         else{
 175                                 $$out .= "      \$r->{'$_'} = undef;\n";
 176                         }
 177                         push( @$methods, $_ );
 178                 }
 179         }
 180         elsif( $type eq 'ARRAY' ){
 181                 if( $member ){
 182                         $$out .= "      my(\$r) = \@_ ? shift : [];\n";
 183                 }
 184                 else{
 185                         $$out .= "      my(\$r) = [];\n";
 186                 }
 187                 while( $idx < @$ref ){
 188                         $n = $ref->[$idx];
 189                         push( @$methods, $n );
 190                         $val = $ref->[$idx+1];
 191                         $cmt = "# $n";
 192                         if( $val =~ /^\*(.)/ ){
 193                                 $refs->{$n}++;
 194                                 $val = $1;
 195                         }
 196                         if( $val eq '@' ){
 197                                 $$out .= "      \$r->[$cnt] = []; $cmt\n";
 198                                 $arrays->{$n}++;
 199                         }
 200                         elsif( $val eq '%' ){
 201                                 $$out .= "      \$r->[$cnt] = {}; $cmt\n";
 202                                 $hashes->{$n}++;
 203                         }
 204                         elsif( $val ne '$' ){
 205                                 $$out .= "      \$r->[$cnt] = \&${val}::new();\n";
 206                         }
 207                         else{
 208                                 $$out .= "      \$r->[$cnt] = undef; $cmt\n";
 209                         }
 210                         ++$cnt;
 211                         $idx += 2;
 212                 }
 213         }
 214 }
 215
 216
 217 sub build_methods {
 218         my( $ref, $out, $methods, $refs, $arrays, $hashes ) = @_;
 219         my $type = ref $ref;
 220         my $elem = '';
 221         my $cnt = 0;
 222         my( $pre, $pst, $cmt, $idx );
 223
 224         foreach (@$methods){
 225                 $pre = $pst = $cmt = $idx = '';
 226                 if( defined $refs->{$_} ){
 227                         $pre = "\\(";
 228                         $pst = ")";
 229                         $cmt = " # returns ref";
 230                 }
 231                 $$out .= "  sub $_ {$cmt\n      my \$r = shift;\n";
 232                 if( $type eq 'ARRAY' ){
 233                         $elem = "[$cnt]";
 234                         ++$cnt;
 235                 }
 236                 elsif( $type eq 'HASH' ){
 237                         $elem = "{'$_'}";
 238                 }
 239                 if( defined $arrays->{$_} ){
 240                         $$out .= "      my \$i;\n";
 241                         $$out .= "      \@_ ? (\$i = shift) : return \$r->$elem;\n";
 242                         $idx = "->[\$i]";
 243                 }
 244                 elsif( defined $hashes->{$_} ){
 245                         $$out .= "      my \$i;\n";
 246                         $$out .= "      \@_ ? (\$i = shift) : return \$r->$elem;\n";
 247                         $idx = "->{\$i}";
 248                 }
 249                 $$out .= "      \@_ ? (\$r->$elem$idx = shift) : $pre\$r->$elem$idx$pst;\n";
 250                 $$out .= "  }\n";
 251         }
 252 }
 253
 254 1;