cvs commit: modperl-2.0/lib/ModPerl Code.pm

[dougm]

dougm       00/06/11 21:41:09

  Modified:    lib/ModPerl Code.pm
  Log:
  add string => flag bit lookup functions
  
  Revision  Changes    Path
  1.28      +29 -4     modperl-2.0/lib/ModPerl/Code.pm
  
  Index: Code.pm
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/lib/ModPerl/Code.pm,v
  retrieving revision 1.27
  retrieving revision 1.28
  diff -u -r1.27 -r1.28
  --- Code.pm   2000/06/12 03:30:50     1.27
  +++ Code.pm   2000/06/12 04:41:09     1.28
  @@ -83,12 +83,14 @@
   
   my %flags = (
       Srv => [qw(NONE PERL_TAINT_CHECK PERL_WARN FRESH_RESTART
  -               PERL_CLONE PERL_ALLOC)],
  +               PERL_CLONE PERL_ALLOC UNSET)],
       Dir => [qw(NONE INCPUSH SENDHDR SENTHDR ENV CLEANUP RCLEANUP)],
       Interp => [qw(NONE IN_USE PUTBACK CLONED BASE)],
       Handler => [qw(NONE PARSED METHOD OBJECT ANON)],
   );
   
  +my %flags_lookup = map { $_,1 } qw(Srv);
  +
   sub new {
       my $class = shift;
       bless {
  @@ -234,10 +236,17 @@
   }
   
   sub generate_flags {
  -    my($self, $h_fh) = @_;
  +    my($self, $h_fh, $c_fh) = @_;
   
       while (my($class, $opts) = each %{ $self->{flags} }) {
           my $i = 0;
  +        my @lookup = ();
  +        my $lookup_proto = "";
  +        if ($flags_lookup{$class}) {
  +            $lookup_proto = join canon_func('flags', 'lookup', $class),
  +              'int ', '(const char *str)';
  +            push @lookup, "$lookup_proto {";
  +        }
   
           print $h_fh "\n#define Mp${class}FLAGS(p) p->flags\n";
           $class = "Mp$class";
  @@ -245,6 +254,10 @@
           for my $f (@$opts) {
               my $flag = "${class}_f_$f";
               my $cmd  = $class . $f;
  +            if (@lookup) {
  +                my $name = canon_name($f);
  +                push @lookup, qq(   if (strEQ(str, "$name")) return $flag;);
  +            }
   
               print $h_fh <<EOF;
   
  @@ -257,6 +270,10 @@
   EOF
               $i += $i || 1;
           }
  +        if (@lookup) {
  +            print $c_fh join "\n", @lookup, "   return -1;\n}\n";
  +            print $h_fh "$lookup_proto;\n";
  +        }
       }
   
       ();
  @@ -346,6 +363,13 @@
       join '_', 'modperl', map { canon_lc($_) } @_;
   }
   
  +sub canon_name {
  +    local $_ = shift;
  +    s/([A-Z]+)/ucfirst(lc($1))/ge;
  +    s/_//g;
  +    $_;
  +}
  +
   sub canon_define {
       join '_', 'MP', map { canon_uc($_) } @_;
   }
  @@ -374,12 +398,13 @@
                                      c => 'modperl_hooks.c'},
      generate_handler_directives => {h => 'modperl_directives.h',
                                      c => 'modperl_directives.c'},
  -   generate_flags              => {h => 'modperl_flags.h'},
  +   generate_flags              => {h => 'modperl_flags.h',
  +                                   c => 'modperl_flags.c'},
      generate_trace              => {h => 'modperl_trace.h'},
   );
   
   my @c_src_names = qw(interp tipool log config callback gtop);
  -my @g_c_names = map { "modperl_$_" } qw(hooks directives xsinit);
  +my @g_c_names = map { "modperl_$_" } qw(hooks directives flags xsinit);
   my @c_names   = ('mod_perl', (map "modperl_$_", @c_src_names));
   sub c_files { [map { "$_.c" } @c_names, @g_c_names] }
   sub o_files { [map { "$_.o" } @c_names, @g_c_names] }