From: Gurusamy Sarathy <gsar@cpan.org>
Date: Fri, 3 Mar 2000 01:59:49 +0000 (+0000)
Subject: support for generation of accessor functions (from Hugo van der
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7c1d48a58e96316fb1cc83908d021dc029328ce5;p=p5sagit%2Fp5-mst-13.2.git

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
--- 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;