# $Id: Head.U,v 3.0.1.9 1997/02/28 15:02:09 ram Exp $
#
-# Generated on Tue Jan 23 16:39:46 EET 2001 [metaconfig 3.0 PL70]
+# Generated on Sat Feb 3 18:24:21 EET 2001 [metaconfig 3.0 PL70]
# (with additional metaconfig patches by perlbug@perl.org)
cat >c1$$ <<EOF
dflt='n'
. ./myread
case "$ans" in
- [yY]) echo >&4 "Okay, continuing." ;;
+ [yY]) echo >&4 "Okay, continuing."
+ usedevel="$define" ;;
*) echo >&4 "Okay, bye."
exit 1
;;
esac
;;
esac
+case "$usedevel" in
+$define|true|[yY]*)
+ case "$versiononly" in
+ '') versiononly="$define" ;;
+ esac
+ case "$installusrbinperl" in
+ '') installusrbinperl="$undef" ;;
+ esac
+ ;;
+esac
: general instructions
needman=true
: check for non-blocking I/O stuff
case "$h_sysfile" in
-true) echo "#include <sys/file.h>" > head.c;;
-*)
- case "$h_fcntl" in
- true) echo "#include <fcntl.h>" > head.c;;
- *) echo "#include <sys/fcntl.h>" > head.c;;
- esac
- ;;
+true) echo "#include <sys/file.h>" > head.c;;
+esac
+case "$h_fcntl" in
+true) echo "#include <fcntl.h>" >> head.c;;
+*) echo "#include <sys/fcntl.h>" >> head.c;;
esac
echo " "
echo "Figuring out the flag used by open() for non-blocking I/O..." >&4
pod/perl5005delta.pod Changes from 5.004 to 5.005
pod/perl56delta.pod Changes from 5.005 to 5.6
pod/perlapi.pod Perl API documentation (autogenerated)
-pod/perlapio.pod IO API info
+pod/perlapio.pod PerlIO IO API info
pod/perlbook.pod Perl book information
pod/perlboot.pod Beginner's Object-oriented Tutorial
pod/perlbot.pod Object-oriented Bag o' Tricks
pod/perlhack.pod Perl hackers guide
pod/perlhist.pod Perl history info
pod/perlintern.pod Perl internal function docs (autogenrated)
+pod/perliol.pod Internals of PerlIO with layers.
pod/perlipc.pod IPC info
pod/perllexwarn.pod Lexical Warnings info
pod/perllocale.pod Locale support info
t/lib/posix.t See if POSIX works
t/lib/safe1.t See if Safe works
t/lib/safe2.t See if Safe works
+t/lib/sample-tests/bailout Test data for Test::Harness
+t/lib/sample-tests/combined Test data for Test::Harness
+t/lib/sample-tests/descriptive Test data for Test::Harness
+t/lib/sample-tests/duplicates Test data for Test::Harness
+t/lib/sample-tests/header_at_end Test data for Test::Harness
+t/lib/sample-tests/no_nums Test data for Test::Harness
+t/lib/sample-tests/simple Test data for Test::Harness
+t/lib/sample-tests/simple_fail Test data for Test::Harness
+t/lib/sample-tests/skip Test data for Test::Harness
+t/lib/sample-tests/skip_all Test data for Test::Harness
+t/lib/sample-tests/todo Test data for Test::Harness
+t/lib/sample-tests/with_comments Test data for Test::Harness
t/lib/sdbm.t See if SDBM_File works
t/lib/searchdict.t See if Search::Dict works
t/lib/selectsaver.t See if SelectSaver works
t/lib/symbol.t See if Symbol works
t/lib/syslfs.t See if large files work for sysio
t/lib/syslog.t See if Sys::Syslog works
+t/lib/test-harness.t See if Test::Harness works
t/lib/textfill.t See if Text::Wrap::fill works
t/lib/texttabs.t See if Text::Tabs works
t/lib/textwrap.t See if Text::Wrap::wrap works
linklibperl="-L `pwd | sed 's/\/UU$//'` -Wl,+s -Wl,+b$archlibexp/CORE -lperl"
;;
os390*)
+ shrpldflags='-W l,dll'
linklibperl='libperl.x'
DPERL_EXTERNAL_GLOB=''
;;
case "$useshrplib" in
true)
$spitshell >>Makefile <<'!NO!SUBS!'
- $(LD) $(SHRPLDFLAGS) -o $@ perl$(OBJ_EXT) $(obj)
+ $(LD) -o $@ $(SHRPLDFLAGS) perl$(OBJ_EXT) $(obj)
!NO!SUBS!
case "$osname" in
aix)
$spitshell >>Makefile <<'!NO!SUBS!'
perl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(PERLEXPORT)
- $(SHRPENV) $(LDLIBPTH) $(CC) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
+ $(SHRPENV) $(LDLIBPTH) $(CC) -o perl $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
pureperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(PERLEXPORT)
- $(SHRPENV) $(LDLIBPTH) purify $(CC) $(CLDFLAGS) $(CCDLFLAGS) -o pureperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
+ $(SHRPENV) $(LDLIBPTH) purify $(CC) -o pureperl $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
purecovperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(PERLEXPORT)
- $(SHRPENV) $(LDLIBPTH) purecov $(CC) $(CLDFLAGS) $(CCDLFLAGS) -o purecovperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
+ $(SHRPENV) $(LDLIBPTH) purecov $(CC) -o purecovperl $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
quantperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(PERLEXPORT)
- $(SHRPENV) $(LDLIBPTH) quantify $(CC) $(CLDFLAGS) $(CCDLFLAGS) -o quantperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
+ $(SHRPENV) $(LDLIBPTH) quantify $(CC) -o quantperl $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
# This version, if specified in Configure, does ONLY those scripts which need
# set-id emulation. Suidperl must be setuid root. It contains the "taint"
# has been invoked correctly.
suidperl: $& sperl$(OBJ_EXT) perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(PERLEXPORT)
- $(SHRPENV) $(LDLIBPTH) $(CC) $(CLDFLAGS) $(CCDLFLAGS) -o suidperl perlmain$(OBJ_EXT) sperl$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
+ $(SHRPENV) $(LDLIBPTH) $(CC) -o suidperl $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) sperl$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
!NO!SUBS!
system("chmod +x @exe");
my @writables = qw(
+ keywords.h
+ opcode.h
+ opnames.h
+ pp_proto.h
+ pp.sym
+ proto.h
embed.h
embedvar.h
- ext/B/B/Asmdata.pm
- ext/ByteLoader/byterun.c
- ext/ByteLoader/byterun.h
global.sym
- keywords.h
- lib/warnings.pm
+ pod/perlintern.pod
+ pod/perlapi.pod
objXSUB.h
- opcode.h
- pp.sym
- pp_proto.h
+ perlapi.h
+ perlapi.c
+ ext/ByteLoader/byterun.h
+ ext/ByteLoader/byterun.c
+ ext/B/B/Asmdata.pm
regnodes.h
warnings.h
+ lib/warnings.pm
+ vms/perly_c.vms
+ vms/perly_h.vms
+ win32/Makefile
+ win32/makefile.mk
+ win32/config_H.bc
win32/config_H.bc
win32/config_H.gc
win32/config_H.vc
SC28-1890-07 "OS/390 UNIX System Services Planning", in particular
Chapter 6 on customizing the OE shell.
-GNU make for OS/390, which is required for the build of perl (as well as
+GNU make for OS/390, which is recommended for the build of perl (as well as
building CPAN modules and extensions), is available from:
http://www.mks.com/s390/gnu/index.htm
(as well as Perl and Apache) in the red-piece/book "Open Source Software
for OS/390 UNIX", SG24-5944-00 from IBM.
+If instead of the recommended GNU make you would like to use the system
+supplied make program then be sure to install the default rules file
+properly via the shell command:
+
+ cp /samples/startup.mk /etc
+
+and be sure to also set the environment variable _C89_CCMODE=1 (exporting
+_C89_CCMODE=1 is also a good idea for users of GNU make).
+
+You might also want to have GNU groff for OS/390 installed before
+running the `make install` step for Perl.
+
There is a syntax error in the /usr/include/sys/socket.h header file
that IBM supplies with USS V2R7, V2R8, and possibly V2R9. The problem with
the header file is that near the definition of the SO_REUSEPORT constant
=item *
-This port doesn't support dynamic loading. Although OS/390 has support
-for DLLs via dllload(), there are some differences that cause problems
-for Perl. (We need a volunteer to write a ext/DynaLoader/dl_dllload.xs
-file).
+This port will support dynamic loading, but it is not selected by
+default. If you would like to experiment with dynamic loading then
+be sure to specify -Dusedl in the arguments to the Configure script.
+See the comments in hints/os390.sh for more information on dynamic loading.
+If you build with dynamic loading then you will need to add the
+$archlibexp/CORE directory to your LIBPATH environment variable in order
+for perl to work. See the config.sh file for the value of $archlibexp.
=item *
=back
+=head2 installation anomalies
+
+The installman script will try to run on OS/390. There will be fewer errors
+if you have a roff utility installed. You can obtain GNU groff from the
+Redbook SG24-5944-00 ftp site.
+
=head2 Usage Hints
When using perl on OS/390 please keep in mind that the EBCDIC and ASCII
make test
make install
-You can also build xs based extensions to Perl for OS/390 but will need
-to follow the instructions in ExtUtils::MakeMaker for building
+If you built perl with dynamic loading capability then that would also
+be the way to build xs based extensions. However, if you built perl with
+the default static linking you can still build xs based extensions for OS/390
+but you will need to follow the instructions in ExtUtils::MakeMaker for building
statically linked perl binaries. In the simplest configurations building
a static perl + xs extension boils down to:
than the system's /bin/make program, whether for plain modules or for
xs based extensions.
+If the make process encounters trouble with either compilation or
+linking then try setting the _C89_CCMODE to 1. Assuming sh is your
+login shell then run:
+
+ export _C89_CCMODE=1
+
+If tcsh is your login shell then use the setenv command.
+
=head1 AUTHORS
David Fiander and Peter Prymmer with thanks to Dennis Longnecker
and William Raffloer for valuable reports, LPAR and PTF feedback.
Thanks to Mike MacIsaac and Egon Terwedow for SG24-5944-00.
Thanks to Ignasi Roca for pointing out the floating point problems.
+Thanks to John Goodyear for dynamic loading help.
=head1 SEE ALSO
Updated 15 January 2001 for the 5.7.1 release of Perl.
+Updated 24 January 2001 to mention dynamic loading.
+
=cut
All this should be handled automatically by the hints file, if
requested.
-If you do want to be able to allocate more than 4GB memory inside
-perl, then you should use the Solaris malloc, since the perl
-malloc breaks when dealing with more than 2GB of memory. You can do
-this with
-
- sh Configure -Uusemymalloc
-
=head3 Long Doubles.
As of 5.6.0, long doubles are not working.
=head2 Malloc Issues.
+Starting from Perl 5.7.1 Perl uses the Solaris malloc, since the perl
+malloc breaks when dealing with more than 2GB of memory, and the Solaris
+malloc also seems to be faster.
+
+If you for some reason (such as binary backward compatibility) really
+need to use perl's malloc, you can rebuild Perl from the sources
+and Configure the build with
+
+ sh Configure -Dusemymalloc
+
You should not use perl's malloc if you are building with gcc. There
are reports of core dumps, especially in the PDL module. The problem
appears to go away under -DDEBUGGING, so it has been difficult to
track down. Sun's compiler appears to be ok with or without perl's
malloc. [XXX further investigation is needed here.]
-You should also not use perl's malloc if you are building perl as
-an LP64 application, since perl's malloc has trouble allocating more
-than 2GB of memory.
-
-You can avoid perl's malloc by Configuring with
-
- sh Configure -Uusemymalloc
-
-[XXX Update hints file.]
-
=head1 MAKE PROBLEMS.
=over 4
/* FALL THROUGH */
default:
if (PerlIO_isutf8(fp)) {
- tmps = SvPVutf8(sv, len);
- }
- else {
- if (DO_UTF8(sv))
- sv_utf8_downgrade(sv, FALSE);
- tmps = SvPV(sv, len);
+ if (!SvUTF8(sv))
+ sv_utf8_upgrade(sv = sv_mortalcopy(sv));
}
+ else if (DO_UTF8(sv))
+ sv_utf8_downgrade((sv = sv_mortalcopy(sv)), FALSE);
+ tmps = SvPV(sv, len);
break;
}
/* To detect whether the process is about to overstep its
if (CvCONST(sv)) sv_catpv(d, "CONST,");
if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
+ if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
+ if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
break;
case SVt_PVHV:
if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
#define utf8_distance Perl_utf8_distance
#define utf8_hop Perl_utf8_hop
#define utf8_to_bytes Perl_utf8_to_bytes
+#define bytes_from_utf8 Perl_bytes_from_utf8
#define bytes_to_utf8 Perl_bytes_to_utf8
#define utf8_to_uv_simple Perl_utf8_to_uv_simple
#define utf8_to_uv Perl_utf8_to_uv
#define filter_gets S_filter_gets
#define find_in_my_stash S_find_in_my_stash
#define new_constant S_new_constant
+#define tokereport S_tokereport
#define ao S_ao
#define depcom S_depcom
#define incl_perldb S_incl_perldb
#define utf8_distance(a,b) Perl_utf8_distance(aTHX_ a,b)
#define utf8_hop(a,b) Perl_utf8_hop(aTHX_ a,b)
#define utf8_to_bytes(a,b) Perl_utf8_to_bytes(aTHX_ a,b)
+#define bytes_from_utf8(a,b,c) Perl_bytes_from_utf8(aTHX_ a,b,c)
#define bytes_to_utf8(a,b) Perl_bytes_to_utf8(aTHX_ a,b)
#define utf8_to_uv_simple(a,b) Perl_utf8_to_uv_simple(aTHX_ a,b)
#define utf8_to_uv(a,b,c,d) Perl_utf8_to_uv(aTHX_ a,b,c,d)
#define filter_gets(a,b,c) S_filter_gets(aTHX_ a,b,c)
#define find_in_my_stash(a,b) S_find_in_my_stash(aTHX_ a,b)
#define new_constant(a,b,c,d,e,f) S_new_constant(aTHX_ a,b,c,d,e,f)
+#define tokereport(a,b,c) S_tokereport(aTHX_ a,b,c)
#define ao(a) S_ao(aTHX_ a)
#define depcom() S_depcom(aTHX)
#define incl_perldb() S_incl_perldb(aTHX)
#define utf8_hop Perl_utf8_hop
#define Perl_utf8_to_bytes CPerlObj::Perl_utf8_to_bytes
#define utf8_to_bytes Perl_utf8_to_bytes
+#define Perl_bytes_from_utf8 CPerlObj::Perl_bytes_from_utf8
+#define bytes_from_utf8 Perl_bytes_from_utf8
#define Perl_bytes_to_utf8 CPerlObj::Perl_bytes_to_utf8
#define bytes_to_utf8 Perl_bytes_to_utf8
#define Perl_utf8_to_uv_simple CPerlObj::Perl_utf8_to_uv_simple
#define find_in_my_stash S_find_in_my_stash
#define S_new_constant CPerlObj::S_new_constant
#define new_constant S_new_constant
+#define S_tokereport CPerlObj::S_tokereport
+#define tokereport S_tokereport
#define S_ao CPerlObj::S_ao
#define ao S_ao
#define S_depcom CPerlObj::S_depcom
diehook
dirty
perl_destruct_level
+ ppaddr
);
sub readsyms (\%$) {
Apd |IV |utf8_distance |U8 *a|U8 *b
Apd |U8* |utf8_hop |U8 *s|I32 off
ApMd |U8* |utf8_to_bytes |U8 *s|STRLEN *len
+ApMd |U8* |bytes_from_utf8|U8 *s|STRLEN *len|bool *is_utf8
ApMd |U8* |bytes_to_utf8 |U8 *s|STRLEN *len
Apd |UV |utf8_to_uv_simple|U8 *s|STRLEN* retlen
Adp |UV |utf8_to_uv |U8 *s|STRLEN curlen|STRLEN* retlen|U32 flags
s |HV * |find_in_my_stash|char *pkgname|I32 len
s |SV* |new_constant |char *s|STRLEN len|const char *key|SV *sv \
|SV *pv|const char *type
+s |void |tokereport |char *thing|char *s|I32 rv
s |int |ao |int toketype
s |void |depcom
s |char* |incl_perldb
#define no_modify PL_no_modify
#define perl_destruct_level PL_perl_destruct_level
#define perldb PL_perldb
+#define ppaddr PL_ppaddr
#define rsfp PL_rsfp
#define rsfp_filters PL_rsfp_filters
#define stack_base PL_stack_base
} elsif ($^O eq 'vmesa') {
# OS/390 C compiler doesn't generate #file or #line directives
$file{'../../vmesa/errno.h'} = 1;
+ } elsif ($Config{archname} eq 'epoc') {
+ # Watch out for cross compiling for EPOC (usually done on linux)
+ $file{'/usr/local/epoc/include/libc/sys/errno.h'} = 1;
} elsif ($^O eq 'linux') {
# Some Linuxes have weird errno.hs which generate
# no #file or #line directives
/* Set up any desired mask. */
svp = hv_fetch(action, "MASK", 4, FALSE);
if (svp && sv_isa(*svp, "POSIX::SigSet")) {
- unsigned long tmp;
- tmp = (unsigned long)SvNV((SV*)SvRV(*svp));
- sigset = (sigset_t*) tmp;
+ IV tmp = SvIV((SV*)SvRV(*svp));
+ sigset = INT2PTR(sigset_t*, tmp);
act.sa_mask = *sigset;
}
else
Perl_utf8_distance
Perl_utf8_hop
Perl_utf8_to_bytes
+Perl_bytes_from_utf8
Perl_bytes_to_utf8
Perl_utf8_to_uv_simple
Perl_utf8_to_uv
lr = 1;
}
break;
+ case int_amg:
case iter_amg: /* XXXX Eventually should do to_gv. */
/* FAIL safe */
return NULL; /* Delegate operation to standard mechanisms. */
fi
# HP-UX 10.X uses the old pthreads API
- case "$d_oldpthreads" in
- '') d_oldpthreads="$define" ;;
- esac
+ d_oldpthreads="$define"
# include libcma before all the others
libswanted="cma $libswanted"
case "$useshrplib" in
'') useshrplib='true' ;;
esac
- case "$dlext" in
- '') dlext='dll' ;;
- esac
case "$dlsrc" in
'') dlsrc='dl_dllload.xs' ;;
esac
- so='dll'
- libperl='libperl.dll'
+ # For performance use 'so' at or beyond v2.8, 'dll' for 2.7 and prior versions
+ case "`uname -v`x`uname -r`" in
+ 02x0[89].*|02x1[0-9].*|[0-9][3-9]x*)
+ so='so'
+ case "$dlext" in
+ '') dlext='so' ;;
+ esac
+ ;;
+ *)
+ so='dll'
+ case "$dlext" in
+ '') dlext='dll' ;;
+ esac
+ ;;
+ esac
+ libperl="libperl.$so"
ccflags="$ccflags -D_SHR_ENVIRON -DPERL_EXTERNAL_GLOB -Wc,dll"
cccdlflags='-c -Wc,dll,EXPORTALL'
# You might add '-Wl,EDIT=NO' to get rid of the symbol
- # information at the end of the executable.
- #
- # The following will need to be modified for the installed libperl.x
+ # information at the end of the executable (=> smaller binaries).
+ # Do so with -Dldflags='-Wl,EDIT=NO'.
+ case "$ldflags" in
+ '') ldflags='' ;;
+ esac
+ # The following will need to be modified for the installed libperl.x.
+ # The modification to Config.pm is done by the installperl script after the build and test.
ccdlflags="-W l,dll `pwd`/libperl.x"
- ldflags=''
- lddlflags='-W l,dll'
+ lddlflags="-W l,dll `pwd`/libperl.x"
;;
esac
# even on static builds using LIBPATH should be OK.
# other things. Unfortunately, cppflags occurs too late to be of
# value external to the script. This may need to be revisited
# under a compiler other than c89.
+case "$usedl" in
+define)
+echo 'cat >.$$.c; '"$cc"' -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE -D_SHR_ENVIRON -E -Wc,NOLOC ${1+"$@"} .$$.c; rm .$$.c' > cppstdin
+ ;;
+*)
echo 'cat >.$$.c; '"$cc"' -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE -E -Wc,NOLOC ${1+"$@"} .$$.c; rm .$$.c' > cppstdin
+ ;;
+esac
#
# Note that Makefile.SH employs a bare yacc command to generate
# hints/solaris_2.sh
-# Last modified: Tue Jan 2 10:16:35 2001
+# Last modified: Mon Jan 29 12:52:28 2001
# Lupe Christoph <lupe@lupe-christoph.de>
# Based on version by:
# Andy Dougherty <doughera@lafayette.edu>
# these ought to be harmless. See below for more details.
# See man vfork.
-usevfork=false
+usevfork=${usevfork:-false}
-d_suidsafe=define
+# Solaris has secure SUID scripts
+d_suidsafe=${d_suidsafe:-define}
+
+# Several people reported problems with perl's malloc, especially
+# when use64bitall is defined or when using gcc.
+# http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-01/msg01318.html
+# http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-01/msg00465.html
+usemymalloc=${usemymalloc:-false}
# Avoid all libraries in /usr/ucblib.
# /lib is just a symlink to /usr/lib
register HE *entry;
SV *sv;
bool is_utf8 = FALSE;
+ const char *keysave = key;
if (!hv)
return 0;
return 0;
}
+ if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+ key = (char*)bytes_from_utf8((U8*)key, (STRLEN*)&klen, &is_utf8);
+
PERL_HASH(hash, key, klen);
entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
continue;
if (HeKUTF8(entry) != (char)is_utf8)
continue;
+ if (key != keysave)
+ Safefree(key);
return &HeVAL(entry);
}
#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
if (env) {
sv = newSVpvn(env,len);
SvTAINTED_on(sv);
+ if (key != keysave)
+ Safefree(key);
return hv_store(hv,key,klen,sv,hash);
}
}
#endif
if (lval) { /* gonna assign to this, so it better be there */
sv = NEWSV(61,0);
- return hv_store(hv,key,is_utf8?-klen:klen,sv,hash);
+ if (key != keysave) { /* must be is_utf8 == 0 */
+ SV **ret = hv_store(hv,key,klen,sv,hash);
+ Safefree(key);
+ return ret;
+ }
+ else
+ return hv_store(hv,key,is_utf8?-klen:klen,sv,hash);
}
+ if (key != keysave)
+ Safefree(key);
return 0;
}
register HE *entry;
SV *sv;
bool is_utf8;
+ char *keysave;
if (!hv)
return 0;
return 0;
}
- key = SvPV(keysv, klen);
+ keysave = key = SvPV(keysv, klen);
is_utf8 = (SvUTF8(keysv)!=0);
+ if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+ key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
+
if (!hash)
PERL_HASH(hash, key, klen);
continue;
if (HeKUTF8(entry) != (char)is_utf8)
continue;
+ if (key != keysave)
+ Safefree(key);
return entry;
}
#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
}
}
#endif
+ if (key != keysave)
+ Safefree(key);
if (lval) { /* gonna assign to this, so it better be there */
sv = NEWSV(61,0);
return hv_store_ent(hv,keysv,sv,hash);
register HE *entry;
register HE **oentry;
bool is_utf8 = FALSE;
+ const char *keysave = key;
if (!hv)
return 0;
#endif
}
}
+ if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+ key = (char*)bytes_from_utf8((U8*)key, (STRLEN*)&klen, &is_utf8);
+
if (!hash)
PERL_HASH(hash, key, klen);
continue;
SvREFCNT_dec(HeVAL(entry));
HeVAL(entry) = val;
+ if (key != keysave)
+ Safefree(key);
return &HeVAL(entry);
}
HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
else /* gotta do the real thing */
HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
+ if (key != keysave)
+ Safefree(key);
HeVAL(entry) = val;
HeNEXT(entry) = *oentry;
*oentry = entry;
register HE *entry;
register HE **oentry;
bool is_utf8;
+ char *keysave;
if (!hv)
return 0;
}
}
- key = SvPV(keysv, klen);
+ keysave = key = SvPV(keysv, klen);
is_utf8 = (SvUTF8(keysv) != 0);
+ if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+ key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
+
if (!hash)
PERL_HASH(hash, key, klen);
continue;
SvREFCNT_dec(HeVAL(entry));
HeVAL(entry) = val;
+ if (key != keysave)
+ Safefree(key);
return entry;
}
HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
else /* gotta do the real thing */
HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
+ if (key != keysave)
+ Safefree(key);
HeVAL(entry) = val;
HeNEXT(entry) = *oentry;
*oentry = entry;
SV **svp;
SV *sv;
bool is_utf8 = FALSE;
+ const char *keysave = key;
if (!hv)
return Nullsv;
if (!xhv->xhv_array)
return Nullsv;
+ if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+ key = (char*)bytes_from_utf8((U8*)key, (STRLEN*)&klen, &is_utf8);
+
PERL_HASH(hash, key, klen);
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
continue;
if (HeKUTF8(entry) != (char)is_utf8)
continue;
+ if (key != keysave)
+ Safefree(key);
*oentry = HeNEXT(entry);
if (i && !*oentry)
xhv->xhv_fill--;
--xhv->xhv_keys;
return sv;
}
+ if (key != keysave)
+ Safefree(key);
return Nullsv;
}
register HE **oentry;
SV *sv;
bool is_utf8;
+ char *keysave;
if (!hv)
return Nullsv;
if (!xhv->xhv_array)
return Nullsv;
- key = SvPV(keysv, klen);
+ keysave = key = SvPV(keysv, klen);
is_utf8 = (SvUTF8(keysv) != 0);
+ if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+ key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
+
if (!hash)
PERL_HASH(hash, key, klen);
continue;
if (HeKUTF8(entry) != (char)is_utf8)
continue;
+ if (key != keysave)
+ Safefree(key);
*oentry = HeNEXT(entry);
if (i && !*oentry)
xhv->xhv_fill--;
--xhv->xhv_keys;
return sv;
}
+ if (key != keysave)
+ Safefree(key);
return Nullsv;
}
register HE *entry;
SV *sv;
bool is_utf8 = FALSE;
+ const char *keysave = key;
if (!hv)
return 0;
return 0;
#endif
+ if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+ key = (char*)bytes_from_utf8((U8*)key, (STRLEN*)&klen, &is_utf8);
+
PERL_HASH(hash, key, klen);
#ifdef DYNAMIC_ENV_FETCH
continue;
if (HeKUTF8(entry) != (char)is_utf8)
continue;
+ if (key != keysave)
+ Safefree(key);
return TRUE;
}
#ifdef DYNAMIC_ENV_FETCH /* is it out there? */
}
}
#endif
+ if (key != keysave)
+ Safefree(key);
return FALSE;
}
register HE *entry;
SV *sv;
bool is_utf8;
+ char *keysave;
if (!hv)
return 0;
return 0;
#endif
- key = SvPV(keysv, klen);
+ keysave = key = SvPV(keysv, klen);
is_utf8 = (SvUTF8(keysv) != 0);
+ if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+ key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
if (!hash)
PERL_HASH(hash, key, klen);
continue;
if (HeKUTF8(entry) != (char)is_utf8)
continue;
+ if (key != keysave)
+ Safefree(key);
return TRUE;
}
#ifdef DYNAMIC_ENV_FETCH /* is it out there? */
}
}
#endif
+ if (key != keysave)
+ Safefree(key);
return FALSE;
}
register I32 i = 1;
I32 found = 0;
bool is_utf8 = FALSE;
+ const char *save = str;
if (len < 0) {
len = -len;
is_utf8 = TRUE;
+ if (!(PL_hints & HINT_UTF8_DISTINCT))
+ str = (char*)bytes_from_utf8((U8*)str, (STRLEN*)&len, &is_utf8);
}
/* what follows is the moral equivalent of:
break;
}
UNLOCK_STRTAB_MUTEX;
-
+ if (str != save)
+ Safefree(str);
if (!found && ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str);
}
register I32 i = 1;
I32 found = 0;
bool is_utf8 = FALSE;
+ const char *save = str;
if (len < 0) {
len = -len;
is_utf8 = TRUE;
+ if (!(PL_hints & HINT_UTF8_DISTINCT))
+ str = (char*)bytes_from_utf8((U8*)str, (STRLEN*)&len, &is_utf8);
}
/* what follows is the moral equivalent of:
++HeVAL(entry); /* use value slot as REFCNT */
UNLOCK_STRTAB_MUTEX;
+ if (str != save)
+ Safefree(str);
return HeKEY_hek(entry);
}
-
-
-
# print "[$_]\n" for sort keys %archpms;
my $ver = $Config{version};
-my $release = substr($],0,3); # Not used presently.
+my $release = substr($],0,3); # Not used currently.
my $patchlevel = substr($],3,2);
die "Patchlevel of perl ($patchlevel)",
"and patchlevel of config.sh ($Config{'PERL_VERSION'}) don't match\n"
my $so = $Config{so};
my $dlext = $Config{dlext};
my $dlsrc = $Config{dlsrc};
+if ($^O eq 'os390') {
+ my $pwd;
+ chomp($pwd=`pwd`);
+ my $archlibexp = $Config{archlibexp};
+ my $usedl = $Config{usedl};
+ if ($usedl eq 'define') {
+ `./$^X -pibak -e 's{$pwd\/libperl.x}{$archlibexp/CORE/libperl.x}' lib/Config.pm`;
+ }
+}
my $d_dosuid = $Config{d_dosuid};
my $binexp = $Config{binexp};
PERLVAR(Idoswitches, bool)
/*
-=for apidoc Amn|bool|PL_dowarn
+=for apidoc mn|bool|PL_dowarn
The C variable which corresponds to Perl's $^W warning variable.
PERLVAR(IDBline, GV *)
/*
-=for apidoc Amn|GV *|PL_DBsub
+=for apidoc mn|GV *|PL_DBsub
When Perl is run in debugging mode, with the B<-d> switch, this GV contains
the SV which holds the name of the sub being debugged. This is the C
variable which corresponds to Perl's $DB::sub variable. See
C<PL_DBsingle>.
-=for apidoc Amn|SV *|PL_DBsingle
+=for apidoc mn|SV *|PL_DBsingle
When Perl is run in debugging mode, with the B<-d> switch, this SV is a
boolean which indicates whether subs are being single-stepped.
Single-stepping is automatically turned on after every step. This is the C
variable which corresponds to Perl's $DB::single variable. See
C<PL_DBsub>.
-=for apidoc Amn|SV *|PL_DBtrace
+=for apidoc mn|SV *|PL_DBtrace
Trace variable used when Perl is run in debugging mode, with the B<-d>
switch. This is the C variable which corresponds to Perl's $DB::trace
variable. See C<PL_DBsingle>.
/* Assume simple numerics */
PERLVARI(Inumeric_local, bool, TRUE)
/* Assume local numerics */
-PERLVAR(Inumeric_radix, char)
- /* The radix character if not '.' */
+PERLVAR(Inumeric_radix, SV *)
+ /* The radix separator if not '.' */
#endif /* !USE_LOCALE_NUMERIC */
~$
\.old$
^#.*#$
+ ^\.#
If no MANIFEST.SKIP file is found, a default set of skips will be
used, similar to the example above. If you want nothing skipped,
package Getopt::Long;
-# RCS Status : $Id: GetoptLong.pl,v 2.25 2000-08-28 21:45:17+02 jv Exp jv $
+# RCS Status : $Id: GetoptLong.pl,v 2.26 2001-01-31 10:20:29+01 jv Exp $
# Author : Johan Vromans
# Created On : Tue Sep 11 15:00:12 1990
# Last Modified By: Johan Vromans
use strict;
use vars qw($VERSION $VERSION_STRING);
-$VERSION = 2.24_02;
-$VERSION_STRING = "2.24_02";
+$VERSION = 2.25;
+$VERSION_STRING = "2.25";
use Exporter;
use AutoLoader qw(AUTOLOAD);
################ AutoLoading subroutines ################
-# RCS Status : $Id: GetoptLongAl.pl,v 2.29 2000-08-28 21:56:18+02 jv Exp jv $
+# RCS Status : $Id: GetoptLongAl.pl,v 2.30 2001-01-31 10:21:11+01 jv Exp $
# Author : Johan Vromans
# Created On : Fri Mar 27 11:50:30 1998
# Last Modified By: Johan Vromans
print STDERR ("GetOpt::Long $Getopt::Long::VERSION ",
"called from package \"$pkg\".",
"\n ",
- 'GetOptionsAl $Revision: 2.29 $ ',
+ 'GetOptionsAl $Revision: 2.30 $ ',
"\n ",
"ARGV: (@ARGV)",
"\n ",
--foo -- arg1 --bar arg2 arg3
+If C<pass_through> is also enabled, options processing will terminate
+at the first unrecognized option, or non-option, whichever comes
+first.
+
=item bundling (default: disabled)
Enabling this option will allow single-character options to be bundled.
only part of the user supplied command line arguments, and pass the
remaining options to some other program.
-This can be very confusing, especially when C<permute> is also enabled.
+If C<require_order> is enabled, options processing will terminate at
+the first unrecognized option, or non-option, whichever comes first.
+However, if C<permute> is enabled instead, results can become confusing.
=item prefix
=cut
# Local Variables:
-# mode: perl
# eval: (load-file "pod.el")
# End:
scalar fdiv(${$_[0]},$_[1])},
'neg' => sub {new Math::BigFloat &fneg},
'abs' => sub {new Math::BigFloat &fabs},
+'int' => sub {new Math::BigInt &f2int},
qw(
"" stringify
return $n;
}
+sub import {
+ shift;
+ return unless @_;
+ die "unknown import: @_" unless @_ == 1 and $_[0] eq ':constant';
+ overload::constant float => sub {Math::BigFloat->new(shift)};
+}
+
$div_scale = 40;
# Rounding modes one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'.
}
}
}
+
+# Calculate the integer part of $x
+sub f2int { #(fnum_str) return inum_str
+ local($x) = ${$_[$[]};
+ if ($x eq 'NaN') {
+ die "Attempt to take int(NaN)";
+ } else {
+ local($xm,$xe) = split('E',$x);
+ if ($xe >= 0) {
+ $xm . '0' x $xe;
+ } else {
+ $xe = length($xm)+$xe;
+ if ($xe <= 1) {
+ '+0';
+ } else {
+ substr($xm,$[,$xe);
+ }
+ }
+ }
+}
# compare 2 values returns one of undef, <0, =0, >0
# returns undef if either or both input value are not numbers
'|' => sub {new Math::BigInt &bior},
'^' => sub {new Math::BigInt &bxor},
'~' => sub {new Math::BigInt &bnot},
+'int' => sub { shift },
qw(
"" stringify
use Config;
use strict;
-our($VERSION, $verbose, $switches, $have_devel_corestack, $curtest,
- $columns, @ISA, @EXPORT, @EXPORT_OK);
-$have_devel_corestack = 0;
+our($VERSION, $Verbose, $Switches, $Have_Devel_Corestack, $Curtest,
+ $Columns, $verbose, $switches,
+ @ISA, @EXPORT, @EXPORT_OK
+ );
-$VERSION = "1.1607";
+# Backwards compatibility for exportable variable names.
+*verbose = \$Verbose;
+*switches = \$Switches;
+
+$Have_Devel_Corestack = 0;
+
+$VERSION = "1.1702";
$ENV{HARNESS_ACTIVE} = 1;
# Some experimental versions of OS/2 build have broken $?
-my $ignore_exitcode = $ENV{HARNESS_IGNORE_EXITCODE};
+my $Ignore_Exitcode = $ENV{HARNESS_IGNORE_EXITCODE};
+
+my $Files_In_Dir = $ENV{HARNESS_FILELEAK_IN_DIR};
-my $files_in_dir = $ENV{HARNESS_FILELEAK_IN_DIR};
-my $tests_skipped = 0;
-my $subtests_skipped = 0;
+@ISA = ('Exporter');
+@EXPORT = qw(&runtests);
+@EXPORT_OK = qw($verbose $switches);
-@ISA=('Exporter');
-@EXPORT= qw(&runtests);
-@EXPORT_OK= qw($verbose $switches);
+$Verbose = 0;
+$Switches = "-w";
+$Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
-$verbose = 0;
-$switches = "-w";
-$columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
sub globdir { opendir DIRH, shift; my @f = readdir DIRH; closedir DIRH; @f }
sub runtests {
my(@tests) = @_;
+
+ my($tot, $failedtests) = _runtests(@tests);
+ _show_results($tot, $failedtests);
+
+ return ($tot->{bad} == 0 && $tot->{max}) ;
+}
+
+
+sub _runtests {
+ my(@tests) = @_;
local($|) = 1;
- my($test,$te,$ok,$next,$max,$pct,$totbonus,@failed,%failedtests);
- my $totmax = 0;
- my $totok = 0;
- my $files = 0;
- my $bad = 0;
- my $good = 0;
- my $total = @tests;
+ my(%failedtests);
+
+ # Test-wide totals.
+ my(%tot) = (
+ bonus => 0,
+ max => 0,
+ ok => 0,
+ files => 0,
+ bad => 0,
+ good => 0,
+ tests => scalar @tests,
+ sub_skipped => 0,
+ skipped => 0,
+ bench => 0
+ );
# pass -I flags to children
my $old5lib = $ENV{PERL5LIB};
my $new5lib;
if ($^O eq 'VMS') {
$new5lib = join($Config{path_sep}, grep {!/perl_root/i;} @INC);
- $switches =~ s/-(\S*[A-Z]\S*)/"-$1"/g;
+ $Switches =~ s/-(\S*[A-Z]\S*)/"-$1"/g;
}
else {
$new5lib = join($Config{path_sep}, @INC);
}
local($ENV{'PERL5LIB'}) = $new5lib;
- my @dir_files = globdir $files_in_dir if defined $files_in_dir;
+ my @dir_files = globdir $Files_In_Dir if defined $Files_In_Dir;
my $t_start = new Benchmark;
- while ($test = shift(@tests)) {
- $te = $test;
- chop($te);
+
+ foreach my $test (@tests) {
+ my $te = $test;
+ chop($te); # XXX chomp?
+
if ($^O eq 'VMS') { $te =~ s/^.*\.t\./[.t./s; }
my $blank = (' ' x 77);
my $leader = "$te" . '.' x (20 - length($te));
my $ml = "";
$ml = "\r$blank\r$leader"
- if -t STDOUT and not $ENV{HARNESS_NOTTY} and not $verbose;
+ if -t STDOUT and not $ENV{HARNESS_NOTTY} and not $Verbose;
print $leader;
- open(my $fh, $test) or print "can't open $test. $!\n";
- my $first = <$fh>;
- my $s = $switches;
- $s .= " $ENV{'HARNESS_PERL_SWITCHES'}"
- if exists $ENV{'HARNESS_PERL_SWITCHES'};
- $s .= join " ", q[ "-T"], map {qq["-I$_"]} @INC
- if $first =~ /^#!.*\bperl.*-\w*T/;
- close($fh) or print "can't close $test. $!\n";
+
+ my $s = _set_switches($test);
+
my $cmd = ($ENV{'HARNESS_COMPILE_TEST'})
? "./perl -I../lib ../utils/perlcc $test "
. "-run 2>> ./compilelog |"
: "$^X $s $test|";
$cmd = "MCR $cmd" if $^O eq 'VMS';
- open($fh, $cmd) or print "can't run $test. $!\n";
- $ok = $next = $max = 0;
- @failed = ();
- my %todo = ();
- my $bonus = 0;
- my $skipped = 0;
- my $skip_reason;
+ open(my $fh, $cmd) or print "can't run $test. $!\n";
+
+ # state of the current test.
+ my %test = (
+ ok => 0,
+ next => 0,
+ max => 0,
+ failed => [],
+ todo => {},
+ bonus => 0,
+ skipped => 0,
+ skip_reason => undef,
+ ml => $ml,
+ );
+
+ my($seen_header, $tests_seen) = (0,0);
while (<$fh>) {
- if( $verbose ){
- print $_;
- }
- if (/^1\.\.([0-9]+) todo([\d\s]+)\;/) {
- $max = $1;
- for (split(/\s+/, $2)) { $todo{$_} = 1; }
- $totmax += $max;
- $files++;
- $next = 1;
- } elsif (/^1\.\.([0-9]+)(\s*\#\s*[Ss]kip\S*(?>\s+)(.+))?/) {
- $max = $1;
- $totmax += $max;
- $files++;
- $next = 1;
- $skip_reason = $3 if not $max and defined $3;
- } elsif ($max && /^(not\s+)?ok\b/) {
- my $this = $next;
- if (/^not ok\s*(\d*)/){
- $this = $1 if $1 > 0;
- print "${ml}NOK $this" if $ml;
- if (!$todo{$this}) {
- push @failed, $this;
- } else {
- $ok++;
- $totok++;
- }
- } elsif (/^ok\s*(\d*) *(\s*\#\s*[Ss]kip\S*(?:(?>\s+)(.+))?)?$/) {
- $this = $1 if $1 > 0;
- print "${ml}ok $this/$max" if $ml;
- $ok++;
- $totok++;
- $skipped++ if defined $2;
- my $reason;
- $reason = 'unknown reason' if defined $2;
- $reason = $3 if defined $3;
- if (defined $reason and defined $skip_reason) {
- # print "was: '$skip_reason' new '$reason'\n";
- $skip_reason = 'various reasons'
- if $skip_reason ne $reason;
- } elsif (defined $reason) {
- $skip_reason = $reason;
- }
- $bonus++, $totbonus++ if $todo{$this};
- } elsif (/^ok\s*(\d*)\s*\#([^\r]*)$/) {
- $this = $1 if $1 > 0;
- print "${ml}ok $this/$max" if $ml;
- $ok++;
- $totok++;
- } else {
- # an ok or not ok not matching the 3 cases above...
- # just ignore it for compatibility with TEST
- next;
- }
- if ($this > $next) {
- # print "Test output counter mismatch [test $this]\n";
- # no need to warn probably
- push @failed, $next..$this-1;
- } elsif ($this < $next) {
- #we have seen more "ok" lines than the number suggests
- print "Confused test output: test $this answered after test ", $next-1, "\n";
- $next = $this;
- }
- $next = $this + 1;
- } elsif (/^Bail out!\s*(.*)/i) { # magic words
- die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n");
+ if( _parse_header($_, \%test, \%tot) ) {
+ warn "Test header seen twice!\n" if $seen_header;
+
+ $seen_header = 1;
+
+ warn "1..M can only appear at the beginning or end of tests\n"
+ if $tests_seen && $test{max} < $tests_seen;
+ }
+ elsif( _parse_test_line($_, \%test, \%tot) ) {
+ $tests_seen++;
}
+ # else, ignore it.
}
- close($fh); # must close to reap child resource values
- my $wstatus = $ignore_exitcode ? 0 : $?; # Can trust $? ?
- my $estatus;
- $estatus = ($^O eq 'VMS'
- ? eval 'use vmsish "status"; $estatus = $?'
- : $wstatus >> 8);
+
+ my($estatus, $wstatus) = _close_fh($fh);
+
if ($wstatus) {
- my ($failed, $canon, $percent) = ('??', '??');
- printf "${ml}dubious\n\tTest returned status $estatus (wstat %d, 0x%x)\n",
- $wstatus,$wstatus;
- print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS';
- if (corestatus($wstatus)) { # until we have a wait module
- if ($have_devel_corestack) {
- Devel::CoreStack::stack($^X);
- } else {
- print "\ttest program seems to have generated a core\n";
- }
- }
- $bad++;
- if ($max) {
- if ($next == $max + 1 and not @failed) {
- print "\tafter all the subtests completed successfully\n";
- $percent = 0;
- $failed = 0; # But we do not set $canon!
- } else {
- push @failed, $next..$max;
- $failed = @failed;
- (my $txt, $canon) = canonfailed($max,$skipped,@failed);
- $percent = 100*(scalar @failed)/$max;
- print "DIED. ",$txt;
- }
- }
- $failedtests{$test} = { canon => $canon, max => $max || '??',
- failed => $failed,
- name => $test, percent => $percent,
- estat => $estatus, wstat => $wstatus,
- };
- } elsif ($ok == $max && $next == $max+1) {
- if ($max and $skipped + $bonus) {
+ $failedtests{$test} = _dubious_return(\%test, \%tot,
+ $estatus, $wstatus);
+ }
+ elsif ($test{ok} == $test{max} && $test{next} == $test{max}+1) {
+ if ($test{max} and $test{skipped} + $test{bonus}) {
my @msg;
- push(@msg, "$skipped/$max skipped: $skip_reason")
- if $skipped;
- push(@msg, "$bonus/$max unexpectedly succeeded")
- if $bonus;
- print "${ml}ok, ".join(', ', @msg)."\n";
- } elsif ($max) {
- print "${ml}ok\n";
- } elsif (defined $skip_reason) {
- print "skipped: $skip_reason\n";
- $tests_skipped++;
+ push(@msg, "$test{skipped}/$test{max} skipped: $test{skip_reason}")
+ if $test{skipped};
+ push(@msg, "$test{bonus}/$test{max} unexpectedly succeeded")
+ if $test{bonus};
+ print "$test{ml}ok, ".join(', ', @msg)."\n";
+ } elsif ($test{max}) {
+ print "$test{ml}ok\n";
+ } elsif (defined $test{skip_reason}) {
+ print "skipped: $test{skip_reason}\n";
+ $tot{skipped}++;
} else {
print "skipped test on this platform\n";
- $tests_skipped++;
+ $tot{skipped}++;
}
- $good++;
- } elsif ($max) {
- if ($next <= $max) {
- push @failed, $next..$max;
+ $tot{good}++;
+ } elsif ($test{max}) {
+ if ($test{next} <= $test{max}) {
+ push @{$test{failed}}, $test{next}..$test{max};
}
- if (@failed) {
- my ($txt, $canon) = canonfailed($max,$skipped,@failed);
- print "${ml}$txt";
- $failedtests{$test} = { canon => $canon, max => $max,
- failed => scalar @failed,
- name => $test, percent => 100*(scalar @failed)/$max,
- estat => '', wstat => '',
+ if (@{$test{failed}}) {
+ my ($txt, $canon) = canonfailed($test{max},$test{skipped},
+ @{$test{failed}});
+ print "$test{ml}$txt";
+ $failedtests{$test} = { canon => $canon,
+ max => $test{max},
+ failed => scalar @{$test{failed}},
+ name => $test,
+ percent => 100*(scalar @{$test{failed}})/$test{max},
+ estat => '',
+ wstat => '',
};
} else {
- print "Don't know which tests failed: got $ok ok, expected $max\n";
- $failedtests{$test} = { canon => '??', max => $max,
- failed => '??',
- name => $test, percent => undef,
- estat => '', wstat => '',
+ print "Don't know which tests failed: got $test{ok} ok, ".
+ "expected $test{max}\n";
+ $failedtests{$test} = { canon => '??',
+ max => $test{max},
+ failed => '??',
+ name => $test,
+ percent => undef,
+ estat => '',
+ wstat => '',
};
}
- $bad++;
- } elsif ($next == 0) {
+ $tot{bad}++;
+ } elsif ($test{next} == 0) {
print "FAILED before any test output arrived\n";
- $bad++;
- $failedtests{$test} = { canon => '??', max => '??',
- failed => '??',
- name => $test, percent => undef,
- estat => '', wstat => '',
+ $tot{bad}++;
+ $failedtests{$test} = { canon => '??',
+ max => '??',
+ failed => '??',
+ name => $test,
+ percent => undef,
+ estat => '',
+ wstat => '',
};
}
- $subtests_skipped += $skipped;
- if (defined $files_in_dir) {
- my @new_dir_files = globdir $files_in_dir;
+ $tot{sub_skipped} += $test{skipped};
+
+ if (defined $Files_In_Dir) {
+ my @new_dir_files = globdir $Files_In_Dir;
if (@new_dir_files != @dir_files) {
my %f;
@f{@new_dir_files} = (1) x @new_dir_files;
}
}
}
- my $t_total = timediff(new Benchmark, $t_start);
+ $tot{bench} = timediff(new Benchmark, $t_start);
if ($^O eq 'VMS') {
if (defined $old5lib) {
delete $ENV{PERL5LIB};
}
}
- my $bonusmsg = '';
- $bonusmsg = (" ($totbonus subtest".($totbonus>1?'s':'').
- " UNEXPECTEDLY SUCCEEDED)")
- if $totbonus;
- if ($tests_skipped) {
- $bonusmsg .= ", $tests_skipped test" . ($tests_skipped != 1 ? 's' : '');
- if ($subtests_skipped) {
- $bonusmsg .= " and $subtests_skipped subtest"
- . ($subtests_skipped != 1 ? 's' : '');
- }
- $bonusmsg .= ' skipped';
- }
- elsif ($subtests_skipped) {
- $bonusmsg .= ", $subtests_skipped subtest"
- . ($subtests_skipped != 1 ? 's' : '')
- . " skipped";
- }
- if ($bad == 0 && $totmax) {
+
+ return(\%tot, \%failedtests);
+}
+
+
+sub _show_results {
+ my($tot, $failedtests) = @_;
+
+ my $pct;
+ my $bonusmsg = _bonusmsg($tot);
+
+ if ($tot->{bad} == 0 && $tot->{max}) {
print "All tests successful$bonusmsg.\n";
- } elsif ($total==0){
+ } elsif ($tot->{tests}==0){
die "FAILED--no tests were run for some reason.\n";
- } elsif ($totmax==0) {
- my $blurb = $total==1 ? "script" : "scripts";
- die "FAILED--$total test $blurb could be run, alas--no output ever seen\n";
+ } elsif ($tot->{max} == 0) {
+ my $blurb = $tot->{tests}==1 ? "script" : "scripts";
+ die "FAILED--$tot->{tests} test $blurb could be run, ".
+ "alas--no output ever seen\n";
} else {
- $pct = sprintf("%.2f", $good / $total * 100);
+ $pct = sprintf("%.2f", $tot->{good} / $tot->{tests} * 100);
my $subpct = sprintf " %d/%d subtests failed, %.2f%% okay.",
- $totmax - $totok, $totmax, 100*$totok/$totmax;
- # Create formats
- # First, figure out max length of test names
- my $failed_str = "Failed Test";
- my $middle_str = " Status Wstat Total Fail Failed ";
- my $list_str = "List of Failed";
- my $max_namelen = length($failed_str);
- my $script;
- foreach $script (keys %failedtests) {
- $max_namelen =
- (length $failedtests{$script}->{name} > $max_namelen) ?
- length $failedtests{$script}->{name} : $max_namelen;
- }
- my $list_len = $columns - length($middle_str) - $max_namelen;
- if ($list_len < length($list_str)) {
- $list_len = length($list_str);
- $max_namelen = $columns - length($middle_str) - $list_len;
- if ($max_namelen < length($failed_str)) {
- $max_namelen = length($failed_str);
- $columns = $max_namelen + length($middle_str) + $list_len;
- }
- }
-
- my $fmt_top = "format STDOUT_TOP =\n"
- . sprintf("%-${max_namelen}s", $failed_str)
- . $middle_str
- . $list_str . "\n"
- . "-" x $columns
- . "\n.\n";
- my $fmt = "format STDOUT =\n"
- . "@" . "<" x ($max_namelen - 1)
- . " @>> @>>>> @>>>> @>>> ^##.##% "
- . "^" . "<" x ($list_len - 1) . "\n"
- . '{ $curtest->{name}, $curtest->{estat},'
- . ' $curtest->{wstat}, $curtest->{max},'
- . ' $curtest->{failed}, $curtest->{percent},'
- . ' $curtest->{canon}'
- . "\n}\n"
- . "~~" . " " x ($columns - $list_len - 2) . "^"
- . "<" x ($list_len - 1) . "\n"
- . '$curtest->{canon}'
- . "\n.\n";
+ $tot->{max} - $tot->{ok}, $tot->{max},
+ 100*$tot->{ok}/$tot->{max};
- eval $fmt_top;
- die $@ if $@;
- eval $fmt;
- die $@ if $@;
+ my($fmt_top, $fmt) = _create_fmts($failedtests);
# Now write to formats
- for $script (sort keys %failedtests) {
- $curtest = $failedtests{$script};
+ for my $script (sort keys %$failedtests) {
+ $Curtest = $failedtests->{$script};
write;
}
- if ($bad) {
+ if ($tot->{bad}) {
$bonusmsg =~ s/^,\s*//;
print "$bonusmsg.\n" if $bonusmsg;
- die "Failed $bad/$total test scripts, $pct% okay.$subpct\n";
+ die "Failed $tot->{bad}/$tot->{tests} test scripts, $pct% okay.".
+ "$subpct\n";
}
}
- printf("Files=%d, Tests=%d, %s\n", $files, $totmax, timestr($t_total, 'nop'));
- return ($bad == 0 && $totmax) ;
+ printf("Files=%d, Tests=%d, %s\n",
+ $tot->{files}, $tot->{max}, timestr($tot->{bench}, 'nop'));
+}
+
+
+sub _parse_header {
+ my($line, $test, $tot) = @_;
+
+ my $is_header = 0;
+
+ print $line if $Verbose;
+
+ # 1..10 todo 4 7 10;
+ if ($line =~ /^1\.\.([0-9]+) todo([\d\s]+);?/i) {
+ $test->{max} = $1;
+ for (split(/\s+/, $2)) { $test->{todo}{$_} = 1; }
+
+ $tot->{max} += $test->{max};
+ $tot->{files}++;
+
+ $is_header = 1;
+ }
+ # 1..10
+ # 1..0 # skip Why? Because I said so!
+ elsif ($line =~ /^1\.\.([0-9]+)
+ (\s*\#\s*[Ss]kip\S*(?>\s+) (.+))?
+ /x
+ )
+ {
+ $test->{max} = $1;
+ $tot->{max} += $test->{max};
+ $tot->{files}++;
+ $test->{next} = 1 unless $test->{next};
+ $test->{skip_reason} = $3 if not $test->{max} and defined $3;
+
+ $is_header = 1;
+ }
+ else {
+ $is_header = 0;
+ }
+
+ return $is_header;
}
+
+sub _parse_test_line {
+ my($line, $test, $tot) = @_;
+
+ if ($line =~ /^(not\s+)?ok\b/i) {
+ my $this = $test->{next} || 1;
+ # "not ok 23"
+ if ($line =~ /^not ok\s*(\d*)/){ # test failed
+ $this = $1 if length $1 and $1 > 0;
+ print "$test->{ml}NOK $this" if $test->{ml};
+ if (!$test->{todo}{$this}) {
+ push @{$test->{failed}}, $this;
+ } else {
+ $test->{ok}++;
+ $tot->{ok}++;
+ }
+ }
+ # "ok 23 # skip (you're not cleared for that)"
+ elsif ($line =~ /^ok\s*(\d*)\ *
+ (\s*\#\s*[Ss]kip\S*(?:(?>\s+)(.+))?)?
+ /x) # test skipped
+ {
+ $this = $1 if length $1 and $1 > 0;
+ print "$test->{ml}ok $this/$test->{max}" if $test->{ml};
+ $test->{ok}++;
+ $tot->{ok}++;
+ $test->{skipped}++ if defined $2;
+ my $reason;
+ $reason = 'unknown reason' if defined $2;
+ $reason = $3 if defined $3;
+ if (defined $reason and defined $test->{skip_reason}) {
+ # print "was: '$skip_reason' new '$reason'\n";
+ $test->{skip_reason} = 'various reasons'
+ if $test->{skip_reason} ne $reason;
+ } elsif (defined $reason) {
+ $test->{skip_reason} = $reason;
+ }
+ $test->{bonus}++, $tot->{bonus}++ if $test->{todo}{$this};
+ }
+ # XXX ummm... dunno
+ elsif ($line =~ /^ok\s*(\d*)\s*\#([^\r]*)$/) { # XXX multiline ok?
+ $this = $1 if $1 > 0;
+ print "$test->{ml}ok $this/$test->{max}" if $test->{ml};
+ $test->{ok}++;
+ $tot->{ok}++;
+ }
+ else {
+ # an ok or not ok not matching the 3 cases above...
+ # just ignore it for compatibility with TEST
+ next;
+ }
+
+ if ($this > $test->{next}) {
+ # print "Test output counter mismatch [test $this]\n";
+ # no need to warn probably
+ push @{$test->{failed}}, $test->{next}..$this-1;
+ }
+ elsif ($this < $test->{next}) {
+ #we have seen more "ok" lines than the number suggests
+ print "Confused test output: test $this answered after ".
+ "test ", $test->{next}-1, "\n";
+ $test->{next} = $this;
+ }
+ $test->{next} = $this + 1;
+
+ }
+ elsif ($line =~ /^Bail out!\s*(.*)/i) { # magic words
+ die "FAILED--Further testing stopped" .
+ ($1 ? ": $1\n" : ".\n");
+ }
+}
+
+
+sub _bonusmsg {
+ my($tot) = @_;
+
+ my $bonusmsg = '';
+ $bonusmsg = (" ($tot->{bonus} subtest".($tot->{bonus} > 1 ? 's' : '').
+ " UNEXPECTEDLY SUCCEEDED)")
+ if $tot->{bonus};
+
+ if ($tot->{skipped}) {
+ $bonusmsg .= ", $tot->{skipped} test"
+ . ($tot->{skipped} != 1 ? 's' : '');
+ if ($tot->{sub_skipped}) {
+ $bonusmsg .= " and $tot->{sub_skipped} subtest"
+ . ($tot->{sub_skipped} != 1 ? 's' : '');
+ }
+ $bonusmsg .= ' skipped';
+ }
+ elsif ($tot->{sub_skipped}) {
+ $bonusmsg .= ", $tot->{sub_skipped} subtest"
+ . ($tot->{sub_skipped} != 1 ? 's' : '')
+ . " skipped";
+ }
+
+ return $bonusmsg;
+}
+
+# VMS has some subtle nastiness with closing the test files.
+sub _close_fh {
+ my($fh) = shift;
+
+ close($fh); # must close to reap child resource values
+
+ my $wstatus = $Ignore_Exitcode ? 0 : $?; # Can trust $? ?
+ my $estatus;
+ $estatus = ($^O eq 'VMS'
+ ? eval 'use vmsish "status"; $estatus = $?'
+ : $wstatus >> 8);
+
+ return($estatus, $wstatus);
+}
+
+
+# Set up the command-line switches to run perl as.
+sub _set_switches {
+ my($test) = shift;
+
+ open(my $fh, $test) or print "can't open $test. $!\n";
+ my $first = <$fh>;
+ my $s = $Switches;
+ $s .= " $ENV{'HARNESS_PERL_SWITCHES'}"
+ if exists $ENV{'HARNESS_PERL_SWITCHES'};
+ $s .= join " ", q[ "-T"], map {qq["-I$_"]} @INC
+ if $first =~ /^#!.*\bperl.*-\w*T/;
+
+ close($fh) or print "can't close $test. $!\n";
+
+ return $s;
+}
+
+
+# Test program go boom.
+sub _dubious_return {
+ my($test, $tot, $estatus, $wstatus) = @_;
+ my ($failed, $canon, $percent) = ('??', '??');
+
+ printf "$test->{ml}dubious\n\tTest returned status $estatus ".
+ "(wstat %d, 0x%x)\n",
+ $wstatus,$wstatus;
+ print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS';
+
+ if (corestatus($wstatus)) { # until we have a wait module
+ if ($Have_Devel_Corestack) {
+ Devel::CoreStack::stack($^X);
+ } else {
+ print "\ttest program seems to have generated a core\n";
+ }
+ }
+
+ $tot->{bad}++;
+
+ if ($test->{max}) {
+ if ($test->{next} == $test->{max} + 1 and not @{$test->{failed}}) {
+ print "\tafter all the subtests completed successfully\n";
+ $percent = 0;
+ $failed = 0; # But we do not set $canon!
+ }
+ else {
+ push @{$test->{failed}}, $test->{next}..$test->{max};
+ $failed = @{$test->{failed}};
+ (my $txt, $canon) = canonfailed($test->{max},$test->{skipped},@{$test->{failed}});
+ $percent = 100*(scalar @{$test->{failed}})/$test->{max};
+ print "DIED. ",$txt;
+ }
+ }
+
+ return { canon => $canon, max => $test->{max} || '??',
+ failed => $failed,
+ name => $test, percent => $percent,
+ estat => $estatus, wstat => $wstatus,
+ };
+}
+
+
+sub _garbled_output {
+ my($gibberish) = shift;
+ warn "Confusing test output: '$gibberish'\n";
+}
+
+
+sub _create_fmts {
+ my($failedtests) = @_;
+
+ my $failed_str = "Failed Test";
+ my $middle_str = " Status Wstat Total Fail Failed ";
+ my $list_str = "List of Failed";
+
+ # Figure out our longest name string for formatting purposes.
+ my $max_namelen = length($failed_str);
+ foreach my $script (keys %$failedtests) {
+ my $namelen = length $failedtests->{$script}->{name};
+ $max_namelen = $namelen if $namelen > $max_namelen;
+ }
+
+ my $list_len = $Columns - length($middle_str) - $max_namelen;
+ if ($list_len < length($list_str)) {
+ $list_len = length($list_str);
+ $max_namelen = $Columns - length($middle_str) - $list_len;
+ if ($max_namelen < length($failed_str)) {
+ $max_namelen = length($failed_str);
+ $Columns = $max_namelen + length($middle_str) + $list_len;
+ }
+ }
+
+ my $fmt_top = "format STDOUT_TOP =\n"
+ . sprintf("%-${max_namelen}s", $failed_str)
+ . $middle_str
+ . $list_str . "\n"
+ . "-" x $Columns
+ . "\n.\n";
+
+ my $fmt = "format STDOUT =\n"
+ . "@" . "<" x ($max_namelen - 1)
+ . " @>> @>>>> @>>>> @>>> ^##.##% "
+ . "^" . "<" x ($list_len - 1) . "\n"
+ . '{ $Curtest->{name}, $Curtest->{estat},'
+ . ' $Curtest->{wstat}, $Curtest->{max},'
+ . ' $Curtest->{failed}, $Curtest->{percent},'
+ . ' $Curtest->{canon}'
+ . "\n}\n"
+ . "~~" . " " x ($Columns - $list_len - 2) . "^"
+ . "<" x ($list_len - 1) . "\n"
+ . '$Curtest->{canon}'
+ . "\n.\n";
+
+ eval $fmt_top;
+ die $@ if $@;
+ eval $fmt;
+ die $@ if $@;
+
+ return($fmt_top, $fmt);
+}
+
+
my $tried_devel_corestack;
sub corestatus {
my($st) = @_;
eval {require 'wait.ph'};
my $ret = defined &WCOREDUMP ? WCOREDUMP($st) : $st & 0200;
- eval { require Devel::CoreStack; $have_devel_corestack++ }
+ eval { require Devel::CoreStack; $Have_Devel_Corestack++ }
unless $tried_devel_corestack++;
$ret;
my $ender = 's' x ($skipped > 1);
my $good = $max - $failed - $skipped;
my $goodper = sprintf("%.2f",100*($good/$max));
- push @result, " (-$skipped skipped test$ender: $good okay, $goodper%)" if $skipped;
+ push @result, " (-$skipped skipped test$ender: $good okay, ".
+ "$goodper%)"
+ if $skipped;
push @result, "\n";
my $txt = join "", @result;
($txt, $canon);
=head1 DESCRIPTION
-(By using the L<Test> module, you can write test scripts without
+(By using the Test module, you can write test scripts without
knowing the exact output this module expects. However, if you need to
know the specifics, read on!)
=head2 The test script output
+=over 4
+
+=item B<1..M>
+
+This header tells how many tests there will be. It should be the
+first line output by your test program (but its okay if its preceded
+by comments).
+
+In certain instanced, you may not know how many tests you will
+ultimately be running. In this case, it is permitted (but not
+encouraged) for the 1..M header to appear as the B<last> line output
+by your test (again, it can be followed by further comments). But we
+strongly encourage you to put it first.
+
+Under B<no> circumstances should 1..M appear in the middle of your
+output or more than once.
+
+
+=item B<'ok', 'not ok'. Ok?>
+
Any output from the testscript to standard error is ignored and
bypassed, thus will be seen by the user. Lines written to standard
output containing C</^(not\s+)?ok\b/> are interpreted as feedback for
runtests(). All other lines are discarded.
-It is tolerated if the test numbers after C<ok> are omitted. In this
-case Test::Harness maintains temporarily its own counter until the
-script supplies test numbers again. So the following test script
+C</^not ok/> indicates a failed test. C</^ok/> is a successful test.
+
+
+=item B<test numbers>
+
+Perl normally expects the 'ok' or 'not ok' to be followed by a test
+number. It is tolerated if the test numbers after 'ok' are
+omitted. In this case Test::Harness maintains temporarily its own
+counter until the script supplies test numbers again. So the following
+test script
print <<END;
1..6
FAILED tests 1, 3, 6
Failed 3/6 tests, 50.00% okay
+
+=item B<$Test::Harness::verbose>
+
The global variable $Test::Harness::verbose is exportable and can be
used to let runtests() display the standard output of the script
without altering the behavior otherwise.
+=item B<$Test::Harness::switches>
+
The global variable $Test::Harness::switches is exportable and can be
used to set perl command line options used for running the test
script(s). The default value is C<-w>.
+=item B<Skipping tests>
+
If the standard output line contains substring C< # Skip> (with
variations in spacing and case) after C<ok> or C<ok NUMBER>, it is
-counted as a skipped test. In no other circumstance is anything
-allowed to follow C<ok> or C<ok NUMBER>. If the whole testscript
-succeeds, the count of skipped tests is included in the generated
-output.
+counted as a skipped test. If the whole testscript succeeds, the
+count of skipped tests is included in the generated output.
C<Test::Harness> reports the text after C< # Skip\S*\s+> as a reason
for skipping. Similarly, one can include a similar explanation in a
-C<1..0> line emitted if the test is skipped completely:
+C<1..0> line emitted if the test script is skipped completely:
1..0 # Skipped: no leverage found
+=item B<Bail out!>
+
As an emergency measure, a test script can decide that further tests
are useless (e.g. missing dependencies) and testing should stop
immediately. In that case the test script prints the magic words
to standard output. Any message after these words will be displayed by
C<Test::Harness> as the reason why testing is stopped.
+=item B<Comments>
+
+Additional comments may be put into the testing output on their own
+lines. Comment lines should begin with a '#', Test::Harness will
+ignore them.
+
+ ok 1
+ # Life is good, the sun is shining, RAM is cheap.
+ not ok 2
+ # got 'Bush' expected 'Gore'
+
+
=head1 EXPORT
C<&runtests> is exported by Test::Harness per default.
+C<$verbose> and C<$switches> are exported upon request.
+
+
=head1 DIAGNOSTICS
=over 4
=item C<Test returned status %d (wstat %d)>
-Scripts that return a non-zero exit status, both C<$? E<gt>E<gt> 8> and C<$?> are
-printed in a message similar to the above.
+Scripts that return a non-zero exit status, both C<$? E<gt>E<gt> 8>
+and C<$?> are printed in a message similar to the above.
=item C<Failed 1 test, %.2f%% okay. %s>
binary => "& | ^",
unary => "neg ! ~",
mutators => '++ --',
- func => "atan2 cos sin exp abs log sqrt",
+ func => "atan2 cos sin exp abs log sqrt int",
conversion => 'bool "" 0+',
iterators => '<>',
dereferencing => '${} @{} %{} &{} *{}',
=item * I<Transcendental functions>
- "atan2", "cos", "sin", "exp", "abs", "log", "sqrt",
+ "atan2", "cos", "sin", "exp", "abs", "log", "sqrt", "int"
If C<abs> is unavailable, it can be autogenerated using methods
for "E<lt>" or "E<lt>=E<gt>" combined with either unary minus or subtraction.
+Note that traditionally the Perl function L<int> rounds to 0, thus for
+floating-point-like types one should follow the same semantic. If
+C<int> is unavailable, it can be autogenerated using the overloading of
+C<0+>.
+
=item * I<Boolean, string and numeric conversion>
"bool", "\"\"", "0+",
Both these problems can be cured. Say, if we want to overload hash
dereference on a reference to an object which is I<implemented> as a
hash itself, the only problem one has to circumvent is how to access
-this I<actual> hash (as opposed to the I<virtual> exhibited by
+this I<actual> hash (as opposed to the I<virtual> hash exhibited by the
overloaded dereference operator). Here is one possible fetching routine:
sub access_hash {
$out;
}
-To move creation of the tied hash on each access, one may an extra
+To remove creation of the tied hash on each access, one may an extra
level of indirection which allows a non-circular structure of references:
package two_refs1;
$a->[$key];
}
-Now if $baz is overloaded like this, then C<$bar> is a reference to a
+Now if $baz is overloaded like this, then C<$baz> is a reference to a
reference to the intermediate array, which keeps a reference to an
actual array, and the access hash. The tie()ing object for the access
-hash is also a reference to a reference to the actual array, so
+hash is a reference to a reference to the actual array, so
=over
I<components> $a and $b of an object. In the above subroutine
C<"[$meth $a $b]"> is a catenation of some strings and components $a
and $b. If these components use overloading, the catenation operator
-will look for an overloaded operator C<.>, if not present, it will
+will look for an overloaded operator C<.>; if not present, it will
look for an overloaded operator C<"">. Thus it is enough to use
use overload nomethod => \&wrap, '""' => \&str;
(not required without mutators!), and implements only those arithmetic
operations which are used in the example.
-To implement most arithmetic operations is easy, one should just use
+To implement most arithmetic operations is easy; one should just use
the tables of operations, and change the code which fills %subr to
my %subr = ( 'n' => sub {$_[0]} );
way to know that the implementation of C<'+='> does not mutate
the argument, compare L<Copy Constructor>).
-To implement a copy constructor, add C<'=' => \&cpy> to C<use overload>
+To implement a copy constructor, add C<< '=' => \&cpy >> to C<use overload>
line, and code (this code assumes that mutators change things one level
deep only, so recursive copying is not needed):
+++ /dev/null
-# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
-# This file is built by mktables.PL from e.g. Unicode.301.
-# Any changes made here will be lost!
-return <<'END';
-fb55
-fb59
-fb5d
-fb61
-fb65
-fb69
-fb6d
-fb71
-fb75
-fb79
-fb7d
-fb81
-fb91
-fb95
-fb99
-fb9d
-fba3
-fba9
-fbad
-fbd6
-fbe7
-fbe9
-fbff
-fcdf fcf4
-fd34 fd3b
-fe71
-fe77
-fe79
-fe7b
-fe7d
-fe7f
-fe8c
-fe92
-fe98
-fe9c
-fea0
-fea4
-fea8
-feb4
-feb8
-febc
-fec0
-fec4
-fec8
-fecc
-fed0
-fed4
-fed8
-fedc
-fee0
-fee4
-fee8
-feec
-fef4
-END
POPSTACK;
if (SvTRUE(ERRSV)) {
+#ifndef PERL_MICRO
#ifdef HAS_SIGPROCMASK
/* Handler "died", for example to get out of a restart-able read().
* Before we re-do that on its behalf re-enable the signal which was
(void)rsignal(sig, SIG_IGN);
(void)rsignal(sig, &Perl_csighandler);
#endif
+#endif /* !PERL_MICRO */
Perl_die(aTHX_ Nullch);
}
cleanup:
#define Perl_utf8_to_bytes pPerl->Perl_utf8_to_bytes
#undef utf8_to_bytes
#define utf8_to_bytes Perl_utf8_to_bytes
+#undef Perl_bytes_from_utf8
+#define Perl_bytes_from_utf8 pPerl->Perl_bytes_from_utf8
+#undef bytes_from_utf8
+#define bytes_from_utf8 Perl_bytes_from_utf8
#undef Perl_bytes_to_utf8
#define Perl_bytes_to_utf8 pPerl->Perl_bytes_to_utf8
#undef bytes_to_utf8
case OP_AASSIGN:
case OP_NEXTSTATE:
case OP_DBSTATE:
- case OP_REFGEN:
case OP_CHOMP:
PL_modcount = RETURN_UNLIMITED_NUMBER;
break;
#if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT)
static char *local_patches[] = {
NULL
- ,"DEVEL8530"
+ ,"DEVEL8670"
,NULL
};
#ifdef USE_LOCALE_NUMERIC
Safefree(PL_numeric_name);
PL_numeric_name = Nullch;
+ SvREFCNT_dec(PL_numeric_radix);
#endif
/* clear utf8 character classes */
to_sv_amg, to_av_amg,
to_hv_amg, to_gv_amg,
to_cv_amg, iter_amg,
- DESTROY_amg, max_amg_code
+ int_amg, DESTROY_amg,
+ max_amg_code
/* Do not leave a trailing comma here. C9X allows it, C89 doesn't. */
};
"(${}", "(@{}",
"(%{}", "(*{}",
"(&{}", "(<>",
- "DESTROY",
+ "(int", "DESTROY",
};
#else
EXTCONST char * PL_AMG_names[NofAMmeth];
#define SET_NUMERIC_LOCAL() \
set_numeric_local();
-#define IS_NUMERIC_RADIX(c) \
+#define IS_NUMERIC_RADIX(s) \
((PL_hints & HINT_LOCALE) && \
- PL_numeric_radix && (c) == PL_numeric_radix)
+ PL_numeric_radix && memEQ(s, SvPVX(PL_numeric_radix), SvCUR(PL_numeric_radix)))
#define STORE_NUMERIC_LOCAL_SET_STANDARD() \
bool was_local = (PL_hints & HINT_LOCALE) && PL_numeric_local; \
* massively.
*/
-#ifndef PERL_OLD_SIGNALS
-#define PERL_ASYNC_CHECK() if (PL_sig_pending) despatch_signals()
+#ifndef PERL_MICRO
+# ifndef PERL_OLD_SIGNALS
+# define PERL_ASYNC_CHECK() if (PL_sig_pending) despatch_signals()
+# endif
#endif
#ifndef PERL_ASYNC_CHECK
-#define PERL_ASYNC_CHECK() NOOP
+# define PERL_ASYNC_CHECK() NOOP
#endif
/*
return ((CPerlObj*)pPerl)->Perl_utf8_to_bytes(s, len);
}
+#undef Perl_bytes_from_utf8
+U8*
+Perl_bytes_from_utf8(pTHXo_ U8 *s, STRLEN *len, bool *is_utf8)
+{
+ return ((CPerlObj*)pPerl)->Perl_bytes_from_utf8(s, len, is_utf8);
+}
+
#undef Perl_bytes_to_utf8
U8*
Perl_bytes_to_utf8(pTHXo_ U8 *s, STRLEN *len)
PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
if (tab)
{
+ if (as && (ae == Nullch)) {
+ ae = e;
+ Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s);
+ }
len = (as) ? (ae-(as++)-1) : 0;
if (!PerlIO_push(f,tab,mode,as,len))
return -1;
=for hackers
Found in file av.c
+=item bytes_from_utf8
+
+Converts a string C<s> of length C<len> from UTF8 into byte encoding.
+Unlike <utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to
+the newly-created string, and updates C<len> to contain the new
+length. Returns the original string if no conversion occurs, C<len>
+is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
+0 if C<s> is converted or contains all 7bit characters.
+
+NOTE: this function is experimental and may change or be
+removed without notice.
+
+ U8* bytes_from_utf8(U8 *s, STRLEN *len, bool *is_utf8)
+
+=for hackers
+Found in file utf8.c
+
=item bytes_to_utf8
Converts a string C<s> of length C<len> from ASCII into UTF8 encoding.
=for hackers
Found in file perl.c
-=item PL_DBsingle
-
-When Perl is run in debugging mode, with the B<-d> switch, this SV is a
-boolean which indicates whether subs are being single-stepped.
-Single-stepping is automatically turned on after every step. This is the C
-variable which corresponds to Perl's $DB::single variable. See
-C<PL_DBsub>.
-
- SV * PL_DBsingle
-
-=for hackers
-Found in file intrpvar.h
-
-=item PL_DBsub
-
-When Perl is run in debugging mode, with the B<-d> switch, this GV contains
-the SV which holds the name of the sub being debugged. This is the C
-variable which corresponds to Perl's $DB::sub variable. See
-C<PL_DBsingle>.
-
- GV * PL_DBsub
-
-=for hackers
-Found in file intrpvar.h
-
-=item PL_DBtrace
-
-Trace variable used when Perl is run in debugging mode, with the B<-d>
-switch. This is the C variable which corresponds to Perl's $DB::trace
-variable. See C<PL_DBsingle>.
-
- SV * PL_DBtrace
-
-=for hackers
-Found in file intrpvar.h
-
-=item PL_dowarn
-
-The C variable which corresponds to Perl's $^W warning variable.
-
- bool PL_dowarn
-
-=for hackers
-Found in file intrpvar.h
-
-=item PL_last_in_gv
-
-The GV which was last used for a filehandle input operation. (C<< <FH> >>)
-
- GV* PL_last_in_gv
-
-=for hackers
-Found in file thrdvar.h
-
=item PL_modglobal
C<PL_modglobal> is a general purpose, interpreter global HV for use by
=for hackers
Found in file thrdvar.h
-=item PL_ofs_sv
-
-The output field separator - C<$,> in Perl space.
-
- SV* PL_ofs_sv
-
-=for hackers
-Found in file thrdvar.h
-
-=item PL_rs
-
-The input record separator - C<$/> in Perl space.
-
- SV* PL_rs
-
-=for hackers
-Found in file thrdvar.h
-
=item PL_sv_no
This is the C<false> SV. See C<PL_sv_yes>. Always refer to this as
=for hackers
Found in file sv.h
-=item svtype
+=item SvTYPE
-An enum of flags for Perl types. These are found in the file B<sv.h>
-in the C<svtype> enum. Test these flags with the C<SvTYPE> macro.
+Returns the type of the SV. See C<svtype>.
+
+ svtype SvTYPE(SV* sv)
=for hackers
Found in file sv.h
-=item SvTYPE
-
-Returns the type of the SV. See C<svtype>.
+=item svtype
- svtype SvTYPE(SV* sv)
+An enum of flags for Perl types. These are found in the file B<sv.h>
+in the C<svtype> enum. Test these flags with the C<SvTYPE> macro.
=for hackers
Found in file sv.h
=head1 SYNOPSIS
+ #define PERLIO_NOT_STDIO 0 /* For co-existence with stdio only */
+ #include <perlio.h> /* Usually via #include <perl.h> */
+
PerlIO *PerlIO_stdin(void);
PerlIO *PerlIO_stdout(void);
PerlIO *PerlIO_stderr(void);
- PerlIO *PerlIO_open(const char *,const char *);
- int PerlIO_close(PerlIO *);
-
- int PerlIO_stdoutf(const char *,...)
- int PerlIO_puts(PerlIO *,const char *);
- int PerlIO_putc(PerlIO *,int);
- int PerlIO_write(PerlIO *,const void *,size_t);
- int PerlIO_printf(PerlIO *, const char *,...);
- int PerlIO_vprintf(PerlIO *, const char *, va_list);
- int PerlIO_flush(PerlIO *);
-
- int PerlIO_eof(PerlIO *);
- int PerlIO_error(PerlIO *);
- void PerlIO_clearerr(PerlIO *);
-
- int PerlIO_getc(PerlIO *);
- int PerlIO_ungetc(PerlIO *,int);
- int PerlIO_read(PerlIO *,void *,size_t);
-
- int PerlIO_fileno(PerlIO *);
- PerlIO *PerlIO_fdopen(int, const char *);
- PerlIO *PerlIO_importFILE(FILE *, int flags);
- FILE *PerlIO_exportFILE(PerlIO *, int flags);
- FILE *PerlIO_findFILE(PerlIO *);
- void PerlIO_releaseFILE(PerlIO *,FILE *);
-
- void PerlIO_setlinebuf(PerlIO *);
-
- long PerlIO_tell(PerlIO *);
- int PerlIO_seek(PerlIO *,off_t,int);
- int PerlIO_getpos(PerlIO *,Fpos_t *)
- int PerlIO_setpos(PerlIO *,Fpos_t *)
- void PerlIO_rewind(PerlIO *);
-
- int PerlIO_has_base(PerlIO *);
- int PerlIO_has_cntptr(PerlIO *);
- int PerlIO_fast_gets(PerlIO *);
- int PerlIO_canset_cnt(PerlIO *);
-
- char *PerlIO_get_ptr(PerlIO *);
- int PerlIO_get_cnt(PerlIO *);
- void PerlIO_set_cnt(PerlIO *,int);
- void PerlIO_set_ptrcnt(PerlIO *,char *,int);
- char *PerlIO_get_base(PerlIO *);
- int PerlIO_get_bufsiz(PerlIO *);
+ PerlIO *PerlIO_open(const char *path,const char *mode);
+ PerlIO *PerlIO_fdopen(int fd, const char *mode);
+ PerlIO *PerlIO_reopen(const char *path, const char *mode, PerlIO *old); /* deprecated */
+ int PerlIO_close(PerlIO *f);
+
+ int PerlIO_stdoutf(const char *fmt,...)
+ int PerlIO_puts(PerlIO *f,const char *string);
+ int PerlIO_putc(PerlIO *f,int ch);
+ int PerlIO_write(PerlIO *f,const void *buf,size_t numbytes);
+ int PerlIO_printf(PerlIO *f, const char *fmt,...);
+ int PerlIO_vprintf(PerlIO *f, const char *fmt, va_list args);
+ int PerlIO_flush(PerlIO *f);
+
+ int PerlIO_eof(PerlIO *f);
+ int PerlIO_error(PerlIO *f);
+ void PerlIO_clearerr(PerlIO *f);
+
+ int PerlIO_getc(PerlIO *d);
+ int PerlIO_ungetc(PerlIO *f,int ch);
+ int PerlIO_read(PerlIO *f, void *buf, size_t numbytes);
+
+ int PerlIO_fileno(PerlIO *f);
+
+ void PerlIO_setlinebuf(PerlIO *f);
+
+ Off_t PerlIO_tell(PerlIO *f);
+ int PerlIO_seek(PerlIO *f, Off_t offset, int whence);
+ void PerlIO_rewind(PerlIO *f);
+
+ int PerlIO_getpos(PerlIO *f, SV *save); /* prototype changed */
+ int PerlIO_setpos(PerlIO *f, SV *saved); /* prototype changed */
+
+ int PerlIO_fast_gets(PerlIO *f);
+ int PerlIO_has_cntptr(PerlIO *f);
+ int PerlIO_get_cnt(PerlIO *f);
+ char *PerlIO_get_ptr(PerlIO *f);
+ void PerlIO_set_ptrcnt(PerlIO *f, char *ptr, int count);
+
+ int PerlIO_canset_cnt(PerlIO *f); /* deprecated */
+ void PerlIO_set_cnt(PerlIO *f, int count); /* deprecated */
+
+ int PerlIO_has_base(PerlIO *f);
+ char *PerlIO_get_base(PerlIO *f);
+ int PerlIO_get_bufsiz(PerlIO *f);
+
+ PerlIO *PerlIO_importFILE(FILE *stdio, int flags);
+ FILE *PerlIO_exportFILE(PerlIO *f, int flags);
+ FILE *PerlIO_findFILE(PerlIO *f);
+ void PerlIO_releaseFILE(PerlIO *f,FILE *stdio);
+
+ int PerlIO_apply_layers(PerlIO *f, const char *mode, const char *layers);
+ int PerlIO_binmode(PerlIO *f, int ptype, int imode, const char *layers);
+ void PerlIO_debug(const char *fmt,...)
=head1 DESCRIPTION
-Perl's source code should use the above functions instead of those
-defined in ANSI C's I<stdio.h>. The perl headers will C<#define> them to
-the I/O mechanism selected at Configure time.
+Perl's source code, and extensions that want maximum portability, should use the above
+functions instead of those defined in ANSI C's I<stdio.h>. The perl headers (in
+particular "perlio.h") will C<#define> them to the I/O mechanism selected at Configure time.
The functions are modeled on those in I<stdio.h>, but parameter order
has been "tidied up a little".
+C<PerlIO *> takes the place of FILE *. Like FILE * it should be treated as
+opaque (it is probably safe to assume it is a pointer to something).
+
+There are currently three implementations:
+
=over 4
-=item B<PerlIO *>
+=item 1. USE_STDIO
-This takes the place of FILE *. Like FILE * it should be treated as
-opaque (it is probably safe to assume it is a pointer to something).
+All above are #define'd to stdio functions or are trivial wrapper functions which
+call stdio. In this case I<only> PerlIO * is a FILE *.
+This has been the default implementation since the abstraction was introduced
+in perl5.003_02.
+
+=item 2. USE_SFIO
+
+A "legacy" implementation in terms of the "sfio" library. Used for some specialist
+applications on Unix machines ("sfio" is not widely ported away from Unix).
+Most of above are #define'd to the sfio functions. PerlIO * is in this case Sfio_t *.
+
+=item 3. USE_PERLIO
+
+Introduced just after perl5.7.0 this is a re-implementation of the above abstraction
+which allows perl more control over how IO is done as it decouples IO from the
+way the operating system and C library choose to do things. For USE_PERLIO
+PerlIO * has an extra layer of indirection - it is a pointer-to-a-pointer.
+This allows the PerlIO * to remain with a known value while swapping the
+implementation arround underneath I<at run time>. In this case all the
+above are true (but very simple) functions which call the underlying implementation.
+
+This is the only implementation for which C<PerlIO_apply_layers()> does anything
+"interesting".
+
+The USE_PERLIO implementation is described in L<perliol>.
+
+=back
+
+Because "perlio.h" is a thing layer (for efficiency) the semantics of these functions are
+somewhat dependent on the the underlying implementation. Where these variations are
+understood they are noted below.
+
+Unless otherwise noted, functions return 0 on success, or a negative value (usually
+C<EOF> which is usually -1) and set C<errno> on error.
+
+=over 4
=item B<PerlIO_stdin()>, B<PerlIO_stdout()>, B<PerlIO_stderr()>
=item B<PerlIO_open(path, mode)>, B<PerlIO_fdopen(fd,mode)>
-These correspond to fopen()/fdopen() arguments are the same.
+These correspond to fopen()/fdopen() and the arguments are the same.
+Return C<NULL> and set C<errno> if there is an error.
+There may be an implementation limit on the number of open handles, which may
+be lower than the limit on the number of open files - C<errno> may
+not be set when C<NULL> is returned if this limnit is exceeded.
+
+=item B<PerlIO_reopen(path,mode,f)>
+
+While this currently exists in all three implementations perl itself
+does not use it. I<As perl does not use it, it is not well tested.>
+
+Perl prefers to C<dup> the new low-level descriptor to the descriptor used
+by the existing PerlIO. This may become the behaviour of this function
+in the future.
=item B<PerlIO_printf(f,fmt,...)>, B<PerlIO_vprintf(f,fmt,a)>
These correspond to fread() and fwrite(). Note that arguments
are different, there is only one "count" and order has
-"file" first.
+"file" first. Returns a byte count if successful (which may be zero),
+returns negative value and sets C<errno> on error.
+Depending on implementation C<errno> may be C<EINTR> if operation
+was interrupted by a signal.
=item B<PerlIO_close(f)>
+Depending on implementation C<errno> may be C<EINTR> if operation
+was interrupted by a signal.
+
=item B<PerlIO_puts(f,s)>, B<PerlIO_putc(f,c)>
These correspond to fputs() and fputc().
This corresponds to ungetc().
Note that arguments have been revised to have "file" first.
+Arranges that next read operation will return the byte B<c>.
+Despite the implied "character" in the name only values in the
+range 0..0xFF are defined. Returns the byte B<c> on success or -1 (C<EOF>) on error.
+The number of bytes that can be "pushed back" may vary, only 1 character is
+certain, and then only if it is the last character that was read from the handle.
=item B<PerlIO_getc(f)>
This corresponds to getc().
+Despite the c in the name only byte range 0..0xFF is supported.
+Returns the character read or -1 (C<EOF>) on error.
=item B<PerlIO_eof(f)>
This corresponds to feof().
+Returns a true/false indication of whether the handle is at end of file.
+For terminal devices this may or may not be "sticky" depending on the implementation.
+The flag is cleared by PerlIO_seek(), or PerlIO_rewind().
=item B<PerlIO_error(f)>
This corresponds to ferror().
+Returns a true/false indication of whether there has been an IO error on the handle.
=item B<PerlIO_fileno(f)>
This corresponds to fileno(), note that on some platforms,
-the meaning of "fileno" may not match Unix.
+the meaning of "fileno" may not match Unix. Returns -1 if the handle has no
+open descriptor associated with it.
=item B<PerlIO_clearerr(f)>
-This corresponds to clearerr(), i.e., clears 'eof' and 'error'
-flags for the "stream".
+This corresponds to clearerr(), i.e., clears 'error' and (usually) 'eof'
+flags for the "stream". Does not return a value.
=item B<PerlIO_flush(f)>
This corresponds to fflush().
+Sends any buffered write data to the underlying file.
+If called with C<NULL> this may flush all open streams (or core dump).
+Calling on a handle open for read only, or on which last operation was a read of some kind
+may lead to undefined behaviour.
-=item B<PerlIO_tell(f)>
+=item B<PerlIO_seek(f,offset,whence)>
-This corresponds to ftell().
+This corresponds to fseek().
+Sends buffered write data to the underlying file, or discards any buffered
+read data, then positions the file desciptor as specified by B<offset> and B<whence> (sic).
+This is the correct thing to do when switching between read and write on the same
+handle (see issues with PerlIO_flush() above).
+Offset is of type C<Off_t> which is a perl Configure value which may not be same
+as stdio's C<off_t>.
-=item B<PerlIO_seek(f,o,w)>
+=item B<PerlIO_tell(f)>
-This corresponds to fseek().
+This corresponds to ftell().
+Returns the current file position, or (Off_t) -1 on error.
+May just return value system "knows" without making a system call or checking
+the underlying file descriptor (so use on shared file descriptors is not
+safe without a PerlIO_seek()). Return value is of type C<Off_t> which is a perl Configure
+value which may not be same as stdio's C<off_t>.
=item B<PerlIO_getpos(f,p)>, B<PerlIO_setpos(f,p)>
-These correspond to fgetpos() and fsetpos(). If platform does not
-have the stdio calls then they are implemented in terms of PerlIO_tell()
-and PerlIO_seek().
+These correspond (loosely) to fgetpos() and fsetpos(). Rather than stdio's Fpos_t
+they expect a "Perl Scalar Value" to be passed. What is stored there should
+be considered opaque. The layout of the data may vary from handle to handle.
+When not using stdio or if platform does not have the stdio calls then they are
+implemented in terms of PerlIO_tell() and PerlIO_seek().
=item B<PerlIO_rewind(f)>
-This corresponds to rewind(). Note may be redefined
-in terms of PerlIO_seek() at some point.
+This corresponds to rewind(). It is usually defined as being
+
+ PerlIO_seek(f,(Off_t)0L, SEEK_SET);
+ PerlIO_clearerr(f);
+
=item B<PerlIO_tmpfile()>
This corresponds to tmpfile(), i.e., returns an anonymous
-PerlIO which will automatically be deleted when closed.
+PerlIO or NULL on error.
+The system will attempt to automatically delete the file when closed.
+On Unix the file is usually C<unlink>-ed just after
+it is created so it does not matter how it gets closed. On other systems the file may
+only be deleted if closed via PerlIO_close() and/or the program exits via C<exit>.
+Depending on the implementation there may be "race conditions" which allow other
+processes access to the file, though in general it will be safer in this regard
+than ad. hoc. schemes.
+
+=item B<PerlIO_setlinebuf(f)>
+
+This corresponds to setlinebuf().
+Does not return a value. What constitutes a "line" is implementation
+dependent but usually means that writing "\n" flushes the buffer.
+What happens with things like "this\nthat" is uncertain.
+(Perl core uses it I<only> when "dumping"; it has nothing to do with $| auto-flush.)
=back
There is outline support for co-existence of PerlIO with stdio.
Obviously if PerlIO is implemented in terms of stdio there is
-no problem. However if perlio is implemented on top of (say) sfio
-then mechanisms must exist to create a FILE * which can be passed
-to library code which is going to use stdio calls.
+no problem. However in other cases then mechanisms must exist to create a FILE *
+which can be passed to library code which is going to use stdio calls.
+
+The fisrt step is to add this line:
+
+ #define PERLIO_NOT_STDIO 0
+
+I<before> including any perl header files. (This will probably become the
+default at some point). That prevents "perlio.h" from attempting to
+#define stdio functions onto PerlIO functions.
+
+XS code is probably better using "typemap" if it expects FILE * arguments.
+The standard typemap will be adjusted to comprehend any changes in this area.
=over 4
Used to get a PerlIO * from a FILE *.
May need additional arguments, interface under review.
+The flags argument was meant to be used for read vs write vs read/write
+information. In hindsight it would have been better to make it a char *mode
+as in fopen/freopen.
+
=item B<PerlIO_exportFILE(f,flags)>
-Given an PerlIO * return a 'native' FILE * suitable for
+Given a PerlIO * return a 'native' FILE * suitable for
passing to code expecting to be compiled and linked with
ANSI C I<stdio.h>.
FILE *s, and associated PerlIO * should revert to original
behaviour.
-=item B<PerlIO_setlinebuf(f)>
-
-This corresponds to setlinebuf(). Use is deprecated pending
-further discussion. (Perl core uses it I<only> when "dumping";
-it has nothing to do with $| auto-flush.)
-
=back
-In addition to user API above there is an "implementation" interface
+=head2 "Fast gets" Functions
+
+In addition to standard-like API defined so far above there is an "implementation" interface
which allows perl to get at internals of PerlIO.
The following calls correspond to the various FILE_xxx macros determined
-by Configure. This section is really of interest to only those
-concerned with detailed perl-core behaviour or implementing a
-PerlIO mapping.
+by Configure - or their equivalent in other implementations. This section is really of
+interest to only those concerned with detailed perl-core behaviour, implementing a
+PerlIO mapping or writing code which can make use of the "read ahead" that has been done by
+the IO system in the same way perl does. Note that any code that uses these interfaces
+must be prepared to do things the traditional way if a handle does not support
+them.
=over 4
-=item B<PerlIO_has_cntptr(f)>
-
-Implementation can return pointer to current position in the "buffer" and
-a count of bytes available in the buffer.
+=item B<PerlIO_fast_gets(f)>
-=item B<PerlIO_get_ptr(f)>
+Returns true if implementation has all the interfaces required to
+allow perl's C<sv_gets> to "bypass" normal IO mechanism.
+This can vary from handle to handle.
-Return pointer to next readable byte in buffer.
+ PerlIO_fast_gets(f) = PerlIO_has_cntptr(f) && \
+ PerlIO_canset_cnt(f) && \
+ `Can set pointer into buffer'
-=item B<PerlIO_get_cnt(f)>
-Return count of readable bytes in the buffer.
+=item B<PerlIO_has_cntptr(f)>
-=item B<PerlIO_canset_cnt(f)>
+Implementation can return pointer to current position in the "buffer" and
+a count of bytes available in the buffer.
+Do not use this - use PerlIO_fast_gets.
-Implementation can adjust its idea of number of
-bytes in the buffer.
+=item B<PerlIO_get_cnt(f)>
-=item B<PerlIO_fast_gets(f)>
+Return count of readable bytes in the buffer. Zero or negative return means
+no more bytes available.
-Implementation has all the interfaces required to
-allow perl's fast code to handle <FILE> mechanism.
+=item B<PerlIO_get_ptr(f)>
- PerlIO_fast_gets(f) = PerlIO_has_cntptr(f) && \
- PerlIO_canset_cnt(f) && \
- `Can set pointer into buffer'
+Return pointer to next readable byte in buffer, accessing via the pointer
+(dereferencing) is only safe if PerlIO_get_cnt() has returned a positive value.
+Only positive offsets up to value returned by PerlIO_get_cnt() are allowed.
=item B<PerlIO_set_ptrcnt(f,p,c)>
Set pointer into buffer, and a count of bytes still in the
buffer. Should be used only to set
pointer to within range implied by previous calls
-to C<PerlIO_get_ptr> and C<PerlIO_get_cnt>.
+to C<PerlIO_get_ptr> and C<PerlIO_get_cnt>. The two values I<must> be consistent
+with each other (implementation may only use one or the other or may require both).
+
+=item B<PerlIO_canset_cnt(f)>
+
+Implementation can adjust its idea of number of bytes in the buffer.
+Do not use this - use PerlIO_fast_gets.
=item B<PerlIO_set_cnt(f,c)>
Obscure - set count of bytes in the buffer. Deprecated.
-Currently used in only doio.c to force count < -1 to -1.
+Only usable if PerlIO_canset_cnt() returns true.
+Currently used in only doio.c to force count less than -1 to -1.
Perhaps should be PerlIO_set_empty or similar.
This call may actually do nothing if "count" is deduced from pointer
and a "limit".
+Do not use this - use PerlIO_set_ptrcnt().
=item B<PerlIO_has_base(f)>
-Implementation has a buffer, and can return pointer
+Returns true if implementation has a buffer, and can return pointer
to whole buffer and its size. Used by perl for B<-T> / B<-B> tests.
Other uses would be very obscure...
=item B<PerlIO_get_base(f)>
-Return I<start> of buffer.
+Return I<start> of buffer. Access only positive offsets in the buffer
+up to the value returned by PerlIO_get_bufsiz().
=item B<PerlIO_get_bufsiz(f)>
-Return I<total size> of buffer.
+Return the I<total number of bytes> in the buffer, this is neither the number
+that can be read, nor the amount of memory allocated to the buffer. Rather
+it is what the operating system and/or implementation happened to C<read()>
+(or whatever) last time IO was requested.
+
+=back
+
+=head2 Other Functions
+
+=over 4
+
+=item PerlIO_apply_layers(f,mode,layers)
+
+The new interface to the USE_PERLIO implementation. The layers ":crlf"
+and ":raw" are only ones allowed for other implementations and those
+are silently ignored. Use PerlIO_binmode() below for the portable
+case.
+
+=item PerlIO_binmode(f,ptype,imode,layers)
+
+The hook used by perl's C<binmode> operator.
+B<ptype> is perl's charcter for the kind of IO:
+
+=over 8
+
+=item 'E<lt>' read
+
+=item 'E<gt>' write
+
+=item '+' read/write
+
+=back
+
+B<imode> is C<O_BINARY> or C<O_TEXT>.
+
+B<layers> is a string of layers to apply, only ":raw" or :"crlf" make
+sense in the non USE_PERLIO case.
+
+Portable cases are:
+
+ PerlIO_binmode(f,ptype,O_BINARY,":raw");
+and
+ PerlIO_binmode(f,ptype,O_TEXT,":crlf");
+
+On Unix these calls probably have no effect whatsoever.
+Elsewhere they alter "\n" to CR,LF translation and possibly cause a special
+text "end of file" indicator to be written or honoured on read. The effect of
+making the call after doing any IO to the handle depends on the implementation. (It may be
+ignored, affect any data which is already buffered as well, or only apply
+to subsequent data.)
+
+=item PerlIO_debug(fmt,...)
+
+PerlIO_debug is a printf()-like function which can be used for debugging.
+No return value. Its main use is inside PerlIO where using real printf, warn() etc. would
+recursively call PerlIO and be a problem.
+
+PerlIO_debug writes to the file named by $ENV{'PERLIO_DEBUG'} typical use
+might be
+
+ Bourne shells:
+ PERLIO_DEBUG=/dev/tty ./perl somescript some args
+
+ Csh:
+ setenv PERLIO_DEBUG /dev/tty
+ ./perl somescript some args
+
+ Win32:
+ set PERLIO_DEBUG=CON
+ perl somescript some args
+
+If $ENV{'PERLIO_DEBUG'} is not set PerlIO_debug() is a no-op.
=back
For more information, see L<perlobj> (for all the gritty details about
Perl objects, now that you've seen the basics), L<perltoot> (the
-tutorial for those who already know objects), L<perlbot> (for some
-more tricks), and books such as Damian Conway's excellent I<Object
-Oriented Perl>.
+tutorial for those who already know objects), L<perltootc> (dealing
+with class data), L<perlbot> (for some more tricks), and books such as
+Damian Conway's excellent I<Object Oriented Perl>.
+
+Some modules which might prove interesting are Class::Accessor,
+Class::Class, Class::Contract, Class::Data::Inheritable,
+Class::MethodMaker and Tie::SecureHash
=head1 COPYRIGHT
you run Perl. How to really fix the problem can be found in
L<perllocale> section B<LOCALE PROBLEMS>.
+=item perlio: argument list not closed for layer "%s"
+
+(S) When pusing a layer with arguments onto the Perl I/O system you forgot
+the ) that closes the argument list. (Layers take care of transforming
+data between external and internal representations.) Perl assumed that
+the argument list finished at the next : or the end of the layer
+specification. If your program didn't explicitly request the failing
+operation, it may be the result of the value of the environment variable
+PERLIO.
+
=item perlio: unknown layer "%s"
(S) An attempt was made to push an unknown layer onto the Perl I/O
(W newline) A file operation was attempted on a filename, and that
operation failed, PROBABLY because the filename contained a newline,
-PROBABLY because you forgot to chop() or chomp() it off. See
-L<perlfunc/chomp>.
+PROBABLY because you forgot to chomp() it off. See L<perlfunc/chomp>.
=item Unsupported directory function "%s" called
http://conference.perl.com/
http://reference.perl.com/
-Perl Mongers is an advocacy organization for the Perl language. For
-details, see the Perl Mongers web site at http://www.perlmongers.org/.
+Perl Mongers is an advocacy organization for the Perl language which
+maintains the web site http://www.perl.org/ as a general advocacy
+site for the Perl language, with many sub-domains for special topics,
+including
+
+ http://history.perl.org/
+ http://bugs.perl.org/
+ http://use.perl.org/
Perl Mongers uses the pm.org domain for services related to Perl user
-groups. See the Perl user group web site at http://www.pm.org/ for more
-information about joining, starting, or requesting services for a Perl
-user group.
+groups, including the hosting of mailing lists and web sites. See the
+Perl user group web site at http://www.pm.org/ for more information about
+joining, starting, or requesting services for a Perl user group.
-Perl Mongers also maintains the perl.org domain to provide general
-support services to the Perl community, including the hosting of mailing
-lists, web sites, and other services. The web site
-http://www.perl.org/ is a general advocacy site for the Perl language,
-and there are many other sub-domains for special topics, such as
- http://history.perl.org/
- http://bugs.perl.org/
- http://www.news.perl.org/
=head1 AUTHOR AND COPYRIGHT
# been opened on a pipe...
system("/bin/stty $stty");
$_ = <MODEM_IN>;
- chop;
+ chomp;
if ( !m/^Connected/ ) {
print STDERR "$0: cu printed `$_' instead of `Connected'\n";
}
Example:
while (<>) {
- chop;
+ chomp;
next unless -f $_; # ignore specials
#...
}
=item chop
Chops off the last character of a string and returns the character
-chopped. It's used primarily to remove the newline from the end of an
-input record, but is much more efficient than C<s/\n//> because it neither
+chopped. It is much more efficient than C<s/.$//s> because it neither
scans nor copies the string. If VARIABLE is omitted, chops C<$_>.
-Example:
-
- while (<>) {
- chop; # avoid \n on last field
- @array = split(/:/);
- #...
- }
-
If VARIABLE is a hash, it chops the hash's values, but not its keys.
-You can actually chop anything that's an lvalue, including an assignment:
-
- chop($cwd = `pwd`);
- chop($answer = <STDIN>);
+You can actually chop anything that's an lvalue, including an assignment.
If you chop a list, each element is chopped. Only the value of the
last C<chop> is returned.
open(PASSWD, '/etc/passwd');
while (<PASSWD>) {
- ($login, $passwd, $uid, $gid,
+ chomp;
+ ($login, $passwd, $uid, $gid,
$gcos, $home, $shell) = split(/:/);
#...
}
-(Note that $shell above will still have a newline on it. See L</chop>,
-L</chomp>, and L</join>.)
=item sprintf FORMAT, LIST
If no C<unimport> method can be found the call fails with a fatal error.
-See L<perlmod> for a list of standard modules and pragmas. See L<perlrun>
+See L<perlmodlib> for a list of standard modules and pragmas. See L<perlrun>
for the C<-M> and C<-m> command-line options to perl that give C<use>
functionality from the command-line.
Here is a handy table of equivalents between ordinary C and Perl's
memory abstraction layer:
- Instead Of: Use:
-
- t* p = malloc(n) New(id, p, n, t)
- t* p = calloc(n, s) Newz(id, p, n, t)
- p = realloc(p, n) Renew(p, n, t)
- memcpy(dst, src, n) Copy(src, dst, n, t)
- memmove(dst, src, n) Move(src, dst, n, t)
- free(p) Safefree(p)
- strdup(p) savepv(p)
- strndup(p, n) savepvn(p, n) (Hey, strndup doesn't exist!)
- memcpy/*(struct foo *) StructCopy(src, dst, t)
-
- t type
- p pointer
- ck cookie for the memory region (now unused)
- n number of elements
+ Instead Of: Use:
+
+ t* p = malloc(n) New(id, p, n, t)
+ t* p = calloc(n, s) Newz(id, p, n, t)
+ p = realloc(p, n) Renew(p, n, t)
+ memcpy(dst, src, n) Copy(src, dst, n, t)
+ memmove(dst, src, n) Move(src, dst, n, t)
+ free(p) Safefree(p)
+ strdup(p) savepv(p)
+ strndup(p, n) savepvn(p, n) (Hey, strndup doesn't exist!)
+ memcpy/*(struct foo *) StructCopy(src, dst, t)
+
+ t type
+ p pointer
+ ck cookie for the memory region (now unused)
+ n number of elements
src source pointer
dst destination pointer
something like this:
ifdef PERL_IMPLICIT_CONTEXT
- define sv_setsv(a,b) Perl_sv_setsv(aTHX_ a, b)
+ define sv_setsv(a,b) Perl_sv_setsv(aTHX_ a, b)
/* can't do this for vararg functions, see below */
else
- define sv_setsv Perl_sv_setsv
+ define sv_setsv Perl_sv_setsv
endif
This works well, and means that XS authors can gleefully write:
The second, more efficient way is to use the following template for
your Foo.xs:
- #define PERL_NO_GET_CONTEXT /* we want efficiency */
- #include "EXTERN.h"
- #include "perl.h"
- #include "XSUB.h"
+ #define PERL_NO_GET_CONTEXT /* we want efficiency */
+ #include "EXTERN.h"
+ #include "perl.h"
+ #include "XSUB.h"
static my_private_function(int arg1, int arg2);
- static SV *
- my_private_function(int arg1, int arg2)
- {
- dTHX; /* fetch context */
- ... call many Perl API functions ...
- }
+ static SV *
+ my_private_function(int arg1, int arg2)
+ {
+ dTHX; /* fetch context */
+ ... call many Perl API functions ...
+ }
[... etc ...]
- MODULE = Foo PACKAGE = Foo
+ MODULE = Foo PACKAGE = Foo
- /* typical XSUB */
+ /* typical XSUB */
- void
- my_xsub(arg)
- int arg
- CODE:
- my_private_function(arg, 10);
+ void
+ my_xsub(arg)
+ int arg
+ CODE:
+ my_private_function(arg, 10);
Note that the only two changes from the normal way of writing an
extension is the addition of a C<#define PERL_NO_GET_CONTEXT> before
the Perl guts:
- #define PERL_NO_GET_CONTEXT /* we want efficiency */
- #include "EXTERN.h"
- #include "perl.h"
- #include "XSUB.h"
+ #define PERL_NO_GET_CONTEXT /* we want efficiency */
+ #include "EXTERN.h"
+ #include "perl.h"
+ #include "XSUB.h"
/* pTHX_ only needed for functions that call Perl API */
static my_private_function(pTHX_ int arg1, int arg2);
- static SV *
- my_private_function(pTHX_ int arg1, int arg2)
- {
- /* dTHX; not needed here, because THX is an argument */
- ... call Perl API functions ...
- }
+ static SV *
+ my_private_function(pTHX_ int arg1, int arg2)
+ {
+ /* dTHX; not needed here, because THX is an argument */
+ ... call Perl API functions ...
+ }
[... etc ...]
- MODULE = Foo PACKAGE = Foo
+ MODULE = Foo PACKAGE = Foo
- /* typical XSUB */
+ /* typical XSUB */
- void
- my_xsub(arg)
- int arg
- CODE:
- my_private_function(aTHX_ arg, 10);
+ void
+ my_xsub(arg)
+ int arg
+ CODE:
+ my_private_function(aTHX_ arg, 10);
This implementation never has to fetch the context using a function
call, since it is always passed as an extra argument. Depending on
formatting codes like C<%d>, C<%ld>, C<%f>, you should use the
following macros for portability
- IVdf IV in decimal
- UVuf UV in decimal
- UVof UV in octal
- UVxf UV in hexadecimal
- NVef NV %e-like
- NVff NV %f-like
- NVgf NV %g-like
+ IVdf IV in decimal
+ UVuf UV in decimal
+ UVof UV in octal
+ UVxf UV in hexadecimal
+ NVef NV %e-like
+ NVff NV %f-like
+ NVgf NV %g-like
These will take care of 64-bit integers and long doubles.
For example:
- printf("IV is %"IVdf"\n", iv);
+ printf("IV is %"IVdf"\n", iv);
The IVdf will expand to whatever is the correct format for the IVs.
Because pointer size does not necessarily equal integer size,
use the follow macros to do it right.
- PTR2UV(pointer)
- PTR2IV(pointer)
- PTR2NV(pointer)
- INT2PTR(pointertotype, integer)
+ PTR2UV(pointer)
+ PTR2IV(pointer)
+ PTR2NV(pointer)
+ INT2PTR(pointertotype, integer)
For example:
- IV iv = ...;
- SV *sv = INT2PTR(SV*, iv);
+ IV iv = ...;
+ SV *sv = INT2PTR(SV*, iv);
and
- AV *av = ...;
- UV uv = PTR2UV(av);
+ AV *av = ...;
+ UV uv = PTR2UV(av);
=head2 Source Documentation
=for hackers
Found in file pp.h
+=item PL_DBsingle
+
+When Perl is run in debugging mode, with the B<-d> switch, this SV is a
+boolean which indicates whether subs are being single-stepped.
+Single-stepping is automatically turned on after every step. This is the C
+variable which corresponds to Perl's $DB::single variable. See
+C<PL_DBsub>.
+
+ SV * PL_DBsingle
+
+=for hackers
+Found in file intrpvar.h
+
+=item PL_DBsub
+
+When Perl is run in debugging mode, with the B<-d> switch, this GV contains
+the SV which holds the name of the sub being debugged. This is the C
+variable which corresponds to Perl's $DB::sub variable. See
+C<PL_DBsingle>.
+
+ GV * PL_DBsub
+
+=for hackers
+Found in file intrpvar.h
+
+=item PL_DBtrace
+
+Trace variable used when Perl is run in debugging mode, with the B<-d>
+switch. This is the C variable which corresponds to Perl's $DB::trace
+variable. See C<PL_DBsingle>.
+
+ SV * PL_DBtrace
+
+=for hackers
+Found in file intrpvar.h
+
+=item PL_dowarn
+
+The C variable which corresponds to Perl's $^W warning variable.
+
+ bool PL_dowarn
+
+=for hackers
+Found in file intrpvar.h
+
+=item PL_last_in_gv
+
+The GV which was last used for a filehandle input operation. (C<< <FH> >>)
+
+ GV* PL_last_in_gv
+
+=for hackers
+Found in file thrdvar.h
+
+=item PL_ofs_sv
+
+The output field separator - C<$,> in Perl space.
+
+ SV* PL_ofs_sv
+
+=for hackers
+Found in file thrdvar.h
+
+=item PL_rs
+
+The input record separator - C<$/> in Perl space.
+
+ SV* PL_rs
+
+=for hackers
+Found in file thrdvar.h
+
=item start_glob
Function called by C<do_readline> to spawn a glob (or do the glob inside
--- /dev/null
+
+=head1 NAME
+
+perliol - C API for Perl's implementation of IO in Layers.
+
+=head1 SYNOPSIS
+
+ /* Defining a layer ... */
+ #include <perliol.h>
+
+
+=head1 DESCRIPTION
+
+This document describes the behavior and implementation of the PerlIO
+abstraction described in L<perlapio> when C<USE_PERLIO> is defined (and
+C<USE_SFIO> is not).
+
+=head2 History and Background
+
+The PerlIO abstraction was introduced in perl5.003_02 but languished as
+just an abstraction until perl5.7.0. However during that time a number
+of perl extentions switched to using it, so the API is mostly fixed to
+maintain (source) compatibility.
+
+The aim of the implementation is to provide the PerlIO API in a flexible
+and platform neutral manner. It is also a trial of an "Object Oriented
+C, with vtables" approach which may be applied to perl6.
+
+=head2 Layers vs Disciplines
+
+Initial discussion of the ability to modify IO streams behaviour used
+the term "discipline" for the entities which were added. This came (I
+believe) from the use of the term in "sfio", which in turn borrowed it
+from "line disciplines" on Unix terminals. However, this document (and
+the C code) uses the term "layer".
+
+This is, I hope, a natural term given the implementation, and should avoid
+connotations that are inherent in earlier uses of "discipline" for things
+which are rather different.
+
+=head2 Data Structures
+
+The basic data structure is a PerlIOl:
+
+ typedef struct _PerlIO PerlIOl;
+ typedef struct _PerlIO_funcs PerlIO_funcs;
+ typedef PerlIOl *PerlIO;
+
+ struct _PerlIO
+ {
+ PerlIOl * next; /* Lower layer */
+ PerlIO_funcs * tab; /* Functions for this layer */
+ IV flags; /* Various flags for state */
+ };
+
+A C<PerlIOl *> is a pointer to to the struct, and the I<application> level
+C<PerlIO *> is a pointer to a C<PerlIOl *> - i.e. a pointer to a pointer to
+the struct. This allows the application level C<PerlIO *> to remain
+constant while the actual C<PerlIOl *> underneath changes. (Compare perl's
+C<SV *> which remains constant while its C<sv_any> field changes as the
+scalar's type changes.) An IO stream is then in general represented as a
+pointer to this linked-list of "layers".
+
+It should be noted that because of the double indirection in a C<PerlIO *>,
+a C<< &(perlio-E<gt>next) >> "is" a C<PerlIO *>, and so to some degree
+at least one layer can use the "standard" API on the next layer down.
+
+A "layer" is composed of two parts:
+
+=over 4
+
+=item 1. The functions and attributes of the "layer class".
+
+=item 2. The per-instance data for a particular handle.
+
+=back
+
+=head2 Functions and Attributes
+
+The functions and attributes are accessed via the "tab" (for table)
+member of C<PerlIOl>. The functions (methods of the layer "class") are
+fixed, and are defined by the C<PerlIO_funcs> type. They are broadly the
+same as the public C<PerlIO_xxxxx> functions:
+
+ struct _PerlIO_funcs
+ {
+ char * name;
+ Size_t size;
+ IV kind;
+ IV (*Fileno)(PerlIO *f);
+ PerlIO * (*Fdopen)(PerlIO_funcs *tab, int fd, const char *mode);
+ PerlIO * (*Open)(PerlIO_funcs *tab, const char *path, const char *mode);
+ int (*Reopen)(const char *path, const char *mode, PerlIO *f);
+ IV (*Pushed)(PerlIO *f,const char *mode,const char *arg,STRLEN len);
+ IV (*Popped)(PerlIO *f);
+ /* Unix-like functions - cf sfio line disciplines */
+ SSize_t (*Read)(PerlIO *f, void *vbuf, Size_t count);
+ SSize_t (*Unread)(PerlIO *f, const void *vbuf, Size_t count);
+ SSize_t (*Write)(PerlIO *f, const void *vbuf, Size_t count);
+ IV (*Seek)(PerlIO *f, Off_t offset, int whence);
+ Off_t (*Tell)(PerlIO *f);
+ IV (*Close)(PerlIO *f);
+ /* Stdio-like buffered IO functions */
+ IV (*Flush)(PerlIO *f);
+ IV (*Fill)(PerlIO *f);
+ IV (*Eof)(PerlIO *f);
+ IV (*Error)(PerlIO *f);
+ void (*Clearerr)(PerlIO *f);
+ void (*Setlinebuf)(PerlIO *f);
+ /* Perl's snooping functions */
+ STDCHAR * (*Get_base)(PerlIO *f);
+ Size_t (*Get_bufsiz)(PerlIO *f);
+ STDCHAR * (*Get_ptr)(PerlIO *f);
+ SSize_t (*Get_cnt)(PerlIO *f);
+ void (*Set_ptrcnt)(PerlIO *f,STDCHAR *ptr,SSize_t cnt);
+ };
+
+The first few members of the struct give a "name" for the layer, the
+size to C<malloc> for the per-instance data, and some flags which are
+attributes of the class as whole (such as whether it is a buffering
+layer), then follow the functions which fall into four basic groups:
+
+=over 4
+
+=item 1. Opening and setup functions
+
+=item 2. Basic IO operations
+
+=item 3. Stdio class buffering options.
+
+=item 4. Functions to support Perl's traditional "fast" access to the buffer.
+
+=back
+
+A layer does not have to implement all the functions, but the whole table has
+to be present. Unimplemented slots can be NULL (which will will result in an error
+when called) or can be filled in with stubs to "inherit" behaviour from
+a "base class". This "inheritance" is fixed for all instances of the layer,
+but as the layer chooses which stubs to populate the table, limited
+"multiple inheritance" is possible.
+
+=head2 Per-instance Data
+
+The per-instance data are held in memory beyond the basic PerlIOl struct,
+by making a PerlIOl the first member of the layer's struct thus:
+
+ typedef struct
+ {
+ struct _PerlIO base; /* Base "class" info */
+ STDCHAR * buf; /* Start of buffer */
+ STDCHAR * end; /* End of valid part of buffer */
+ STDCHAR * ptr; /* Current position in buffer */
+ Off_t posn; /* Offset of buf into the file */
+ Size_t bufsiz; /* Real size of buffer */
+ IV oneword; /* Emergency buffer */
+ } PerlIOBuf;
+
+In this way (as for perl's scalars) a pointer to a PerlIOBuf can be treated
+as a pointer to a PerlIOl.
+
+=head2 Layers in action.
+
+ table perlio unix
+ | |
+ +-----------+ +----------+ +--------+
+ PerlIO ->| |--->| next |--->| NULL |
+ +-----------+ +----------+ +--------+
+ | | | buffer | | fd |
+ +-----------+ | | +--------+
+ | | +----------+
+
+
+The above attempts to show how the layer scheme works in a simple case.
+The application's C<PerlIO *> points to an entry in the table(s)
+representing open (allocated) handles. For example the first three slots
+in the table correspond to C<stdin>,C<stdout> and C<stderr>. The table
+in turn points to the current "top" layer for the handle - in this case
+an instance of the generic buffering layer "perlio". That layer in turn
+points to the next layer down - in this case the lowlevel "unix" layer.
+
+The above is roughly equivalent to a "stdio" buffered stream, but with
+much more flexibility:
+
+=over 4
+
+=item *
+
+If Unix level C<read>/C<write>/C<lseek> is not appropriate for (say)
+sockets then the "unix" layer can be replaced (at open time or even
+dynamically) with a "socket" layer.
+
+=item *
+
+Different handles can have different buffering schemes. The "top" layer
+could be the "mmap" layer if reading disk files was quicker using C<mmap>
+than C<read>. An "unbuffered" stream can be implemented simply by
+not having a buffer layer.
+
+=item *
+
+Extra layers can be inserted to process the data as it flows through.
+This was the driving need for including the scheme in perl 5.7.0+ - we
+needed a mechanism to allow data to be translated bewteen perl's
+internal encoding (conceptually at least Unicode as UTF-8), and the
+"native" format used by the system. This is provided by the
+":encoding(xxxx)" layer which typically sits above the buffering layer.
+
+=item *
+
+A layer can be added that does "\n" to CRLF translation. This layer can be used
+on any platform, not just those that normally do such things.
+
+=back
+
+=head2 Per-instance flag bits
+
+The generic flag bits are a hybrid of C<O_XXXXX> style flags deduced from
+the mode string passed to C<PerlIO_open()>, and state bits for typical buffer
+layers.
+
+=over 4
+
+=item PERLIO_F_EOF
+
+End of file.
+
+=item PERLIO_F_CANWRITE
+
+Writes are permitted, i.e. opened as "w" or "r+" or "a", etc.
+
+=item PERLIO_F_CANREAD
+
+Reads are permitted i.e. opened "r" or "w+" (or even "a+" - ick).
+
+=item PERLIO_F_ERROR
+
+An error has occured (for C<PerlIO_error()>)
+
+=item PERLIO_F_TRUNCATE
+
+Truncate file suggested by open mode.
+
+=item PERLIO_F_APPEND
+
+All writes should be appends.
+
+=item PERLIO_F_CRLF
+
+Layer is performing Win32-like "\n" mapped to CR,LF for output and CR,LF
+mapped to "\n" for input. Normally the provided "crlf" layer is the only
+layer that need bother about this. C<PerlIO_binmode()> will mess with this
+flag rather than add/remove layers if the C<PERLIO_K_CANCRLF> bit is set
+for the layers class.
+
+=item PERLIO_F_UTF8
+
+Data written to this layer should be UTF-8 encoded; data provided
+by this layer should be considered UTF-8 encoded. Can be set on any layer
+by ":utf8" dummy layer. Also set on ":encoding" layer.
+
+=item PERLIO_F_UNBUF
+
+Layer is unbuffered - i.e. write to next layer down should occur for
+each write to this layer.
+
+=item PERLIO_F_WRBUF
+
+The buffer for this layer currently holds data written to it but not sent
+to next layer.
+
+=item PERLIO_F_RDBUF
+
+The buffer for this layer currently holds unconsumed data read from
+layer below.
+
+=item PERLIO_F_LINEBUF
+
+Layer is line buffered. Write data should be passed to next layer down
+whenever a "\n" is seen. Any data beyond the "\n" should then be
+processed.
+
+=item PERLIO_F_TEMP
+
+File has been C<unlink()>ed, or should be deleted on C<close()>.
+
+=item PERLIO_F_OPEN
+
+Handle is open.
+
+=item PERLIO_F_FASTGETS
+
+This instance of this layer supports the "fast C<gets>" interface.
+Normally set based on C<PERLIO_K_FASTGETS> for the class and by the
+existance of the function(s) in the table. However a class that
+normally provides that interface may need to avoid it on a
+particular instance. The "pending" layer needs to do this when
+it is pushed above an layer which does not support the interface.
+(Perl's C<sv_gets()> does not expect the streams fast C<gets> behaviour
+to change during one "get".)
+
+=back
+
+=head2 Methods in Detail
+
+=over 4
+
+=item IV (*Fileno)(PerlIO *f);
+
+Returns the Unix/Posix numeric file decriptor for the handle. Normally
+C<PerlIOBase_fileno()> (which just asks next layer down) will suffice
+for this.
+
+=item PerlIO * (*Fdopen)(PerlIO_funcs *tab, int fd, const char *mode);
+
+Should (perhaps indirectly) call C<PerlIO_allocate()> to allocate a slot
+in the table and associate it with the given numeric file descriptor,
+which will be open in an manner compatible with the supplied mode string.
+
+=item PerlIO * (*Open)(PerlIO_funcs *tab, const char *path, const char *mode);
+
+Should attempt to open the given path and if that succeeds then (perhaps
+indirectly) call C<PerlIO_allocate()> to allocate a slot in the table and
+associate it with the layers information for the opened file.
+
+=item int (*Reopen)(const char *path, const char *mode, PerlIO *f);
+
+Re-open the supplied C<PerlIO *> to connect it to C<path> in C<mode>.
+Returns as success flag. Perl does not use this and L<perlapio> marks it
+as subject to change.
+
+=item IV (*Pushed)(PerlIO *f,const char *mode,const char *arg,STRLEN len);
+
+Called when the layer is pushed onto the stack. The C<mode> argument may
+be NULL if this occurs post-open. The C<arg> and C<len> will be present
+if an argument string was passed. In most cases this should call
+C<PerlIOBase_pushed()> to convert C<mode> into the appropriate
+C<PERLIO_F_XXXXX> flags in addition to any actions the layer itself takes.
+
+=item IV (*Popped)(PerlIO *f);
+
+Called when the layer is popped from the stack. A layer will normally be
+popped after C<Close()> is called. But a layer can be popped without being
+closed if the program is dynamically managing layers on the stream. In
+such cases C<Popped()> should free any resources (buffers, translation
+tables, ...) not held directly in the layer's struct.
+
+=item SSize_t (*Read)(PerlIO *f, void *vbuf, Size_t count);
+
+Basic read operation. Returns actual bytes read, or -1 on an error.
+Typically will call Fill and manipulate pointers (possibly via the API).
+C<PerlIOBuf_read()> may be suitable for derived classes which provide
+"fast gets" methods.
+
+=item SSize_t (*Unread)(PerlIO *f, const void *vbuf, Size_t count);
+
+A superset of stdio's C<ungetc()>. Should arrange for future reads to
+see the bytes in C<vbuf>. If there is no obviously better implementation
+then C<PerlIOBase_unread()> provides the function by pushing a "fake"
+"pending" layer above the calling layer.
+
+=item SSize_t (*Write)(PerlIO *f, const void *vbuf, Size_t count);
+
+Basic write operation. Returns bytes written or -1 on an error.
+
+=item IV (*Seek)(PerlIO *f, Off_t offset, int whence);
+
+Position the file pointer. Should normally call its own C<Flush> method and
+then the C<Seek> method of next layer down.
+
+=item Off_t (*Tell)(PerlIO *f);
+
+Return the file pointer. May be based on layers cached concept of
+position to avoid overhead.
+
+=item IV (*Close)(PerlIO *f);
+
+Close the stream. Should normally call C<PerlIOBase_close()> to flush
+itself and close layers below, and then deallocate any data structures
+(buffers, translation tables, ...) not held directly in the data
+structure.
+
+=item IV (*Flush)(PerlIO *f);
+
+Should make stream's state consistent with layers below. That is, any
+buffered write data should be written, and file position of lower layers
+adjusted for data read fron below but not actually consumed.
+
+=item IV (*Fill)(PerlIO *f);
+
+The buffer for this layer should be filled (for read) from layer below.
+
+=item IV (*Eof)(PerlIO *f);
+
+Return end-of-file indicator. C<PerlIOBase_eof()> is normally sufficient.
+
+=item IV (*Error)(PerlIO *f);
+
+Return error indicator. C<PerlIOBase_error()> is normally sufficient.
+
+=item void (*Clearerr)(PerlIO *f);
+
+Clear end-of-file and error indicators. Should call C<PerlIOBase_clearerr()>
+to set the C<PERLIO_F_XXXXX> flags, which may suffice.
+
+=item void (*Setlinebuf)(PerlIO *f);
+
+Mark the stream as line buffered.
+
+=item STDCHAR * (*Get_base)(PerlIO *f);
+
+Allocate (if not already done so) the read buffer for this layer and
+return pointer to it.
+
+=item Size_t (*Get_bufsiz)(PerlIO *f);
+
+Return the number of bytes that last C<Fill()> put in the buffer.
+
+=item STDCHAR * (*Get_ptr)(PerlIO *f);
+
+Return the current read pointer relative to this layer's buffer.
+
+=item SSize_t (*Get_cnt)(PerlIO *f);
+
+Return the number of bytes left to be read in the current buffer.
+
+=item void (*Set_ptrcnt)(PerlIO *f,STDCHAR *ptr,SSize_t cnt);
+
+Adjust the read pointer and count of bytes to match C<ptr> and/or C<cnt>.
+The application (or layer above) must ensure they are consistent.
+(Checking is allowed by the paranoid.)
+
+=back
+
+
+=head2 Core Layers
+
+The file C<perlio.c> provides the following layers:
+
+=over 4
+
+=item "unix"
+
+A basic non-buffered layer which calls Unix/POSIX C<read()>, C<write()>,
+C<lseek()>, C<close()>. No buffering. Even on platforms that distinguish
+between O_TEXT and O_BINARY this layer is always O_BINARY.
+
+=item "perlio"
+
+A very complete generic buffering layer which provides the whole of
+PerlIO API. It is also intended to be used as a "base class" for other
+layers. (For example its C<Read()> method is implemented in terms of the
+C<Get_cnt()>/C<Get_ptr()>/C<Set_ptrcnt()> methods).
+
+"perlio" over "unix" provides a complete replacement for stdio as seen
+via PerlIO API. This is the default for USE_PERLIO when system's stdio
+does not permit perl's "fast gets" access, and which do not distinguish
+between C<O_TEXT> and C<O_BINARY>.
+
+=item "stdio"
+
+A layer which provides the PerlIO API via the layer scheme, but
+implements it by calling system's stdio. This is (currently) the default
+if system's stdio provides sufficient access to allow perl's "fast gets"
+access and which do not distinguish between C<O_TEXT> and C<O_BINARY>.
+
+=item "crlf"
+
+A layer derived using "perlio" as a base class. It provides Win32-like
+"\n" to CR,LF translation. Can either be applied above "perlio" or serve
+as the buffer layer itself. "crlf" over "unix" is the default if system
+distinguishes between C<O_TEXT> and C<O_BINARY> opens. (At some point
+"unix" will be replaced by a "native" Win32 IO layer on that platform,
+as Win32's read/write layer has various drawbacks.) The "crlf" layer is
+a reasonable model for a layer which transforms data in some way.
+
+=item "mmap"
+
+If Configure detects C<mmap()> functions this layer is provided (with
+"perlio" as a "base") which does "read" operations by mmap()ing the
+file. Performance improvement is marginal on modern systems, so it is
+mainly there as a proof of concept. It is likely to be unbundled from
+the core at some point. The "mmap" layer is a reasonable model for a
+minimalist "derived" layer.
+
+=item "pending"
+
+An "internal" derivative of "perlio" which can be used to provide
+Unread() function for layers which have no buffer or cannot be bothered.
+(Basically this layer's C<Fill()> pops itself off the stack and so resumes
+reading from layer below.)
+
+=item "raw"
+
+A dummy layer which never exists on the layer stack. Instead when
+"pushed" it actually pops the stack(!), removing itself, and any other
+layers until it reaches a layer with the class C<PERLIO_K_RAW> bit set.
+
+=item "utf8"
+
+Another dummy layer. When pushed it pops itself and sets the
+C<PERLIO_F_UTF8> flag on the layer which was (and now is once more) the top
+of the stack.
+
+=back
+
+In addition F<perlio.c> also provides a number of C<PerlIOBase_xxxx()>
+functions which are intended to be used in the table slots of classes
+which do not need to do anything special for a particular method.
+
+=head2 Extension Layers
+
+Layers can made available by extension modules.
+
+=over 4
+
+=item "encoding"
+
+ use Encoding;
+
+makes this layer available. It is an example of a layer which takes an argument.
+as it is called as:
+
+ open($fh,"<:encoding(iso-8859-7)",$pathname)
+
+=back
+
+
+=cut
+
+
+
}
print OUT <<'EOF';
+# Generated by perlmodlib.PL DO NOT EDIT!
+
=head1 NAME
perlmodlib - constructing new Perl modules and finding existing ones
=over
=item *
+
Language Extensions and Documentation Tools
=item *
+
Development Support
=item *
+
Operating System Interfaces
=item *
+
Networking, Device Control (modems) and InterProcess Communication
=item *
+
Data Types and Data Type Utilities
=item *
+
Database Interfaces
=item *
+
User Interfaces
=item *
+
Interfaces to / Emulations of Other Programming Languages
=item *
+
File Names, File Systems and File Locking (see also File Handles)
=item *
+
String Processing, Language Text Processing, Parsing, and Searching
=item *
+
Option, Argument, Parameter, and Configuration File Processing
=item *
+
Internationalization and Locale
=item *
+
Authentication, Security, and Encryption
=item *
+
World Wide Web, HTML, HTTP, CGI, MIME
=item *
+
Server and Daemon Utilities
=item *
+
Archiving and Compression
=item *
+
Images, Pixmap and Bitmap Manipulation, Drawing, and Graphing
=item *
+
Mail and Usenet News
=item *
+
Control Flow Utilities (callbacks and exceptions etc)
=item *
+
File Handle and Input/Output Stream Utilities
=item *
+
Miscellaneous Modules
=back
=item Africa
- South Africa ftp://ftp.is.co.za/programming/perl/CPAN/
- ftp://ftp.saix.net/pub/CPAN/
- ftp://ftp.sun.ac.za/CPAN/
- ftp://ftpza.co.za/pub/mirrors/cpan/
-
+ South Africa ftp://ftp.is.co.za/programming/perl/CPAN/
+ ftp://ftp.saix.net/pub/CPAN/
+ ftp://ftpza.co.za/pub/mirrors/cpan/
+ ftp://ftp.sun.ac.za/CPAN/
=item Asia
- China ftp://freesoft.cei.gov.cn/pub/languages/perl/CPAN/
- Hong Kong ftp://ftp.pacific.net.hk/pub/mirror/CPAN/
- Indonesia ftp://malone.piksi.itb.ac.id/pub/CPAN/
- Israel ftp://bioinfo.weizmann.ac.il/pub/software/perl/CPAN/
- Japan ftp://ftp.dti.ad.jp/pub/lang/CPAN/
- ftp://ftp.jaist.ac.jp/pub/lang/perl/CPAN/
- ftp://ftp.lab.kdd.co.jp/lang/perl/CPAN/
- ftp://ftp.meisei-u.ac.jp/pub/CPAN/
- ftp://ftp.ring.gr.jp/pub/lang/perl/CPAN/
- ftp://mirror.nucba.ac.jp/mirror/Perl/
- Saudi-Arabia ftp://ftp.isu.net.sa/pub/CPAN/
- Singapore ftp://ftp.nus.edu.sg/pub/unix/perl/CPAN/
- South Korea ftp://ftp.bora.net/pub/CPAN/
- ftp://ftp.kornet.net/pub/CPAN/
- ftp://ftp.nuri.net/pub/CPAN/
- Taiwan ftp://coda.nctu.edu.tw/computer-languages/perl/CPAN/
- ftp://ftp.ee.ncku.edu.tw/pub3/perl/CPAN/
- ftp://ftp1.sinica.edu.tw/pub1/perl/CPAN/
- Thailand ftp://ftp.nectec.or.th/pub/mirrors/CPAN/
-
-
-=item Australasia
-
- Australia ftp://cpan.topend.com.au/pub/CPAN/
- ftp://ftp.labyrinth.net.au/pub/perl-CPAN/
- ftp://ftp.sage-au.org.au/pub/compilers/perl/CPAN/
- ftp://mirror.aarnet.edu.au/pub/perl/CPAN/
- New Zealand ftp://ftp.auckland.ac.nz/pub/perl/CPAN/
- ftp://sunsite.net.nz/pub/languages/perl/CPAN/
-
+ China ftp://freesoft.cei.gov.cn/pub/languages/perl/CPAN/
+ http://www2.linuxforum.net/mirror/CPAN/
+ Hong Kong http://CPAN.pacific.net.hk/
+ ftp://ftp.pacific.net.hk/pub/mirror/CPAN/
+ Indonesia http://piksi.itb.ac.id/CPAN/
+ ftp://mirrors.piksi.itb.ac.id/CPAN/
+ http://CPAN.mweb.co.id/
+ ftp://ftp.mweb.co.id/pub/languages/perl/CPAN/
+ Israel http://www.iglu.org.il:/pub/CPAN/
+ ftp://ftp.iglu.org.il/pub/CPAN/
+ http://bioinfo.weizmann.ac.il/pub/software/perl/CPAN/
+ ftp://bioinfo.weizmann.ac.il/pub/software/perl/CPAN/
+ Japan ftp://ftp.u-aizu.ac.jp/pub/lang/perl/CPAN/
+ ftp://ftp.kddlabs.co.jp/CPAN/
+ http://mirror.nucba.ac.jp/mirror/Perl/
+ ftp://mirror.nucba.ac.jp/mirror/Perl/
+ ftp://ftp.meisei-u.ac.jp/pub/CPAN/
+ ftp://ftp.jaist.ac.jp/pub/lang/perl/CPAN/
+ ftp://ftp.dti.ad.jp/pub/lang/CPAN/
+ ftp://ftp.ring.gr.jp/pub/lang/perl/CPAN/
+ Saudi Arabia ftp://ftp.isu.net.sa/pub/CPAN/
+ Singapore http://ftp.nus.edu.sg/unix/perl/CPAN/
+ ftp://ftp.nus.edu.sg/pub/unix/perl/CPAN/
+ South Korea http://CPAN.bora.net/
+ ftp://ftp.bora.net/pub/CPAN/
+ http://ftp.kornet.net/CPAN/
+ ftp://ftp.kornet.net/pub/CPAN/
+ ftp://ftp.nuri.net/pub/CPAN/
+ Taiwan ftp://coda.nctu.edu.tw/computer-languages/perl/CPAN/
+ ftp://ftp.ee.ncku.edu.tw/pub/perl/CPAN/
+ ftp://ftp1.sinica.edu.tw/pub1/perl/CPAN/
+ Thailand http://download.nectec.or.th/CPAN/
+ ftp://ftp.nectec.or.th/pub/languages/CPAN/
+ ftp://ftp.cs.riubon.ac.th/pub/mirrors/CPAN/
=item Central America
- Costa Rica ftp://ftp.ucr.ac.cr/pub/Unix/CPAN/
-
+ Costa Rica ftp://ftp.linux.co.cr/mirrors/CPAN/
+ http://ftp.ucr.ac.cr/Unix/CPAN/
+ ftp://ftp.ucr.ac.cr/pub/Unix/CPAN/
=item Europe
- Austria ftp://ftp.tuwien.ac.at/pub/languages/perl/CPAN/
- Belgium ftp://ftp.kulnet.kuleuven.ac.be/pub/mirror/CPAN/
- Bulgaria ftp://ftp.ntrl.net/pub/mirrors/CPAN/
- Croatia ftp://ftp.linux.hr/pub/CPAN/
- Czech Republic ftp://ftp.fi.muni.cz/pub/perl/
- ftp://sunsite.mff.cuni.cz/Languages/Perl/CPAN/
- Denmark ftp://sunsite.auc.dk/pub/languages/perl/CPAN/
- Estonia ftp://ftp.ut.ee/pub/languages/perl/CPAN/
- Finland ftp://ftp.funet.fi/pub/languages/perl/CPAN/
- France ftp://ftp.grolier.fr/pub/perl/CPAN/
- ftp://ftp.lip6.fr/pub/perl/CPAN/
- ftp://ftp.oleane.net/pub/mirrors/CPAN/
- ftp://ftp.pasteur.fr/pub/computing/CPAN/
- ftp://ftp.uvsq.fr/pub/perl/CPAN/
- German ftp://ftp.gigabell.net/pub/CPAN/
- Germany ftp://ftp.archive.de.uu.net/pub/CPAN/
- ftp://ftp.freenet.de/pub/ftp.cpan.org/pub/
- ftp://ftp.gmd.de/packages/CPAN/
- ftp://ftp.gwdg.de/pub/languages/perl/CPAN/
-
-ftp://ftp.leo.org/pub/comp/general/programming/languages/script/perl/CPAN/
- ftp://ftp.mpi-sb.mpg.de/pub/perl/CPAN/
- ftp://ftp.rz.ruhr-uni-bochum.de/pub/CPAN/
- ftp://ftp.uni-erlangen.de/pub/source/CPAN/
- ftp://ftp.uni-hamburg.de/pub/soft/lang/perl/CPAN/
- Germany ftp://ftp.archive.de.uu.net/pub/CPAN/
- ftp://ftp.freenet.de/pub/ftp.cpan.org/pub/
- ftp://ftp.gmd.de/packages/CPAN/
- ftp://ftp.gwdg.de/pub/languages/perl/CPAN/
-
-ftp://ftp.leo.org/pub/comp/general/programming/languages/script/perl/CPAN/
- ftp://ftp.mpi-sb.mpg.de/pub/perl/CPAN/
- ftp://ftp.rz.ruhr-uni-bochum.de/pub/CPAN/
- ftp://ftp.uni-erlangen.de/pub/source/CPAN/
- ftp://ftp.uni-hamburg.de/pub/soft/lang/perl/CPAN/
- Greece ftp://ftp.ntua.gr/pub/lang/perl/
- Hungary ftp://ftp.kfki.hu/pub/packages/perl/CPAN/
- Iceland ftp://ftp.gm.is/pub/CPAN/
- Ireland ftp://cpan.indigo.ie/pub/CPAN/
- ftp://sunsite.compapp.dcu.ie/pub/perl/
- Italy ftp://cis.uniRoma2.it/CPAN/
- ftp://ftp.flashnet.it/pub/CPAN/
- ftp://ftp.unina.it/pub/Other/CPAN/
- ftp://ftp.unipi.it/pub/mirror/perl/CPAN/
- Netherlands ftp://ftp.cs.uu.nl/mirror/CPAN/
- ftp://ftp.nluug.nl/pub/languages/perl/CPAN/
- Norway ftp://ftp.uit.no/pub/languages/perl/cpan/
- ftp://sunsite.uio.no/pub/languages/perl/CPAN/
- Poland ftp://ftp.man.torun.pl/pub/CPAN/
- ftp://ftp.pk.edu.pl/pub/lang/perl/CPAN/
- ftp://sunsite.icm.edu.pl/pub/CPAN/
- Portugal ftp://ftp.ci.uminho.pt/pub/mirrors/cpan/
- ftp://ftp.ist.utl.pt/pub/CPAN/
- ftp://ftp.ua.pt/pub/CPAN/
- Romania ftp://ftp.dnttm.ro/pub/CPAN/
- Russia ftp://ftp.chg.ru/pub/lang/perl/CPAN/
- ftp://ftp.sai.msu.su/pub/lang/perl/CPAN/
- Slovakia ftp://ftp.entry.sk/pub/languages/perl/CPAN/
- Slovenia ftp://ftp.arnes.si/software/perl/CPAN/
- Spain ftp://ftp.etse.urv.es/pub/perl/
- ftp://ftp.rediris.es/mirror/CPAN/
- Sweden ftp://ftp.sunet.se/pub/lang/perl/CPAN/
- Switzerland ftp://sunsite.cnlab-switch.ch/mirror/CPAN/
- Turkey ftp://sunsite.bilkent.edu.tr/pub/languages/CPAN/
- United Kingdom ftp://ftp.demon.co.uk/pub/mirrors/perl/CPAN/
- ftp://ftp.flirble.org/pub/languages/perl/CPAN/
-
-ftp://ftp.mirror.ac.uk/sites/ftp.funet.fi/pub/languages/perl/CPAN/
- ftp://ftp.plig.org/pub/CPAN/
- ftp://sunsite.doc.ic.ac.uk/packages/CPAN/
-
+ Austria ftp://ftp.tuwien.ac.at/pub/languages/perl/CPAN/
+ Belgium http://ftp.easynet.be/CPAN/
+ ftp://ftp.easynet.be/CPAN/
+ ftp://ftp.kulnet.kuleuven.ac.be/pub/mirror/CPAN/
+ Bulgaria ftp://ftp.ntrl.net/pub/mirrors/CPAN/
+ Croatia ftp://ftp.linux.hr/pub/CPAN/
+ Czech Republic http://www.fi.muni.cz/pub/perl/
+ ftp://ftp.fi.muni.cz/pub/perl/
+ ftp://sunsite.mff.cuni.cz/MIRRORS/ftp.funet.fi/pub/languages/perl/CPAN/
+ Denmark ftp://sunsite.auc.dk/pub/languages/perl/CPAN/
+ http://www.cpan.dk/CPAN/
+ England http://www.mirror.ac.uk/sites/ftp.funet.fi/pub/languages/perl/CPAN
+ ftp://ftp.mirror.ac.uk/sites/ftp.funet.fi/pub/languages/perl/CPAN/
+ ftp://ftp.demon.co.uk/pub/mirrors/perl/CPAN/
+ ftp://ftp.flirble.org/pub/languages/perl/CPAN/
+ ftp://ftp.plig.org/pub/CPAN/
+ ftp://sunsite.doc.ic.ac.uk/packages/CPAN/
+ http://mirror.uklinux.net/CPAN/
+ ftp://mirror.uklinux.net/pub/CPAN/
+ ftp://usit.shef.ac.uk/pub/packages/CPAN/
+ Estonia ftp://ftp.ut.ee/pub/languages/perl/CPAN/
+ Finland ftp://ftp.funet.fi/pub/languages/perl/CPAN/
+ France ftp://cpan.ftp.worldonline.fr/pub/CPAN/
+ ftp://ftp.club-internet.fr/pub/perl/CPAN/
+ ftp://ftp.lip6.fr/pub/perl/CPAN/
+ ftp://ftp.oleane.net/pub/mirrors/CPAN/
+ ftp://ftp.pasteur.fr/pub/computing/CPAN/
+ ftp://cpan.cict.fr/pub/CPAN/
+ ftp://ftp.uvsq.fr/pub/perl/CPAN/
+ Germany ftp://ftp.rz.ruhr-uni-bochum.de/pub/CPAN/
+ ftp://ftp.freenet.de/pub/ftp.cpan.org/pub/CPAN/
+ ftp://ftp.uni-erlangen.de/pub/source/CPAN/
+ ftp://ftp-stud.fht-esslingen.de/pub/Mirrors/CPAN
+ ftp://ftp.gigabell.net/pub/CPAN/
+ http://ftp.gwdg.de/pub/languages/perl/CPAN/
+ ftp://ftp.gwdg.de/pub/languages/perl/CPAN/
+ ftp://ftp.uni-hamburg.de/pub/soft/lang/perl/CPAN/
+ ftp://ftp.leo.org/pub/comp/general/programming/languages/script/perl/CPAN/
+ ftp://ftp.mpi-sb.mpg.de/pub/perl/CPAN/
+ ftp://ftp.gmd.de/packages/CPAN/
+ Greece ftp://ftp.ntua.gr/pub/lang/perl/
+ Hungary http://cpan.artifact.hu/
+ ftp://cpan.artifact.hu/CPAN/
+ ftp://ftp.kfki.hu/pub/packages/perl/CPAN/
+ Iceland http://cpan.gm.is/
+ ftp://ftp.gm.is/pub/CPAN/
+ Ireland http://cpan.indigo.ie/
+ ftp://cpan.indigo.ie/pub/CPAN/
+ http://sunsite.compapp.dcu.ie/pub/perl/
+ ftp://sunsite.compapp.dcu.ie/pub/perl/
+ Italy http://cpan.nettuno.it/
+ http://softcity.iol.it/cpan
+ ftp://softcity.iol.it/pub/cpan
+ ftp://ftp.unina.it/pub/Other/CPAN/
+ ftp://ftp.unipi.it/pub/mirror/perl/CPAN/
+ ftp://cis.uniRoma2.it/CPAN/
+ ftp://ftp.edisontel.it/pub/CPAN_Mirror/
+ ftp://ftp.flashnet.it/pub/CPAN/
+ Latvia http://kvin.lv/pub/CPAN/
+ Netherlands ftp://download.xs4all.nl/pub/mirror/CPAN/
+ ftp://ftp.nl.uu.net/pub/CPAN/
+ ftp://ftp.cpan.nl/pub/CPAN/
+ ftp://ftp.nluug.nl/pub/languages/perl/CPAN/
+ http://www.cs.uu.nl/mirror/CPAN/
+ ftp://ftp.cs.uu.nl/mirror/CPAN/
+ Norway ftp://sunsite.uio.no/pub/languages/perl/CPAN/
+ ftp://ftp.uit.no/pub/languages/perl/cpan/
+ Poland ftp://ftp.pk.edu.pl/pub/lang/perl/CPAN/
+ ftp://ftp.mega.net.pl/pub/mirrors/ftp.perl.com/
+ ftp://ftp.man.torun.pl/pub/doc/CPAN/
+ ftp://sunsite.icm.edu.pl/pub/CPAN/
+ Portugal ftp://ftp.ua.pt/pub/CPAN/
+ ftp://perl.di.uminho.pt/pub/CPAN/
+ ftp://ftp.ist.utl.pt/pub/CPAN/
+ ftp://ftp.netc.pt/pub/CPAN/
+ Romania ftp://archive.logicnet.ro/mirrors/ftp.cpan.org/CPAN/
+ ftp://ftp.kappa.ro/pub/mirrors/ftp.perl.org/pub/CPAN/
+ ftp://ftp.dntis.ro/pub/cpan/
+ ftp://ftp.opsynet.com/cpan/
+ ftp://ftp.dnttm.ro/pub/CPAN/
+ Russia ftp://ftp.chg.ru/pub/lang/perl/CPAN/
+ http://cpan.rinet.ru/
+ ftp://cpan.rinet.ru/pub/mirror/CPAN/
+ ftp://ftp.aha.ru/pub/CPAN/
+ ftp://ftp.sai.msu.su/pub/lang/perl/CPAN/
+ Slovakia ftp://ftp.entry.sk/pub/languages/perl/CPAN/
+ Slovenia ftp://ftp.arnes.si/software/perl/CPAN/
+ Spain ftp://ftp.rediris.es/mirror/CPAN/
+ ftp://ftp.etse.urv.es/pub/perl/
+ Sweden http://ftp.du.se/CPAN/
+ ftp://ftp.du.se/pub/CPAN/
+ ftp://ftp.sunet.se/pub/lang/perl/CPAN/
+ Switzerland ftp://ftp.danyk.ch/CPAN/
+ ftp://sunsite.cnlab-switch.ch/mirror/CPAN/
+ Turkey ftp://sunsite.bilkent.edu.tr/pub/languages/CPAN/
=item North America
- Alberta ftp://sunsite.ualberta.ca/pub/Mirror/CPAN/
- California ftp://cpan.nas.nasa.gov/pub/perl/CPAN/
- ftp://cpan.valueclick.com/CPAN/
- ftp://ftp.cdrom.com/pub/perl/CPAN/
- http://download.sourceforge.net/mirrors/CPAN/
- Colorado ftp://ftp.cs.colorado.edu/pub/perl/CPAN/
- Florida ftp://ftp.cise.ufl.edu/pub/perl/CPAN/
- Georgia ftp://ftp.twoguys.org/CPAN/
- Illinois ftp://uiarchive.uiuc.edu/pub/lang/perl/CPAN/
- Indiana ftp://csociety-ftp.ecn.purdue.edu/pub/CPAN/
- ftp://ftp.uwsg.indiana.edu/pub/perl/CPAN/
- Kentucky ftp://ftp.uky.edu/CPAN/
- Manitoba ftp://theoryx5.uwinnipeg.ca/pub/CPAN/
- Massachusetts
-ftp://ftp.ccs.neu.edu/net/mirrors/ftp.funet.fi/pub/languages/perl/CPAN/
- ftp://ftp.iguide.com/pub/mirrors/packages/perl/CPAN/
- Mexico ftp://ftp.msg.com.mx/pub/CPAN/
- New York ftp://ftp.deao.net/pub/CPAN/
- ftp://ftp.rge.com/pub/languages/perl/
- North Carolina ftp://ftp.duke.edu/pub/perl/
- Nova Scotia ftp://cpan.chebucto.ns.ca/pub/CPAN/
- Oklahoma ftp://ftp.ou.edu/mirrors/CPAN/
- Ontario ftp://ftp.crc.ca/pub/packages/lang/perl/CPAN/
- Oregon ftp://ftp.orst.edu/pub/packages/CPAN/
- Pennsylvania ftp://ftp.epix.net/pub/languages/perl/
- Tennessee ftp://ftp.sunsite.utk.edu/pub/CPAN/
- Texas ftp://ftp.sedl.org/pub/mirrors/CPAN/
- ftp://jhcloos.com/pub/mirror/CPAN/
- Utah ftp://mirror.xmission.com/CPAN/
- Virginia ftp://ftp.perl.org/pub/perl/CPAN/
- ftp://ruff.cs.jmu.edu/pub/CPAN/
- Washington ftp://ftp-mirror.internap.com/pub/CPAN/
- ftp://ftp.llarian.net/pub/CPAN/
- ftp://ftp.spu.edu/pub/CPAN/
-
+ Alberta http://sunsite.ualberta.ca/pub/Mirror/CPAN/
+ ftp://sunsite.ualberta.ca/pub/Mirror/CPAN/
+ Alabama http://mirror.hiwaay.net/CPAN/
+ ftp://mirror.hiwaay.net/CPAN/
+ California http://www.cpan.org/
+ ftp://ftp.cpan.org/CPAN/
+ ftp://cpan.nas.nasa.gov/pub/perl/CPAN/
+ ftp://ftp.digital.com/pub/plan/perl/CPAN/
+ http://www.kernel.org/pub/mirrors/cpan/
+ ftp://ftp.kernel.org/pub/mirrors/cpan/
+ http://www.perl.com/CPAN/
+ http://download.sourceforge.net/mirrors/CPAN/
+ Colorado ftp://ftp.cs.colorado.edu/pub/perl/CPAN/
+ Florida ftp://ftp.cise.ufl.edu/pub/perl/CPAN/
+ Georgia ftp://ftp.twoguys.org/CPAN/
+ Illinois http://www.neurogames.com/mirrors/CPAN
+ Indiana ftp://ftp.uwsg.indiana.edu/pub/perl/CPAN/
+ http://cpan.nitco.com/
+ ftp://cpan.nitco.com/pub/CPAN/
+ ftp://cpan.in-span.net/
+ http://csociety-ftp.ecn.purdue.edu/pub/CPAN
+ ftp://csociety-ftp.ecn.purdue.edu/pub/CPAN
+ Manitoba http://theoryx5.uwinnipeg.ca/pub/CPAN/
+ ftp://theoryx5.uwinnipeg.ca/pub/CPAN/
+ Massachusetts ftp://ftp.ccs.neu.edu/net/mirrors/ftp.funet.fi/pub/languages/perl/CPAN/
+ ftp://ftp.iguide.com/pub/mirrors/packages/perl/CPAN/
+ Mexico http://www.msg.com.mx/CPAN/
+ ftp://ftp.msg.com.mx/pub/CPAN/
+ New Jersey ftp://ftp.cpanel.net/pub/CPAN/
+ New York ftp://ftp.freesoftware.com/pub/perl/CPAN/
+ http://www.deao.net/mirrors/CPAN/
+ ftp://ftp.deao.net/pub/CPAN/
+ ftp://ftp.stealth.net/pub/mirrors/ftp.cpan.org/pub/CPAN/
+ http://mirror.nyc.anidea.com/CPAN/
+ ftp://mirror.nyc.anidea.com/pub/CPAN/
+ http://www.rge.com/pub/languages/perl/
+ ftp://ftp.rge.com/pub/languages/perl/
+ ftp://mirrors.cloud9.net/pub/mirrors/CPAN/
+ North Carolina ftp://ftp.duke.edu/pub/perl/
+ Nova Scotia ftp://cpan.chebucto.ns.ca/pub/CPAN/
+ Ohio ftp://ftp.loaded.net/pub/CPAN/
+ Oklahoma ftp://ftp.ou.edu/mirrors/CPAN/
+ Ontario ftp://ftp.crc.ca/pub/packages/lang/perl/CPAN/
+ Oregon ftp://ftp.orst.edu/pub/packages/CPAN/
+ Pennsylvania http://ftp.epix.net/CPAN/
+ ftp://ftp.epix.net/pub/languages/perl/
+ ftp://carroll.cac.psu.edu/pub/CPAN/
+ Tennessee ftp://ftp.sunsite.utk.edu/pub/CPAN/
+ Texas http://ftp.sedl.org/pub/mirrors/CPAN/
+ http://jhcloos.com/pub/mirror/CPAN/
+ ftp://jhcloos.com/pub/mirror/CPAN/
+ Utah ftp://mirror.xmission.com/CPAN/
+ Virginia http://mirrors.rcn.net/pub/lang/CPAN/
+ ftp://mirrors.rcn.net/pub/lang/CPAN/
+ ftp://ruff.cs.jmu.edu/pub/CPAN/
+ Washington http://cpan.llarian.net/
+ ftp://cpan.llarian.net/pub/CPAN/
+ ftp://ftp-mirror.internap.com/pub/CPAN/
+ ftp://ftp.spu.edu/pub/CPAN/
+
+=item Oceania
+
+ Australia http://ftp.planetmirror.com/pub/CPAN/
+ ftp://ftp.planetmirror.com/pub/CPAN/
+ ftp://mirror.aarnet.edu.au/pub/perl/CPAN/
+ ftp://cpan.topend.com.au/pub/CPAN/
+ New Zealand ftp://ftp.auckland.ac.nz/pub/perl/CPAN/
=item South America
- Brazil ftp://cpan.if.usp.br/pub/mirror/CPAN/
- ftp://ftp.matrix.com.br/pub/perl/
- Chile ftp://sunsite.dcc.uchile.cl/pub/Lang/PERL/
+ Argentina ftp://mirrors.bannerlandia.com.ar/mirrors/CPAN/
+ Brazil ftp://cpan.pop-mg.com.br/pub/CPAN/
+ ftp://ftp.matrix.com.br/pub/perl/
+ ftp://cpan.if.usp.br/pub/mirror/CPAN/
+ Chile ftp://ftp.psinet.cl/pub/programming/perl/CPAN/
+ ftp://sunsite.dcc.uchile.cl/pub/lang/perl/
=back
=over 4
-=item Do similar modules already exist in some form?
+=item *
+
+Do similar modules already exist in some form?
If so, please try to reuse the existing modules either in whole or
by inheriting useful features into a new class. If this is not
helps if you follow the same naming scheme and module interaction
scheme as the original author.
-=item Try to design the new module to be easy to extend and reuse.
+=item *
+
+Try to design the new module to be easy to extend and reuse.
Try to C<use warnings;> (or C<use warnings qw(...);>).
Remember that you can add C<no warnings qw(...);> to individual blocks
Always use B<-w>.
-=item Some simple style guidelines
+=item *
+
+Some simple style guidelines
The perlstyle manual supplied with Perl has many helpful points.
You can use a leading underscore to indicate that a variable or
function should not be used outside the package that defined it.
-=item Select what to export.
+=item *
+
+Select what to export.
Do NOT export method names!
then export nothing. If it's just a collection of functions then
@EXPORT_OK anything but use @EXPORT with caution.
-=item Select a name for the module.
+=item *
+
+Select a name for the module.
This name should be as descriptive, accurate, and complete as
possible. Avoid any risk of ambiguity. Always try to use two or
11 characters. If it might be used on MS-DOS then try to ensure each is
unique in the first 8 characters. Nested modules make this easier.
-=item Have you got it right?
+=item *
+
+Have you got it right?
How do you know that you've made the right decisions? Have you
picked an interface design that will cause problems later? Have
ready - just say so in the message. It might be worth inviting
others to help you, they may be able to complete it for you!
-=item README and other Additional Files.
+=item *
+
+README and other Additional Files.
It's well known that software developers usually fully document the
software they write. If, however, the world is in urgent need of
=over 10
=item *
+
A description of the module/package/extension etc.
=item *
+
A copyright notice - see below.
=item *
+
Prerequisites - what else you may need to have.
=item *
+
How to build it - possible changes to Makefile.PL etc.
=item *
+
How to install it.
=item *
+
Recent changes in this release, especially incompatibilities
=item *
+
Changes / enhancements you plan to make in the future.
=back
=item Adding a Copyright Notice.
+
How you choose to license your work is a personal decision.
The general mechanism is to assert your Copyright and then make
a declaration of how others may copy/use/modify your work.
also wish to include it in a Copying file and your source files.
Remember to include the other words in addition to the Copyright.
-=item Give the module a version/issue/release number.
+=item *
+
+Give the module a version/issue/release number.
To be fully compatible with the Exporter and MakeMaker modules you
should store your module's version number in a non-my package
releasing the module (ModuleName-1.02.tar.Z).
See perldoc ExtUtils::MakeMaker.pm for details.
-=item How to release and distribute a module.
+=item *
+
+How to release and distribute a module.
It's good idea to post an announcement of the availability of your
module (or the module itself if small) to the comp.lang.perl.announce
Please remember to send me an updated entry for the Module list!
-=item Take care when changing a released module.
+=item *
+
+Take care when changing a released module.
Always strive to remain compatible with previous released versions.
Otherwise try to add a mechanism to revert to the
=over 4
-=item There is no requirement to convert anything.
+=item *
+
+There is no requirement to convert anything.
If it ain't broke, don't fix it! Perl 4 library scripts should
continue to work with no problems. You may need to make some minor
changes (like escaping non-array @'s in double quoted strings) but
there is no need to convert a .pl file into a Module for just that.
-=item Consider the implications.
+=item *
+
+Consider the implications.
All Perl applications that make use of the script will need to
be changed (slightly) if the script is converted into a module. Is
it worth it unless you plan to make other changes at the same time?
-=item Make the most of the opportunity.
+=item *
+
+Make the most of the opportunity.
If you are going to convert the script to a module you can use the
opportunity to redesign the interface. The guidelines for module
creation above include many of the issues you should consider.
-=item The pl2pm utility will get you started.
+=item *
+
+The pl2pm utility will get you started.
This utility will read *.pl files (given as parameters) and write
corresponding *.pm files. The pl2pm utilities does the following:
=over 10
=item *
+
Adds the standard Module prologue lines
=item *
+
Converts package specifiers from ' to ::
=item *
+
Converts die(...) to croak(...)
=item *
+
Several other minor changes
=back
=over 4
-=item Complete applications rarely belong in the Perl Module Library.
+=item *
+
+Complete applications rarely belong in the Perl Module Library.
+
+=item *
-=item Many applications contain some Perl code that could be reused.
+Many applications contain some Perl code that could be reused.
Help save the world! Share your code in a form that makes it easy
to reuse.
-=item Break-out the reusable code into one or more separate module files.
+=item *
+
+Break-out the reusable code into one or more separate module files.
+
+=item *
+
+Take the opportunity to reconsider and redesign the interfaces.
-=item Take the opportunity to reconsider and redesign the interfaces.
+=item *
-=item In some cases the 'application' can then be reduced to a small
+In some cases the 'application' can then be reduced to a small
fragment of code built on top of the reusable modules. In these cases
the application could invoked as:
=head1 SEE ALSO
-A kinder, gentler tutorial on object-oriented programming in Perl
-can be found in L<perltoot> and L<perltootc>. You should also check
-out L<perlbot> for other object tricks, traps, and tips, as well
-as L<perlmodlib> for some style guides on constructing both modules
-and classes.
+A kinder, gentler tutorial on object-oriented programming in Perl can
+be found in L<perltoot>, L<perlbootc> and L<perltootc>. You should
+also check out L<perlbot> for other object tricks, traps, and tips, as
+well as L<perlmodlib> for some style guides on constructing both
+modules and classes.
open(FOO, "echo *.c | tr -s ' \t\r\f' '\\012\\012\\012\\012'|");
while (<FOO>) {
- chop;
+ chomp;
chmod 0644, $_;
}
Unix does the same thing on ttys in canonical mode. C<\015\012>
is commonly referred to as CRLF.
+A common cause of unportable programs is the misuse of chop() to trim
+newlines:
+
+ # XXX UNPORTABLE!
+ while(<FILE>) {
+ chop;
+ @array = split(/:/);
+ #...
+ }
+
+You can get away with this on Unix and MacOS (they have a single
+character end-of-line), but the same program will break under DOSish
+perls because you're only chop()ing half the end-of-line. Instead,
+chomp() should be used to trim newlines. The Dunce::Files module can
+help audit your code for misuses of chop().
+
+When dealing with binary files (or text files in binary mode) be sure
+to explicitly set $/ to the appropriate value for your file format
+before using chomp().
+
Because of the "text" mode translation, DOSish perls have limitations
in using C<seek> and C<tell> on a file accessed in "text" mode.
Stick to C<seek>-ing to locations you got from C<tell> (and no
$_ = 'bar';
s/\w??/<$&>/g;
-results in C<"<><b><><a><><r><>">. At each position of the string the best
+results in C<< <><b><><a><><r><> >>. At each position of the string the best
match given by non-greedy C<??> is the zero-length match, and the I<second
best> match is what is matched by C<\w>. Thus zero-length matches
alternate with one-character-long matches.
Notice how there's no memory to deallocate in the destructor? That's
something that Perl takes care of for you all by itself.
+Alternatively, you could use the Class::Data::Inheritable module from
+CPAN.
+
+
=head2 Accessing Class Data
It turns out that this is not really a good way to go about handling
and
L<overload>.
+L<perlboot> is a kinder, gentler introduction to object-oriented
+programming.
+
+L<perltootc> provides more detail on class data.
+
+Some modules which might prove interesting are Class::Accessor,
+Class::Class, Class::Contract, Class::Data::Inheritable,
+Class::MethodMaker and Tie::SecureHash
+
+
=head1 AUTHOR AND COPYRIGHT
Copyright (c) 1997, 1998 Tom Christiansen
scope, or you can limit direct data access exclusively to the methods
implementing those attributes.
+=head1 Class Data in a Can
+
+One of the easiest ways to solve a hard problem is to let someone else
+do it for you! In this case, Class::Data::Inheritable (available on a
+CPAN near you) offers a canned solution to the class data problem
+using closures. So before you wade into this document, consider
+having a look at that module.
+
+
=head1 Class Data as Package Variables
Because a class in Perl is really just a package, using package variables
L<perltoot>, L<perlobj>, L<perlmod>, and L<perlbot>.
-The Tie::SecureHash module from CPAN is worth checking out.
+The Tie::SecureHash and Class::Data::Inheritable modules from CPAN are
+worth checking out.
=head1 AUTHOR AND COPYRIGHT
=head1 HISTORY
-Last edit: Fri May 21 15:47:56 MDT 1999
+Last edit: Sun Feb 4 20:50:28 EST 2001
on C<s/foo/bar> will produce a Perl program based around this:
while (<>) {
- chop;
+ chomp;
s/foo/bar/g;
print if $printit;
}
djSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
useleft = USE_LEFT(TOPm1s);
#ifdef PERL_PRESERVE_IVUV
- /* We must see if we can perform the addition with integers if possible,
- as the integer code detects overflow while the NV code doesn't.
- If either argument hasn't had a numeric conversion yet attempt to get
- the IV. It's important to do this now, rather than just assuming that
- it's not IOK as a PV of "9223372036854775806" may not take well to NV
- addition, and an SV which is NOK, NV=6.0 ought to be coerced to
- integer in case the second argument is IV=9223372036854775806
- We can (now) rely on sv_2iv to do the right thing, only setting the
- public IOK flag if the value in the NV (or PV) slot is truly integer.
-
- A side effect is that this also aggressively prefers integer maths over
- fp maths for integer values. */
+ /* See comments in pp_add (in pp_hot.c) about Overflow, and how
+ "bad things" happen if you rely on signed integers wrapping. */
SvIV_please(TOPs);
if (SvIOK(TOPs)) {
/* Unless the left argument is integer in range we are going to have to
use NV maths. Hence only attempt to coerce the right argument if
we know the left is integer. */
+ register UV auv;
+ bool auvok;
+ bool a_valid = 0;
+
if (!useleft) {
- /* left operand is undef, treat as zero. + 0 is identity. */
- if (SvUOK(TOPs)) {
- dPOPuv; /* Scary macros. Lets put a sequence point (;) here */
- if (value <= (UV)IV_MIN) {
- /* 2s complement assumption. */
- SETi(-(IV)value);
- RETURN;
- } /* else drop through into NVs below */
- } else {
- dPOPiv;
- SETu((UV)-value);
- RETURN;
- }
+ auv = 0;
+ a_valid = auvok = 1;
+ /* left operand is undef, treat as zero. */
} else {
/* Left operand is defined, so is it IV? */
SvIV_please(TOPm1s);
if (SvIOK(TOPm1s)) {
- bool auvok = SvUOK(TOPm1s);
- bool buvok = SvUOK(TOPs);
-
- if (!auvok && !buvok) { /* ## IV - IV ## */
- IV aiv = SvIVX(TOPm1s);
- IV biv = SvIVX(TOPs);
- IV result = aiv - biv;
-
- if (biv >= 0 ? (result < aiv) : (result >= aiv)) {
- SP--;
- SETi( result );
- RETURN;
- }
- /* +ve - +ve can't overflow. (worst case 0 - IV_MAX) */
- /* -ve - -ve can't overflow. (worst case -1 - IV_MIN) */
- /* -ve - +ve can only overflow too negative. */
- /* leaving +ve - -ve, which will go UV */
- if (aiv >= 0 && biv < 0) { /* assert don't need biv <0 */
- /* 2s complement assumption for IV_MIN */
- UV result = (UV)aiv + (UV)-biv;
- /* UV + UV must get bigger. +ve IV + +ve IV +1 can't
- overflow UV (2s complement assumption */
- assert (result >= (UV) aiv);
- SP--;
- SETu( result );
- RETURN;
- }
- /* Overflow, drop through to NVs */
- } else if (auvok && buvok) { /* ## UV - UV ## */
- UV auv = SvUVX(TOPm1s);
- UV buv = SvUVX(TOPs);
- IV result;
-
- if (auv >= buv) {
- SP--;
- SETu( auv - buv );
- RETURN;
- }
- /* Blatant 2s complement assumption. */
- result = (IV)(auv - buv);
- if (result < 0) {
- SP--;
- SETi( result );
- RETURN;
+ if ((auvok = SvUOK(TOPm1s)))
+ auv = SvUVX(TOPm1s);
+ else {
+ register IV aiv = SvIVX(TOPm1s);
+ if (aiv >= 0) {
+ auv = aiv;
+ auvok = 1; /* Now acting as a sign flag. */
+ } else { /* 2s complement assumption for IV_MIN */
+ auv = (UV)-aiv;
}
- /* Overflow on IV - IV, drop through to NVs */
- } else if (auvok) { /* ## Mixed UV - IV ## */
- UV auv = SvUVX(TOPm1s);
- IV biv = SvIVX(TOPs);
-
- if (biv < 0) {
- /* 2s complement assumptions for IV_MIN */
- UV result = auv + ((UV)-biv);
- /* UV + UV can only get bigger... */
- if (result >= auv) {
- SP--;
- SETu( result );
- RETURN;
- }
- /* and if it gets too big for UV then it's NV time. */
- } else if (auv > (UV)IV_MAX) {
- /* I think I'm making an implicit 2s complement
- assumption that IV_MIN == -IV_MAX - 1 */
- /* biv is >= 0 */
- UV result = auv - (UV)biv;
- assert (result <= auv);
- SP--;
- SETu( result );
- RETURN;
- } else {
- /* biv is >= 0 */
- IV result = (IV)auv - biv;
- assert (result <= (IV)auv);
- SP--;
- SETi( result );
- RETURN;
+ }
+ a_valid = 1;
+ }
+ }
+ if (a_valid) {
+ bool result_good = 0;
+ UV result;
+ register UV buv;
+ bool buvok = SvUOK(TOPs);
+
+ if (buvok)
+ buv = SvUVX(TOPs);
+ else {
+ register IV biv = SvIVX(TOPs);
+ if (biv >= 0) {
+ buv = biv;
+ buvok = 1;
+ } else
+ buv = (UV)-biv;
+ }
+ /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
+ else "IV" now, independant of how it came in.
+ if a, b represents positive, A, B negative, a maps to -A etc
+ a - b => (a - b)
+ A - b => -(a + b)
+ a - B => (a + b)
+ A - B => -(a - b)
+ all UV maths. negate result if A negative.
+ subtract if signs same, add if signs differ. */
+
+ if (auvok ^ buvok) {
+ /* Signs differ. */
+ result = auv + buv;
+ if (result >= auv)
+ result_good = 1;
+ } else {
+ /* Signs same */
+ if (auv >= buv) {
+ result = auv - buv;
+ /* Must get smaller */
+ if (result <= auv)
+ result_good = 1;
+ } else {
+ result = buv - auv;
+ if (result <= buv) {
+ /* result really should be -(auv-buv). as its negation
+ of true value, need to swap our result flag */
+ auvok = !auvok;
+ result_good = 1;
}
- } else { /* ## Mixed IV - UV ## */
- IV aiv = SvIVX(TOPm1s);
- UV buv = SvUVX(TOPs);
- IV result = aiv - (IV)buv; /* 2s complement assumption. */
-
- /* result must not get larger. */
- if (result <= aiv) {
- SP--;
- SETi( result );
- RETURN;
- } /* end of IV-IV / UV-UV / UV-IV / IV-UV */
}
}
+ if (result_good) {
+ SP--;
+ if (auvok)
+ SETu( result );
+ else {
+ /* Negate result */
+ if (result <= (UV)IV_MIN)
+ SETi( -(IV)result );
+ else {
+ /* result valid, but out of range for IV. */
+ SETn( -(NV)result );
+ }
+ }
+ RETURN;
+ } /* Overflow, drop through to NVs. */
}
}
#endif
+ useleft = USE_LEFT(TOPm1s);
{
dPOPnv;
if (!useleft) {
PP(pp_int)
{
- djSP; dTARGET;
+ djSP; dTARGET; tryAMAGICun(int);
{
NV value;
IV iv = TOPi; /* attempt to convert to IV if possible. */
=cut */
+#undef SP /* Solaris 2.7 i386 has this in /usr/include/sys/reg.h */
#define SP sp
#define MARK mark
#define TARG targ
#define TOPs (*sp)
#define TOPm1s (*(sp-1))
+#define TOPp1s (*(sp+1))
#define TOPp (SvPV(TOPs, PL_na)) /* deprecated */
#define TOPpx (SvPV(TOPs, n_a))
#define TOPn (SvNV(TOPs))
public IOK flag if the value in the NV (or PV) slot is truly integer.
A side effect is that this also aggressively prefers integer maths over
- fp maths for integer values. */
+ fp maths for integer values.
+
+ How to detect overflow?
+
+ C 99 section 6.2.6.1 says
+
+ The range of nonnegative values of a signed integer type is a subrange
+ of the corresponding unsigned integer type, and the representation of
+ the same value in each type is the same. A computation involving
+ unsigned operands can never overflow, because a result that cannot be
+ represented by the resulting unsigned integer type is reduced modulo
+ the number that is one greater than the largest value that can be
+ represented by the resulting type.
+
+ (the 9th paragraph)
+
+ which I read as "unsigned ints wrap."
+
+ signed integer overflow seems to be classed as "exception condition"
+
+ If an exceptional condition occurs during the evaluation of an
+ expression (that is, if the result is not mathematically defined or not
+ in the range of representable values for its type), the behavior is
+ undefined.
+
+ (6.5, the 5th paragraph)
+
+ I had assumed that on 2s complement machines signed arithmetic would
+ wrap, hence coded pp_add and pp_subtract on the assumption that
+ everything perl builds on would be happy. After much wailing and
+ gnashing of teeth it would seem that irix64 knows its ANSI spec well,
+ knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
+ unsigned code below is actually shorter than the old code. :-)
+ */
+
SvIV_please(TOPs);
if (SvIOK(TOPs)) {
/* Unless the left argument is integer in range we are going to have to
use NV maths. Hence only attempt to coerce the right argument if
we know the left is integer. */
+ register UV auv;
+ bool auvok;
+ bool a_valid = 0;
+
if (!useleft) {
- /* left operand is undef, treat as zero. + 0 is identity. */
- if (SvUOK(TOPs)) {
- dPOPuv; /* Scary macros. Lets put a sequence point (;) here */
- SETu(value);
- RETURN;
- } else {
- dPOPiv;
- SETi(value);
- RETURN;
+ auv = 0;
+ a_valid = auvok = 1;
+ /* left operand is undef, treat as zero. + 0 is identity,
+ Could SETi or SETu right now, but space optimise by not adding
+ lots of code to speed up what is probably a rarish case. */
+ } else {
+ /* Left operand is defined, so is it IV? */
+ SvIV_please(TOPm1s);
+ if (SvIOK(TOPm1s)) {
+ if ((auvok = SvUOK(TOPm1s)))
+ auv = SvUVX(TOPm1s);
+ else {
+ register IV aiv = SvIVX(TOPm1s);
+ if (aiv >= 0) {
+ auv = aiv;
+ auvok = 1; /* Now acting as a sign flag. */
+ } else { /* 2s complement assumption for IV_MIN */
+ auv = (UV)-aiv;
+ }
+ }
+ a_valid = 1;
}
}
- /* Left operand is defined, so is it IV? */
- SvIV_please(TOPm1s);
- if (SvIOK(TOPm1s)) {
- bool auvok = SvUOK(TOPm1s);
+ if (a_valid) {
+ bool result_good = 0;
+ UV result;
+ register UV buv;
bool buvok = SvUOK(TOPs);
-
- if (!auvok && !buvok) { /* ## IV + IV ## */
- IV aiv = SvIVX(TOPm1s);
- IV biv = SvIVX(TOPs);
- IV result = aiv + biv;
-
- if (biv >= 0 ? (result >= aiv) : (result < aiv)) {
- SP--;
- SETi( result );
- RETURN;
- }
- if (biv >=0 && aiv >= 0) {
- UV result = (UV)aiv + (UV)biv;
- /* UV + UV can only get bigger... */
- if (result >= (UV) aiv) {
- SP--;
- SETu( result );
- RETURN;
+
+ if (buvok)
+ buv = SvUVX(TOPs);
+ else {
+ register IV biv = SvIVX(TOPs);
+ if (biv >= 0) {
+ buv = biv;
+ buvok = 1;
+ } else
+ buv = (UV)-biv;
+ }
+ /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
+ else "IV" now, independant of how it came in.
+ if a, b represents positive, A, B negative, a maps to -A etc
+ a + b => (a + b)
+ A + b => -(a - b)
+ a + B => (a - b)
+ A + B => -(a + b)
+ all UV maths. negate result if A negative.
+ add if signs same, subtract if signs differ. */
+
+ if (auvok ^ buvok) {
+ /* Signs differ. */
+ if (auv >= buv) {
+ result = auv - buv;
+ /* Must get smaller */
+ if (result <= auv)
+ result_good = 1;
+ } else {
+ result = buv - auv;
+ if (result <= buv) {
+ /* result really should be -(auv-buv). as its negation
+ of true value, need to swap our result flag */
+ auvok = !auvok;
+ result_good = 1;
}
}
- /* Overflow, drop through to NVs (beyond next if () else ) */
- } else if (auvok && buvok) { /* ## UV + UV ## */
- UV auv = SvUVX(TOPm1s);
- UV buv = SvUVX(TOPs);
- UV result = auv + buv;
- if (result >= auv) {
- SP--;
+ } else {
+ /* Signs same */
+ result = auv + buv;
+ if (result >= auv)
+ result_good = 1;
+ }
+ if (result_good) {
+ SP--;
+ if (auvok)
SETu( result );
- RETURN;
- }
- /* Overflow, drop through to NVs (beyond next if () else ) */
- } else { /* ## Mixed IV,UV ## */
- IV aiv;
- UV buv;
-
- /* addition is commutative so swap if needed (save code) */
- if (buvok) {
- aiv = SvIVX(TOPm1s);
- buv = SvUVX(TOPs);
- } else {
- aiv = SvIVX(TOPs);
- buv = SvUVX(TOPm1s);
- }
-
- if (aiv >= 0) {
- UV result = (UV)aiv + buv;
- if (result >= buv) {
- SP--;
- SETu( result );
- RETURN;
- }
- } else if (buv > (UV) IV_MAX) {
- /* assuming 2s complement means that IV_MIN == -IV_MIN,
- and (UV)-IV_MIN *is* the value -IV_MIN (or IV_MAX + 1)
- as buv > IV_MAX, it is >= (IV_MAX + 1), and therefore
- as the value we can be subtracting from it only lies in
- the range (-IV_MIN to -1) it can't overflow a UV */
- SP--;
- SETu( buv - (UV)-aiv );
- RETURN;
- } else {
- IV result = (IV) buv + aiv;
- /* aiv < 0 so it must get smaller. */
- if (result < (IV) buv) {
- SP--;
- SETi( result );
- RETURN;
+ else {
+ /* Negate result */
+ if (result <= (UV)IV_MIN)
+ SETi( -(IV)result );
+ else {
+ /* result valid, but out of range for IV. */
+ SETn( -(NV)result );
}
}
- } /* end of IV+IV / UV+UV / mixed */
+ RETURN;
+ } /* Overflow, drop through to NVs. */
}
}
#endif
PERL_CALLCONV IV Perl_utf8_distance(pTHX_ U8 *a, U8 *b);
PERL_CALLCONV U8* Perl_utf8_hop(pTHX_ U8 *s, I32 off);
PERL_CALLCONV U8* Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len);
+PERL_CALLCONV U8* Perl_bytes_from_utf8(pTHX_ U8 *s, STRLEN *len, bool *is_utf8);
PERL_CALLCONV U8* Perl_bytes_to_utf8(pTHX_ U8 *s, STRLEN *len);
PERL_CALLCONV UV Perl_utf8_to_uv_simple(pTHX_ U8 *s, STRLEN* retlen);
PERL_CALLCONV UV Perl_utf8_to_uv(pTHX_ U8 *s, STRLEN curlen, STRLEN* retlen, U32 flags);
STATIC char * S_filter_gets(pTHX_ SV *sv, PerlIO *fp, STRLEN append);
STATIC HV * S_find_in_my_stash(pTHX_ char *pkgname, I32 len);
STATIC SV* S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, const char *type);
+STATIC void S_tokereport(pTHX_ char *thing, char *s, I32 rv);
STATIC int S_ao(pTHX_ int toketype);
STATIC void S_depcom(pTHX);
STATIC char* S_incl_perldb(pTHX);
/* *These* symbols are masked to allow static link. */
# define Perl_regnext my_regnext
# define Perl_save_re_context my_save_re_context
-# define Perl_reginitcolors my_reginitcolors
+# define Perl_reginitcolors my_reginitcolors
# define PERL_NO_GET_CONTEXT
-#endif
+#endif
/*SUPPRESS 112*/
/*
* Forward declarations for pregcomp()'s friends.
*/
-static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0};
#define SF_BEFORE_EOL (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
*/
#define MARKER1 "HERE" /* marker as it appears in the description */
#define MARKER2 " << HERE " /* marker as it appears within the regex */
-
+
#define REPORT_LOCATION " before " MARKER1 " mark in regex m/%.*s" MARKER2 "%s/"
/*
{
STRLEN l = CHR_SVLEN(data->last_found);
STRLEN old_l = CHR_SVLEN(*data->longest);
-
+
if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
sv_setsv(*data->longest, data->last_found);
if (*data->longest == data->longest_fixed) {
data->offset_fixed = l ? data->last_start_min : data->pos_min;
if (data->flags & SF_BEFORE_EOL)
- data->flags
+ data->flags
|= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
else
data->flags &= ~SF_FIX_BEFORE_EOL;
}
else {
data->offset_float_min = l ? data->last_start_min : data->pos_min;
- data->offset_float_max = (l
- ? data->last_start_max
+ data->offset_float_max = (l
+ ? data->last_start_max
: data->pos_min + data->pos_delta);
if (data->flags & SF_BEFORE_EOL)
- data->flags
+ data->flags
|= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
else
data->flags &= ~SF_FL_BEFORE_EOL;
} else {
/* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
- && (!(or_with->flags & ANYOF_FOLD)
+ && (!(or_with->flags & ANYOF_FOLD)
|| (cl->flags & ANYOF_FOLD)) ) {
int i;
I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
scan_data_t data_fake;
struct regnode_charclass_class and_with; /* Valid if flags & SCF_DO_STCLASS_OR */
-
+
while (scan && OP(scan) != END && scan < last) {
/* Peephole optimizer: */
U32 stringok = 1;
#ifdef DEBUGGING
regnode *stop = scan;
-#endif
+#endif
next = scan + NODE_SZ_STR(scan);
/* Skip NOTHING, merge EXACT*. */
while (n &&
- ( PL_regkind[(U8)OP(n)] == NOTHING ||
+ ( PL_regkind[(U8)OP(n)] == NOTHING ||
(stringok && (OP(n) == OP(scan))))
&& NEXT_OFF(n)
&& NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) {
#ifdef DEBUGGING
if (stringok)
stop = n;
-#endif
+#endif
n = regnext(n);
}
else {
int oldl = STR_LEN(scan);
regnode *nnext = regnext(n);
-
- if (oldl + STR_LEN(n) > U8_MAX)
+
+ if (oldl + STR_LEN(n) > U8_MAX)
break;
NEXT_OFF(scan) += NEXT_OFF(n);
STR_LEN(scan) += STR_LEN(n);
#ifdef DEBUGGING
if (stringok)
stop = next - 1;
-#endif
+#endif
n = nnext;
}
}
int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
int noff;
regnode *n = scan;
-
+
/* Skip NOTHING and LONGJMP. */
while ((n = regnext(n))
&& ((PL_regkind[(U8)OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
off += noff;
if (reg_off_by_arg[OP(scan)])
ARG(scan) = off;
- else
+ else
NEXT_OFF(scan) = off;
}
/* The principal pseudo-switch. Cannot be a switch, since we
look into several different things. */
- if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
+ if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
|| OP(scan) == IFTHEN || OP(scan) == SUSPEND) {
next = regnext(scan);
code = OP(scan);
-
- if (OP(next) == code || code == IFTHEN || code == SUSPEND) {
+
+ if (OP(next) == code || code == IFTHEN || code == SUSPEND) {
I32 max1 = 0, min1 = I32_MAX, num = 0;
struct regnode_charclass_class accum;
num++;
data_fake.flags = 0;
- if (data) {
+ if (data) {
data_fake.whilem_c = data->whilem_c;
data_fake.last_closep = data->last_closep;
}
cl_init(pRExC_state, &this_class);
data_fake.start_class = &this_class;
f = SCF_DO_STCLASS_AND;
- }
+ }
if (flags & SCF_WHILEM_VISITED_POS)
f |= SCF_WHILEM_VISITED_POS;
/* we suppose the run is continuous, last=next...*/
minnext = study_chunk(pRExC_state, &scan, &deltanext,
next, &data_fake, f);
- if (min1 > minnext)
+ if (min1 > minnext)
min1 = minnext;
if (max1 < minnext + deltanext)
max1 = minnext + deltanext;
data->whilem_c = data_fake.whilem_c;
if (flags & SCF_DO_STCLASS)
cl_or(pRExC_state, &accum, &this_class);
- if (code == SUSPEND)
+ if (code == SUSPEND)
break;
}
if (code == IFTHEN && num < 2) /* Empty ELSE branch */
flags &= ~SCF_DO_STCLASS;
}
else {
- /* Switch to OR mode: cache the old value of
+ /* Switch to OR mode: cache the old value of
* data->start_class */
StructCopy(data->start_class, &and_with,
struct regnode_charclass_class);
if (data->last_end == -1) { /* Update the start info. */
data->last_start_min = data->pos_min;
data->last_start_max = is_inf
- ? I32_MAX : data->pos_min + data->pos_delta;
+ ? I32_MAX : data->pos_min + data->pos_delta;
}
sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
data->last_end = data->pos_min + l;
int compat = 1;
if (uc >= 0x100 ||
- !(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
+ !(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
&& !ANYOF_BITMAP_TEST(data->start_class, uc)
&& (!(data->start_class->flags & ANYOF_FOLD)
|| !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
UV uc = *((U8*)STRING(scan));
/* Search for fixed substrings supports EXACT only. */
- if (flags & SCF_DO_SUBSTR)
+ if (flags & SCF_DO_SUBSTR)
scan_commit(pRExC_state, data);
if (UTF) {
U8 *s = (U8 *)STRING(scan);
int compat = 1;
if (uc >= 0x100 ||
- !(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
+ !(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
&& !ANYOF_BITMAP_TEST(data->start_class, uc)
&& !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc]))
compat = 0;
if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
next = NEXTOPER(scan);
if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
- mincount = 1;
- maxcount = REG_INFTY;
+ mincount = 1;
+ maxcount = REG_INFTY;
next = regnext(scan);
scan = NEXTOPER(scan);
goto do_curly;
case STAR:
if (flags & SCF_DO_STCLASS) {
mincount = 0;
- maxcount = REG_INFTY;
+ maxcount = REG_INFTY;
next = regnext(scan);
scan = NEXTOPER(scan);
goto do_curly;
}
- is_inf = is_inf_internal = 1;
+ is_inf = is_inf_internal = 1;
scan = regnext(scan);
if (flags & SCF_DO_SUBSTR) {
scan_commit(pRExC_state, data); /* Cannot extend fixed substrings */
}
goto optimize_curly_tail;
case CURLY:
- mincount = ARG1(scan);
+ mincount = ARG1(scan);
maxcount = ARG2(scan);
next = regnext(scan);
if (OP(scan) == CURLYX) {
/* These are the cases when once a subexpression
fails at a particular position, it cannot succeed
even after backtracking at the enclosing scope.
-
+
XXXX what if minimal match and we are at the
initial run of {n,m}? */
if ((mincount != maxcount - 1) && (maxcount != REG_INFTY))
f &= ~SCF_WHILEM_VISITED_POS;
/* This will finish on WHILEM, setting scan, or on NULL: */
- minnext = study_chunk(pRExC_state, &scan, &deltanext, last, data,
- mincount == 0
+ minnext = study_chunk(pRExC_state, &scan, &deltanext, last, data,
+ mincount == 0
? (f & ~SCF_DO_SUBSTR) : f);
if (flags & SCF_DO_STCLASS)
cl_or(pRExC_state, data->start_class, &this_class);
}
else if (flags & SCF_DO_STCLASS_AND) {
- /* Switch to OR mode: cache the old value of
+ /* Switch to OR mode: cache the old value of
* data->start_class */
StructCopy(data->start_class, &and_with,
struct regnode_charclass_class);
}
if (!scan) /* It was not CURLYX, but CURLY. */
scan = next;
- if (ckWARN(WARN_REGEXP) && (minnext + deltanext == 0)
+ if (ckWARN(WARN_REGEXP) && (minnext + deltanext == 0)
&& !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
&& maxcount <= REG_INFTY/3) /* Complement check for big count */
{
}
min += minnext * mincount;
- is_inf_internal |= ((maxcount == REG_INFTY
+ is_inf_internal |= ((maxcount == REG_INFTY
&& (minnext + deltanext) > 0)
|| deltanext == I32_MAX);
is_inf |= is_inf_internal;
delta += (minnext + deltanext) * maxcount - minnext * mincount;
/* Try powerful optimization CURLYX => CURLYN. */
- if ( OP(oscan) == CURLYX && data
+ if ( OP(oscan) == CURLYX && data
&& data->flags & SF_IN_PAR
&& !(data->flags & SF_HAS_EVAL)
&& !deltanext && minnext == 1 ) {
nxt = regnext(nxt);
if (!strchr((char*)PL_simple,OP(nxt))
&& !(PL_regkind[(U8)OP(nxt)] == EXACT
- && STR_LEN(nxt) == 1))
+ && STR_LEN(nxt) == 1))
goto nogo;
nxt2 = nxt;
nxt = regnext(nxt);
- if (OP(nxt) != CLOSE)
+ if (OP(nxt) != CLOSE)
goto nogo;
/* Now we know that nxt2 is the only contents: */
oscan->flags = ARG(nxt);
OP(nxt) = OPTIMIZED; /* was CLOSE. */
OP(nxt + 1) = OPTIMIZED; /* was count. */
NEXT_OFF(nxt+ 1) = 0; /* just for consistancy. */
-#endif
+#endif
}
nogo:
/* Try optimization CURLYX => CURLYM. */
- if ( OP(oscan) == CURLYX && data
+ if ( OP(oscan) == CURLYX && data
&& !(data->flags & SF_HAS_PAR)
&& !(data->flags & SF_HAS_EVAL)
&& !deltanext ) {
OP(oscan) = CURLYM;
while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
- && (OP(nxt2) != WHILEM))
+ && (OP(nxt2) != WHILEM))
nxt = nxt2;
OP(nxt2) = SUCCEED; /* Whas WHILEM */
/* Need to optimize away parenths. */
/* Set the parenth number. */
regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
- if (OP(nxt) != CLOSE)
+ if (OP(nxt) != CLOSE)
FAIL("Panic opt close");
oscan->flags = ARG(nxt);
OP(nxt1) = OPTIMIZED; /* was OPEN. */
OP(nxt + 1) = OPTIMIZED; /* was count. */
NEXT_OFF(nxt1 + 1) = 0; /* just for consistancy. */
NEXT_OFF(nxt + 1) = 0; /* just for consistancy. */
-#endif
+#endif
#if 0
while ( nxt1 && (OP(nxt1) != WHILEM)) {
regnode *nnxt = regnext(nxt1);
-
+
if (nnxt == nxt) {
if (reg_off_by_arg[OP(nxt1)])
ARG_SET(nxt1, nxt2 - nxt1);
}
#endif
/* Optimize again: */
- study_chunk(pRExC_state, &nxt1, &deltanext, nxt,
+ study_chunk(pRExC_state, &nxt1, &deltanext, nxt,
NULL, 0);
}
else
PREVOPER(nxt)->flags = data->whilem_c
| (RExC_whilem_seen << 4); /* On WHILEM */
}
- if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
+ if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
pars++;
if (flags & SCF_DO_SUBSTR) {
SV *last_str = Nullsv;
int counted = mincount != 0;
if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
- I32 b = pos_before >= data->last_start_min
+ I32 b = pos_before >= data->last_start_min
? pos_before : data->last_start_min;
STRLEN l;
char *s = SvPV(data->last_found, l);
/* What was added is a constant string */
if (mincount > 1) {
SvGROW(last_str, (mincount * l) + 1);
- repeatcpy(SvPVX(last_str) + l,
+ repeatcpy(SvPVX(last_str) + l,
SvPVX(last_str), l, mincount - 1);
SvCUR(last_str) *= mincount;
/* Add additional parts. */
- SvCUR_set(data->last_found,
+ SvCUR_set(data->last_found,
SvCUR(data->last_found) - l);
sv_catsv(data->last_found, last_str);
data->last_end += l * (mincount - 1);
if (mincount && last_str) {
sv_setsv(data->last_found, last_str);
data->last_end = data->pos_min;
- data->last_start_min =
+ data->last_start_min =
data->pos_min - CHR_SVLEN(last_str);
- data->last_start_max = is_inf
- ? I32_MAX
+ data->last_start_max = is_inf
+ ? I32_MAX
: data->pos_min + data->pos_delta
- CHR_SVLEN(last_str);
}
else {
for (value = 0; value < 256; value++)
if (isALNUM(value))
- ANYOF_BITMAP_SET(data->start_class, value);
+ ANYOF_BITMAP_SET(data->start_class, value);
}
}
break;
else {
for (value = 0; value < 256; value++)
if (!isALNUM(value))
- ANYOF_BITMAP_SET(data->start_class, value);
+ ANYOF_BITMAP_SET(data->start_class, value);
}
}
break;
else {
for (value = 0; value < 256; value++)
if (isSPACE(value))
- ANYOF_BITMAP_SET(data->start_class, value);
+ ANYOF_BITMAP_SET(data->start_class, value);
}
}
break;
else {
for (value = 0; value < 256; value++)
if (!isSPACE(value))
- ANYOF_BITMAP_SET(data->start_class, value);
+ ANYOF_BITMAP_SET(data->start_class, value);
}
}
break;
else {
for (value = 0; value < 256; value++)
if (isDIGIT(value))
- ANYOF_BITMAP_SET(data->start_class, value);
+ ANYOF_BITMAP_SET(data->start_class, value);
}
}
break;
else {
for (value = 0; value < 256; value++)
if (!isDIGIT(value))
- ANYOF_BITMAP_SET(data->start_class, value);
+ ANYOF_BITMAP_SET(data->start_class, value);
}
}
break;
int f = 0;
data_fake.flags = 0;
- if (data) {
+ if (data) {
data_fake.whilem_c = data->whilem_c;
data_fake.last_closep = data->last_closep;
}
finish:
*scanp = scan;
*deltap = is_inf_internal ? I32_MAX : delta;
- if (flags & SCF_DO_SUBSTR && is_inf)
+ if (flags & SCF_DO_SUBSTR && is_inf)
data->pos_delta = I32_MAX - data->pos_min;
if (is_par > U8_MAX)
is_par = 0;
S_add_data(pTHX_ RExC_state_t *pRExC_state, I32 n, char *s)
{
if (RExC_rx->data) {
- Renewc(RExC_rx->data,
- sizeof(*RExC_rx->data) + sizeof(void*) * (RExC_rx->data->count + n - 1),
+ Renewc(RExC_rx->data,
+ sizeof(*RExC_rx->data) + sizeof(void*) * (RExC_rx->data->count + n - 1),
char, struct reg_data);
Renew(RExC_rx->data->what, RExC_rx->data->count + n, U8);
RExC_rx->data->count += n;
{
int i = 0;
char *s = PerlEnv_getenv("PERL_RE_COLORS");
-
+
if (s) {
PL_colors[0] = s = savepv(s);
while (++i < 6) {
PL_colors[i] = s = "";
}
} else {
- while (i < 6)
+ while (i < 6)
PL_colors[i++] = "";
}
PL_colorset = 1;
first = NEXTOPER(first);
goto again;
}
- if (sawplus && (!sawopen || !RExC_sawback)
+ if (sawplus && (!sawopen || !RExC_sawback)
&& !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
/* x+ must match at the 1st pos of run of x's */
r->reganch |= ROPT_SKIP;
/* Scan is after the zeroth branch, first is atomic matcher. */
- DEBUG_r(PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
(IV)(first - scan + 1)));
/*
* If there's something expensive in the r.e., find the
minlen = study_chunk(pRExC_state, &first, &fake, scan + RExC_size, /* Up to end */
&data, SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag);
if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
- && data.last_start_min == 0 && data.last_end > 0
+ && data.last_start_min == 0 && data.last_end > 0
&& !RExC_seen_zerolen
&& (!(RExC_seen & REG_SEEN_GPOS) || (r->reganch & ROPT_ANCH_GPOS)))
r->reganch |= ROPT_CHECK_ALL;
SvREFCNT_dec(data.longest_fixed);
longest_fixed_length = 0;
}
- if (r->regstclass
+ if (r->regstclass
&& (OP(r->regstclass) == REG_ANY || OP(r->regstclass) == SANY))
r->regstclass = NULL;
if ((!r->anchored_substr || r->anchored_offset) && stclass_flag
SV *sv;
I32 n = add_data(pRExC_state, 1, "f");
- New(1006, RExC_rx->data->data[n], 1,
+ New(1006, RExC_rx->data->data[n], 1,
struct regnode_charclass_class);
StructCopy(data.start_class,
(struct regnode_charclass_class*)RExC_rx->data->data[n],
SV *sv;
I32 n = add_data(pRExC_state, 1, "f");
- New(1006, RExC_rx->data->data[n], 1,
+ New(1006, RExC_rx->data->data[n], 1,
struct regnode_charclass_class);
StructCopy(data.start_class,
(struct regnode_charclass_class*)RExC_rx->data->data[n],
}
r->minlen = minlen;
- if (RExC_seen & REG_SEEN_GPOS)
+ if (RExC_seen & REG_SEEN_GPOS)
r->reganch |= ROPT_GPOS_SEEN;
if (RExC_seen & REG_SEEN_LOOKBEHIND)
r->reganch |= ROPT_LOOKBEHIND_SEEN;
switch (paren) {
case '<':
RExC_seen |= REG_SEEN_LOOKBEHIND;
- if (*RExC_parse == '!')
+ if (*RExC_parse == '!')
paren = ',';
- if (*RExC_parse != '=' && *RExC_parse != '!')
+ if (*RExC_parse != '=' && *RExC_parse != '!')
goto unknown;
RExC_parse++;
case '=':
while (count && (c = *RExC_parse)) {
if (c == '\\' && RExC_parse[1])
RExC_parse++;
- else if (c == '{')
+ else if (c == '{')
count++;
- else if (c == '}')
+ else if (c == '}')
count--;
RExC_parse++;
}
if (*RExC_parse != ')')
{
- RExC_parse = s;
+ RExC_parse = s;
vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
}
if (!SIZE_ONLY) {
AV *av;
-
- if (RExC_parse - 1 - s)
+
+ if (RExC_parse - 1 - s)
sv = newSVpvn(s, RExC_parse - 1 - s);
else
sv = newSVpvn("", 0);
case '(':
{
if (RExC_parse[0] == '?') {
- if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
- || RExC_parse[1] == '<'
+ if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
+ || RExC_parse[1] == '<'
|| RExC_parse[1] == '{') { /* Lookahead or eval. */
I32 flag;
ret->flags = 1;
regtail(pRExC_state, ret, reg(pRExC_state, 1, &flag));
goto insert_if;
- }
+ }
}
else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
parno = atoi(RExC_parse++);
register regnode *latest;
I32 flags = 0, c = 0;
- if (first)
+ if (first)
ret = NULL;
else {
- if (!SIZE_ONLY && RExC_extralen)
+ if (!SIZE_ONLY && RExC_extralen)
ret = reganode(pRExC_state, BRANCHJ,0);
else
ret = reg_node(pRExC_state, BRANCH);
}
- if (!first && SIZE_ONLY)
+ if (!first && SIZE_ONLY)
RExC_extralen += 1; /* BRANCHJ */
-
+
*flagp = WORST; /* Tentatively. */
RExC_parse--;
if (!(flags&HASWIDTH) && op != '?')
vFAIL("Regexp *+ operand could be empty");
-#endif
+#endif
nextchar(pRExC_state);
break;
case '$':
nextchar(pRExC_state);
- if (*RExC_parse)
+ if (*RExC_parse)
RExC_seen_zerolen++;
if (RExC_flags16 & PMf_MULTILINE)
ret = reg_node(pRExC_state, MEOL);
case 'x':
if (*++p == '{') {
char* e = strchr(p, '}');
-
+
if (!e) {
RExC_parse = p + 1;
vFAIL("Missing right brace on \\x{}");
*RExC_parse == '.')) {
char c = *RExC_parse;
char* s = RExC_parse++;
-
+
while (RExC_parse < RExC_end && *RExC_parse != c)
RExC_parse++;
if (RExC_parse == RExC_end)
case 'x':
if (*RExC_parse == '{') {
e = strchr(RExC_parse++, '}');
- if (!e)
+ if (!e)
vFAIL("Missing right brace on \\x{}");
numlen = 1; /* allow underscores */
value = (UV)scan_hex(RExC_parse,
ANYOF_FLAGS(ret) = ANYOF_UNICODE_ALL;
}
- if (!SIZE_ONLY) {
+ if (!SIZE_ONLY) {
AV *av = newAV();
SV *rv;
register regnode *dst;
register regnode *place;
register int offset = regarglen[(U8)op];
-
+
/* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
if (SIZE_ONLY) {
(int)(2*l + 1), "", SvPVX(sv));
if (next == NULL) /* Next ptr. */
PerlIO_printf(Perl_debug_log, "(0)");
- else
+ else
PerlIO_printf(Perl_debug_log, "(%"IVdf")", (IV)(next - start));
(void)PerlIO_putc(Perl_debug_log, '\n');
after_print:
if (PL_regkind[(U8)op] == BRANCHJ) {
- register regnode *nnode = (OP(next) == LONGJMP
- ? regnext(next)
+ register regnode *nnode = (OP(next) == LONGJMP
+ ? regnext(next)
: next);
if (last && nnode > last)
nnode = last;
/* Header fields of interest. */
if (r->anchored_substr)
PerlIO_printf(Perl_debug_log,
- "anchored `%s%.*s%s'%s at %"IVdf" ",
+ "anchored `%s%.*s%s'%s at %"IVdf" ",
PL_colors[0],
(int)(SvCUR(r->anchored_substr) - (SvTAIL(r->anchored_substr)!=0)),
- SvPVX(r->anchored_substr),
+ SvPVX(r->anchored_substr),
PL_colors[1],
SvTAIL(r->anchored_substr) ? "$" : "",
(IV)r->anchored_offset);
if (r->float_substr)
PerlIO_printf(Perl_debug_log,
- "floating `%s%.*s%s'%s at %"IVdf"..%"UVuf" ",
+ "floating `%s%.*s%s'%s at %"IVdf"..%"UVuf" ",
PL_colors[0],
- (int)(SvCUR(r->float_substr) - (SvTAIL(r->float_substr)!=0)),
+ (int)(SvCUR(r->float_substr) - (SvTAIL(r->float_substr)!=0)),
SvPVX(r->float_substr),
PL_colors[1],
SvTAIL(r->float_substr) ? "$" : "",
(IV)r->float_min_offset, (UV)r->float_max_offset);
if (r->check_substr)
- PerlIO_printf(Perl_debug_log,
- r->check_substr == r->float_substr
+ PerlIO_printf(Perl_debug_log,
+ r->check_substr == r->float_substr
? "(checking floating" : "(checking anchored");
if (r->reganch & ROPT_NOSCAN)
PerlIO_printf(Perl_debug_log, " noscan");
{
SV *lv;
SV *sw = regclass_swash(o, FALSE, &lv);
-
+
if (lv) {
if (sw) {
UV i;
U8 s[UTF8_MAXLEN+1];
-
+
for (i = 0; i <= 256; i++) { /* just the first 256 */
U8 *e = uv_to_utf8(s, i);
rangestart = i;
} else if (rangestart != -1) {
U8 *p;
-
+
if (i <= rangestart + 3)
for (; rangestart < i; rangestart++) {
for(e = uv_to_utf8(s, rangestart), p = s; p < e; p++)
{
char *s = savepv(SvPVX(lv));
char *origs = s;
-
+
while(*s && *s != '\n') s++;
-
+
if (*s == '\n') {
char *t = ++s;
sv_catpv(sv, t);
}
-
+
Safefree(origs);
}
}
void
Perl_save_re_context(pTHX)
-{
+{
#if 0
SAVEPPTR(RExC_precomp); /* uncompiled string. */
SAVEI32(RExC_npar); /* () count. */
SAVEVPTR(PL_reglastparen); /* Similarly for lastparen. */
SAVEPPTR(PL_regtill); /* How far we are required to go. */
SAVEI8(PL_regprev); /* char before regbol, \n if none */
- SAVEVPTR(PL_reg_start_tmp); /* from regexec.c */
+ SAVEGENERICPV(PL_reg_start_tmp); /* from regexec.c */
PL_reg_start_tmp = 0;
- SAVEFREEPV(PL_reg_start_tmp);
SAVEI32(PL_reg_start_tmpl); /* from regexec.c */
PL_reg_start_tmpl = 0;
SAVEVPTR(PL_regdata);
SAVEVPTR(PL_reg_curpm); /* from regexec.c */
SAVEI32(PL_regnpar); /* () count. */
#ifdef DEBUGGING
- SAVEPPTR(PL_reg_starttry); /* from regexec.c */
+ SAVEPPTR(PL_reg_starttry); /* from regexec.c */
#endif
}
SSPUSHINT(PL_regsize);
SSPUSHINT(*PL_reglastparen);
SSPUSHPTR(PL_reginput);
- SSPUSHINT(paren_elems_to_push + (REGCP_PAREN_ELEMS - 1));
+#define REGCP_FRAME_ELEMS 2
+/* REGCP_FRAME_ELEMS are part of the REGCP_OTHER_ELEMS and
+ * are needed for the regexp context stack bookkeeping. */
+ SSPUSHINT(paren_elems_to_push + REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
SSPUSHINT(SAVEt_REGCONTEXT); /* Magic cookie. */
+
return retval;
}
PL_regsize = SSPOPINT;
/* Now restore the parentheses context. */
- for (i -= (REGCP_PAREN_ELEMS - 1); i > 0; i -= REGCP_PAREN_ELEMS) {
+ for (i -= (REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
+ i > 0; i -= REGCP_PAREN_ELEMS) {
paren = (U32)SSPOPINT;
PL_reg_start_tmp[paren] = (char *) SSPOPPTR;
PL_regstartp[paren] = SSPOPINT;
I32 numtype = 0;
I32 sawinf = 0;
STRLEN len;
+#ifdef USE_LOCALE_NUMERIC
+ bool specialradix = FALSE;
+#endif
if (SvPOK(sv)) {
sbegin = SvPVX(sv);
if (*s == '.'
#ifdef USE_LOCALE_NUMERIC
- || IS_NUMERIC_RADIX(*s)
+ || (specialradix = IS_NUMERIC_RADIX(s))
#endif
) {
- s++;
+#ifdef USE_LOCALE_NUMERIC
+ if (specialradix)
+ s += SvCUR(PL_numeric_radix);
+ else
+#endif
+ s++;
numtype |= IS_NUMBER_NOT_INT;
while (isDIGIT(*s)) /* optional digits after the radix */
s++;
}
else if (*s == '.'
#ifdef USE_LOCALE_NUMERIC
- || IS_NUMERIC_RADIX(*s)
+ || (specialradix = IS_NUMERIC_RADIX(s))
#endif
) {
- s++;
+#ifdef USE_LOCALE_NUMERIC
+ if (specialradix)
+ s += SvCUR(PL_numeric_radix);
+ else
+#endif
+ s++;
numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
/* no digits before the radix means we need digits after it */
if (isDIGIT(*s)) {
Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
{
register char *dptr;
- {
- /* len is STRLEN which is unsigned, need to copy to signed */
- IV iv = len;
- assert(iv >= 0);
- }
+
SV_CHECK_THINKFIRST(sv);
if (!ptr) {
(void)SvOK_off(sv);
return;
}
+ else {
+ /* len is STRLEN which is unsigned, need to copy to signed */
+ IV iv = len;
+ assert(iv >= 0);
+ }
(void)SvUPGRADE(sv, SVt_PV);
SvGROW(sv, len + 1);
/* do not utf8ize the comparands as a side-effect */
if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
+ bool is_utf8 = TRUE;
+
if (PL_hints & HINT_UTF8_DISTINCT)
return FALSE;
if (SvUTF8(sv1)) {
- (void)utf8_to_bytes((U8*)(pv1 = savepvn(pv1, cur1)), &cur1);
- {
- IV scur1 = cur1;
- if (scur1 < 0) {
- Safefree(pv1);
- return 0;
- }
- }
- pv1tmp = TRUE;
+ char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
+ if (is_utf8)
+ return 0;
+ pv1tmp = (pv != pv1);
+ pv1 = pv;
}
else {
- (void)utf8_to_bytes((U8*)(pv2 = savepvn(pv2, cur2)), &cur2);
- {
- IV scur2 = cur2;
- if (scur2 < 0) {
- Safefree(pv2);
- return 0;
- }
- }
- pv2tmp = TRUE;
+ char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
+ if (is_utf8)
+ return 0;
+ pv2tmp = (pv != pv2);
+ pv2 = pv;
}
}
len = -len;
is_utf8 = TRUE;
}
+ if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+ src = (char*)bytes_from_utf8((U8*)src, (STRLEN*)&len, &is_utf8);
if (!hash)
PERL_HASH(hash, src, len);
new_SV(sv);
PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
PL_numeric_standard = proto_perl->Inumeric_standard;
PL_numeric_local = proto_perl->Inumeric_local;
- PL_numeric_radix = proto_perl->Inumeric_radix;
+ PL_numeric_radix = sv_dup_inc(proto_perl->Inumeric_radix);
#endif /* !USE_LOCALE_NUMERIC */
/* utf8 character classes */
}
else {
$next = $1, $ok = 0, last if /^not ok ([0-9]*)/;
- if (/^ok (\d+)(\s*#.*)?$/ && $1 == $next) {
+ if (/^ok (\d+)(\s*#.*)?/ && $1 == $next) {
$next = $next + 1;
}
elsif (/^Bail out!\s*(.*)/i) { # magic words
die "/dev/null IS NOT A CHARACTER SPECIAL FILE!!!!\n" unless -c '/dev/null';
}
-open(try, "../Configure") || (die "Can't open ../Configure.");
+open(try, "harness") || (die "Can't open harness.");
if (<try> ne '') {print "ok 7\n";} else {print "not ok 7\n";}
$Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'dos' or
$^O eq 'os2' or $^O eq 'mint' or $^O eq 'cygwin');
-open($TST, '../Configure') || (die "Can't open ../Configure");
+open($TST, 'harness') || (die "Can't open harness");
binmode $TST if $Is_Dosish;
if (eof(tst)) { print "not ok 1\n"; } else { print "ok 1\n"; }
if ($. == 0) { print "not ok 14\n"; } else { print "ok 14\n"; }
$curline = $.;
-open(other, '../Configure') || (die "Can't open ../Configure");
+open(other, 'harness') || (die "Can't open harness: $!");
binmode other if $^O eq 'MSWin32';
{
print "ok 17\n";
}
-print F $b,"\n"; # This upgrades $b!
+print F $b,"\n"; # Don't upgrades $b
{ # Check byte length of $b
use bytes; my $y = length($b);
-print "not " unless $y == 2;
+print "not ($y) " unless $y == 1;
print "ok 18\n";
}
{ my $x = tell(F);
{ use bytes; $y += 3;}
- print "not " unless $x == $y;
+ print "not ($x,$y) " unless $x == $y;
print "ok 19\n";
}
open F, "a" or die $!; # Not UTF
$x = <F>;
chomp($x);
-print "not " unless $x eq v196.172.194.130;
+printf "not (%vd) ", $x unless $x eq v196.172.194.130;
print "ok 20\n";
open F, "<:utf8", "a" or die $!;
$x = <F>;
chomp($x);
close F;
-print "not " unless $x eq chr(300).chr(130);
+printf "not (%vd) ", $x unless $x eq chr(300).chr(130);
print "ok 21\n";
# Now let's make it suffer.
use strict;
use warnings;
use Config;
-use File::Find;
my %Core_Modules;
-find(sub {
- if ($File::Find::name =~ m!^lib\W+(.+)\.pm$!i) {
- my $module = $1;
- $module =~ s/[^\w-]/::/g;
- $Core_Modules{$module}++;
- }
- }, "lib");
+unless (open(MANIFEST, "MANIFEST")) {
+ die "$0: failed to open 'MANIFEST': $!\n";
+}
+
+sub add_by_name {
+ $Core_Modules{$_[0]}++;
+}
+
+while (<MANIFEST>) {
+ next unless m!^lib/(\S+?)\.pm!;
+ my $module = $1;
+ $module =~ s!/!::!g;
+ add_by_name($module);
+}
+
+close(MANIFEST);
# Delete stuff that can't be tested here.
-sub delete_unless_in_extensions {
- delete $Core_Modules{$_[0]} unless $Config{extensions} =~ /\b$_[0]\b/;
+sub delete_by_name {
+ delete $Core_Modules{$_[0]};
+}
+
+sub has_extension {
+ $Config{extensions} =~ /\b$_[0]\b/i;
+}
+
+sub delete_unless_has_extension {
+ delete $Core_Modules{$_[0]} unless has_extension($_[0]);
}
foreach my $known_extension (split(' ', $Config{known_extensions})) {
- delete_unless_in_extensions($known_extension);
+ delete_unless_has_extension($known_extension);
}
sub delete_by_prefix {
- delete @Core_Modules{grep { /^$_[0]/ } keys %Core_Modules};
+ for my $match (grep { /^$_[0]/ } keys %Core_Modules) {
+ delete_by_name($match);
+ }
}
-delete $Core_Modules{'CGI::Fast'}; # won't load without FCGI
+delete_by_name('CGI::Fast'); # won't load without FCGI
-delete $Core_Modules{'Devel::DProf'}; # needs to be run as -d:DProf
+delete_by_name('Devel::DProf'); # needs to be run as -d:DProf
delete_by_prefix('ExtUtils::MM_'); # ExtUtils::MakeMaker's domain
delete_by_prefix('File::Spec::'); # File::Spec's domain
-$Core_Modules{'File::Spec::Functions'}++; # put this back
+add_by_name('File::Spec::Functions'); # put this back
-unless ($Config{extensions} =~ /\bThread\b/) {
- delete $Core_Modules{Thread};
+sub using_feature {
+ my $use = "use$_[0]";
+ exists $Config{$use} &&
+ defined $Config{$use} &&
+ $Config{$use} eq 'define';
+}
+
+unless (using_feature('threads') && has_extension('Thread')) {
+ delete_by_name('Thread');
delete_by_prefix('Thread::');
}
delete_by_prefix('unicode::');
-$Core_Modules{'unicode::distinct'}++; # put this back
+add_by_name('unicode::distinct'); # put this back
# Okay, this is the list.
$test_num++;
}
-
-# We do this as a separate process else we'll blow the hell out of our
-# namespace.
+# We do this as a separate process else we'll blow the hell
+# out of our namespace.
sub compile_module {
- my($module) = @_;
+ my ($module) = $_[0];
return scalar `./perl -Ilib t/lib/compmod.pl $module` =~ /^ok/;
}
my $Is_VMS = $^O eq 'VMS';
$a = `$^X "-I../lib" "-MO=Deparse" -anle 1 2>&1`;
$a =~ s/-e syntax OK\n//g;
+$a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
+$a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
$b = <<'EOF';
LINE: while (defined($_ = <ARGV>)) {
if ($Config{static_ext} eq ' ') {
$b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,'
. '-umain,-ustrict,-uwarnings';
+ if (ord('A') == 193) { # EBCDIC sort order is qw(a A) not qw(A a)
+ $b = join ',', sort split /,/, $b;
+ }
print "# [$a] vs [$b]\nnot " if $a ne $b;
ok;
} else {
print "# use5005threads: test $test skipped\n";
} else {
$a = `$^X "-I../lib" "-MO=Showlex" -e "my %one" 2>&1`;
- print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s;
+ if (ord('A') != 193) { # ASCIIish
+ print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s;
+ }
+ else { # EBCDICish C<1: PVNV (0x1a7ede34) "%\226\225\205">
+ print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%\\[0-9].*sv_undef.*HV/s;
+ }
}
ok;
$test = 0;
$| = 1;
-print "1..362\n";
+print "1..406\n";
while (<DATA>) {
chop;
if (s/^&//) {
$try .= "-\$x;";
} elsif ($f eq "fabs") {
$try .= "abs \$x;";
+ } elsif ($f eq "fint") {
+ $try .= "int \$x;";
} elsif ($f eq "fround") {
$try .= "0+\$x->fround($args[1]);";
} elsif ($f eq "ffround") {
}
}
}
+
+{
+ use Math::BigFloat ':constant';
+
+ $test++;
+ # print "# " . 2. * '1427247692705959881058285969449495136382746624' . "\n";
+ print "not "
+ unless 2. * '1427247692705959881058285969449495136382746624'
+ == "2854495385411919762116571938898990272765493248.";
+ print "ok $test\n";
+ $test++;
+ @a = ();
+ for ($i = 1.; $i < 10; $i++) {
+ push @a, $i;
+ }
+ print "not " unless "@a" eq "1. 2. 3. 4. 5. 6. 7. 8. 9.";
+ print "ok $test\n";
+}
+
__END__
&fnorm
abc:NaN.
+100:10.
+123.456:11.11107555549866648462149404118219234119
+15241.383936:123.456
+&fint
++0:+0
++1:+1
++11111111111111111234:+11111111111111111234
+-1:-1
+-11111111111111111234:-11111111111111111234
++0.3:+0
++1.3:+1
++23.3:+23
++12345678901234567890:+12345678901234567890
++12345678901234567.890:+12345678901234567
++12345678901234567890E13:+123456789012345678900000000000000
++12345678901234567.890E13:+123456789012345678900000000000
++12345678901234567890E-3:+12345678901234567
++12345678901234567.890E-3:+12345678901234
++12345678901234567890E-13:+1234567
++12345678901234567.890E-13:+1234
++12345678901234567890E-17:+123
++12345678901234567.890E-16:+1
++12345678901234567.890E-17:+0
++12345678901234567890E-19:+1
++12345678901234567890E-20:+0
++12345678901234567890E-21:+0
++12345678901234567890E-225:+0
+-0:+0
+-0.3:+0
+-1.3:-1
+-23.3:-23
+-12345678901234567890:-12345678901234567890
+-12345678901234567.890:-12345678901234567
+-12345678901234567890E13:-123456789012345678900000000000000
+-12345678901234567.890E13:-123456789012345678900000000000
+-12345678901234567890E-3:-12345678901234567
+-12345678901234567.890E-3:-12345678901234
+-12345678901234567890E-13:-1234567
+-12345678901234567.890E-13:-1234
+-12345678901234567890E-17:-123
+-12345678901234567.890E-16:-1
+-12345678901234567.890E-17:+0
+-12345678901234567890E-19:-1
+-12345678901234567890E-20:+0
+-12345678901234567890E-21:+0
+-12345678901234567890E-225:+0
$test = 0;
$| = 1;
-print "1..278\n";
+print "1..283\n";
while (<DATA>) {
chop;
if (s/^&//) {
$try .= "-\$x;";
} elsif ($f eq "babs") {
$try .= "abs \$x;";
+ } elsif ($f eq "bint") {
+ $try .= "int \$x;";
} else {
$try .= "\$y = new Math::BigInt \"$args[1]\";";
if ($f eq "bcmp"){
+0:-1
+8:-9
+281474976710656:-281474976710657
+&bint
++0:+0
++1:+1
++11111111111111111234:+11111111111111111234
+-1:-1
+-11111111111111111234:-11111111111111111234
}
$| = 1;
-print "1..13\n";
+print "1..14\n";
use charnames ':full';
$encoded_bet = "\327\221";
sub to_bytes {
- use bytes;
- "".shift;
+ pack"a*", shift;
}
{
print "ok 13\n";
}
+{
+ use charnames qw(:full);
+ use utf8;
+ print "not " unless "\x{100}\N{CENT SIGN}" eq "\x{100}"."\N{CENT SIGN}";
+ print "ok 14\n";
+}
+
print "\nperl: $perl\n" if $opt_v;
if( ! -f $perl ){ die "Where's Perl?" }
-if( ! -f $dpp ){ die "Where's dprofpp?" }
+if( ! -f $dpp ) {
+ ($dpp = $^X) =~ s@(^.*)[/|\\].*@$1/dprofpp@;
+ die "Where's dprofpp?" if( ! -f $dpp );
+}
sub dprofpp {
my $switches = shift;
REFCNT = 1
FLAGS = \\(NOK,pNOK\\)
IV = 0
- NV = 789\\.1
+ NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
PV = $ADDR "789"\\\0
CUR = 3
LEN = 4');
--- /dev/null
+print <<DUMMY_TEST;
+1..5
+ok 1
+ok 2
+ok 3
+Bail out! GERONIMMMOOOOOO!!!
+ok 4
+ok 5
+DUMMY_TEST
--- /dev/null
+print <<DUMMY_TEST;
+1..10 todo 4 10
+ok 1
+ok 2 basset hounds got long ears
+not ok 3 all hell broke lose
+ok 4
+ok
+ok 6
+ok 7 # Skip contract negociations
+ok 8
+not ok 9
+not ok 10
+DUMMY_TEST
--- /dev/null
+print <<DUMMY_TEST;
+1..5
+ok 1 Interlock activated
+ok 2 Megathrusters are go
+ok 3 Head formed
+ok 4 Blazing sword formed
+ok 5 Robeast destroyed
+DUMMY_TEST
--- /dev/null
+print <<DUMMY_TEST
+1..10
+ok 1
+ok 2
+ok 3
+ok 4
+ok 4
+ok 5
+ok 6
+ok 7
+ok 8
+ok 9
+ok 10
+DUMMY_TEST
--- /dev/null
+print <<DUMMY_TEST;
+# comments
+ok 1
+ok 2
+ok 3
+ok 4
+# comment
+1..4
+# more ignored stuff
+# and yet more
+DUMMY_TEST
--- /dev/null
+print <<DUMMY_TEST;
+1..5
+ok
+ok
+not ok
+ok
+ok
+DUMMY_TEST
--- /dev/null
+print <<DUMMY_TEST;
+1..5
+ok 1
+ok 2
+ok 3
+ok 4
+ok 5
+DUMMY_TEST
--- /dev/null
+print <<DUMMY_TEST;
+1..5
+ok 1
+not ok 2
+ok 3
+ok 4
+not ok 5
+DUMMY_TEST
--- /dev/null
+print <<DUMMY_TEST;
+1..5
+ok 1
+ok 2 # skipped rain delay
+ok 3
+ok 4
+ok 5
+DUMMY_TEST
--- /dev/null
+print <<DUMMY_TEST;
+1..0 # skip: rope
+DUMMY_TEST
--- /dev/null
+print <<DUMMY_TEST;
+1..5 todo 3 2;
+ok 1
+ok 2
+not ok 3
+ok 4
+ok 5
+DUMMY_TEST
--- /dev/null
+print <<DUMMY_TEST;
+# and stuff
+1..5 todo 1 2 4 5;
+# yeah, that
+not ok 1
+# Failed test 1 in t/todo.t at line 9 *TODO*
+ok 2 # (t/todo.t at line 10 TODO?!)
+ok 3
+not ok 4
+# Test 4 got: '0' (t/todo.t at line 12 *TODO*)
+# Expected: '1' (need more tuits)
+ok 5 # (t/todo.t at line 13 TODO?!)
+# woo
+DUMMY_TEST
package main;
+my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0;
+
my $r = ROOT->make;
my $data = '';
-while (<DATA>) {
- next if /^#/;
- $data .= unpack("u", $_);
+if (!$Is_EBCDIC) {
+ while (<DATA>) {
+ next if /^#/;
+ $data .= unpack("u", $_);
+ }
+}
+else {
+ while (<DATA>) {
+ next if /^#$/; # skip comments
+ next if /^#\s+/; # skip comments
+ next if /^[^#]/; # skip uuencoding for ASCII machines
+ s/^#//; # prepare uuencoded data for EBCDIC machines
+ $data .= unpack("u", $_);
+ }
}
-ok 1, length $data == 278;
+my $expected_length = $Is_EBCDIC ? 217 : 278;
+ok 1, length $data == $expected_length;
my $y = thaw($data);
ok 2, 1;
M24U03$586`0"`````0B"6&(&4TE-4$Q%6%@$`@````$(@UAB!E-)35!,15A8
M!`(````!"(188@9324U03$586%A8`````V]B:@0,!``````*6%A8`````W)E
(9F($4D]/5%@`
+#
+# using Storable-0.6@11, output of: print '#' . pack("u", nfreeze(ROOT->make));
+# on OS/390 (cp 1047) original size: 217 bytes
+#
+#M!0,1!-G6UN,#````!00,!!$)X\G%Q&W(P>+(`P````(*!*6!D_$````$DH6H
+#M\0H$I8&3\@````22A:CR`````YF%A@0"````!@B!"(`(?0H(8/-+\?3Q]?D)
+#M```!R`H#]$OU`````Y6DE`0"````!001!N+)U-?3Q0(````!"(`$$@("````
+#M`0B!!!("`@````$(@@02`@(````!"(,$$@("`````0B$`````Y:"D00`````
+#E!`````&(!`(````#"@:BHYF)E8<$``````0$```````````!@0``
--- /dev/null
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+
+# For shutting up Test::Harness.
+package My::Dev::Null;
+use Tie::Handle;
+@ISA = qw(Tie::StdHandle);
+
+sub WRITE { }
+
+
+package main;
+
+# Utility testing functions.
+my $test_num = 1;
+sub ok ($;$) {
+ my($test, $name) = @_;
+ print "not " unless $test;
+ print "ok $test_num";
+ print " - $name" if defined $name;
+ print "\n";
+ $test_num++;
+}
+
+sub eqhash {
+ my($a1, $a2) = @_;
+ return 0 unless keys %$a1 == keys %$a2;
+
+ my $ok = 1;
+ foreach my $k (keys %$a1) {
+ $ok = $a1->{$k} eq $a2->{$k};
+ last unless $ok;
+ }
+
+ return $ok;
+}
+
+
+my $loaded;
+BEGIN { $| = 1; $^W = 1; }
+END {print "not ok $test_num\n" unless $loaded;}
+print "1..$Total_tests\n";
+use Test::Harness;
+$loaded = 1;
+ok(1, 'compile');
+######################### End of black magic.
+
+BEGIN {
+ %samples = (
+ simple => {
+ bonus => 0,
+ max => 5,
+ ok => 5,
+ files => 1,
+ bad => 0,
+ good => 1,
+ tests => 1,
+ sub_skipped=> 0,
+ skipped => 0,
+ },
+ simple_fail => {
+ bonus => 0,
+ max => 5,
+ ok => 3,
+ files => 1,
+ bad => 1,
+ good => 0,
+ tests => 1,
+ sub_skipped => 0,
+ skipped => 0,
+ },
+ descriptive => {
+ bonus => 0,
+ max => 5,
+ ok => 5,
+ files => 1,
+ bad => 0,
+ good => 1,
+ tests => 1,
+ sub_skipped=> 0,
+ skipped => 0,
+ },
+ no_nums => {
+ bonus => 0,
+ max => 5,
+ ok => 4,
+ files => 1,
+ bad => 1,
+ good => 0,
+ tests => 1,
+ sub_skipped=> 0,
+ skipped => 0,
+ },
+ todo => {
+ bonus => 1,
+ max => 5,
+ ok => 5,
+ files => 1,
+ bad => 0,
+ good => 1,
+ tests => 1,
+ sub_skipped=> 0,
+ skipped => 0,
+ },
+ skip => {
+ bonus => 0,
+ max => 5,
+ ok => 5,
+ files => 1,
+ bad => 0,
+ good => 1,
+ tests => 1,
+ sub_skipped=> 1,
+ skipped => 0,
+ },
+ bailout => 0,
+ combined => {
+ bonus => 1,
+ max => 10,
+ ok => 8,
+ files => 1,
+ bad => 1,
+ good => 0,
+ tests => 1,
+ sub_skipped=> 1,
+ skipped => 0
+ },
+ duplicates => {
+ bonus => 0,
+ max => 10,
+ ok => 11,
+ files => 1,
+ bad => 1,
+ good => 0,
+ tests => 1,
+ sub_skipped=> 0,
+ skipped => 0,
+ },
+ header_at_end => {
+ bonus => 0,
+ max => 4,
+ ok => 4,
+ files => 1,
+ bad => 0,
+ good => 1,
+ tests => 1,
+ sub_skipped=> 0,
+ skipped => 0,
+ },
+ skip_all => {
+ bonus => 0,
+ max => 0,
+ ok => 0,
+ files => 1,
+ bad => 0,
+ good => 1,
+ tests => 1,
+ sub_skipped=> 0,
+ skipped => 1,
+ },
+ with_comments => {
+ bonus => 2,
+ max => 5,
+ ok => 5,
+ files => 1,
+ bad => 0,
+ good => 1,
+ tests => 1,
+ sub_skipped=> 0,
+ skipped => 0,
+ },
+ );
+
+ $Total_tests = keys(%samples) + 1;
+}
+
+tie *NULL, 'My::Dev::Null' or die $!;
+
+while (my($test, $expect) = each %samples) {
+ # _runtests() runs the tests but skips the formatting.
+ my($totals, $failed);
+ eval {
+ select NULL; # _runtests() isn't as quiet as it should be.
+ ($totals, $failed) =
+ Test::Harness::_runtests("lib/sample-tests/$test");
+ };
+ select STDOUT;
+
+ unless( $@ ) {
+ ok( eqhash( $expect, {map { $_=>$totals->{$_} } keys %$expect} ),
+ $test );
+ }
+ else { # special case for bailout
+ ok( ($test eq 'bailout' and $@ =~ /Further testing stopped: GERONI/i),
+ $test );
+ }
+}
-#!./perl
+#!./perl -w
-print "1..12\n";
+print "1..109\n";
sub try ($$) {
print +($_[1] ? "ok" : "not ok"), " $_[0]\n";
}
+sub tryeq ($$$) {
+ if ($_[1] == $_[2]) {
+ print "ok $_[0]\n";
+ } else {
+ print "not ok $_[0] # $_[1] != $_[2]\n";
+ }
+}
-try 1, 13 % 4 == 1;
-try 2, -13 % 4 == 3;
-try 3, 13 % -4 == -3;
-try 4, -13 % -4 == -1;
+tryeq 1, 13 % 4, 1;
+tryeq 2, -13 % 4, 3;
+tryeq 3, 13 % -4, -3;
+tryeq 4, -13 % -4, -1;
my $limit = 1e6;
# UVs should behave properly
-try 9, 4063328477 % 65535 == 27407;
-try 10, 4063328477 % 4063328476 == 1;
-try 11, 4063328477 % 2031664238 == 1;
-try 12, 2031664238 % 4063328477 == 2031664238;
+tryeq 9, 4063328477 % 65535, 27407;
+tryeq 10, 4063328477 % 4063328476, 1;
+tryeq 11, 4063328477 % 2031664238, 1;
+tryeq 12, 2031664238 % 4063328477, 2031664238;
+
+# These should trigger wrapping on 32 bit IVs and UVs
+
+tryeq 13, 2147483647 + 0, 2147483647;
+
+# IV + IV promote to UV
+tryeq 14, 2147483647 + 1, 2147483648;
+tryeq 15, 2147483640 + 10, 2147483650;
+tryeq 16, 2147483647 + 2147483647, 4294967294;
+# IV + UV promote to NV
+tryeq 17, 2147483647 + 2147483649, 4294967296;
+# UV + IV promote to NV
+tryeq 18, 4294967294 + 2, 4294967296;
+# UV + UV promote to NV
+tryeq 19, 4294967295 + 4294967295, 8589934590;
+
+# UV + IV to IV
+tryeq 20, 2147483648 + -1, 2147483647;
+tryeq 21, 2147483650 + -10, 2147483640;
+# IV + UV to IV
+tryeq 22, -1 + 2147483648, 2147483647;
+tryeq 23, -10 + 4294967294, 4294967284;
+# IV + IV to NV
+tryeq 24, -2147483648 + -2147483648, -4294967296;
+tryeq 25, -2147483640 + -10, -2147483650;
+
+# Hmm. Don't forget the simple stuff
+tryeq 26, 1 + 1, 2;
+tryeq 27, 4 + -2, 2;
+tryeq 28, -10 + 100, 90;
+tryeq 29, -7 + -9, -16;
+tryeq 30, -63 + +2, -61;
+tryeq 31, 4 + -1, 3;
+tryeq 32, -1 + 1, 0;
+tryeq 33, +29 + -29, 0;
+tryeq 34, -1 + 4, 3;
+tryeq 35, +4 + -17, -13;
+
+# subtraction
+tryeq 36, 3 - 1, 2;
+tryeq 37, 3 - 15, -12;
+tryeq 38, 3 - -7, 10;
+tryeq 39, -156 - 5, -161;
+tryeq 40, -156 - -5, -151;
+tryeq 41, -5 - -12, 7;
+tryeq 42, -3 - -3, 0;
+tryeq 43, 15 - 15, 0;
+
+tryeq 44, 2147483647 - 0, 2147483647;
+tryeq 45, 2147483648 - 0, 2147483648;
+tryeq 46, -2147483648 - 0, -2147483648;
+
+tryeq 47, 0 - -2147483647, 2147483647;
+tryeq 48, -1 - -2147483648, 2147483647;
+tryeq 49, 2 - -2147483648, 2147483650;
+
+tryeq 50, 4294967294 - 3, 4294967291;
+tryeq 51, -2147483648 - -1, -2147483647;
+
+# IV - IV promote to UV
+tryeq 52, 2147483647 - -1, 2147483648;
+tryeq 53, 2147483647 - -2147483648, 4294967295;
+# UV - IV promote to NV
+tryeq 54, 4294967294 - -3, 4294967297;
+# IV - IV promote to NV
+tryeq 55, -2147483648 - +1, -2147483649;
+# UV - UV promote to IV
+tryeq 56, 2147483648 - 2147483650, -2;
+# IV - UV promote to IV
+tryeq 57, 2000000000 - 4000000000, -2000000000;
+
+# No warnings should appear;
+my $a;
+$a += 1;
+tryeq 58, $a, 1;
+undef $a;
+$a += -1;
+tryeq 59, $a, -1;
+undef $a;
+$a += 4294967290;
+tryeq 60, $a, 4294967290;
+undef $a;
+$a += -4294967290;
+tryeq 61, $a, -4294967290;
+undef $a;
+$a += 4294967297;
+tryeq 62, $a, 4294967297;
+undef $a;
+$a += -4294967297;
+tryeq 63, $a, -4294967297;
+
+my $s;
+$s -= 1;
+tryeq 64, $s, -1;
+undef $s;
+$s -= -1;
+tryeq 65, $s, +1;
+undef $s;
+$s -= -4294967290;
+tryeq 66, $s, +4294967290;
+undef $s;
+$s -= 4294967290;
+tryeq 67, $s, -4294967290;
+undef $s;
+$s -= 4294967297;
+tryeq 68, $s, -4294967297;
+undef $s;
+$s -= -4294967297;
+tryeq 69, $s, +4294967297;
+
+# Multiplication
+
+tryeq 70, 1 * 3, 3;
+tryeq 71, -2 * 3, -6;
+tryeq 72, 3 * -3, -9;
+tryeq 73, -4 * -3, 12;
+
+# check with 0xFFFF and 0xFFFF
+tryeq 74, 65535 * 65535, 4294836225;
+tryeq 75, 65535 * -65535, -4294836225;
+tryeq 76, -65535 * 65535, -4294836225;
+tryeq 77, -65535 * -65535, 4294836225;
+
+# check with 0xFFFF and 0x10001
+tryeq 78, 65535 * 65537, 4294967295;
+tryeq 79, 65535 * -65537, -4294967295;
+tryeq 80, -65535 * 65537, -4294967295;
+tryeq 81, -65535 * -65537, 4294967295;
+
+# check with 0x10001 and 0xFFFF
+tryeq 82, 65537 * 65535, 4294967295;
+tryeq 83, 65537 * -65535, -4294967295;
+tryeq 84, -65537 * 65535, -4294967295;
+tryeq 85, -65537 * -65535, 4294967295;
+
+# These should all be dones as NVs
+tryeq 86, 65537 * 65537, 4295098369;
+tryeq 87, 65537 * -65537, -4295098369;
+tryeq 88, -65537 * 65537, -4295098369;
+tryeq 89, -65537 * -65537, 4295098369;
+
+# will overflow an IV (in 32-bit)
+tryeq 90, 46340 * 46342, 0x80001218;
+tryeq 91, 46340 * -46342, -0x80001218;
+tryeq 92, -46340 * 46342, -0x80001218;
+tryeq 93, -46340 * -46342, 0x80001218;
+
+tryeq 94, 46342 * 46340, 0x80001218;
+tryeq 95, 46342 * -46340, -0x80001218;
+tryeq 96, -46342 * 46340, -0x80001218;
+tryeq 97, -46342 * -46340, 0x80001218;
+
+# will overflow a positive IV (in 32-bit)
+tryeq 98, 65536 * 32768, 0x80000000;
+tryeq 99, 65536 * -32768, -0x80000000;
+tryeq 100, -65536 * 32768, -0x80000000;
+tryeq 101, -65536 * -32768, 0x80000000;
+
+tryeq 102, 32768 * 65536, 0x80000000;
+tryeq 103, 32768 * -65536, -0x80000000;
+tryeq 104, -32768 * 65536, -0x80000000;
+tryeq 105, -32768 * -65536, 0x80000000;
+
+# 2147483647 is prime. bah.
+
+tryeq 106, 46339 * 46341, 0x7ffea80f;
+tryeq 107, 46339 * -46341, -0x7ffea80f;
+tryeq 108, -46339 * 46341, -0x7ffea80f;
+tryeq 109, -46339 * -46341, 0x7ffea80f;
#!./perl
-print "1..24\n";
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+}
+
+print "1..26\n";
$h{'abc'} = 'ABC';
$h{'def'} = 'DEF';
print "ok 23\n";
print "#$u{$_}\n" for keys %u; # Used to core dump before change #8056.
print "ok 24\n";
+
+$d = qu"\xe3\x81\x82";
+%u = ($d => "downgrade");
+for (keys %u) {
+ use bytes;
+ print "not " if length ne 3 or $_ ne "\xe3\x81\x82";
+ print "ok 25\n";
+}
+{
+ use bytes;
+ print "not " if length($d) ne 6 or $d ne qu"\xe3\x81\x82";
+ print "ok 26\n";
+}
@a = ('a','b','c','d','e','f','g');
-open(of,'../Configure');
+open(of,'harness') or die "Can't open harness: $!";
while (<of>) {
(3 .. 5) && ($foo .= $_);
}
@INC = '../lib';
}
-print "1..49\n";
+print "1..51\n";
$_ = "abcdefghijklmnopqrstuvwxyz";
print "not " unless sprintf("%vd", $a) eq '196.172.200';
print "ok 49\n";
+# UTF8 range
+
+($a = v300.196.172.302.197.172) =~ tr/\x{12c}-\x{130}/\xc0-\xc4/;
+print "not " unless $a eq v192.196.172.194.197.172;
+print "ok 50\n";
+
+($a = v300.196.172.302.197.172) =~ tr/\xc4-\xc8/\x{12c}-\x{130}/;
+print "not " unless $a eq v300.300.172.302.301.172;
+print "ok 51\n";
test($a =~ /^`1' is not a code reference at/); # 215
}
+{
+ my $c = 0;
+ package ov_int1;
+ use overload '""' => sub { 3+shift->[0] },
+ '0+' => sub { 10+shift->[0] },
+ 'int' => sub { 100+shift->[0] };
+ sub new {my $p = shift; bless [shift], $p}
+
+ package ov_int2;
+ use overload '""' => sub { 5+shift->[0] },
+ '0+' => sub { 30+shift->[0] },
+ 'int' => sub { 'ov_int1'->new(1000+shift->[0]) };
+ sub new {my $p = shift; bless [shift], $p}
+
+ package noov_int;
+ use overload '""' => sub { 2+shift->[0] },
+ '0+' => sub { 9+shift->[0] };
+ sub new {my $p = shift; bless [shift], $p}
+
+ package main;
+
+ my $x = new noov_int 11;
+ my $int_x = int $x;
+ main::test("$int_x" eq 20); # 216
+ $x = new ov_int1 31;
+ $int_x = int $x;
+ main::test("$int_x" eq 131); # 217
+ $x = new ov_int2 51;
+ $int_x = int $x;
+ main::test("$int_x" eq 1054); # 218
+}
+
# make sure that we don't inifinitely recurse
{
my $c = 0;
'bool' => sub { shift },
fallback => 1;
my $x = bless([]);
- main::test("$x" =~ /Recurse=ARRAY/); # 216
- main::test($x); # 217
- main::test($x+0 =~ /Recurse=ARRAY/); # 218
-};
+ main::test("$x" =~ /Recurse=ARRAY/); # 219
+ main::test($x); # 220
+ main::test($x+0 =~ /Recurse=ARRAY/); # 221
+}
+
+
# Last test is:
-sub last {218}
+sub last {221}
$str = "Made w/ JavaScript";
sub veclv : lvalue { vec($str, 2, 32) }
-veclv() = 0x5065726C;
+if (ord('A') != 193) {
+ veclv() = 0x5065726C;
+}
+else { # EBCDIC?
+ veclv() = 0xD7859993;
+}
print "# $str\nnot " unless $str eq "Made w/ PerlScript";
print "ok 62\n";
}
}
-print "1..106\n";
+print "1..107\n";
my $test = 1;
print "ok $test\n";
$test++; # 106
}
+
+{
+ use utf8;
+
+ my $w = 0;
+ local $SIG{__WARN__} = sub { print "#($_[0])\n"; $w++ };
+ my $x = eval q/"\\/ . "\x{100}" . q/"/;;
+
+ print "not " unless $w == 0 && $x eq "\x{100}";
+ print "ok $test\n";
+ $test++; # 107
+}
+
PERLVAR(Tnrs, SV *)
/*
-=for apidoc Amn|SV*|PL_rs
+=for apidoc mn|SV*|PL_rs
The input record separator - C<$/> in Perl space.
-=for apidoc Amn|GV*|PL_last_in_gv
+=for apidoc mn|GV*|PL_last_in_gv
The GV which was last used for a filehandle input operation. (C<< <FH> >>)
-=for apidoc Amn|SV*|PL_ofs_sv
+=for apidoc mn|SV*|PL_ofs_sv
The output field separator - C<$,> in Perl space.
# define pthread_mutexattr_init(a) pthread_mutexattr_create(a)
# define pthread_mutexattr_settype(a,t) pthread_mutexattr_setkind_np(a,t)
# endif
+# if defined(__hpux) && defined(__ux_version) && __ux_version <= 1020
+# define pthread_attr_init(a) pthread_attr_create(a)
+ /* XXX pthread_setdetach_np() missing in DCE threads on HP-UX 10.20 */
+# define PTHREAD_CREATE(t,a,s,d) pthread_create(t,a,s,d)
+# define pthread_key_create(k,d) pthread_keycreate(k,(pthread_destructor_t)(d))
+# define pthread_mutexattr_init(a) pthread_mutexattr_create(a)
+# define pthread_mutexattr_settype(a,t) pthread_mutexattr_setkind_np(a,t)
+# endif
# if defined(DJGPP) || defined(__OPEN_VM)
# define PTHREAD_ATTR_SETDETACHSTATE(a,s) pthread_attr_setdetachstate(a,&(s))
# define YIELD pthread_yield(NULL)
# endif
# endif
+# if !defined(__hpux) || !defined(__ux_version) || __ux_version > 1020
# define pthread_mutexattr_default NULL
# define pthread_condattr_default NULL
+# endif
#endif
#ifndef PTHREAD_CREATE
* Also see LOP and lop() below.
*/
-#define TOKEN(retval) return (PL_bufptr = s,(int)retval)
-#define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
-#define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
-#define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
-#define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
-#define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
-#define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
-#define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
-#define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
-#define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
-#define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
-#define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
-#define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
-#define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
-#define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
-#define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
-#define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
-#define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
-#define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
-#define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
+#ifdef DEBUGGING /* Serve -DT. */
+# define REPORT(x,retval) tokereport(x,s,(int)retval)
+# define REPORT2(x,retval) tokereport(x,s, yylval.ival)
+#else
+# define REPORT(x,retval) 1
+# define REPORT2(x,retval) 1
+#endif
+
+#define TOKEN(retval) return (REPORT2("token",retval), PL_bufptr = s,(int)retval)
+#define OPERATOR(retval) return (REPORT2("operator",retval), PL_expect = XTERM, PL_bufptr = s,(int)retval)
+#define AOPERATOR(retval) return ao((REPORT2("aop",retval), PL_expect = XTERM, PL_bufptr = s,(int)retval))
+#define PREBLOCK(retval) return (REPORT2("preblock",retval), PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
+#define PRETERMBLOCK(retval) return (REPORT2("pretermblock",retval), PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
+#define PREREF(retval) return (REPORT2("preref",retval), PL_expect = XREF,PL_bufptr = s,(int)retval)
+#define TERM(retval) return (CLINE, REPORT2("term",retval), PL_expect = XOPERATOR, PL_bufptr = s,(int)retval)
+#define LOOPX(f) return(yylval.ival=f, REPORT("loopx",f), PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
+#define FTST(f) return(yylval.ival=f, REPORT("ftst",f), PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
+#define FUN0(f) return(yylval.ival = f, REPORT("fun0",f), PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
+#define FUN1(f) return(yylval.ival = f, REPORT("fun1",f), PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
+#define BOop(f) return ao((yylval.ival=f, REPORT("bitorop",f), PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
+#define BAop(f) return ao((yylval.ival=f, REPORT("bitandop",f), PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
+#define SHop(f) return ao((yylval.ival=f, REPORT("shiftop",f), PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
+#define PWop(f) return ao((yylval.ival=f, REPORT("powop",f), PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
+#define PMop(f) return(yylval.ival=f, REPORT("matchop",f), PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
+#define Aop(f) return ao((yylval.ival=f, REPORT("add",f), PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
+#define Mop(f) return ao((yylval.ival=f, REPORT("mul",f), PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
+#define Eop(f) return(yylval.ival=f, REPORT("eq",f), PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
+#define Rop(f) return(yylval.ival=f, REPORT("rel",f), PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
/* This bit of chicanery makes a unary function followed by
* a parenthesis into a function with one argument, highest precedence.
*/
#define UNI(f) return(yylval.ival = f, \
+ REPORT("uni",f), \
PL_expect = XTERM, \
PL_bufptr = s, \
PL_last_uni = PL_oldbufptr, \
(*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
#define UNIBRACK(f) return(yylval.ival = f, \
+ REPORT("uni",f), \
PL_bufptr = s, \
PL_last_uni = PL_oldbufptr, \
(*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
/* grandfather return to old style */
#define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
+void
+S_tokereport(pTHX_ char *thing, char* s, I32 rv)
+{
+ SV *report;
+ DEBUG_T({
+ report = newSVpv(thing, 0);
+ Perl_sv_catpvf(aTHX_ report, ":line %i:%i:", CopLINE(PL_curcop), rv);
+
+ if (s - PL_bufptr > 0)
+ sv_catpvn(report, PL_bufptr, s - PL_bufptr);
+ else {
+ if (PL_oldbufptr && *PL_oldbufptr)
+ sv_catpv(report, PL_tokenbuf);
+ }
+ PerlIO_printf(Perl_debug_log, "### %s\n", SvPV_nolen(report));
+ })
+}
+
/*
* S_ao
*
{
yylval.ival = f;
CLINE;
+ REPORT("lop", f);
PL_expect = x;
PL_bufptr = s;
PL_last_lop = PL_oldbufptr;
"Unrecognized escape \\%c passed through",
*s);
/* default action is to copy the quoted character */
- *d++ = *s++;
- continue;
+ goto default_action;
}
/* \132 indicates an octal constant */
if (has_utf8 || uv > 255) {
d = (char*)uv_to_utf8((U8*)d, uv);
has_utf8 = TRUE;
+ if (PL_lex_inwhat == OP_TRANS &&
+ PL_sublex_info.sub_op) {
+ PL_sublex_info.sub_op->op_private |=
+ (PL_lex_repl ? OPpTRANS_FROM_UTF
+ : OPpTRANS_TO_UTF);
+ utf = TRUE;
+ }
}
else {
*d++ = (char)uv;
res = newSVpvn(s + 1, e - s - 1);
res = new_constant( Nullch, 0, "charnames",
res, Nullsv, "\\N{...}" );
+ if (has_utf8)
+ sv_utf8_upgrade(res);
str = SvPV(res,len);
if (!has_utf8 && SvUTF8(res)) {
char *ostart = SvPVX(sv);
continue;
} /* end if (backslash) */
- /* (now in tr/// code again) */
-
+ default_action:
if (UTF8_IS_CONTINUED(*s) && (this_utf8 || has_utf8)) {
STRLEN len = (STRLEN) -1;
UV uv;
*d++ = *s++;
}
has_utf8 = TRUE;
+ if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
+ PL_sublex_info.sub_op->op_private |=
+ (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
+ utf = TRUE;
+ }
continue;
}
- *d++ = *s++;
+ *d++ = *s++;
} /* while loop to process each character */
/* terminate the string and set up the sv */
}
do {
bof = PL_rsfp ? TRUE : FALSE;
- if (bof) {
+ if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
+ fake_eof:
+ if (PL_rsfp) {
+ if (PL_preprocess && !PL_in_eval)
+ (void)PerlProc_pclose(PL_rsfp);
+ else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
+ PerlIO_clearerr(PL_rsfp);
+ else
+ (void)PerlIO_close(PL_rsfp);
+ PL_rsfp = Nullfp;
+ PL_doextract = FALSE;
+ }
+ if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
+ sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
+ sv_catpv(PL_linestr,";}");
+ PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_minus_n = PL_minus_p = 0;
+ goto retry;
+ }
+ PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
+ sv_setpv(PL_linestr,"");
+ TOKEN(';'); /* not infinite loop because rsfp is NULL now */
+ }
+ /* if it looks like the start of a BOM, check if it in fact is */
+ else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) {
#ifdef PERLIO_IS_STDIO
# ifdef __GNU_LIBRARY__
# if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
* Workaround? Maybe attach some extra state to PL_rsfp?
*/
if (!PL_preprocess)
- bof = PerlIO_tell(PL_rsfp) == 0;
+ bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
#else
- bof = PerlIO_tell(PL_rsfp) == 0;
+ bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
#endif
- }
- s = filter_gets(PL_linestr, PL_rsfp, 0);
- if (s == Nullch) {
- fake_eof:
- if (PL_rsfp) {
- if (PL_preprocess && !PL_in_eval)
- (void)PerlProc_pclose(PL_rsfp);
- else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
- PerlIO_clearerr(PL_rsfp);
- else
- (void)PerlIO_close(PL_rsfp);
- PL_rsfp = Nullfp;
- PL_doextract = FALSE;
- }
- if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
- sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
- sv_catpv(PL_linestr,";}");
- PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
+ if (bof) {
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- PL_minus_n = PL_minus_p = 0;
- goto retry;
+ s = swallow_bom((U8*)s);
}
- PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
- sv_setpv(PL_linestr,"");
- TOKEN(';'); /* not infinite loop because rsfp is NULL now */
- } else if (bof) {
- PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- s = swallow_bom((U8*)s);
}
if (PL_doextract) {
if (*s == '#' && s[1] == '!' && instr(s,"perl"))
(void)PerlIO_seek(PL_rsfp, 0L, 0);
}
if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
-#if defined(__BORLANDC__)
- /* XXX see note in do_binmode() */
- ((FILE*)PL_rsfp)->flags |= _F_BIN;
-#endif
if (loc > 0)
PerlIO_seek(PL_rsfp, loc, 0);
}
case KEY_qq:
case KEY_qu:
s = scan_str(s,FALSE,FALSE);
- if (tmp == KEY_qu && is_utf8_string((U8*)s, SvCUR(PL_lex_stuff)))
+ if (tmp == KEY_qu &&
+ is_utf8_string((U8*)SvPVX(PL_lex_stuff), SvCUR(PL_lex_stuff)))
SvUTF8_on(PL_lex_stuff);
if (!s)
missingterm((char*)0);
}
/*
+=for apidoc A|U8 *|bytes_from_utf8|U8 *s|STRLEN *len|bool *is_utf8
+
+Converts a string C<s> of length C<len> from UTF8 into byte encoding.
+Unlike <utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to
+the newly-created string, and updates C<len> to contain the new
+length. Returns the original string if no conversion occurs, C<len>
+is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
+0 if C<s> is converted or contains all 7bit characters.
+
+=cut */
+
+U8 *
+Perl_bytes_from_utf8(pTHX_ U8* s, STRLEN *len, bool *is_utf8)
+{
+ U8 *send;
+ U8 *d;
+ U8 *start = s;
+ I32 count = 0;
+
+ if (!*is_utf8)
+ return start;
+
+ /* ensure valid UTF8 and chars < 256 before converting string */
+ for (send = s + *len; s < send;) {
+ U8 c = *s++;
+ if (!UTF8_IS_ASCII(c)) {
+ if (UTF8_IS_CONTINUATION(c) || s >= send ||
+ !UTF8_IS_CONTINUATION(*s) || UTF8_IS_DOWNGRADEABLE_START(c))
+ return start;
+ s++, count++;
+ }
+ }
+
+ *is_utf8 = 0;
+
+ if (!count)
+ return start;
+
+ Newz(801, d, (*len) - count + 1, U8);
+ s = start; start = d;
+ while (s < send) {
+ U8 c = *s++;
+ if (UTF8_IS_ASCII(c))
+ *d++ = c;
+ else
+ *d++ = UTF8_ACCUMULATE(c&3, *s++);
+ }
+ *d = '\0';
+ *len = d - start;
+ return start;
+}
+
+/*
=for apidoc A|U8 *|bytes_to_utf8|U8 *s|STRLEN *len
Converts a string C<s> of length C<len> from ASCII into UTF8 encoding.
#define UTF8_IS_START(c) (((U8)c) >= 0xc0 && (((U8)c) <= 0xfd))
#define UTF8_IS_CONTINUATION(c) (((U8)c) >= 0x80 && (((U8)c) <= 0xbf))
#define UTF8_IS_CONTINUED(c) (((U8)c) & 0x80)
+#define UTF8_IS_DOWNGRADEABLE_START(c) (((U8)c & 0xfc) != 0xc0)
#define UTF8_CONTINUATION_MASK ((U8)0x3f)
#define UTF8_ACCUMULATION_SHIFT 6
struct lconv* lc;
lc = localeconv();
- if (lc && lc->decimal_point)
- /* We assume that decimal separator aka the radix
- * character is always a single character. If it
- * ever is a string, this needs to be rethunk. */
- PL_numeric_radix = *lc->decimal_point;
+ if (lc && lc->decimal_point) {
+ if (lc->decimal_point[0] == '.' && lc->decimal_point[1] == 0) {
+ SvREFCNT_dec(PL_numeric_radix);
+ PL_numeric_radix = 0;
+ }
+ else {
+ if (PL_numeric_radix)
+ sv_setpv(PL_numeric_radix, lc->decimal_point);
+ else
+ PL_numeric_radix = newSVpv(lc->decimal_point, 0);
+ }
+ }
else
PL_numeric_radix = 0;
# endif /* HAS_LOCALECONV */
my $compat_version = $];
use Getopt::Std;
+use Config;
-sub usage{
- warn "@_\n" if @_;
- die "h2xs [-ACOPXacdfhkmx] [-F addflags] [-M fmask] [-n module_name] [-o tmask] [-p prefix] [-s subs] [-v version] [headerfile [extra_libraries]]
+sub usage {
+ warn "@_\n" if @_;
+ die <<EOFUSAGE;
+h2xs [-ACOPXacdfhkmx] [-F addflags] [-M fmask] [-n module_name] [-o tmask] [-p prefix] [-s subs] [-v version] [-b compat_version ] [headerfile [extra_libraries]]
version: $H2XS_VERSION
-A Omit all autoloading facilities (implies -c).
-C Omit creating the Changes file, add HISTORY heading to stub POD.
extra_libraries
are any libraries that might be needed for loading the
extension, e.g. -lm would try to link in the math library.
-";
+EOFUSAGE
}
__END__
END
-my $author = "A. U. Thor";
-my $email = 'a.u.thor@a.galaxy.far.far.away';
+my ($email,$author);
+
+eval {
+ my $user;
+ ($user,$author) = (getpwuid($>))[0,6];
+ $author =~ s/,.*$//; # in case of sub fields
+ my $domain = $Config{'mydomain'};
+ $domain =~ s/^\.//;
+ $email = "$user\@$domain";
+ };
+
+$author ||= "A. U. Thor";
+$email ||= 'a.u.thor@a.galaxy.far.far.away';
my $revhist = '';
$revhist = <<EOT if $opt_C;
sub END { cleanup($tmp, $buffer) }
1;
} || die;
-eval q{ use sigtrap qw(die INT TERM HUP QUIT) };
+
+# exit/die in a windows sighandler is dangerous, so let it do the
+# default thing, which is to exit
+eval q{ use sigtrap qw(die INT TERM HUP QUIT) } unless $^O eq 'MSWin32';
if ($opt_m) {
foreach my $pager (@pagers) {
$! And do it
$ Show Process/Accounting
$ testdir = "Directory/NoHead/NoTrail/Column=1"
-$ oldshr = F$TrnLNm("''dbg'PerlShr","LNM$PROCESS")
+$ oldshr = F$TrnLNm("''dbg'PerlShr")
+$ PerlShr_filespec = f$parse("Sys$Disk:[-]''dbg'PerlShr''exe'")
$ If F$Length(oldshr).ne.0 Then Write Sys$Error "Superseding ''dbg'PerlShr . . ."
-$ Define 'dbg'Perlshr Sys$Disk:[-]'dbg'PerlShr'exe'
+$ Define 'dbg'Perlshr 'PerlShr_filespec'
$ MCR Sys$Disk:[]Perl. "-I[-.lib]" - "''p3'" "''p4'" "''p5'" "''p6'"
$ Deck/Dollar=$$END-OF-TEST$$
# $RCSfile: TEST,v $$Revision: 4.1 $$Date: 92/08/07 18:27:00 $
#
# uncomment to enable the experimental PerlIO I/O subsystem.
-# This is currently incompatible with USE_MULTI, USE_ITHREADS,
-# and USE_IMP_SYS
-#USE_PERLIO = define
+USE_PERLIO = define
#
# WARNING! This option is deprecated and will eventually go away (enable
USE_IMP_SYS = undef
!ENDIF
+!IF "$(USE_PERLIO)" == ""
+USE_PERLIO = undef
+!ENDIF
+
!IF "$(USE_PERLCRT)" == ""
USE_PERLCRT = undef
!ENDIF
"useithreads=$(USE_ITHREADS)" \
"usethreads=$(USE_5005THREADS)" \
"usemultiplicity=$(USE_MULTI)" \
+ "useperlio=$(USE_PERLIO)" \
"LINK_FLAGS=$(LINK_FLAGS:"=\")" \
"optimize=$(OPTIMIZE:"=\")"
$stripped=0;
&init;
-$rc_file = join('/', $ENV{'HOME'}, ".search");
+if (exists $ENV{'HOME'}) {
+ $rc_file = join('/', $ENV{'HOME'}, ".search");
+}
+else {
+ $rc_file = "";
+}
&check_args;
usemymalloc='n'
usenm='false'
useopcode='true'
-useperlio='undef'
+useperlio='~USE_PERLIO~'
useposix='true'
usesfio='false'
useshrplib='yes'
usemymalloc='n'
usenm='false'
useopcode='true'
-useperlio='define'
+useperlio='~USE_PERLIO~'
useposix='true'
usesfio='false'
useshrplib='yes'
usemymalloc='n'
usenm='false'
useopcode='true'
-useperlio='define'
+useperlio='~USE_PERLIO~'
useposix='true'
usesfio='false'
useshrplib='yes'
* used in a fully backward compatible manner.
*/
#ifndef USE_PERLIO
-/*#define USE_PERLIO /**/
+#define USE_PERLIO /**/
#endif
/* USE_SOCKS:
USE_IMP_SYS *= define
#
+# uncomment to enable the experimental PerlIO I/O subsystem.
+USE_PERLIO = define
+
+#
# WARNING! This option is deprecated and will eventually go away (enable
# USE_ITHREADS instead).
#
USE_OBJECT *= undef
USE_ITHREADS *= undef
USE_IMP_SYS *= undef
+USE_PERLIO *= undef
USE_PERLCRT *= undef
.IF "$(USE_IMP_SYS)$(USE_MULTI)$(USE_5005THREADS)$(USE_OBJECT)" == "defineundefundefundef"
.ELIF "$(USE_MULTI)" == "define"
ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-multi
.ELSE
+.IF "$(USE_PERLIO)" == "define"
+ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-perlio
+.ELSE
+ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)
+.ENDIF
ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)
.ENDIF
useithreads=$(USE_ITHREADS) ~ \
usethreads=$(USE_5005THREADS) ~ \
usemultiplicity=$(USE_MULTI) ~ \
+ useperlio=$(USE_PERLIO) ~ \
LINK_FLAGS=$(LINK_FLAGS:s/\/\\/) ~ \
optimize=$(OPTIMIZE)
DWORD r = GetFileAttributesA(pPtr);
if ((r != 0xffffffff) && (r & FILE_ATTRIBUTE_DIRECTORY))
{
- SetDefaultDirA(pPtr, DriveIndex(pPtr[0]));
+ char szBuffer[(MAX_PATH+1)*2];
+ DoGetFullPathNameA(pPtr, sizeof(szBuffer), szBuffer);
+ SetDefaultDirA(szBuffer, DriveIndex(szBuffer[0]));
nRet = 0;
}
DWORD r = GetFileAttributesW(pPtr);
if ((r != 0xffffffff) && (r & FILE_ATTRIBUTE_DIRECTORY))
{
- SetDefaultDirW(pPtr, DriveIndex((char)pPtr[0]));
+ WCHAR wBuffer[(MAX_PATH+1)*2];
+ DoGetFullPathNameW(pPtr, (sizeof(wBuffer)/sizeof(WCHAR)), wBuffer);
+ SetDefaultDirW(wBuffer, DriveIndex((char)wBuffer[0]));
nRet = 0;
}
projects / p5sagit/p5-mst-13.2.git / commitdiff