0x3E8 "l4()P@˂f^S h 7l4()P@ :- 0a4()P@ۀ6-  q¾package ExtUtils::Constant::XS; use strict; use vars qw($VERSION %XS_Constant %XS_TypeSet @ISA @EXPORT_OK $is_perl56); use Carp; use ExtUtils::Constant::Utils 'perl_stringify'; require ExtUtils::Constant::Base; @ISA = qw(ExtUtils::Constant::Base Exporter); @EXPORT_OK = qw(%XS_Constant %XS_TypeSet); $VERSION = '0.03'; $is_perl56 = ($] < 5.007 && $] > 5.005_50); =head1 NAME ExtUtils::Constant::XS - generate C code for XS modules' constants. =head1 SYNOPSIS require ExtUtils::Constant::XS; =head1 DESCRIPTION ExtUtils::Constant::XS overrides ExtUtils::Constant::Base to generate C code for XS modules' constants. =head1 BUGS Nothing is documented. Probably others. =head1 AUTHOR Nicholas Clark based on the code in C by Larry Wall and others =cut # '' is used as a flag to indicate non-ascii macro names, and hence the need # to pass in the utf8 on/off flag. %XS_Constant = ( '' => '', IV => 'PUSHi(iv)', UV => 'PUSHu((UV)iv)', NV => 'PUSHn(nv)', PV => 'PUSHp(pv, strlen(pv))', PVN => 'PUSHp(pv, iv)', SV => 'PUSHs(sv)', YES => 'PUSHs(&PL_sv_yes)', NO => 'PUSHs(&PL_sv_no)', UNDEF => '', # implicit undef ); %XS_TypeSet = ( IV => '*iv_return = ', UV => '*iv_return = (IV)', NV => '*nv_return = ', PV => '*pv_return = ', PVN => ['*pv_return = ', '*iv_return = (IV)'], SV => '*sv_return = ', YES => undef, NO => undef, UNDEF => undef, ); sub header { my $start = 1; my @lines; push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++; push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++; foreach (sort keys %XS_Constant) { next if $_ eq ''; push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++; } push @lines, << 'EOT'; #ifndef NVTYPE typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */ #endif #ifndef aTHX_ #define aTHX_ /* 5.6 or later define this for threading support. */ #endif #ifndef pTHX_ #define pTHX_ /* 5.6 or later define this for threading support. */ #endif EOT return join '', @lines; } sub valid_type { my ($self, $type) = @_; return exists $XS_TypeSet{$type}; } # This might actually be a return statement sub assignment_clause_for_type { my $self = shift; my $args = shift; my $type = $args->{type}; my $typeset = $XS_TypeSet{$type}; if (ref $typeset) { die "Type $type is aggregate, but only single value given" if @_ == 1; return map {"$typeset->[$_]$_[$_];"} 0 .. $#$typeset; } elsif (defined $typeset) { confess "Aggregate value given for type $type" if @_ > 1; return "$typeset$_[0];"; } return (); } sub return_statement_for_type { my ($self, $type) = @_; # In the future may pass in an options hash $type = $type->{type} if ref $type; "return PERL_constant_IS$type;"; } sub return_statement_for_notdef { # my ($self) = @_; "return PERL_constant_NOTDEF;"; } sub return_statement_for_notfound { # my ($self) = @_; "return PERL_constant_NOTFOUND;"; } sub default_type { 'IV'; } sub macro_from_name { my ($self, $item) = @_; my $macro = $item->{name}; $macro = $item->{value} unless defined $macro; $macro; } sub macro_from_item { my ($self, $item) = @_; my $macro = $item->{macro}; $macro = $self->macro_from_name($item) unless defined $macro; $macro; } # Keep to the traditional perl source macro sub memEQ { "memEQ"; } sub params { my ($self, $what) = @_; foreach (sort keys %$what) { warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_}; } my $params = {}; $params->{''} = 1 if $what->{''}; $params->{IV} = 1 if $what->{IV} || $what->{UV} || $what->{PVN}; $params->{NV} = 1 if $what->{NV}; $params->{PV} = 1 if $what->{PV} || $what->{PVN}; $params->{SV} = 1 if $what->{SV}; return $params; } sub C_constant_prefix_param { "aTHX_ "; }