ExtUtils::Constant

Message-ID: <20010610232540.C76396@plum.flirble.org>

p4raw-id: //depot/perl@10507

diff --git a/lib/ExtUtils/Constant.pm b/lib/ExtUtils/Constant.pm
index 4efccfe..25feacc 100644 (file)
--- a/lib/ExtUtils/Constant.pm
+++ b/lib/ExtUtils/Constant.pm
@@ -55,6 +55,18 @@ NUL terminated string, length will be determined with C<strlen>
 A fixed length thing, given as a [pointer, length] pair. If you know the
 length of a string at compile time you may use this instead of I<PV>
 
+=item YES
+
+Truth.  (C<PL_sv_yes>)  The value is not needed (and ignored).
+
+=item NO
+
+Defined Falsehood.  (C<PL_sv_no>)  The value is not needed (and ignored).
+
+=item UNDEF
+
+C<undef>.  The value of the macro is not needed.
+
 =back
 
 =head1 FUNCTIONS
@@ -75,7 +87,7 @@ $Text::Wrap::huge = 'overflow';
 $Text::Wrap::columns = 80;
 
 @ISA = 'Exporter';
-$VERSION = '0.03';
+$VERSION = '0.04';
 
 %EXPORT_TAGS = ( 'all' => [ qw(
        XS_constant constant_types return_clause memEQ_clause C_stringify
@@ -89,7 +101,10 @@ $VERSION = '0.03';
                 UV => 'PUSHu((UV)iv)',
                 NV => 'PUSHn(nv)',
                 PV => 'PUSHp(pv, strlen(pv))',
-                PVN => 'PUSHp(pv, iv)'
+                PVN => 'PUSHp(pv, iv)',
+               YES => 'PUSHs(&PL_sv_yes)',
+               NO => 'PUSHs(&PL_sv_no)',
+               UNDEF => ''     # implicit undef
 );
 
 %XS_TypeSet = (
@@ -97,7 +112,8 @@ $VERSION = '0.03';
                 UV => '*iv_return = (IV)',
                 NV => '*nv_return =',
                 PV => '*pv_return =',
-                PVN => ['*pv_return =', '*iv_return = (IV)']
+                PVN => ['*pv_return =', '*iv_return = (IV)'],
+               YES => undef, NO => undef, UNDEF => undef
 );
 
 
@@ -116,6 +132,9 @@ sub C_stringify {
   s/([\"\'])/\\$1/g;   # Grr. fix perl mode.
   s/\n/\\n/g;          # Ensure newlines don't end up in octal
   s/\r/\\r/g;
+  s/\t/\\t/g;
+  s/\f/\\f/g;
+  s/\a/\\a/g;
   s/([[:cntrl:]])/sprintf "\\%03o", ord $1/ge;
   s/\177/\\177/g;      # DEL doesn't seem to be a [:cntrl:]
   $_;
@@ -201,16 +220,16 @@ I<VALUE>s for the components.
 sub assign {
   my $indent = shift;
   my $type = shift;
-  my $typeset = $XS_TypeSet{$type};
   my $clause;
-  die "Can't generate code for type $type" unless defined $typeset;
+  die "Can't generate code for type $type" unless exists $XS_TypeSet{$type};
+  my $typeset = $XS_TypeSet{$type};
   if (ref $typeset) {
     die "Type $type is aggregate, but only single value given"
       if @_ == 1;
     foreach (0 .. $#$typeset) {
       $clause .= $indent . "$typeset->[$_] $_[$_];\n";
     }
-  } else {
+  } elsif (defined $typeset) {
     die "Aggregate value given for type $type"
       if @_ > 1;
     $clause .= $indent . "$typeset $_[0];\n";
@@ -372,6 +391,8 @@ EOT
       # Ensure that the enclosing C comment doesn't end
       # by turning */  into *" . "/
       $line =~ s!\*\/!\*" . "/!gs;
+      # gcc -Wall doesn't like finding /* inside a comment
+      $line =~ s!\/\*!/" . "\*!gs;
       $result .= $line;
     }
   }

diff --git a/t/lib/extutils.t b/t/lib/extutils.t
index 9d54dad..48c2aa3 100644 (file)
--- a/t/lib/extutils.t
+++ b/t/lib/extutils.t
@@ -1,6 +1,6 @@
 #!./perl -w
 
-print "1..18\n";
+print "1..21\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -47,9 +47,15 @@ my @names = ("FIVE", {name=>"OK6", type=>"PV",},
               value=>['"not ok 7\\n\\0ok 7\\n"', 15]},
              {name => "FARTHING", type=>"NV"},
              {name => "NOT_ZERO", type=>"UV", value=>"~(UV)0"},
+             {name => "OPEN", type=>"PV", value=>'"/*"',
+              macro=>["#if 1\n", "#endif\n"]},
              {name => "CLOSE", type=>"PV", value=>'"*/"',
               macro=>["#if 1\n", "#endif\n"]},
-             {name => "ANSWER", default=>["UV", 42]}, "NOTDEF");
+             {name => "ANSWER", default=>["UV", 42]}, "NOTDEF",
+             {name => "Yes", type=>"YES"},
+             {name => "No", type=>"NO"},
+             {name => "Undef", type=>"UNDEF"}
+);
 
 my @names_only = map {(ref $_) ? $_->{name} : $_} @names;
 
@@ -69,6 +75,9 @@ print FH <<'EOT';
 #define OK7 1
 #define FARTHING 0.25
 #define NOT_ZERO 1
+#define Yes 0
+#define No 1
+#define Undef 1
 #undef NOTDEF
 EOT
 close FH or die "close $header: $!\n";
@@ -199,6 +208,30 @@ if (defined $notthere) {
   print "ok 13\n";
 }
 
+# Truth
+my $yes = Yes;
+if ($yes) {
+  print "ok 14\n";
+} else {
+  print "not ok 14 # $yes='\$yes'\n";
+}
+
+# Falsehood
+my $no = No;
+if (defined $no and !$no) {
+  print "ok 15\n";
+} else {
+  print "not ok 15 # \$no=" . defined ($no) ? "'$no'\n" : "undef\n";
+}
+
+# Undef
+my $undef = Undef;
+unless (defined $undef) {
+  print "ok 16\n";
+} else {
+  print "not ok 16 # \$undef='$undef'\n";
+}
+
 EOT
 
 close FH or die "close $testpl: $!\n";
@@ -276,27 +309,29 @@ if ($Config{usedl}) {
   }
 }
 
-my $test = 14;
+my $test = 17;
 my $maketest = "$make test";
 print "# make = '$maketest'\n";
 $makeout = `$maketest`;
-if ($?) {
-  print "not ok $test # $maketest failed: $?\n";
-} else {
-  # echo of running the test script
-  $makeout =~ s/^\s*PERL_DL_NONLAZY=.+?\n//m;
-  $makeout =~ s/^MCR.+test.pl\n//mig if $^O eq 'VMS';
 
-  # GNU make babblings
-  $makeout =~ s/^\w*?make.+?(?:entering|leaving) directory.+?\n//mig;
+# echo of running the test script
+$makeout =~ s/^\s*PERL_DL_NONLAZY=.+?\n//m;
+$makeout =~ s/^MCR.+test.pl\n//mig if $^O eq 'VMS';
+
+# GNU make babblings
+$makeout =~ s/^\w*?make.+?(?:entering|leaving) directory.+?\n//mig;
 
-  # Hopefully gets most make's babblings
-  # make -f Makefile.aperl perl
-  $makeout =~ s/^\w*?make.+\sperl[^A-Za-z0-9]*\n//mig;
-  # make[1]: `perl' is up to date.
-  $makeout =~ s/^\w*?make.+perl.+?is up to date.*?\n//mig;
+# Hopefully gets most make's babblings
+# make -f Makefile.aperl perl
+$makeout =~ s/^\w*?make.+\sperl[^A-Za-z0-9]*\n//mig;
+# make[1]: `perl' is up to date.
+$makeout =~ s/^\w*?make.+perl.+?is up to date.*?\n//mig;
 
-  print $makeout;
+print $makeout;
+
+if ($?) {
+  print "not ok $test # $maketest failed: $?\n";
+} else {
   print "ok $test\n";
 }
 $test++;