support for generation of accessor functions (from Hugo van der

Sanden)

p4raw-id: //depot/perl@5462

diff --git a/utils/h2xs.PL b/utils/h2xs.PL
index c47418e..333e891 100644 (file)
--- a/utils/h2xs.PL
+++ b/utils/h2xs.PL
@@ -100,6 +100,14 @@ Omit the autogenerated stub POD section.
 Omit the XS portion.  Used to generate templates for a module which is not
 XS-based.  C<-c> and C<-f> are implicitly enabled.
 
+=item B<-a>
+
+Generate an accessor method for each element of structs and unions. The
+generated methods are named after the element name; will return the current
+value of the element if called without additional arguments; and will set
+the element to the supplied value (and return the old value) if called with
+an additional argument.
+
 =item B<-c>
 
 Omit C<constant()> from the .xs file and corresponding specialised
@@ -322,6 +330,7 @@ version: $H2XS_VERSION
     -O   Allow overwriting of a pre-existing extension directory.
     -P   Omit the stub POD section.
     -X   Omit the XS portion (implies both -c and -f).
+    -a   Generate get/set accessors for struct and union members (used with -x).
     -c   Omit the constant() function and specialised AUTOLOAD from the XS file.
     -d   Turn on debugging messages.
     -f   Force creation of the extension even if the C header does not exist.
@@ -339,8 +348,8 @@ extra_libraries
 }
 
 
-getopts("ACF:M:OPXcdfhn:o:p:s:v:x") || usage;
-use vars qw($opt_A $opt_C $opt_F $opt_M $opt_O $opt_P $opt_X $opt_c
+getopts("ACF:M:OPXacdfhn:o:p:s:v:x") || usage;
+use vars qw($opt_A $opt_C $opt_F $opt_M $opt_O $opt_P $opt_X $opt_a $opt_c
            $opt_d $opt_f $opt_h $opt_n $opt_o $opt_p $opt_s $opt_v $opt_x);
 
 usage if $opt_h;
@@ -530,6 +539,7 @@ my $fdecls_parsed = [];
 my $typedef_rex;
 my %typedefs_pre;
 my %known_fnames;
+my %structs;
 
 my @fnames;
 my @fnames_no_prefix;
@@ -554,13 +564,17 @@ if( ! $opt_X ){  # use XS, unless it was disabled
       }
       warn "Scanning $filename for functions...\n";
       $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
-       'add_cppflags' => $addflags;
+       'add_cppflags' => $addflags, 'c_styles' => [qw(C++ C9X)];
       $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]);
 
       push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };
       push(@$fdecls, @{$c->get('fdecls')});
 
       push @td, @{$c->get('typedefs_maybe')};
+      if ($opt_a) {
+       my $structs = $c->get('typedef_structs');
+       @structs{keys %$structs} = values %$structs;
+      }
 
       unless ($tmask_all) {
        warn "Scanning $filename for typedefs...\n";
@@ -1148,6 +1162,47 @@ EOP
   }
 }
 
+sub print_accessors {
+  my($fh, $name, $struct) = @_;
+  return unless defined $struct && $name !~ /\s|_ANON/;
+  $name = normalize_type($name);
+  my $ptrname = normalize_type("$name *");
+  printf $fh <<"EOF";
+
+MODULE = $module               PACKAGE = ${name}Ptr            $prefix
+
+EOF
+  my @items = @$struct;
+  while (@items) {
+    my $item = shift @items;
+    if ($item->[0] =~ /_ANON/) {
+      if (defined $item->[1]) {
+       push @items, map [
+         $_->[0], "$item->[1]_$_->[1]", "$item->[1].$_->[1]"
+       ], @{ $structs{$item->[0]} };
+      } else {
+       push @items, @{ $structs{$item->[0]} };
+      }
+    } else {
+      my $type = normalize_type($item->[0]);
+      print $fh <<"EOF";
+$type
+$item->[1](THIS, __value = NO_INIT)
+       $ptrname THIS
+       $type __value
+    PROTOTYPE: \$;\$
+    CODE:
+       RETVAL = THIS->$item->[-1];
+       if (items > 1)
+           THIS->$item->[-1] = __value;
+    OUTPUT:
+       RETVAL
+
+EOF
+    }
+  }
+}
+
 # Should be called before any actual call to normalize_type().
 sub get_typemap {
   # We do not want to read ./typemap by obvios reasons.
@@ -1240,6 +1295,11 @@ sub assign_typemap_entry {
 
 if ($opt_x) {
     for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
+    if ($opt_a) {
+       while (my($name, $struct) = each %structs) {
+           print_accessors(\*XS, $name, $struct);
+       }
+    }
 }
 
 close XS;