GPL_bin_fullset/NaturalDocs/Modules/NaturalDocs/DefineMembers.pm

   1 ###############################################################################
   2 #
   3 #   Package: NaturalDocs::DefineMembers
   4 #
   5 ###############################################################################
   6 #
   7 #   A custom Perl pragma to define member constants and accessors for use in Natural Docs objects while supporting inheritance.
   8 #
   9 #   Each member will be defined as a numeric constant which should be used as that variable's index into the object arrayref.
  10 #   They will be assigned sequentially from zero, and take into account any members defined this way in parent classes.  Note
  11 #   that you can *not* use multiple inheritance with this method.
  12 #
  13 #   If a parameter ends in parenthesis, it will be generated as an accessor for the previous member.  If it also starts with "Set",
  14 #   the accessor will accept a single parameter to replace the value with.  If it's followed with "duparrayref", it will assume the
  15 #   parameter is either an arrayref or undef, and if the former, will duplicate it to set the value.
  16 #
  17 #   Example:
  18 #
  19 #   > package MyPackage;
  20 #   >
  21 #   > use NaturalDocs::DefineMembers 'VAR_A', 'VarA()', 'SetVarA()',
  22 #   >                                'VAR_B', 'VarB()',
  23 #   >                                'VAR_C',
  24 #   >                                'VAR_D', 'VarD()', 'SetVarD() duparrayref';
  25 #   >
  26 #   > sub SetC #(C)
  27 #   >    {
  28 #   >    my ($self, $c) = @_;
  29 #   >    $self->[VAR_C] = $c;
  30 #   >    };
  31 #
  32 ###############################################################################
  33
  34 # This file is part of Natural Docs, which is Copyright © 2003-2010 Greg Valure
  35 # Natural Docs is licensed under version 3 of the GNU Affero General Public License (AGPL)
  36 # Refer to License.txt for the complete details
  37
  38
  39 package NaturalDocs::DefineMembers;
  40
  41 sub import #(member, member, ...)
  42     {
  43     my ($self, @parameters) = @_;
  44     my $package = caller();
  45
  46     no strict 'refs';
  47     my $parent = ${$package . '::ISA'}[0];
  48     use strict 'refs';
  49
  50     my $memberConstant = 0;
  51     my $lastMemberName;
  52
  53     if (defined $parent && $parent->can('END_OF_MEMBERS'))
  54         {  $memberConstant = $parent->END_OF_MEMBERS();  };
  55
  56     my $code = '{ package ' . $package . ";\n";
  57
  58     foreach my $parameter (@parameters)
  59         {
  60         if ($parameter =~ /^(.+)\(\) *(duparrayref)?$/i)
  61             {
  62             my ($functionName, $pragma) = ($1, lc($2));
  63
  64             if ($functionName =~ /^Set/)
  65                 {
  66                 if ($pragma eq 'duparrayref')
  67                     {
  68                     $code .=
  69                     'sub ' . $functionName . '
  70                         {
  71                         if (defined $_[1])
  72                             {  $_[0]->[' . $lastMemberName . '] = [ @{$_[1]} ];  }
  73                         else
  74                             {  $_[0]->[' . $lastMemberName . '] = undef;  };
  75                         };' . "\n";
  76                     }
  77                 else
  78                     {
  79                     $code .= 'sub ' . $functionName . ' { $_[0]->[' . $lastMemberName . '] = $_[1];  };' . "\n";
  80                     };
  81                 }
  82             else
  83                 {
  84                 $code .= 'sub ' . $functionName . ' { return $_[0]->[' . $lastMemberName . '];  };' . "\n";
  85                 };
  86             }
  87         else
  88             {
  89             $code .= 'use constant ' . $parameter . ' => ' . $memberConstant . ";\n";
  90             $memberConstant++;
  91             $lastMemberName = $parameter;
  92             };
  93         };
  94
  95     $code .= 'use constant END_OF_MEMBERS => ' . $memberConstant . ";\n";
  96     $code .= '};';
  97
  98     eval $code;
  99     };
 100
 101 1;