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.02';
  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 sub macro_from_item {
 147   my ($self, $item) = @_;
 148   my $macro = $item->{macro};
 149   $macro = $self->macro_from_name($item) unless defined $macro;
 150   $macro;
 151 }
 152
 153 # Keep to the traditional perl source macro
 154 sub memEQ {
 155   "memEQ";
 156 }
 157
 158 sub params {
 159   my ($self, $what) = @_;
 160   foreach (sort keys %$what) {
 161     warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_};
 162   }
 163   my $params = {};
 164   $params->{''} = 1 if $what->{''};
 165   $params->{IV} = 1 if $what->{IV} || $what->{UV} || $what->{PVN};
 166   $params->{NV} = 1 if $what->{NV};
 167   $params->{PV} = 1 if $what->{PV} || $what->{PVN};
 168   $params->{SV} = 1 if $what->{SV};
 169   return $params;
 170 }
 171
 172
 173 sub C_constant_prefix_param {
 174   "aTHX_ ";
 175 }
 176
 177 sub C_constant_prefix_param_defintion {
 178   "pTHX_ ";
 179 }
 180
 181 sub namelen_param_definition {
 182   'STRLEN ' . $_[0] -> namelen_param;
 183 }
 184
 185 sub C_constant_other_params_defintion {
 186   my ($self, $params) = @_;
 187   my $body = '';
 188   $body .= ", int utf8" if $params->{''};
 189   $body .= ", IV *iv_return" if $params->{IV};
 190   $body .= ", NV *nv_return" if $params->{NV};
 191   $body .= ", const char **pv_return" if $params->{PV};
 192   $body .= ", SV **sv_return" if $params->{SV};
 193   $body;
 194 }
 195
 196 sub C_constant_other_params {
 197   my ($self, $params) = @_;
 198   my $body = '';
 199   $body .= ", utf8" if $params->{''};
 200   $body .= ", iv_return" if $params->{IV};
 201   $body .= ", nv_return" if $params->{NV};
 202   $body .= ", pv_return" if $params->{PV};
 203   $body .= ", sv_return" if $params->{SV};
 204   $body;
 205 }
 206
 207 sub dogfood {
 208   my ($self, $args, @items) = @_;
 209   my ($package, $subname, $default_type, $what, $indent, $breakout) =
 210     @{$args}{qw(package subname default_type what indent breakout)};
 211   my $result = <<"EOT";
 212   /* When generated this function returned values for the list of names given
 213      in this section of perl code.  Rather than manually editing these functions
 214      to add or remove constants, which would result in this comment and section
 215      of code becoming inaccurate, we recommend that you edit this section of
 216      code, and use it to regenerate a new set of constant functions which you
 217      then use to replace the originals.
 218
 219      Regenerate these constant functions by feeding this entire source file to
 220      perl -x
 221
 222 #!$^X -w
 223 use ExtUtils::Constant qw (constant_types C_constant XS_constant);
 224
 225 EOT
 226   $result .= $self->dump_names ({default_type=>$default_type, what=>$what,
 227                                  indent=>0, declare_types=>1},
 228                                 @items);
 229   $result .= <<'EOT';
 230
 231 print constant_types(), "\n"; # macro defs
 232 EOT
 233   $package = perl_stringify($package);
 234   $result .=
 235     "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, ";
 236   # The form of the indent parameter isn't defined. (Yet)
 237   if (defined $indent) {
 238     require Data::Dumper;
 239     $Data::Dumper::Terse=1;
 240     $Data::Dumper::Terse=1; # Not used once. :-)
 241     chomp ($indent = Data::Dumper::Dumper ($indent));
 242     $result .= $indent;
 243   } else {
 244     $result .= 'undef';
 245   }
 246   $result .= ", $breakout" . ', @names) ) {
 247     print $_, "\n"; # C constant subs
 248 }
 249 print "\n#### XS Section:\n";
 250 print XS_constant ("' . $package . '", $types);
 251 __END__
 252    */
 253
 254 ';
 255
 256   $result;
 257 }
 258
 259 1;