scope.h Scope entry and exit header
sv.c Scalar value code
sv.h Scalar value header
-t/base/commonsense.t See if configuration meets basic needs
t/base/cond.t See if conditionals work
t/base/if.t See if if works
t/base/lex.t See if lexical items work
t/io/tell.t See if file seeking works
t/io/utf8.t See if file seeking works
t/lib/1_compile.t See if the various libraries and extensions compile
+t/lib/commonsense.t See if configuration meets basic needs
t/lib/compmod.pl Helper for 1_compile.t
t/lib/dprof/test1_t Perl code profiler tests
t/lib/dprof/test1_v Perl code profiler tests
if ((*type == IoTYPE_RDWR) && /* scary */
(*(type+1) == IoTYPE_RDONLY || *(type+1) == IoTYPE_WRONLY) &&
((!num_svs || (tend > type+1 && tend[-1] != IoTYPE_PIPE)))) {
+ TAINT_PROPER("open");
mode[1] = *type++;
writing = 1;
}
my @text;
local($self->{'curcv'}) = $form;
local($self->{'curcvlex'});
+ local($self->{'in_format'}) = 1;
local(@$self{qw'curstash warnings hints'})
- = @$self{'curstash warnings hints'};
+ = @$self{qw'curstash warnings hints'};
my $op = $form->ROOT;
my $kid;
$op = $op->first->first; # skip leavewrite, lineseq
}
my $body = join(";\n", grep {length} @exprs);
my $subs = "";
- if (defined $root && defined $limit_seq) {
+ if (defined $root && defined $limit_seq && !$self->{'in_format'}) {
$subs = join "\n", $self->seq_subs($limit_seq);
}
return join(";\n", grep {length} $body, $subs);
$type = substr($line,0,1);
last unless $type eq '#';
}
- my $class = ref($obj).('::'.(($type eq 'H') ? 'HanZi' : ($type eq 'E') ? 'Escape' : 'Table'));
+ my $class = ref($obj).('::'.(
+ ($type eq 'X') ? 'Extended' :
+ ($type eq 'H') ? 'HanZi' :
+ ($type eq 'E') ? 'Escape' : 'Table'
+ ));
# carp "Loading $file";
bless $obj,$class;
return $obj if $obj->read($fh,$obj->name,$type);
my $std = $seq->[0];
my $cur = $std;
my @sta = ($std, undef, undef, undef); # G0 .. G3 state
- my($g1,$g2,$g3) = (0,0,0);
+ my $s = 0; # state of SO-SI. 0 (G0) or 1 (G1);
+ my $ss = 0; # state of SS2,SS3. 0 (G0), 2 (G2) or 3 (G3);
my $uni;
while (length($str)){
my $uch = substr($str,0,1,'');
if($uch eq "\e"){
if($str =~ s/^($esc)//)
{
- my $esc = "\e$1";
- $sta[ $grp->{$esc} ] = $esc if $tbl->{$esc};
+ my $e = "\e$1";
+ $sta[ $grp->{$e} ] = $e if $tbl->{$e};
}
# appearance of "\eN\eO" or "\eO\eN" isn't supposed.
- # but coincidental ON of G2 and G3 is explicitly avoided.
elsif($str =~ s/^N//)
{
- $g2 = 1; $g3 = 0;
+ $ss = 2;
}
elsif($str =~ s/^O//)
{
- $g3 = 1; $g2 = 0;
+ $ss = 3;
}
else
{
next;
}
if($uch eq "\x0e"){
- $g1 = 1; next;
+ $s = 1; next;
}
if($uch eq "\x0f"){
- $g1 = 0; next;
+ $s = 0; next;
}
- $cur = $g3 ? $sta[3] : $g2 ? $sta[2] : $g1 ? $sta[1] : $sta[0];
+ $cur = $ss ? $sta[$ss] : $sta[$s];
if(ref($tbl->{$cur}) eq 'Encode::XS'){
$uni .= $tbl->{$cur}->decode($uch);
- $g2 = $g3 = 0;
+ $ss = 0;
next;
}
my $ch = ord($uch);
$x = '';
}
$uni .= $x;
- $g2 = $g3 = 0;
+ $ss = 0;
}
$_[1] = $str if $chk;
return $uni;
my $fin = $obj->{'final'};
my $std = $seq->[0];
my $str = $ini;
- my @sta = ($std,undef,undef,undef);
- my @pre = ($std,undef,undef,undef);
+ my @sta = ($std,undef,undef,undef); # G0 .. G3 state
my $cur = $std;
- my $pG = 0;
- my $cG = 0;
+ my $pG = 0; # previous G: 0 or 1.
+ my $cG = 0; # current G: 0,1,2,3.
- if($ini)
+ if($ini && defined $grp->{$ini})
{
- $sta[ $grp->{$ini} ] = $pre[ $grp->{$ini} ] = $ini;
+ $sta[ $grp->{$ini} ] = $ini;
}
while (length($uni)){
$x = pack(&$rep($x),$x);
}
$cG = $grp->{$cur};
- $str .= $pre[ $cG ] = $cur if $cur ne $pre[ $cG ];
+ $str .= $sta[$cG] = $cur unless $cG < 2 && $cur eq $sta[$cG];
$str .= $cG == 0 && $pG == 1 ? "\cO" :
$cG == 1 && $pG == 0 ? "\cN" :
$cG == 2 ? "\eN" :
- $cG == 3 ? "\eO" : "";
+ $cG == 3 ? "\eO" : "";
$str .= $x;
$pG = $cG if $cG < 2;
}
- $str .= $std unless $cur eq $std;
$str .= "\cO" if $pG == 1; # back to G0
+ $str .= $std unless $std eq $sta[0]; # GO to ASCII
$str .= $fin; # necessary?
$_[1] = $uni if $chk;
return $str;
}
+
+package Encode::Tcl::Extended;
+use base 'Encode::Encoding';
+
+use Carp;
+
+sub read
+{
+ my ($obj,$fh,$name) = @_;
+ my(%tbl, $enc, %ssc, @key);
+ while (<$fh>)
+ {
+ my ($key,$val) = /^(\S+)\s+(.*)$/;
+ $val =~ s/\{(.*?)\}/$1/;
+ $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
+
+ if($enc = Encode->getEncoding($key)){
+ push @key, $val;
+ $tbl{$val} = ref($enc) eq 'Encode::Tcl'
+ ? $enc->loadEncoding : $enc;
+ $ssc{$val} = substr($val,1) if $val =~ /^>/;
+ }else{
+ $obj->{$key} = $val;
+ }
+ }
+ $obj->{'SSC'} = \%ssc; # single shift char
+ $obj->{'Tbl'} = \%tbl; # encoding tables
+ $obj->{'Key'} = \@key; # keys of table hash
+ return $obj;
+}
+
+sub decode
+{
+ my ($obj,$str,$chk) = @_;
+ my $tbl = $obj->{'Tbl'};
+ my $ssc = $obj->{'SSC'};
+ my $cur = ''; # current state
+ my $uni;
+ while (length($str)){
+ my $uch = substr($str,0,1,'');
+ my $ch = ord($uch);
+ if(!$cur && $ch > 0x7F)
+ {
+ $cur = '>';
+ $cur .= $uch, next if $ssc->{$cur.$uch};
+ }
+ $ch ^= 0x80 if $cur;
+
+ if(ref($tbl->{$cur}) eq 'Encode::XS'){
+ $uni .= $tbl->{$cur}->decode(chr($ch));
+ $cur = '';
+ next;
+ }
+ my $rep = $tbl->{$cur}->{'Rep'};
+ my $touni = $tbl->{$cur}->{'ToUni'};
+ my $x;
+ if (&$rep($ch) eq 'C')
+ {
+ $x = $touni->[0][$ch];
+ }
+ else
+ {
+ $x = $touni->[$ch][0x80 ^ ord(substr($str,0,1,''))];
+ }
+ unless (defined $x)
+ {
+ last if $chk;
+ # What do we do here ?
+ $x = '';
+ }
+ $uni .= $x;
+ $cur = '';
+ }
+ $_[1] = $str if $chk;
+ return $uni;
+}
+
+sub encode
+{
+ my ($obj,$uni,$chk) = @_;
+ my $tbl = $obj->{'Tbl'};
+ my $ssc = $obj->{'SSC'};
+ my $key = $obj->{'Key'};
+ my $str;
+ my $cur;
+
+ while (length($uni)){
+ my $ch = substr($uni,0,1,'');
+ my $x;
+ foreach my $k (@$key){
+ $x = ref($tbl->{$k}) eq 'Encode::XS'
+ ? $k =~ /^>/
+ ? $tbl->{$k}->encode(chr(0x80 ^ ord $ch),1)
+ : $tbl->{$k}->encode($ch,1)
+ : $tbl->{$k}->{FmUni}->{$ch};
+ $cur = $k, last if defined $x;
+ }
+ if(ref($tbl->{$cur}) ne 'Encode::XS')
+ {
+ my $def = $tbl->{$cur}->{'Def'};
+ my $rep = $tbl->{$cur}->{'Rep'};
+ unless (defined $x){
+ last if ($chk);
+ $x = $def;
+ }
+ my $r = &$rep($x);
+ $x = pack($r,
+ $cur =~ /^>/
+ ? $r eq 'C' ? 0x80 ^ $x : 0x8080 ^ $x
+ : $x);
+ }
+
+ $str .= $ssc->{$cur} if defined $ssc->{$cur};
+ $str .= $x;
+ }
+ $_[1] = $uni if $chk;
+ return $str;
+}
+
package Encode::Tcl::HanZi;
use base 'Encode::Encoding';
--- /dev/null
+# Encoding file: euc-jp-0212, extended
+X
+name euc-jp-0212
+ascii {}
+jis0208 >{}
+7bit-kana >\x8e
+jis0212 >\x8f
$lc = &POSIX::setlocale(&POSIX::LC_NUMERIC, 'C') if $Config{d_setlocale};
($n, $x) = &POSIX::strtod('3.14159_OR_SO');
# we're just checking that strtod works, not how accurate it is
- print (("3.14159" eq $n + 0) && ($x == 6) ?
+ print ((abs("3.14159" - $n) < 1e-6) && ($x == 6) ?
"ok 14\n" : "not ok 14\n");
&POSIX::setlocale(&POSIX::LC_NUMERIC, $lc) if $Config{d_setlocale};
} else { print "# strtod not present\n", "ok 14\n"; }
int useconds
void
-sleep(fseconds)
- NV fseconds
+sleep(...)
CODE:
- int useconds = fseconds * 1000000;
- usleep (useconds);
+ if (items > 0)
+ usleep((int)(SvNV(ST(0)) * 1000000));
+ else
+ PerlProc_pause();
#endif
case '7':
case '8':
case '9':
+ /* ensures variable is only digits */
+ /* ${"1foo"} fails this test (and is thus writeable) */
+ /* added by japhy, but borrowed from is_gv_magical */
+
+ if (len > 1) {
+ const char *end = name + len;
+ while (--end > name) {
+ if (!isDIGIT(*end)) return gv;
+ }
+ }
+
ro_magicalize:
SvREADONLY_on(GvSV(gv));
magicalize:
#libc='/usr/lib/libSystem.dylib';
# Optimize.
-optimize='-O3';
+if [ "x$optimize" = 'x' ]; then
+ optimize='-O3'
+fi
-# We have a prototype for telldir.
-ccflags="${ccflags} -pipe -fno-common -DHAS_TELLDIR_PROTOTYPE";
+# XXX Unclear why we require -pipe and -fno-common here.
+ccflags="${ccflags} -pipe -fno-common"
# At least on Darwin 1.3.x:
#
# Optimize.
optimize='-O3';
-# We have a prototype for telldir.
-ccflags="${ccflags} -pipe -fno-common -DHAS_TELLDIR_PROTOTYPE";
+# XXX Unclear why we require -pipe and -fno-common here.
+ccflags="${ccflags} -pipe -fno-common"
# cpp-precomp is problematic.
cppflags='-traditional-cpp';
I32 ipart = 0; /* index into part[] */
I32 offcount; /* number of digits in least significant part */
+ /* leading whitespace */
+ while (isSPACE(*s))
+ ++s;
+
/* sign */
switch (*s) {
case '-':
Equivalent to C<print FILEHANDLE sprintf(FORMAT, LIST)>, except that C<$\>
(the output record separator) is not appended. The first argument
-of the list will be interpreted as the C<printf> format. If C<use locale> is
-in effect, the character used for the decimal point in formatted real numbers
-is affected by the LC_NUMERIC locale. See L<perllocale>.
+of the list will be interpreted as the C<printf> format. See C<sprintf>
+for an explanation of the format argument. If C<use locale> is in effect,
+the character used for the decimal point in formatted real numbers is
+affected by the LC_NUMERIC locale. See L<perllocale>.
Don't fall into the trap of using a C<printf> when a simple
C<print> would do. The C<print> is more efficient and less
=back
-=head3 Why rsync the source tree
+=head2 Why rsync the source tree
=over 4
=back
-=head3 Why rsync the patches
+=head2 Why rsync the patches
=over 4
=head2 Submitting patches
-Always submit patches to I<perl5-porters@perl.org>. This lets other
-porters review your patch, which catches a surprising number of errors
-in patches. Either use the diff program (available in source code
-form from I<ftp://ftp.gnu.org/pub/gnu/>), or use Johan Vromans'
-I<makepatch> (available from I<CPAN/authors/id/JV/>). Unified diffs
-are preferred, but context diffs are accepted. Do not send RCS-style
-diffs or diffs without context lines. More information is given in
-the I<Porting/patching.pod> file in the Perl source distribution.
-Please patch against the latest B<development> version (e.g., if
-you're fixing a bug in the 5.005 track, patch against the latest
-5.005_5x version). Only patches that survive the heat of the
-development branch get applied to maintenance versions.
-
-Your patch should update the documentation and test suite.
+Always submit patches to I<perl5-porters@perl.org>. If you're
+patching a core module and there's an author listed, send the author a
+copy (see L<Patching a core module>). This lets other porters review
+your patch, which catches a surprising number of errors in patches.
+Either use the diff program (available in source code form from
+I<ftp://ftp.gnu.org/pub/gnu/>), or use Johan Vromans' I<makepatch>
+(available from I<CPAN/authors/id/JV/>). Unified diffs are preferred,
+but context diffs are accepted. Do not send RCS-style diffs or diffs
+without context lines. More information is given in the
+I<Porting/patching.pod> file in the Perl source distribution. Please
+patch against the latest B<development> version (e.g., if you're
+fixing a bug in the 5.005 track, patch against the latest 5.005_5x
+version). Only patches that survive the heat of the development
+branch get applied to maintenance versions.
+
+Your patch should update the documentation and test suite. See
+L<Writing a test>.
To report a bug in Perl, use the program I<perlbug> which comes with
Perl (if you can't get Perl to work, send mail to the address
subdirectories: F<lib/> is for the pure-Perl modules, and F<ext/>
contains the core XS modules.
+=item Tests
+
+There are tests for nearly all the modules, built-ins and major bits
+of functionality. Test files all have a .t suffix. Module tests live
+in the F<lib/> and F<ext/> directories next to the module being
+tested. Others live in F<t/>. See L<Writing a test>
+
=item Documentation
Documentation maintenance includes looking after everything in the
And finally, we submit it, with our rationale, to perl5-porters. Job
done!
+=head2 Patching a core module
+
+This works just like patching anything else, with an extra
+consideration. Many core modules also live on CPAN. If this is so,
+patch the CPAN version instead of the core and send the patch off to
+the module maintainer (with a copy to p5p). This will help the module
+maintainer keep the CPAN version in sync with the core version without
+constantly scanning p5p.
+
+
+=head2 Writing a test
+
+Every module and built-in function has an associated test file (or
+should...). If you add or change functionality, you have to write a
+test. If you fix a bug, you have to write a test so that bug never
+comes back. If you alter the docs, it would be nice to test what the
+new documentation says.
+
+In short, if you submit a patch you probably also have to patch the
+tests.
+
+For modules, the test file is right next to the module itself.
+F<lib/strict.t> tests F<lib/strict.pm>. This is a recent innovation,
+so there are some snags (and it would be wonderful for you to brush
+them out), but it basically works that way. Everything else lives in
+F<t/>.
+
+=over 3
+
+=item F<t/base/>
+
+Testing of the absolute basic functionality of Perl. Things like
+C<if>, basic file reads and writes, simple regexes, etc. These are
+run first in the test suite and if any of them fail, something is
+I<really> broken.
+
+=item F<t/cmd/>
+
+These test the basic control structures, C<if/else>, C<while>,
+subroutines, etc...
+
+=item F<t/comp/>
+
+Tests basic issues of how Perl parses and compiles itself.
+
+=item F<t/io/>
+
+Tests for built-in IO functions, including command line arguments.
+
+=item F<t/lib/>
+
+The old home for the module tests, you shouldn't put anything new in
+here. There are still some bits and pieces hanging around in here
+that need to be moved. Perhaps you could move them? Thanks!
+
+=item F<t/op/>
+
+Tests for perl's built in functions that don't fit into any of the
+other directories.
+
+=item F<t/pod/>
+
+Tests for POD directives. There are still some tests for the Pod
+modules hanging around in here that need to be moved out into F<lib/>.
+
+=item F<t/run/>
+
+Testing features of how perl actually runs, including exit codes and
+handling of PERL* environment variables.
+
+=back
+
+The core uses the same testing style as the rest of Perl, a simple
+"ok/not ok" run through Test::Harness, but there are a few special
+considerations.
+
+For most libraries and extensions, you'll want to use the Test::More
+library rather than rolling your own test functions. If a module test
+doesn't use Test::More, consider rewriting it so it does. For the
+rest it's best to use a simple C<print "ok $test_num\n"> style to avoid
+broken core functionality from causing the whole test to collapse.
+
+When you say "make test" Perl uses the F<t/TEST> program to run the
+test suite. All tests are run from the F<t/> directory, B<not> the
+directory which contains the test. This causes some problems with the
+tests in F<lib/>, so here's some opportunity for some patching.
+
+You must be triply conscious of cross-platform concerns. This usually
+boils down to using File::Spec and avoiding things like C<fork()> and
+C<system()> unless absolutely necessary.
+
+
=head1 EXTERNAL TOOLS FOR DEBUGGING PERL
Sometimes it helps to use external tools while debugging and
=head1 DESCRIPTION
-This page describes the syntax of regular expressions in Perl. For a
-description of how to I<use> regular expressions in matching
-operations, plus various examples of the same, see discussions
-of C<m//>, C<s///>, C<qr//> and C<??> in L<perlop/"Regexp Quote-Like Operators">.
+This page describes the syntax of regular expressions in Perl.
+
+if you haven't used regular expressions before, a quick-start
+introduction is available in L<perlrequick>, and a longer tutorial
+introduction is available in L<perlretut>.
+
+For reference on how regular expressions are used in matching
+operations, plus various examples of the same, see discussions of
+C<m//>, C<s///>, C<qr//> and C<??> in L<perlop/"Regexp Quote-Like
+Operators">.
Matching operations can have various modifiers. Modifiers
that relate to the interpretation of the regular expression inside
=head1 SEE ALSO
+L<perlrequick>.
+
+L<perlretut>.
+
L<perlop/"Regexp Quote-Like Operators">.
L<perlop/"Gory details of parsing quoted constructs">.
Pid_t childpid;
GV *tmpgv;
+# if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
+ Perl_croak(aTHX_ "No pthread_atfork() -- fork() too unsafe");
+# endif
+
EXTEND(SP, 1);
PERL_FLUSHALL_FOR_CHILD;
childpid = fork();
New(0, ret->endp, npar, I32);
Copy(r->startp, ret->startp, npar, I32);
- if (r->regstclass) {
- New(0, ret->regstclass, 1, regnode);
- StructCopy(r->regstclass, ret->regstclass, regnode);
- }
- else
- ret->regstclass = NULL;
-
New(0, ret->substrs, 1, struct reg_substr_data);
for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
s->min_offset = r->substrs->data[i].min_offset;
s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
}
+ ret->regstclass = NULL;
if (r->data) {
struct reg_data *d;
int count = r->data->count;
New(0, d->data[i], 1, struct regnode_charclass_class);
StructCopy(r->data->data[i], d->data[i],
struct regnode_charclass_class);
+ ret->regstclass = (regnode*)d->data[i];
break;
case 'o':
case 'n':
Copy(r->offsets, ret->offsets, 2*len+1, U32);
ret->precomp = SAVEPV(r->precomp);
- ret->subbeg = SAVEPV(r->subbeg);
- ret->sublen = r->sublen;
ret->refcnt = r->refcnt;
ret->minlen = r->minlen;
ret->prelen = r->prelen;
ret->lastcloseparen = r->lastcloseparen;
ret->reganch = r->reganch;
+ ret->sublen = r->sublen;
+
+ if (RX_MATCH_COPIED(ret))
+ ret->subbeg = SAVEPV(r->subbeg);
+ else
+ ret->subbeg = Nullch;
+
ptr_table_store(PL_ptr_table, r, ret);
return ret;
}
-This is the perl test library. To run all the tests, just type './TEST'.
+This is the perl test library. To run most of the tests, just type './TEST'
+(which will not run the tests residing in lib/ or ext/. In order to run
+all of the tests type 'make test' from the build direcotory above t/).
To add new tests, just look at the current tests and do likewise.
If you know that Perl is basically working but expect that some tests
will fail, you may want to use Test::Harness thusly:
+ cd t
./perl -I../lib harness
This method pinpoints failed tests automatically.
If you come up with new tests, please send them to perlbug@perl.org.
-Tests in the base/ directory ought to be runnable with plain miniperl.
+Tests in the t/base/ directory ought to be runnable with plain miniperl.
That is, they should not require Config.pm nor should they require any
extensions to have been built. TEST will abort if any tests in the
-base/ directory fail.
+t/base/ directory fail.
+
+Tests in the t/comp/, t/cmd/, t/run/, t/io/, and t/op/ directories should
+also be runnable by miniperl and not require Config.pm, but failures
+to comply will not cause TEST to abort like for t/base/.
#!./perl -w
-print "1..109\n";
+print "1..113\n";
sub try ($$) {
print +($_[1] ? "ok" : "not ok"), " $_[0]\n";
tryeq 107, 46339 * -46341, -0x7ffea80f;
tryeq 108, -46339 * 46341, -0x7ffea80f;
tryeq 109, -46339 * -46341, 0x7ffea80f;
+
+# leading space should be ignored
+
+tryeq 110, 1 + " 1", 2;
+tryeq 111, 3 + " -1", 2;
+tryeq 112, 1.2, " 1.2";
+tryeq 113, -1.2, " -1.2";
@INC = '../lib';
}
use warnings;
-# %Config is needed to obtain archname for VAX (since @INC is now insufficient)
-use Config;
+# we do not load %Config since this test resides in op and needs
+# to run under the minitest target even without Config.pm working.
# strictness
my @tests = ();
};
my $Is_VMS_VAX = 0;
-# The redundant $^O check might help non VMS platforms avoid %Config load
-if ($^O eq 'VMS' &&
- defined($Config{'archname'}) && $Config{'archname'} eq 'VMS_VAX') {
- $Is_VMS_VAX = 1;
+# We use HW_MODEL since ARCH_NAME was not in VMS V5.*
+if ($^O eq 'VMS') {
+ my $hw_model;
+ chomp($hw_model = `write sys\$output f\$getsyi("HW_MODEL")`);
+ $Is_VMS_VAX = $hw_model < 1024 ? 1 : 0;
}
for ($i = 1; @tests; $i++) {
# define PTHREAD_ATFORK(prepare,parent,child) \
pthread_atfork(prepare,parent,child)
# else
-# ifdef HAS_FORK
-# define PTHREAD_ATFORK(prepare,parent,child) \
- Perl_croak(aTHX_ "No pthread_atfork() -- fork() too unsafe");
-# else
-# define PTHREAD_ATFORK(prepare,parent,child) \
- NOOP
-# endif
+# define PTHREAD_ATFORK(prepare,parent,child) \
+ NOOP
# endif
#endif
#ifndef INIT_THREADS
# define INIT_THREADS NOOP
#endif
-
-#ifndef PTHREAD_ATFORK
-# define PTHREAD_ATFORK(prepare,parent,child) NOOP
-#endif
=head1 SYNOPSIS
-B<h2xs> [B<-ACOPXacdfkmx>] [B<-F> addflags] [B<-M> fmask] [B<-n> module_name] [B<-o> tmask] [B<-p> prefix] [B<-s> subs] [B<-v> version] [B<-b> compat_version] [headerfile ... [extra_libraries]]
+B<h2xs> [B<OPTIONS> ...] [headerfile ... [extra_libraries]]
-B<h2xs> B<-h>
+B<h2xs> B<-h>|B<-?>|B<--help>
=head1 DESCRIPTION
header scanning process will be assumed to have this type. Future versions
of C<h2xs> may gain the ability to make educated guesses.
+=item B<--use-new-tests>
+
+When B<--compat-version> (B<-b>) is present the generated tests will use
+C<Test::More> rather then C<Test> which is the default for versions before
+5.7.2 . C<Test::More> will be added to PREREQ_PM in the generated
+C<Makefile.PL>.
+
+=item B<--use-old-tests>
+
+Will force the generation of test code that uses the older C<Test> module.
+
=item B<-v>, B<--version>=I<version>
Specify a version number for this extension. This version number is added
Perl function names.
-s, --const-subs Create subroutines for specified macros.
-t, --default-type Default type for autoloaded constants
+ --use-new-tests Use Test::More in backward compatible modules
+ --use-old-tests Use the module Test rather than Test::More
-v, --version Specify a version number for this extension.
-x, --autogen-xsubs Autogenerate XSUBs using C::Scan.
$opt_v,
$opt_x,
$opt_b,
- $opt_t
+ $opt_t,
+ $new_test,
+ $old_test
);
Getopt::Long::Configure('bundling');
'const-subs|s=s' => \$opt_s,
'default-type|t=s' => \$opt_t,
'version|v=s' => \$opt_v,
- 'autogen-xsubs|x=s' => \$opt_x
+ 'autogen-xsubs|x=s' => \$opt_x,
+ 'use-new-tests' => \$new_test,
+ 'use-old-tests' => \$old_test
);
GetOptions(%options) || usage;
if( $opt_b ){
usage "You cannot use -b and -m at the same time.\n" if ($opt_b && $opt_m);
$opt_b =~ /^\d+\.\d+\.\d+/ ||
- usage "You must provide the backwards compatibility version in X.Y.Z form. " .
- "(i.e. 5.5.0)\n";
+ usage "You must provide the backwards compatibility version in X.Y.Z form. "
+ . "(i.e. 5.5.0)\n";
my ($maj,$min,$sub) = split(/\./,$opt_b,3);
$compat_version = sprintf("%d.%03d%02d",$maj,$min,$sub);
}
# use $module;
# blah blah blah
#
+#=head1 ABSTRACT
+#
+# This should be the abstract for $module.
+# The abstract is used when making PPD (Perl Package Description) files.
+# If you don't want an ABSTRACT you should also edit Makefile.PL to
+# remove the ABSTRACT_FROM option.
+#
#=head1 DESCRIPTION
#
#Stub documentation for $module, created by h2xs. It looks like the
warn "Writing $ext$modpname/Makefile.PL\n";
open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
+my $prereq_pm;
+
+if ( $compat_version < 5.00702 and $new_test )
+{
+ $prereq_pm = q%'Test::More' => 0%;
+}
+else
+{
+ $prereq_pm = '';
+}
+
print PL <<END;
use ExtUtils::MakeMaker;
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
WriteMakefile(
'NAME' => '$module',
'VERSION_FROM' => '$modfname.pm', # finds \$VERSION
- 'PREREQ_PM' => {}, # e.g., Module::Name => 1.1
+ 'PREREQ_PM' => {$prereq_pm}, # e.g., Module::Name => 1.1
(\$] >= 5.005 ? ## Add these new keywords supported since 5.005
(ABSTRACT_FROM => '$modfname.pm', # retrieve abstract from module
AUTHOR => '$author <$email>') : ()),
my $thisyear = (gmtime)[5] + 1900;
my $rmhead = "$modpname version $TEMPLATE_VERSION";
my $rmheadeq = "=" x length($rmhead);
+
+my $rm_prereq;
+
+if ( $compat_version < 5.00702 and $new_test )
+{
+ $rm_prereq = 'Test::More';
+}
+else
+{
+ $rm_prereq = 'blah blah blah';
+}
+
print RM <<_RMEND_;
$rmhead
$rmheadeq
This module requires these other modules and libraries:
- blah blah blah
+ $rm_prereq
COPYRIGHT AND LICENCE
my $tests = @const_names ? 2 : 1;
open EX, ">$testfile" or die "Can't create $ext$modpname/$testfile: $!\n";
+
print EX <<_END_;
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl 1.t'
# change 'tests => $tests' to 'tests => last_test_to_print';
+_END_
+
+my $test_mod = 'Test::More';
+
+if ( $old_test or ($compat_version < 5.007 and not $new_test ))
+{
+ my $test_mod = 'Test';
+
+ print EX <<_END_;
use Test;
BEGIN { plan tests => $tests };
use $module;
ok(1); # If we made it this far, we're ok.
_END_
-if (@const_names) {
- my $const_names = join " ", @const_names;
- print EX <<'_END_';
+
+ if (@const_names) {
+ my $const_names = join " ", @const_names;
+ print EX <<'_END_';
my $fail;
foreach my $constname (qw(
_END_
- print EX wrap ("\t", "\t", $const_names);
- print EX (")) {\n");
- print EX <<_END_;
+
+ print EX wrap ("\t", "\t", $const_names);
+ print EX (")) {\n");
+
+ print EX <<_END_;
next if (eval "my \\\$a = \$constname; 1");
if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
print "# pass: \$\@";
}
_END_
+ }
+}
+else
+{
+ print EX <<_END_;
+use Test::More tests => $tests;
+BEGIN { use_ok('$module') };
+
+_END_
+
+ if (@const_names) {
+ my $const_names = join " ", @const_names;
+ print EX <<'_END_';
+
+my $fail = 0;
+foreach my $constname (qw(
+_END_
+
+ print EX wrap ("\t", "\t", $const_names);
+ print EX (")) {\n");
+
+ print EX <<_END_;
+ next if (eval "my \\\$a = \$constname; 1");
+ if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
+ print "# pass: \$\@";
+ } else {
+ print "# fail: \$\@";
+ \$fail = 1;
+ }
+
+}
+
+ok( \$fail == 0 , 'Constants' );
+_END_
+ }
}
-print EX <<'_END_';
+
+print EX <<_END_;
#########################
-# Insert your test code below, the Test module is use()ed here so read
-# its man page ( perldoc Test ) for help writing this test script.
+# Insert your test code below, the $test_mod module is use()ed here so read
+# its man page ( perldoc $test_mod ) for help writing this test script.
_END_
+
close(EX) || die "Can't close $ext$modpname/$testfile: $!\n";
unless ($opt_C) {
void
CPerlHost::Clearenv(void)
{
+ dTHXo;
char ch;
LPSTR lpPtr, lpStr, lpEnvPtr;
- if(m_lppEnvList != NULL) {
+ if (m_lppEnvList != NULL) {
/* set every entry to an empty string */
for(DWORD index = 0; index < m_dwEnvCount; ++index) {
char* ptr = strchr(m_lppEnvList[index], '=');
ch = *++lpPtr;
*lpPtr = 0;
Add(lpStr);
+ if (!w32_pseudo_id)
+ (void)win32_putenv(lpStr);
*lpPtr = ch;
}
lpStr += strlen(lpStr) + 1;
char*
CPerlHost::Getenv(const char *varname)
{
- char* pEnv = Find(varname);
- if(pEnv == NULL) {
- pEnv = win32_getenv(varname);
- }
- else {
- if(!*pEnv)
- pEnv = 0;
+ dTHXo;
+ if (w32_pseudo_id) {
+ char *pEnv = Find(varname);
+ if (pEnv && *pEnv)
+ return pEnv;
}
-
- return pEnv;
+ return win32_getenv(varname);
}
int
CPerlHost::Putenv(const char *envstring)
{
+ dTHXo;
Add(envstring);
+ if (!w32_pseudo_id)
+ return win32_putenv(envstring);
+
return 0;
}
*/
const char* defaultshell = (IsWinNT()
? "cmd.exe /x/c" : "command.com /c");
- const char *usershell = getenv("PERL5SHELL");
+ const char *usershell = PerlEnv_getenv("PERL5SHELL");
w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
&w32_perlshell_tokens,
&w32_perlshell_vec);
}
/* look in PATH */
- pathstr = win32_getenv("PATH");
+ pathstr = PerlEnv_getenv("PATH");
New(0, fullcmd, MAX_PATH+1, char);
curfullcmd = fullcmd;
projects / p5sagit/p5-mst-13.2.git / commitdiff