lib/ExtUtils/Constant/XS.pm

   1 package ExtUtils::Constant::XS;
   2
   3 use strict;
   4 use vars qw($VERSION %XS_Constant %XS_TypeSet @ISA @EXPORT_OK $is_perl56);
   5 use Carp;
   6 use ExtUtils::Constant::Utils 'perl_stringify';
   7 require ExtUtils::Constant::Base;
   8
   9
  10 @ISA = qw(ExtUtils::Constant::Base Exporter);
  11 @EXPORT_OK = qw(%XS_Constant %XS_TypeSet);
  12
  13 $VERSION = '0.01';
  14
  15 $is_perl56 = ($] < 5.007 && $] > 5.005_50);
  16
  17 =head1 NAME
  18
  19 ExtUtils::Constant::Base - base class for ExtUtils::Constant objects
  20
  21 =head1 SYNOPSIS
  22
  23     require ExtUtils::Constant::XS;
  24
  25 =head1 DESCRIPTION
  26
  27 ExtUtils::Constant::XS overrides ExtUtils::Constant::Base to generate C
  28 code for XS modules' constants.
  29
  30 =head1 BUGS
  31
  32 Nothing is documented.
  33
  34 Probably others.
  35
  36 =head1 AUTHOR
  37
  38 Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
  39 others
  40
  41 =cut
  42
  43 # '' is used as a flag to indicate non-ascii macro names, and hence the need
  44 # to pass in the utf8 on/off flag.
  45 %XS_Constant = (
  46                 ''    => '',
  47                 IV    => 'PUSHi(iv)',
  48                 UV    => 'PUSHu((UV)iv)',
  49                 NV    => 'PUSHn(nv)',
  50                 PV    => 'PUSHp(pv, strlen(pv))',
  51                 PVN   => 'PUSHp(pv, iv)',
  52                 SV    => 'PUSHs(sv)',
  53                 YES   => 'PUSHs(&PL_sv_yes)',
  54                 NO    => 'PUSHs(&PL_sv_no)',
  55                 UNDEF => '',    # implicit undef
  56 );
  57
  58 %XS_TypeSet = (
  59                 IV    => '*iv_return = ',
  60                 UV    => '*iv_return = (IV)',
  61                 NV    => '*nv_return = ',
  62                 PV    => '*pv_return = ',
  63                 PVN   => ['*pv_return = ', '*iv_return = (IV)'],
  64                 SV    => '*sv_return = ',
  65                 YES   => undef,
  66                 NO    => undef,
  67                 UNDEF => undef,
  68 );
  69
  70 sub header {
  71   my $start = 1;
  72   my @lines;
  73   push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++;
  74   push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++;
  75   foreach (sort keys %XS_Constant) {
  76     next if $_ eq '';
  77     push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++;
  78   }
  79   push @lines, << 'EOT';
  80
  81 #ifndef NVTYPE
  82 typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it.  */
  83 #endif
  84 #ifndef aTHX_
  85 #define aTHX_ /* 5.6 or later define this for threading support.  */
  86 #endif
  87 #ifndef pTHX_
  88 #define pTHX_ /* 5.6 or later define this for threading support.  */
  89 #endif
  90 EOT
  91
  92   return join '', @lines;
  93 }
  94
  95 sub valid_type {
  96   my ($self, $type) = @_;
  97   return exists $XS_TypeSet{$type};
  98 }
  99
 100 # This might actually be a return statement
 101 sub assignment_clause_for_type {
 102   my $self = shift;
 103   my $args = shift;
 104   my $type = $args->{type};
 105   my $typeset = $XS_TypeSet{$type};
 106   if (ref $typeset) {
 107     die "Type $type is aggregate, but only single value given"
 108       if @_ == 1;
 109     return map {"$typeset->[$_]$_[$_];"} 0 .. $#$typeset;
 110   } elsif (defined $typeset) {
 111     confess "Aggregate value given for type $type"
 112       if @_ > 1;
 113     return "$typeset$_[0];";
 114   }
 115   return ();
 116 }
 117
 118 sub return_statement_for_type {
 119   my ($self, $type) = @_;
 120   # In the future may pass in an options hash
 121   $type = $type->{type} if ref $type;
 122   "return PERL_constant_IS$type;";
 123 }
 124
 125 sub return_statement_for_notdef {
 126   # my ($self) = @_;
 127   "return PERL_constant_NOTDEF;";
 128 }
 129
 130 sub return_statement_for_notfound {
 131   # my ($self) = @_;
 132   "return PERL_constant_NOTFOUND;";
 133 }
 134
 135 sub default_type {
 136   'IV';
 137 }
 138
 139 sub macro_from_name {
 140   my ($self, $item) = @_;
 141   my $macro = $item->{name};
 142   $macro = $item->{value} unless defined $macro;
 143   $macro;
 144 }
 145
 146 # Keep to the traditional perl source macro
 147 sub memEQ {
 148   "memEQ";
 149 }
 150
 151 sub params {
 152   my ($self, $what) = @_;
 153   foreach (sort keys %$what) {
 154     warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_};
 155   }
 156   my $params = {};
 157   $params->{''} = 1 if $what->{''};
 158   $params->{IV} = 1 if $what->{IV} || $what->{UV} || $what->{PVN};
 159   $params->{NV} = 1 if $what->{NV};
 160   $params->{PV} = 1 if $what->{PV} || $what->{PVN};
 161   $params->{SV} = 1 if $what->{SV};
 162   return $params;
 163 }
 164
 165
 166 sub C_constant_prefix_param {
 167   "aTHX_ ";
 168 }
 169
 170 sub C_constant_prefix_param_defintion {
 171   "pTHX_ ";
 172 }
 173
 174 sub namelen_param_definition {
 175   'STRLEN ' . $_[0] -> namelen_param;
 176 }
 177
 178 sub C_constant_other_params_defintion {
 179   my ($self, $params) = @_;
 180   my $body = '';
 181   $body .= ", int utf8" if $params->{''};
 182   $body .= ", IV *iv_return" if $params->{IV};
 183   $body .= ", NV *nv_return" if $params->{NV};
 184   $body .= ", const char **pv_return" if $params->{PV};
 185   $body .= ", SV **sv_return" if $params->{SV};
 186   $body;
 187 }
 188
 189 sub C_constant_other_params {
 190   my ($self, $params) = @_;
 191   my $body = '';
 192   $body .= ", utf8" if $params->{''};
 193   $body .= ", iv_return" if $params->{IV};
 194   $body .= ", nv_return" if $params->{NV};
 195   $body .= ", pv_return" if $params->{PV};
 196   $body .= ", sv_return" if $params->{SV};
 197   $body;
 198 }
 199
 200 sub dogfood {
 201   my ($self, $args, @items) = @_;
 202   my ($package, $subname, $default_type, $what, $indent, $breakout) =
 203     @{$args}{qw(package subname default_type what indent breakout)};
 204   my $result = <<"EOT";
 205   /* When generated this function returned values for the list of names given
 206      in this section of perl code.  Rather than manually editing these functions
 207      to add or remove constants, which would result in this comment and section
 208      of code becoming inaccurate, we recommend that you edit this section of
 209      code, and use it to regenerate a new set of constant functions which you
 210      then use to replace the originals.
 211
 212      Regenerate these constant functions by feeding this entire source file to
 213      perl -x
 214
 215 #!$^X -w
 216 use ExtUtils::Constant qw (constant_types C_constant XS_constant);
 217
 218 EOT
 219   $result .= $self->dump_names ({default_type=>$default_type, what=>$what,
 220                                  indent=>0, declare_types=>1},
 221                                 @items);
 222   $result .= <<'EOT';
 223
 224 print constant_types(); # macro defs
 225 EOT
 226   $package = perl_stringify($package);
 227   $result .=
 228     "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, ";
 229   # The form of the indent parameter isn't defined. (Yet)
 230   if (defined $indent) {
 231     require Data::Dumper;
 232     $Data::Dumper::Terse=1;
 233     $Data::Dumper::Terse=1; # Not used once. :-)
 234     chomp ($indent = Data::Dumper::Dumper ($indent));
 235     $result .= $indent;
 236   } else {
 237     $result .= 'undef';
 238   }
 239   $result .= ", $breakout" . ', @names) ) {
 240     print $_, "\n"; # C constant subs
 241 }
 242 print "#### XS Section:\n";
 243 print XS_constant ("' . $package . '", $types);
 244 __END__
 245    */
 246
 247 ';
 248
 249   $result;
 250 }
 251
 252 1;