This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate mainline
authorNick Ing-Simmons <nik@tiuk.ti.com>
Mon, 20 Jan 2003 09:37:52 +0000 (09:37 +0000)
committerNick Ing-Simmons <nik@tiuk.ti.com>
Mon, 20 Jan 2003 09:37:52 +0000 (09:37 +0000)
p4raw-id: //depot/perlio@18518

78 files changed:
MANIFEST
Makefile.micro
README.epoc
README.mint
doio.c
embedvar.h
ext/Data/Dumper/Dumper.pm
ext/Digest/MD5/Changes
ext/Digest/MD5/MD5.pm
ext/Digest/MD5/MD5.xs
ext/Digest/MD5/Makefile.PL
ext/Digest/MD5/README
ext/Digest/MD5/t/align.t
ext/Digest/MD5/t/files.t
ext/Encode/Changes
ext/Encode/Encode.pm
ext/Encode/Encode.xs
ext/Encode/MANIFEST
ext/Encode/Unicode/Unicode.xs
ext/Encode/encoding.pm
ext/Encode/t/CJKT.t
ext/Encode/t/enc_eucjp.t [new file with mode: 0644]
ext/Encode/t/enc_utf8.t [new file with mode: 0644]
ext/MIME/Base64/Base64.pm
ext/MIME/Base64/Changes
ext/MIME/Base64/QuotedPrint.pm
ext/MIME/Base64/t/quoted-print.t
ext/MIME/Base64/t/unicode.t
ext/Time/HiRes/Changes
ext/Time/HiRes/HiRes.pm
ext/Time/HiRes/HiRes.xs
ext/Time/HiRes/Makefile.PL
ext/Time/HiRes/fallback/const-c.inc [new file with mode: 0644]
ext/Time/HiRes/fallback/const-xs.inc [new file with mode: 0644]
gv.c
intrpvar.h
lib/Attribute/Handlers.pm
lib/Attribute/Handlers/t/multi.t
lib/CGI.pm
lib/CGI/Carp.pm
lib/CGI/Cookie.pm
lib/CGI/Pretty.pm
lib/CGI/t/carp.t
lib/CGI/t/html.t
lib/CGI/t/pretty.t
lib/Digest.pm
lib/File/Find.pm
lib/File/Find/t/find.t
lib/Time/Local.pm
lib/Time/Local.t
lib/diagnostics.pm
locale.c
mg.c
perl.c
perlapi.h
pod/perlfunc.pod
pod/perlrun.pod
pod/perlunicode.pod
pod/perluniintro.pod
pod/perlvar.pod
pp.c
pp_hot.c
reentr.c
reentr.pl
sv.c
sv.h
t/io/tell.t
t/op/do.t
t/op/fh.t
t/op/readline.t [new file with mode: 0644]
t/op/universal.t
uconfig.h
uconfig.sh
universal.c
utils/libnetcfg.PL
win32/bin/search.pl
win32/win32.h
wince/win32.h

index 4e798d4..be7882c 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -259,6 +259,8 @@ ext/Encode/t/big5-hkscs.utf test data
 ext/Encode/t/CJKT.t            test script
 ext/Encode/t/Encode.t          test script
 ext/Encode/t/Encoder.t         test script
+ext/Encode/t/enc_eucjp.t       test script
+ext/Encode/t/enc_utf8.t                test script
 ext/Encode/t/encoding.t                test script
 ext/Encode/t/fallback.t                test script
 ext/Encode/t/gb2312.enc                test data
@@ -709,6 +711,8 @@ ext/threads/threads.pm              ithreads
 ext/threads/threads.xs         ithreads
 ext/threads/typemap            ithreads
 ext/Time/HiRes/Changes         Time::HiRes extension
+ext/Time/HiRes/fallback/const-c.inc    Time::HiRes extension
+ext/Time/HiRes/fallback/const-xs.inc   Time::HiRes extension
 ext/Time/HiRes/hints/dynixptx.pl       Hint for Time::HiRes for named architecture
 ext/Time/HiRes/hints/sco.pl    Hints for Time::HiRes for named architecture
 ext/Time/HiRes/HiRes.pm                Time::HiRes extension
@@ -2598,6 +2602,7 @@ t/op/quotemeta.t          See if quotemeta works
 t/op/rand.t                    See if rand works
 t/op/range.t                   See if .. works
 t/op/read.t                    See if read() works
+t/op/readline.t                        See if <> / readline work
 t/op/readdir.t                 See if readdir() works
 t/op/recurse.t                 See if deep recursion works
 t/op/ref.t                     See if refs and objects work
index a0daee2..7950f71 100644 (file)
@@ -9,8 +9,8 @@ all:    microperl
 
 O = uav$(_O) udeb$(_O) udoio$(_O) udoop$(_O) udump$(_O) \
        uglobals$(_O) ugv$(_O) uhv$(_O) \
-       umg$(_O) uperlmain$(_O) uop$(_O) upad$(_O) ureentr$(_O) \
-       uperl$(_O) uperlio$(_O) uperly$(_O) upp$(_O) \
+       umg$(_O) uperlmain$(_O) uop$(_O) ureentr$(_O) \
+       upad$(_O) uperl$(_O) uperlio$(_O) uperly$(_O) upp$(_O) \
        upp_ctl$(_O) upp_hot$(_O) upp_sys$(_O) upp_pack$(_O) upp_sort$(_O) \
        uregcomp$(_O) uregexec$(_O) urun$(_O) \
        uscope$(_O) usv$(_O) utaint$(_O) utoke$(_O) \
@@ -82,12 +82,12 @@ uperlmain$(_O):     $(HE) miniperlmain.c
 uop$(_O):      $(HE) op.c keywords.h
        $(CC) -c -o $@ $(CFLAGS) op.c
 
-upad$(_O):     $(HE) pad.c
-       $(CC) -c -o $@ $(CFLAGS) pad.c
-
 ureentr$(_O):  $(HE) reentr.c
        $(CC) -c -o $@ $(CFLAGS) reentr.c
 
+upad$(_O):     $(HE) pad.c
+       $(CC) -c -o $@ $(CFLAGS) pad.c
+
 uperl$(_O):    $(HE) perl.c
        $(CC) -c -o $@ $(CFLAGS) perl.c
 
index 90e87eb..aa744e3 100644 (file)
@@ -17,8 +17,8 @@ http://www.symbian.com/
 
 This is a port of perl to the epocemx SDK by Eberhard Mattes, which
 itself uses the SDK by symbian. Essentially epocemx it is a POSIX
-look alike environment for the EPOC OS. For more informations look at: 
-http://www.windhager.de/~mattes/epocemx/
+look alike environment for the EPOC OS.  For more information look at: 
+http://epocemx.sourceforge.net/
 
 perl and epocemx runs on Epoc Release 5 machines: Psion 5mx, 5mx Pro,
 Psion Revo, Psion Netbook and on the Ericson M128. It may run on Epoc
@@ -31,13 +31,12 @@ me a sample.
 =head1 INSTALLING PERL ON EPOC
 
 You can download a ready-to-install version from
-http://www.science-computing.de/o.flebbe/perl/
+http://www.oflebbe.de/oflebbe/perl/
 
-You will need at least ~6MB free space in order to install and run
-perl.
+You will need at least ~6MB free space in order to install and run perl.
 
 Please install the emxusr.sis package from
-http://www.windhager.de/~mattes/epocemx/ first.
+http://epocemx.sourceforge.net/ first.
 
 Install perl.sis on the EPOC machine. If you do not know how to do
 that, consult your PsiWin documentation.
@@ -150,11 +149,11 @@ Very special thanks to Eberhard Mattes for epocemx.
 
 =head1 AUTHOR
 
-Olaf Flebbe <o.flebbe@science-computing.de>
-http://www.science-computing.de/o.flebbe/perl/
+Olaf Flebbe <olaf@oflebbe.de>
+http://www.oflebbe.de/oflebbe/perl/
 
 =head1 LAST UPDATE
 
-2002-03-26
+2003-01-18
 
 =cut
index 82f7509..a231341 100644 (file)
@@ -123,16 +123,16 @@ This will fix the problem.
 
 This version (5.00402) of perl has passed most of the tests on my system:
 
-Failed Test  Status Wstat Total Fail  Failed  List of failed
-------------------------------------------------------------------------------
-io/pipe.t                    10    2  20.00%  7, 9
-io/tell.t                    13    1   7.69%  12
-lib/complex.t               762   13   1.71%  84-85, 248-251, 257, 272-273,
-                                              371, 380, 419-420
-lib/io_pipe.t                10    1  10.00%  9
-lib/io_tell.t                13    1   7.69%  12
-op/magic.t                   30    2   6.67%  29-30
-Failed 6/152 test scripts, 96.05% okay. 20/4359 subtests failed, 99.54% okay.
+ Failed Test  Status Wstat Total Fail  Failed  List of failed
+ ------------------------------------------------------------------------------
+ io/pipe.t                    10    2  20.00%  7, 9
+ io/tell.t                    13    1   7.69%  12
+ lib/complex.t               762   13   1.71%  84-85, 248-251, 257, 272-273,
+                                               371, 380, 419-420
+ lib/io_pipe.t                10    1  10.00%  9
+ lib/io_tell.t                13    1   7.69%  12
+ op/magic.t                   30    2   6.67%  29-30
+ Failed 6/152 test scripts, 96.05% okay. 20/4359 subtests failed, 99.54% okay.
 
 Pipes always cause problems with MiNT, it's actually a surprise that
 most of the tests did work.  I've got no idea why the "tell" test failed,
diff --git a/doio.c b/doio.c
index e23a2ca..fe8ed7e 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -323,13 +323,13 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                    if (num_svs > 1) {
                        Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io));
                    }
+                   /*SUPPRESS 530*/
+                   for (; isSPACE(*type); type++) ;
                    if (num_svs && (SvIOK(*svp) || (SvPOK(*svp) && looks_like_number(*svp)))) {
                        fd = SvUV(*svp);
                        num_svs = 0;
                    }
                    else if (isDIGIT(*type)) {
-                       /*SUPPRESS 530*/
-                       for (; isSPACE(*type); type++) ;
                        fd = atoi(type);
                    }
                    else {
@@ -339,8 +339,6 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                        }
                        else {
                            GV *thatgv;
-                           /*SUPPRESS 530*/
-                           for (; isSPACE(*type); type++) ;
                            thatgv = gv_fetchpv(type,FALSE,SVt_PVIO);
                            thatio = GvIO(thatgv);
                        }
@@ -1268,7 +1266,8 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
     default:
        if (PerlIO_isutf8(fp)) {
            if (!SvUTF8(sv))
-               sv_utf8_upgrade(sv = sv_mortalcopy(sv));
+               sv_utf8_upgrade_flags(sv = sv_mortalcopy(sv),
+                                     SV_GMAGIC|SV_UTF8_NO_ENCODING);
        }
        else if (DO_UTF8(sv)) {
            if (!sv_utf8_downgrade((sv = sv_mortalcopy(sv)), TRUE)
index cc70926..202cea0 100644 (file)
 #define PL_utf8_toupper                (vTHX->Iutf8_toupper)
 #define PL_utf8_upper          (vTHX->Iutf8_upper)
 #define PL_utf8_xdigit         (vTHX->Iutf8_xdigit)
+#define PL_utf8locale          (vTHX->Iutf8locale)
 #define PL_uudmap              (vTHX->Iuudmap)
 #define PL_wantutf8            (vTHX->Iwantutf8)
 #define PL_warnhook            (vTHX->Iwarnhook)
-#define PL_widesyscalls                (vTHX->Iwidesyscalls)
 #define PL_xiv_arenaroot       (vTHX->Ixiv_arenaroot)
 #define PL_xiv_root            (vTHX->Ixiv_root)
 #define PL_xnv_arenaroot       (vTHX->Ixnv_arenaroot)
 #define PL_Iutf8_toupper       PL_utf8_toupper
 #define PL_Iutf8_upper         PL_utf8_upper
 #define PL_Iutf8_xdigit                PL_utf8_xdigit
+#define PL_Iutf8locale         PL_utf8locale
 #define PL_Iuudmap             PL_uudmap
 #define PL_Iwantutf8           PL_wantutf8
 #define PL_Iwarnhook           PL_warnhook
-#define PL_Iwidesyscalls       PL_widesyscalls
 #define PL_Ixiv_arenaroot      PL_xiv_arenaroot
 #define PL_Ixiv_root           PL_xiv_root
 #define PL_Ixnv_arenaroot      PL_xnv_arenaroot
index 189ad00..8e5320e 100644 (file)
@@ -803,7 +803,9 @@ so that they can be chained together nicely.
 
 =over 4
 
-=item $Data::Dumper::Indent  I<or>  I<$OBJ>->Indent(I<[NEWVAL]>)
+=item *
+
+$Data::Dumper::Indent  I<or>  I<$OBJ>->Indent(I<[NEWVAL]>)
 
 Controls the style of indentation.  It can be set to 0, 1, 2 or 3.  Style 0
 spews output without any newlines, indentation, or spaces between list
@@ -816,24 +818,32 @@ up).  Style 3 is like style 2, but also annotates the elements of arrays
 with their index (but the comment is on its own line, so array output
 consumes twice the number of lines).  Style 2 is the default.
 
-=item $Data::Dumper::Purity  I<or>  I<$OBJ>->Purity(I<[NEWVAL]>)
+=item *
+
+$Data::Dumper::Purity  I<or>  I<$OBJ>->Purity(I<[NEWVAL]>)
 
 Controls the degree to which the output can be C<eval>ed to recreate the
 supplied reference structures.  Setting it to 1 will output additional perl
 statements that will correctly recreate nested references.  The default is
 0.
 
-=item $Data::Dumper::Pad  I<or>  I<$OBJ>->Pad(I<[NEWVAL]>)
+=item *
+
+$Data::Dumper::Pad  I<or>  I<$OBJ>->Pad(I<[NEWVAL]>)
 
 Specifies the string that will be prefixed to every line of the output.
 Empty string by default.
 
-=item $Data::Dumper::Varname  I<or>  I<$OBJ>->Varname(I<[NEWVAL]>)
+=item *
+
+$Data::Dumper::Varname  I<or>  I<$OBJ>->Varname(I<[NEWVAL]>)
 
 Contains the prefix to use for tagging variable names in the output. The
 default is "VAR".
 
-=item $Data::Dumper::Useqq  I<or>  I<$OBJ>->Useqq(I<[NEWVAL]>)
+=item *
+
+$Data::Dumper::Useqq  I<or>  I<$OBJ>->Useqq(I<[NEWVAL]>)
 
 When set, enables the use of double quotes for representing string values.
 Whitespace other than space will be represented as C<[\n\t\r]>, "unsafe"
@@ -842,14 +852,18 @@ quoted octal integers.  Since setting this variable imposes a performance
 penalty, the default is 0.  C<Dump()> will run slower if this flag is set,
 since the fast XSUB implementation doesn't support it yet.
 
-=item $Data::Dumper::Terse  I<or>  I<$OBJ>->Terse(I<[NEWVAL]>)
+=item *
+
+$Data::Dumper::Terse  I<or>  I<$OBJ>->Terse(I<[NEWVAL]>)
 
 When set, Data::Dumper will emit single, non-self-referential values as
 atoms/terms rather than statements.  This means that the C<$VAR>I<n> names
 will be avoided where possible, but be advised that such output may not
 always be parseable by C<eval>.
 
-=item $Data::Dumper::Freezer  I<or>  $I<OBJ>->Freezer(I<[NEWVAL]>)
+=item *
+
+$Data::Dumper::Freezer  I<or>  $I<OBJ>->Freezer(I<[NEWVAL]>)
 
 Can be set to a method name, or to an empty string to disable the feature.
 Data::Dumper will invoke that method via the object before attempting to
@@ -860,7 +874,9 @@ method can be called via the object, and that the object ends up containing
 only perl data types after the method has been called.  Defaults to an empty
 string.
 
-=item $Data::Dumper::Toaster  I<or>  $I<OBJ>->Toaster(I<[NEWVAL]>)
+=item *
+
+$Data::Dumper::Toaster  I<or>  $I<OBJ>->Toaster(I<[NEWVAL]>)
 
 Can be set to a method name, or to an empty string to disable the feature.
 Data::Dumper will emit a method call for any objects that are to be dumped
@@ -871,26 +887,34 @@ different package) and then return it.  The client is responsible for making
 sure the method can be called via the object, and that it returns a valid
 object.  Defaults to an empty string.
 
-=item $Data::Dumper::Deepcopy  I<or>  $I<OBJ>->Deepcopy(I<[NEWVAL]>)
+=item *
+
+$Data::Dumper::Deepcopy  I<or>  $I<OBJ>->Deepcopy(I<[NEWVAL]>)
 
 Can be set to a boolean value to enable deep copies of structures.
 Cross-referencing will then only be done when absolutely essential
 (i.e., to break reference cycles).  Default is 0.
 
-=item $Data::Dumper::Quotekeys  I<or>  $I<OBJ>->Quotekeys(I<[NEWVAL]>)
+=item *
+
+$Data::Dumper::Quotekeys  I<or>  $I<OBJ>->Quotekeys(I<[NEWVAL]>)
 
 Can be set to a boolean value to control whether hash keys are quoted.
 A false value will avoid quoting hash keys when it looks like a simple
 string.  Default is 1, which will always enclose hash keys in quotes.
 
-=item $Data::Dumper::Bless  I<or>  $I<OBJ>->Bless(I<[NEWVAL]>)
+=item *
+
+$Data::Dumper::Bless  I<or>  $I<OBJ>->Bless(I<[NEWVAL]>)
 
 Can be set to a string that specifies an alternative to the C<bless>
 builtin operator used to create objects.  A function with the specified
 name should exist, and should accept the same arguments as the builtin.
 Default is C<bless>.
 
-=item $Data::Dumper::Maxdepth  I<or>  $I<OBJ>->Maxdepth(I<[NEWVAL]>)
+=item *
+
+$Data::Dumper::Maxdepth  I<or>  $I<OBJ>->Maxdepth(I<[NEWVAL]>)
 
 Can be set to a positive integer that specifies the depth beyond which
 which we don't venture into a structure.  Has no effect when
@@ -898,7 +922,9 @@ C<Data::Dumper::Purity> is set.  (Useful in debugger when we often don't
 want to see more than enough).  Default is 0, which means there is 
 no maximum depth. 
 
-=item $Data::Dumper::Useperl  I<or>  $I<OBJ>->Useperl(I<[NEWVAL]>)
+=item *
+
+$Data::Dumper::Useperl  I<or>  $I<OBJ>->Useperl(I<[NEWVAL]>)
 
 Can be set to a boolean value which controls whether the pure Perl
 implementation of C<Data::Dumper> is used. The C<Data::Dumper> module is
@@ -908,7 +934,9 @@ will always be used if possible. This option lets you override the
 default behavior, usually for testing purposes only. Default is 0, which
 means the XS implementation will be used if possible.
 
-=item $Data::Dumper::Sortkeys  I<or>  $I<OBJ>->Sortkeys(I<[NEWVAL]>)
+=item *
+
+$Data::Dumper::Sortkeys  I<or>  $I<OBJ>->Sortkeys(I<[NEWVAL]>)
 
 Can be set to a boolean value to control whether hash keys are dumped in
 sorted order. A true value will cause the keys of all hashes to be
@@ -923,7 +951,9 @@ other words, this subroutine acts as a filter by which you can exclude
 certain keys from being dumped. Default is 0, which means that hash keys
 are not sorted.
 
-=item $Data::Dumper::Deparse  I<or>  $I<OBJ>->Deparse(I<[NEWVAL]>)
+=item *
+
+$Data::Dumper::Deparse  I<or>  $I<OBJ>->Deparse(I<[NEWVAL]>)
 
 Can be set to a boolean value to control whether code references are
 turned into perl source code. If set to a true value, C<B::Deparse>
index a100886..2c113b4 100644 (file)
@@ -1,3 +1,26 @@
+2002-03-04   Gisle Aas <gisle@ActiveState.com>
+
+   Release 2.22.
+
+   Added clone method.
+   Contributed by Holger Smolinski <holger@kunterbunt.bb.bawue.de>
+
+
+
+2002-12-27   Gisle Aas <gisle@ActiveState.com>
+
+   Release 2.21
+
+   Minor tweaks sync up with bleadperl:
+     - VMS optimizer tweaks to the Makefile.PL
+     - MacOS support
+     - Added alignment test
+
+   Added example to the MD5 POD that shows how to calculate the
+   digest of Unicode strings.
+
+
+
 2002-05-05   Gisle Aas <gisle@ActiveState.com>
 
    Release 2.20
index 372e007..0017e5a 100644 (file)
@@ -3,7 +3,7 @@ package Digest::MD5;
 use strict;
 use vars qw($VERSION @ISA @EXPORT_OK);
 
-$VERSION = '2.20';  # $Date: 2002/05/06 05:15:09 $
+$VERSION = '2.22';  # $Date: 2003/01/05 00:56:14 $
 
 require Exporter;
 *import = \&Exporter::import;
@@ -117,6 +117,14 @@ If called as an instance method (i.e. $md5->new) it will just reset the
 state the object to the state of a newly created object.  No new
 object is created in this case.
 
+=item $md5->clone
+
+This is a copy constructor returning a clone of the $md5 object. It is
+useful when you do not want to destroy the digests state, but need an
+intermediate value of the digest, e.g. when calculating digests
+iteratively on a continuous data stream in order to obtain a copy which
+may be destroyed.
+
 =item $md5->reset
 
 This is just an alias for $md5->new.
@@ -142,7 +150,8 @@ Return the binary digest for the message.
 Note that the C<digest> operation is effectively a destructive,
 read-once operation. Once it has been performed, the C<Digest::MD5>
 object is automatically C<reset> and can be used to calculate another
-digest value.
+digest value.  Call $md5->clone->digest if you want to calculate the
+digest without reseting the digest state.
 
 =item $md5->hexdigest
 
@@ -214,6 +223,29 @@ the file:
 
     print Digest::MD5->new->addfile(*FILE)->hexdigest, " $file\n";
 
+Perl 5.8 support Unicode characters in strings.  Since the MD5
+algorithm is only defined for strings of bytes, it can not be used on
+strings that contains chars with ordinal number above 255.  The MD5
+functions and methods will croak if you try to feed them such input
+data:
+
+    use Digest::MD5 qw(md5_hex);
+
+    my $str = "abc\x{300}";
+    print md5_hex($str), "\n";  # croaks
+    # Wide character in subroutine entry
+
+What you can do is calculate the MD5 checksum of the UTF-8
+representation of such strings.  This is achieved by filtering the
+string through encode_utf8() function:
+
+    use Digest::MD5 qw(md5_hex);
+    use Encode qw(encode_utf8);
+
+    my $str = "abc\x{300}";
+    print md5_hex(encode_utf8($str)), "\n";
+    # 8c2d46911f3f5a326455f0ed7a8ed3b3
+
 =head1 SEE ALSO
 
 L<Digest>,
@@ -230,7 +262,7 @@ RFC 1321
 This library is free software; you can redistribute it and/or
 modify it under the same terms as Perl itself.
 
- Copyright 1998-2002 Gisle Aas.
+ Copyright 1998-2003 Gisle Aas.
  Copyright 1995-1996 Neil Winton.
  Copyright 1991-1992 RSA Data Security, Inc.
 
index 4a30550..abc1748 100644 (file)
@@ -1,4 +1,4 @@
-/* $Id: MD5.xs,v 1.34 2002/05/01 23:30:28 gisle Exp $ */
+/* $Id: MD5.xs,v 1.35 2003/01/05 00:54:17 gisle Exp $ */
 
 /* 
  * This library is free software; you can redistribute it and/or
@@ -562,6 +562,22 @@ new(xclass)
        XSRETURN(1);
 
 void
+clone(self)
+       SV* self
+    PREINIT:
+       MD5_CTX* cont = get_md5_ctx(self);
+       char *myname = sv_reftype(SvRV(self),TRUE);
+       MD5_CTX* context;
+    PPCODE:
+       STRLEN my_na;
+       New(55, context, 1, MD5_CTX);
+       ST(0) = sv_newmortal();
+       sv_setref_pv(ST(0), myname , (void*)context);
+       SvREADONLY_on(SvRV(ST(0)));
+       memcpy(context,cont,sizeof(MD5_CTX));
+       XSRETURN(1);
+
+void
 DESTROY(context)
        MD5_CTX* context
     CODE:
index 3a6450c..ceae949 100644 (file)
@@ -4,29 +4,32 @@ use Config qw(%Config);
 use ExtUtils::MakeMaker;
 
 my @extra;
+@extra = (DEFINE => "-DU32_ALIGNMENT_REQUIRED") unless free_u32_alignment();
 
-unless ($Config{d_u32align}) {
-    @extra = (DEFINE => "-DU32_ALIGNMENT_REQUIRED")
-       if !($Config{'byteorder'} eq '1234' ||
-            $Config{'byteorder'} eq '4321');
-}
-my @optimize = ();
 if ($^O eq 'VMS') {
     if (defined($Config{ccname})) {
         if (grep(/VMS_VAX/, @INC) && ($Config{ccname} eq 'DEC')) {
             # VAX compiler optimizer even as late as v6.4 gets stuck
-            @optimize = ("OPTIMIZE","/Optimize=(NODISJOINT)");
+            push(@extra, OPTIMIZE => "/Optimize=(NODISJOINT)");
         }
     }
 }
 
+
 WriteMakefile(
     'NAME'        => 'Digest::MD5',
     'VERSION_FROM' => 'MD5.pm',
     MAN3PODS    => {},  # Pods will be built by installman.
     @extra,
     'dist'         => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
-    @optimize
 );
 exit;
 
+
+
+sub free_u32_alignment
+{
+    return 0 if $Config{d_u32align};
+    return 1 if $Config{'byteorder'} eq '1234' || $Config{'byteorder'} eq '4321';
+    return 0;
+}
index 9ca4221..d0297ec 100644 (file)
@@ -6,7 +6,7 @@ MD5 is described in RFC 1321.
 
 You will need perl version 5.004 or better to install this module.
 
-Copyright 1998-2002 Gisle Aas.
+Copyright 1998-2003 Gisle Aas.
 Copyright 1995-1996 Neil Winton.
 Copyright 1990-1992 RSA Data Security, Inc.
 
index 4176062..e9660f3 100644 (file)
@@ -1,6 +1,8 @@
 BEGIN {
-        chdir 't' if -d 't';
-        @INC = '../lib';
+       if ($ENV{PERL_CORE}) {
+               chdir 't' if -d 't';
+               @INC = '../lib';
+       }
 }
 
 # Test that md5 works on unaligned memory blocks
index bf8aa06..6351af5 100644 (file)
@@ -10,11 +10,6 @@ print "1..5\n";
 use strict;
 use Digest::MD5 qw(md5 md5_hex md5_base64);
 
-#
-# This is the output of: 'md5sum Changes README MD5.pm MD5.xs rfc1321.txt'
-#
-my $EXPECT;
-
 # To update the EBCDIC section even on a Latin 1 platform,
 # run this script with $ENV{EBCDIC_MD5SUM} set to a true value.
 # (You'll need to have Perl 5.7.3 or later, to have the Encode installed.)
@@ -22,28 +17,30 @@ my $EXPECT;
 #  also have the $ENV{PERL_CORE} set to a true value.)
 # Similarly, to update MacOS section, run with $ENV{MAC_MD5SUM} set.
 
+my $EXPECT;
 if (ord "A" == 193) { # EBCDIC
     $EXPECT = <<EOT;
-b362148b17a451f0d81e0ebb2487756e  Changes
-5a591a47e8c40fe4b78c744111511c45  README
-3157e2d2e27dacddea7c54efddc32520  MD5.pm
-4850753428db9422e8e5f97b401d5a13  MD5.xs
+ed8efe2e2dbab62fcc9dea2df6682569  Changes
+0565ec21b15c0f23f4c51fb327c8926d  README
+0fcdd6d6e33b8772bd4b4832043035cd  MD5.pm
+d7fd24455b9160aa8706635d15e6177e  MD5.xs
 276da0aa4e9a08b7fe09430c9c5690aa  rfc1321.txt
 EOT
 } elsif ("\n" eq "\015") { # MacOS
     $EXPECT = <<EOT;
-cc90a85f89b397341f97c9279640fbf5  Changes
-127952946201e6afc19eb41250c56871  README
-d87ec77c963d27198b7427156167a5b3  MD5.pm
-5be7049479ea47d7c257dabcae835720  MD5.xs
-f9a35714ee1d1d0c5a3a80f4dbea956a  rfc1321.txt
+2879619f967d5fc5a00ffe37b639f2ee  Changes
+6c950a0211a5a28f023bb482037698cd  README
+4e1043f0a7a266416d8408d6fa96f454  MD5.pm
+6bff95ff70ba43a6c81e255c6510a865  MD5.xs
+754b9db19f79dbc4992f7166eb0f37ce  rfc1321.txt
 EOT
 } else {
+    # This is the output of: 'md5sum Changes README MD5.pm MD5.xs rfc1321.txt'
     $EXPECT = <<EOT;
-0106b67df0dbf9f4d65e9fc04907745b  Changes
-3519f3d02c7c91158f732f0f00064657  README
-88c35ca46c7e8069fb5ae00c091c98d6  MD5.pm
-1be293491bba726810f8e87671ee0328  MD5.xs
+2879619f967d5fc5a00ffe37b639f2ee  Changes
+6c950a0211a5a28f023bb482037698cd  README
+4e1043f0a7a266416d8408d6fa96f454  MD5.pm
+6bff95ff70ba43a6c81e255c6510a865  MD5.xs
 754b9db19f79dbc4992f7166eb0f37ce  rfc1321.txt
 EOT
 }
@@ -187,8 +184,8 @@ sub cat_file
     local $/;  # slurp
     open(FILE, $file) or die "Can't open $file: $!";
 
-    # For PerlIO (Perl 5.8.0 and later) in case of UTF-8 locales.
-    eval { binmode(FILE, ":bytes"); };
+    # For PerlIO in case of UTF-8 locales.
+    eval 'binmode(FILE, ":bytes")' if $] >= 5.008;
 
     my $tmp = <FILE>;
     close(FILE);
index 60452d8..cc1615a 100644 (file)
@@ -1,9 +1,26 @@
 # Revision history for Perl extension Encode.
 #
-# $Id: Changes,v 1.83 2002/11/18 17:28:49 dankogai Exp dankogai $
+# $Id: Changes,v 1.84 2003/01/10 12:00:16 dankogai Exp dankogai $
 #
 
-$Revision: 1.83 $ $Date: 2002/11/18 17:28:49 $
+$Revision: 1.84 $ $Date: 2003/01/10 12:00:16 $
+! encoding.pm
+  ${^ENCODING} is no longer set for utf so encoding is no longer fun :)
+  (That is to prevent duplicate encoding first by IO then ${^ENCODING})
+  Message-Id: <20030108213737.GK331043@lyta.hut.fi>
+! Unicode/Unicode.xs
+  %_ fixes saves the resulting .so .05% smaller, by NC
+  Message-Id: <20021226225709.GF284@Bagpuss.unfortu.net>
+! Encode.pm
+  Silence Encode on undef, by Andreas
+  Message-Id: <m3smwrohd1.fsf@k242.linux.bogus>
+  Message-Id: <m3of7fo7np.fsf@k242.linux.bogus>
+! Unicode/Unicode.xs
+  s/regognised/recognised/ .  British spelling left intact to pay
+  respect to two British Nicks :)
+  Message-Id: <20021203020454.GK2274@kosh.hut.fi>
+
+1.83 2002/11/18 17:28:49
 ! Encode.xs lib/Encode/JIS7.pm
   Even more patches from Inaba-san has been applied.  With this
   patch t/uni/tr_7jis.t and t/uni/t_utf8.t of bleedperl will work.
index 01dc8ff..4bf30e1 100644 (file)
@@ -1,9 +1,9 @@
 #
-# $Id: Encode.pm,v 1.83 2002/11/18 17:28:29 dankogai Exp $
+# $Id: Encode.pm,v 1.84 2003/01/10 12:00:16 dankogai Exp dankogai $
 #
 package Encode;
 use strict;
-our $VERSION = do { my @r = (q$Revision: 1.83 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+our $VERSION = do { my @r = (q$Revision: 1.84 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
 our $DEBUG = 0;
 use XSLoader ();
 XSLoader::load(__PACKAGE__, $VERSION);
@@ -131,6 +131,7 @@ sub resolve_alias {
 sub encode($$;$)
 {
     my ($name, $string, $check) = @_;
+    return undef unless defined $string;
     $check ||=0;
     my $enc = find_encoding($name);
     unless(defined $enc){
@@ -145,6 +146,7 @@ sub encode($$;$)
 sub decode($$;$)
 {
     my ($name,$octets,$check) = @_;
+    return undef unless defined $octets;
     $check ||=0;
     my $enc = find_encoding($name);
     unless(defined $enc){
@@ -159,6 +161,7 @@ sub decode($$;$)
 sub from_to($$$;$)
 {
     my ($string,$from,$to,$check) = @_;
+    return undef unless defined $string;
     $check ||=0;
     my $f = find_encoding($from);
     unless (defined $f){
index d125cd0..e34d961 100644 (file)
@@ -1,5 +1,5 @@
 /*
- $Id: Encode.xs,v 1.52 2002/11/18 17:28:49 dankogai Exp dankogai $
+ $Id: Encode.xs,v 1.52 2002/11/18 17:28:49 dankogai Exp $
  */
 
 #define PERL_NO_GET_CONTEXT
index 77c189e..cb4a0d8 100644 (file)
@@ -61,6 +61,7 @@ t/big5-eten.enc       test data
 t/big5-eten.utf        test data
 t/big5-hkscs.enc       test data
 t/big5-hkscs.utf       test data
+t/enc_utf8.t   test script
 t/encoding.t   test script
 t/fallback.t   test script
 t/gb2312.enc   test data
index 7c79d4a..fb5c61b 100644 (file)
@@ -1,5 +1,5 @@
 /*
- $Id: Unicode.xs,v 1.5 2002/05/20 15:25:44 dankogai Exp $
+ $Id: Unicode.xs,v 1.6 2003/01/10 12:00:16 dankogai Exp dankogai $
  */
 
 #define PERL_NO_GET_CONTEXT
@@ -113,8 +113,8 @@ CODE:
                endian = 'V';
            }
            else {
-               croak("%s:Unregognised BOM %"UVxf,
-                      SvPV_nolen(*hv_fetch((HV *)SvRV(obj),"Name",4,0)),
+               croak("%"SVf": Unrecognised BOM %"UVxf,
+                      *hv_fetch((HV *)SvRV(obj),"Name",4,0),
                      bom);
            }
        }
@@ -129,8 +129,8 @@ CODE:
        if (size != 4 && invalid_ucs2(ord)) {
            if (ucs2) {
                if (check) {
-                   croak("%s:no surrogates allowed %"UVxf,
-                         SvPV_nolen(*hv_fetch((HV *)SvRV(obj),"Name",4,0)),
+                   croak("%"SVf":no surrogates allowed %"UVxf,
+                         *hv_fetch((HV *)SvRV(obj),"Name",4,0),
                          ord);
                }
                if (s+size <= e) {
@@ -142,8 +142,8 @@ CODE:
            else {
                UV lo;
                if (!isHiSurrogate(ord)) {
-                   croak("%s:Malformed HI surrogate %"UVxf,
-                         SvPV_nolen(*hv_fetch((HV *)SvRV(obj),"Name",4,0)),
+                   croak("%"SVf":Malformed HI surrogate %"UVxf,
+                         *hv_fetch((HV *)SvRV(obj),"Name",4,0),
                          ord);
                }
                if (s+size > e) {
@@ -153,8 +153,8 @@ CODE:
                }
                lo = enc_unpack(aTHX_ &s,e,size,endian);
                if (!isLoSurrogate(lo)){
-                   croak("%s:Malformed LO surrogate %"UVxf,
-                         SvPV_nolen(*hv_fetch((HV *)SvRV(obj),"Name",4,0)),
+                   croak("%"SVf":Malformed LO surrogate %"UVxf,
+                         *hv_fetch((HV *)SvRV(obj),"Name",4,0),
                          ord);
                }
                ord = 0x10000 + ((ord - 0xD800) << 10) + (lo - 0xDC00);
@@ -165,8 +165,8 @@ CODE:
        SvCUR_set(result,d - (U8 *)SvPVX(result));
     }
     if (s < e) {
-           Perl_warner(aTHX_ packWARN(WARN_UTF8),"%s:Partial character",
-                       SvPV_nolen(*hv_fetch((HV *)SvRV(obj),"Name",4,0)));
+           Perl_warner(aTHX_ packWARN(WARN_UTF8),"%"SVf":Partial character",
+                       *hv_fetch((HV *)SvRV(obj),"Name",4,0));
     }
     if (check && !(check & ENCODE_LEAVE_SRC)){
        if (s < e) {
@@ -212,10 +212,8 @@ CODE:
            if (!issurrogate(ord)){
                if (ucs2) {
                    if (check) {
-                       croak("%s:code point \"\\x{%"UVxf"}\" too high",
-                             SvPV_nolen(
-                                 *hv_fetch((HV *)SvRV(obj),"Name",4,0))
-                             ,ord);
+                       croak("%"SVf":code point \"\\x{%"UVxf"}\" too high",
+                                 *hv_fetch((HV *)SvRV(obj),"Name",4,0),ord);
                    }
                    enc_pack(aTHX_ result,size,endian,FBCHAR);
                }else{
@@ -235,8 +233,8 @@ CODE:
        }
     }
     if (s < e) {
-       Perl_warner(aTHX_ packWARN(WARN_UTF8),"%s:Partial character",
-                   SvPV_nolen(*hv_fetch((HV *)SvRV(obj),"Name",4,0)));
+       Perl_warner(aTHX_ packWARN(WARN_UTF8),"%"SVf":Partial character",
+                   *hv_fetch((HV *)SvRV(obj),"Name",4,0));
     }
     if (check && !(check & ENCODE_LEAVE_SRC)){
        if (s < e) {
index 778b44b..1a43790 100644 (file)
@@ -1,5 +1,5 @@
 package encoding;
-our $VERSION = do { my @r = (q$Revision: 1.37 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+our $VERSION = do { my @r = (q$Revision: 1.38 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
 
 use Encode;
 use strict;
@@ -28,8 +28,8 @@ sub import {
        require Carp;
        Carp::croak("Unknown encoding '$name'");
     }
-    unless ($arg{Filter}){
-       ${^ENCODING} = $enc; # this is all you need, actually.
+    unless ($arg{Filter}) {
+       ${^ENCODING} = $enc;
        $HAS_PERLIO or return 1;
        for my $h (qw(STDIN STDOUT)){
            if ($arg{$h}){
index 5421f23..72e5d3c 100644 (file)
@@ -57,7 +57,7 @@ for my $charset (sort keys %Charset){
 
 
     open $src, "<$src_enc" or die "$src_enc : $!";
-    # binmode($src); # not needed! 
+    binmode($src); # needed if UTF-8 locales enabled!
 
     $txt = join('',<$src>);
     close($src);
diff --git a/ext/Encode/t/enc_eucjp.t b/ext/Encode/t/enc_eucjp.t
new file mode 100644 (file)
index 0000000..019b426
--- /dev/null
@@ -0,0 +1,66 @@
+# This is the twin of enc_utf8.t, the only difference is that
+# this has "use encoding 'euc-jp'".
+
+BEGIN {
+    require Config; import Config;
+    if ($Config{'extensions'} !~ /\bEncode\b/) {
+      print "1..0 # Skip: Encode was not built\n";
+      exit 0;
+    }
+    unless (find PerlIO::Layer 'perlio') {
+       print "1..0 # Skip: PerlIO was not built\n";
+       exit 0;
+    }
+    if (ord("A") == 193) {
+       print "1..0 # encoding pragma does not support EBCDIC platforms\n";
+       exit(0);
+    }
+}
+
+use encoding 'euc-jp';
+
+my @c = (127, 128, 255, 256);
+
+print "1.." . (scalar @c + 1) . "\n";
+
+my @f;
+
+for my $i (0..$#c) {
+  push @f, "f$i";
+  open(F, ">f$i") or die "$0: failed to open 'f$i' for writing: $!";
+  binmode(F, ":utf8");
+  print F chr($c[$i]);
+  close F;
+}
+
+my $t = 1;
+
+for my $i (0..$#c) {
+  open(F, "<f$i") or die "$0: failed to open 'f$i' for reading: $!";
+  binmode(F, ":utf8");
+  my $c = <F>;
+  my $o = ord($c);
+  print $o == $c[$i] ? "ok $t - utf8 I/O $c[$i]\n" : "not ok $t - utf8 I/O $c[$i]: $o != $c[$i]\n";
+  $t++;
+}
+
+my $f = "f" . @f;
+
+push @f, $f;
+open(F, ">$f") or die "$0: failed to open '$f' for writing: $!";
+binmode(F, ":raw"); # Output raw bytes.
+print F chr(128); # Output illegal UTF-8.
+close F;
+open(F, $f) or die "$0: failed to open '$f' for reading: $!";
+binmode(F, ":encoding(utf-8)");
+{
+       local $^W = 1;
+       local $SIG{__WARN__} = sub { $a = shift };
+       eval { <F> }; # This should get caught.
+}
+print $a =~ qr{^utf8 "\\x80" does not map to Unicode} ?
+  "ok $t - illegal utf8 input\n" : "not ok $t - illegal utf8 input: a = " . unpack("H*", $a) . "\n";
+
+END {
+  1 while unlink @f;
+}
diff --git a/ext/Encode/t/enc_utf8.t b/ext/Encode/t/enc_utf8.t
new file mode 100644 (file)
index 0000000..6271fe6
--- /dev/null
@@ -0,0 +1,66 @@
+# This is the twin of enc_eucjp.t, the only difference is that
+# this has "use encoding 'utf8'".
+
+BEGIN {
+    require Config; import Config;
+    if ($Config{'extensions'} !~ /\bEncode\b/) {
+      print "1..0 # Skip: Encode was not built\n";
+      exit 0;
+    }
+    unless (find PerlIO::Layer 'perlio') {
+       print "1..0 # Skip: PerlIO was not built\n";
+       exit 0;
+    }
+    if (ord("A") == 193) {
+       print "1..0 # encoding pragma does not support EBCDIC platforms\n";
+       exit(0);
+    }
+}
+
+use encoding 'utf8';
+
+my @c = (127, 128, 255, 256);
+
+print "1.." . (scalar @c + 1) . "\n";
+
+my @f;
+
+for my $i (0..$#c) {
+  push @f, "f$i";
+  open(F, ">f$i") or die "$0: failed to open 'f$i' for writing: $!";
+  binmode(F, ":utf8");
+  print F chr($c[$i]);
+  close F;
+}
+
+my $t = 1;
+
+for my $i (0..$#c) {
+  open(F, "<f$i") or die "$0: failed to open 'f$i' for reading: $!";
+  binmode(F, ":utf8");
+  my $c = <F>;
+  my $o = ord($c);
+  print $o == $c[$i] ? "ok $t - utf8 I/O $c[$i]\n" : "not ok $t - utf8 I/O $c[$$i]: $o != $c[$i]\n";
+  $t++;
+}
+
+my $f = "f" . @f;
+
+push @f, $f;
+open(F, ">$f") or die "$0: failed to open '$f' for writing: $!";
+binmode(F, ":raw"); # Output raw bytes.
+print F chr(128); # Output illegal UTF-8.
+close F;
+open(F, $f) or die "$0: failed to open '$f' for reading: $!";
+binmode(F, ":encoding(utf-8)");
+{
+       local $^W = 1;
+       local $SIG{__WARN__} = sub { $a = shift };
+       eval { <F> }; # This should get caught.
+}
+print $a =~ qr{^utf8 "\\x80" does not map to Unicode} ?
+  "ok $t - illegal utf8 input\n" : "not ok $t - illegal utf8 input: a = " . unpack("H*", $a) . "\n";
+
+END {
+  1 while unlink @f;
+}
index 29fb7d5..6703418 100644 (file)
@@ -1,5 +1,5 @@
 #
-# $Id: Base64.pm,v 2.16 2001/02/24 06:28:10 gisle Exp $
+# $Id: Base64.pm,v 2.19 2002/12/28 06:32:37 gisle Exp $
 
 package MIME::Base64;
 
@@ -135,7 +135,7 @@ require DynaLoader;
 @ISA = qw(Exporter DynaLoader);
 @EXPORT = qw(encode_base64 decode_base64);
 
-$VERSION = '2.12';
+$VERSION = '2.13';
 
 eval { bootstrap MIME::Base64 $VERSION; };
 if ($@) {
@@ -155,12 +155,13 @@ use integer;
 
 sub old_encode_base64 ($;$)
 {
-    my $res = "";
     my $eol = $_[1];
     $eol = "\n" unless defined $eol;
-    pos($_[0]) = 0;                          # ensure start at the beginning
 
-    $res = join '', map( pack('u',$_)=~ /^.(\S*)/, ($_[0]=~/(.{1,45})/gs));
+    my $res = pack("u", $_[0]);
+    # Remove first character of each line, remove newlines
+    $res =~ s/^.//mg;
+    $res =~ s/\n//g;
 
     $res =~ tr|` -_|AA-Za-z0-9+/|;               # `# help emacs
     # fix padding at the end
@@ -187,8 +188,22 @@ sub old_decode_base64 ($)
     $str =~ s/=+$//;                        # remove padding
     $str =~ tr|A-Za-z0-9+/| -_|;            # convert to uuencoded format
 
-    return join'', map( unpack("u", chr(32 + length($_)*3/4) . $_),
-                       $str =~ /(.{1,60})/gs);
+    ## I guess this could be written as
+    #return unpack("u", join('', map( chr(32 + length($_)*3/4) . $_,
+    #                  $str =~ /(.{1,60})/gs) ) );
+    ## but I do not like that...
+    my $uustr = '';
+    my ($i, $l);
+    $l = length($str) - 60;
+    for ($i = 0; $i <= $l; $i += 60) {
+       $uustr .= "M" . substr($str, $i, 60);
+    }
+    $str = substr($str, $i);
+    # and any leftover chars
+    if ($str ne "") {
+       $uustr .= chr(32 + length($str)*3/4) . $str;
+    }
+    return unpack ("u", $uustr);
 }
 
 # Set up aliases so that these functions also can be called as
index 10cd3ce..a462317 100644 (file)
@@ -1,3 +1,19 @@
+2002-02-27   Gisle Aas <gisle@ActiveState.com>
+
+   Release 2.13
+
+   Sync up with bleadperl:
+       - Documentation update
+       - EBCDIC support
+       - Whitespace tweaks
+       - Improved Unicode support
+       - Test suite tweaks
+
+   Improved version of the old_{en,de}code_base64 functions
+   contributed by Paul Szabo <psz@maths.usyd.edu.au>.
+
+
+
 2001-02-23   Gisle Aas <gisle@ActiveState.com>
 
    Release 2.12
index 2cdc018..c2d4cbf 100644 (file)
@@ -1,5 +1,5 @@
 #
-# $Id: QuotedPrint.pm,v 2.3 1997/12/02 10:24:27 aas Exp $
+# $Id: QuotedPrint.pm,v 2.4 2002/12/28 05:50:05 gisle Exp $
 
 package MIME::QuotedPrint;
 
@@ -74,13 +74,18 @@ require Exporter;
 
 use Carp qw(croak);
 
-$VERSION = sprintf("%d.%02d", q$Revision: 2.3 $ =~ /(\d+)\.(\d+)/);
+$VERSION = sprintf("%d.%02d", q$Revision: 2.4 $ =~ /(\d+)\.(\d+)/);
 
 sub encode_qp ($)
 {
     my $res = shift;
-    croak("The Quoted-Printable encoding is only defined for bytes")
-       if $res =~ /[^\0-\xFF]/;
+    if ($] >= 5.006) {
+       require bytes;
+       if (bytes::length($res) > length($res) ||
+           ($] >= 5.008 && $res =~ /[^\0-\xFF]/)) {
+           croak("The Quoted-Printable encoding is only defined for bytes");
+       }
+    }
 
     # Do not mention ranges such as $res =~ s/([^ \t\n!-<>-~])/sprintf("=%02X", ord($1))/eg;
     # since that will not even compile on an EBCDIC machine (where ord('!') > ord('<')).
index 97e525e..395958e 100644 (file)
@@ -1,6 +1,8 @@
 BEGIN {
-        chdir 't' if -d 't';
-        @INC = '../lib';
+        if ($ENV{PERL_CORE}) {
+                chdir 't' if -d 't';
+                @INC = '../lib';
+        }
 }
 
 use MIME::QuotedPrint;
@@ -111,5 +113,5 @@ print "not " unless decode_qp("foo  \r\n\r\nfoo =\r\n\r\nfoo=20\r\n\r\n") eq
                                 "foo\r\n\r\nfoo \r\nfoo \r\n\r\n";
 $testno++; print "ok $testno\n";
 
-print "not " if eval { encode_qp("XXX \x{100}") } || $@ !~ /^The Quoted-Printable encoding is only defined for bytes/;
+print "not " if $] >= 5.006 && (eval 'encode_qp("XXX \x{100}")' || $@ !~ /^The Quoted-Printable encoding is only defined for bytes/);
 $testno++; print "ok $testno\n";
index 0b8df1a..8037440 100644 (file)
@@ -1,6 +1,12 @@
 BEGIN {
-        chdir 't' if -d 't';
-        @INC = '../lib';
+       unless ($] >= 5.006) {
+               print "1..0\n";
+               exit(0);
+       }
+        if ($ENV{PERL_CORE}) {
+                chdir 't' if -d 't';
+                @INC = '../lib';
+        }
 }
 
 print "1..1\n";
index 2340fb5..971e701 100644 (file)
@@ -1,5 +1,26 @@
 Revision history for Perl extension Time::HiRes.
 
+1.42
+       - modernize the constants code (from Nicholas Clark)
+
+1.41
+       - At some point the ability to figure our the correct incdir
+         for EXTERN.h (either a core perl build, or an installed perl)
+         had broken (which lead into all test compiles failing with
+         a core perl build, but thanks to the robustness of Makefile.PL
+         nothing of was visible).  The brokenness seemed to be caused
+         by $ENV{PERL_CORE} not being on for core builds?  Now stole
+         a trick from the Encode that sets $ENV{PERL_CORE} right, and
+         both styles of build should work again.
+
+1.40
+       - Nicholas Clark noticed that the my_catdir() emulation function
+         was broken (which means that we didn't really work for Perls
+         5.002 and 5.003)
+       - inspired by fixing the above made the whole Makefile.PL -w
+         and strict clean
+       - tightened up the Makefile.PL output, less whitespace
+
 1.39
        - fix from Craig Berry for better building in VMS with PERL_CORE
 
index 532484e..ffa010b 100644 (file)
@@ -15,18 +15,16 @@ require DynaLoader;
                 d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer
                 d_nanosleep);
        
-$VERSION = '1.39';
+$VERSION = '1.42';
 $XS_VERSION = $VERSION;
 $VERSION = eval $VERSION;
 
 sub AUTOLOAD {
     my $constname;
-    ($constname= $AUTOLOAD) =~ s/.*:://;
-    my $val = constant($constname, @_ ? $_[0] : 0);
-    if ($!) {
-       my ($pack,$file,$line) = caller;
-       die "Your vendor has not defined Time::HiRes macro $constname, used at $file line $line.\n";
-    }
+    ($constname = $AUTOLOAD) =~ s/.*:://;
+    die "&Time::HiRes::constant not defined" if $constname eq 'constant';
+    my ($error, $val) = constant($constname);
+    if ($error) { die $error; }
     {
        no strict 'refs';
        *$AUTOLOAD = sub { $val };
index 5da54c6..560cb3d 100644 (file)
@@ -98,77 +98,14 @@ sv_2pv_nolen(pTHX_ register SV *sv)
 #   undef ITIMER_REALPROF
 #endif
 
-static IV
-constant(char *name, int arg)
-{
-    errno = 0;
-    switch (*name) {
-    case 'd':
-      if (strEQ(name, "d_getitimer"))
-#ifdef HAS_GETITIMER
-       return 1;
-#else
-       return 0;
-#endif
-      if (strEQ(name, "d_nanosleep"))
-#ifdef HAS_NANOSLEEP
-       return 1;
-#else
-       return 0;
-#endif
-      if (strEQ(name, "d_setitimer"))
-#ifdef HAS_SETITIMER
-       return 1;
-#else
-       return 0;
-#endif
-      if (strEQ(name, "d_ualarm"))
-#ifdef HAS_UALARM
-       return 1;
-#else
-       return 0;
-#endif
-      if (strEQ(name, "d_usleep"))
-#ifdef HAS_USLEEP
-       return 1;
-#else
-       return 0;
+/* 5.004 doesn't define PL_sv_undef */
+#ifndef ATLEASTFIVEOHOHFIVE
+#ifndef PL_sv_undef
+#define PL_sv_undef sv_undef
 #endif
-      break;
-    case 'I':
-      if (strEQ(name, "ITIMER_REAL"))
-#ifdef ITIMER_REAL
-       return ITIMER_REAL;
-#else
-       goto not_there;
-#endif
-      if (strEQ(name, "ITIMER_REALPROF"))
-#ifdef ITIMER_REALPROF
-       return ITIMER_REALPROF;
-#else
-       goto not_there;
 #endif
-      if (strEQ(name, "ITIMER_VIRTUAL"))
-#ifdef ITIMER_VIRTUAL
-       return ITIMER_VIRTUAL;
-#else
-       goto not_there;
-#endif
-      if (strEQ(name, "ITIMER_PROF"))
-#ifdef ITIMER_PROF
-       return ITIMER_PROF;
-#else
-       goto not_there;
-#endif
-      break;
-    }
-    errno = EINVAL;
-    return 0;
 
-not_there:
-    errno = ENOENT;
-    return 0;
-}
+#include "const-c.inc"
 
 #if !defined(HAS_GETTIMEOFDAY) && defined(WIN32)
 #define HAS_GETTIMEOFDAY
@@ -699,10 +636,7 @@ BOOT:
 #endif
 #endif
 
-IV
-constant(name, arg)
-       char *          name
-       int             arg
+INCLUDE: const-xs.inc
 
 #if defined(HAS_USLEEP) && defined(HAS_GETTIMEOFDAY)
 
index 5868239..50b98ba 100644 (file)
@@ -7,10 +7,18 @@ require 5.002;
 
 use Config;
 use ExtUtils::MakeMaker;
-
-# Perls 5.002 and 5.003 did not have File::Spec, fake what we need.
+use strict;
 
 my $VERBOSE = $ENV{VERBOSE};
+my $DEFINE;
+my $LIBS;
+my $XSOPT;
+
+unless($ENV{PERL_CORE}) { # This trick from Encode/Makefile.PL.
+    $ENV{PERL_CORE} = 1 if ($^X =~ m{\bminiperl[^/\\\]>:]*$}o);
+}
+
+# Perls 5.002 and 5.003 did not have File::Spec, fake what we need.
 
 sub my_dirsep {
     $^O eq 'VMS' ? '.' :
@@ -22,7 +30,14 @@ sub my_dirsep {
 sub my_catdir {
     shift;
     my $catdir = join(my_dirsep, @_);
-    $^O eq 'VMS' ? "[$dirsep]" : $dirsep;
+    $^O eq 'VMS' ? "[$catdir]" : $catdir;
+}
+
+sub my_catfile {
+    shift;
+    return join(my_dirsep, @_) unless $^O eq 'VMS';
+    my $file = pop;
+    return my_catdir (undef, @_) . $file;
 }
 
 sub my_updir {
@@ -35,9 +50,15 @@ BEGIN {
     if ($@) {
        *File::Spec::catdir = \&my_catdir;
        *File::Spec::updir  = \&my_updir;
+       *File::Spec::catfile = \&my_catfile;
     }
 }
 
+# Avoid 'used only once' warnings.
+my $nop1 = *File::Spec::catdir;
+my $nop2 = *File::Spec::updir;
+my $nop3 = *File::Spec::catfile;
+
 # if you have 5.004_03 (and some slightly older versions?), xsubpp
 # tries to generate line numbers in the C code generated from the .xs.
 # unfortunately, it is a little buggy around #ifdef'd code.
@@ -50,8 +71,7 @@ sub TMPDIR {
     my $TMPDIR =
        (grep(defined $_ && -d $_ && -w _,
              ((defined $ENV{'TMPDIR'} ? $ENV{'TMPDIR'} : undef),
-              qw(/var/tmp /usr/tmp /tmp))))[0]
-                  unless defined $TMPDIR;
+              qw(/var/tmp /usr/tmp /tmp))))[0];
     $TMPDIR || die "Cannot find writable temporary directory.\n";
 }
 
@@ -59,7 +79,7 @@ sub try_compile_and_link {
     my ($c, %args) = @_;
 
     my ($ok) = 0;
-    my ($tmp) = (($^O eq 'VMS') ? "sys\$scratch:tmp$$" : TMPDIR . '/' . "tmp$$");
+    my ($tmp) = (($^O eq 'VMS') ? "sys\$scratch:tmp$$" : TMPDIR() . '/' . "tmp$$");
     local(*TMPC);
 
     my $obj_ext = $Config{obj_ext} || ".o";
@@ -69,18 +89,21 @@ sub try_compile_and_link {
        print TMPC $c;
        close(TMPC);
 
-       $cccmd = $args{cccmd};
+       my $cccmd = $args{cccmd};
 
        my $errornull;
 
        my $COREincdir;
+
        if ($ENV{PERL_CORE}) {
            my $updir = File::Spec->updir;
            $COREincdir = File::Spec->catdir(($updir) x 3);
        } else {
            $COREincdir = File::Spec->catdir($Config{'archlibexp'}, 'CORE');
        }
+
        my $ccflags = $Config{'ccflags'} . ' ' . "-I$COREincdir";
+
        if ($^O eq 'VMS') {
            if ($ENV{PERL_CORE}) {
                # Fragile if the extensions change hierachy within
@@ -89,7 +112,7 @@ sub try_compile_and_link {
            } else {
                my $perl_core = $Config{'installarchlib'};
                $perl_core =~ s/\]$/.CORE]/;
-                $cccmd = "$Config{'cc'} /include=(perl_root:[000000],$perl_core) $tmp.c"; 
+                $cccmd = "$Config{'cc'} /include=(perl_root:[000000],$perl_core) $tmp.c";
            }
         }
 
@@ -99,18 +122,19 @@ sub try_compile_and_link {
            $errornull = '';
        }
 
-       $cccmd = "$Config{'cc'} -o $tmp $ccflags $tmp.c @$LIBS $errornull"
+        $cccmd = "$Config{'cc'} -o $tmp $ccflags $tmp.c @$LIBS $errornull"
            unless defined $cccmd;
+
        if ($^O eq 'VMS') {
            open( CMDFILE, ">$tmp.com" );
            print CMDFILE "\$ SET MESSAGE/NOFACILITY/NOSEVERITY/NOIDENT/NOTEXT\n";
            print CMDFILE "\$ $cccmd\n";
-           print CMDFILE "\$ IF \$SEVERITY .NE. 1 THEN EXIT 44\n";  # escalate
+           print CMDFILE "\$ IF \$SEVERITY .NE. 1 THEN EXIT 44\n"; # escalate
            close CMDFILE;
            system("\@ $tmp.com");
            $ok = $?==0;
            for ("$tmp.c", "$tmp$obj_ext", "$tmp.com", "$tmp$Config{exe_ext}") { 
-               1 while unlink $_; 
+               1 while unlink $_;
            }
         }
         else
@@ -128,7 +152,7 @@ sub try_compile_and_link {
 sub has_gettimeofday {
     # confusing but true (if condition true ==> -DHAS_GETTIMEOFDAY already)
     return 0 if $Config{'d_gettimeod'} eq 'define';
-    return 1 if try_compile_and_link(<<EOM); 
+    return 1 if try_compile_and_link(<<EOM);
 #include "EXTERN.h" 
 #include "perl.h" 
 #include "XSUB.h" 
@@ -157,7 +181,7 @@ EOM
 }
 
 sub has_x {
-    my ($x, %args) = @_; 
+    my ($x, %args) = @_;
 
     return 1 if
     try_compile_and_link(<<EOM, %args);
@@ -206,24 +230,27 @@ sub unixinit {
 
     my @goodlibs;
 
-    select(STDOUT); $| = 1;
+    select(STDOUT);
+    $| = 1;
 
     print "Checking for libraries...\n";
     my $lib;
     for $lib (@$LIBS) {
-       print "Checking for $lib...\n";
+       print "Checking for $lib... ";
        $LIBS = [ $lib ];
        if ($Config{libs} =~ /\b$lib\b/ || has_x("time(0)")) {
            push @goodlibs, $lib;
+           print "found.\n";
+       } else {
+           print "NOT found.\n";
        }
     }
-    @$LIBS = @goodlibs;
+    $LIBS = [ @goodlibs ];
     print @$LIBS ?
          "You have extra libraries: @$LIBS.\n" :
           "You have no applicable extra libraries.\n";
-    print "\n";
 
-    print "Looking for gettimeofday()...\n";
+    print "Looking for gettimeofday()... ";
     my $has_gettimeofday;
     if ($Config{'d_gettimeod'}) {
        $has_gettimeofday++;
@@ -233,7 +260,7 @@ sub unixinit {
     }
 
     if ($has_gettimeofday) {
-       print "You have gettimeofday().\n\n";
+       print "found.\n";
     } else {
        die <<EOD
 Your operating system does not seem to have the gettimeofday() function.
@@ -248,7 +275,7 @@ Aborting configuration.
 EOD
     }
 
-    print "Looking for setitimer()...\n";
+    print "Looking for setitimer()... ";
     my $has_setitimer;
     if ($Config{d_setitimer}) {
         $has_setitimer++;
@@ -258,12 +285,12 @@ EOD
     }
 
     if ($has_setitimer) {
-        print "You have setitimer().\n\n";
+        print "found.\n";
     } else {
-       print "No setitimer().\n\n";
+       print "NOT found.\n";
     }
 
-    print "Looking for getitimer()...\n";
+    print "Looking for getitimer()... ";
     my $has_getitimer;
     if ($Config{d_getitimer}) {
         $has_getitimer++;
@@ -273,19 +300,19 @@ EOD
     }
 
     if ($has_getitimer) {
-        print "You have getitimer().\n\n";
+        print "found.\n";
     } else {
-       print "No getitimer().\n\n";
+       print "NOT found.\n";
     }
 
     if ($has_setitimer && $has_getitimer) {
-       print "You have interval timers (both setitimer and setitimer).\n\n";
+       print "You have interval timers (both setitimer and setitimer).\n";
     } else {
-       print "You do not have interval timers.\n\n";
+       print "You do not have interval timers.\n";
     }
 
-    print "Looking for ualarm()...\n";
-    my $has_ualarm; 
+    print "Looking for ualarm()... ";
+    my $has_ualarm;
     if ($Config{d_ualarm}) {
         $has_ualarm++;
     } elsif (has_x ("ualarm (0, 0)")) {
@@ -294,17 +321,16 @@ EOD
     }
 
     if ($has_ualarm) {
-        print "You have ualarm().\n\n";
+        print "found.\n";
     } else {
-       print "Whoops! No ualarm()!\n";
-       if ($setitimer) {
-           print "You have setitimer(); we can make a Time::HiRes::ualarm()\n\n";
-       } else {
-            print "We'll manage.\n\n";
+       print "NOT found.\n";
+       if ($has_setitimer) {
+           print "But you have setitimer().\n";
+           print "We can make a Time::HiRes::ualarm().\n";
        }
     }
 
-    print "Looking for usleep()...\n";
+    print "Looking for usleep()... ";
     my $has_usleep;
     if ($Config{d_usleep}) {
        $has_usleep++;
@@ -314,17 +340,20 @@ EOD
     }
 
     if ($has_usleep) {
-       print "You have usleep().\n\n";
+       print "found.\n";
     } else {
-       print "Whoops! No usleep()! Let's see if you have select().\n";
+       print "NOT found.\n";
+        print "Let's see if you have select()... ";
         if ($Config{'d_select'} eq 'define') {
-           print "You have select(); we can make a Time::HiRes::usleep()\n\n";
+           print "found.\n";
+           print "We can make a Time::HiRes::usleep().\n";
        } else {
-           print "No select(); you won't have a Time::HiRes::usleep()\n\n";
+           print "NOT found.\n";
+           print "You won't have a Time::HiRes::usleep().\n";
        }
     }
 
-    print "Looking for nanosleep()...\n";
+    print "Looking for nanosleep()... ";
     my $has_nanosleep;
     if ($Config{d_nanosleep}) {
        $has_nanosleep++;
@@ -334,9 +363,11 @@ EOD
     }
 
     if ($has_nanosleep) {
-       print "You have nanosleep().  You can mix subsecond sleeps with signals.\n\n";
+       print "found.\n";
+        print "You can mix subsecond sleeps with signals.\n";
     } else {
-       print "Whoops! No nanosleep()!  You cannot mix subsecond sleeps with signals.\n";
+       print "NOT found.\n";
+        print "You cannot mix subsecond sleeps with signals.\n";
     }
 
     if ($DEFINE) {
@@ -349,7 +380,7 @@ EOD
 }
 
 sub doMakefile {
-    @makefileopts = ();
+    my @makefileopts = ();
 
     if ($] >= 5.005) {
        push (@makefileopts,
@@ -374,17 +405,42 @@ sub doMakefile {
            'SUFFIX'   => 'gz',
        },
         clean => { FILES => "xdefine" },
+        realclean => {FILES=> 'const-c.inc const-xs.inc'},
     );
 
     WriteMakefile(@makefileopts);
 }
 
-sub main {
-    print <<EOM;
-
-Configuring Time::HiRes...
+sub doConstants {
+    if (eval {require ExtUtils::Constant; 1}) {
+       my @names = (qw(ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF
+                       ITIMER_REALPROF));
+       foreach (qw (d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer
+                    d_nanosleep)) {
+           my $macro = $_;
+           $macro =~ s/d_(.*)/HAS_\U$1/;
+           push @names, {name => $_, macro => $macro, value => 1,
+                         default => ["IV", "0"]};
+       }
+       ExtUtils::Constant::WriteConstants(
+                                          NAME => 'Time::HiRes',
+                                          NAMES => \@names,
+                                         );
+    } else {
+       foreach my $file ('const-c.inc', 'const-xs.inc') {
+           my $fallback = File::Spec->catfile('fallback', $file);
+           local $/;
+           open IN, "<$fallback" or die "Can't open $fallback: $!";
+           open OUT, ">$file" or die "Can't open $file: $!";
+           print OUT <IN> or die $!;
+           close OUT or die "Can't close $file: $!";
+           close IN or die "Can't close $fallback: $!";
+       }
+    }
+}
 
-EOM
+sub main {
+    print "Configuring Time::HiRes...\n";
 
     if ($^O =~ /Win32/i) {
       $DEFINE = '-DSELECT_IS_BROKEN';
@@ -392,16 +448,12 @@ EOM
     } else {
       unixinit();
     }
-    configure;
     doMakefile;
+    doConstants;
     my $make = $Config{'make'} || "make";
     unless ($ENV{PERL_CORE}) {
        print  <<EOM;
-
-Done configuring.
-
 Now you may issue '$make'.  Do not forget also '$make test'.
-
 EOM
     }
 }
diff --git a/ext/Time/HiRes/fallback/const-c.inc b/ext/Time/HiRes/fallback/const-c.inc
new file mode 100644 (file)
index 0000000..77b137f
--- /dev/null
@@ -0,0 +1,202 @@
+#define PERL_constant_NOTFOUND 1
+#define PERL_constant_NOTDEF   2
+#define PERL_constant_ISIV     3
+#define PERL_constant_ISNO     4
+#define PERL_constant_ISNV     5
+#define PERL_constant_ISPV     6
+#define PERL_constant_ISPVN    7
+#define PERL_constant_ISSV     8
+#define PERL_constant_ISUNDEF  9
+#define PERL_constant_ISUV     10
+#define PERL_constant_ISYES    11
+
+#ifndef NVTYPE
+typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it.  */
+#endif
+#ifndef aTHX_
+#define aTHX_ /* 5.6 or later define this for threading support.  */
+#endif
+#ifndef pTHX_
+#define pTHX_ /* 5.6 or later define this for threading support.  */
+#endif
+
+static int
+constant_11 (pTHX_ const char *name, IV *iv_return) {
+  /* When generated this function returned values for the list of names given
+     here.  However, subsequent manual editing may have added or removed some.
+     ITIMER_PROF ITIMER_REAL d_getitimer d_nanosleep d_setitimer */
+  /* Offset 7 gives the best switch position.  */
+  switch (name[7]) {
+  case 'P':
+    if (memEQ(name, "ITIMER_PROF", 11)) {
+    /*                      ^          */
+#ifdef ITIMER_PROF
+      *iv_return = ITIMER_PROF;
+      return PERL_constant_ISIV;
+#else
+      return PERL_constant_NOTDEF;
+#endif
+    }
+    break;
+  case 'R':
+    if (memEQ(name, "ITIMER_REAL", 11)) {
+    /*                      ^          */
+#ifdef ITIMER_REAL
+      *iv_return = ITIMER_REAL;
+      return PERL_constant_ISIV;
+#else
+      return PERL_constant_NOTDEF;
+#endif
+    }
+    break;
+  case 'i':
+    if (memEQ(name, "d_getitimer", 11)) {
+    /*                      ^          */
+#ifdef HAS_GETITIMER
+      *iv_return = 1;
+      return PERL_constant_ISIV;
+#else
+      *iv_return = 0;
+      return PERL_constant_ISIV;
+#endif
+    }
+    if (memEQ(name, "d_setitimer", 11)) {
+    /*                      ^          */
+#ifdef HAS_SETITIMER
+      *iv_return = 1;
+      return PERL_constant_ISIV;
+#else
+      *iv_return = 0;
+      return PERL_constant_ISIV;
+#endif
+    }
+    break;
+  case 'l':
+    if (memEQ(name, "d_nanosleep", 11)) {
+    /*                      ^          */
+#ifdef HAS_NANOSLEEP
+      *iv_return = 1;
+      return PERL_constant_ISIV;
+#else
+      *iv_return = 0;
+      return PERL_constant_ISIV;
+#endif
+    }
+    break;
+  }
+  return PERL_constant_NOTFOUND;
+}
+
+static int
+constant (pTHX_ const char *name, STRLEN len, IV *iv_return) {
+  /* Initially switch on the length of the name.  */
+  /* When generated this function returned values for the list of names given
+     in this section of perl code.  Rather than manually editing these functions
+     to add or remove constants, which would result in this comment and section
+     of code becoming inaccurate, we recommend that you edit this section of
+     code, and use it to regenerate a new set of constant functions which you
+     then use to replace the originals.
+
+     Regenerate these constant functions by feeding this entire source file to
+     perl -x
+
+#!/usr/local/bin/perl5.8.0 -w
+use ExtUtils::Constant qw (constant_types C_constant XS_constant);
+
+my $types = {map {($_, 1)} qw(IV)};
+my @names = (qw(ITIMER_PROF ITIMER_REAL ITIMER_REALPROF ITIMER_VIRTUAL),
+            {name=>"d_getitimer", type=>"IV", macro=>"HAS_GETITIMER", value=>"1", default=>["IV", "0"]},
+            {name=>"d_gettimeofday", type=>"IV", macro=>"HAS_GETTIMEOFDAY", value=>"1", default=>["IV", "0"]},
+            {name=>"d_nanosleep", type=>"IV", macro=>"HAS_NANOSLEEP", value=>"1", default=>["IV", "0"]},
+            {name=>"d_setitimer", type=>"IV", macro=>"HAS_SETITIMER", value=>"1", default=>["IV", "0"]},
+            {name=>"d_ualarm", type=>"IV", macro=>"HAS_UALARM", value=>"1", default=>["IV", "0"]},
+            {name=>"d_usleep", type=>"IV", macro=>"HAS_USLEEP", value=>"1", default=>["IV", "0"]});
+
+print constant_types(); # macro defs
+foreach (C_constant ("Time::HiRes", 'constant', 'IV', $types, undef, 3, @names) ) {
+    print $_, "\n"; # C constant subs
+}
+print "#### XS Section:\n";
+print XS_constant ("Time::HiRes", $types);
+__END__
+   */
+
+  switch (len) {
+  case 8:
+    /* Names all of length 8.  */
+    /* d_ualarm d_usleep */
+    /* Offset 7 gives the best switch position.  */
+    switch (name[7]) {
+    case 'm':
+      if (memEQ(name, "d_ualarm", 8)) {
+      /*                      ^      */
+#ifdef HAS_UALARM
+        *iv_return = 1;
+        return PERL_constant_ISIV;
+#else
+        *iv_return = 0;
+        return PERL_constant_ISIV;
+#endif
+      }
+      break;
+    case 'p':
+      if (memEQ(name, "d_usleep", 8)) {
+      /*                      ^      */
+#ifdef HAS_USLEEP
+        *iv_return = 1;
+        return PERL_constant_ISIV;
+#else
+        *iv_return = 0;
+        return PERL_constant_ISIV;
+#endif
+      }
+      break;
+    }
+    break;
+  case 11:
+    return constant_11 (aTHX_ name, iv_return);
+    break;
+  case 14:
+    /* Names all of length 14.  */
+    /* ITIMER_VIRTUAL d_gettimeofday */
+    /* Offset 6 gives the best switch position.  */
+    switch (name[6]) {
+    case '_':
+      if (memEQ(name, "ITIMER_VIRTUAL", 14)) {
+      /*                     ^              */
+#ifdef ITIMER_VIRTUAL
+        *iv_return = ITIMER_VIRTUAL;
+        return PERL_constant_ISIV;
+#else
+        return PERL_constant_NOTDEF;
+#endif
+      }
+      break;
+    case 'i':
+      if (memEQ(name, "d_gettimeofday", 14)) {
+      /*                     ^              */
+#ifdef HAS_GETTIMEOFDAY
+        *iv_return = 1;
+        return PERL_constant_ISIV;
+#else
+        *iv_return = 0;
+        return PERL_constant_ISIV;
+#endif
+      }
+      break;
+    }
+    break;
+  case 15:
+    if (memEQ(name, "ITIMER_REALPROF", 15)) {
+#ifdef ITIMER_REALPROF
+      *iv_return = ITIMER_REALPROF;
+      return PERL_constant_ISIV;
+#else
+      return PERL_constant_NOTDEF;
+#endif
+    }
+    break;
+  }
+  return PERL_constant_NOTFOUND;
+}
+
diff --git a/ext/Time/HiRes/fallback/const-xs.inc b/ext/Time/HiRes/fallback/const-xs.inc
new file mode 100644 (file)
index 0000000..c84dd05
--- /dev/null
@@ -0,0 +1,88 @@
+void
+constant(sv)
+    PREINIT:
+#ifdef dXSTARG
+       dXSTARG; /* Faster if we have it.  */
+#else
+       dTARGET;
+#endif
+       STRLEN          len;
+        int            type;
+       IV              iv;
+       /* NV           nv;     Uncomment this if you need to return NVs */
+       /* const char   *pv;    Uncomment this if you need to return PVs */
+    INPUT:
+       SV *            sv;
+        const char *   s = SvPV(sv, len);
+    PPCODE:
+        /* Change this to constant(aTHX_ s, len, &iv, &nv);
+           if you need to return both NVs and IVs */
+       type = constant(aTHX_ s, len, &iv);
+      /* Return 1 or 2 items. First is error message, or undef if no error.
+           Second, if present, is found value */
+        switch (type) {
+        case PERL_constant_NOTFOUND:
+          sv = sv_2mortal(newSVpvf("%s is not a valid Time::HiRes macro", s));
+          PUSHs(sv);
+          break;
+        case PERL_constant_NOTDEF:
+          sv = sv_2mortal(newSVpvf(
+           "Your vendor has not defined Time::HiRes macro %s, used", s));
+          PUSHs(sv);
+          break;
+        case PERL_constant_ISIV:
+          EXTEND(SP, 1);
+          PUSHs(&PL_sv_undef);
+          PUSHi(iv);
+          break;
+       /* Uncomment this if you need to return NOs
+        case PERL_constant_ISNO:
+          EXTEND(SP, 1);
+          PUSHs(&PL_sv_undef);
+          PUSHs(&PL_sv_no);
+          break; */
+       /* Uncomment this if you need to return NVs
+        case PERL_constant_ISNV:
+          EXTEND(SP, 1);
+          PUSHs(&PL_sv_undef);
+          PUSHn(nv);
+          break; */
+       /* Uncomment this if you need to return PVs
+        case PERL_constant_ISPV:
+          EXTEND(SP, 1);
+          PUSHs(&PL_sv_undef);
+          PUSHp(pv, strlen(pv));
+          break; */
+       /* Uncomment this if you need to return PVNs
+        case PERL_constant_ISPVN:
+          EXTEND(SP, 1);
+          PUSHs(&PL_sv_undef);
+          PUSHp(pv, iv);
+          break; */
+       /* Uncomment this if you need to return SVs
+        case PERL_constant_ISSV:
+          EXTEND(SP, 1);
+          PUSHs(&PL_sv_undef);
+          PUSHs(sv);
+          break; */
+       /* Uncomment this if you need to return UNDEFs
+        case PERL_constant_ISUNDEF:
+          break; */
+       /* Uncomment this if you need to return UVs
+        case PERL_constant_ISUV:
+          EXTEND(SP, 1);
+          PUSHs(&PL_sv_undef);
+          PUSHu((UV)iv);
+          break; */
+       /* Uncomment this if you need to return YESs
+        case PERL_constant_ISYES:
+          EXTEND(SP, 1);
+          PUSHs(&PL_sv_undef);
+          PUSHs(&PL_sv_yes);
+          break; */
+        default:
+          sv = sv_2mortal(newSVpvf(
+           "Unexpected return type %d while processing Time::HiRes macro %s, used",
+               type, s));
+          PUSHs(sv);
+        }
diff --git a/gv.c b/gv.c
index 08dd7c3..8dfa932 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -974,9 +974,15 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
             goto ro_magicalize;
         else
             break;
+    case '\025':
+        if (len > 1 && strNE(name, "\025TF8_LOCALE")) 
+           break;
+       goto ro_magicalize;
+
     case '\027':       /* $^W & $^WARNING_BITS */
-       if (len > 1 && strNE(name, "\027ARNING_BITS")
-           && strNE(name, "\027IDE_SYSTEM_CALLS"))
+       if (len > 1
+           && strNE(name, "\027ARNING_BITS")
+           )
            break;
        goto magicalize;
 
@@ -1793,10 +1799,13 @@ Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
            goto yes;
        }
        break;
+    case '\025':
+        if (len > 1 && strEQ(name, "\025TF8_LOCALE"))
+           goto yes;
     case '\027':   /* $^W & $^WARNING_BITS */
        if (len == 1
            || (len == 12 && strEQ(name, "\027ARNING_BITS"))
-           || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
+           )
        {
            goto yes;
        }
index f44ccce..7320725 100644 (file)
@@ -48,7 +48,7 @@ The C variable which corresponds to Perl's $^W warning variable.
 */
 
 PERLVAR(Idowarn,       U8)
-PERLVAR(Iwidesyscalls, bool)           /* wide system calls */
+PERLVAR(Iutf8locale,   bool)           /* utf8 locale detected */
 PERLVAR(Idoextract,    bool)
 PERLVAR(Isawampersand, bool)           /* must save all match strings */
 PERLVAR(Iunsafe,       bool)
index a26ed18..9dfe783 100644 (file)
@@ -137,7 +137,8 @@ sub _gen_handler_AH_() {
                        %lastattr=(pkg=>$pkg,ref=>$ref,type=>$data);
                }
                else {
-                       my $handler = $pkg->can($attr);
+                       my $type = ref $ref;
+                       my $handler = $pkg->can("_ATTR_${type}_${attr}");
                        next unless $handler;
                        my $decl = [$pkg, $ref, $attr, $data,
                                    $raw{$handler}, $phase{$handler}];
index cddab91..db00b1c 100644 (file)
@@ -184,3 +184,20 @@ ok(1,52 ,"# Skip, no difference between lexical handlers and normal handlers pri
 ok( $match, 52 );
 }
 
+
+# The next two check for the phase invariance that Marcel spotted.
+# Subject: Attribute::Handlers phase variance
+# Message-Id: <54EDDB80-FD75-11D6-A18D-00039379E28A@noug.at>
+
+my ($code_applied, $scalar_applied);
+sub Scotty :ATTR(CODE,BEGIN)   { $code_applied = $_[5] }
+{
+no warnings 'redefine';
+sub Scotty :ATTR(SCALAR,CHECK) { $scalar_applied = $_[5] }
+}
+
+sub warp_coil :Scotty {}
+my $photon_torpedo :Scotty;
+
+ok( $code_applied   eq 'BEGIN', 53, "# phase variance" );
+ok( $scalar_applied eq 'CHECK', 54 );
index a53fbb5..62c41ea 100644 (file)
@@ -18,8 +18,8 @@ use Carp 'croak';
 # The most recent version and complete docs are available at:
 #   http://stein.cshl.org/WWW/software/CGI/
 
-$CGI::revision = '$Id: CGI.pm,v 1.62 2002/04/10 19:36:01 lstein Exp $';
-$CGI::VERSION='2.81';
+$CGI::revision = '$Id: CGI.pm,v 1.75 2002/10/16 17:48:37 lstein Exp $';
+$CGI::VERSION='2.89';
 
 # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
 # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
@@ -32,6 +32,10 @@ use CGI::Util qw(rearrange make_attributes unescape escape expires);
 use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN',
                            'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd'];
 
+$TAINTED = substr("$0$^X",0,0);
+
+my @SAVED_SYMBOLS;
+
 # >>>>> Here are some globals that you might want to adjust <<<<<<
 sub initialize_globals {
     # Set this to 1 to enable copious autoloader debugging messages
@@ -127,12 +131,14 @@ if ($OS =~ /^MSWin/i) {
     $OS = 'OS2';
 } elsif ($OS =~ /^epoc/i) {
     $OS = 'EPOC';
+} elsif ($OS =~ /^cygwin/i) {
+    $OS = 'CYGWIN';
 } else {
     $OS = 'UNIX';
 }
 
 # Some OS logic.  Binary mode enabled on DOS, NT and VMS
-$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin)/;
+$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin|CYGWIN)/;
 
 # This is the default class for the CGI object to use when all else fails.
 $DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
@@ -153,13 +159,19 @@ $SL = {
 $IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
 
 # Turn on special checking for Doug MacEachern's modperl
-if (exists $ENV{'GATEWAY_INTERFACE'} 
-    && 
+if (exists $ENV{'GATEWAY_INTERFACE'}
+    &&
     ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//))
-{
+  {
     $| = 1;
-    require Apache;
-}
+    require mod_perl;
+    if ($mod_perl::VERSION >= 1.99) {
+      require Apache::compat;
+    } else {
+      require Apache;
+    }
+  }
+
 # Turn on special checking for ActiveState's PerlEx
 $PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
 
@@ -219,7 +231,7 @@ if ($needs_binmode) {
 sub import {
     my $self = shift;
 
-# This causes modules to clash.  
+    # This causes modules to clash.
     undef %EXPORT_OK;
     undef %EXPORT;
 
@@ -381,6 +393,9 @@ sub init {
     # set charset to the safe ISO-8859-1
     $self->charset('ISO-8859-1');
 
+    # set autoescaping to on
+    $self->{'escape'} = 1;
+
   METHOD: {
 
       # avoid unreasonably large postings
@@ -714,6 +729,7 @@ sub _setup_symbols {
        }
     }
     _compile_all(keys %EXPORT) if $compile;
+    @SAVED_SYMBOLS = @_;
 }
 
 sub charset {
@@ -766,11 +782,12 @@ END_OF_FUNC
 ####
 sub delete {
     my($self,@p) = self_or_default(@_);
-    my($name) = rearrange([NAME],@p);
-    CORE::delete $self->{$name};
-    CORE::delete $self->{'.fieldnames'}->{$name};
-    @{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
-    return wantarray ? () : undef;
+    my(@names) = rearrange([NAME],@p);
+    for my $name (@names) {
+      CORE::delete $self->{$name};
+      CORE::delete $self->{'.fieldnames'}->{$name};
+      @{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
+    }
 }
 END_OF_FUNC
 
@@ -992,7 +1009,9 @@ EOF
 'autoEscape' => <<'END_OF_FUNC',
 sub autoEscape {
     my($self,$escape) = self_or_default(@_);
-    $self->{'dontescape'}=!$escape;
+    my $d = $self->{'escape'};
+    $self->{'escape'} = $escape;
+    $d;
 }
 END_OF_FUNC
 
@@ -1363,7 +1382,7 @@ sub start_html {
     } else {
         push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">));
     }
-    push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml" lang="$lang"><head><title>$title</title>)
+    push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml" lang="$lang" xml:lang="$lang"><head><title>$title</title>)
                         : qq(<html lang="$lang"><head><title>$title</title>));
        if (defined $author) {
     push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />"
@@ -1504,14 +1523,14 @@ END_OF_FUNC
 # Parameters:
 #  $action -> optional URL of script to run
 # Returns:
-#   A string containing a <ISINDEX> tag
+#   A string containing a <isindex> tag
 'isindex' => <<'END_OF_FUNC',
 sub isindex {
     my($self,@p) = self_or_default(@_);
     my($action,@other) = rearrange([ACTION],@p);
-    $action = qq/action="$action"/ if $action;
+    $action = qq/ action="$action"/ if $action;
     my($other) = @other ? " @other" : '';
-    return $XHTML ? "<isindex $action$other />" : "<isindex $action$other>";
+    return $XHTML ? "<isindex$action$other />" : "<isindex$action$other>";
 }
 END_OF_FUNC
 
@@ -1533,7 +1552,9 @@ sub startform {
     $enctype = $enctype || &URL_ENCODED;
     unless (defined $action) {
        $action = $self->url(-absolute=>1,-path=>1);
-       $action .= "?$ENV{QUERY_STRING}" if $ENV{QUERY_STRING};
+       if (length($ENV{QUERY_STRING})>0) {
+           $action .= "?$ENV{QUERY_STRING}";
+       }
     }
     $action = qq(action="$action");
     my($other) = @other ? " @other" : '';
@@ -1629,7 +1650,7 @@ END_OF_FUNC
 #   $size ->  Optional width of field in characaters.
 #   $maxlength -> Optional maximum number of characters.
 # Returns:
-#   A string containing a <INPUT TYPE="text"> field
+#   A string containing a <input type="text"> field
 #
 'textfield' => <<'END_OF_FUNC',
 sub textfield {
@@ -1645,7 +1666,7 @@ END_OF_FUNC
 #   $size ->  Optional width of field in characaters.
 #   $maxlength -> Optional maximum number of characters.
 # Returns:
-#   A string containing a <INPUT TYPE="text"> field
+#   A string containing a <input type="file"> field
 #
 'filefield' => <<'END_OF_FUNC',
 sub filefield {
@@ -1664,7 +1685,7 @@ END_OF_FUNC
 #   $size ->  Optional width of field in characters.
 #   $maxlength -> Optional maximum characters that can be entered.
 # Returns:
-#   A string containing a <INPUT TYPE="password"> field
+#   A string containing a <input type="password"> field
 #
 'password_field' => <<'END_OF_FUNC',
 sub password_field {
@@ -1711,7 +1732,7 @@ END_OF_FUNC
 #   $onclick -> (optional) Text of the JavaScript to run when the button is
 #                clicked.
 # Returns:
-#   A string containing a <INPUT TYPE="button"> tag
+#   A string containing a <input type="button"> tag
 ####
 'button' => <<'END_OF_FUNC',
 sub button {
@@ -1744,7 +1765,7 @@ END_OF_FUNC
 #   $value -> (optional) Value of the button when selected (also doubles as label).
 #   $label -> (optional) Label printed on the button(also doubles as the value).
 # Returns:
-#   A string containing a <INPUT TYPE="submit"> tag
+#   A string containing a <input type="submit"> tag
 ####
 'submit' => <<'END_OF_FUNC',
 sub submit {
@@ -1772,7 +1793,7 @@ END_OF_FUNC
 # Parameters:
 #   $name -> (optional) Name for the button.
 # Returns:
-#   A string containing a <INPUT TYPE="reset"> tag
+#   A string containing a <input type="reset"> tag
 ####
 'reset' => <<'END_OF_FUNC',
 sub reset {
@@ -1792,7 +1813,7 @@ END_OF_FUNC
 # Parameters:
 #   $name -> (optional) Name for the button.
 # Returns:
-#   A string containing a <INPUT TYPE="submit" NAME=".defaults"> tag
+#   A string containing a <input type="submit" name=".defaults"> tag
 #
 # Note: this button has a special meaning to the initialization script,
 # and tells it to ERASE the current query string so that your defaults
@@ -1834,7 +1855,7 @@ END_OF_FUNC
 #   $label -> (optional) a user-readable label printed next to the box.
 #             Otherwise the checkbox name is used.
 # Returns:
-#   A string containing a <INPUT TYPE="checkbox"> field
+#   A string containing a <input type="checkbox"> field
 ####
 'checkbox' => <<'END_OF_FUNC',
 sub checkbox {
@@ -1882,16 +1903,16 @@ END_OF_FUNC
 #             in the form $label{'value'}="Long explanatory label".
 #             Otherwise the provided values are used as the labels.
 # Returns:
-#   An ARRAY containing a series of <INPUT TYPE="checkbox"> fields
+#   An ARRAY containing a series of <input type="checkbox"> fields
 ####
 'checkbox_group' => <<'END_OF_FUNC',
 sub checkbox_group {
     my($self,@p) = self_or_default(@_);
 
-    my($name,$values,$defaults,$linebreak,$labels,$rows,$columns,
+    my($name,$values,$defaults,$linebreak,$labels,$attributes,$rows,$columns,
        $rowheaders,$colheaders,$override,$nolabels,@other) =
        rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
-                         LINEBREAK,LABELS,ROWS,[COLUMNS,COLS],
+            LINEBREAK,LABELS,ATTRIBUTES,ROWS,[COLUMNS,COLS],
                          ROWHEADERS,COLHEADERS,
                          [OVERRIDE,FORCE],NOLABELS],@p);
 
@@ -1921,9 +1942,10 @@ sub checkbox_group {
            $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
            $label = $self->escapeHTML($label);
        }
+        my $attribs = $self->_set_attributes($_, $attributes);
        $_ = $self->escapeHTML($_,1);
-       push(@elements,$XHTML ? qq(<input type="checkbox" name="$name" value="$_"$checked$other />${label}${break})
-                              : qq/<input type="checkbox" name="$name" value="$_"$checked$other>${label}${break}/);
+        push(@elements,$XHTML ? qq(<input type="checkbox" name="$name" value="$_"$checked$other$attribs />${label}${break})
+                              : qq/<input type="checkbox" name="$name" value="$_"$checked$other$attribs>${label}${break}/);
     }
     $self->register_parameter($name);
     return wantarray ? @elements : join(' ',@elements)            
@@ -1939,7 +1961,7 @@ sub escapeHTML {
          push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
          my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
          return undef unless defined($toencode);
-         return $toencode if ref($self) && $self->{'dontescape'};
+         return $toencode if ref($self) && !$self->{'escape'};
          $toencode =~ s{&}{&amp;}gso;
          $toencode =~ s{<}{&lt;}gso;
          $toencode =~ s{>}{&gt;}gso;
@@ -1948,8 +1970,8 @@ sub escapeHTML {
                      uc $self->{'.charset'} eq 'WINDOWS-1252';
          if ($latin) {  # bug in some browsers
                 $toencode =~ s{'}{&#39;}gso;
-                $toencode =~ s{\x8b}{&#139;}gso;
-                $toencode =~ s{\x9b}{&#155;}gso;
+                $toencode =~ s{\x8b}{&#8249;}gso;
+                $toencode =~ s{\x9b}{&#8250;}gso;
                 if (defined $newlinestoo && $newlinestoo) {
                      $toencode =~ s{\012}{&#10;}gso;
                      $toencode =~ s{\015}{&#13;}gso;
@@ -2034,15 +2056,15 @@ END_OF_FUNC
 #             in the form $label{'value'}="Long explanatory label".
 #             Otherwise the provided values are used as the labels.
 # Returns:
-#   An ARRAY containing a series of <INPUT TYPE="radio"> fields
+#   An ARRAY containing a series of <input type="radio"> fields
 ####
 'radio_group' => <<'END_OF_FUNC',
 sub radio_group {
     my($self,@p) = self_or_default(@_);
 
-    my($name,$values,$default,$linebreak,$labels,
+    my($name,$values,$default,$linebreak,$labels,$attributes,
        $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) =
-       rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
+  rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,ATTRIBUTES,
                          ROWS,[COLUMNS,COLS],
                          ROWHEADERS,COLHEADERS,
                          [OVERRIDE,FORCE],NOLABELS],@p);
@@ -2076,9 +2098,10 @@ sub radio_group {
            $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
            $label = $self->escapeHTML($label,1);
        }
+  my $attribs = $self->_set_attributes($_, $attributes);
        $_=$self->escapeHTML($_);
-       push(@elements,$XHTML ? qq(<input type="radio" name="$name" value="$_"$checkit$other />${label}${break})
-                              : qq/<input type="radio" name="$name" value="$_"$checkit$other>${label}${break}/);
+  push(@elements,$XHTML ? qq(<input type="radio" name="$name" value="$_"$checkit$other$attribs />${label}${break})
+                              : qq/<input type="radio" name="$name" value="$_"$checkit$other$attribs>${label}${break}/);
     }
     $self->register_parameter($name);
     return wantarray ? @elements : join(' ',@elements) 
@@ -2106,8 +2129,9 @@ END_OF_FUNC
 sub popup_menu {
     my($self,@p) = self_or_default(@_);
 
-    my($name,$values,$default,$labels,$override,@other) =
-       rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p);
+    my($name,$values,$default,$labels,$attributes,$override,@other) =
+       rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,
+       ATTRIBUTES,[OVERRIDE,FORCE]],@p);
     my($result,$selected);
 
     if (!$override && defined($self->param($name))) {
@@ -2123,12 +2147,22 @@ sub popup_menu {
 
     $result = qq/<select name="$name"$other>\n/;
     foreach (@values) {
+        if (/<optgroup/) {
+            foreach (split(/\n/)) {
+                my $selectit = $XHTML ? 'selected="selected"' : 'selected';
+                s/(value="$selected")/$selectit $1/ if defined $selected;
+                $result .= "$_\n";
+            }
+        }
+        else {
+            my $attribs = $self->_set_attributes($_, $attributes);
        my($selectit) = defined($selected) ? $self->_selected($selected eq $_) : '';
        my($label) = $_;
        $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
        my($value) = $self->escapeHTML($_);
        $label=$self->escapeHTML($label,1);
-       $result .= "<option$selectit value=\"$value\">$label</option>\n";
+            $result .= "<option$selectit$attribs value=\"$value\">$label</option>\n";
+        }
     }
 
     $result .= "</select>";
@@ -2137,6 +2171,66 @@ sub popup_menu {
 END_OF_FUNC
 
 
+#### Method: optgroup
+# Create a optgroup.
+# Parameters:
+#   $name -> Label for the group
+#   $values -> A pointer to a regular array containing the
+#              values for each option line in the group.
+#   $labels -> (optional)
+#              A pointer to an associative array of labels to print next to each item
+#              in the form $label{'value'}="Long explanatory label".
+#              Otherwise the provided values are used as the labels.
+#   $labeled -> (optional)
+#               A true value indicates the value should be used as the label attribute
+#               in the option elements.
+#               The label attribute specifies the option label presented to the user.
+#               This defaults to the content of the <option> element, but the label
+#               attribute allows authors to more easily use optgroup without sacrificing
+#               compatibility with browsers that do not support option groups.
+#   $novals -> (optional)
+#              A true value indicates to suppress the val attribute in the option elements
+# Returns:
+#   A string containing the definition of an option group.
+####
+'optgroup' => <<'END_OF_FUNC',
+sub optgroup {
+    my($self,@p) = self_or_default(@_);
+    my($name,$values,$attributes,$labeled,$noval,$labels,@other)
+        = rearrange([NAME,[VALUES,VALUE],ATTRIBUTES,LABELED,NOVALS,LABELS],@p);
+
+    my($result,@values);
+    @values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals);
+    my($other) = @other ? " @other" : '';
+
+    $name=$self->escapeHTML($name);
+    $result = qq/<optgroup label="$name"$other>\n/;
+    foreach (@values) {
+        if (/<optgroup/) {
+            foreach (split(/\n/)) {
+                my $selectit = $XHTML ? 'selected="selected"' : 'selected';
+                s/(value="$selected")/$selectit $1/ if defined $selected;
+                $result .= "$_\n";
+            }
+        }
+        else {
+            my $attribs = $self->_set_attributes($_, $attributes);
+            my($label) = $_;
+            $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
+            $label=$self->escapeHTML($label);
+            my($value)=$self->escapeHTML($_,1);
+            $result .= $labeled ? $novals ? "<option$attribs label=\"$value\">$label</option>\n"
+                                          : "<option$attribs label=\"$value\" value=\"$value\">$label</option>\n"
+                                : $novals ? "<option$attribs>$label</option>\n"
+                                          : "<option$attribs value=\"$value\">$label</option>\n";
+        }
+    }
+    $result .= "</optgroup>";
+    return $result;
+}
+END_OF_FUNC
+
+
 #### Method: scrolling_list
 # Create a scrolling list.
 # Parameters:
@@ -2160,9 +2254,9 @@ END_OF_FUNC
 'scrolling_list' => <<'END_OF_FUNC',
 sub scrolling_list {
     my($self,@p) = self_or_default(@_);
-    my($name,$values,$defaults,$size,$multiple,$labels,$override,@other)
+    my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,@other)
        = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
-                           SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p);
+          SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE]],@p);
 
     my($result,@values);
     @values = $self->_set_values_and_labels($values,\$labels,$name);
@@ -2182,7 +2276,8 @@ sub scrolling_list {
        $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
        $label=$self->escapeHTML($label);
        my($value)=$self->escapeHTML($_,1);
-       $result .= "<option$selectit value=\"$value\">$label</option>\n";
+        my $attribs = $self->_set_attributes($_, $attributes);
+        $result .= "<option$selectit$attribs value=\"$value\">$label</option>\n";
     }
     $result .= "</select>";
     $self->register_parameter($name);
@@ -2198,7 +2293,7 @@ END_OF_FUNC
 #      or
 #   $default->[initial values of field]
 # Returns:
-#   A string containing a <INPUT TYPE="hidden" NAME="name" VALUE="value">
+#   A string containing a <input type="hidden" name="name" value="value">
 ####
 'hidden' => <<'END_OF_FUNC',
 sub hidden {
@@ -2241,7 +2336,7 @@ END_OF_FUNC
 #   $src ->  URL of the image source
 #   $align -> Alignment style (TOP, BOTTOM or MIDDLE)
 # Returns:
-#   A string containing a <INPUT TYPE="image" NAME="name" SRC="url" ALIGN="alignment">
+#   A string containing a <input type="image" name="name" src="url" align="alignment">
 ####
 'image_button' => <<'END_OF_FUNC',
 sub image_button {
@@ -2908,6 +3003,7 @@ sub read_multipart {
        }
 
        my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/;
+        $param .= $TAINTED;
 
        # Bug:  Netscape doesn't escape quotation marks in file names!!!
        my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\"]*)"?/;
@@ -2919,6 +3015,7 @@ sub read_multipart {
        # to our parameter list.
        if ( !defined($filename) || $filename eq '' ) {
            my($value) = $buffer->readBody;
+            $value .= $TAINTED;
            push(@{$self->{$param}},$value);
            next;
        }
@@ -3005,6 +3102,22 @@ sub _set_values_and_labels {
 }
 END_OF_FUNC
 
+# internal routine, don't use
+'_set_attributes' => <<'END_OF_FUNC',
+sub _set_attributes {
+    my $self = shift;
+    my($element, $attributes) = @_;
+    return '' unless defined($attributes->{$element});
+    $attribs = ' ';
+    foreach my $attrib (keys %{$attributes->{$element}}) {
+        $attrib =~ s/^-//;
+        $attribs .= "@{[lc($attrib)]}=\"$attributes->{$element}{$attrib}\" ";
+    }
+    $attribs =~ s/ $//;
+    return $attribs;
+}
+END_OF_FUNC
+
 '_compile_all' => <<'END_OF_FUNC',
 sub _compile_all {
     foreach (@_) {
@@ -3043,7 +3156,7 @@ sub asString {
     # get rid of package name
     (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//; 
     $i =~ s/%(..)/ chr(hex($1)) /eg;
-    return $i;
+    return $i.$CGI::TAINTED;
 # BEGIN DEAD CODE
 # This was an extremely clever patch that allowed "use strict refs".
 # Unfortunately it relied on another bug that caused leaky file descriptors.
@@ -3066,12 +3179,15 @@ END_OF_FUNC
 'new'  => <<'END_OF_FUNC',
 sub new {
     my($pack,$name,$file,$delete) = @_;
+    _setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
     require Fcntl unless defined &Fcntl::O_RDWR;
     (my $safename = $name) =~ s/([':%])/ sprintf '%%%02X', ord $1 /eg;
     my $fv = ++$FH . $safename;
     my $ref = \*{"Fh::$fv"};
-    sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
-    unlink($file) if $delete;
+    $file =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$! || return;
+    my $safe = $1;
+    sysopen($ref,$safe,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
+    unlink($safe) if $delete;
     CORE::delete $Fh::{$fv};
     return bless $ref,$pack;
 }
@@ -3197,15 +3313,15 @@ sub readHeader {
     substr($self->{BUFFER},0,$end+4) = '';
     my %return;
 
-    
     # See RFC 2045 Appendix A and RFC 822 sections 3.4.8
     #   (Folding Long Header Fields), 3.4.3 (Comments)
     #   and 3.4.5 (Quoted-Strings).
 
     my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
     $header=~s/$CRLF\s+/ /og;          # merge continuation lines
+
     while ($header=~/($token+):\s+([^$CRLF]*)/mgox) {
-       my ($field_name,$field_value) = ($1,$2); # avoid taintedness
+        my ($field_name,$field_value) = ($1,$2);
        $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize
        $return{$field_name}=$field_value;
     }
@@ -3345,7 +3461,7 @@ unless ($TMPDIRECTORY) {
           "${vol}${SL}Temporary Items",
            "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH",
           "C:${SL}system${SL}temp");
-    unshift(@TEMP,$ENV{'TMPDIR'}) if exists $ENV{'TMPDIR'};
+    unshift(@TEMP,$ENV{'TMPDIR'}) if defined $ENV{'TMPDIR'};
 
     # this feature was supposed to provide per-user tmpfiles, but
     # it is problematic.
@@ -3370,7 +3486,9 @@ $MAXTRIES = 5000;
 
 sub DESTROY {
     my($self) = @_;
-    unlink $$self;              # get rid of the file
+    $$self =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$! || return;
+    my $safe = $1;             # untaint operation
+    unlink $safe;              # get rid of the file
 }
 
 ###############################################################################
@@ -3387,9 +3505,10 @@ sub new {
     for (my $i = 0; $i < $MAXTRIES; $i++) {
        last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++));
     }
-    # untaint the darn thing
-    return unless $filename =~ m!^([a-zA-Z0-9_ '":/.\$\\-]+)$!;
-    $filename = $1;
+    # check that it is a more-or-less valid filename
+    return unless $filename =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$!;
+    # this used to untaint, now it doesn't
+    # $filename = $1;
     return bless \$filename;
 }
 END_OF_FUNC
@@ -3574,10 +3693,10 @@ this:
    ----                           --------------
    h1()                           <h1>
    h1('some','contents');         <h1>some contents</h1>
-   h1({-align=>left});            <h1 ALIGN="LEFT">
-   h1({-align=>left},'contents'); <h1 ALIGN="LEFT">contents</h1>
+   h1({-align=>left});            <h1 align="LEFT">
+   h1({-align=>left},'contents'); <h1 align="LEFT">contents</h1>
 
-HTML tags are described in more detail later.  
+HTML tags are described in more detail later.
 
 Many newcomers to CGI.pm are puzzled by the difference between the
 calling conventions for the HTML shortcuts, which require curly braces
@@ -3785,11 +3904,11 @@ Perl module B<import> operator.
 
 =head2 DELETING A PARAMETER COMPLETELY:
 
-    $query->delete('foo');
+    $query->delete('foo','bar','baz');
 
-This completely clears a parameter.  It sometimes useful for
-resetting parameters that you don't want passed down between
-script invocations.
+This completely clears a list of parameters.  It sometimes useful for
+resetting parameters that you don't want passed down between script
+invocations.
 
 If you are using the function call interface, use "Delete()" instead
 to avoid conflicts with Perl's built-in delete operator.
@@ -4090,7 +4209,14 @@ or even
 Note that using the -compile pragma in this way will always have
 the effect of importing the compiled functions into the current
 namespace.  If you want to compile without importing use the
-compile() method instead (see below).
+compile() method instead:
+
+   use CGI();
+   CGI->compile();
+
+This is particularly useful in a mod_perl environment, in which you
+might want to precompile all CGI routines in a startup script, and
+then import the functions individually in each mod_perl script.
 
 =item -nosticky
 
@@ -4590,9 +4716,9 @@ internal anchors but you don't want to disrupt the current contents
 of the form(s).  Something like this will do the trick.
 
      $myself = $query->self_url;
-     print "<a href=$myself#table1>See table 1</a>";
-     print "<a href=$myself#table2>See table 2</a>";
-     print "<a href=$myself#yourself>See for yourself</a>";
+     print "<a href=\"$myself#table1\">See table 1</a>";
+     print "<a href=\"$myself#table2\">See table 2</a>";
+     print "<a href=\"$myself#yourself\">See for yourself</a>";
 
 If you want more control over what's returned, using the B<url()>
 method instead.
@@ -4863,9 +4989,9 @@ Provided that you have specified a character set of ISO-8859-1 (the
 default), the standard HTML escaping rules will be used.  The "<"
 character becomes "&lt;", ">" becomes "&gt;", "&" becomes "&amp;", and
 the quote character becomes "&quot;".  In addition, the hexadecimal
-0x8b and 0x9b characters, which many windows-based browsers interpret
+0x8b and 0x9b characters, which some browsers incorrectly interpret
 as the left and right angle-bracket characters, are replaced by their
-numeric HTML entities ("&#139" and "&#155;").  If you manually change
+numeric character entities ("&#8249" and "&#8250;").  If you manually change
 the charset, either by calling the charset() method explicitly or by
 passing a -charset argument to header(), then B<all> characters will
 be replaced by their numeric entities, since CGI.pm has no lookup
@@ -4875,7 +5001,7 @@ The automatic escaping does not apply to other shortcuts, such as
 h1().  You should call escapeHTML() yourself on untrusted data in
 order to protect your pages against nasty tricks that people may enter
 into guestbooks, etc..  To change the character set, use charset().
-To turn autoescaping off completely, use autoescape():
+To turn autoescaping off completely, use autoEscape(0):
 
 =over 4
 
@@ -5278,16 +5404,18 @@ recognized.  See textfield() for details.
    %labels = ('eenie'=>'your first choice',
              'meenie'=>'your second choice',
              'minie'=>'your third choice');
+   %attributes = ('eenie'=>{'class'=>'class of first choice'});
    print $query->popup_menu('menu_name',
                            ['eenie','meenie','minie'],
-                           'meenie',\%labels);
+          'meenie',\%labels,\%attributes);
 
        -or (named parameter style)-
 
    print $query->popup_menu(-name=>'menu_name',
                            -values=>['eenie','meenie','minie'],
                            -default=>'meenie',
-                           -labels=>\%labels);
+          -labels=>\%labels,
+          -attributes=>\%attributes);
 
 popup_menu() creates a menu.
 
@@ -5314,11 +5442,19 @@ The values of the previous choice will be maintained across queries.
 
 The optional fourth parameter (-labels) is provided for people who
 want to use different values for the user-visible label inside the
-popup menu nd the value returned to your script.  It's a pointer to an
+popup menu and the value returned to your script.  It's a pointer to an
 associative array relating menu values to user-visible labels.  If you
 leave this parameter blank, the menu values will be displayed by
 default.  (You can also leave a label undefined if you want to).
 
+=item 5.
+
+The optional fifth parameter (-attributes) is provided to assign
+any of the common HTML attributes to an individual menu item. It's
+a pointer to an associative array relating menu values to another
+associative array with the attribute's name as the key and the
+attribute's value as the value.
+
 =back
 
 When the form is processed, the selected value of the popup menu can
@@ -5331,17 +5467,90 @@ B<-onChange>, B<-onFocus>, B<-onMouseOver>, B<-onMouseOut>, and
 B<-onBlur>.  See the textfield() section for details on when these
 handlers are called.
 
+=head2 CREATING AN OPTION GROUP
+
+Named parameter style
+
+  print $query->popup_menu(-name=>'menu_name',
+                  -values=>[qw/eenie meenie minie/,
+                            $q->optgroup(-name=>'optgroup_name',
+                                         -values ['moe','catch'],
+                                         -attributes=>{'catch'=>{'class'=>'red'}}),
+                  -labels=>{'eenie'=>'one',
+                            'meenie'=>'two',
+                            'minie'=>'three'},
+                  -default=>'meenie');
+
+  Old style
+  print $query->popup_menu('menu_name',
+                  ['eenie','meenie','minie',
+                   $q->optgroup('optgroup_name', ['moe', 'catch'],
+                         {'catch'=>{'class'=>'red'}})],'meenie',
+                  {'eenie'=>'one','meenie'=>'two','minie'=>'three'});
+
+optgroup creates an option group within a popup menu.
+
+=over 4
+
+=item 1.
+
+The required first argument (B<-name>) is the label attribute of the
+optgroup and is B<not> inserted in the parameter list of the query.
+
+=item 2.
+
+The required second argument (B<-values>)  is an array reference
+containing the list of menu items in the menu.  You can pass the
+method an anonymous array, as shown in the example, or a reference
+to a named array, such as \@foo.  If you pass a HASH reference,
+the keys will be used for the menu values, and the values will be
+used for the menu labels (see -labels below).
+
+=item 3.
+
+The optional third parameter (B<-labels>) allows you to pass a reference
+to an associative array containing user-visible labels for one or more
+of the menu items.  You can use this when you want the user to see one
+menu string, but have the browser return your program a different one.
+If you don't specify this, the value string will be used instead
+("eenie", "meenie" and "minie" in this example).  This is equivalent
+to using a hash reference for the -values parameter.
+
+=item 4.
+
+An optional fourth parameter (B<-labeled>) can be set to a true value
+and indicates that the values should be used as the label attribute
+for each option element within the optgroup.
+
+=item 5.
+
+An optional fifth parameter (-novals) can be set to a true value and
+indicates to suppress the val attribut in each option element within
+the optgroup.
+
+See the discussion on optgroup at W3C
+(http://www.w3.org/TR/REC-html40/interact/forms.html#edef-OPTGROUP)
+for details.
+
+=item 6.
+
+An optional sixth parameter (-attributes) is provided to assign
+any of the common HTML attributes to an individual menu item. It's
+a pointer to an associative array relating menu values to another
+associative array with the attribute's name as the key and the
+attribute's value as the value.
+
 =head2 CREATING A SCROLLING LIST
 
    print $query->scrolling_list('list_name',
                                ['eenie','meenie','minie','moe'],
-                               ['eenie','moe'],5,'true');
+        ['eenie','moe'],5,'true',{'moe'=>{'class'=>'red'}});
       -or-
 
    print $query->scrolling_list('list_name',
                                ['eenie','meenie','minie','moe'],
                                ['eenie','moe'],5,'true',
-                               \%labels);
+        \%labels,%attributes);
 
        -or-
 
@@ -5350,7 +5559,8 @@ handlers are called.
                                -default=>['eenie','moe'],
                                -size=>5,
                                -multiple=>'true',
-                               -labels=>\%labels);
+        -labels=>\%labels,
+        -attributes=>\%attributes);
 
 scrolling_list() creates a scrolling list.  
 
@@ -5389,6 +5599,14 @@ The optional sixth argument is a pointer to an associative array
 containing long user-visible labels for the list items (-labels).
 If not provided, the values will be displayed.
 
+=item 6.
+
+The optional sixth parameter (-attributes) is provided to assign
+any of the common HTML attributes to an individual menu item. It's
+a pointer to an associative array relating menu values to another
+associative array with the attribute's name as the key and the
+attribute's value as the value.
+
 When this form is processed, all selected list items will be returned as
 a list under the parameter name 'list_name'.  The values of the
 selected items can be retrieved with:
@@ -5408,11 +5626,13 @@ handlers are called.
                                -values=>['eenie','meenie','minie','moe'],
                                -default=>['eenie','moe'],
                                -linebreak=>'true',
-                               -labels=>\%labels);
+        -labels=>\%labels,
+        -attributes=>\%attributes);
 
    print $query->checkbox_group('group_name',
                                ['eenie','meenie','minie','moe'],
-                               ['eenie','moe'],'true',\%labels);
+        ['eenie','moe'],'true',\%labels,
+        {'moe'=>{'class'=>'red'}});
 
    HTML3-COMPATIBLE BROWSERS ONLY:
 
@@ -5465,6 +5685,14 @@ the checkbox group formatted with the specified number of rows and
 columns.  You can provide just the -columns parameter if you wish;
 checkbox_group will calculate the correct number of rows for you.
 
+=item 6.
+
+The optional sixth parameter (-attributes) is provided to assign
+any of the common HTML attributes to an individual menu item. It's
+a pointer to an associative array relating menu values to another
+associative array with the attribute's name as the key and the
+attribute's value as the value.
+
 To include row and column headings in the returned table, you
 can use the B<-rowheaders> and B<-colheaders> parameters.  Both
 of these accept a pointer to an array of headings to use.
@@ -5549,12 +5777,13 @@ parameter.  See checkbox_group() for further details.
                             -values=>['eenie','meenie','minie'],
                             -default=>'meenie',
                             -linebreak=>'true',
-                            -labels=>\%labels);
+           -labels=>\%labels,
+           -attributes=>\%attributes);
 
        -or-
 
    print $query->radio_group('group_name',['eenie','meenie','minie'],
-                                         'meenie','true',\%labels);
+            'meenie','true',\%labels,\%attributes);
 
 
    HTML3-COMPATIBLE BROWSERS ONLY:
@@ -5612,6 +5841,14 @@ and columns.  You can provide just the -columns parameter if you
 wish; radio_group will calculate the correct number of rows
 for you.
 
+=item 6.
+
+The optional sixth parameter (-attributes) is provided to assign
+any of the common HTML attributes to an individual menu item. It's
+a pointer to an associative array relating menu values to another
+associative array with the attribute's name as the key and the
+attribute's value as the value.
+
 To include row and column headings in the returned table, you
 can use the B<-rowheader> and B<-colheader> parameters.  Both
 of these accept a pointer to an array of headings to use.
@@ -6679,13 +6916,7 @@ for suggestions and bug fixes.
 
 =head1 BUGS
 
-This module has grown large and monolithic.  Furthermore it's doing many
-things, such as handling URLs, parsing CGI input, writing HTML, etc., that
-are also done in the LWP modules. It should be discarded in favor of
-the CGI::* modules, but somehow I continue to work on it.
-
-Note that the code is truly contorted in order to avoid spurious
-warnings when programs are run with the B<-w> switch.
+Please report them.
 
 =head1 SEE ALSO
 
index bc3d1c3..ce9b407 100644 (file)
@@ -169,6 +169,39 @@ content where HTML comments are not allowed:
 Note: In this respect warningsToBrowser() differs fundamentally from
 fatalsToBrowser(), which you should never call yourself!
 
+=head1 OVERRIDING THE NAME OF THE PROGRAM
+
+CGI::Carp includes the name of the program that generated the error or
+warning in the messages written to the log and the browser window.
+Sometimes, Perl can get confused about what the actual name of the
+executed program was.  In these cases, you can override the program
+name that CGI::Carp will use for all messages.
+
+The quick way to do that is to tell CGI::Carp the name of the program
+in its use statement.  You can do that by adding
+"name=cgi_carp_log_name" to your "use" statement.  For example:
+
+    use CGI::Carp qw(name=cgi_carp_log_name);
+
+.  If you want to change the program name partway through the program,
+you can use the C<set_progname()> function instead.  It is not
+exported by default, you must import it explicitly by saying
+
+    use CGI::Carp qw(set_progname);
+
+Once you've done that, you can change the logged name of the program
+at any time by calling
+
+    set_progname(new_program_name);
+
+You can set the program back to the default by calling
+
+    set_progname(undef);
+
+Note that this override doesn't happen until after the program has
+compiled, so any compile-time errors will still show up with the
+non-overridden program name
+  
 =head1 CHANGE LOG
 
 1.05 carpout() added and minor corrections by Marc Hedlund
@@ -203,6 +236,9 @@ fatalsToBrowser(), which you should never call yourself!
      (hack alert!) in order to accomodate various combinations of Perl and
      mod_perl.
 
+1.24 Patch from Scott Gifford (sgifford@suspectclass.com): Add support
+     for overriding program name.
+
 =head1 AUTHORS
 
 Copyright 1995-2002, Lincoln D. Stein.  All rights reserved.  
@@ -216,6 +252,10 @@ Address bug reports and comments to: lstein@cshl.org
 
 Carp, CGI::Base, CGI::BasePlus, CGI::Request, CGI::MiniSvr, CGI::Form,
 CGI::Response
+    if (defined($CGI::Carp::PROGNAME)) 
+    {
+      $file = $CGI::Carp::PROGNAME;
+    }
 
 =cut
 
@@ -227,17 +267,26 @@ use File::Spec;
 
 @ISA = qw(Exporter);
 @EXPORT = qw(confess croak carp);
-@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message cluck);
+@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message set_progname cluck ^name=);
 
 $main::SIG{__WARN__}=\&CGI::Carp::warn;
-$main::SIG{__DIE__}=\&CGI::Carp::die;
-$CGI::Carp::VERSION = '1.23';
+*CORE::GLOBAL::die = \&CGI::Carp::die;
+$CGI::Carp::VERSION = '1.24';
 $CGI::Carp::CUSTOM_MSG = undef;
 
 # fancy import routine detects and handles 'errorWrap' specially.
 sub import {
     my $pkg = shift;
     my(%routines);
+    my(@name);
+  
+    if (@name=grep(/^name=/,@_))
+      {
+        my($n) = (split(/=/,$name[0]))[1];
+        set_progname($n);
+        @_=grep(!/^name=/,@_);
+      }
+
     grep($routines{$_}++,@_,@EXPORT);
     $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'};
     $WARN++ if $routines{'warningsToBrowser'};
@@ -262,14 +311,24 @@ sub stamp {
     my $time = scalar(localtime);
     my $frame = 0;
     my ($id,$pack,$file,$dev,$dirs);
-    do {
-       $id = $file;
-       ($pack,$file) = caller($frame++);
-    } until !$file;
+    if (defined($CGI::Carp::PROGNAME)) {
+        $id = $CGI::Carp::PROGNAME;
+    } else {
+        do {
+         $id = $file;
+         ($pack,$file) = caller($frame++);
+        } until !$file;
+    }
     ($dev,$dirs,$id) = File::Spec->splitpath($id);
     return "[$time] $id: ";
 }
 
+sub set_progname {
+    $CGI::Carp::PROGNAME = shift;
+    return $CGI::Carp::PROGNAME;
+}
+
+
 sub warn {
     my $message = shift;
     my($file,$line,$id) = id(1);
@@ -294,7 +353,10 @@ sub _warn {
     }
 }
 
-sub ineval { $^S || _longmess() =~ /eval [\{\']/m }
+sub ineval { 
+  (exists $ENV{MOD_PERL} ? 0 : $^S) || _longmess() =~ /eval [\{\']/m 
+}
+
 
 # The mod_perl package Apache::Registry loads CGI programs by calling
 # eval.  These evals don't count when looking at the stack backtrace.
index 1e1cfde..7c7434c 100644 (file)
@@ -13,7 +13,7 @@ package CGI::Cookie;
 # wish, but if you redistribute a modified version, please attach a note
 # listing the modifications you have made.
 
-$CGI::Cookie::VERSION='1.20';
+$CGI::Cookie::VERSION='1.21';
 
 use CGI::Util qw(rearrange unescape escape);
 use overload '""' => \&as_string,
@@ -117,6 +117,7 @@ sub new {
   $self->domain($domain) if defined $domain;
   $self->secure($secure) if defined $secure;
   $self->expires($expires) if defined $expires;
+#  $self->max_age($expires) if defined $expires;
   return $self;
 }
 
@@ -124,11 +125,12 @@ sub as_string {
     my $self = shift;
     return "" unless $self->name;
 
-    my(@constant_values,$domain,$path,$expires,$secure);
+    my(@constant_values,$domain,$path,$expires,$max_age,$secure);
 
-    push(@constant_values,"domain=$domain") if $domain = $self->domain;
-    push(@constant_values,"path=$path") if $path = $self->path;
+    push(@constant_values,"domain=$domain")   if $domain = $self->domain;
+    push(@constant_values,"path=$path")       if $path = $self->path;
     push(@constant_values,"expires=$expires") if $expires = $self->expires;
+    push(@constant_values,"max-age=$max_age") if $max_age = $self->max_age;
     push(@constant_values,"secure") if $secure = $self->secure;
 
     my($key) = escape($self->name);
@@ -190,6 +192,13 @@ sub expires {
     return $self->{'expires'};
 }
 
+sub max_age {
+  my $self = shift;
+  my $expires = shift;
+  $self->{'max-age'} = CGI::Util::expire_calc($expires)-time if defined $expires;
+  return $self->{'max-age'};
+}
+
 sub path {
     my $self = shift;
     my $path = shift;
index ef606e9..c498db5 100644 (file)
@@ -10,7 +10,7 @@ package CGI::Pretty;
 use strict;
 use CGI ();
 
-$CGI::Pretty::VERSION = '1.05_00';
+$CGI::Pretty::VERSION = '1.07_00';
 $CGI::DefaultClass = __PACKAGE__;
 $CGI::Pretty::AutoloadClass = 'CGI';
 @CGI::Pretty::ISA = qw( CGI );
@@ -19,18 +19,27 @@ initialize_globals();
 
 sub _prettyPrint {
     my $input = shift;
+    return if !$$input;
+    return if !$CGI::Pretty::LINEBREAK || !$CGI::Pretty::INDENT;
+
+#    print STDERR "'", $$input, "'\n";
 
     foreach my $i ( @CGI::Pretty::AS_IS ) {
-       if ( $$input =~ /<\/$i>/si ) {
-           my ( $a, $b, $c, $d, $e ) = $$input =~ /(.*)<$i(\s?)(.*?)>(.*?)<\/$i>(.*)/si;
-           _prettyPrint( \$a );
-           _prettyPrint( \$e );
+       if ( $$input =~ m{</$i>}si ) {
+           my ( $a, $b, $c ) = $$input =~ m{(.*)(<$i[\s/>].*?</$i>)(.*)}si;
+           next if !$b;
+           $a ||= "";
+           $c ||= "";
+
+           _prettyPrint( \$a ) if $a;
+           _prettyPrint( \$c ) if $c;
            
-           $$input = "$a<$i$b$c>$d</$i>$e";
+           $b ||= "";
+           $$input = "$a$b$c";
            return;
        }
     }
-    $$input =~ s/$CGI::Pretty::LINEBREAK/$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT/g if $CGI::Pretty::LINEBREAK; 
+    $$input =~ s/$CGI::Pretty::LINEBREAK/$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT/g;
 }
 
 sub comment {
@@ -44,7 +53,6 @@ sub comment {
 
 sub _make_tag_func {
     my ($self,$tagname) = @_;
-    return $self->SUPER::_make_tag_func($tagname) if $tagname=~/^(start|end)_/;
 
     # As Lincoln as noted, the last else clause is VERY hairy, and it
     # took me a while to figure out what I was trying to do.
@@ -57,60 +65,74 @@ sub _make_tag_func {
     # guru, so if anybody wants to contribute something that would
     # be quicker, easier to read, etc, I would be more than
     # willing to put it in - Brian
-    
-    return qq{
-       sub $tagname { 
-           # handle various cases in which we're called
-           # most of this bizarre stuff is to avoid -w errors
-            shift if \$_[0] && 
-                    (ref(\$_[0]) &&
-                     (substr(ref(\$_[0]),0,3) eq 'CGI' ||
-                    UNIVERSAL::isa(\$_[0],'CGI')));
-           
-           my(\$attr) = '';
-           if (ref(\$_[0]) && ref(\$_[0]) eq 'HASH') {
-               my(\@attr) = make_attributes(shift);
-               \$attr = " \@attr" if \@attr;
-           }
 
-           my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E");
-           return \$tag unless \@_;
-
-           my \@result;
-           my \$NON_PRETTIFY_ENDTAGS =  join "", map { "</\$_>" } \@CGI::Pretty::AS_IS;
-
-           if ( \$NON_PRETTIFY_ENDTAGS =~ /\$untag/ ) {
+    my $func = qq"
+       sub $tagname {";
+
+    $func .= q'
+            shift if $_[0] && 
+                    (ref($_[0]) &&
+                     (substr(ref($_[0]),0,3) eq "CGI" ||
+                    UNIVERSAL::isa($_[0],"CGI")));
+           my($attr) = "";
+           if (ref($_[0]) && ref($_[0]) eq "HASH") {
+               my(@attr) = make_attributes(shift()||undef,1);
+               $attr = " @attr" if @attr;
+           }';
+
+    if ($tagname=~/start_(\w+)/i) {
+       $func .= qq! 
+            return "<\L$1\E\$attr>\$CGI::Pretty::LINEBREAK";} !;
+    } elsif ($tagname=~/end_(\w+)/i) {
+       $func .= qq! 
+            return "<\L/$1\E>\$CGI::Pretty::LINEBREAK"; } !;
+    } else {
+       $func .= qq#
+           return ( \$CGI::XHTML ? "<\L$tagname\E\$attr />" : "<\L$tagname\E\$attr>" ) .
+                   \$CGI::Pretty::LINEBREAK unless \@_;
+           my(\$tag,\$untag) = ("<\L$tagname\E\$attr>","</\L$tagname>\E");
+
+            my \%ASIS = map { lc("\$_") => 1 } \@CGI::Pretty::AS_IS;
+            my \@args;
+            if ( \$CGI::Pretty::LINEBREAK || \$CGI::Pretty::INDENT ) {
+             if(ref(\$_[0]) eq 'ARRAY') {
+                 \@args = \@{\$_[0]}
+              } else {
+                  foreach (\@_) {
+                     \$args[0] .= \$_;
+                      \$args[0] .= \$CGI::Pretty::LINEBREAK if \$args[0] !~ /\$CGI::Pretty::LINEBREAK\$/ && 0;
+                      chomp \$args[0] if exists \$ASIS{ "\L$tagname\E" };
+                      
+                     \$args[0] .= \$" if \$args[0] !~ /\$CGI::Pretty::LINEBREAK\$/ && 1;
+                 }
+                  chop \$args[0];
+             }
+            }
+            else {
+              \@args = ref(\$_[0]) eq 'ARRAY' ? \@{\$_[0]} : "\@_";
+            }
+
+            my \@result;
+            if ( exists \$ASIS{ "\L$tagname\E" } ) {
                \@result = map { "\$tag\$_\$untag\$CGI::Pretty::LINEBREAK" } 
-                (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_";
+                \@args;
            }
            else {
-                my \@args;
-               if(ref(\$_[0]) eq 'ARRAY') {
-                    \@args = \@{\$_[0]}
-                } else {
-                    foreach (\@_) {
-                        \$args[0] .= \$_;
-                        \$args[0] .= " " unless \$args[0] =~ /\\s\$/;
-                    }
-                    chop \$args[0];
-                }
                \@result = map { 
                    chomp; 
-                   if ( \$_ !~ /<\\// ) {
-                       s/\$CGI::Pretty::LINEBREAK/\$CGI::Pretty::LINEBREAK\$CGI::Pretty::INDENT/g if \$CGI::Pretty::LINEBREAK; 
-                   } 
-                   else {
-                       my \$tmp = \$_;
-                       CGI::Pretty::_prettyPrint( \\\$tmp );
-                       \$_ = \$tmp;
-                   }
-                   "\$tag\$CGI::Pretty::LINEBREAK\$CGI::Pretty::INDENT\$_\$CGI::Pretty::LINEBREAK\$untag\$CGI::Pretty::LINEBREAK" 
+                   my \$tmp = \$_;
+                   CGI::Pretty::_prettyPrint( \\\$tmp );
+                    \$tag . \$CGI::Pretty::LINEBREAK .
+                    \$CGI::Pretty::INDENT . \$tmp . \$CGI::Pretty::LINEBREAK . 
+                    \$untag . \$CGI::Pretty::LINEBREAK
                 } \@args;
            }
-           local \$" = "";
+           local \$" = "" if \$CGI::Pretty::LINEBREAK || \$CGI::Pretty::INDENT;
            return "\@result";
-       }
-    };
+       }#;
+    }    
+
+    return $func;
 }
 
 sub start_html {
@@ -136,10 +158,10 @@ sub initialize_globals {
     $CGI::Pretty::INDENT = "\t";
     
     # This is the string used for seperation between tags
-    $CGI::Pretty::LINEBREAK = "\n";
+    $CGI::Pretty::LINEBREAK = $/;
 
     # These tags are not prettify'd.
-    @CGI::Pretty::AS_IS = qw( a pre code script textarea );
+    @CGI::Pretty::AS_IS = qw( a pre code script textarea td );
 
     1;
 }
index b17f014..0de6a10 100644 (file)
@@ -14,7 +14,7 @@ BEGIN {
 
 use strict;
 
-use Test::More tests => 42;
+use Test::More tests => 47;
 use IO::Handle;
 
 BEGIN { use_ok('CGI::Carp') };
@@ -159,6 +159,28 @@ is($CGI::Carp::CUSTOM_MSG,
 CGI::Carp::set_message(''),
 
 #-----------------------------------------------------------------------------
+# Test set_progname
+#-----------------------------------------------------------------------------
+
+import CGI::Carp qw(name=new_progname);
+is($CGI::Carp::PROGNAME,
+     'new_progname',
+     'CGI::Carp::import set program name correctly');
+
+is(CGI::Carp::set_progname('newer_progname'),
+   'newer_progname',
+   'CGI::Carp::set_progname returns new program name');
+
+is($CGI::Carp::PROGNAME,
+   'newer_progname',
+   'CGI::Carp::set_progname program name set correctly');
+
+# set the message back to the empty string so that the tests later
+# work properly.
+is (CGI::Carp::set_progname(undef),undef,"CGI::Carp::set_progname returns unset name correctly");
+is ($CGI::Carp::PROGNAME,undef,"CGI::Carp::set_progname program name unset correctly");
+
+#-----------------------------------------------------------------------------
 # Test warnings_to_browser
 #-----------------------------------------------------------------------------
 
index b101e4d..1af6754 100755 (executable)
@@ -67,14 +67,14 @@ test(13,start_html() ."\n" eq <<END,"start_html()");
 <!DOCTYPE html
        PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
         "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
-<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>Untitled Document</title>
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US"><head><title>Untitled Document</title>
 </head><body>
 END
     ;
 test(14,start_html(-dtd=>"-//IETF//DTD HTML 3.2//FR",-lang=>'fr') ."\n" eq <<END,"start_html()");
 <!DOCTYPE html
        PUBLIC "-//IETF//DTD HTML 3.2//FR">
-<html xmlns="http://www.w3.org/1999/xhtml" lang="fr"><head><title>Untitled Document</title>
+<html xmlns="http://www.w3.org/1999/xhtml" lang="fr" xml:lang="fr"><head><title>Untitled Document</title>
 </head><body>
 END
     ;
@@ -83,7 +83,7 @@ test(15,start_html(-Title=>'The world of foo') ."\n" eq <<END,"start_html()");
 <!DOCTYPE html
        PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
         "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
-<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>The world of foo</title>
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US"><head><title>The world of foo</title>
 </head><body>
 END
     ;
@@ -94,7 +94,7 @@ test(17,$h =~ m!^Set-Cookie: fred=chocolate&chip\; path=/${CRLF}Date:.*${CRLF}Co
 test(18,start_h3 eq '<h3>');
 test(19,end_h3 eq '</h3>');
 test(20,start_table({-border=>undef}) eq '<table border>');
-test(21,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is &lt;not&gt; &#139;right&#155;</h1>');
+test(21,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is &lt;not&gt; &#8249;right&#8250;</h1>');
 charset('utf-8');
 if (ord("\t") == 9) {
 test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is &lt;not&gt; \8bright\9b</h1>');
index 033bcbf..d3c19c0 100755 (executable)
@@ -1,23 +1,16 @@
-#!/usr/local/bin/perl -w
-
-BEGIN {
-       chdir 't' if -d 't';
-       if ($ENV{PERL_CORE}) {
-               @INC = '../lib';
-       } else {
-               unshift @INC, qw( ../blib/lib ../blib/arch lib );
-       }
-}
+#!/bin/perl -w
 
 use strict;
-use Test::More tests => 5;
+use lib '.', 't/lib','../blib/lib','./blib/lib';
+use Test::More tests => 18;
 
 BEGIN { use_ok('CGI::Pretty') };
 
 # This is silly use_ok should take arguments
 use CGI::Pretty (':all');
 
-is(h1(), '<h1>',"single tag");
+is(h1(), '<h1 />
+',"single tag");
 
 is(ol(li('fred'),li('ethel')), <<HTML,   "basic indentation");
 <ol>
@@ -38,6 +31,26 @@ is(p('hi',pre('there'),'frog'), <<HTML, "<pre> tags");
 </p>
 HTML
 
+is(h1({-align=>'CENTER'},'fred'), <<HTML, "open/close tag with attribute");
+<h1 align="CENTER">
+       fred
+</h1>
+HTML
+
+is(h1({-align=>undef},'fred'), <<HTML,"open/close tag with orphan attribute");
+<h1 align>
+       fred
+</h1>
+HTML
+
+is(h1({-align=>'CENTER'},['fred','agnes']), <<HTML, "distributive tag with attribute");
+<h1 align="CENTER">
+       fred
+</h1>
+<h1 align="CENTER">
+       agnes
+</h1>
+HTML
 
 is(p('hi',a({-href=>'frog'},'there'),'frog'), <<HTML,   "as-is");
 <p>
@@ -46,3 +59,63 @@ is(p('hi',a({-href=>'frog'},'there'),'frog'), <<HTML,   "as-is");
 </p>
 HTML
 
+is(p([ qw( hi there frog ) ] ), <<HTML,   "array-reference");
+<p>
+       hi
+</p>
+<p>
+       there
+</p>
+<p>
+       frog
+</p>
+HTML
+
+is(p(p(p('hi'), 'there' ), 'frog'), <<HTML,   "nested tags");
+<p>
+       <p>
+               <p>
+                       hi
+               </p>
+               there
+       </p>
+       frog
+</p>
+HTML
+
+is(table(TR(td(table(TR(td('hi', 'there', 'frog')))))), <<HTML,   "nested as-is tags");
+<table>
+       <tr>
+               <td><table>
+                       <tr>
+                               <td>hi there frog</td>
+                       </tr>
+               </table></td>
+       </tr>
+</table>
+HTML
+
+is(table(TR(td(table(TR(td( [ qw( hi there frog ) ])))))), <<HTML,   "nested as-is array-reference");
+<table>
+       <tr>
+               <td><table>
+                       <tr>
+                               <td>hi</td>
+                               <td>there</td>
+                               <td>frog</td>
+                       </tr>
+               </table></td>
+       </tr>
+</table>
+HTML
+
+$CGI::Pretty::INDENT = $CGI::Pretty::LINEBREAK = ""; 
+
+is(h1(), '<h1 />',"single tag (pretty turned off)");
+is(h1('fred'), '<h1>fred</h1>',"open/close tag (pretty turned off)");
+is(h1('fred','agnes','maura'), '<h1>fred agnes maura</h1>',"open/close tag multiple (pretty turned off)");
+is(h1({-align=>'CENTER'},'fred'), '<h1 align="CENTER">fred</h1>',"open/close tag with attribute (pretty turned off)");
+is(h1({-align=>undef},'fred'), '<h1 align>fred</h1>',"open/close tag with orphan attribute (pretty turned off)");
+is(h1({-align=>'CENTER'},['fred','agnes']), '<h1 align="CENTER">fred</h1> <h1 align="CENTER">agnes</h1>',
+   "distributive tag with attribute (pretty turned off)");
+
index 9727a1c..4ad93ff 100644 (file)
@@ -3,7 +3,7 @@ package Digest;
 use strict;
 use vars qw($VERSION %MMAP $AUTOLOAD);
 
-$VERSION = "1.00";
+$VERSION = "1.01";
 
 %MMAP = (
   "SHA-1"      => "Digest::SHA1",
@@ -124,11 +124,16 @@ load the right module on first use.  The second form allow you to use
 algorithm names which contains letters which are not legal perl
 identifiers, e.g. "SHA-1".
 
-If new() is called as an instance method (i.e. $ctx->new) it will just
+If new() is called as a instance method (i.e. $ctx->new) it will just
 reset the state the object to the state of a newly created object.  No
 new object is created in this case, and the return value is the
 reference to the object (i.e. $ctx).
 
+=item $other_ctx = $ctx->clone
+
+The clone method creates a copy of the digest state object and returns
+a reference to the copy.
+
 =item $ctx->reset
 
 This is just an alias for $ctx->new.
@@ -151,7 +156,8 @@ Return the binary digest for the message.
 Note that the C<digest> operation is effectively a destructive,
 read-once operation. Once it has been performed, the $ctx object is
 automatically C<reset> and can be used to calculate another digest
-value.
+value.  Call $ctx->clone->digest if you want to calculate the digest
+without reseting the digest state.
 
 =item $ctx->hexdigest
 
index 72fd195..8953e97 100644 (file)
@@ -568,7 +568,7 @@ sub _find_opt {
     local ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow,
        $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat,
        $pre_process, $post_process, $dangling_symlinks);
-    local($dir, $name, $fullname, $prune);
+    local($dir, $name, $fullname, $prune, $_);
 
     my $cwd            = $wanted->{bydepth} ? Cwd::fastcwd() : Cwd::getcwd();
     my $cwd_untainted  = $cwd;
index 4e5a217..c55b4a9 100644 (file)
@@ -15,8 +15,8 @@ BEGIN {
     $SIG{'__WARN__'} = sub { $warn_msg = $_[0]; warn "# $_[0]"; }
 }
 
-if ( $symlink_exists ) { print "1..188\n"; }
-else                   { print "1..78\n";  }
+if ( $symlink_exists ) { print "1..189\n"; }
+else                   { print "1..79\n";  }
 
 # Uncomment this to see where File::Find is chdir'ing to.  Helpful for
 # debugging its little jaunts around the filesystem.
@@ -484,6 +484,18 @@ File::Find::find( {wanted => \&noop_wanted,
 
 Check( scalar(keys %Expect_Dir) == 0 );
 
+{
+    print "# checking argument localization\n";
+
+    ### this checks the fix of perlbug [19977] ###
+    my @foo = qw( a b c d e f );
+    my %pre = map { $_ => } @foo;
+
+    File::Find::find( sub {  } , 'fa' ) for @foo;
+    delete $pre{$_} for @foo;
+
+    Check( scalar( keys %pre ) == 0 );
+}
 
 if ( $symlink_exists ) {
     print "# --- symbolic link tests --- \n";
@@ -761,5 +773,4 @@ if ( $symlink_exists ) {
     Check( scalar(keys %Expect_File) == 0 );
     unlink file_path('fa', 'faa_sl');
 
-} 
-
+}
index faef1d7..51553b5 100644 (file)
@@ -132,7 +132,18 @@ sub timelocal {
        or return $loc_t;
 
     # Adjust for DST change
-    $loc_t + $dst_off;
+    $loc_t += $dst_off;
+
+    # for a negative offset from GMT, and if the original date
+    # was a non-extent gap in a forward DST jump, we should
+    # now have the wrong answer - undo the DST adjust;
+
+    return $loc_t if $zone_off <= 0;
+
+    my ($s,$m,$h) = localtime($loc_t);
+    $loc_t -= $dst_off if $s != $_[0] || $m != $_[1] || $h != $_[2];
+
+    $loc_t;
 }
 
 
index a384b17..68952c9 100755 (executable)
@@ -28,7 +28,7 @@ use Time::Local;
 # use vmsish 'time' makes for oddness around the Unix epoch
 if ($^O eq 'VMS') { $time[0][2]++ }
 
-print "1..", @time * 2 + 5, "\n";
+print "1..", @time * 2 + 6, "\n";
 
 $count = 1;
 for (@time) {
@@ -93,6 +93,20 @@ timegm(0,0,0, 1, 2, 80) - timegm(0,0,0, 1, 0, 80) == 60 * 24 * 3600
   or print "not ";
 print "ok ", $count++, "\n";
 
+# bugid #19393
+# At a DST transition, the clock skips forward, eg from 01:59:59 to
+# 03:00:00. In this case, 02:00:00 is an invalid time, and should be
+# treated like 03:00:00 rather than 01:00:00 - negative zone offsets used
+# to do the latter
+
+{
+    my $hour = (localtime(timelocal(0, 0, 2, 7, 3, 102)))[2];
+    # testers in US/Pacific should get 3,
+    # other testers should get 2
+    print "not " unless $hour == 2 || $hour == 3;
+    print "ok ", $main::count++, "\n";
+}
+
 
 #print "Testing timelocal.pl module too...\n";
 package test;
index c68fa3f..1ba70c5 100755 (executable)
@@ -4,7 +4,7 @@ package diagnostics;
 
 diagnostics - Perl compiler pragma to force verbose warning diagnostics
 
-splain - standalone program to do the same thing
+splain - filter to produce verbose descriptions of perl warning diagnostics
 
 =head1 SYNOPSIS
 
@@ -16,7 +16,7 @@ As a pragma:
     enable  diagnostics;
     disable diagnostics;
 
-Aa a program:
+As a program:
 
     perl program 2>diag.out
     splain [-v] [-p] diag.out
index c03451b..9d52244 100644 (file)
--- a/locale.c
+++ b/locale.c
@@ -475,7 +475,7 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
 
 #ifdef USE_PERLIO
     {
-      /* Set PL_wantutf8 to TRUE if using PerlIO _and_
+      /* Set PL_utf8locale to TRUE if using PerlIO _and_
         any of the following are true:
         - nl_langinfo(CODESET) contains /^utf-?8/i
         - $ENV{LC_ALL}   contains /^utf-?8/i
@@ -487,37 +487,44 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
         it overrides LC_MESSAGES for GNU gettext, and it also
         can have more than one locale, separated by spaces,
         in case you need to know.)
-        If PL_wantutf8 is true, perl.c:S_parse_body()
-        will turn on the PerlIO :utf8 discipline on STDIN, STDOUT,
-        STDERR, _and_ the default open discipline.
+        If PL_utf8locale and PL_wantutf8 (set by -C) are true,
+        perl.c:S_parse_body() will turn on the PerlIO :utf8 layer
+        on STDIN, STDOUT, STDERR, _and_ the default open discipline.
       */
-        bool wantutf8 = FALSE;
+        bool utf8locale = FALSE;
         char *codeset = NULL;
 #if defined(HAS_NL_LANGINFO) && defined(CODESET)
         codeset = nl_langinfo(CODESET);
 #endif
         if (codeset)
-             wantutf8 = (ibcmp(codeset,  "UTF-8", 5) == 0 ||
-                         ibcmp(codeset,  "UTF8",  4) == 0);
+             utf8locale = (ibcmp(codeset,  "UTF-8", 5) == 0 ||
+                           ibcmp(codeset,  "UTF8",  4) == 0);
 #if defined(USE_LOCALE)
         else { /* nl_langinfo(CODESET) is supposed to correctly
                 * interpret the locale environment variables,
                 * but just in case it fails, let's do this manually. */ 
              if (lang)
-                  wantutf8 = (ibcmp(lang,     "UTF-8", 5) == 0 ||
-                              ibcmp(lang,     "UTF8",  4) == 0);
+                  utf8locale = (ibcmp(lang,     "UTF-8", 5) == 0 ||
+                                ibcmp(lang,     "UTF8",  4) == 0);
 #ifdef USE_LOCALE_CTYPE
              if (curctype)
-                  wantutf8 = (ibcmp(curctype,     "UTF-8", 5) == 0 ||
-                              ibcmp(curctype,     "UTF8",  4) == 0);
+                  utf8locale = (ibcmp(curctype,     "UTF-8", 5) == 0 ||
+                                ibcmp(curctype,     "UTF8",  4) == 0);
 #endif
              if (lc_all)
-                  wantutf8 = (ibcmp(lc_all,   "UTF-8", 5) == 0 ||
-                              ibcmp(lc_all,   "UTF8",  4) == 0);
-#endif /* USE_LOCALE */
+                  utf8locale = (ibcmp(lc_all,   "UTF-8", 5) == 0 ||
+                                ibcmp(lc_all,   "UTF8",  4) == 0);
         }
-        if (wantutf8)
-             PL_wantutf8 = TRUE;
+#endif /* USE_LOCALE */
+        if (utf8locale)
+             PL_utf8locale = TRUE;
+    }
+    /* Set PL_wantutf8 to $ENV{PERL_UTF8_LOCALE} if using PerlIO.
+       This is an alternative to using the -C command line switch
+       (the -C if present will override this). */
+    {
+        char *p = PerlEnv_getenv("PERL_UTF8_LOCALE");
+        PL_wantutf8 = p ? (bool) atoi(p) : FALSE;
     }
 #endif
 
diff --git a/mg.c b/mg.c
index bdf204b..72c8fdf 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -662,7 +662,11 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
                    ? (PL_taint_warn || PL_unsafe ? -1 : 1)
                    : 0);
         break;
-    case '\027':               /* ^W  & $^WARNING_BITS & ^WIDE_SYSTEM_CALLS */
+    case '\025':               /* $^UTF8_LOCALE */
+        if (strEQ(mg->mg_ptr, "\025TF8_LOCALE"))
+           sv_setiv(sv, (IV) (PL_wantutf8 && PL_utf8locale));
+        break;
+    case '\027':               /* ^W  & $^WARNING_BITS */
        if (*(mg->mg_ptr+1) == '\0')
            sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
        else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
@@ -679,8 +683,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
            }
            SvPOK_only(sv);
        }
-       else if (strEQ(mg->mg_ptr+1, "IDE_SYSTEM_CALLS"))
-           sv_setiv(sv, (IV)PL_widesyscalls);
        break;
     case '1': case '2': case '3': case '4':
     case '5': case '6': case '7': case '8': case '9': case '&':
@@ -1925,7 +1927,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
        PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
 #endif
        break;
-    case '\027':       /* ^W & $^WARNING_BITS & ^WIDE_SYSTEM_CALLS */
+    case '\025':       /* $^UTF8_LOCALE */
+        if (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv))
+           PL_wantutf8 = PL_utf8locale;
+       else
+           PL_wantutf8 = FALSE;
+        break;
+    case '\027':       /* ^W & $^WARNING_BITS */
        if (*(mg->mg_ptr+1) == '\0') {
            if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
                i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
@@ -1967,8 +1975,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
                }
            }
        }
-       else if (strEQ(mg->mg_ptr+1, "IDE_SYSTEM_CALLS"))
-           PL_widesyscalls = (bool)SvTRUE(sv);
        break;
     case '.':
        if (PL_localizing) {
diff --git a/perl.c b/perl.c
index 8b73d25..3493cd8 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -1355,10 +1355,11 @@ print \"  \\@INC:\\n    @INC\\n\";");
     if (!PL_do_undump)
        init_postdump_symbols(argc,argv,env);
 
-    /* PL_wantutf8 is conditionally turned on by
+    /* PL_utf8locale is conditionally turned on by
      * locale.c:Perl_init_i18nl10n() if the environment
-     * look like the user wants to use UTF-8. */
-    if (PL_wantutf8) { /* Requires init_predump_symbols(). */
+     * look like the user wants to use UTF-8.
+     * PL_wantutf8 is turned on by -C or by $ENV{PERL_UTF8_LOCALE}. */
+    if (PL_utf8locale && PL_wantutf8) { /* Requires init_predump_symbols(). */
         IO* io;
         PerlIO* fp;
         SV* sv;
@@ -2156,7 +2157,7 @@ Perl_moreswitches(pTHX_ char *s)
        return s + numlen;
     }
     case 'C':
-       PL_widesyscalls = TRUE;
+        PL_wantutf8 = TRUE; /* Can be set earlier by $ENV{PERL_UTF8_LOCALE}. */
        s++;
        return s;
     case 'F':
@@ -3397,7 +3398,7 @@ Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
        for (; argc > 0; argc--,argv++) {
            SV *sv = newSVpv(argv[0],0);
            av_push(GvAVn(PL_argvgv),sv);
-           if (PL_widesyscalls)
+           if (PL_wantutf8)
                (void)sv_utf8_decode(sv);
        }
     }
index 451a4d9..ff344ab 100644 (file)
--- a/perlapi.h
+++ b/perlapi.h
@@ -584,14 +584,14 @@ END_EXTERN_C
 #define PL_utf8_upper          (*Perl_Iutf8_upper_ptr(aTHX))
 #undef  PL_utf8_xdigit
 #define PL_utf8_xdigit         (*Perl_Iutf8_xdigit_ptr(aTHX))
+#undef  PL_utf8locale
+#define PL_utf8locale          (*Perl_Iutf8locale_ptr(aTHX))
 #undef  PL_uudmap
 #define PL_uudmap              (*Perl_Iuudmap_ptr(aTHX))
 #undef  PL_wantutf8
 #define PL_wantutf8            (*Perl_Iwantutf8_ptr(aTHX))
 #undef  PL_warnhook
 #define PL_warnhook            (*Perl_Iwarnhook_ptr(aTHX))
-#undef  PL_widesyscalls
-#define PL_widesyscalls                (*Perl_Iwidesyscalls_ptr(aTHX))
 #undef  PL_xiv_arenaroot
 #define PL_xiv_arenaroot       (*Perl_Ixiv_arenaroot_ptr(aTHX))
 #undef  PL_xiv_root
index bd21291..f25f9c7 100644 (file)
@@ -5277,7 +5277,8 @@ The commonly available S_IF* constants are
     S_IRWXG S_IRGRP S_IWGRP S_IXGRP
     S_IRWXO S_IROTH S_IWOTH S_IXOTH
 
-    # Setuid/Setgid/Stickiness.
+    # Setuid/Setgid/Stickiness/SaveText.
+    # Note that the exact meaning of these is system dependent.
 
     S_ISUID S_ISGID S_ISVTX S_ISTXT
 
index 9360b85..46e1849 100644 (file)
@@ -266,11 +266,21 @@ An alternate delimiter may be specified using B<-F>.
 
 =item B<-C>
 
-enables Perl to use the native wide character APIs on the target system.
-The magic variable C<${^WIDE_SYSTEM_CALLS}> reflects the state of
-this switch.  See L<perlvar/"${^WIDE_SYSTEM_CALLS}">.
-
-This feature is currently only implemented on the Win32 platform.
+enables Perl to use the Unicode APIs on the target system.
+
+As of Perl 5.8.1, if C<-C> is used and the locale settings (the LC_ALL,
+LC_CTYPE, and LANG environment variables) indicate a UTF-8 locale,
+the STDIN is expected to be in UTF-8, the STDOUT and STDERR are
+expected to be in UTF-8, and C<:utf8> is the default file open layer.
+See L<perluniintro>, L<perlfunc/open>, and L<open> for more information.
+The magic variable C<${^UTF8_LOCALE}> reflects this state,
+see L<perlvar/"${^UTF8_LOCALE}">.  (Another way of setting this
+variable is to set the environment variable PERL_UTF8_LOCALE.)
+
+(In Perls earlier than 5.8.1 the C<-C> switch was a Win32-only switch
+that enabled the use of Unicode-aware "wide system call" Win32 APIs.
+This feature was practically unused, however, and the command line
+switch was therefore "recycled".)
 
 =item B<-c>
 
@@ -448,9 +458,9 @@ output filehandle after the loop.
 As shown above, Perl creates the backup file whether or not any output
 is actually changed.  So this is just a fancy way to copy files:
 
-    $ perl -p -i '/some/file/path/*' -e 1 file1 file2 file3...
+    $ perl -p -i'/some/file/path/*' -e 1 file1 file2 file3...
 or
-    $ perl -p -i '.orig' -e 1 file1 file2 file3...
+    $ perl -p -i'.orig' -e 1 file1 file2 file3...
 
 You can use C<eof> without parentheses to locate the end of each input
 file, in case you want to append to each file, or reset line numbering
index ee8b6ef..1d3f846 100644 (file)
@@ -67,13 +67,6 @@ character data.  Such data may come from filehandles, from calls to
 external programs, from information provided by the system (such as %ENV),
 or from literals and constants in the source text.
 
-On Windows platforms, if the C<-C> command line switch is used or the
-${^WIDE_SYSTEM_CALLS} global flag is set to C<1>, all system calls
-will use the corresponding wide-character APIs.  This feature is
-available only on Windows to conform to the API standard already
-established for that platform--and there are very few non-Windows
-platforms that have Unicode-aware APIs.
-
 The C<bytes> pragma will always, regardless of platform, force byte
 semantics in a particular lexical scope.  See L<bytes>.
 
@@ -1050,10 +1043,14 @@ there are a couple of exceptions:
 
 =item *
 
-If your locale environment variables (LANGUAGE, LC_ALL, LC_CTYPE, LANG)
-contain the strings 'UTF-8' or 'UTF8' (case-insensitive matching),
-the default encodings of your STDIN, STDOUT, and STDERR, and of
-B<any subsequent file open>, are considered to be UTF-8.
+If your locale environment variables (LC_ALL, LC_CTYPE, LANG)
+contain the strings 'UTF-8' or 'UTF8' (matched case-insensitively)
+B<and> you enable using UTF-8 either by using the C<-C> command line
+switch or setting the PERL_UTF8_LOCALE environment variable to a true
+value, then the default encodings of your STDIN, STDOUT, and STDERR,
+and of B<any subsequent file open>, are considered to be UTF-8.
+See L<perluniintro>, L<perlfunc/open>, and L<open> for more
+information.  The magic variable C<${^UTF8_LOCALE}> will also be set.
 
 =item *
 
@@ -1410,6 +1407,6 @@ the UTF-8 flag:
 =head1 SEE ALSO
 
 L<perluniintro>, L<encoding>, L<Encode>, L<open>, L<utf8>, L<bytes>,
-L<perlretut>, L<perlvar/"${^WIDE_SYSTEM_CALLS}">
+L<perlretut>, L<perlvar/"${^UTF8_LOCALE}">
 
 =cut
index 21f0fa7..3a23460 100644 (file)
@@ -172,13 +172,15 @@ To output UTF-8, use the C<:utf8> output layer.  Prepending
 to this sample program ensures that the output is completely UTF-8,
 and removes the program's warning.
 
-If your locale environment variables (C<LANGUAGE>, C<LC_ALL>,
-C<LC_CTYPE>, C<LANG>) contain the strings 'UTF-8' or 'UTF8',
-regardless of case, then the default encoding of your STDIN, STDOUT,
-and STDERR and of B<any subsequent file open>, is UTF-8.  Note that
-this means that Perl expects other software to work, too: if Perl has
-been led to believe that STDIN should be UTF-8, but then STDIN coming
-in from another command is not UTF-8, Perl will complain about the
+If your locale environment variables (C<LC_ALL>, C<LC_CTYPE>, C<LANG>)
+contain the strings 'UTF-8' or 'UTF8' (matched case-insensitively)
+B<and> you enable using UTF-8 either by using the C<-C> command line
+switch or by setting the PERL_UTF8_LOCALE environment variable to
+a true value, then the default encoding of your STDIN, STDOUT, and
+STDERR, and of B<any subsequent file open>, is UTF-8.  Note that this
+means that Perl expects other software to work, too: if Perl has been
+led to believe that STDIN should be UTF-8, but then STDIN coming in
+from another command is not UTF-8, Perl will complain about the
 malformed UTF-8.
 
 All features that combine Unicode and I/O also require using the new
index 08235c2..7621be0 100644 (file)
@@ -1109,6 +1109,16 @@ Reflects if taint mode is on or off.  1 for on (the program was run with
 B<-T>), 0 for off, -1 when only taint warnings are enabled (i.e. with
 B<-t> or B<-TU>).  This variable is read-only.
 
+=item ${^UTF8_LOCALE}
+
+Reflects whether the locale settings indicated the use of UTF-8 and that
+the use of UTF-8 was enabled either by the C<-C> command line switch or
+by setting the PERL_UTF8_LOCALE environment variable to a true value.
+This variable is read-only.  If true, the STDIN is expected to be in
+UTF-8, the STDOUT and STDERR are in UTF-8, and C<:utf8> is the default
+file open layer.  See L<perluniintro>, L<perlfunc/open>, and L<open>
+for more information.
+
 =item $PERL_VERSION
 
 =item $^V
@@ -1148,21 +1158,6 @@ related to the B<-w> switch.)  See also L<warnings>.
 The current set of warning checks enabled by the C<use warnings> pragma.
 See the documentation of C<warnings> for more details.
 
-=item ${^WIDE_SYSTEM_CALLS}
-
-Global flag that enables system calls made by Perl to use wide character
-APIs native to the system, if available.  This is currently only implemented
-on the Windows platform.
-
-This can also be enabled from the command line using the C<-C> switch.
-
-The initial value is typically C<0> for compatibility with Perl versions
-earlier than 5.6, but may be automatically set to C<1> by Perl if the system
-provides a user-settable default (e.g., C<$ENV{LC_CTYPE}>).
-
-The C<bytes> pragma always overrides the effect of this flag in the current
-lexical scope.  See L<bytes>.
-
 =item $EXECUTABLE_NAME
 
 =item $^X
diff --git a/pp.c b/pp.c
index c78246e..c9d1dc6 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -3278,8 +3278,19 @@ PP(pp_chr)
     *tmps++ = (char)value;
     *tmps = '\0';
     (void)SvPOK_only(TARG);
-    if (PL_encoding)
+    if (PL_encoding && !IN_BYTES) {
         sv_recode_to_utf8(TARG, PL_encoding);
+       tmps = SvPVX(TARG);
+       if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
+           memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
+           SvGROW(TARG,3);
+           SvCUR_set(TARG, 2);
+           *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
+           *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
+           *tmps = '\0';
+           SvUTF8_on(TARG);
+       }
+    }
     XPUSHs(TARG);
     RETURN;
 }
index 24d26d7..461c666 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1466,6 +1466,8 @@ Perl_do_readline(pTHX)
                report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
        }
        if (gimme == G_SCALAR) {
+           /* undef TARG, and push that undefined value */
+           SV_CHECK_THINKFIRST_COW_DROP(TARG);
            (void)SvOK_off(TARG);
            PUSHTARG;
        }
@@ -1527,6 +1529,7 @@ Perl_do_readline(pTHX)
                }
            }
            if (gimme == G_SCALAR) {
+               SV_CHECK_THINKFIRST_COW_DROP(TARG);
                (void)SvOK_off(TARG);
                SPAGAIN;
                PUSHTARG;
index 35a1e91..052af90 100644 (file)
--- a/reentr.c
+++ b/reentr.c
@@ -35,10 +35,10 @@ Perl_reentrant_size(pTHX) {
 #ifdef HAS_DRAND48_R
 #endif /* HAS_DRAND48_R */
 #ifdef HAS_GETGRNAM_R
-#   if defined(HAS_SYSCONF) && defined(_SC_GETPW_R_SIZE_MAX) && !defined(__GLIBC__)
-       PL_reentrant_buffer->_grent_size = sysconf(_SC_GETPW_R_SIZE_MAX);
-       if (PL_reentrant_buffer->_pwent_size == -1)
-               PL_reentrant_buffer->_pwent_size = REENTRANTUSUALSIZE;
+#   if defined(HAS_SYSCONF) && defined(_SC_GETGR_R_SIZE_MAX) && !defined(__GLIBC__)
+       PL_reentrant_buffer->_grent_size = sysconf(_SC_GETGR_R_SIZE_MAX);
+       if (PL_reentrant_buffer->_grent_size == -1)
+               PL_reentrant_buffer->_grent_size = REENTRANTUSUALSIZE;
 #   else
 #       if defined(__osf__) && defined(__alpha) && defined(SIABUFSIZ)
        PL_reentrant_buffer->_grent_size = SIABUFSIZ;
@@ -94,8 +94,8 @@ Perl_reentrant_size(pTHX) {
 #ifdef HAS_GETSPNAM_R
 #   if defined(HAS_SYSCONF) && defined(_SC_GETPW_R_SIZE_MAX) && !defined(__GLIBC__)
        PL_reentrant_buffer->_spent_size = sysconf(_SC_GETPW_R_SIZE_MAX);
-       if (PL_reentrant_buffer->_pwent_size == -1)
-               PL_reentrant_buffer->_pwent_size = REENTRANTUSUALSIZE;
+       if (PL_reentrant_buffer->_spent_size == -1)
+               PL_reentrant_buffer->_spent_size = REENTRANTUSUALSIZE;
 #   else
 #       if defined(__osf__) && defined(__alpha) && defined(SIABUFSIZ)
        PL_reentrant_buffer->_spent_size = SIABUFSIZ;
@@ -342,10 +342,10 @@ Perl_reentrant_retry(const char *f, ...)
                case OP_GHOSTENT:
                    retptr = gethostent(); break;
                default:
+                   SETERRNO(ERANGE, LIB_INVARG);
                    break;
                }
            }
-           SETERRNO(ERANGE, LIB_INVARG);
        }
        break;
 #endif
@@ -373,10 +373,10 @@ Perl_reentrant_retry(const char *f, ...)
                case OP_GGRENT:
                    retptr = getgrent(); break;
                default:
+                   SETERRNO(ERANGE, LIB_INVARG);
                    break;
                }
            }
-           SETERRNO(ERANGE, LIB_INVARG);
        }
        break;
 #endif
@@ -405,10 +405,10 @@ Perl_reentrant_retry(const char *f, ...)
                case OP_GNETENT:
                    retptr = getnetent(); break;
                default:
+                   SETERRNO(ERANGE, LIB_INVARG);
                    break;
                }
            }
-           SETERRNO(ERANGE, LIB_INVARG);
        }
        break;
 #endif
@@ -436,6 +436,7 @@ Perl_reentrant_retry(const char *f, ...)
                case OP_GPWENT:
                    retptr = getpwent(); break;
                default:
+                   SETERRNO(ERANGE, LIB_INVARG);
                    break;
                }
            }
@@ -465,10 +466,10 @@ Perl_reentrant_retry(const char *f, ...)
                case OP_GPROTOENT:
                    retptr = getprotoent(); break;
                default:
+                   SETERRNO(ERANGE, LIB_INVARG);
                    break;
                }
            }
-           SETERRNO(ERANGE, LIB_INVARG);
        }
        break;
 #endif
@@ -497,10 +498,10 @@ Perl_reentrant_retry(const char *f, ...)
                case OP_GSERVENT:
                    retptr = getservent(); break;
                default:
+                   SETERRNO(ERANGE, LIB_INVARG);
                    break;
                }
            }
-           SETERRNO(ERANGE, LIB_INVARG);
        }
        break;
 #endif
index 85ec64a..6b23aa8 100644 (file)
--- a/reentr.pl
+++ b/reentr.pl
@@ -493,43 +493,36 @@ EOF
        $seent{$func}*  _${genfunc}_ptr;
 #   endif
 EOF
-           if ($genfunc eq 'getspent') {
-               push @size, <<EOF;
-       PL_reentrant_buffer->_${genfunc}_size = 1024;
-EOF
-           } else {
-               push @struct, <<EOF;
+           push @struct, <<EOF;
 #   ifdef USE_${GENFUNC}_FPTR
        FILE*   _${genfunc}_fptr;
 #   endif
 EOF
-                   push @init, <<EOF;
+           push @init, <<EOF;
 #   ifdef USE_${GENFUNC}_FPTR
        PL_reentrant_buffer->_${genfunc}_fptr = NULL;
 #   endif
 EOF
-               my $sc = $genfunc eq 'getgrent' ?
+           my $sc = $genfunc eq 'grent' ?
                    '_SC_GETGR_R_SIZE_MAX' : '_SC_GETPW_R_SIZE_MAX';
-               my $sz = $genfunc eq 'getgrent' ?
-                    '_grent_size' : '_pwent_size';
-               push @size, <<EOF;
+           my $sz = "_${genfunc}_size";
+           push @size, <<EOF;
 #   if defined(HAS_SYSCONF) && defined($sc) && !defined(__GLIBC__)
-       PL_reentrant_buffer->_${genfunc}_size = sysconf($sc);
+       PL_reentrant_buffer->$sz = sysconf($sc);
        if (PL_reentrant_buffer->$sz == -1)
                PL_reentrant_buffer->$sz = REENTRANTUSUALSIZE;
 #   else
 #       if defined(__osf__) && defined(__alpha) && defined(SIABUFSIZ)
-       PL_reentrant_buffer->_${genfunc}_size = SIABUFSIZ;
+       PL_reentrant_buffer->$sz = SIABUFSIZ;
 #       else
 #           ifdef __sgi
-       PL_reentrant_buffer->_${genfunc}_size = BUFSIZ;
+       PL_reentrant_buffer->$sz = BUFSIZ;
 #           else
-       PL_reentrant_buffer->_${genfunc}_size = REENTRANTUSUALSIZE;
+       PL_reentrant_buffer->$sz = REENTRANTUSUALSIZE;
 #           endif
 #       endif
 #   endif 
 EOF
-            }
            pushinitfree $genfunc;
            pushssif $endif;
        }
@@ -814,6 +807,7 @@ Perl_reentrant_retry(const char *f, ...)
                case OP_GHOSTENT:
                    retptr = gethostent(); break;
                default:
+                   SETERRNO(ERANGE, LIB_INVARG);
                    break;
                }
            }
@@ -844,6 +838,7 @@ Perl_reentrant_retry(const char *f, ...)
                case OP_GGRENT:
                    retptr = getgrent(); break;
                default:
+                   SETERRNO(ERANGE, LIB_INVARG);
                    break;
                }
            }
@@ -875,10 +870,10 @@ Perl_reentrant_retry(const char *f, ...)
                case OP_GNETENT:
                    retptr = getnetent(); break;
                default:
+                   SETERRNO(ERANGE, LIB_INVARG);
                    break;
                }
            }
-           SETERRNO(ERANGE, LIB_INVARG);
        }
        break;
 #endif
@@ -906,10 +901,10 @@ Perl_reentrant_retry(const char *f, ...)
                case OP_GPWENT:
                    retptr = getpwent(); break;
                default:
+                   SETERRNO(ERANGE, LIB_INVARG);
                    break;
                }
            }
-           SETERRNO(ERANGE, LIB_INVARG);
        }
        break;
 #endif
@@ -936,10 +931,10 @@ Perl_reentrant_retry(const char *f, ...)
                case OP_GPROTOENT:
                    retptr = getprotoent(); break;
                default:
+                   SETERRNO(ERANGE, LIB_INVARG);
                    break;
                }
            }
-           SETERRNO(ERANGE, LIB_INVARG);
        }
        break;
 #endif
@@ -968,10 +963,10 @@ Perl_reentrant_retry(const char *f, ...)
                case OP_GSERVENT:
                    retptr = getservent(); break;
                default:
+                   SETERRNO(ERANGE, LIB_INVARG);
                    break;
                }
            }
-           SETERRNO(ERANGE, LIB_INVARG);
        }
        break;
 #endif
diff --git a/sv.c b/sv.c
index ffa71e1..33e2202 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3395,7 +3395,7 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
         sv_force_normal_flags(sv, 0);
     }
 
-    if (PL_encoding)
+    if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
         sv_recode_to_utf8(sv, PL_encoding);
     else { /* Assume Latin-1/EBCDIC */
         /* This function could be much more efficient if we
diff --git a/sv.h b/sv.h
index 7c5e6dc..598397e 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -1030,6 +1030,7 @@ otherwise.
 #define SV_IMMEDIATE_UNREF     1
 #define SV_GMAGIC              2
 #define SV_COW_DROP_PV         4
+#define SV_UTF8_NO_ENCODING    8
 
 /* We are about to replace the SV's current value. So if it's copy on write
    we need to normalise it. Use the SV_COW_DROP_PV flag hint to say that
index ddc29ff..deb49ce 100755 (executable)
@@ -136,7 +136,9 @@ if (tell($tst) == 5) { print "ok 30\n"; } else { print "not ok 30\n"; }
 
 print $tst "xxxx\n";
 
-if (tell($tst) == 15) { print "ok 27\n"; } else { print "not ok 27\n"; }
+if (tell($tst) == 15 ||
+    tell($tst) == 5) # unset PERLIO or PERLIO=stdio (e.g. HP-UX, Solaris)
+{ print "ok 27\n"; } else { print "not ok 27\n"; }
 
 close($tst);
 
index a92a918..b611d0d 100755 (executable)
--- a/t/op/do.t
+++ b/t/op/do.t
@@ -31,7 +31,7 @@ sub ok {
     return $ok;
 }
 
-print "1..21\n";
+print "1..22\n";
 
 # Test do &sub and proper @_ handling.
 $_[0] = 0;
@@ -90,6 +90,10 @@ ok( !$@, "do on a non-existing file, second try"  );
 # 6 must be interpreted as a file name here
 ok( (!defined do 6) && $!, "'do 6' : $!" );
 
+# [perl #19545]
+push @t, ($u = (do {} . "This should be pushed."));
+ok( $#t == 0, "empty do result value" );
+
 END {
     1 while unlink("$$.16", "$$.17", "$$.18");
 }
index 86e405a..16ba186 100755 (executable)
--- a/t/op/fh.t
+++ b/t/op/fh.t
@@ -1,26 +1,29 @@
 #!./perl
 
-print "1..5\n";
+BEGIN {
+    chdir 't';
+    @INC = '../lib';
+    require './test.pl';
+}
 
-my $test = 0;
+plan tests => 8;
 
 # symbolic filehandles should only result in glob entries with FH constructors
 
 $|=1;
 my $a = "SYM000";
-print "not " if defined(fileno($a)) or defined *{$a};
-++$test; print "ok $test\n";
+ok(!defined(fileno($a)));
+ok(!defined *{$a});
 
 select select $a;
-print "not " unless defined *{$a};
-++$test; print "ok $test\n";
+ok(defined *{$a});
 
 $a++;
-print "not " if close $a or defined *{$a};
-++$test; print "ok $test\n";
+ok(!close $a);
+ok(!defined *{$a});
 
-print "not " unless open($a, ">&STDOUT") and defined *{$a};
-++$test; print $a "ok $test\n";
+ok(open($a, ">&STDOUT"));
+ok(defined *{$a});
+
+ok(close $a);
 
-print "not " unless close $a;
-++$test; print $a "not "; print "ok $test\n";
diff --git a/t/op/readline.t b/t/op/readline.t
new file mode 100644 (file)
index 0000000..ae04312
--- /dev/null
@@ -0,0 +1,13 @@
+#!./perl
+
+BEGIN {
+    chdir 't';
+    @INC = '../lib';
+    require './test.pl';
+}
+
+plan tests => 1;
+
+eval { for (\2) { $_ = <FH> } };
+like($@, 'Modification of a read-only value attempted', '[perl #19566]');
+
index fc53c39..7d5f59a 100755 (executable)
@@ -9,7 +9,7 @@ BEGIN {
     $| = 1;
 }
 
-print "1..94\n";
+print "1..98\n";
 
 $a = {};
 bless $a, "Bob";
@@ -174,3 +174,16 @@ test ! UNIVERSAL::isa("\xff\xff\xff\0", 'HASH');
     main::test can( "Pickup", "can" ) == \&UNIVERSAL::can;
     main::test VERSION "UNIVERSAL" ;
 }
+
+{
+    # test isa() and can() on magic variables
+    "Human" =~ /(.*)/;
+    test $1->isa("Human");
+    test $1->can("eat");
+    package HumanTie;
+    sub TIESCALAR { bless {} }
+    sub FETCH { "Human" }
+    tie my($x), "HumanTie";
+    ::test $x->isa("Human");
+    ::test $x->can("eat");
+}
index e4dd65d..93aa8ba 100644 (file)
--- a/uconfig.h
+++ b/uconfig.h
  *     available to split a long double x into a fractional part f and
  *     an integer part i such that |f| < 1.0 and (f + i) = x.
  */
+/* HAS_MODFL_PROTO:
+ *     This symbol, if defined, indicates that the system provides
+ *     a prototype for the modfl() function.  Otherwise, it is up
+ *     to the program to supply one.
+ */
 /* HAS_MODFL_POW32_BUG:
  *     This symbol, if defined, indicates that the modfl routine is
  *     broken for long doubles >= pow(2, 32).
  *     release 2.2.2 is known to be okay.
  */
 /*#define HAS_MODFL            / **/
+/*#define HAS_MODFL_PROTO              / **/
 /*#define HAS_MODFL_POW32_BUG          / **/
 
 /* HAS_MPROTECT:
  */
 /*#define HAS_STRUCT_MSGHDR    / **/
 
+/* HAS_NANOSLEEP:
+ *     This symbol, if defined, indicates that the nanosleep
+ *     system call is available to sleep with 1E-9 sec accuracy.
+ */
+/*#define HAS_NANOSLEEP                / **/
+
 /* HAS_OFF64_T:
  *     This symbol will be defined if the C compiler supports off64_t.
  */
  *     This symbol, if defined, indicates to the C program that
  *     the struct tm has a tm_zone field.
  */
+/* HAS_TM_TM_GMTOFF:
+ *     This symbol, if defined, indicates to the C program that
+ *     the struct tm has a tm_gmtoff field.
+ */
 #define I_TIME         /**/
 /*#define I_SYS_TIME           / **/
 /*#define I_SYS_TIME_KERNEL            / **/
 /*#define HAS_TM_TM_ZONE               / **/
+/*#define HAS_TM_TM_GMTOFF     / **/
 
 /* I_USTAT:
  *     This symbol, if defined, indicates that <ustat.h> exists and
index ef28911..e1ad46a 100755 (executable)
@@ -218,6 +218,7 @@ d_mkstemps='undef'
 d_mktime='undef'
 d_mmap='undef'
 d_modfl='undef'
+d_modflproto='undef'
 d_modfl_pow32_bug='undef'
 d_mprotect='undef'
 d_msg='undef'
@@ -234,6 +235,7 @@ d_msgsnd='undef'
 d_msync='undef'
 d_munmap='undef'
 d_mymalloc='undef'
+d_nanosleep='undef'
 d_nice='undef'
 d_nl_langinfo='undef'
 d_nv_preserves_uv='undef'
index 7999757..3e8d8b1 100644 (file)
@@ -232,7 +232,8 @@ XS(XS_UNIVERSAL_isa)
     if (SvGMAGICAL(sv))
        mg_get(sv);
 
-    if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
+    if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
+               || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
        XSRETURN_UNDEF;
 
     name = (char *)SvPV(ST(1),n_a);
@@ -258,7 +259,8 @@ XS(XS_UNIVERSAL_can)
     if (SvGMAGICAL(sv))
        mg_get(sv);
 
-    if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
+    if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
+               || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
        XSRETURN_UNDEF;
 
     name = (char *)SvPV(ST(1),n_a);
index 6f2d65f..4f71114 100644 (file)
@@ -77,9 +77,9 @@ the C<-d> options.
 The default name of the old configuration file is by default
 "libnet.cfg", unless otherwise specified using the -i option,
 C<-i oldfile>, and it is searched first from the current directory,
-and the from your module path.
+and then from your module path.
 
-The default name of new configuration file is "libnet.cfg", and by
+The default name of the new configuration file is "libnet.cfg", and by
 default it is written to the current directory, unless otherwise
 specified using the -o option, C<-o newfile>.
 
@@ -91,7 +91,7 @@ L<Net::Config>, L<Net::libnetFAQ>
 
 Graham Barr, the original Configure script of libnet.
 
-Jarkko Hietaniemi, conversion into libnet cfg for inclusion into Perl 5.8.
+Jarkko Hietaniemi, conversion into libnetcfg for inclusion into Perl 5.8.
 
 =cut
 
index f647b84..2ceffa7 100644 (file)
@@ -634,8 +634,8 @@ sub read_rc
        ## no RC file -- use this default.
        @default = split(/\n/,<<'--------INLINE_LITERAL_TEXT');
             magic: 32 : $H =~ m/[\x00-\x06\x10-\x1a\x1c-\x1f\x80\xff]{2}/
-           option: -skip '.a .COM .elc .EXE .gz .o .pbm .xbm .dvi'
-           option: -iskip '.tarz .zip .z .lzh .jpg .jpeg .gif .uu'
+           option: -skip '.a .elc .gz .o .pbm .xbm .dvi'
+           option: -iskip '.com .exe .lib .pdb .tarz .zip .z .lzh .jpg .jpeg .gif .uu'
            <!~> option: -skip '~ #'
 --------INLINE_LITERAL_TEXT
     }
index 849f13b..e06049b 100644 (file)
@@ -444,7 +444,7 @@ DllExport int win32_async_check(pTHX);
                                       lpw, wlen, (LPSTR)lpa, nChars,NULL,NULL))
 #define W2AHELPER(lpw, lpa, nChars)    W2AHELPER_LEN(lpw, -1, lpa, nChars)
 
-#define USING_WIDE() (PL_widesyscalls && PerlEnv_os_id() == VER_PLATFORM_WIN32_NT)
+#define USING_WIDE() (0)
 
 #ifdef USE_ITHREADS
 #  define PERL_WAIT_FOR_CHILDREN \
index 7d107c6..e116ac1 100644 (file)
@@ -397,7 +397,7 @@ struct interp_intern {
                                       lpw, wlen, (LPSTR)lpa, nChars,NULL,NULL))
 #define W2AHELPER(lpw, lpa, nChars)    W2AHELPER_LEN(lpw, -1, lpa, nChars)
 
-#define USING_WIDE() (PL_widesyscalls && PerlEnv_os_id() == VER_PLATFORM_WIN32_NT)
+#define USING_WIDE() (0)
 
 #ifdef USE_ITHREADS
 #  define PERL_WAIT_FOR_CHILDREN \