Eliminate four unsightly magical hash refs

Previously, we'd be generating and passing around four lookup tables for
C-type to XS-type (type kind), C-type to prototype, XS-type to input map
code, and XS-type to output map code. This is now all handled by
ExtUtils::Typemaps.

diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm
index a11c03e..9de9770 100644 (file)
--- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm
+++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm
@@ -137,25 +137,7 @@ sub process_file {
     select $args{output};
   }
 
-  (
-    $self->{type_kind},
-    $self->{proto_letter},
-    $self->{input_expr},
-    $self->{output_expr},
-  ) = process_typemaps( $args{typemap}, $pwd );
-
-  foreach my $value (values %{ $self->{input_expr} }) {
-    $value =~ s/;*\s+\z//;
-    # Move C pre-processor instructions to column 1 to be strictly ANSI
-    # conformant. Some pre-processors are fussy about this.
-    $value =~ s/^\s+#/#/mg;
-  }
-  foreach my $value (values %{ $self->{output_expr} }) {
-    # And again.
-    $value =~ s/^\s+#/#/mg;
-  }
-
-  my %targetable = make_targetable($self->{output_expr});
+  $self->{typemap} = process_typemaps( $args{typemap}, $pwd );
 
   my $END = "!End!\n\n";        # "impossible" keyword (multiple newline)
 
@@ -628,8 +610,9 @@ EOF
             if !$self->{retvaldone};
           $self->{args_match}->{"RETVAL"} = 0;
           $self->{var_types}->{"RETVAL"} = $self->{ret_type};
+          my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} );
           print "\tdXSTARG;\n"
-            if $self->{optimize} and $targetable{$self->{type_kind}->{$self->{ret_type}}};
+            if $self->{optimize} and $outputmap and $outputmap->targetable;
         }
 
         if (@fake_INPUT or @fake_INPUT_pre) {
@@ -706,7 +689,8 @@ EOF
         print "\t$self->{RETVAL_code}\n";
       }
       elsif ($self->{gotRETVAL} || $wantRETVAL) {
-        my $t = $self->{optimize} && $targetable{$self->{type_kind}->{$self->{ret_type}}};
+        my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} );
+        my $t = $self->{optimize} && $outputmap && $outputmap->targetable;
         # Although the '$var' declared in the next line is never explicitly
         # used within this 'elsif' block, commenting it out leads to
         # disaster, starting with the first 'eval qq' inside the 'elsif' block
@@ -718,24 +702,23 @@ EOF
         my $var = 'RETVAL';
         my $type = $self->{ret_type};
 
-        # 0: type, 1: with_size, 2: how, 3: how_size
-        if ($t and not $t->[1] and $t->[0] eq 'p') {
+        if ($t and not $t->{with_size} and $t->{type} eq 'p') {
           # PUSHp corresponds to setpvn.  Treat setpv directly
-          my $what = eval qq("$t->[2]");
+          my $what = eval qq("$t->{what}");
           warn $@ if $@;
 
           print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";
           $prepush_done = 1;
         }
         elsif ($t) {
-          my $what = eval qq("$t->[2]");
+          my $what = eval qq("$t->{what}");
           warn $@ if $@;
 
-          my $tsize = $t->[3];
+          my $tsize = $t->{what_size};
           $tsize = '' unless defined $tsize;
           $tsize = eval qq("$tsize");
           warn $@ if $@;
-          print "\tXSprePUSH; PUSH$t->[0]($what$tsize);\n";
+          print "\tXSprePUSH; PUSH$t->{type}($what$tsize);\n";
           $prepush_done = 1;
         }
         else {
@@ -1108,7 +1091,8 @@ sub INPUT_handler {
     $self->{var_num} = $self->{args_match}->{$var_name};
 
     if ($self->{var_num}) {
-      $self->{proto_arg}->[$self->{var_num}] = $self->{proto_letter}->{$var_type} || "\$";
+      my $typemap = $self->{typemap}->get_typemap(ctype => $var_type);
+      $self->{proto_arg}->[$self->{var_num}] = ($typemap && $typemap->proto) || "\$";
     }
     $self->{func_args} =~ s/\b($var_name)\b/&$1/ if $var_addr;
     if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
@@ -1681,19 +1665,22 @@ sub generate_init {
     $argsref->{printed_name},
   );
   my $arg = "ST(" . ($num - 1) . ")";
-  my ($argoff, $ntype, $tk);
+  my ($argoff, $ntype);
   $argoff = $num - 1;
 
+  my $typemaps = $self->{typemap};
+
   $type = tidy_type($type);
   blurt( $self, "Error: '$type' not in typemap"), return
-    unless defined($self->{type_kind}->{$type});
+    unless $typemaps->get_typemap(ctype => $type);
 
   ($ntype = $type) =~ s/\s*\*/Ptr/g;
   my $subtype;
   ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
-  $tk = $self->{type_kind}->{$type};
-  $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
-  if ($tk eq 'T_PV' and exists $self->{lengthof}->{$var}) {
+  my $typem = $typemaps->get_typemap(ctype => $type);
+  my $xstype = $typem->xstype;
+  $xstype =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
+  if ($xstype eq 'T_PV' and exists $self->{lengthof}->{$var}) {
     print "\t$var" unless $printed_name;
     print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
     die "default value not supported with length(NAME) supplied"
@@ -1701,15 +1688,21 @@ sub generate_init {
     return;
   }
   $type =~ tr/:/_/ unless $self->{hiertype};
-  blurt( $self, "Error: No INPUT definition for type '$type', typekind '$self->{type_kind}->{$type}' found"), return
-    unless defined $self->{input_expr}->{$tk};
-  my $expr = $self->{input_expr}->{$tk};
+
+  my $inputmap = $typemaps->get_inputmap(xstype => $xstype);
+  blurt( $self, "Error: No INPUT definition for type '$type', typekind '" . $type->xstype . "' found"), return
+    unless defined $inputmap;
+
+  my $expr = $inputmap->cleaned_code;
+  # Note: This gruesome bit either needs heavy rethinking or documentation. I vote for the former. --Steffen
   if ($expr =~ /DO_ARRAY_ELEM/) {
+    my $subtypemap  = $typemaps->get_typemap(ctype => $subtype);
+    my $subinputmap = $typemaps->get_inputmap(xstype => $subtypemap->xstype);
     blurt( $self, "Error: '$subtype' not in typemap"), return
-      unless defined($self->{type_kind}->{$subtype});
-    blurt( $self, "Error: No INPUT definition for type '$subtype', typekind '$self->{type_kind}->{$subtype}' found"), return
-      unless defined $self->{input_expr}->{$self->{type_kind}->{$subtype}};
-    my $subexpr = $self->{input_expr}->{$self->{type_kind}->{$subtype}};
+      unless $subtypemap;
+    blurt( $self, "Error: No INPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"), return
+      unless $subinputmap;
+    my $subexpr = $subinputmap->cleaned_code;
     $subexpr =~ s/\$type/\$subtype/g;
     $subexpr =~ s/ntype/subtype/g;
     $subexpr =~ s/\$arg/ST(ix_$var)/g;
@@ -1770,6 +1763,8 @@ sub generate_output {
   my $arg = "ST(" . ($num - ($num != 0)) . ")";
   my $ntype;
 
+  my $typemaps = $self->{typemap};
+
   $type = tidy_type($type);
   if ($type =~ /^array\(([^,]*),(.*)\)/) {
     print "\t$arg = sv_newmortal();\n";
@@ -1777,21 +1772,26 @@ sub generate_output {
     print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
   }
   else {
+    my $typemap   = $typemaps->get_typemap(ctype => $type);
+    my $outputmap = $typemaps->get_outputmap(xstype => $typemap->xstype);
     blurt( $self, "Error: '$type' not in typemap"), return
-      unless defined($self->{type_kind}->{$type});
-    blurt( $self, "Error: No OUTPUT definition for type '$type', typekind '$self->{type_kind}->{$type}' found"), return
-      unless defined $self->{output_expr}->{$self->{type_kind}->{$type}};
+      unless $typemap;
+    blurt( $self, "Error: No OUTPUT definition for type '$type', typekind '" . $typemap->xstype . "' found"), return
+      unless $outputmap;
     ($ntype = $type) =~ s/\s*\*/Ptr/g;
     $ntype =~ s/\(\)//g;
     my $subtype;
     ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
-    my $expr = $self->{output_expr}->{$self->{type_kind}->{$type}};
+
+    my $expr = $outputmap->cleaned_code;
     if ($expr =~ /DO_ARRAY_ELEM/) {
+      my $subtypemap   = $typemaps->get_typemap(ctype => $subtype);
+      my $suboutputmap = $typemaps->get_outputmap(xstype => $subtypemap->xstype);
       blurt( $self, "Error: '$subtype' not in typemap"), return
-        unless defined($self->{type_kind}->{$subtype});
-      blurt( $self, "Error: No OUTPUT definition for type '$subtype', typekind '$self->{type_kind}->{$subtype}' found"), return
-        unless defined $self->{output_expr}->{$self->{type_kind}->{$subtype}};
-      my $subexpr = $self->{output_expr}->{$self->{type_kind}->{$subtype}};
+        unless $subtypemap;
+      blurt( $self, "Error: No OUTPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"), return
+        unless $suboutputmap;
+      my $subexpr = $suboutputmap->cleaned_code;
       $subexpr =~ s/ntype/subtype/g;
       $subexpr =~ s/\$arg/ST(ix_$var)/g;
       $subexpr =~ s/\$var/${var}[ix_$var]/g;

diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm
index b492f38..e4ab36d 100644 (file)
--- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm
+++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm
@@ -289,76 +289,7 @@ directory.
 
 =item * Return Value
 
-Upon success, returns a list of four hash references.  (This will probably be
-refactored.)  Here is a I<rough> description of what is in these hashrefs:
-
-=over 4
-
-=item * C<$type_kind_ref>
-
-  {
-    'char **' => 'T_PACKEDARRAY',
-    'bool_t' => 'T_IV',
-    'AV *' => 'T_AVREF',
-    'InputStream' => 'T_IN',
-    'double' => 'T_DOUBLE',
-    # ...
-  }
-
-Keys:  C types.  Values:  XS types identifiers
-
-=item * C<$proto_letter_ref>
-
-  {
-    'char **' => '$',
-    'bool_t' => '$',
-    'AV *' => '$',
-    'InputStream' => '$',
-    'double' => '$',
-    # ...
-  }
-
-Keys: C types.  Values. Corresponding prototype letters.
-
-=item * C<$input_expr_ref>
-
-  {
-    'T_CALLBACK' => '  $var = make_perl_cb_$type($arg)
-  ',
-    'T_OUT' => '       $var = IoOFP(sv_2io($arg))
-  ',
-    'T_REF_IV_PTR' => '        if (sv_isa($arg, \\"${ntype}\\")) {
-    # ...
-  }
-
-Keys:  XS typemap identifiers.  Values:  Newline-terminated strings that
-will be written to C source code (F<.c>) files.   The strings are C code, but
-with Perl variables whose values will be interpolated at F<xsubpp>'s runtime
-by one of the C<eval EXPR> statements in ExtUtils::ParseXS.
-
-=item * C<$output_expr_ref>
-
-  {
-    'T_CALLBACK' => '  sv_setpvn($arg, $var.context.value().chp(),
-               $var.context.value().size());
-  ',
-    'T_OUT' => '       {
-           GV *gv = newGVgen("$Package");
-           if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) )
-               sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
-           else
-               $arg = &PL_sv_undef;
-       }
-  ',
-    # ...
-  }
-
-Keys:  XS typemap identifiers.  Values:  Newline-terminated strings that
-will be written to C source code (F<.c>) files.   The strings are C code, but
-with Perl variables whose values will be interpolated at F<xsubpp>'s runtime
-by one of the C<eval EXPR> statements in ExtUtils::ParseXS.
-
-=back
+Upon success, returns an L<ExtUtils::Typemaps> object.
 
 =back
 
@@ -385,12 +316,7 @@ sub process_typemaps {
     $typemap->merge(file => $typemap_loc, replace => 1);
   }
 
-  return (
-    $typemap->_get_typemap_hash(),
-    $typemap->_get_prototype_hash(),
-    $typemap->_get_inputmap_hash(),
-    $typemap->_get_outputmap_hash(),
-  );
+  return $typemap;
 }
 
 =head2 C<make_targetable()>

diff --git a/dist/ExtUtils-ParseXS/t/600-t-compat.t b/dist/ExtUtils-ParseXS/t/600-t-compat.t
index 90d3483..abb99f8 100644 (file)
--- a/dist/ExtUtils-ParseXS/t/600-t-compat.t
+++ b/dist/ExtUtils-ParseXS/t/600-t-compat.t
@@ -76,7 +76,8 @@ foreach my $test (@tests) {
   @standard_typemap_locations = @{ $test->{std_maps} };
 
   my $res = [_process_typemaps([@local_tmaps], '.')];
-  my $res_new = [process_typemaps([@local_tmaps], '.')];
+  my $tm = process_typemaps([@local_tmaps], '.');
+  my $res_new = [map $tm->$_(), qw(_get_typemap_hash _get_prototype_hash _get_inputmap_hash _get_outputmap_hash) ];
 
   # Normalize trailing whitespace. Let's be that lenient, mkay?
   for ($res, $res_new) {