diff options
author | Charles Bailey <bailey@newman.upenn.edu> | 2000-05-23 23:35:13 +0000 |
---|---|---|
committer | bailey <bailey@newman.upenn.edu> | 2000-05-23 23:35:13 +0000 |
commit | ee8c7f5465f003860e2347a2946abacac39bd9b9 (patch) | |
tree | fb05d3d164ae556f95f63a324d3fbb66c4a36517 /ext | |
parent | 099f76bb8eab859fbb7b90260152c1ead1bf3022 (diff) | |
download | perl-ee8c7f5465f003860e2347a2946abacac39bd9b9.tar.gz |
Resync with mainline prior to post-5.6.0 updates
p4raw-id: //depot/vmsperl@6111
Diffstat (limited to 'ext')
35 files changed, 386 insertions, 228 deletions
diff --git a/ext/B/B/Bblock.pm b/ext/B/B/Bblock.pm index b914bc661b..fe7fc52139 100644 --- a/ext/B/B/Bblock.pm +++ b/ext/B/B/Bblock.pm @@ -169,7 +169,9 @@ B::Bblock - Walk basic blocks =head1 DESCRIPTION -See F<ext/B/README>. +This module is used by the B::CC back end. It walks "basic blocks". +A basic block is a series of operations which is known to execute from +start to finish, with no possiblity of branching or halting. =head1 AUTHOR diff --git a/ext/B/B/Bytecode.pm b/ext/B/B/Bytecode.pm index 27003b6bd0..941a818f6b 100644 --- a/ext/B/B/Bytecode.pm +++ b/ext/B/B/Bytecode.pm @@ -654,8 +654,8 @@ sub bytecompile_main { warn "done main program, now walking symbol table\n" if $debug_bc; my ($pack, %exclude); foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS strict vars - FileHandle Exporter Carp UNIVERSAL IO Fcntl Symbol - SelectSaver blib Cwd)) + FileHandle Exporter Carp UNIVERSAL IO Fcntl Symbol warnings + attributes File::Spec SelectSaver blib Cwd)) { $exclude{$pack."::"} = 1; } diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm index cd53c112d8..b6e1097593 100644 --- a/ext/B/B/Deparse.pm +++ b/ext/B/B/Deparse.pm @@ -1,5 +1,5 @@ # B::Deparse.pm -# Copyright (c) 1998, 1999 Stephen McCamant. All rights reserved. +# Copyright (c) 1998, 1999, 2000 Stephen McCamant. All rights reserved. # This module is free software; you can redistribute and/or modify # it under the same terms as Perl itself. @@ -8,7 +8,6 @@ package B::Deparse; use Carp 'cluck', 'croak'; -use Config; use B qw(class main_root main_start main_cv svref_2object opnumber OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL @@ -17,7 +16,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber SVf_IOK SVf_NOK SVf_ROK SVf_POK PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED); -$VERSION = 0.59; +$VERSION = 0.591; use strict; # Changes between 0.50 and 0.51: @@ -252,17 +251,17 @@ sub walk_sub { walk_tree($op, sub { my $op = shift; if ($op->name eq "gv") { - my $gv = $self->maybe_padgv($op); + my $gv = $self->gv_or_padgv($op); if ($op->next->name eq "entersub") { - next if $self->{'subs_done'}{$$gv}++; - next if class($gv->CV) eq "SPECIAL"; + return if $self->{'subs_done'}{$$gv}++; + return if class($gv->CV) eq "SPECIAL"; $self->todo($gv, $gv->CV, 0); $self->walk_sub($gv->CV); } elsif ($op->next->name eq "enterwrite" or ($op->next->name eq "rv2gv" and $op->next->next->name eq "enterwrite")) { - next if $self->{'forms_done'}{$$gv}++; - next if class($gv->FORM) eq "SPECIAL"; + return if $self->{'forms_done'}{$$gv}++; + return if class($gv->FORM) eq "SPECIAL"; $self->todo($gv, $gv->FORM, 1); $self->walk_sub($gv->FORM); } @@ -378,7 +377,7 @@ sub compile { while (scalar(@{$self->{'subs_todo'}})) { push @text, $self->next_todo; } - print indent(join("", @text)), "\n" if @text; + print $self->indent(join("", @text)), "\n" if @text; } } @@ -1653,6 +1652,13 @@ sub pp_list { } } +sub is_ifelse_cont { + my $op = shift; + return ($op->name eq "null" and class($op) eq "UNOP" + and $op->first->name =~ /^(and|cond_expr)$/ + and is_scope($op->first->first->sibling)); +} + sub pp_cond_expr { my $self = shift; my($op, $cx) = @_; @@ -1660,36 +1666,34 @@ sub pp_cond_expr { my $true = $cond->sibling; my $false = $true->sibling; my $cuddle = $self->{'cuddle'}; - unless ($cx == 0 and is_scope($true) and is_scope($false)) { + unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and + (is_scope($false) || is_ifelse_cont($false))) { $cond = $self->deparse($cond, 8); $true = $self->deparse($true, 8); $false = $self->deparse($false, 8); return $self->maybe_parens("$cond ? $true : $false", $cx, 8); - } + } + $cond = $self->deparse($cond, 1); $true = $self->deparse($true, 0); - if ($false->name eq "lineseq") { # braces w/o scope => elsif - my $head = "if ($cond) {\n\t$true\n\b}"; - my @elsifs; - while (!null($false) and $false->name eq "lineseq") { - my $newop = $false->first->sibling->first; - my $newcond = $newop->first; - my $newtrue = $newcond->sibling; - $false = $newtrue->sibling; # last in chain is OP_AND => no else - $newcond = $self->deparse($newcond, 1); - $newtrue = $self->deparse($newtrue, 0); - push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}"; - } - if (!null($false)) { - $false = $cuddle . "else {\n\t" . - $self->deparse($false, 0) . "\n\b}\cK"; - } else { - $false = "\cK"; - } - return $head . join($cuddle, "", @elsifs) . $false; + my $head = "if ($cond) {\n\t$true\n\b}"; + my @elsifs; + while (!null($false) and is_ifelse_cont($false)) { + my $newop = $false->first; + my $newcond = $newop->first; + my $newtrue = $newcond->sibling; + $false = $newtrue->sibling; # last in chain is OP_AND => no else + $newcond = $self->deparse($newcond, 1); + $newtrue = $self->deparse($newtrue, 0); + push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}"; + } + if (!null($false)) { + $false = $cuddle . "else {\n\t" . + $self->deparse($false, 0) . "\n\b}\cK"; + } else { + $false = "\cK"; } - $false = $self->deparse($false, 0); - return "if ($cond) {\n\t$true\n\b}${cuddle}else {\n\t$false\n\b}\cK"; + return $head . join($cuddle, "", @elsifs) . $false; } sub pp_leaveloop { @@ -1780,7 +1784,7 @@ sub pp_leaveloop { if (is_state $state) { $expr = $self->deparse($state, 0); $state = $state->sibling; - last if null $kid; + last if null $state; } $expr .= $self->deparse($state, 0); push @exprs, $expr if $expr; @@ -1814,7 +1818,7 @@ sub pp_null { } elsif ($op->first->name eq "enter") { return $self->pp_leave($op, $cx); } elsif ($op->targ == OP_STRINGIFY) { - return $self->dquote($op); + return $self->dquote($op, $cx); } elsif (!null($op->first->sibling) and $op->first->sibling->name eq "readline" and $op->first->sibling->flags & OPf_STACKED) { @@ -1879,37 +1883,34 @@ sub pp_threadsv { return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]); } -sub maybe_padgv { +sub gv_or_padgv { my $self = shift; my $op = shift; - my $gv; - if ($Config{useithreads}) { - $gv = $self->padval($op->padix); - } - else { - $gv = $op->gv; + if (class($op) eq "PADOP") { + return $self->padval($op->padix); + } else { # class($op) eq "SVOP" + return $op->gv; } - return $gv; } sub pp_gvsv { my $self = shift; my($op, $cx) = @_; - my $gv = $self->maybe_padgv($op); + my $gv = $self->gv_or_padgv($op); return $self->maybe_local($op, $cx, "\$" . $self->gv_name($gv)); } sub pp_gv { my $self = shift; my($op, $cx) = @_; - my $gv = $self->maybe_padgv($op); + my $gv = $self->gv_or_padgv($op); return $self->gv_name($gv); } sub pp_aelemfast { my $self = shift; my($op, $cx) = @_; - my $gv = $self->maybe_padgv($op); + my $gv = $self->gv_or_padgv($op); return "\$" . $self->gv_name($gv) . "[" . $op->private . "]"; } @@ -2220,7 +2221,7 @@ sub pp_entersub { $amper = "&"; $kid = "{" . $self->deparse($kid, 0) . "}"; } elsif ($kid->first->name eq "gv") { - my $gv = $self->maybe_padgv($kid->first); + my $gv = $self->gv_or_padgv($kid->first); if (class($gv->CV) ne "SPECIAL") { $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK; } @@ -2252,9 +2253,9 @@ sub pp_entersub { } else { if (defined $proto and $proto eq "") { return $kid; - } elsif ($proto eq "\$") { + } elsif (defined $proto and $proto eq "\$") { return $self->maybe_parens_func($kid, $args, $cx, 16); - } elsif ($proto or $simple) { + } elsif (defined($proto) && $proto or $simple) { return $self->maybe_parens_func($kid, $args, $cx, 5); } else { return "$kid(" . $args . ")"; @@ -2418,7 +2419,7 @@ sub pp_backtick { sub dquote { my $self = shift; - my($op, $cx) = shift; + my($op, $cx) = @_; my $kid = $op->first->sibling; # skip ex-stringify, pushmark return $self->deparse($kid, $cx) if $self->{'unquote'}; $self->maybe_targmy($kid, $cx, diff --git a/ext/B/B/Disassembler.pm b/ext/B/B/Disassembler.pm index d054a2d164..212532b9ce 100644 --- a/ext/B/B/Disassembler.pm +++ b/ext/B/B/Disassembler.pm @@ -31,6 +31,13 @@ sub GET_U16 { return unpack("n", $str); } +sub GET_NV { + my $fh = shift; + my $str = $fh->readn(8); + croak "reached EOF while reading NV" unless length($str) == 8; + return unpack("N", $str); +} + sub GET_U32 { my $fh = shift; my $str = $fh->readn(4); diff --git a/ext/B/B/Stash.pm b/ext/B/B/Stash.pm index 0a3543eed4..b9b828f505 100644 --- a/ext/B/B/Stash.pm +++ b/ext/B/B/Stash.pm @@ -6,7 +6,7 @@ BEGIN { %Seen = %INC } CHECK { my @arr=scan($main::{"main::"}); - @arr=map{s/\:\:$//;$_;} @arr; + @arr=map{s/\:\:$//;$_ eq "<none>"?():$_;} @arr; print "-umain,-u", join (",-u",@arr) ,"\n"; } sub scan{ diff --git a/ext/DB_File/Changes b/ext/DB_File/Changes index 95eb487e56..ad54382d63 100644 --- a/ext/DB_File/Changes +++ b/ext/DB_File/Changes @@ -291,3 +291,8 @@ to David Harris for spotting the underlying problem, contributing the updates to the documentation and writing DB_File::Lock (available on CPAN). + +1.73 27th April 2000 + + * Added support in version.c for building with threaded Perl. + diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm index 00b24b90e6..a1ec0e6362 100644 --- a/ext/DB_File/DB_File.pm +++ b/ext/DB_File/DB_File.pm @@ -1,8 +1,8 @@ # DB_File.pm -- Perl 5 interface to Berkeley DB # # written by Paul Marquess (Paul.Marquess@btinternet.com) -# last modified 16th January 2000 -# version 1.72 +# last modified 26th April 2000 +# version 1.73 # # Copyright (c) 1995-2000 Paul Marquess. All rights reserved. # This program is free software; you can redistribute it and/or @@ -147,7 +147,7 @@ use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO use Carp; -$VERSION = "1.72" ; +$VERSION = "1.73" ; #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; $DB_BTREE = new DB_File::BTREEINFO ; diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs index 2b76bab722..cb8fd80385 100644 --- a/ext/DB_File/DB_File.xs +++ b/ext/DB_File/DB_File.xs @@ -3,8 +3,8 @@ DB_File.xs -- Perl 5 interface to Berkeley DB written by Paul Marquess <Paul.Marquess@btinternet.com> - last modified 16th January 2000 - version 1.72 + last modified 27th April 2000 + version 1.73 All comments/suggestions/problems are welcome @@ -82,6 +82,7 @@ Support for Berkeley DB 2/3's backward compatability mode. Rewrote push 1.72 - No change to DB_File.xs + 1.73 - No change to DB_File.xs */ diff --git a/ext/DB_File/version.c b/ext/DB_File/version.c index f8c6cac9af..f3e2c947c8 100644 --- a/ext/DB_File/version.c +++ b/ext/DB_File/version.c @@ -4,7 +4,7 @@ written by Paul Marquess <Paul.Marquess@btinternet.com> last modified 16th January 2000 - version 1.72 + version 1.73 All comments/suggestions/problems are welcome @@ -16,6 +16,7 @@ 1.71 - Support for Berkeley DB version 3. Support for Berkeley DB 2/3's backward compatability mode. 1.72 - No change. + 1.73 - Added support for threading */ @@ -28,6 +29,9 @@ void __getBerkeleyDBInfo() { +#ifdef dTHX + dTHX; +#endif SV * version_sv = perl_get_sv("DB_File::db_version", GV_ADD|GV_ADDMULTI) ; SV * ver_sv = perl_get_sv("DB_File::db_ver", GV_ADD|GV_ADDMULTI) ; SV * compat_sv = perl_get_sv("DB_File::db_185_compat", GV_ADD|GV_ADDMULTI) ; diff --git a/ext/Data/Dumper/Dumper.xs b/ext/Data/Dumper/Dumper.xs index 990ea74699..bb606f42ca 100644 --- a/ext/Data/Dumper/Dumper.xs +++ b/ext/Data/Dumper/Dumper.xs @@ -584,8 +584,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, if (SvIOK(val)) { STRLEN len; - i = SvIV(val); - (void) sprintf(tmpbuf, "%"IVdf, (IV)i); + (void) sprintf(tmpbuf, "%"IVdf, SvIV(val)); len = strlen(tmpbuf); sv_catpvn(retval, tmpbuf, len); } diff --git a/ext/Devel/Peek/Peek.xs b/ext/Devel/Peek/Peek.xs index e7f5746803..9837e9ceb2 100644 --- a/ext/Devel/Peek/Peek.xs +++ b/ext/Devel/Peek/Peek.xs @@ -127,7 +127,7 @@ DeadCode(pTHX) #define _CvGV(cv) \ (SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV) \ - ? (SV*)CvGV((CV*)SvRV(cv)) : &PL_sv_undef) + ? SvREFCNT_inc(CvGV((CV*)SvRV(cv))) : &PL_sv_undef) MODULE = Devel::Peek PACKAGE = Devel::Peek diff --git a/ext/DynaLoader/DynaLoader_pm.PL b/ext/DynaLoader/DynaLoader_pm.PL index e0eb604c73..55b8eca727 100644 --- a/ext/DynaLoader/DynaLoader_pm.PL +++ b/ext/DynaLoader/DynaLoader_pm.PL @@ -114,9 +114,9 @@ push(@dl_library_path, split(/:/, $ENV{LD_LIBRARY_PATH})) } # No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. +# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) && - !defined(&dl_load_file); - + !defined(&dl_error); if ($dl_debug) { print STDERR "DynaLoader.pm loaded (@INC, @dl_library_path)\n"; diff --git a/ext/DynaLoader/XSLoader_pm.PL b/ext/DynaLoader/XSLoader_pm.PL index 8cdfd63425..7657410d46 100644 --- a/ext/DynaLoader/XSLoader_pm.PL +++ b/ext/DynaLoader/XSLoader_pm.PL @@ -37,10 +37,12 @@ print OUT ' my $dl_dlext = ', to_string($Config::Config{'dlext'}), ";\n" ; print OUT <<'EOT'; -# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. package DynaLoader; + +# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. +# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) && - !defined(&dl_load_file); + !defined(&dl_error); package XSLoader; 1; # End of main code diff --git a/ext/DynaLoader/dl_aix.xs b/ext/DynaLoader/dl_aix.xs index 35242ed652..d6acc689af 100644 --- a/ext/DynaLoader/dl_aix.xs +++ b/ext/DynaLoader/dl_aix.xs @@ -36,6 +36,8 @@ #include <sys/types.h> #include <sys/ldr.h> #include <a.out.h> +#undef FREAD +#undef FWRITE #include <ldfcn.h> #ifdef USE_64_BIT_ALL @@ -87,6 +89,8 @@ /* If using PerlIO, redefine these macros from <ldfcn.h> */ #ifdef USE_PERLIO +#undef FSEEK +#undef FREAD #define FSEEK(ldptr,o,p) PerlIO_seek(IOPTR(ldptr),(p==BEGINNING)?(OFFSET(ldptr)+o):o,p) #define FREAD(p,s,n,ldptr) PerlIO_read(IOPTR(ldptr),p,s*n) #endif @@ -116,8 +120,8 @@ typedef struct Module { } Module, *ModulePtr; /* - * We keep a list of all loaded modules to be able to call the fini - * handlers at atexit() time. + * We keep a list of all loaded modules to be able to reference count + * duplicate dlopen's. */ static ModulePtr modList; /* XXX threaded */ @@ -130,7 +134,7 @@ static int errvalid; /* XXX threaded */ static void caterr(char *); static int readExports(ModulePtr); -static void terminate(void); +static void *findMain(void); static char *strerror_failed = "(strerror failed)"; static char *strerror_r_failed = "(strerror_r failed)"; @@ -197,15 +201,15 @@ void *dlopen(char *path, int mode) { dTHX; register ModulePtr mp; - static int inited; /* XXX threaded */ + static void *mainModule; /* XXX threaded */ /* * Upon the first call register a terminate handler that will * close all libraries. */ - if (!inited) { - inited++; - atexit(terminate); + if (mainModule == NULL) { + if ((mainModule = findMain()) == NULL) + return NULL; } /* * Scan the list of modules if have the module already loaded. @@ -273,9 +277,13 @@ void *dlopen(char *path, int mode) /* * Assume anonymous exports come from the module this dlopen * is linked into, that holds true as long as dlopen and all - * of the perl core are in the same shared object. + * of the perl core are in the same shared object. Also bind + * against the main part, in the case a perl is not the main + * part, e.g mod_perl as DSO in Apache so perl modules can + * also reference Apache symbols. */ - if (loadbind(0, (void *)dlopen, mp->entry) == -1) { + if (loadbind(0, (void *)dlopen, mp->entry) == -1 || + loadbind(0, mainModule, mp->entry)) { int saverrno = errno; dlclose(mp); @@ -393,12 +401,6 @@ int dlclose(void *handle) return result; } -static void terminate(void) -{ - while (modList) - dlclose(modList); -} - /* Added by Wayne Scott * This is needed because the ldopen system call calls * calloc to allocated a block of date. The ldclose call calls free. @@ -590,6 +592,52 @@ static int readExports(ModulePtr mp) return 0; } +/* + * Find the main modules entry point. This is used as export pointer + * for loadbind() to be able to resolve references to the main part. + */ +static void * findMain(void) +{ + struct ld_info *lp; + char *buf; + int size = 4*1024; + int i; + void *ret; + + if ((buf = safemalloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "findMain: "); + strerrorcat(errbuf, errno); + return NULL; + } + while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { + safefree(buf); + size += 4*1024; + if ((buf = safemalloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "findMain: "); + strerrorcat(errbuf, errno); + return NULL; + } + } + if (i == -1) { + errvalid++; + strcpy(errbuf, "findMain: "); + strerrorcat(errbuf, errno); + safefree(buf); + return NULL; + } + /* + * The first entry is the main module. The entry point + * returned by load() does actually point to the data + * segment origin. + */ + lp = (struct ld_info *)buf; + ret = lp->ldinfo_dataorg; + safefree(buf); + return ret; +} + /* dl_dlopen.xs * * Platform: SunOS/Solaris, possibly others which use dlopen. @@ -642,6 +690,17 @@ dl_load_file(filename, flags=0) else sv_setiv( ST(0), PTR2IV(RETVAL) ); +int +dl_unload_file(libref) + void * libref + CODE: + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_unload_file(%lx):\n", libref)); + RETVAL = (dlclose(libref) == 0 ? 1 : 0); + if (!RETVAL) + SaveError(aTHX_ "%s", dlerror()) ; + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " retval = %d\n", RETVAL)); + OUTPUT: + RETVAL void * dl_find_symbol(libhandle, symbolname) diff --git a/ext/DynaLoader/dlutils.c b/ext/DynaLoader/dlutils.c index 5c6bbea1ac..9d88f5fdad 100644 --- a/ext/DynaLoader/dlutils.c +++ b/ext/DynaLoader/dlutils.c @@ -21,7 +21,7 @@ static HV *dl_loaded_files = Nullhv; /* only needed on a few systems */ #ifdef DEBUGGING -static int dl_debug = 0; /* value copied from $DynaLoader::dl_error */ +static int dl_debug = 0; /* value copied from $DynaLoader::dl_debug */ #define DLDEBUG(level,code) if (dl_debug>=level) { code; } #else #define DLDEBUG(level,code) @@ -69,7 +69,9 @@ dl_generic_private_init(pTHXo) /* called by dl_*.xs dl_private_init() */ if (!dl_loaded_files) dl_loaded_files = newHV(); /* provide cache for dl_*.xs if needed */ #endif +#ifdef DL_UNLOAD_ALL_AT_EXIT call_atexit(&dl_unload_all_files, (void*)0); +#endif } diff --git a/ext/Fcntl/Fcntl.pm b/ext/Fcntl/Fcntl.pm index 171538e583..92103a1eaf 100644 --- a/ext/Fcntl/Fcntl.pm +++ b/ext/Fcntl/Fcntl.pm @@ -118,11 +118,15 @@ $VERSION = "1.03"; O_NDELAY O_NOCTTY O_NOFOLLOW + O_NOINHERIT O_NONBLOCK + O_RANDOM + O_RAW O_RDONLY O_RDWR O_RSRC O_RSYNC + O_SEQUENTIAL O_SHLOCK O_SYNC O_TEMPORARY diff --git a/ext/Fcntl/Fcntl.xs b/ext/Fcntl/Fcntl.xs index 8d4a073658..b597e03c1a 100644 --- a/ext/Fcntl/Fcntl.xs +++ b/ext/Fcntl/Fcntl.xs @@ -46,7 +46,7 @@ constant(char *name, int arg) errno = 0; switch (*name) { case '_': - if (strEQ(name, "_S_IFMT")) /* Yes, _S_IFMT. */ + if (strEQ(name, "_S_IFMT")) /* Yes, on name _S_IFMT return S_IFMT. */ #ifdef S_IFMT return S_IFMT; #else @@ -476,12 +476,30 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "O_NOINHERIT")) +#ifdef O_NOINHERIT + return O_NOINHERIT; +#else + goto not_there; +#endif if (strEQ(name, "O_NONBLOCK")) #ifdef O_NONBLOCK return O_NONBLOCK; #else goto not_there; #endif + if (strEQ(name, "O_RANDOM")) +#ifdef O_RANDOM + return O_RANDOM; +#else + goto not_there; +#endif + if (strEQ(name, "O_RAW")) +#ifdef O_RAW + return O_RAW; +#else + goto not_there; +#endif if (strEQ(name, "O_RDONLY")) #ifdef O_RDONLY return O_RDONLY; @@ -500,6 +518,12 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "O_SEQUENTIAL")) +#ifdef O_SEQUENTIAL + return O_SEQUENTIAL; +#else + goto not_there; +#endif if (strEQ(name, "O_SHLOCK")) #ifdef O_SHLOCK return O_SHLOCK; diff --git a/ext/File/Glob/Glob.pm b/ext/File/Glob/Glob.pm index 4b7e54b9e3..98ee34d57d 100644 --- a/ext/File/Glob/Glob.pm +++ b/ext/File/Glob/Glob.pm @@ -11,8 +11,12 @@ require AutoLoader; @ISA = qw(Exporter AutoLoader); +# NOTE: The glob() export is only here for compatibility with 5.6.0. +# csh_glob() should not be used directly, unless you know what you're doing. + @EXPORT_OK = qw( csh_glob + bsd_glob glob GLOB_ABEND GLOB_ALTDIRFUNC @@ -47,6 +51,7 @@ require AutoLoader; GLOB_QUOTE GLOB_TILDE glob + bsd_glob ) ], ); @@ -108,12 +113,18 @@ if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos|MacOS)$/) { # Autoload methods go after =cut, and are processed by the autosplit program. -sub glob { +sub bsd_glob { my ($pat,$flags) = @_; $flags = $DEFAULT_FLAGS if @_ < 2; return doglob($pat,$flags); } +# File::Glob::glob() is deprecated because its prototype is different from +# CORE::glob() (use bsd_glob() instead) +sub glob { + goto &bsd_glob; +} + ## borrowed heavily from gsar's File::DosGlob my %iter; my %entries; @@ -177,13 +188,13 @@ File::Glob - Perl extension for BSD glob routine =head1 SYNOPSIS use File::Glob ':glob'; - @list = glob('*.[ch]'); - $homedir = glob('~gnat', GLOB_TILDE | GLOB_ERR); + @list = bsd_glob('*.[ch]'); + $homedir = bsd_glob('~gnat', GLOB_TILDE | GLOB_ERR); if (GLOB_ERROR) { # an error occurred reading $homedir } - ## override the core glob (core glob() does this automatically + ## override the core glob (CORE::glob() does this automatically ## by default anyway, since v5.6.0) use File::Glob ':globally'; my @sources = <*.{c,h,y}> @@ -198,19 +209,27 @@ File::Glob - Perl extension for BSD glob routine =head1 DESCRIPTION -File::Glob implements the FreeBSD glob(3) routine, which is a superset -of the POSIX glob() (described in IEEE Std 1003.2 "POSIX.2"). The -glob() routine takes a mandatory C<pattern> argument, and an optional +File::Glob::bsd_glob() implements the FreeBSD glob(3) routine, which is +a superset of the POSIX glob() (described in IEEE Std 1003.2 "POSIX.2"). +bsd_glob() takes a mandatory C<pattern> argument, and an optional C<flags> argument, and returns a list of filenames matching the pattern, with interpretation of the pattern modified by the C<flags> -variable. The POSIX defined flags are: +variable. + +Since v5.6.0, Perl's CORE::glob() is implemented in terms of bsd_glob(). +Note that they don't share the same prototype--CORE::glob() only accepts +a single argument. Due to historical reasons, CORE::glob() will also +split its argument on whitespace, treating it as multiple patterns, +whereas bsd_glob() considers them as one pattern. + +The POSIX defined flags for bsd_glob() are: =over 4 =item C<GLOB_ERR> -Force glob() to return an error when it encounters a directory it -cannot open or read. Ordinarily glob() continues to find matches. +Force bsd_glob() to return an error when it encounters a directory it +cannot open or read. Ordinarily bsd_glob() continues to find matches. =item C<GLOB_MARK> @@ -220,18 +239,18 @@ appended. =item C<GLOB_NOCASE> By default, file names are assumed to be case sensitive; this flag -makes glob() treat case differences as not significant. +makes bsd_glob() treat case differences as not significant. =item C<GLOB_NOCHECK> -If the pattern does not match any pathname, then glob() returns a list +If the pattern does not match any pathname, then bsd_glob() returns a list consisting of only the pattern. If C<GLOB_QUOTE> is set, its effect is present in the pattern returned. =item C<GLOB_NOSORT> By default, the pathnames are sorted in ascending ASCII order; this -flag prevents that sorting (speeding up glob()). +flag prevents that sorting (speeding up bsd_glob()). =back @@ -277,7 +296,7 @@ interaction with the underlying C structures. =head1 DIAGNOSTICS -glob() returns a list of matching paths, possibly zero length. If an +bsd_glob() returns a list of matching paths, possibly zero length. If an error occurred, &File::Glob::GLOB_ERROR will be non-zero and C<$!> will be set. &File::Glob::GLOB_ERROR is guaranteed to be zero if no error occurred, or one of the following values otherwise: @@ -294,12 +313,12 @@ The glob was stopped because an error was encountered. =back -In the case where glob() has found some matching paths, but is -interrupted by an error, glob() will return a list of filenames B<and> +In the case where bsd_glob() has found some matching paths, but is +interrupted by an error, it will return a list of filenames B<and> set &File::Glob::ERROR. -Note that glob() deviates from POSIX and FreeBSD glob(3) behaviour by -not considering C<ENOENT> and C<ENOTDIR> as errors - glob() will +Note that bsd_glob() deviates from POSIX and FreeBSD glob(3) behaviour +by not considering C<ENOENT> and C<ENOTDIR> as errors - bsd_glob() will continue processing despite those errors, unless the C<GLOB_ERR> flag is set. @@ -311,10 +330,10 @@ Be aware that all filenames returned from File::Glob are tainted. =item * -If you want to use multiple patterns, e.g. C<glob "a* b*">, you should -probably throw them in a set as in C<glob "{a*,b*}>. This is because -the argument to glob isn't subjected to parsing by the C shell. Remember -that you can use a backslash to escape things. +If you want to use multiple patterns, e.g. C<bsd_glob "a* b*">, you should +probably throw them in a set as in C<bsd_glob "{a*,b*}">. This is because +the argument to bsd_glob() isn't subjected to parsing by the C shell. +Remember that you can use a backslash to escape things. =item * diff --git a/ext/IO/lib/IO/File.pm b/ext/IO/lib/IO/File.pm index 819b4b18e8..569c2800f8 100644 --- a/ext/IO/lib/IO/File.pm +++ b/ext/IO/lib/IO/File.pm @@ -113,9 +113,8 @@ use IO::Seekable; use File::Spec; require Exporter; -require DynaLoader; -@ISA = qw(IO::Handle IO::Seekable Exporter DynaLoader); +@ISA = qw(IO::Handle IO::Seekable Exporter); $VERSION = "1.08"; diff --git a/ext/IO/lib/IO/Poll.pm b/ext/IO/lib/IO/Poll.pm index 687664b9ab..70a3469edb 100644 --- a/ext/IO/lib/IO/Poll.pm +++ b/ext/IO/lib/IO/Poll.pm @@ -1,3 +1,4 @@ + # IO::Poll.pm # # Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. @@ -12,28 +13,31 @@ use Exporter (); our(@ISA, @EXPORT_OK, @EXPORT, $VERSION); @ISA = qw(Exporter); -$VERSION = "0.01"; +$VERSION = "0.05"; -@EXPORT = qw(poll); +@EXPORT = qw( POLLIN + POLLOUT + POLLERR + POLLHUP + POLLNVAL + ); @EXPORT_OK = qw( - POLLIN POLLPRI - POLLOUT POLLRDNORM POLLWRNORM POLLRDBAND POLLWRBAND POLLNORM - POLLERR - POLLHUP - POLLNVAL -); + ); +# [0] maps fd's to requested masks +# [1] maps fd's to returned masks +# [2] maps fd's to handles sub new { my $class = shift; - my $self = bless [{},{}], $class; + my $self = bless [{},{},{}], $class; $self; } @@ -42,20 +46,21 @@ sub mask { my $self = shift; my $io = shift; my $fd = fileno($io); - if(@_) { + if (@_) { my $mask = shift; - $self->[0]{$fd} ||= {}; if($mask) { - $self->[0]{$fd}{$io} = $mask; - } - else { + $self->[0]{$fd}{$io} = $mask; # the error events are always returned + $self->[1]{$fd} = 0; # output mask + $self->[2]{$io} = $io; # remember handle + } else { delete $self->[0]{$fd}{$io}; + delete $self->[1]{$fd} unless %{$self->[0]{$fd}}; + delete $self->[2]{$io}; } } - elsif(exists $self->[0]{$fd}{$io}) { + + return unless exists $self->[0]{$fd} and exists $self->[0]{$fd}{$io}; return $self->[0]{$fd}{$io}; - } - return; } @@ -64,13 +69,13 @@ sub poll { $self->[1] = {}; - my($fd,$ref); + my($fd,$mask,$iom); my @poll = (); - while(($fd,$ref) = each %{$self->[0]}) { - my $events = 0; - map { $events |= $_ } values %{$ref}; - push(@poll,$fd, $events); + while(($fd,$iom) = each %{$self->[0]}) { + $mask = 0; + $mask |= $_ for values(%$iom); + push(@poll,$fd => $mask); } my $ret = @poll ? _poll(defined($timeout) ? $timeout * 1000 : -1,@poll) : 0; @@ -80,8 +85,7 @@ sub poll { while(@poll) { my($fd,$got) = splice(@poll,0,2); - $self->[1]{$fd} = $got - if $got; + $self->[1]{$fd} = $got if $got; } return $ret; @@ -91,9 +95,8 @@ sub events { my $self = shift; my $io = shift; my $fd = fileno($io); - - exists $self->[1]{$fd} && exists $self->[0]{$fd}{$io} - ? $self->[1]{$fd} & $self->[0]{$fd}{$io} + exists $self->[1]{$fd} and exists $self->[0]{$fd}{$io} + ? $self->[1]{$fd} & ($self->[0]{$fd}{$io}|POLLHUP|POLLERR|POLLNVAL) : 0; } @@ -105,20 +108,16 @@ sub remove { sub handles { my $self = shift; - - return map { keys %$_ } values %{$self->[0]} - unless(@_); + return values %{$self->[2]} unless @_; my $events = shift || 0; my($fd,$ev,$io,$mask); my @handles = (); while(($fd,$ev) = each %{$self->[1]}) { - if($ev & $events) { - while(($io,$mask) = each %{$self->[0][$fd]}) { - push(@handles, $io) - if $events & $mask; - } + while (($io,$mask) = each %{$self->[0]{$fd}}) { + $mask |= POLLHUP|POLLERR|POLLNVAL; # must allow these + push @handles,$self->[2]{$io} if ($ev & $mask) & $events; } } return @handles; @@ -138,8 +137,8 @@ IO::Poll - Object interface to system poll call $poll = new IO::Poll; - $poll->mask($input_handle => POLLRDNORM | POLLIN | POLLHUP); - $poll->mask($output_handle => POLLWRNORM); + $poll->mask($input_handle => POLLIN); + $poll->mask($output_handle => POLLOUT); $poll->poll($timeout); diff --git a/ext/IO/lib/IO/Seekable.pm b/ext/IO/lib/IO/Seekable.pm index bfcfc139aa..e09d48b9bf 100644 --- a/ext/IO/lib/IO/Seekable.pm +++ b/ext/IO/lib/IO/Seekable.pm @@ -48,7 +48,10 @@ require 5.005_64; use Carp; use strict; our($VERSION, @EXPORT, @ISA); -use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); +use IO::Handle (); +# XXX we can't get these from IO::Handle or we'll get prototype +# mismatch warnings on C<use POSIX; use IO::File;> :-( +use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); require Exporter; @EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END); diff --git a/ext/IO/lib/IO/Select.pm b/ext/IO/lib/IO/Select.pm index 1d8cda6fbf..df92b04b74 100644 --- a/ext/IO/lib/IO/Select.pm +++ b/ext/IO/lib/IO/Select.pm @@ -7,10 +7,11 @@ package IO::Select; use strict; +use warnings::register; use vars qw($VERSION @ISA); require Exporter; -$VERSION = "1.13"; +$VERSION = "1.14"; @ISA = qw(Exporter); # This is only so we can do version checking @@ -129,9 +130,8 @@ sub has_exception sub has_error { - require Carp; - Carp::carp("Call to depreciated method 'has_error', use 'has_exception'") - if $^W; + warnings::warn("Call to depreciated method 'has_error', use 'has_exception'") + if warnings::enabled(); goto &has_exception; } diff --git a/ext/IO/lib/IO/Socket/INET.pm b/ext/IO/lib/IO/Socket/INET.pm index 27a3d4d847..c922bf35c9 100644 --- a/ext/IO/lib/IO/Socket/INET.pm +++ b/ext/IO/lib/IO/Socket/INET.pm @@ -34,6 +34,7 @@ sub new { sub _sock_info { my($addr,$port,$proto) = @_; + my $origport = $port; my @proto = (); my @serv = (); @@ -59,14 +60,14 @@ sub _sock_info { my $defport = $1 || undef; my $pnum = ($port =~ m,^(\d+)$,)[0]; - if ($port =~ m,\D,) { - unless (@serv = getservbyname($port, $proto[0] || "")) { - $@ = "Bad service '$port'"; - return; - } - } + @serv = getservbyname($port, $proto[0] || "") + if ($port =~ m,\D,); $port = $pnum || $serv[2] || $defport || undef; + unless (defined $port) { + $@ = "Bad service '$origport'"; + return; + } $proto = (getprotobyname($serv[3]))[2] || undef if @serv && !$proto; diff --git a/ext/IO/poll.c b/ext/IO/poll.c index 0f8c8434f2..024c52ff9f 100644 --- a/ext/IO/poll.c +++ b/ext/IO/poll.c @@ -5,8 +5,8 @@ * This program is free software; you can redistribute it and/or * modify it under the same terms as Perl itself. * - * For systems that do not have the poll() system call (for example Linux) - * try to emulate it as closely as possible using select() + * For systems that do not have the poll() system call (for example Linux + * kernels < v2.1.23) try to emulate it as closely as possible using select() * */ diff --git a/ext/IPC/SysV/Msg.pm b/ext/IPC/SysV/Msg.pm index 099329826f..120a5b2d3a 100644 --- a/ext/IPC/SysV/Msg.pm +++ b/ext/IPC/SysV/Msg.pm @@ -90,14 +90,14 @@ sub rcv { msgrcv($$self,$buf,$_[1],$_[2] || 0, $_[3] || 0) or return; my $type; - ($type,$_[0]) = unpack("L a*",$buf); + ($type,$_[0]) = unpack("l! a*",$buf); $type; } sub snd { @_ <= 4 && @_ >= 3 or croak '$msg->snd( TYPE, BUF, FLAGS )'; my $self = shift; - msgsnd($$self,pack("L a*",$_[0],$_[1]), $_[2] || 0); + msgsnd($$self,pack("l! a*",$_[0],$_[1]), $_[2] || 0); } @@ -111,12 +111,12 @@ IPC::Msg - SysV Msg IPC object class =head1 SYNOPSIS - use IPC::SysV qw(IPC_PRIVATE S_IRWXU S_IRWXG S_IRWXO); + use IPC::SysV qw(IPC_PRIVATE S_IRWXU); use IPC::Msg; - $msg = new IPC::Msg(IPC_PRIVATE, S_IRWXU | S_IRWXG | S_IRWXO); + $msg = new IPC::Msg(IPC_PRIVATE, S_IRWXU); - $msg->snd(pack("L a*",$msgtype,$msg)); + $msg->snd(pack("l! a*",$msgtype,$msg)); $msg->rcv($buf,256); @@ -157,8 +157,8 @@ Returns the system message queue identifier. =item rcv ( BUF, LEN [, TYPE [, FLAGS ]] ) -Read a message from the queue. Returns the type of the message read. See -L<msgrcv> +Read a message from the queue. Returns the type of the message read. +See L<msgrcv>. The BUF becomes tainted. =item remove diff --git a/ext/POSIX/Makefile.PL b/ext/POSIX/Makefile.PL index 15256cf198..55c5c1fbf3 100644 --- a/ext/POSIX/Makefile.PL +++ b/ext/POSIX/Makefile.PL @@ -1,7 +1,17 @@ use ExtUtils::MakeMaker; +use Config; +my @libs; +if ($^O ne 'MSWin32') { + if ($Config{archname} =~ /RM\d\d\d-svr4/) { + @libs = ('LIBS' => ["-lm -lc -lposix -lcposix"]); + } + else { + @libs = ('LIBS' => ["-lm -lposix -lcposix"]); + } +} WriteMakefile( NAME => 'POSIX', - ($^O eq 'MSWin32' ? () : (LIBS => ["-lm -lposix -lcposix"])), + @libs, MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'POSIX.pm', diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index 3a523d1d07..b33e9619a4 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -1517,6 +1517,11 @@ constant(char *name, int arg) break; case 'H': if (strEQ(name, "HUGE_VAL")) +#if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL) + /* HUGE_VALL is admittedly non-POSIX but if are using long doubles + * we might as well use long doubles. --jhi */ + return HUGE_VALL; +#endif #ifdef HUGE_VAL return HUGE_VAL; #else diff --git a/ext/Socket/Socket.pm b/ext/Socket/Socket.pm index f83cb18399..02f098df77 100644 --- a/ext/Socket/Socket.pm +++ b/ext/Socket/Socket.pm @@ -1,7 +1,7 @@ package Socket; our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); -$VERSION = "1.71"; +$VERSION = "1.72"; =head1 NAME @@ -160,6 +160,7 @@ have AF_UNIX in the right place. =cut use Carp; +use warnings::register; require Exporter; use XSLoader (); @@ -302,7 +303,8 @@ BEGIN { sub sockaddr_in { if (@_ == 6 && !wantarray) { # perl5.001m compat; use this && die my($af, $port, @quad) = @_; - carp "6-ARG sockaddr_in call is deprecated" if $^W; + warnings::warn "6-ARG sockaddr_in call is deprecated" + if warnings::enabled(); pack_sockaddr_in($port, inet_aton(join('.', @quad))); } elsif (wantarray) { croak "usage: (port,iaddr) = sockaddr_in(sin_sv)" unless @_ == 1; diff --git a/ext/Socket/Socket.xs b/ext/Socket/Socket.xs index 752c3ddb10..0584e785b5 100644 --- a/ext/Socket/Socket.xs +++ b/ext/Socket/Socket.xs @@ -19,6 +19,10 @@ # ifdef I_SYS_UN # include <sys/un.h> # endif +/* XXX Configure test for <netinet/in_systm.h needed XXX */ +# if defined(NeXT) || defined(__NeXT__) +# include <netinet/in_systm.h> +# endif # ifdef I_NETINET_IN # include <netinet/in.h> # endif diff --git a/ext/Sys/Syslog/Syslog.pm b/ext/Sys/Syslog/Syslog.pm index 17ebb379c6..c7ce3ded96 100644 --- a/ext/Sys/Syslog/Syslog.pm +++ b/ext/Sys/Syslog/Syslog.pm @@ -70,9 +70,11 @@ Sets the socket type to be used for the next call to C<openlog()> or C<syslog()> and returns TRUE on success, undef on failure. -A value of 'unix' will connect to the UNIX domain socket returned by -C<_PATH_LOG> in F<syslog.ph>. A value of 'inet' will connect to an -INET socket returned by getservbyname(). Any other value croaks. +A value of 'unix' will connect to the UNIX domain socket returned by the +C<_PATH_LOG> macro (if you system defines it) in F<syslog.h>. A value of +'inet' will connect to an INET socket returned by getservbyname(). If +C<_PATH_LOG> is unavailable or if getservbyname() fails, returns undef. Any +other value croaks. The default is for the INET socket to be used. @@ -107,10 +109,15 @@ L<syslog(3)> =head1 AUTHOR -Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall E<lt>F<larry@wall.org>E<gt>. -UNIX domain sockets added by Sean Robinson E<lt>F<robinson_s@sc.maricopa.edu>E<gt> -with support from Tim Bunce <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list. -Dependency on F<syslog.ph> replaced with XS code bu Tom Hughes E<lt>F<tom@compton.nu>E<gt>. +Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall +E<lt>F<larry@wall.org>E<gt>. + +UNIX domain sockets added by Sean Robinson +E<lt>F<robinson_s@sc.maricopa.edu>E<gt> with support from Tim Bunce +E<lt>F<Tim.Bunce@ig.co.uk>E<gt> and the perl5-porters mailing list. + +Dependency on F<syslog.ph> replaced with XS code by Tom Hughes +E<lt>F<tom@compton.nu>E<gt>. =cut @@ -122,7 +129,7 @@ sub AUTOLOAD { our $AUTOLOAD; ($constname = $AUTOLOAD) =~ s/.*:://; croak "& not defined" if $constname eq 'constant'; - my $val = constant($constname, @_ ? $_[0] : 0); + my $val = constant($constname); if ($! != 0) { croak "Your vendor has not defined Sys::Syslog macro $constname"; } @@ -159,7 +166,7 @@ sub setlogsock { local($setsock) = shift; &disconnect if $connected; if (lc($setsock) eq 'unix') { - if (defined &_PATH_LOG) { + if (length _PATH_LOG()) { $sock_type = 1; } else { return undef; @@ -244,9 +251,9 @@ sub syslog { else { if (open(CONS,">/dev/console")) { print CONS "<$facility.$priority>$whoami: $message\r"; - exit if defined $pid; # if fork failed, we're parent close CONS; } + exit if defined $pid; # if fork failed, we're parent } } } @@ -274,7 +281,8 @@ sub connect { socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp) || croak "socket: $!"; connect(SYSLOG,$that) || croak "connect: $!"; } else { - my $syslog = &_PATH_LOG || croak "_PATH_LOG not found in syslog.ph"; + my $syslog = _PATH_LOG(); + length($syslog) || croak "_PATH_LOG unavailable in syslog.h"; my $that = sockaddr_un($syslog) || croak "Can't locate $syslog"; socket(SYSLOG,AF_UNIX,SOCK_STREAM,0) || croak "socket: $!"; if (!connect(SYSLOG,$that)) { diff --git a/ext/Sys/Syslog/Syslog.xs b/ext/Sys/Syslog/Syslog.xs index 511df9f85f..31c0e845a2 100644 --- a/ext/Sys/Syslog/Syslog.xs +++ b/ext/Sys/Syslog/Syslog.xs @@ -7,7 +7,7 @@ #endif static double -constant_LOG_NO(char *name, int len, int arg) +constant_LOG_NO(char *name, int len) { switch (name[6 + 0]) { case 'T': @@ -36,7 +36,7 @@ not_there: } static double -constant_LOG_N(char *name, int len, int arg) +constant_LOG_N(char *name, int len) { switch (name[5 + 0]) { case 'D': @@ -64,7 +64,7 @@ constant_LOG_N(char *name, int len, int arg) #endif } case 'O': - return constant_LOG_NO(name, len, arg); + return constant_LOG_NO(name, len); } errno = EINVAL; return 0; @@ -75,7 +75,7 @@ not_there: } static double -constant_LOG_P(char *name, int len, int arg) +constant_LOG_P(char *name, int len) { switch (name[5 + 0]) { case 'I': @@ -104,7 +104,7 @@ not_there: } static double -constant_LOG_AU(char *name, int len, int arg) +constant_LOG_AU(char *name, int len) { if (6 + 2 >= len ) { errno = EINVAL; @@ -137,7 +137,7 @@ not_there: } static double -constant_LOG_A(char *name, int len, int arg) +constant_LOG_A(char *name, int len) { switch (name[5 + 0]) { case 'L': @@ -149,7 +149,7 @@ constant_LOG_A(char *name, int len, int arg) #endif } case 'U': - return constant_LOG_AU(name, len, arg); + return constant_LOG_AU(name, len); } errno = EINVAL; return 0; @@ -160,7 +160,7 @@ not_there: } static double -constant_LOG_CR(char *name, int len, int arg) +constant_LOG_CR(char *name, int len) { switch (name[6 + 0]) { case 'I': @@ -189,7 +189,7 @@ not_there: } static double -constant_LOG_C(char *name, int len, int arg) +constant_LOG_C(char *name, int len) { switch (name[5 + 0]) { case 'O': @@ -201,7 +201,7 @@ constant_LOG_C(char *name, int len, int arg) #endif } case 'R': - return constant_LOG_CR(name, len, arg); + return constant_LOG_CR(name, len); } errno = EINVAL; return 0; @@ -212,7 +212,7 @@ not_there: } static double -constant_LOG_D(char *name, int len, int arg) +constant_LOG_D(char *name, int len) { switch (name[5 + 0]) { case 'A': @@ -241,7 +241,7 @@ not_there: } static double -constant_LOG_U(char *name, int len, int arg) +constant_LOG_U(char *name, int len) { switch (name[5 + 0]) { case 'S': @@ -270,7 +270,7 @@ not_there: } static double -constant_LOG_E(char *name, int len, int arg) +constant_LOG_E(char *name, int len) { switch (name[5 + 0]) { case 'M': @@ -299,7 +299,7 @@ not_there: } static double -constant_LOG_F(char *name, int len, int arg) +constant_LOG_F(char *name, int len) { switch (name[5 + 0]) { case 'A': @@ -328,7 +328,7 @@ not_there: } static double -constant_LOG_LO(char *name, int len, int arg) +constant_LOG_LO(char *name, int len) { if (6 + 3 >= len ) { errno = EINVAL; @@ -409,7 +409,7 @@ not_there: } static double -constant_LOG_L(char *name, int len, int arg) +constant_LOG_L(char *name, int len) { switch (name[5 + 0]) { case 'F': @@ -421,7 +421,7 @@ constant_LOG_L(char *name, int len, int arg) #endif } case 'O': - return constant_LOG_LO(name, len, arg); + return constant_LOG_LO(name, len); case 'P': if (strEQ(name + 5, "PR")) { /* LOG_L removed */ #ifdef LOG_LPR @@ -440,7 +440,7 @@ not_there: } static double -constant(char *name, int len, int arg) +constant(char *name, int len) { errno = 0; if (0 + 4 >= len ) { @@ -451,23 +451,23 @@ constant(char *name, int len, int arg) case 'A': if (!strnEQ(name + 0,"LOG_", 4)) break; - return constant_LOG_A(name, len, arg); + return constant_LOG_A(name, len); case 'C': if (!strnEQ(name + 0,"LOG_", 4)) break; - return constant_LOG_C(name, len, arg); + return constant_LOG_C(name, len); case 'D': if (!strnEQ(name + 0,"LOG_", 4)) break; - return constant_LOG_D(name, len, arg); + return constant_LOG_D(name, len); case 'E': if (!strnEQ(name + 0,"LOG_", 4)) break; - return constant_LOG_E(name, len, arg); + return constant_LOG_E(name, len); case 'F': if (!strnEQ(name + 0,"LOG_", 4)) break; - return constant_LOG_F(name, len, arg); + return constant_LOG_F(name, len); case 'I': if (strEQ(name + 0, "LOG_INFO")) { /* removed */ #ifdef LOG_INFO @@ -487,7 +487,7 @@ constant(char *name, int len, int arg) case 'L': if (!strnEQ(name + 0,"LOG_", 4)) break; - return constant_LOG_L(name, len, arg); + return constant_LOG_L(name, len); case 'M': if (strEQ(name + 0, "LOG_MAIL")) { /* removed */ #ifdef LOG_MAIL @@ -499,7 +499,7 @@ constant(char *name, int len, int arg) case 'N': if (!strnEQ(name + 0,"LOG_", 4)) break; - return constant_LOG_N(name, len, arg); + return constant_LOG_N(name, len); case 'O': if (strEQ(name + 0, "LOG_ODELAY")) { /* removed */ #ifdef LOG_ODELAY @@ -511,7 +511,7 @@ constant(char *name, int len, int arg) case 'P': if (!strnEQ(name + 0,"LOG_", 4)) break; - return constant_LOG_P(name, len, arg); + return constant_LOG_P(name, len); case 'S': if (strEQ(name + 0, "LOG_SYSLOG")) { /* removed */ #ifdef LOG_SYSLOG @@ -523,7 +523,7 @@ constant(char *name, int len, int arg) case 'U': if (!strnEQ(name + 0,"LOG_", 4)) break; - return constant_LOG_U(name, len, arg); + return constant_LOG_U(name, len); case 'W': if (strEQ(name + 0, "LOG_WARNING")) { /* removed */ #ifdef LOG_WARNING @@ -550,8 +550,7 @@ _PATH_LOG() #ifdef _PATH_LOG RETVAL = _PATH_LOG; #else - croak("Your vendor has not defined the Sys::Syslog macro _PATH_LOG"); - RETVAL = NULL; + RETVAL = ""; #endif OUTPUT: RETVAL @@ -629,15 +628,14 @@ LOG_UPTO(pri) double -constant(sv,arg) +constant(sv) PREINIT: STRLEN len; INPUT: SV * sv char * s = SvPV(sv, len); - int arg CODE: - RETVAL = constant(s,len,arg); + RETVAL = constant(s,len); OUTPUT: RETVAL diff --git a/ext/Thread/Thread.pm b/ext/Thread/Thread.pm index 3e50a99cd4..c752e3d6dd 100644 --- a/ext/Thread/Thread.pm +++ b/ext/Thread/Thread.pm @@ -36,16 +36,15 @@ Thread - manipulate threads in Perl (EXPERIMENTAL, subject to change) =head1 DESCRIPTION -The C<Thread> module provides multithreading support for perl. - -WARNING: Threading is an experimental feature. Both the interface -and implementation are subject to change drastically. + WARNING: Threading is an experimental feature. Both the interface + and implementation are subject to change drastically. In fact, this + documentation describes the flavor of threads that was in version + 5.005. Perl 5.6.0 and later have the beginnings of support for + interpreter threads, which (when finished) is expected to be + significantly different from what is described here. The information + contained here may therefore soon be obsolete. Use at your own risk! -In fact, this documentation describes the flavor of threads that was in -version 5.005. Perl v5.6 has the beginnings of support for interpreter -threads, which (when finished) is expected to be significantly different -from what is described here. The information contained here may therefore -soon be obsolete. Use at your own risk! +The C<Thread> module provides multithreading support for perl. =head1 FUNCTIONS @@ -131,7 +130,7 @@ signal is discarded. =item cond_broadcast VARIABLE -The C<cond_broadcast> function works similarly to C<cond_wait>. +The C<cond_broadcast> function works similarly to C<cond_signal>. C<cond_broadcast>, though, will unblock B<all> the threads that are blocked in a C<cond_wait> on the locked variable, rather than only one. diff --git a/ext/Thread/Thread/Queue.pm b/ext/Thread/Thread/Queue.pm index 6e2fba8e88..831573c726 100644 --- a/ext/Thread/Thread/Queue.pm +++ b/ext/Thread/Thread/Queue.pm @@ -67,13 +67,13 @@ sub new { return bless [@_], $class; } -sub dequeue : locked, method { +sub dequeue : locked : method { my $q = shift; cond_wait $q until @$q; return shift @$q; } -sub dequeue_nb : locked, method { +sub dequeue_nb : locked : method { my $q = shift; if (@$q) { return shift @$q; @@ -82,12 +82,12 @@ sub dequeue_nb : locked, method { } } -sub enqueue : locked, method { +sub enqueue : locked : method { my $q = shift; push(@$q, @_) and cond_broadcast $q; } -sub pending : locked, method { +sub pending : locked : method { my $q = shift; return scalar(@$q); } diff --git a/ext/Thread/Thread/Semaphore.pm b/ext/Thread/Thread/Semaphore.pm index f50f96c8af..3cd6338d4d 100644 --- a/ext/Thread/Thread/Semaphore.pm +++ b/ext/Thread/Thread/Semaphore.pm @@ -69,14 +69,14 @@ sub new { bless \$val, $class; } -sub down : locked, method { +sub down : locked : method { my $s = shift; my $inc = @_ ? shift : 1; cond_wait $s until $$s >= $inc; $$s -= $inc; } -sub up : locked, method { +sub up : locked : method { my $s = shift; my $inc = @_ ? shift : 1; ($$s += $inc) > 0 and cond_broadcast $s; diff --git a/ext/Thread/Thread/Specific.pm b/ext/Thread/Thread/Specific.pm index da3f9375a7..a6271a4ae4 100644 --- a/ext/Thread/Thread/Specific.pm +++ b/ext/Thread/Thread/Specific.pm @@ -15,12 +15,13 @@ C<key_create> returns a unique thread-specific key. =cut -sub import : locked, method { +sub import : locked : method { require fields; fields::->import(@_); } -sub key_create : locked, method { +sub key_create : locked : method { + our %FIELDS; # suppress "used only once" return ++$FIELDS{__MAX__}; } |