merge changes#1423,1465 from maintbranch; checkin two missed files

from earlier changes#1461,1478

p4raw-link: @1478 on //depot/perl: 1d84e8dfc14d5303f4e9e567bd263f6b4d88e584
p4raw-link: @1465 on //depot/maint-5.004/perl: 5c79ff06c1b2e0ce9610857baca341a322e96624
p4raw-link: @1461 on //depot/perl: 8782bef2aa2ca158fdd0d7436e68ae3ac2b01ff7
p4raw-link: @1423 on //depot/maint-5.004/perl: 9b114077a050865568261ebf91069aa7983019c3

p4raw-id: //depot/perl@1488

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index e196784..26289b7 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2609,8 +2609,13 @@ certain type.  Arrays must be @NAME or C<@{EXPR}>.  Hashes must be
 
 =item umask: argument is missing initial 0
 
-(W) A umask of 222 is incorrect.  It should be 0222, because octal literals
-always start with 0 in Perl, as in C.
+(W) A umask of 222 is incorrect.  It should be 0222, because octal
+literals always start with 0 in Perl, as in C.
+
+=item umask not implemented
+
+(F) Your machine doesn't implement the umask function and you tried
+to use it to restrict permissions for yourself (EXPR & 0700).
 
 =item Unable to create sub named "%s"
 

diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index 9692dd4..abef92e 100644 (file)
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -4068,10 +4068,15 @@ If EXPR is omitted, uses C<$_>.
 =item umask
 
 Sets the umask for the process to EXPR and returns the previous value.
-If EXPR is omitted, merely returns the current umask.  If C<umask(2)> is
-not implemented on your system, returns C<undef>.  Remember that a
-umask is a number, usually given in octal; it is I<not> a string of octal
-digits.  See also L</oct>, if all you have is a string.
+If EXPR is omitted, merely returns the current umask.
+
+If C<umask(2)> is not implemented on your system and you are trying to
+restrict access for I<yourself> (i.e., (EXPR & 0700) > 0), produces a
+fatal error at run time.  If C<umask(2)> is not implemented and you are
+not trying to restrict access for yourself, returns C<undef>.
+
+Remember that a umask is a number, usually given in octal; it is I<not> a
+string of octal digits.  See also L</oct>, if all you have is a string.
 
 =item undef EXPR
 

diff --git a/pod/perlop.pod b/pod/perlop.pod
index 96427b2..d9cfccf 100644 (file)
--- a/pod/perlop.pod
+++ b/pod/perlop.pod
@@ -624,6 +624,7 @@ the same character fore and aft, but the 4 sorts of brackets
        ``      qx{}          Command             yes (unless '' is delimiter)
                qw{}         Word list            no
        //       m{}       Pattern match          yes
+               qr{}          Pattern             yes
                 s{}{}      Substitution          yes
                tr{}{}    Transliteration         no (but see below)
 
@@ -909,6 +910,34 @@ A double-quoted, interpolated string.
                if /(tcl|rexx|python)/;      # :-)
     $baz = "\n";               # a one-character string
 
+=item qr/STRING/imosx
+
+A string which is (possibly) interpolated and then compiled as a
+regular expression. The result may be used as a pattern in a match
+
+    $re = qr/$pattern/;
+    $string =~ /$re/;
+
+Options are:
+
+    i  Do case-insensitive pattern matching.
+    m  Treat string as multiple lines.
+    o  Compile pattern only once.
+    s  Treat string as single line.
+    x  Use extended regular expressions.
+
+The benefit from this is that the pattern is compiled into an internal
+representation by the C<qr//> operator and not by the match operator.
+
+    foreach $pattern (@pattern_list) {
+       my $re = qr/$pattern/;
+       foreach $line (@lines) {
+           if($line =~ /$re/) {
+               do_something($line);
+           }
+       }
+    }
+
 =item qx/STRING/
 
 =item `STRING`

diff --git a/pp_sys.c b/pp_sys.c
index 16e39e2..fe75220 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -499,6 +499,11 @@ PP(pp_umask)
     TAINT_PROPER("umask");
     XPUSHi(anum);
 #else
+    /* Only DIE if trying to restrict permissions on `user' (self).
+     * Otherwise it's harmless and more useful to just return undef
+     * since 'group' and 'other' concepts probably don't exist here. */
+    if (MAXARG >= 1 && (POPi & 0700))
+       DIE("umask not implemented");
     XPUSHs(&sv_undef);
 #endif
     RETURN;
@@ -1267,7 +1272,7 @@ PP(pp_sysread)
 #ifdef HAS_SOCKET
     if (op->op_type == OP_RECV) {
        char namebuf[MAXPATHLEN];
-#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
+#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE)
        bufsize = sizeof (struct sockaddr_in);
 #else
        bufsize = sizeof namebuf;
@@ -1761,18 +1766,47 @@ PP(pp_bind)
 {
     djSP;
 #ifdef HAS_SOCKET
+#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
+    extern GETPRIVMODE();
+    extern GETUSERMODE();
+#endif
     SV *addrsv = POPs;
     char *addr;
     GV *gv = (GV*)POPs;
     register IO *io = GvIOn(gv);
     STRLEN len;
+    int bind_ok = 0;
+#ifdef MPE
+    int mpeprivmode = 0;
+#endif
 
     if (!io || !IoIFP(io))
        goto nuts;
 
     addr = SvPV(addrsv, len);
     TAINT_PROPER("bind");
-    if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
+#ifdef MPE /* Deal with MPE bind() peculiarities */
+    if (((struct sockaddr *)addr)->sa_family == AF_INET) {
+        /* The address *MUST* stupidly be zero. */
+        ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
+        /* PRIV mode is required to bind() to ports < 1024. */
+        if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
+            ((struct sockaddr_in *)addr)->sin_port > 0) {
+            GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
+           mpeprivmode = 1;
+       }
+    }
+#endif /* MPE */
+    if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
+                     (struct sockaddr *)addr, len) >= 0)
+       bind_ok = 1;
+
+#ifdef MPE /* Switch back to USER mode */
+    if (mpeprivmode)
+       GETUSERMODE();
+#endif /* MPE */
+
+    if (bind_ok)
        RETPUSHYES;
     else
        RETPUSHUNDEF;

diff --git a/t/TEST b/t/TEST
index a302e66..05ee168 100755 (executable)
--- a/t/TEST
+++ b/t/TEST
@@ -17,7 +17,7 @@ chdir 't' if -f 't/TEST';
 die "You need to run \"make test\" first to set things up.\n"
   unless -e 'perl' or -e 'perl.exe';
 
-#$ENV{PERL_DESTRUCT_LEVEL} = '2';
+$ENV{PERL_DESTRUCT_LEVEL} = 2; # check leakage for embedders
 $ENV{EMXSHELL} = 'sh';        # For OS/2
 
 if ($#ARGV == -1) {

diff --git a/t/lib/thread.t b/t/lib/thread.t
index 853fa39..ae0a16e 100755 (executable)
--- a/t/lib/thread.t
+++ b/t/lib/thread.t
@@ -8,6 +8,7 @@ BEGIN {
        print "1..0\n";
        exit 0;
     }
+    $ENV{PERL_DESTRUCT_LEVEL} = 0;     # XXX known trouble with global destruction
 }
 $| = 1;
 print "1..12\n";

diff --git a/t/op/local.t b/t/op/local.t
index 82a5cb9..f8c037d 100755 (executable)
--- a/t/op/local.t
+++ b/t/op/local.t
@@ -4,6 +4,8 @@
 
 print "1..58\n";
 
+$ENV{PERL_DESTRUCT_LEVEL} = 0; # XXX known to leaks scalars
+
 sub foo {
     local($a, $b) = @_;
     local($c, $d);

diff --git a/t/op/pat.t b/t/op/pat.t
index 46d2b91..cbd5f89 100755 (executable)
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -14,6 +14,8 @@ BEGIN {
 }
 eval 'use Config';          #  Defaults assumed if this fails
 
+$ENV{PERL_DESTRUCT_LEVEL} = 0; # XXX known to leaks scalars
+
 $x = "abc\ndef\n";
 
 if ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";}

diff --git a/t/op/regexp.t b/t/op/regexp.t
index 244ed4a..4ebb8c0 100755 (executable)
--- a/t/op/regexp.t
+++ b/t/op/regexp.t
@@ -1,5 +1,7 @@
 #!./perl
 
+$ENV{PERL_DESTRUCT_LEVEL} = 0; # XXX known to leaks scalars
+
 # The tests are in a separate file 't/op/re_tests'.
 # Each line in that file is a separate test.
 # There are five columns, separated by tabs.

diff --git a/t/op/substr.t b/t/op/substr.t
index 87efcb4..fe53f01 100755 (executable)
--- a/t/op/substr.t
+++ b/t/op/substr.t
@@ -2,6 +2,8 @@
 
 print "1..106\n";
 
+$ENV{PERL_DESTRUCT_LEVEL} = 0; # XXX known to leaks scalars
+
 #P = start of string  Q = start of substr  R = end of substr  S = end of string
 
 $a = 'abcdefxyz';

diff --git a/t/op/vec.t b/t/op/vec.t
index 7117144..5ae2247 100755 (executable)
--- a/t/op/vec.t
+++ b/t/op/vec.t
@@ -4,6 +4,8 @@
 
 print "1..15\n";
 
+$ENV{PERL_DESTRUCT_LEVEL} = 0; # XXX known to leaks scalars
+
 print vec($foo,0,1) == 0 ? "ok 1\n" : "not ok 1\n";
 print length($foo) == 0 ? "ok 2\n" : "not ok 2\n";
 vec($foo,0,1) = 1;