[Summary view] [Print] [Text view]

   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;