From: Gurusamy Sarathy Date: Tue, 14 Jul 1998 07:34:45 +0000 (+0000) Subject: merge changes#1423,1465 from maintbranch; checkin two missed files X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=eec2d3df379716e72d6e7a8316fcb65b89fb13eb;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 --- 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 is -not implemented on your system, returns C. Remember that a -umask is a number, usually given in octal; it is I a string of octal -digits. See also L, if all you have is a string. +If EXPR is omitted, merely returns the current umask. + +If C is not implemented on your system and you are trying to +restrict access for I (i.e., (EXPR & 0700) > 0), produces a +fatal error at run time. If C is not implemented and you are +not trying to restrict access for yourself, returns C. + +Remember that a umask is a number, usually given in octal; it is I a +string of octal digits. See also L, if all you have is a string. =item undef EXPR diff --git a/pod/perlop.pod b/pod/perlop.pod index 96427b2..d9cfccf 100644 --- 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 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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;