diff options
Diffstat (limited to 'contrib/perl5/ext')
251 files changed, 0 insertions, 57313 deletions
diff --git a/contrib/perl5/ext/B/B.pm b/contrib/perl5/ext/B/B.pm deleted file mode 100644 index c58e769..0000000 --- a/contrib/perl5/ext/B/B.pm +++ /dev/null @@ -1,892 +0,0 @@ -# B.pm -# -# Copyright (c) 1996, 1997, 1998 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. -# -package B; -use XSLoader (); -require Exporter; -@ISA = qw(Exporter); - -# walkoptree_slow comes from B.pm (you are there), -# walkoptree comes from B.xs -@EXPORT_OK = qw(minus_c ppname save_BEGINs - class peekop cast_I32 cstring cchar hash threadsv_names - main_root main_start main_cv svref_2object opnumber - amagic_generation - walkoptree_slow walkoptree walkoptree_exec walksymtable - parents comppadlist sv_undef compile_stats timing_info - begin_av init_av end_av); - -sub OPf_KIDS (); -use strict; -@B::SV::ISA = 'B::OBJECT'; -@B::NULL::ISA = 'B::SV'; -@B::PV::ISA = 'B::SV'; -@B::IV::ISA = 'B::SV'; -@B::NV::ISA = 'B::IV'; -@B::RV::ISA = 'B::SV'; -@B::PVIV::ISA = qw(B::PV B::IV); -@B::PVNV::ISA = qw(B::PV B::NV); -@B::PVMG::ISA = 'B::PVNV'; -@B::PVLV::ISA = 'B::PVMG'; -@B::BM::ISA = 'B::PVMG'; -@B::AV::ISA = 'B::PVMG'; -@B::GV::ISA = 'B::PVMG'; -@B::HV::ISA = 'B::PVMG'; -@B::CV::ISA = 'B::PVMG'; -@B::IO::ISA = 'B::PVMG'; -@B::FM::ISA = 'B::CV'; - -@B::OP::ISA = 'B::OBJECT'; -@B::UNOP::ISA = 'B::OP'; -@B::BINOP::ISA = 'B::UNOP'; -@B::LOGOP::ISA = 'B::UNOP'; -@B::LISTOP::ISA = 'B::BINOP'; -@B::SVOP::ISA = 'B::OP'; -@B::PADOP::ISA = 'B::OP'; -@B::PVOP::ISA = 'B::OP'; -@B::CVOP::ISA = 'B::OP'; -@B::LOOP::ISA = 'B::LISTOP'; -@B::PMOP::ISA = 'B::LISTOP'; -@B::COP::ISA = 'B::OP'; - -@B::SPECIAL::ISA = 'B::OBJECT'; - -{ - # Stop "-w" from complaining about the lack of a real B::OBJECT class - package B::OBJECT; -} - -sub B::GV::SAFENAME { - my $name = (shift())->NAME; - - # The regex below corresponds to the isCONTROLVAR macro - # from toke.c - - $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".chr(64 ^ ord($1))/e; - return $name; -} - -sub B::IV::int_value { - my ($self) = @_; - return (($self->FLAGS() & SVf_IVisUV()) ? $self->UVX : $self->IV); -} - -my $debug; -my $op_count = 0; -my @parents = (); - -sub debug { - my ($class, $value) = @_; - $debug = $value; - walkoptree_debug($value); -} - -sub class { - my $obj = shift; - my $name = ref $obj; - $name =~ s/^.*:://; - return $name; -} - -sub parents { \@parents } - -# For debugging -sub peekop { - my $op = shift; - return sprintf("%s (0x%x) %s", class($op), $$op, $op->name); -} - -sub walkoptree_slow { - my($op, $method, $level) = @_; - $op_count++; # just for statistics - $level ||= 0; - warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug; - $op->$method($level); - if ($$op && ($op->flags & OPf_KIDS)) { - my $kid; - unshift(@parents, $op); - for ($kid = $op->first; $$kid; $kid = $kid->sibling) { - walkoptree_slow($kid, $method, $level + 1); - } - shift @parents; - } -} - -sub compile_stats { - return "Total number of OPs processed: $op_count\n"; -} - -sub timing_info { - my ($sec, $min, $hr) = localtime; - my ($user, $sys) = times; - sprintf("%02d:%02d:%02d user=$user sys=$sys", - $hr, $min, $sec, $user, $sys); -} - -my %symtable; - -sub clearsym { - %symtable = (); -} - -sub savesym { - my ($obj, $value) = @_; -# warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug - $symtable{sprintf("sym_%x", $$obj)} = $value; -} - -sub objsym { - my $obj = shift; - return $symtable{sprintf("sym_%x", $$obj)}; -} - -sub walkoptree_exec { - my ($op, $method, $level) = @_; - $level ||= 0; - my ($sym, $ppname); - my $prefix = " " x $level; - for (; $$op; $op = $op->next) { - $sym = objsym($op); - if (defined($sym)) { - print $prefix, "goto $sym\n"; - return; - } - savesym($op, sprintf("%s (0x%lx)", class($op), $$op)); - $op->$method($level); - $ppname = $op->name; - if ($ppname =~ - /^(or|and|mapwhile|grepwhile|entertry|range|cond_expr)$/) - { - print $prefix, uc($1), " => {\n"; - walkoptree_exec($op->other, $method, $level + 1); - print $prefix, "}\n"; - } elsif ($ppname eq "match" || $ppname eq "subst") { - my $pmreplstart = $op->pmreplstart; - if ($$pmreplstart) { - print $prefix, "PMREPLSTART => {\n"; - walkoptree_exec($pmreplstart, $method, $level + 1); - print $prefix, "}\n"; - } - } elsif ($ppname eq "substcont") { - print $prefix, "SUBSTCONT => {\n"; - walkoptree_exec($op->other->pmreplstart, $method, $level + 1); - print $prefix, "}\n"; - $op = $op->other; - } elsif ($ppname eq "enterloop") { - print $prefix, "REDO => {\n"; - walkoptree_exec($op->redoop, $method, $level + 1); - print $prefix, "}\n", $prefix, "NEXT => {\n"; - walkoptree_exec($op->nextop, $method, $level + 1); - print $prefix, "}\n", $prefix, "LAST => {\n"; - walkoptree_exec($op->lastop, $method, $level + 1); - print $prefix, "}\n"; - } elsif ($ppname eq "subst") { - my $replstart = $op->pmreplstart; - if ($$replstart) { - print $prefix, "SUBST => {\n"; - walkoptree_exec($replstart, $method, $level + 1); - print $prefix, "}\n"; - } - } - } -} - -sub walksymtable { - my ($symref, $method, $recurse, $prefix) = @_; - my $sym; - my $ref; - no strict 'vars'; - local(*glob); - $prefix = '' unless defined $prefix; - while (($sym, $ref) = each %$symref) { - *glob = "*main::".$prefix.$sym; - if ($sym =~ /::$/) { - $sym = $prefix . $sym; - if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym)) { - walksymtable(\%glob, $method, $recurse, $sym); - } - } else { - svref_2object(\*glob)->EGV->$method(); - } - } -} - -{ - package B::Section; - my $output_fh; - my %sections; - - sub new { - my ($class, $section, $symtable, $default) = @_; - $output_fh ||= FileHandle->new_tmpfile; - my $obj = bless [-1, $section, $symtable, $default], $class; - $sections{$section} = $obj; - return $obj; - } - - sub get { - my ($class, $section) = @_; - return $sections{$section}; - } - - sub add { - my $section = shift; - while (defined($_ = shift)) { - print $output_fh "$section->[1]\t$_\n"; - $section->[0]++; - } - } - - sub index { - my $section = shift; - return $section->[0]; - } - - sub name { - my $section = shift; - return $section->[1]; - } - - sub symtable { - my $section = shift; - return $section->[2]; - } - - sub default { - my $section = shift; - return $section->[3]; - } - - sub output { - my ($section, $fh, $format) = @_; - my $name = $section->name; - my $sym = $section->symtable || {}; - my $default = $section->default; - - seek($output_fh, 0, 0); - while (<$output_fh>) { - chomp; - s/^(.*?)\t//; - if ($1 eq $name) { - s{(s\\_[0-9a-f]+)} { - exists($sym->{$1}) ? $sym->{$1} : $default; - }ge; - printf $fh $format, $_; - } - } - } -} - -XSLoader::load 'B'; - -1; - -__END__ - -=head1 NAME - -B - The Perl Compiler - -=head1 SYNOPSIS - - use B; - -=head1 DESCRIPTION - -The C<B> module supplies classes which allow a Perl program to delve -into its own innards. It is the module used to implement the -"backends" of the Perl compiler. Usage of the compiler does not -require knowledge of this module: see the F<O> module for the -user-visible part. The C<B> module is of use to those who want to -write new compiler backends. This documentation assumes that the -reader knows a fair amount about perl's internals including such -things as SVs, OPs and the internal symbol table and syntax tree -of a program. - -=head1 OVERVIEW OF CLASSES - -The C structures used by Perl's internals to hold SV and OP -information (PVIV, AV, HV, ..., OP, SVOP, UNOP, ...) are modelled on a -class hierarchy and the C<B> module gives access to them via a true -object hierarchy. Structure fields which point to other objects -(whether types of SV or types of OP) are represented by the C<B> -module as Perl objects of the appropriate class. The bulk of the C<B> -module is the methods for accessing fields of these structures. Note -that all access is read-only: you cannot modify the internals by -using this module. - -=head2 SV-RELATED CLASSES - -B::IV, B::NV, B::RV, B::PV, B::PVIV, B::PVNV, B::PVMG, B::BM, B::PVLV, -B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes correspond in -the obvious way to the underlying C structures of similar names. The -inheritance hierarchy mimics the underlying C "inheritance". Access -methods correspond to the underlying C macros for field access, -usually with the leading "class indication" prefix removed (Sv, Av, -Hv, ...). The leading prefix is only left in cases where its removal -would cause a clash in method name. For example, C<GvREFCNT> stays -as-is since its abbreviation would clash with the "superclass" method -C<REFCNT> (corresponding to the C function C<SvREFCNT>). - -=head2 B::SV METHODS - -=over 4 - -=item REFCNT - -=item FLAGS - -=back - -=head2 B::IV METHODS - -=over 4 - -=item IV - -Returns the value of the IV, I<interpreted as -a signed integer>. This will be misleading -if C<FLAGS & SVf_IVisUV>. Perhaps you want the -C<int_value> method instead? - -=item IVX - -=item UVX - -=item int_value - -This method returns the value of the IV as an integer. -It differs from C<IV> in that it returns the correct -value regardless of whether it's stored signed or -unsigned. - -=item needs64bits - -=item packiv - -=back - -=head2 B::NV METHODS - -=over 4 - -=item NV - -=item NVX - -=back - -=head2 B::RV METHODS - -=over 4 - -=item RV - -=back - -=head2 B::PV METHODS - -=over 4 - -=item PV - -This method is the one you usually want. It constructs a -string using the length and offset information in the struct: -for ordinary scalars it will return the string that you'd see -from Perl, even if it contains null characters. - -=item PVX - -This method is less often useful. It assumes that the string -stored in the struct is null-terminated, and disregards the -length information. - -It is the appropriate method to use if you need to get the name -of a lexical variable from a padname array. Lexical variable names -are always stored with a null terminator, and the length field -(SvCUR) is overloaded for other purposes and can't be relied on here. - -=back - -=head2 B::PVMG METHODS - -=over 4 - -=item MAGIC - -=item SvSTASH - -=back - -=head2 B::MAGIC METHODS - -=over 4 - -=item MOREMAGIC - -=item PRIVATE - -=item TYPE - -=item FLAGS - -=item OBJ - -=item PTR - -=back - -=head2 B::PVLV METHODS - -=over 4 - -=item TARGOFF - -=item TARGLEN - -=item TYPE - -=item TARG - -=back - -=head2 B::BM METHODS - -=over 4 - -=item USEFUL - -=item PREVIOUS - -=item RARE - -=item TABLE - -=back - -=head2 B::GV METHODS - -=over 4 - -=item is_empty - -This method returns TRUE if the GP field of the GV is NULL. - -=item NAME - -=item SAFENAME - -This method returns the name of the glob, but if the first -character of the name is a control character, then it converts -it to ^X first, so that *^G would return "^G" rather than "\cG". - -It's useful if you want to print out the name of a variable. -If you restrict yourself to globs which exist at compile-time -then the result ought to be unambiguous, because code like -C<${"^G"} = 1> is compiled as two ops - a constant string and -a dereference (rv2gv) - so that the glob is created at runtime. - -If you're working with globs at runtime, and need to disambiguate -*^G from *{"^G"}, then you should use the raw NAME method. - -=item STASH - -=item SV - -=item IO - -=item FORM - -=item AV - -=item HV - -=item EGV - -=item CV - -=item CVGEN - -=item LINE - -=item FILE - -=item FILEGV - -=item GvREFCNT - -=item FLAGS - -=back - -=head2 B::IO METHODS - -=over 4 - -=item LINES - -=item PAGE - -=item PAGE_LEN - -=item LINES_LEFT - -=item TOP_NAME - -=item TOP_GV - -=item FMT_NAME - -=item FMT_GV - -=item BOTTOM_NAME - -=item BOTTOM_GV - -=item SUBPROCESS - -=item IoTYPE - -=item IoFLAGS - -=back - -=head2 B::AV METHODS - -=over 4 - -=item FILL - -=item MAX - -=item OFF - -=item ARRAY - -=item AvFLAGS - -=back - -=head2 B::CV METHODS - -=over 4 - -=item STASH - -=item START - -=item ROOT - -=item GV - -=item FILE - -=item DEPTH - -=item PADLIST - -=item OUTSIDE - -=item XSUB - -=item XSUBANY - -=item CvFLAGS - -=back - -=head2 B::HV METHODS - -=over 4 - -=item FILL - -=item MAX - -=item KEYS - -=item RITER - -=item NAME - -=item PMROOT - -=item ARRAY - -=back - -=head2 OP-RELATED CLASSES - -B::OP, B::UNOP, B::BINOP, B::LOGOP, B::LISTOP, B::PMOP, -B::SVOP, B::PADOP, B::PVOP, B::CVOP, B::LOOP, B::COP. -These classes correspond in -the obvious way to the underlying C structures of similar names. The -inheritance hierarchy mimics the underlying C "inheritance". Access -methods correspond to the underlying C structre field names, with the -leading "class indication" prefix removed (op_). - -=head2 B::OP METHODS - -=over 4 - -=item next - -=item sibling - -=item name - -This returns the op name as a string (e.g. "add", "rv2av"). - -=item ppaddr - -This returns the function name as a string (e.g. "PL_ppaddr[OP_ADD]", -"PL_ppaddr[OP_RV2AV]"). - -=item desc - -This returns the op description from the global C PL_op_desc array -(e.g. "addition" "array deref"). - -=item targ - -=item type - -=item seq - -=item flags - -=item private - -=back - -=head2 B::UNOP METHOD - -=over 4 - -=item first - -=back - -=head2 B::BINOP METHOD - -=over 4 - -=item last - -=back - -=head2 B::LOGOP METHOD - -=over 4 - -=item other - -=back - -=head2 B::LISTOP METHOD - -=over 4 - -=item children - -=back - -=head2 B::PMOP METHODS - -=over 4 - -=item pmreplroot - -=item pmreplstart - -=item pmnext - -=item pmregexp - -=item pmflags - -=item pmpermflags - -=item precomp - -=back - -=head2 B::SVOP METHOD - -=over 4 - -=item sv - -=item gv - -=back - -=head2 B::PADOP METHOD - -=over 4 - -=item padix - -=back - -=head2 B::PVOP METHOD - -=over 4 - -=item pv - -=back - -=head2 B::LOOP METHODS - -=over 4 - -=item redoop - -=item nextop - -=item lastop - -=back - -=head2 B::COP METHODS - -=over 4 - -=item label - -=item stash - -=item file - -=item cop_seq - -=item arybase - -=item line - -=back - -=head1 FUNCTIONS EXPORTED BY C<B> - -The C<B> module exports a variety of functions: some are simple -utility functions, others provide a Perl program with a way to -get an initial "handle" on an internal object. - -=over 4 - -=item main_cv - -Return the (faked) CV corresponding to the main part of the Perl -program. - -=item init_av - -Returns the AV object (i.e. in class B::AV) representing INIT blocks. - -=item main_root - -Returns the root op (i.e. an object in the appropriate B::OP-derived -class) of the main part of the Perl program. - -=item main_start - -Returns the starting op of the main part of the Perl program. - -=item comppadlist - -Returns the AV object (i.e. in class B::AV) of the global comppadlist. - -=item sv_undef - -Returns the SV object corresponding to the C variable C<sv_undef>. - -=item sv_yes - -Returns the SV object corresponding to the C variable C<sv_yes>. - -=item sv_no - -Returns the SV object corresponding to the C variable C<sv_no>. - -=item amagic_generation - -Returns the SV object corresponding to the C variable C<amagic_generation>. - -=item walkoptree(OP, METHOD) - -Does a tree-walk of the syntax tree based at OP and calls METHOD on -each op it visits. Each node is visited before its children. If -C<walkoptree_debug> (q.v.) has been called to turn debugging on then -the method C<walkoptree_debug> is called on each op before METHOD is -called. - -=item walkoptree_debug(DEBUG) - -Returns the current debugging flag for C<walkoptree>. If the optional -DEBUG argument is non-zero, it sets the debugging flag to that. See -the description of C<walkoptree> above for what the debugging flag -does. - -=item walksymtable(SYMREF, METHOD, RECURSE) - -Walk the symbol table starting at SYMREF and call METHOD on each -symbol visited. When the walk reached package symbols "Foo::" it -invokes RECURSE and only recurses into the package if that sub -returns true. - -=item svref_2object(SV) - -Takes any Perl variable and turns it into an object in the -appropriate B::OP-derived or B::SV-derived class. Apart from functions -such as C<main_root>, this is the primary way to get an initial -"handle" on a internal perl data structure which can then be followed -with the other access methods. - -=item ppname(OPNUM) - -Return the PP function name (e.g. "pp_add") of op number OPNUM. - -=item hash(STR) - -Returns a string in the form "0x..." representing the value of the -internal hash function used by perl on string STR. - -=item cast_I32(I) - -Casts I to the internal I32 type used by that perl. - - -=item minus_c - -Does the equivalent of the C<-c> command-line option. Obviously, this -is only useful in a BEGIN block or else the flag is set too late. - - -=item cstring(STR) - -Returns a double-quote-surrounded escaped version of STR which can -be used as a string in C source code. - -=item class(OBJ) - -Returns the class of an object without the part of the classname -preceding the first "::". This is used to turn "B::UNOP" into -"UNOP" for example. - -=item threadsv_names - -In a perl compiled for threads, this returns a list of the special -per-thread threadsv variables. - -=back - -=head1 AUTHOR - -Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> - -=cut diff --git a/contrib/perl5/ext/B/B.xs b/contrib/perl5/ext/B/B.xs deleted file mode 100644 index 1005747..0000000 --- a/contrib/perl5/ext/B/B.xs +++ /dev/null @@ -1,1285 +0,0 @@ -/* B.xs - * - * Copyright (c) 1996 Malcolm Beattie - * - * You may distribute under the terms of either the GNU General Public - * License or the Artistic License, as specified in the README file. - * - */ - -#define PERL_NO_GET_CONTEXT -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#ifdef PERL_OBJECT -#undef PL_op_name -#undef PL_opargs -#undef PL_op_desc -#define PL_op_name (get_op_names()) -#define PL_opargs (get_opargs()) -#define PL_op_desc (get_op_descs()) -#endif - -#ifdef PerlIO -typedef PerlIO * InputStream; -#else -typedef FILE * InputStream; -#endif - - -static char *svclassnames[] = { - "B::NULL", - "B::IV", - "B::NV", - "B::RV", - "B::PV", - "B::PVIV", - "B::PVNV", - "B::PVMG", - "B::BM", - "B::PVLV", - "B::AV", - "B::HV", - "B::CV", - "B::GV", - "B::FM", - "B::IO", -}; - -typedef enum { - OPc_NULL, /* 0 */ - OPc_BASEOP, /* 1 */ - OPc_UNOP, /* 2 */ - OPc_BINOP, /* 3 */ - OPc_LOGOP, /* 4 */ - OPc_LISTOP, /* 5 */ - OPc_PMOP, /* 6 */ - OPc_SVOP, /* 7 */ - OPc_PADOP, /* 8 */ - OPc_PVOP, /* 9 */ - OPc_CVOP, /* 10 */ - OPc_LOOP, /* 11 */ - OPc_COP /* 12 */ -} opclass; - -static char *opclassnames[] = { - "B::NULL", - "B::OP", - "B::UNOP", - "B::BINOP", - "B::LOGOP", - "B::LISTOP", - "B::PMOP", - "B::SVOP", - "B::PADOP", - "B::PVOP", - "B::CVOP", - "B::LOOP", - "B::COP" -}; - -static int walkoptree_debug = 0; /* Flag for walkoptree debug hook */ - -static SV *specialsv_list[6]; - -static opclass -cc_opclass(pTHX_ OP *o) -{ - if (!o) - return OPc_NULL; - - if (o->op_type == 0) - return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP; - - if (o->op_type == OP_SASSIGN) - return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP); - -#ifdef USE_ITHREADS - if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST) - return OPc_PADOP; -#endif - - switch (PL_opargs[o->op_type] & OA_CLASS_MASK) { - case OA_BASEOP: - return OPc_BASEOP; - - case OA_UNOP: - return OPc_UNOP; - - case OA_BINOP: - return OPc_BINOP; - - case OA_LOGOP: - return OPc_LOGOP; - - case OA_LISTOP: - return OPc_LISTOP; - - case OA_PMOP: - return OPc_PMOP; - - case OA_SVOP: - return OPc_SVOP; - - case OA_PADOP: - return OPc_PADOP; - - case OA_PVOP_OR_SVOP: - /* - * Character translations (tr///) are usually a PVOP, keeping a - * pointer to a table of shorts used to look up translations. - * Under utf8, however, a simple table isn't practical; instead, - * the OP is an SVOP, and the SV is a reference to a swash - * (i.e., an RV pointing to an HV). - */ - return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF)) - ? OPc_SVOP : OPc_PVOP; - - case OA_LOOP: - return OPc_LOOP; - - case OA_COP: - return OPc_COP; - - case OA_BASEOP_OR_UNOP: - /* - * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on - * whether parens were seen. perly.y uses OPf_SPECIAL to - * signal whether a BASEOP had empty parens or none. - * Some other UNOPs are created later, though, so the best - * test is OPf_KIDS, which is set in newUNOP. - */ - return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP; - - case OA_FILESTATOP: - /* - * The file stat OPs are created via UNI(OP_foo) in toke.c but use - * the OPf_REF flag to distinguish between OP types instead of the - * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we - * return OPc_UNOP so that walkoptree can find our children. If - * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set - * (no argument to the operator) it's an OP; with OPf_REF set it's - * an SVOP (and op_sv is the GV for the filehandle argument). - */ - return ((o->op_flags & OPf_KIDS) ? OPc_UNOP : -#ifdef USE_ITHREADS - (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP); -#else - (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP); -#endif - case OA_LOOPEXOP: - /* - * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a - * label was omitted (in which case it's a BASEOP) or else a term was - * seen. In this last case, all except goto are definitely PVOP but - * goto is either a PVOP (with an ordinary constant label), an UNOP - * with OPf_STACKED (with a non-constant non-sub) or an UNOP for - * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to - * get set. - */ - if (o->op_flags & OPf_STACKED) - return OPc_UNOP; - else if (o->op_flags & OPf_SPECIAL) - return OPc_BASEOP; - else - return OPc_PVOP; - } - warn("can't determine class of operator %s, assuming BASEOP\n", - PL_op_name[o->op_type]); - return OPc_BASEOP; -} - -static char * -cc_opclassname(pTHX_ OP *o) -{ - return opclassnames[cc_opclass(aTHX_ o)]; -} - -static SV * -make_sv_object(pTHX_ SV *arg, SV *sv) -{ - char *type = 0; - IV iv; - - for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) { - if (sv == specialsv_list[iv]) { - type = "B::SPECIAL"; - break; - } - } - if (!type) { - type = svclassnames[SvTYPE(sv)]; - iv = PTR2IV(sv); - } - sv_setiv(newSVrv(arg, type), iv); - return arg; -} - -static SV * -make_mg_object(pTHX_ SV *arg, MAGIC *mg) -{ - sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg)); - return arg; -} - -static SV * -cstring(pTHX_ SV *sv) -{ - SV *sstr = newSVpvn("", 0); - STRLEN len; - char *s; - - if (!SvOK(sv)) - sv_setpvn(sstr, "0", 1); - else - { - /* XXX Optimise? */ - s = SvPV(sv, len); - sv_catpv(sstr, "\""); - for (; len; len--, s++) - { - /* At least try a little for readability */ - if (*s == '"') - sv_catpv(sstr, "\\\""); - else if (*s == '\\') - sv_catpv(sstr, "\\\\"); - else if (*s >= ' ' && *s < 127) /* XXX not portable */ - sv_catpvn(sstr, s, 1); - else if (*s == '\n') - sv_catpv(sstr, "\\n"); - else if (*s == '\r') - sv_catpv(sstr, "\\r"); - else if (*s == '\t') - sv_catpv(sstr, "\\t"); - else if (*s == '\a') - sv_catpv(sstr, "\\a"); - else if (*s == '\b') - sv_catpv(sstr, "\\b"); - else if (*s == '\f') - sv_catpv(sstr, "\\f"); - else if (*s == '\v') - sv_catpv(sstr, "\\v"); - else - { - /* no trigraph support */ - char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */ - /* Don't want promotion of a signed -1 char in sprintf args */ - unsigned char c = (unsigned char) *s; - sprintf(escbuff, "\\%03o", c); - sv_catpv(sstr, escbuff); - } - /* XXX Add line breaks if string is long */ - } - sv_catpv(sstr, "\""); - } - return sstr; -} - -static SV * -cchar(pTHX_ SV *sv) -{ - SV *sstr = newSVpvn("'", 1); - STRLEN n_a; - char *s = SvPV(sv, n_a); - - if (*s == '\'') - sv_catpv(sstr, "\\'"); - else if (*s == '\\') - sv_catpv(sstr, "\\\\"); - else if (*s >= ' ' && *s < 127) /* XXX not portable */ - sv_catpvn(sstr, s, 1); - else if (*s == '\n') - sv_catpv(sstr, "\\n"); - else if (*s == '\r') - sv_catpv(sstr, "\\r"); - else if (*s == '\t') - sv_catpv(sstr, "\\t"); - else if (*s == '\a') - sv_catpv(sstr, "\\a"); - else if (*s == '\b') - sv_catpv(sstr, "\\b"); - else if (*s == '\f') - sv_catpv(sstr, "\\f"); - else if (*s == '\v') - sv_catpv(sstr, "\\v"); - else - { - /* no trigraph support */ - char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */ - /* Don't want promotion of a signed -1 char in sprintf args */ - unsigned char c = (unsigned char) *s; - sprintf(escbuff, "\\%03o", c); - sv_catpv(sstr, escbuff); - } - sv_catpv(sstr, "'"); - return sstr; -} - -void -walkoptree(pTHX_ SV *opsv, char *method) -{ - dSP; - OP *o; - - if (!SvROK(opsv)) - croak("opsv is not a reference"); - opsv = sv_mortalcopy(opsv); - o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv))); - if (walkoptree_debug) { - PUSHMARK(sp); - XPUSHs(opsv); - PUTBACK; - perl_call_method("walkoptree_debug", G_DISCARD); - } - PUSHMARK(sp); - XPUSHs(opsv); - PUTBACK; - perl_call_method(method, G_DISCARD); - if (o && (o->op_flags & OPf_KIDS)) { - OP *kid; - for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) { - /* Use the same opsv. Rely on methods not to mess it up. */ - sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid)); - walkoptree(aTHX_ opsv, method); - } - } -} - -typedef OP *B__OP; -typedef UNOP *B__UNOP; -typedef BINOP *B__BINOP; -typedef LOGOP *B__LOGOP; -typedef LISTOP *B__LISTOP; -typedef PMOP *B__PMOP; -typedef SVOP *B__SVOP; -typedef PADOP *B__PADOP; -typedef PVOP *B__PVOP; -typedef LOOP *B__LOOP; -typedef COP *B__COP; - -typedef SV *B__SV; -typedef SV *B__IV; -typedef SV *B__PV; -typedef SV *B__NV; -typedef SV *B__PVMG; -typedef SV *B__PVLV; -typedef SV *B__BM; -typedef SV *B__RV; -typedef AV *B__AV; -typedef HV *B__HV; -typedef CV *B__CV; -typedef GV *B__GV; -typedef IO *B__IO; - -typedef MAGIC *B__MAGIC; - -MODULE = B PACKAGE = B PREFIX = B_ - -PROTOTYPES: DISABLE - -BOOT: -{ - HV *stash = gv_stashpvn("B", 1, TRUE); - AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE); - specialsv_list[0] = Nullsv; - specialsv_list[1] = &PL_sv_undef; - specialsv_list[2] = &PL_sv_yes; - specialsv_list[3] = &PL_sv_no; - specialsv_list[4] = pWARN_ALL; - specialsv_list[5] = pWARN_NONE; -#include "defsubs.h" -} - -#define B_main_cv() PL_main_cv -#define B_init_av() PL_initav -#define B_begin_av() PL_beginav_save -#define B_end_av() PL_endav -#define B_main_root() PL_main_root -#define B_main_start() PL_main_start -#define B_amagic_generation() PL_amagic_generation -#define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv)) -#define B_sv_undef() &PL_sv_undef -#define B_sv_yes() &PL_sv_yes -#define B_sv_no() &PL_sv_no - -B::AV -B_init_av() - -B::AV -B_begin_av() - -B::AV -B_end_av() - -B::CV -B_main_cv() - -B::OP -B_main_root() - -B::OP -B_main_start() - -long -B_amagic_generation() - -B::AV -B_comppadlist() - -B::SV -B_sv_undef() - -B::SV -B_sv_yes() - -B::SV -B_sv_no() - -MODULE = B PACKAGE = B - - -void -walkoptree(opsv, method) - SV * opsv - char * method - CODE: - walkoptree(aTHX_ opsv, method); - -int -walkoptree_debug(...) - CODE: - RETVAL = walkoptree_debug; - if (items > 0 && SvTRUE(ST(1))) - walkoptree_debug = 1; - OUTPUT: - RETVAL - -#define address(sv) PTR2IV(sv) - -IV -address(sv) - SV * sv - -B::SV -svref_2object(sv) - SV * sv - CODE: - if (!SvROK(sv)) - croak("argument is not a reference"); - RETVAL = (SV*)SvRV(sv); - OUTPUT: - RETVAL - -void -opnumber(name) -char * name -CODE: -{ - int i; - IV result = -1; - ST(0) = sv_newmortal(); - if (strncmp(name,"pp_",3) == 0) - name += 3; - for (i = 0; i < PL_maxo; i++) - { - if (strcmp(name, PL_op_name[i]) == 0) - { - result = i; - break; - } - } - sv_setiv(ST(0),result); -} - -void -ppname(opnum) - int opnum - CODE: - ST(0) = sv_newmortal(); - if (opnum >= 0 && opnum < PL_maxo) { - sv_setpvn(ST(0), "pp_", 3); - sv_catpv(ST(0), PL_op_name[opnum]); - } - -void -hash(sv) - SV * sv - CODE: - char *s; - STRLEN len; - U32 hash = 0; - char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */ - s = SvPV(sv, len); - PERL_HASH(hash, s, len); - sprintf(hexhash, "0x%"UVxf, (UV)hash); - ST(0) = sv_2mortal(newSVpv(hexhash, 0)); - -#define cast_I32(foo) (I32)foo -IV -cast_I32(i) - IV i - -void -minus_c() - CODE: - PL_minus_c = TRUE; - -void -save_BEGINs() - CODE: - PL_minus_c |= 0x10; - -SV * -cstring(sv) - SV * sv - CODE: - RETVAL = cstring(aTHX_ sv); - OUTPUT: - RETVAL - -SV * -cchar(sv) - SV * sv - CODE: - RETVAL = cchar(aTHX_ sv); - OUTPUT: - RETVAL - -void -threadsv_names() - PPCODE: -#ifdef USE_THREADS - int i; - STRLEN len = strlen(PL_threadsv_names); - - EXTEND(sp, len); - for (i = 0; i < len; i++) - PUSHs(sv_2mortal(newSVpvn(&PL_threadsv_names[i], 1))); -#endif - - -#define OP_next(o) o->op_next -#define OP_sibling(o) o->op_sibling -#define OP_desc(o) PL_op_desc[o->op_type] -#define OP_targ(o) o->op_targ -#define OP_type(o) o->op_type -#define OP_seq(o) o->op_seq -#define OP_flags(o) o->op_flags -#define OP_private(o) o->op_private - -MODULE = B PACKAGE = B::OP PREFIX = OP_ - -B::OP -OP_next(o) - B::OP o - -B::OP -OP_sibling(o) - B::OP o - -char * -OP_name(o) - B::OP o - CODE: - RETVAL = PL_op_name[o->op_type]; - OUTPUT: - RETVAL - - -void -OP_ppaddr(o) - B::OP o - PREINIT: - int i; - SV *sv = sv_newmortal(); - CODE: - sv_setpvn(sv, "PL_ppaddr[OP_", 13); - sv_catpv(sv, PL_op_name[o->op_type]); - for (i=13; i<SvCUR(sv); ++i) - SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]); - sv_catpv(sv, "]"); - ST(0) = sv; - -char * -OP_desc(o) - B::OP o - -PADOFFSET -OP_targ(o) - B::OP o - -U16 -OP_type(o) - B::OP o - -U16 -OP_seq(o) - B::OP o - -U8 -OP_flags(o) - B::OP o - -U8 -OP_private(o) - B::OP o - -#define UNOP_first(o) o->op_first - -MODULE = B PACKAGE = B::UNOP PREFIX = UNOP_ - -B::OP -UNOP_first(o) - B::UNOP o - -#define BINOP_last(o) o->op_last - -MODULE = B PACKAGE = B::BINOP PREFIX = BINOP_ - -B::OP -BINOP_last(o) - B::BINOP o - -#define LOGOP_other(o) o->op_other - -MODULE = B PACKAGE = B::LOGOP PREFIX = LOGOP_ - -B::OP -LOGOP_other(o) - B::LOGOP o - -MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_ - -U32 -LISTOP_children(o) - B::LISTOP o - OP * kid = NO_INIT - int i = NO_INIT - CODE: - i = 0; - for (kid = o->op_first; kid; kid = kid->op_sibling) - i++; - RETVAL = i; - OUTPUT: - RETVAL - -#define PMOP_pmreplroot(o) o->op_pmreplroot -#define PMOP_pmreplstart(o) o->op_pmreplstart -#define PMOP_pmnext(o) o->op_pmnext -#define PMOP_pmregexp(o) o->op_pmregexp -#define PMOP_pmflags(o) o->op_pmflags -#define PMOP_pmpermflags(o) o->op_pmpermflags - -MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_ - -void -PMOP_pmreplroot(o) - B::PMOP o - OP * root = NO_INIT - CODE: - ST(0) = sv_newmortal(); - root = o->op_pmreplroot; - /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */ - if (o->op_type == OP_PUSHRE) { - sv_setiv(newSVrv(ST(0), root ? - svclassnames[SvTYPE((SV*)root)] : "B::SV"), - PTR2IV(root)); - } - else { - sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root)); - } - -B::OP -PMOP_pmreplstart(o) - B::PMOP o - -B::PMOP -PMOP_pmnext(o) - B::PMOP o - -U16 -PMOP_pmflags(o) - B::PMOP o - -U16 -PMOP_pmpermflags(o) - B::PMOP o - -void -PMOP_precomp(o) - B::PMOP o - REGEXP * rx = NO_INIT - CODE: - ST(0) = sv_newmortal(); - rx = o->op_pmregexp; - if (rx) - sv_setpvn(ST(0), rx->precomp, rx->prelen); - -#define SVOP_sv(o) cSVOPo->op_sv -#define SVOP_gv(o) ((GV*)cSVOPo->op_sv) - -MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_ - -B::SV -SVOP_sv(o) - B::SVOP o - -B::GV -SVOP_gv(o) - B::SVOP o - -#define PADOP_padix(o) o->op_padix -#define PADOP_sv(o) (o->op_padix ? PL_curpad[o->op_padix] : Nullsv) -#define PADOP_gv(o) ((o->op_padix \ - && SvTYPE(PL_curpad[o->op_padix]) == SVt_PVGV) \ - ? (GV*)PL_curpad[o->op_padix] : Nullgv) - -MODULE = B PACKAGE = B::PADOP PREFIX = PADOP_ - -PADOFFSET -PADOP_padix(o) - B::PADOP o - -B::SV -PADOP_sv(o) - B::PADOP o - -B::GV -PADOP_gv(o) - B::PADOP o - -MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_ - -void -PVOP_pv(o) - B::PVOP o - CODE: - /* - * OP_TRANS uses op_pv to point to a table of 256 shorts - * whereas other PVOPs point to a null terminated string. - */ - ST(0) = sv_2mortal(newSVpv(o->op_pv, (o->op_type == OP_TRANS) ? - 256 * sizeof(short) : 0)); - -#define LOOP_redoop(o) o->op_redoop -#define LOOP_nextop(o) o->op_nextop -#define LOOP_lastop(o) o->op_lastop - -MODULE = B PACKAGE = B::LOOP PREFIX = LOOP_ - - -B::OP -LOOP_redoop(o) - B::LOOP o - -B::OP -LOOP_nextop(o) - B::LOOP o - -B::OP -LOOP_lastop(o) - B::LOOP o - -#define COP_label(o) o->cop_label -#define COP_stashpv(o) CopSTASHPV(o) -#define COP_stash(o) CopSTASH(o) -#define COP_file(o) CopFILE(o) -#define COP_cop_seq(o) o->cop_seq -#define COP_arybase(o) o->cop_arybase -#define COP_line(o) CopLINE(o) -#define COP_warnings(o) o->cop_warnings - -MODULE = B PACKAGE = B::COP PREFIX = COP_ - -char * -COP_label(o) - B::COP o - -char * -COP_stashpv(o) - B::COP o - -B::HV -COP_stash(o) - B::COP o - -char * -COP_file(o) - B::COP o - -U32 -COP_cop_seq(o) - B::COP o - -I32 -COP_arybase(o) - B::COP o - -U16 -COP_line(o) - B::COP o - -B::SV -COP_warnings(o) - B::COP o - -MODULE = B PACKAGE = B::SV PREFIX = Sv - -U32 -SvREFCNT(sv) - B::SV sv - -U32 -SvFLAGS(sv) - B::SV sv - -MODULE = B PACKAGE = B::IV PREFIX = Sv - -IV -SvIV(sv) - B::IV sv - -IV -SvIVX(sv) - B::IV sv - -UV -SvUVX(sv) - B::IV sv - - -MODULE = B PACKAGE = B::IV - -#define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv)) - -int -needs64bits(sv) - B::IV sv - -void -packiv(sv) - B::IV sv - CODE: - if (sizeof(IV) == 8) { - U32 wp[2]; - IV iv = SvIVX(sv); - /* - * The following way of spelling 32 is to stop compilers on - * 32-bit architectures from moaning about the shift count - * being >= the width of the type. Such architectures don't - * reach this code anyway (unless sizeof(IV) > 8 but then - * everything else breaks too so I'm not fussed at the moment). - */ -#ifdef UV_IS_QUAD - wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4)); -#else - wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4)); -#endif - wp[1] = htonl(iv & 0xffffffff); - ST(0) = sv_2mortal(newSVpvn((char *)wp, 8)); - } else { - U32 w = htonl((U32)SvIVX(sv)); - ST(0) = sv_2mortal(newSVpvn((char *)&w, 4)); - } - -MODULE = B PACKAGE = B::NV PREFIX = Sv - -NV -SvNV(sv) - B::NV sv - -NV -SvNVX(sv) - B::NV sv - -MODULE = B PACKAGE = B::RV PREFIX = Sv - -B::SV -SvRV(sv) - B::RV sv - -MODULE = B PACKAGE = B::PV PREFIX = Sv - -char* -SvPVX(sv) - B::PV sv - -void -SvPV(sv) - B::PV sv - CODE: - ST(0) = sv_newmortal(); - sv_setpvn(ST(0), SvPVX(sv), SvCUR(sv)); - -STRLEN -SvLEN(sv) - B::PV sv - -STRLEN -SvCUR(sv) - B::PV sv - -MODULE = B PACKAGE = B::PVMG PREFIX = Sv - -void -SvMAGIC(sv) - B::PVMG sv - MAGIC * mg = NO_INIT - PPCODE: - for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) - XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg)); - -MODULE = B PACKAGE = B::PVMG - -B::HV -SvSTASH(sv) - B::PVMG sv - -#define MgMOREMAGIC(mg) mg->mg_moremagic -#define MgPRIVATE(mg) mg->mg_private -#define MgTYPE(mg) mg->mg_type -#define MgFLAGS(mg) mg->mg_flags -#define MgOBJ(mg) mg->mg_obj -#define MgLENGTH(mg) mg->mg_len - -MODULE = B PACKAGE = B::MAGIC PREFIX = Mg - -B::MAGIC -MgMOREMAGIC(mg) - B::MAGIC mg - -U16 -MgPRIVATE(mg) - B::MAGIC mg - -char -MgTYPE(mg) - B::MAGIC mg - -U8 -MgFLAGS(mg) - B::MAGIC mg - -B::SV -MgOBJ(mg) - B::MAGIC mg - -I32 -MgLENGTH(mg) - B::MAGIC mg - -void -MgPTR(mg) - B::MAGIC mg - CODE: - ST(0) = sv_newmortal(); - if (mg->mg_ptr){ - if (mg->mg_len >= 0){ - sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len); - } else { - if (mg->mg_len == HEf_SVKEY) - sv_setsv(ST(0),newRV((SV*)mg->mg_ptr)); - } - } - -MODULE = B PACKAGE = B::PVLV PREFIX = Lv - -U32 -LvTARGOFF(sv) - B::PVLV sv - -U32 -LvTARGLEN(sv) - B::PVLV sv - -char -LvTYPE(sv) - B::PVLV sv - -B::SV -LvTARG(sv) - B::PVLV sv - -MODULE = B PACKAGE = B::BM PREFIX = Bm - -I32 -BmUSEFUL(sv) - B::BM sv - -U16 -BmPREVIOUS(sv) - B::BM sv - -U8 -BmRARE(sv) - B::BM sv - -void -BmTABLE(sv) - B::BM sv - STRLEN len = NO_INIT - char * str = NO_INIT - CODE: - str = SvPV(sv, len); - /* Boyer-Moore table is just after string and its safety-margin \0 */ - ST(0) = sv_2mortal(newSVpvn(str + len + 1, 256)); - -MODULE = B PACKAGE = B::GV PREFIX = Gv - -void -GvNAME(gv) - B::GV gv - CODE: - ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv))); - -bool -is_empty(gv) - B::GV gv - CODE: - RETVAL = GvGP(gv) == Null(GP*); - OUTPUT: - RETVAL - -B::HV -GvSTASH(gv) - B::GV gv - -B::SV -GvSV(gv) - B::GV gv - -B::IO -GvIO(gv) - B::GV gv - -B::CV -GvFORM(gv) - B::GV gv - -B::AV -GvAV(gv) - B::GV gv - -B::HV -GvHV(gv) - B::GV gv - -B::GV -GvEGV(gv) - B::GV gv - -B::CV -GvCV(gv) - B::GV gv - -U32 -GvCVGEN(gv) - B::GV gv - -U16 -GvLINE(gv) - B::GV gv - -char * -GvFILE(gv) - B::GV gv - -B::GV -GvFILEGV(gv) - B::GV gv - -MODULE = B PACKAGE = B::GV - -U32 -GvREFCNT(gv) - B::GV gv - -U8 -GvFLAGS(gv) - B::GV gv - -MODULE = B PACKAGE = B::IO PREFIX = Io - -long -IoLINES(io) - B::IO io - -long -IoPAGE(io) - B::IO io - -long -IoPAGE_LEN(io) - B::IO io - -long -IoLINES_LEFT(io) - B::IO io - -char * -IoTOP_NAME(io) - B::IO io - -B::GV -IoTOP_GV(io) - B::IO io - -char * -IoFMT_NAME(io) - B::IO io - -B::GV -IoFMT_GV(io) - B::IO io - -char * -IoBOTTOM_NAME(io) - B::IO io - -B::GV -IoBOTTOM_GV(io) - B::IO io - -short -IoSUBPROCESS(io) - B::IO io - -MODULE = B PACKAGE = B::IO - -char -IoTYPE(io) - B::IO io - -U8 -IoFLAGS(io) - B::IO io - -MODULE = B PACKAGE = B::AV PREFIX = Av - -SSize_t -AvFILL(av) - B::AV av - -SSize_t -AvMAX(av) - B::AV av - -#define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off - -IV -AvOFF(av) - B::AV av - -void -AvARRAY(av) - B::AV av - PPCODE: - if (AvFILL(av) >= 0) { - SV **svp = AvARRAY(av); - I32 i; - for (i = 0; i <= AvFILL(av); i++) - XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i])); - } - -MODULE = B PACKAGE = B::AV - -U8 -AvFLAGS(av) - B::AV av - -MODULE = B PACKAGE = B::CV PREFIX = Cv - -B::HV -CvSTASH(cv) - B::CV cv - -B::OP -CvSTART(cv) - B::CV cv - -B::OP -CvROOT(cv) - B::CV cv - -B::GV -CvGV(cv) - B::CV cv - -char * -CvFILE(cv) - B::CV cv - -long -CvDEPTH(cv) - B::CV cv - -B::AV -CvPADLIST(cv) - B::CV cv - -B::CV -CvOUTSIDE(cv) - B::CV cv - -void -CvXSUB(cv) - B::CV cv - CODE: - ST(0) = sv_2mortal(newSViv(PTR2IV(CvXSUB(cv)))); - - -void -CvXSUBANY(cv) - B::CV cv - CODE: - ST(0) = sv_2mortal(newSViv(CvXSUBANY(cv).any_iv)); - -MODULE = B PACKAGE = B::CV - -U16 -CvFLAGS(cv) - B::CV cv - - -MODULE = B PACKAGE = B::HV PREFIX = Hv - -STRLEN -HvFILL(hv) - B::HV hv - -STRLEN -HvMAX(hv) - B::HV hv - -I32 -HvKEYS(hv) - B::HV hv - -I32 -HvRITER(hv) - B::HV hv - -char * -HvNAME(hv) - B::HV hv - -B::PMOP -HvPMROOT(hv) - B::HV hv - -void -HvARRAY(hv) - B::HV hv - PPCODE: - if (HvKEYS(hv) > 0) { - SV *sv; - char *key; - I32 len; - (void)hv_iterinit(hv); - EXTEND(sp, HvKEYS(hv) * 2); - while ((sv = hv_iternextsv(hv, &key, &len))) { - PUSHs(newSVpvn(key, len)); - PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv)); - } - } diff --git a/contrib/perl5/ext/B/B/Asmdata.pm b/contrib/perl5/ext/B/B/Asmdata.pm deleted file mode 100644 index dc176be..0000000 --- a/contrib/perl5/ext/B/B/Asmdata.pm +++ /dev/null @@ -1,172 +0,0 @@ -# -# Copyright (c) 1996-1999 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. -# -# -# -# This file is autogenerated from bytecode.pl. Changes made here will be lost. -# -package B::Asmdata; -use Exporter; -@ISA = qw(Exporter); -@EXPORT_OK = qw(%insn_data @insn_name @optype @specialsv_name); -our(%insn_data, @insn_name, @optype, @specialsv_name); - -@optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP); -@specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no pWARN_ALL pWARN_NONE); - -# XXX insn_data is initialised this way because with a large -# %insn_data = (foo => [...], bar => [...], ...) initialiser -# I get a hard-to-track-down stack underflow and segfault. -$insn_data{comment} = [35, \&PUT_comment_t, "GET_comment_t"]; -$insn_data{nop} = [10, \&PUT_none, "GET_none"]; -$insn_data{ret} = [0, \&PUT_none, "GET_none"]; -$insn_data{ldsv} = [1, \&PUT_svindex, "GET_svindex"]; -$insn_data{ldop} = [2, \&PUT_opindex, "GET_opindex"]; -$insn_data{stsv} = [3, \&PUT_U32, "GET_U32"]; -$insn_data{stop} = [4, \&PUT_U32, "GET_U32"]; -$insn_data{stpv} = [5, \&PUT_U32, "GET_U32"]; -$insn_data{ldspecsv} = [6, \&PUT_U8, "GET_U8"]; -$insn_data{newsv} = [7, \&PUT_U8, "GET_U8"]; -$insn_data{newop} = [8, \&PUT_U8, "GET_U8"]; -$insn_data{newopn} = [9, \&PUT_U8, "GET_U8"]; -$insn_data{newpv} = [11, \&PUT_PV, "GET_PV"]; -$insn_data{pv_cur} = [12, \&PUT_U32, "GET_U32"]; -$insn_data{pv_free} = [13, \&PUT_none, "GET_none"]; -$insn_data{sv_upgrade} = [14, \&PUT_U8, "GET_U8"]; -$insn_data{sv_refcnt} = [15, \&PUT_U32, "GET_U32"]; -$insn_data{sv_refcnt_add} = [16, \&PUT_I32, "GET_I32"]; -$insn_data{sv_flags} = [17, \&PUT_U32, "GET_U32"]; -$insn_data{xrv} = [18, \&PUT_svindex, "GET_svindex"]; -$insn_data{xpv} = [19, \&PUT_none, "GET_none"]; -$insn_data{xiv32} = [20, \&PUT_I32, "GET_I32"]; -$insn_data{xiv64} = [21, \&PUT_IV64, "GET_IV64"]; -$insn_data{xnv} = [22, \&PUT_NV, "GET_NV"]; -$insn_data{xlv_targoff} = [23, \&PUT_U32, "GET_U32"]; -$insn_data{xlv_targlen} = [24, \&PUT_U32, "GET_U32"]; -$insn_data{xlv_targ} = [25, \&PUT_svindex, "GET_svindex"]; -$insn_data{xlv_type} = [26, \&PUT_U8, "GET_U8"]; -$insn_data{xbm_useful} = [27, \&PUT_I32, "GET_I32"]; -$insn_data{xbm_previous} = [28, \&PUT_U16, "GET_U16"]; -$insn_data{xbm_rare} = [29, \&PUT_U8, "GET_U8"]; -$insn_data{xfm_lines} = [30, \&PUT_I32, "GET_I32"]; -$insn_data{xio_lines} = [31, \&PUT_I32, "GET_I32"]; -$insn_data{xio_page} = [32, \&PUT_I32, "GET_I32"]; -$insn_data{xio_page_len} = [33, \&PUT_I32, "GET_I32"]; -$insn_data{xio_lines_left} = [34, \&PUT_I32, "GET_I32"]; -$insn_data{xio_top_name} = [36, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{xio_top_gv} = [37, \&PUT_svindex, "GET_svindex"]; -$insn_data{xio_fmt_name} = [38, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{xio_fmt_gv} = [39, \&PUT_svindex, "GET_svindex"]; -$insn_data{xio_bottom_name} = [40, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{xio_bottom_gv} = [41, \&PUT_svindex, "GET_svindex"]; -$insn_data{xio_subprocess} = [42, \&PUT_U16, "GET_U16"]; -$insn_data{xio_type} = [43, \&PUT_U8, "GET_U8"]; -$insn_data{xio_flags} = [44, \&PUT_U8, "GET_U8"]; -$insn_data{xcv_stash} = [45, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_start} = [46, \&PUT_opindex, "GET_opindex"]; -$insn_data{xcv_root} = [47, \&PUT_opindex, "GET_opindex"]; -$insn_data{xcv_gv} = [48, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_file} = [49, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{xcv_depth} = [50, \&PUT_I32, "GET_I32"]; -$insn_data{xcv_padlist} = [51, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_outside} = [52, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_flags} = [53, \&PUT_U16, "GET_U16"]; -$insn_data{av_extend} = [54, \&PUT_I32, "GET_I32"]; -$insn_data{av_push} = [55, \&PUT_svindex, "GET_svindex"]; -$insn_data{xav_fill} = [56, \&PUT_I32, "GET_I32"]; -$insn_data{xav_max} = [57, \&PUT_I32, "GET_I32"]; -$insn_data{xav_flags} = [58, \&PUT_U8, "GET_U8"]; -$insn_data{xhv_riter} = [59, \&PUT_I32, "GET_I32"]; -$insn_data{xhv_name} = [60, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{hv_store} = [61, \&PUT_svindex, "GET_svindex"]; -$insn_data{sv_magic} = [62, \&PUT_U8, "GET_U8"]; -$insn_data{mg_obj} = [63, \&PUT_svindex, "GET_svindex"]; -$insn_data{mg_private} = [64, \&PUT_U16, "GET_U16"]; -$insn_data{mg_flags} = [65, \&PUT_U8, "GET_U8"]; -$insn_data{mg_pv} = [66, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{xmg_stash} = [67, \&PUT_svindex, "GET_svindex"]; -$insn_data{gv_fetchpv} = [68, \&PUT_strconst, "GET_strconst"]; -$insn_data{gv_stashpv} = [69, \&PUT_strconst, "GET_strconst"]; -$insn_data{gp_sv} = [70, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_refcnt} = [71, \&PUT_U32, "GET_U32"]; -$insn_data{gp_refcnt_add} = [72, \&PUT_I32, "GET_I32"]; -$insn_data{gp_av} = [73, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_hv} = [74, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_cv} = [75, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_file} = [76, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{gp_io} = [77, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_form} = [78, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_cvgen} = [79, \&PUT_U32, "GET_U32"]; -$insn_data{gp_line} = [80, \&PUT_U16, "GET_U16"]; -$insn_data{gp_share} = [81, \&PUT_svindex, "GET_svindex"]; -$insn_data{xgv_flags} = [82, \&PUT_U8, "GET_U8"]; -$insn_data{op_next} = [83, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_sibling} = [84, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_ppaddr} = [85, \&PUT_strconst, "GET_strconst"]; -$insn_data{op_targ} = [86, \&PUT_U32, "GET_U32"]; -$insn_data{op_type} = [87, \&PUT_U16, "GET_U16"]; -$insn_data{op_seq} = [88, \&PUT_U16, "GET_U16"]; -$insn_data{op_flags} = [89, \&PUT_U8, "GET_U8"]; -$insn_data{op_private} = [90, \&PUT_U8, "GET_U8"]; -$insn_data{op_first} = [91, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_last} = [92, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_other} = [93, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_pmreplroot} = [94, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_pmreplrootgv} = [95, \&PUT_svindex, "GET_svindex"]; -$insn_data{op_pmreplstart} = [96, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_pmnext} = [97, \&PUT_opindex, "GET_opindex"]; -$insn_data{pregcomp} = [98, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{op_pmflags} = [99, \&PUT_U16, "GET_U16"]; -$insn_data{op_pmpermflags} = [100, \&PUT_U16, "GET_U16"]; -$insn_data{op_sv} = [101, \&PUT_svindex, "GET_svindex"]; -$insn_data{op_padix} = [102, \&PUT_U32, "GET_U32"]; -$insn_data{op_pv} = [103, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{op_pv_tr} = [104, \&PUT_op_tr_array, "GET_op_tr_array"]; -$insn_data{op_redoop} = [105, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_nextop} = [106, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_lastop} = [107, \&PUT_opindex, "GET_opindex"]; -$insn_data{cop_label} = [108, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{cop_stashpv} = [109, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{cop_file} = [110, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{cop_seq} = [111, \&PUT_U32, "GET_U32"]; -$insn_data{cop_arybase} = [112, \&PUT_I32, "GET_I32"]; -$insn_data{cop_line} = [113, \&PUT_U16, "GET_U16"]; -$insn_data{cop_warnings} = [114, \&PUT_svindex, "GET_svindex"]; -$insn_data{main_start} = [115, \&PUT_opindex, "GET_opindex"]; -$insn_data{main_root} = [116, \&PUT_opindex, "GET_opindex"]; -$insn_data{curpad} = [117, \&PUT_svindex, "GET_svindex"]; -$insn_data{push_begin} = [118, \&PUT_svindex, "GET_svindex"]; -$insn_data{push_init} = [119, \&PUT_svindex, "GET_svindex"]; -$insn_data{push_end} = [120, \&PUT_svindex, "GET_svindex"]; - -my ($insn_name, $insn_data); -while (($insn_name, $insn_data) = each %insn_data) { - $insn_name[$insn_data->[0]] = $insn_name; -} -# Fill in any gaps -@insn_name = map($_ || "unused", @insn_name); - -1; - -__END__ - -=head1 NAME - -B::Asmdata - Autogenerated data about Perl ops, used to generate bytecode - -=head1 SYNOPSIS - - use Asmdata; - -=head1 DESCRIPTION - -See F<ext/B/B/Asmdata.pm>. - -=head1 AUTHOR - -Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> - -=cut diff --git a/contrib/perl5/ext/B/B/Assembler.pm b/contrib/perl5/ext/B/B/Assembler.pm deleted file mode 100644 index 5e798ce..0000000 --- a/contrib/perl5/ext/B/B/Assembler.pm +++ /dev/null @@ -1,285 +0,0 @@ -# Assembler.pm -# -# Copyright (c) 1996 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. - -package B::Assembler; -use Exporter; -use B qw(ppname); -use B::Asmdata qw(%insn_data @insn_name); -use Config qw(%Config); -require ByteLoader; # we just need its $VERSIOM - -@ISA = qw(Exporter); -@EXPORT_OK = qw(assemble_fh newasm endasm assemble); -$VERSION = 0.02; - -use strict; -my %opnumber; -my ($i, $opname); -for ($i = 0; defined($opname = ppname($i)); $i++) { - $opnumber{$opname} = $i; -} - -my($linenum, $errors, $out); # global state, set up by newasm - -sub error { - my $str = shift; - warn "$linenum: $str\n"; - $errors++; -} - -my $debug = 0; -sub debug { $debug = shift } - -# -# First define all the data conversion subs to which Asmdata will refer -# - -sub B::Asmdata::PUT_U8 { - my $arg = shift; - my $c = uncstring($arg); - if (defined($c)) { - if (length($c) != 1) { - error "argument for U8 is too long: $c"; - $c = substr($c, 0, 1); - } - } else { - $c = chr($arg); - } - return $c; -} - -sub B::Asmdata::PUT_U16 { pack("S", $_[0]) } -sub B::Asmdata::PUT_U32 { pack("L", $_[0]) } -sub B::Asmdata::PUT_I32 { pack("L", $_[0]) } -sub B::Asmdata::PUT_NV { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...) - # may not even be portable between compilers -sub B::Asmdata::PUT_objindex { pack("L", $_[0]) } # could allow names here -sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex } -sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex } -sub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex } - -sub B::Asmdata::PUT_strconst { - my $arg = shift; - $arg = uncstring($arg); - if (!defined($arg)) { - error "bad string constant: $arg"; - return ""; - } - if ($arg =~ s/\0//g) { - error "string constant argument contains NUL: $arg"; - } - return $arg . "\0"; -} - -sub B::Asmdata::PUT_pvcontents { - my $arg = shift; - error "extraneous argument: $arg" if defined $arg; - return ""; -} -sub B::Asmdata::PUT_PV { - my $arg = shift; - $arg = uncstring($arg); - error "bad string argument: $arg" unless defined($arg); - return pack("L", length($arg)) . $arg; -} -sub B::Asmdata::PUT_comment_t { - my $arg = shift; - $arg = uncstring($arg); - error "bad string argument: $arg" unless defined($arg); - if ($arg =~ s/\n//g) { - error "comment argument contains linefeed: $arg"; - } - return $arg . "\n"; -} -sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above -sub B::Asmdata::PUT_none { - my $arg = shift; - error "extraneous argument: $arg" if defined $arg; - return ""; -} -sub B::Asmdata::PUT_op_tr_array { - my $arg = shift; - my @ary = split(/\s*,\s*/, $arg); - if (@ary != 256) { - error "wrong number of arguments to op_tr_array"; - @ary = (0) x 256; - } - return pack("S256", @ary); -} -# XXX Check this works -sub B::Asmdata::PUT_IV64 { - my $arg = shift; - return pack("LL", $arg >> 32, $arg & 0xffffffff); -} - -my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a", - b => "\b", f => "\f", v => "\013"); - -sub uncstring { - my $s = shift; - $s =~ s/^"// and $s =~ s/"$// or return undef; - $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg; - return $s; -} - -sub strip_comments { - my $stmt = shift; - # Comments only allowed in instructions which don't take string arguments - $stmt =~ s{ - (?sx) # Snazzy extended regexp coming up. Also, treat - # string as a single line so .* eats \n characters. - ^\s* # Ignore leading whitespace - ( - [^"]* # A double quote '"' indicates a string argument. If we - # find a double quote, the match fails and we strip nothing. - ) - \s*\# # Any amount of whitespace plus the comment marker... - .*$ # ...which carries on to end-of-string. - }{$1}; # Keep only the instruction and optional argument. - return $stmt; -} - -# create the ByteCode header: magic, archname, ByteLoader $VERSION, ivsize, -# ptrsize, byteorder -# nvtype is irrelevant (floats are stored as strings) -# byteorder is strconst not U32 because of varying size issues - -sub gen_header { - my $header = ""; - - $header .= B::Asmdata::PUT_U32(0x43424c50); # 'PLBC' - $header .= B::Asmdata::PUT_strconst('"' . $Config{archname}. '"'); - $header .= B::Asmdata::PUT_strconst(qq["$ByteLoader::VERSION"]); - $header .= B::Asmdata::PUT_U32($Config{ivsize}); - $header .= B::Asmdata::PUT_U32($Config{ptrsize}); - $header .= B::Asmdata::PUT_strconst(sprintf(qq["0x%s"], $Config{byteorder})); - - $header; -} - -sub parse_statement { - my $stmt = shift; - my ($insn, $arg) = $stmt =~ m{ - (?sx) - ^\s* # allow (but ignore) leading whitespace - (.*?) # Instruction continues up until... - (?: # ...an optional whitespace+argument group - \s+ # first whitespace. - (.*) # The argument is all the rest (newlines included). - )?$ # anchor at end-of-line - }; - if (defined($arg)) { - if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) { - $arg = hex($arg); - } elsif ($arg =~ s/^0(?=[0-7]+$)//) { - $arg = oct($arg); - } elsif ($arg =~ /^pp_/) { - $arg =~ s/\s*$//; # strip trailing whitespace - my $opnum = $opnumber{$arg}; - if (defined($opnum)) { - $arg = $opnum; - } else { - error qq(No such op type "$arg"); - $arg = 0; - } - } - } - return ($insn, $arg); -} - -sub assemble_insn { - my ($insn, $arg) = @_; - my $data = $insn_data{$insn}; - if (defined($data)) { - my ($bytecode, $putsub) = @{$data}[0, 1]; - my $argcode = &$putsub($arg); - return chr($bytecode).$argcode; - } else { - error qq(no such instruction "$insn"); - return ""; - } -} - -sub assemble_fh { - my ($fh, $out) = @_; - my $line; - my $asm = newasm($out); - while ($line = <$fh>) { - assemble($line); - } - endasm(); -} - -sub newasm { - my($outsub) = @_; - - die "Invalid printing routine for B::Assembler\n" unless ref $outsub eq 'CODE'; - die <<EOD if ref $out; -Can't have multiple byteassembly sessions at once! - (perhaps you forgot an endasm()?) -EOD - - $linenum = $errors = 0; - $out = $outsub; - - $out->(gen_header()); -} - -sub endasm { - if ($errors) { - die "There were $errors assembly errors\n"; - } - $linenum = $errors = $out = 0; -} - -sub assemble { - my($line) = @_; - my ($insn, $arg); - $linenum++; - chomp $line; - if ($debug) { - my $quotedline = $line; - $quotedline =~ s/\\/\\\\/g; - $quotedline =~ s/"/\\"/g; - $out->(assemble_insn("comment", qq("$quotedline"))); - } - $line = strip_comments($line) or next; - ($insn, $arg) = parse_statement($line); - $out->(assemble_insn($insn, $arg)); - if ($debug) { - $out->(assemble_insn("nop", undef)); - } -} - -1; - -__END__ - -=head1 NAME - -B::Assembler - Assemble Perl bytecode - -=head1 SYNOPSIS - - use B::Assembler qw(newasm endasm assemble); - newasm(\&printsub); # sets up for assembly - assemble($buf); # assembles one line - endasm(); # closes down - - use B::Assembler qw(assemble_fh); - assemble_fh($fh, \&printsub); # assemble everything in $fh - -=head1 DESCRIPTION - -See F<ext/B/B/Assembler.pm>. - -=head1 AUTHORS - -Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> -Per-statement interface by Benjamin Stuhl, C<sho_pi@hotmail.com> - -=cut diff --git a/contrib/perl5/ext/B/B/Bblock.pm b/contrib/perl5/ext/B/B/Bblock.pm deleted file mode 100644 index fe7fc52..0000000 --- a/contrib/perl5/ext/B/B/Bblock.pm +++ /dev/null @@ -1,180 +0,0 @@ -package B::Bblock; -use Exporter (); -@ISA = "Exporter"; -@EXPORT_OK = qw(find_leaders); - -use B qw(peekop walkoptree walkoptree_exec - main_root main_start svref_2object - OPf_SPECIAL OPf_STACKED ); - -use B::Terse; -use strict; - -my $bblock; -my @bblock_ends; - -sub mark_leader { - my $op = shift; - if ($$op) { - $bblock->{$$op} = $op; - } -} - -sub remove_sortblock{ - foreach (keys %$bblock){ - my $leader=$$bblock{$_}; - delete $$bblock{$_} if( $leader == 0); - } -} -sub find_leaders { - my ($root, $start) = @_; - $bblock = {}; - mark_leader($start) if ( ref $start ne "B::NULL" ); - walkoptree($root, "mark_if_leader") if ((ref $root) ne "B::NULL") ; - remove_sortblock(); - return $bblock; -} - -# Debugging -sub walk_bblocks { - my ($root, $start) = @_; - my ($op, $lastop, $leader, $bb); - $bblock = {}; - mark_leader($start); - walkoptree($root, "mark_if_leader"); - my @leaders = values %$bblock; - while ($leader = shift @leaders) { - $lastop = $leader; - $op = $leader->next; - while ($$op && !exists($bblock->{$$op})) { - $bblock->{$$op} = $leader; - $lastop = $op; - $op = $op->next; - } - push(@bblock_ends, [$leader, $lastop]); - } - foreach $bb (@bblock_ends) { - ($leader, $lastop) = @$bb; - printf "%s .. %s\n", peekop($leader), peekop($lastop); - for ($op = $leader; $$op != $$lastop; $op = $op->next) { - printf " %s\n", peekop($op); - } - printf " %s\n", peekop($lastop); - } - print "-------\n"; - walkoptree_exec($start, "terse"); -} - -sub walk_bblocks_obj { - my $cvref = shift; - my $cv = svref_2object($cvref); - walk_bblocks($cv->ROOT, $cv->START); -} - -sub B::OP::mark_if_leader {} - -sub B::COP::mark_if_leader { - my $op = shift; - if ($op->label) { - mark_leader($op); - } -} - -sub B::LOOP::mark_if_leader { - my $op = shift; - mark_leader($op->next); - mark_leader($op->nextop); - mark_leader($op->redoop); - mark_leader($op->lastop->next); -} - -sub B::LOGOP::mark_if_leader { - my $op = shift; - my $opname = $op->name; - mark_leader($op->next); - if ($opname eq "entertry") { - mark_leader($op->other->next); - } else { - mark_leader($op->other); - } -} - -sub B::LISTOP::mark_if_leader { - my $op = shift; - my $first=$op->first; - $first=$first->next while ($first->name eq "null"); - mark_leader($op->first) unless (exists( $bblock->{$$first})); - mark_leader($op->next); - if ($op->name eq "sort" and $op->flags & OPf_SPECIAL - and $op->flags & OPf_STACKED){ - my $root=$op->first->sibling->first; - my $leader=$root->first; - $bblock->{$$leader} = 0; - } -} - -sub B::PMOP::mark_if_leader { - my $op = shift; - if ($op->name ne "pushre") { - my $replroot = $op->pmreplroot; - if ($$replroot) { - mark_leader($replroot); - mark_leader($op->next); - mark_leader($op->pmreplstart); - } - } -} - -# PMOP stuff omitted - -sub compile { - my @options = @_; - B::clearsym(); - if (@options) { - return sub { - my $objname; - foreach $objname (@options) { - $objname = "main::$objname" unless $objname =~ /::/; - eval "walk_bblocks_obj(\\&$objname)"; - die "walk_bblocks_obj(\\&$objname) failed: $@" if $@; - } - } - } else { - return sub { walk_bblocks(main_root, main_start) }; - } -} - -# Basic block leaders: -# Any COP (pp_nextstate) with a non-NULL label -# [The op after a pp_enter] Omit -# [The op after a pp_entersub. Don't count this one.] -# The ops pointed at by nextop, redoop and lastop->op_next of a LOOP -# The ops pointed at by op_next and op_other of a LOGOP, except -# for pp_entertry which has op_next and op_other->op_next -# The op pointed at by op_pmreplstart of a PMOP -# The op pointed at by op_other->op_pmreplstart of pp_substcont? -# [The op after a pp_return] Omit - -1; - -__END__ - -=head1 NAME - -B::Bblock - Walk basic blocks - -=head1 SYNOPSIS - - perl -MO=Bblock[,OPTIONS] foo.pl - -=head1 DESCRIPTION - -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 - -Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> - -=cut diff --git a/contrib/perl5/ext/B/B/Bytecode.pm b/contrib/perl5/ext/B/B/Bytecode.pm deleted file mode 100644 index 54d7c53..0000000 --- a/contrib/perl5/ext/B/B/Bytecode.pm +++ /dev/null @@ -1,998 +0,0 @@ -# Bytecode.pm -# -# Copyright (c) 1996-1998 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. -# -package B::Bytecode; - -use strict; -use Carp; -use B qw(main_cv main_root main_start comppadlist - class peekop walkoptree svref_2object cstring walksymtable - init_av begin_av end_av - SVf_POK SVp_POK SVf_IOK SVp_IOK SVf_NOK SVp_NOK - SVf_READONLY GVf_IMPORTED_AV GVf_IMPORTED_CV GVf_IMPORTED_HV - GVf_IMPORTED_SV SVTYPEMASK - ); -use B::Asmdata qw(@optype @specialsv_name); -use B::Assembler qw(newasm endasm assemble); - -my %optype_enum; -my $i; -for ($i = 0; $i < @optype; $i++) { - $optype_enum{$optype[$i]} = $i; -} - -# Following is SVf_POK|SVp_POK -# XXX Shouldn't be hardwired -sub POK () { SVf_POK|SVp_POK } - -# Following is SVf_IOK|SVp_IOK -# XXX Shouldn't be hardwired -sub IOK () { SVf_IOK|SVp_IOK } - -# Following is SVf_NOK|SVp_NOK -# XXX Shouldn't be hardwired -sub NOK () { SVf_NOK|SVp_NOK } - -# nonexistant flags (see B::GV::bytecode for usage) -sub GVf_IMPORTED_IO () { 0; } -sub GVf_IMPORTED_FORM () { 0; } - -my ($verbose, $no_assemble, $debug_bc, $debug_cv); -my @packages; # list of packages to compile - -sub asm (@) { # print replacement that knows about assembling - if ($no_assemble) { - print @_; - } else { - my $buf = join '', @_; - assemble($_) for (split /\n/, $buf); - } -} - -sub asmf (@) { # printf replacement that knows about assembling - if ($no_assemble) { - printf shift(), @_; - } else { - my $format = shift; - my $buf = sprintf $format, @_; - assemble($_) for (split /\n/, $buf); - } -} - -# Optimisation options. On the command line, use hyphens instead of -# underscores for compatibility with gcc-style options. We use -# underscores here because they are OK in (strict) barewords. -my ($compress_nullops, $omit_seq, $bypass_nullops); -my %optimise = (compress_nullops => \$compress_nullops, - omit_sequence_numbers => \$omit_seq, - bypass_nullops => \$bypass_nullops); - -my $strip_syntree; # this is left here in case stripping the - # syntree ever becomes safe again - # -- BKS, June 2000 - -my $nextix = 0; -my %symtable; # maps object addresses to object indices. - # Filled in at allocation (newsv/newop) time. - -my %saved; # maps object addresses (for SVish classes) to "saved yet?" - # flag. Set at FOO::bytecode time usually by SV::bytecode. - # Manipulated via saved(), mark_saved(), unmark_saved(). - -my %strtable; # maps shared strings to object indices - # Filled in at allocation (pvix) time - -my $svix = -1; # we keep track of when the sv register contains an element - # of the object table to avoid unnecessary repeated - # consecutive ldsv instructions. - -my $opix = -1; # Ditto for the op register. - -sub ldsv { - my $ix = shift; - if ($ix != $svix) { - asm "ldsv $ix\n"; - $svix = $ix; - } -} - -sub stsv { - my $ix = shift; - asm "stsv $ix\n"; - $svix = $ix; -} - -sub set_svix { - $svix = shift; -} - -sub ldop { - my $ix = shift; - if ($ix != $opix) { - asm "ldop $ix\n"; - $opix = $ix; - } -} - -sub stop { - my $ix = shift; - asm "stop $ix\n"; - $opix = $ix; -} - -sub set_opix { - $opix = shift; -} - -sub pvstring { - my $str = shift; - if (defined($str)) { - return cstring($str . "\0"); - } else { - return '""'; - } -} - -sub nv { - # print full precision - my $str = sprintf "%.40f", $_[0]; - $str =~ s/0+$//; # remove trailing zeros - $str =~ s/\.$/.0/; - return $str; -} - -sub saved { $saved{${$_[0]}} } -sub mark_saved { $saved{${$_[0]}} = 1 } -sub unmark_saved { $saved{${$_[0]}} = 0 } - -sub debug { $debug_bc = shift } - -sub pvix { # save a shared PV (mainly for COPs) - return $strtable{$_[0]} if defined($strtable{$_[0]}); - asmf "newpv %s\n", pvstring($_[0]); - my $ix = $nextix++; - $strtable{$_[0]} = $ix; - asmf "stpv %d\n", $ix; - return $ix; -} - -sub B::OBJECT::nyi { - my $obj = shift; - warn sprintf("bytecode save method for %s (0x%x) not yet implemented\n", - class($obj), $$obj); -} - -# -# objix may stomp on the op register (for op objects) -# or the sv register (for SV objects) -# -sub B::OBJECT::objix { - my $obj = shift; - my $ix = $symtable{$$obj}; - if (defined($ix)) { - return $ix; - } else { - $obj->newix($nextix); - return $symtable{$$obj} = $nextix++; - } -} - -sub B::SV::newix { - my ($sv, $ix) = @_; - asmf "newsv %d\t# %s\n", $sv->FLAGS & SVTYPEMASK, class($sv); - stsv($ix); -} - -sub B::GV::newix { - my ($gv, $ix) = @_; - my $gvname = $gv->NAME; - my $name = cstring($gv->STASH->NAME . "::" . $gvname); - asm "gv_fetchpv $name\n"; - stsv($ix); -} - -sub B::HV::newix { - my ($hv, $ix) = @_; - my $name = $hv->NAME; - if ($name) { - # It's a stash - asmf "gv_stashpv %s\n", cstring($name); - stsv($ix); - } else { - # It's an ordinary HV. Fall back to ordinary newix method - $hv->B::SV::newix($ix); - } -} - -sub B::SPECIAL::newix { - my ($sv, $ix) = @_; - # Special case. $$sv is not the address of the SV but an - # index into svspecialsv_list. - asmf "ldspecsv $$sv\t# %s\n", $specialsv_name[$$sv]; - stsv($ix); -} - -sub B::OP::newix { - my ($op, $ix) = @_; - my $class = class($op); - my $typenum = $optype_enum{$class}; - croak("OP::newix: can't understand class $class") unless defined($typenum); - asm "newop $typenum\t# $class\n"; - stop($ix); -} - -sub B::OP::walkoptree_debug { - my $op = shift; - warn(sprintf("walkoptree: %s\n", peekop($op))); -} - -sub B::OP::bytecode { - my $op = shift; - my $next = $op->next; - my $nextix; - my $sibix = $op->sibling->objix unless $strip_syntree; - my $ix = $op->objix; - my $type = $op->type; - - if ($bypass_nullops) { - $next = $next->next while $$next && $next->type == 0; - } - $nextix = $next->objix; - - asmf "# %s\n", peekop($op) if $debug_bc; - ldop($ix); - asm "op_next $nextix\n"; - asm "op_sibling $sibix\n" unless $strip_syntree; - asmf "op_type %s\t# %d\n", "pp_" . $op->name, $type; - asmf("op_seq %d\n", $op->seq) unless $omit_seq; - if ($type || !$compress_nullops) { - asmf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n", - $op->targ, $op->flags, $op->private; - } -} - -sub B::UNOP::bytecode { - my $op = shift; - my $firstix = $op->first->objix unless $strip_syntree; - $op->B::OP::bytecode; - if (($op->type || !$compress_nullops) && !$strip_syntree) { - asm "op_first $firstix\n"; - } -} - -sub B::LOGOP::bytecode { - my $op = shift; - my $otherix = $op->other->objix; - $op->B::UNOP::bytecode; - asm "op_other $otherix\n"; -} - -sub B::SVOP::bytecode { - my $op = shift; - my $sv = $op->sv; - my $svix = $sv->objix; - $op->B::OP::bytecode; - asm "op_sv $svix\n"; - $sv->bytecode; -} - -sub B::PADOP::bytecode { - my $op = shift; - my $padix = $op->padix; - $op->B::OP::bytecode; - asm "op_padix $padix\n"; -} - -sub B::PVOP::bytecode { - my $op = shift; - my $pv = $op->pv; - $op->B::OP::bytecode; - # - # This would be easy except that OP_TRANS uses a PVOP to store an - # endian-dependent array of 256 shorts instead of a plain string. - # - if ($op->name eq "trans") { - my @shorts = unpack("s256", $pv); # assembler handles endianness - asm "op_pv_tr ", join(",", @shorts), "\n"; - } else { - asmf "newpv %s\nop_pv\n", pvstring($pv); - } -} - -sub B::BINOP::bytecode { - my $op = shift; - my $lastix = $op->last->objix unless $strip_syntree; - $op->B::UNOP::bytecode; - if (($op->type || !$compress_nullops) && !$strip_syntree) { - asm "op_last $lastix\n"; - } -} - -sub B::LOOP::bytecode { - my $op = shift; - my $redoopix = $op->redoop->objix; - my $nextopix = $op->nextop->objix; - my $lastopix = $op->lastop->objix; - $op->B::LISTOP::bytecode; - asm "op_redoop $redoopix\nop_nextop $nextopix\nop_lastop $lastopix\n"; -} - -sub B::COP::bytecode { - my $op = shift; - my $file = $op->file; - my $line = $op->line; - if ($debug_bc) { # do this early to aid debugging - asmf "# line %s:%d\n", $file, $line; - } - my $stashpv = $op->stashpv; - my $warnings = $op->warnings; - my $warningsix = $warnings->objix; - my $labelix = pvix($op->label); - my $stashix = pvix($stashpv); - my $fileix = pvix($file); - $warnings->bytecode; - $op->B::OP::bytecode; - asmf <<"EOT", $labelix, $stashix, $op->cop_seq, $fileix, $op->arybase; -cop_label %d -cop_stashpv %d -cop_seq %d -cop_file %d -cop_arybase %d -cop_line $line -cop_warnings $warningsix -EOT -} - -sub B::PMOP::bytecode { - my $op = shift; - my $replroot = $op->pmreplroot; - my $replrootix = $replroot->objix; - my $replstartix = $op->pmreplstart->objix; - my $opname = $op->name; - # pmnext is corrupt in some PMOPs (see misc.t for example) - #my $pmnextix = $op->pmnext->objix; - - if ($$replroot) { - # OP_PUSHRE (a mutated version of OP_MATCH for the regexp - # argument to a split) stores a GV in op_pmreplroot instead - # of a substitution syntax tree. We don't want to walk that... - if ($opname eq "pushre") { - $replroot->bytecode; - } else { - walkoptree($replroot, "bytecode"); - } - } - $op->B::LISTOP::bytecode; - if ($opname eq "pushre") { - asmf "op_pmreplrootgv $replrootix\n"; - } else { - asm "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n"; - } - my $re = pvstring($op->precomp); - # op_pmnext omitted since a perl bug means it's sometime corrupt - asmf <<"EOT", $op->pmflags, $op->pmpermflags; -op_pmflags 0x%x -op_pmpermflags 0x%x -newpv $re -pregcomp -EOT -} - -sub B::SV::bytecode { - my $sv = shift; - return if saved($sv); - my $ix = $sv->objix; - my $refcnt = $sv->REFCNT; - my $flags = sprintf("0x%x", $sv->FLAGS); - ldsv($ix); - asm "sv_refcnt $refcnt\nsv_flags $flags\n"; - mark_saved($sv); -} - -sub B::PV::bytecode { - my $sv = shift; - return if saved($sv); - $sv->B::SV::bytecode; - asmf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK; -} - -sub B::IV::bytecode { - my $sv = shift; - return if saved($sv); - my $iv = $sv->IVX; - $sv->B::SV::bytecode; - asmf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32" if $sv->FLAGS & IOK; # could be PVNV -} - -sub B::NV::bytecode { - my $sv = shift; - return if saved($sv); - $sv->B::SV::bytecode; - asmf "xnv %s\n", nv($sv->NVX); -} - -sub B::RV::bytecode { - my $sv = shift; - return if saved($sv); - my $rv = $sv->RV; - my $rvix = $rv->objix; - $rv->bytecode; - $sv->B::SV::bytecode; - asm "xrv $rvix\n"; -} - -sub B::PVIV::bytecode { - my $sv = shift; - return if saved($sv); - my $iv = $sv->IVX; - $sv->B::PV::bytecode; - asmf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32"; -} - -sub B::PVNV::bytecode { - my $sv = shift; - my $flag = shift || 0; - # The $flag argument is passed through PVMG::bytecode by BM::bytecode - # and AV::bytecode and indicates special handling. $flag = 1 is used by - # BM::bytecode and means that we should ensure we save the whole B-M - # table. It consists of 257 bytes (256 char array plus a final \0) - # which follow the ordinary PV+\0 and the 257 bytes are *not* reflected - # in SvCUR. $flag = 2 is used by AV::bytecode and means that we only - # call SV::bytecode instead of saving PV and calling NV::bytecode since - # PV/NV/IV stuff is different for AVs. - return if saved($sv); - if ($flag == 2) { - $sv->B::SV::bytecode; - } else { - my $pv = $sv->PV; - $sv->B::IV::bytecode; - asmf "xnv %s\n", nv($sv->NVX); - if ($flag == 1) { - $pv .= "\0" . $sv->TABLE; - asmf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257; - } else { - asmf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK; - } - } -} - -sub B::PVMG::bytecode { - my ($sv, $flag) = @_; - # See B::PVNV::bytecode for an explanation of $flag. - return if saved($sv); - # XXX We assume SvSTASH is already saved and don't save it later ourselves - my $stashix = $sv->SvSTASH->objix; - my @mgchain = $sv->MAGIC; - my (@mgobjix, $mg); - # - # We need to traverse the magic chain and get objix for each OBJ - # field *before* we do B::PVNV::bytecode since objix overwrites - # the sv register. However, we need to write the magic-saving - # bytecode *after* B::PVNV::bytecode since sv isn't initialised - # to refer to $sv until then. - # - @mgobjix = map($_->OBJ->objix, @mgchain); - $sv->B::PVNV::bytecode($flag); - asm "xmg_stash $stashix\n"; - foreach $mg (@mgchain) { - asmf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n", - cstring($mg->TYPE), shift(@mgobjix), pvstring($mg->PTR); - } -} - -sub B::PVLV::bytecode { - my $sv = shift; - return if saved($sv); - $sv->B::PVMG::bytecode; - asmf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE); -xlv_targoff %d -xlv_targlen %d -xlv_type %s -EOT -} - -sub B::BM::bytecode { - my $sv = shift; - return if saved($sv); - # See PVNV::bytecode for an explanation of what the argument does - $sv->B::PVMG::bytecode(1); - asmf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n", - $sv->USEFUL, $sv->PREVIOUS, $sv->RARE; -} - -sub empty_gv { # is a GV empty except for imported stuff? - my $gv = shift; - - return 0 if ($gv->SV->FLAGS & SVTYPEMASK); # sv not SVt_NULL - my @subfield_names = qw(AV HV CV FORM IO); - @subfield_names = grep {; - no strict 'refs'; - !($gv->GvFLAGS & ${\"GVf_IMPORTED_$_"}->()) && ${$gv->$_()}; - } @subfield_names; - return scalar @subfield_names; -} - -sub B::GV::bytecode { - my $gv = shift; - return if saved($gv); - return unless grep { $_ eq $gv->STASH->NAME; } @packages; - return if $gv->NAME =~ m/^\(/; # ignore overloads - they'll be rebuilt - my $ix = $gv->objix; - mark_saved($gv); - ldsv($ix); - asmf <<"EOT", $gv->FLAGS, $gv->GvFLAGS; -sv_flags 0x%x -xgv_flags 0x%x -EOT - my $refcnt = $gv->REFCNT; - asmf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1; - return if $gv->is_empty; - asmf <<"EOT", $gv->LINE, pvix($gv->FILE); -gp_line %d -gp_file %d -EOT - my $gvname = $gv->NAME; - my $name = cstring($gv->STASH->NAME . "::" . $gvname); - my $egv = $gv->EGV; - my $egvix = $egv->objix; - my $gvrefcnt = $gv->GvREFCNT; - asmf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1; - if ($gvrefcnt > 1 && $ix != $egvix) { - asm "gp_share $egvix\n"; - } else { - if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) { - my $i; - my @subfield_names = qw(SV AV HV CV FORM IO); - @subfield_names = grep {; - no strict 'refs'; - !($gv->GvFLAGS & ${\"GVf_IMPORTED_$_"}->()); - } @subfield_names; - my @subfields = map($gv->$_(), @subfield_names); - my @ixes = map($_->objix, @subfields); - # Reset sv register for $gv - ldsv($ix); - for ($i = 0; $i < @ixes; $i++) { - asmf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; - } - # Now save all the subfields - my $sv; - foreach $sv (@subfields) { - $sv->bytecode; - } - } - } -} - -sub B::HV::bytecode { - my $hv = shift; - return if saved($hv); - mark_saved($hv); - my $name = $hv->NAME; - my $ix = $hv->objix; - if (!$name) { - # It's an ordinary HV. Stashes have NAME set and need no further - # saving beyond the gv_stashpv that $hv->objix already ensures. - my @contents = $hv->ARRAY; - my ($i, @ixes); - for ($i = 1; $i < @contents; $i += 2) { - push(@ixes, $contents[$i]->objix); - } - for ($i = 1; $i < @contents; $i += 2) { - $contents[$i]->bytecode; - } - ldsv($ix); - for ($i = 0; $i < @contents; $i += 2) { - asmf("newpv %s\nhv_store %d\n", - pvstring($contents[$i]), $ixes[$i / 2]); - } - asmf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS; - } -} - -sub B::AV::bytecode { - my $av = shift; - return if saved($av); - my $ix = $av->objix; - my $fill = $av->FILL; - my $max = $av->MAX; - my (@array, @ixes); - if ($fill > -1) { - @array = $av->ARRAY; - @ixes = map($_->objix, @array); - my $sv; - foreach $sv (@array) { - $sv->bytecode; - } - } - # See PVNV::bytecode for the meaning of the flag argument of 2. - $av->B::PVMG::bytecode(2); - # Recover sv register and set AvMAX and AvFILL to -1 (since we - # create an AV with NEWSV and SvUPGRADE rather than doing newAV - # which is what sets AvMAX and AvFILL. - ldsv($ix); - asmf "sv_flags 0x%x\n", $av->FLAGS & ~SVf_READONLY; # SvREADONLY_off($av) in case PADCONST - asmf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS; - if ($fill > -1) { - my $elix; - foreach $elix (@ixes) { - asm "av_push $elix\n"; - } - } else { - if ($max > -1) { - asm "av_extend $max\n"; - } - } - asmf "sv_flags 0x%x\n", $av->FLAGS; # restore flags from above -} - -sub B::CV::bytecode { - my $cv = shift; - return if saved($cv); - return if ${$cv->GV} && ($cv->GV->GvFLAGS & GVf_IMPORTED_CV); - my $fileix = pvix($cv->FILE); - my $ix = $cv->objix; - $cv->B::PVMG::bytecode; - my $i; - my @subfield_names = qw(ROOT START STASH GV PADLIST OUTSIDE); - my @subfields = map($cv->$_(), @subfield_names); - my @ixes = map($_->objix, @subfields); - # Save OP tree from CvROOT (first element of @subfields) - my $root = shift @subfields; - if ($$root) { - walkoptree($root, "bytecode"); - } - # Reset sv register for $cv (since above ->objix calls stomped on it) - ldsv($ix); - for ($i = 0; $i < @ixes; $i++) { - asmf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; - } - asmf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->CvFLAGS; - asmf "xcv_file %d\n", $fileix; - # Now save all the subfields (except for CvROOT which was handled - # above) and CvSTART (now the initial element of @subfields). - shift @subfields; # bye-bye CvSTART - my $sv; - foreach $sv (@subfields) { - $sv->bytecode; - } -} - -sub B::IO::bytecode { - my $io = shift; - return if saved($io); - my $ix = $io->objix; - my $top_gv = $io->TOP_GV; - my $top_gvix = $top_gv->objix; - my $fmt_gv = $io->FMT_GV; - my $fmt_gvix = $fmt_gv->objix; - my $bottom_gv = $io->BOTTOM_GV; - my $bottom_gvix = $bottom_gv->objix; - - $io->B::PVMG::bytecode; - ldsv($ix); - asm "xio_top_gv $top_gvix\n"; - asm "xio_fmt_gv $fmt_gvix\n"; - asm "xio_bottom_gv $bottom_gvix\n"; - my $field; - foreach $field (qw(TOP_NAME FMT_NAME BOTTOM_NAME)) { - asmf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field); - } - foreach $field (qw(LINES PAGE PAGE_LEN LINES_LEFT SUBPROCESS)) { - asmf "xio_%s %d\n", lc($field), $io->$field(); - } - asmf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS; - $top_gv->bytecode; - $fmt_gv->bytecode; - $bottom_gv->bytecode; -} - -sub B::SPECIAL::bytecode { - # nothing extra needs doing -} - -sub bytecompile_object { - for my $sv (@_) { - svref_2object($sv)->bytecode; - } -} - -sub B::GV::bytecodecv { - my $gv = shift; - my $cv = $gv->CV; - if ($$cv && !saved($cv) && !($gv->FLAGS & GVf_IMPORTED_CV)) { - if ($debug_cv) { - warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n", - $gv->STASH->NAME, $gv->NAME, $$cv, $$gv); - } - $gv->bytecode; - } -} - -sub save_call_queues { - if (begin_av()->isa("B::AV")) { # this is just to save 'use Foo;' calls - for my $cv (begin_av()->ARRAY) { - next unless grep { $_ eq $cv->STASH->NAME; } @packages; - my $op = $cv->START; -OPLOOP: - while ($$op) { - if ($op->name eq 'require') { # save any BEGIN that does a require - $cv->bytecode; - asmf "push_begin %d\n", $cv->objix; - last OPLOOP; - } - $op = $op->next; - } - } - } - if (init_av()->isa("B::AV")) { - for my $cv (init_av()->ARRAY) { - next unless grep { $_ eq $cv->STASH->NAME; } @packages; - $cv->bytecode; - asmf "push_init %d\n", $cv->objix; - } - } - if (end_av()->isa("B::AV")) { - for my $cv (end_av()->ARRAY) { - next unless grep { $_ eq $cv->STASH->NAME; } @packages; - $cv->bytecode; - asmf "push_end %d\n", $cv->objix; - } - } -} - -sub symwalk { - no strict 'refs'; - my $ok = 1 if grep { (my $name = $_[0]) =~ s/::$//; $_ eq $name;} @packages; - if (grep { /^$_[0]/; } @packages) { - walksymtable(\%{"$_[0]"}, "bytecodecv", \&symwalk, $_[0]); - } - warn "considering $_[0] ... " . ($ok ? "accepted\n" : "rejected\n") - if $debug_bc; - $ok; -} - -sub bytecompile_main { - my $curpad = (comppadlist->ARRAY)[1]; - my $curpadix = $curpad->objix; - $curpad->bytecode; - save_call_queues(); - walkoptree(main_root, "bytecode") unless ref(main_root) eq "B::NULL"; - warn "done main program, now walking symbol table\n" if $debug_bc; - if (@packages) { - no strict qw(refs); - walksymtable(\%{"main::"}, "bytecodecv", \&symwalk); - } else { - die "No packages requested for compilation!\n"; - } - asmf "main_root %d\n", main_root->objix; - asmf "main_start %d\n", main_start->objix; - asmf "curpad $curpadix\n"; - # XXX Do min_intro_pending and max_intro_pending matter? -} - -sub compile { - my @options = @_; - my ($option, $opt, $arg); - open(OUT, ">&STDOUT"); - binmode OUT; - select OUT; - OPTION: - while ($option = shift @options) { - if ($option =~ /^-(.)(.*)/) { - $opt = $1; - $arg = $2; - } else { - unshift @options, $option; - last OPTION; - } - if ($opt eq "-" && $arg eq "-") { - shift @options; - last OPTION; - } elsif ($opt eq "o") { - $arg ||= shift @options; - open(OUT, ">$arg") or return "$arg: $!\n"; - binmode OUT; - } elsif ($opt eq "a") { - $arg ||= shift @options; - open(OUT, ">>$arg") or return "$arg: $!\n"; - binmode OUT; - } elsif ($opt eq "D") { - $arg ||= shift @options; - foreach $arg (split(//, $arg)) { - if ($arg eq "b") { - $| = 1; - debug(1); - } elsif ($arg eq "o") { - B->debug(1); - } elsif ($arg eq "a") { - B::Assembler::debug(1); - } elsif ($arg eq "C") { - $debug_cv = 1; - } - } - } elsif ($opt eq "v") { - $verbose = 1; - } elsif ($opt eq "S") { - $no_assemble = 1; - } elsif ($opt eq "f") { - $arg ||= shift @options; - my $value = $arg !~ s/^no-//; - $arg =~ s/-/_/g; - my $ref = $optimise{$arg}; - if (defined($ref)) { - $$ref = $value; - } else { - warn qq(ignoring unknown optimisation option "$arg"\n); - } - } elsif ($opt eq "O") { - $arg = 1 if $arg eq ""; - my $ref; - foreach $ref (values %optimise) { - $$ref = 0; - } - if ($arg >= 2) { - $bypass_nullops = 1; - } - if ($arg >= 1) { - $compress_nullops = 1; - $omit_seq = 1; - } - } elsif ($opt eq "u") { - $arg ||= shift @options; - push @packages, $arg; - } else { - warn qq(ignoring unknown option "$opt$arg"\n); - } - } - if (! @packages) { - warn "No package specified for compilation, assuming main::\n"; - @packages = qw(main); - } - if (@options) { - die "Extraneous options left on B::Bytecode commandline: @options\n"; - } else { - return sub { - newasm(\&apr) unless $no_assemble; - bytecompile_main(); - endasm() unless $no_assemble; - }; - } -} - -sub apr { print @_; } - -1; - -__END__ - -=head1 NAME - -B::Bytecode - Perl compiler's bytecode backend - -=head1 SYNOPSIS - - perl -MO=Bytecode[,OPTIONS] foo.pl - -=head1 DESCRIPTION - -This compiler backend takes Perl source and generates a -platform-independent bytecode encapsulating code to load the -internal structures perl uses to run your program. When the -generated bytecode is loaded in, your program is ready to run, -reducing the time which perl would have taken to load and parse -your program into its internal semi-compiled form. That means that -compiling with this backend will not help improve the runtime -execution speed of your program but may improve the start-up time. -Depending on the environment in which your program runs this may -or may not be a help. - -The resulting bytecode can be run with a special byteperl executable -or (for non-main programs) be loaded via the C<byteload_fh> function -in the F<B> module. - -=head1 OPTIONS - -If there are any non-option arguments, they are taken to be names of -objects to be saved (probably doesn't work properly yet). Without -extra arguments, it saves the main program. - -=over 4 - -=item B<-ofilename> - -Output to filename instead of STDOUT. - -=item B<-afilename> - -Append output to filename. - -=item B<--> - -Force end of options. - -=item B<-f> - -Force optimisations on or off one at a time. Each can be preceded -by B<no-> to turn the option off (e.g. B<-fno-compress-nullops>). - -=item B<-fcompress-nullops> - -Only fills in the necessary fields of ops which have -been optimised away by perl's internal compiler. - -=item B<-fomit-sequence-numbers> - -Leaves out code to fill in the op_seq field of all ops -which is only used by perl's internal compiler. - -=item B<-fbypass-nullops> - -If op->op_next ever points to a NULLOP, replaces the op_next field -with the first non-NULLOP in the path of execution. - -=item B<-On> - -Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. -B<-O1> sets B<-fcompress-nullops> B<-fomit-sequence numbers>. -B<-O2> adds B<-fbypass-nullops>. - -=item B<-D> - -Debug options (concatenated or separate flags like C<perl -D>). - -=item B<-Do> - -Prints each OP as it's processed. - -=item B<-Db> - -Print debugging information about bytecompiler progress. - -=item B<-Da> - -Tells the (bytecode) assembler to include source assembler lines -in its output as bytecode comments. - -=item B<-DC> - -Prints each CV taken from the final symbol tree walk. - -=item B<-S> - -Output (bytecode) assembler source rather than piping it -through the assembler and outputting bytecode. - -=item B<-upackage> - -Stores package in the output. - -=back - -=head1 EXAMPLES - - perl -MO=Bytecode,-O6,-ofoo.plc,-umain foo.pl - - perl -MO=Bytecode,-S,-umain foo.pl > foo.S - assemble foo.S > foo.plc - -Note that C<assemble> lives in the C<B> subdirectory of your perl -library directory. The utility called perlcc may also be used to -help make use of this compiler. - - perl -MO=Bytecode,-uFoo,-oFoo.pmc Foo.pm - -=head1 BUGS - -Output is still huge and there are still occasional crashes during -either compilation or ByteLoading. Current status: experimental. - -=head1 AUTHORS - -Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> -Benjamin Stuhl, C<sho_pi@hotmail.com> - -=cut diff --git a/contrib/perl5/ext/B/B/C.pm b/contrib/perl5/ext/B/B/C.pm deleted file mode 100644 index 4befe79..0000000 --- a/contrib/perl5/ext/B/B/C.pm +++ /dev/null @@ -1,1657 +0,0 @@ -# C.pm -# -# Copyright (c) 1996, 1997, 1998 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. -# -package B::C::Section; -use B (); -use base B::Section; - -sub new -{ - my $class = shift; - my $o = $class->SUPER::new(@_); - push(@$o,[]); - return $o; -} - -sub add -{ - my $section = shift; - push(@{$section->[-1]},@_); -} - -sub index -{ - my $section = shift; - return scalar(@{$section->[-1]})-1; -} - -sub output -{ - my ($section, $fh, $format) = @_; - my $sym = $section->symtable || {}; - my $default = $section->default; - foreach (@{$section->[-1]}) - { - s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge; - printf $fh $format, $_; - } -} - -package B::C; -use Exporter (); -@ISA = qw(Exporter); -@EXPORT_OK = qw(output_all output_boilerplate output_main mark_unused - init_sections set_callback save_unused_subs objsym save_context); - -use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop - class cstring cchar svref_2object compile_stats comppadlist hash - threadsv_names main_cv init_av opnumber amagic_generation - AVf_REAL HEf_SVKEY); -use B::Asmdata qw(@specialsv_name); - -use FileHandle; -use Carp; -use strict; -use Config; - -my $hv_index = 0; -my $gv_index = 0; -my $re_index = 0; -my $pv_index = 0; -my $anonsub_index = 0; -my $initsub_index = 0; - -my %symtable; -my %xsub; -my $warn_undefined_syms; -my $verbose; -my %unused_sub_packages; -my $nullop_count; -my $pv_copy_on_grow = 0; -my ($debug_cops, $debug_av, $debug_cv, $debug_mg); -my $max_string_len; - -my @threadsv_names; -BEGIN { - @threadsv_names = threadsv_names(); -} - -# Code sections -my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, - $padopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect, - $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect, - $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect, - $xrvsect, $xpvbmsect, $xpviosect ); - -sub walk_and_save_optree; -my $saveoptree_callback = \&walk_and_save_optree; -sub set_callback { $saveoptree_callback = shift } -sub saveoptree { &$saveoptree_callback(@_) } - -sub walk_and_save_optree { - my ($name, $root, $start) = @_; - walkoptree($root, "save"); - return objsym($start); -} - -# Current workaround/fix for op_free() trying to free statically -# defined OPs is to set op_seq = -1 and check for that in op_free(). -# Instead of hardwiring -1 in place of $op->seq, we use $op_seq -# so that it can be changed back easily if necessary. In fact, to -# stop compilers from moaning about a U16 being initialised with an -# uncast -1 (the printf format is %d so we can't tweak it), we have -# to "know" that op_seq is a U16 and use 65535. Ugh. -my $op_seq = 65535; - -# Look this up here so we can do just a number compare -# rather than looking up the name of every BASEOP in B::OP -my $OP_THREADSV = opnumber('threadsv'); - -sub savesym { - my ($obj, $value) = @_; - my $sym = sprintf("s\\_%x", $$obj); - $symtable{$sym} = $value; -} - -sub objsym { - my $obj = shift; - return $symtable{sprintf("s\\_%x", $$obj)}; -} - -sub getsym { - my $sym = shift; - my $value; - - return 0 if $sym eq "sym_0"; # special case - $value = $symtable{$sym}; - if (defined($value)) { - return $value; - } else { - warn "warning: undefined symbol $sym\n" if $warn_undefined_syms; - return "UNUSED"; - } -} - -sub savepv { - my $pv = shift; - $pv = '' unless defined $pv; # Is this sane ? - my $pvsym = 0; - my $pvmax = 0; - if ($pv_copy_on_grow) { - my $cstring = cstring($pv); - if ($cstring ne "0") { # sic - $pvsym = sprintf("pv%d", $pv_index++); - $decl->add(sprintf("static char %s[] = %s;", $pvsym, $cstring)); - } - } else { - $pvmax = length($pv) + 1; - } - return ($pvsym, $pvmax); -} - -sub B::OP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - my $type = $op->type; - $nullop_count++ unless $type; - if ($type == $OP_THREADSV) { - # saves looking up ppaddr but it's a bit naughty to hard code this - $init->add(sprintf("(void)find_threadsv(%s);", - cstring($threadsv_names[$op->targ]))); - } - $opsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x", - ${$op->next}, ${$op->sibling}, $op->targ, - $type, $op_seq, $op->flags, $op->private)); - my $ix = $opsect->index; - $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr)); - savesym($op, "&op_list[$ix]"); -} - -sub B::FAKEOP::new { - my ($class, %objdata) = @_; - bless \%objdata, $class; -} - -sub B::FAKEOP::save { - my ($op, $level) = @_; - $opsect->add(sprintf("%s, %s, NULL, %u, %u, %u, 0x%x, 0x%x", - $op->next, $op->sibling, $op->targ, - $op->type, $op_seq, $op->flags, $op->private)); - my $ix = $opsect->index; - $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr)); - return "&op_list[$ix]"; -} - -sub B::FAKEOP::next { $_[0]->{"next"} || 0 } -sub B::FAKEOP::type { $_[0]->{type} || 0} -sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 } -sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 } -sub B::FAKEOP::targ { $_[0]->{targ} || 0 } -sub B::FAKEOP::flags { $_[0]->{flags} || 0 } -sub B::FAKEOP::private { $_[0]->{private} || 0 } - -sub B::UNOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - $unopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x", - ${$op->next}, ${$op->sibling}, - $op->targ, $op->type, $op_seq, $op->flags, - $op->private, ${$op->first})); - my $ix = $unopsect->index; - $init->add(sprintf("unop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); - savesym($op, "(OP*)&unop_list[$ix]"); -} - -sub B::BINOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - $binopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x", - ${$op->next}, ${$op->sibling}, - $op->targ, $op->type, $op_seq, $op->flags, - $op->private, ${$op->first}, ${$op->last})); - my $ix = $binopsect->index; - $init->add(sprintf("binop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); - savesym($op, "(OP*)&binop_list[$ix]"); -} - -sub B::LISTOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - $listopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x", - ${$op->next}, ${$op->sibling}, - $op->targ, $op->type, $op_seq, $op->flags, - $op->private, ${$op->first}, ${$op->last})); - my $ix = $listopsect->index; - $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); - savesym($op, "(OP*)&listop_list[$ix]"); -} - -sub B::LOGOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - $logopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x", - ${$op->next}, ${$op->sibling}, - $op->targ, $op->type, $op_seq, $op->flags, - $op->private, ${$op->first}, ${$op->other})); - my $ix = $logopsect->index; - $init->add(sprintf("logop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); - savesym($op, "(OP*)&logop_list[$ix]"); -} - -sub B::LOOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n", - # peekop($op->redoop), peekop($op->nextop), - # peekop($op->lastop)); # debug - $loopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x", - ${$op->next}, ${$op->sibling}, - $op->targ, $op->type, $op_seq, $op->flags, - $op->private, ${$op->first}, ${$op->last}, - ${$op->redoop}, ${$op->nextop}, - ${$op->lastop})); - my $ix = $loopsect->index; - $init->add(sprintf("loop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); - savesym($op, "(OP*)&loop_list[$ix]"); -} - -sub B::PVOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - $pvopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, %s", - ${$op->next}, ${$op->sibling}, - $op->targ, $op->type, $op_seq, $op->flags, - $op->private, cstring($op->pv))); - my $ix = $pvopsect->index; - $init->add(sprintf("pvop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); - savesym($op, "(OP*)&pvop_list[$ix]"); -} - -sub B::SVOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - my $svsym = $op->sv->save; - $svopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, Nullsv", - ${$op->next}, ${$op->sibling}, - $op->targ, $op->type, $op_seq, $op->flags, - $op->private)); - my $ix = $svopsect->index; - $init->add(sprintf("svop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); - $init->add("svop_list[$ix].op_sv = (SV*)$svsym;"); - savesym($op, "(OP*)&svop_list[$ix]"); -} - -sub B::PADOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - $padopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, 0", - ${$op->next}, ${$op->sibling}, - $op->targ, $op->type, $op_seq, $op->flags, - $op->private)); - $init->add(sprintf("padop_list[%d].op_ppaddr = %s;", $padopsect->index, $op->ppaddr)); - my $ix = $padopsect->index; - $init->add(sprintf("padop_list[$ix].op_padix = %ld;", $op->padix)); - savesym($op, "(OP*)&padop_list[$ix]"); -} - -sub B::COP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - warn sprintf("COP: line %d file %s\n", $op->line, $op->file) - if $debug_cops; - $copsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, %s, NULL, NULL, %u, %d, %u", - ${$op->next}, ${$op->sibling}, - $op->targ, $op->type, $op_seq, $op->flags, - $op->private, cstring($op->label), $op->cop_seq, - $op->arybase, $op->line)); - my $ix = $copsect->index; - $init->add(sprintf("cop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); - $init->add(sprintf("CopFILE_set(&cop_list[$ix], %s);", cstring($op->file)), - sprintf("CopSTASHPV_set(&cop_list[$ix], %s);", cstring($op->stashpv))); - savesym($op, "(OP*)&cop_list[$ix]"); -} - -sub B::PMOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - my $replroot = $op->pmreplroot; - my $replstart = $op->pmreplstart; - my $replrootfield = sprintf("s\\_%x", $$replroot); - my $replstartfield = sprintf("s\\_%x", $$replstart); - my $gvsym; - my $ppaddr = $op->ppaddr; - if ($$replroot) { - # OP_PUSHRE (a mutated version of OP_MATCH for the regexp - # argument to a split) stores a GV in op_pmreplroot instead - # of a substitution syntax tree. We don't want to walk that... - if ($op->name eq "pushre") { - $gvsym = $replroot->save; -# warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug - $replrootfield = 0; - } else { - $replstartfield = saveoptree("*ignore*", $replroot, $replstart); - } - } - # pmnext handling is broken in perl itself, I think. Bad op_pmnext - # fields aren't noticed in perl's runtime (unless you try reset) but we - # segfault when trying to dereference it to find op->op_pmnext->op_type - $pmopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %s, %s, 0, 0, 0x%x, 0x%x", - ${$op->next}, ${$op->sibling}, $op->targ, - $op->type, $op_seq, $op->flags, $op->private, - ${$op->first}, ${$op->last}, - $replrootfield, $replstartfield, - $op->pmflags, $op->pmpermflags,)); - my $pm = sprintf("pmop_list[%d]", $pmopsect->index); - $init->add(sprintf("$pm.op_ppaddr = %s;", $ppaddr)); - my $re = $op->precomp; - if (defined($re)) { - my $resym = sprintf("re%d", $re_index++); - $decl->add(sprintf("static char *$resym = %s;", cstring($re))); - $init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);", - length($re))); - } - if ($gvsym) { - $init->add("$pm.op_pmreplroot = (OP*)$gvsym;"); - } - savesym($op, "(OP*)&$pm"); -} - -sub B::SPECIAL::save { - my ($sv) = @_; - # special case: $$sv is not the address but an index into specialsv_list -# warn "SPECIAL::save specialsv $$sv\n"; # debug - my $sym = $specialsv_name[$$sv]; - if (!defined($sym)) { - confess "unknown specialsv index $$sv passed to B::SPECIAL::save"; - } - return $sym; -} - -sub B::OBJECT::save {} - -sub B::NULL::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; -# warn "Saving SVt_NULL SV\n"; # debug - # debug - if ($$sv == 0) { - warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n"; - return savesym($sv, "Nullsv /* XXX */"); - } - $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS)); - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub B::IV::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX)); - $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x", - $xpvivsect->index, $sv->REFCNT , $sv->FLAGS)); - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub B::NV::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - my $val= $sv->NVX; - $val .= '.00' if $val =~ /^-?\d+$/; - $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val)); - $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x", - $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS)); - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub savepvn { - my ($dest,$pv) = @_; - my @res; - if (defined $max_string_len && length($pv) > $max_string_len) { - push @res, sprintf("New(0,%s,%u,char);", $dest, length($pv)+1); - my $offset = 0; - while (length $pv) { - my $str = substr $pv, 0, $max_string_len, ''; - push @res, sprintf("Copy(%s,$dest+$offset,%u,char);", - cstring($str), length($str)); - $offset += length $str; - } - push @res, sprintf("%s[%u] = '\\0';", $dest, $offset); - } - else { - push @res, sprintf("%s = savepvn(%s, %u);", $dest, - cstring($pv), length($pv)); - } - return @res; -} - -sub B::PVLV::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - my $pv = $sv->PV; - my $len = length($pv); - my ($pvsym, $pvmax) = savepv($pv); - my ($lvtarg, $lvtarg_sym); - $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s", - $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX, - $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE))); - $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x", - $xpvlvsect->index, $sv->REFCNT , $sv->FLAGS)); - if (!$pv_copy_on_grow) { - $init->add(savepvn(sprintf("xpvlv_list[%d].xpv_pv", - $xpvlvsect->index), $pv)); - } - $sv->save_magic; - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub B::PVIV::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - my $pv = $sv->PV; - my $len = length($pv); - my ($pvsym, $pvmax) = savepv($pv); - $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX)); - $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x", - $xpvivsect->index, $sv->REFCNT , $sv->FLAGS)); - if (!$pv_copy_on_grow) { - $init->add(savepvn(sprintf("xpviv_list[%d].xpv_pv", - $xpvivsect->index), $pv)); - } - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub B::PVNV::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - my $pv = $sv->PV; - $pv = '' unless defined $pv; - my $len = length($pv); - my ($pvsym, $pvmax) = savepv($pv); - my $val= $sv->NVX; - $val .= '.00' if $val =~ /^-?\d+$/; - $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s", - $pvsym, $len, $pvmax, $sv->IVX, $val)); - $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x", - $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS)); - if (!$pv_copy_on_grow) { - $init->add(savepvn(sprintf("xpvnv_list[%d].xpv_pv", - $xpvnvsect->index), $pv)); - } - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub B::BM::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - my $pv = $sv->PV . "\0" . $sv->TABLE; - my $len = length($pv); - $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x", - $len, $len + 258, $sv->IVX, $sv->NVX, - $sv->USEFUL, $sv->PREVIOUS, $sv->RARE)); - $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x", - $xpvbmsect->index, $sv->REFCNT , $sv->FLAGS)); - $sv->save_magic; - $init->add(savepvn(sprintf("xpvbm_list[%d].xpv_pv", - $xpvbmsect->index), $pv), - sprintf("xpvbm_list[%d].xpv_cur = %u;", - $xpvbmsect->index, $len - 257)); - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub B::PV::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - my $pv = $sv->PV; - my $len = length($pv); - my ($pvsym, $pvmax) = savepv($pv); - $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax)); - $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x", - $xpvsect->index, $sv->REFCNT , $sv->FLAGS)); - if (!$pv_copy_on_grow) { - $init->add(savepvn(sprintf("xpv_list[%d].xpv_pv", - $xpvsect->index), $pv)); - } - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub B::PVMG::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - my $pv = $sv->PV; - my $len = length($pv); - my ($pvsym, $pvmax) = savepv($pv); - $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0", - $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX)); - $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x", - $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS)); - if (!$pv_copy_on_grow) { - $init->add(savepvn(sprintf("xpvmg_list[%d].xpv_pv", - $xpvmgsect->index), $pv)); - } - $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); - $sv->save_magic; - return $sym; -} - -sub B::PVMG::save_magic { - my ($sv) = @_; - #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug - my $stash = $sv->SvSTASH; - $stash->save; - if ($$stash) { - warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash) - if $debug_mg; - # XXX Hope stash is already going to be saved. - $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash)); - } - my @mgchain = $sv->MAGIC; - my ($mg, $type, $obj, $ptr,$len,$ptrsv); - foreach $mg (@mgchain) { - $type = $mg->TYPE; - $obj = $mg->OBJ; - $ptr = $mg->PTR; - $len=$mg->LENGTH; - if ($debug_mg) { - warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n", - class($sv), $$sv, class($obj), $$obj, - cchar($type), cstring($ptr)); - } - $obj->save; - if ($len == HEf_SVKEY){ - #The pointer is an SV* - $ptrsv=svref_2object($ptr)->save; - $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);", - $$sv, $$obj, cchar($type),$ptrsv,$len)); - }else{ - $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);", - $$sv, $$obj, cchar($type),cstring($ptr),$len)); - } - } -} - -sub B::RV::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - my $rv = $sv->RV->save; - $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/; - $xrvsect->add($rv); - $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x", - $xrvsect->index, $sv->REFCNT , $sv->FLAGS)); - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub try_autoload { - my ($cvstashname, $cvname) = @_; - warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname); - # Handle AutoLoader classes explicitly. Any more general AUTOLOAD - # use should be handled by the class itself. - no strict 'refs'; - my $isa = \@{"$cvstashname\::ISA"}; - if (grep($_ eq "AutoLoader", @$isa)) { - warn "Forcing immediate load of sub derived from AutoLoader\n"; - # Tweaked version of AutoLoader::AUTOLOAD - my $dir = $cvstashname; - $dir =~ s(::)(/)g; - eval { require "auto/$dir/$cvname.al" }; - if ($@) { - warn qq(failed require "auto/$dir/$cvname.al": $@\n); - return 0; - } else { - return 1; - } - } -} -sub Dummy_initxs{}; -sub B::CV::save { - my ($cv) = @_; - my $sym = objsym($cv); - if (defined($sym)) { -# warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug - return $sym; - } - # Reserve a place in svsect and xpvcvsect and record indices - my $gv = $cv->GV; - my ($cvname, $cvstashname); - if ($$gv){ - $cvname = $gv->NAME; - $cvstashname = $gv->STASH->NAME; - } - my $root = $cv->ROOT; - my $cvxsub = $cv->XSUB; - #INIT is removed from the symbol table, so this call must come - # from PL_initav->save. Re-bootstrapping will push INIT back in - # so nullop should be sent. - if ($cvxsub && ($cvname ne "INIT")) { - my $egv = $gv->EGV; - my $stashname = $egv->STASH->NAME; - if ($cvname eq "bootstrap") - { - my $file = $gv->FILE; - $decl->add("/* bootstrap $file */"); - warn "Bootstrap $stashname $file\n"; - $xsub{$stashname}='Dynamic'; - # $xsub{$stashname}='Static' unless $xsub{$stashname}; - return qq/NULL/; - } - warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv; - return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/; - } - if ($cvxsub && $cvname eq "INIT") { - no strict 'refs'; - return svref_2object(\&Dummy_initxs)->save; - } - my $sv_ix = $svsect->index + 1; - $svsect->add("svix$sv_ix"); - my $xpvcv_ix = $xpvcvsect->index + 1; - $xpvcvsect->add("xpvcvix$xpvcv_ix"); - # Save symbol now so that GvCV() doesn't recurse back to us via CvGV() - $sym = savesym($cv, "&sv_list[$sv_ix]"); - warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv; - if (!$$root && !$cvxsub) { - if (try_autoload($cvstashname, $cvname)) { - # Recalculate root and xsub - $root = $cv->ROOT; - $cvxsub = $cv->XSUB; - if ($$root || $cvxsub) { - warn "Successful forced autoload\n"; - } - } - } - my $startfield = 0; - my $padlist = $cv->PADLIST; - my $pv = $cv->PV; - my $xsub = 0; - my $xsubany = "Nullany"; - if ($$root) { - warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n", - $$cv, $$root) if $debug_cv; - my $ppname = ""; - if ($$gv) { - my $stashname = $gv->STASH->NAME; - my $gvname = $gv->NAME; - if ($gvname ne "__ANON__") { - $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_"; - $ppname .= ($stashname eq "main") ? - $gvname : "$stashname\::$gvname"; - $ppname =~ s/::/__/g; - if ($gvname eq "INIT"){ - $ppname .= "_$initsub_index"; - $initsub_index++; - } - } - } - if (!$ppname) { - $ppname = "pp_anonsub_$anonsub_index"; - $anonsub_index++; - } - $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY); - warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n", - $$cv, $ppname, $$root) if $debug_cv; - if ($$padlist) { - warn sprintf("saving PADLIST 0x%x for CV 0x%x\n", - $$padlist, $$cv) if $debug_cv; - $padlist->save; - warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n", - $$padlist, $$cv) if $debug_cv; - } - } - else { - warn sprintf("No definition for sub %s::%s (unable to autoload)\n", - $cvstashname, $cvname); # debug - } - $pv = '' unless defined $pv; # Avoid use of undef warnings - $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, \"\", %d, s\\_%x, (CV*)s\\_%x, 0x%x", - $xpvcv_ix, cstring($pv), length($pv), $cv->IVX, - $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH, - $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS)); - - if (${$cv->OUTSIDE} == ${main_cv()}){ - $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv)); - $init->add(sprintf("SvREFCNT_inc(PL_main_cv);")); - } - - if ($$gv) { - $gv->save; - $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv)); - warn sprintf("done saving GV 0x%x for CV 0x%x\n", - $$gv, $$cv) if $debug_cv; - } - $init->add(sprintf("CvFILE($sym) = %s;", cstring($cv->FILE))); - my $stash = $cv->STASH; - if ($$stash) { - $stash->save; - $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash)); - warn sprintf("done saving STASH 0x%x for CV 0x%x\n", - $$stash, $$cv) if $debug_cv; - } - $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x", - $sv_ix, $xpvcv_ix, $cv->REFCNT +1 , $cv->FLAGS)); - return $sym; -} - -sub B::GV::save { - my ($gv) = @_; - my $sym = objsym($gv); - if (defined($sym)) { - #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug - return $sym; - } else { - my $ix = $gv_index++; - $sym = savesym($gv, "gv_list[$ix]"); - #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug - } - my $is_empty = $gv->is_empty; - my $gvname = $gv->NAME; - my $name = cstring($gv->STASH->NAME . "::" . $gvname); - #warn "GV name is $name\n"; # debug - my $egvsym; - unless ($is_empty) { - my $egv = $gv->EGV; - if ($$gv != $$egv) { - #warn(sprintf("EGV name is %s, saving it now\n", - # $egv->STASH->NAME . "::" . $egv->NAME)); # debug - $egvsym = $egv->save; - } - } - $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);], - sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS), - sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS)); - $init->add(sprintf("GvLINE($sym) = %u;", $gv->LINE)) unless $is_empty; - - # Shouldn't need to do save_magic since gv_fetchpv handles that - #$gv->save_magic; - my $refcnt = $gv->REFCNT + 1; - $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1; - - return $sym if $is_empty; - - my $gvrefcnt = $gv->GvREFCNT; - if ($gvrefcnt > 1) { - $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1)); - } - if (defined($egvsym)) { - # Shared glob *foo = *bar - $init->add("gp_free($sym);", - "GvGP($sym) = GvGP($egvsym);"); - } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) { - # Don't save subfields of special GVs (*_, *1, *# and so on) -# warn "GV::save saving subfields\n"; # debug - my $gvsv = $gv->SV; - if ($$gvsv) { - $gvsv->save; - $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv)); -# warn "GV::save \$$name\n"; # debug - } - my $gvav = $gv->AV; - if ($$gvav) { - $gvav->save; - $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav)); -# warn "GV::save \@$name\n"; # debug - } - my $gvhv = $gv->HV; - if ($$gvhv) { - $gvhv->save; - $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv)); -# warn "GV::save \%$name\n"; # debug - } - my $gvcv = $gv->CV; - if ($$gvcv) { - my $origname=cstring($gvcv->GV->EGV->STASH->NAME . - "::" . $gvcv->GV->EGV->NAME); - if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias - # must save as a 'stub' so newXS() has a CV to populate - $init->add("{ CV *cv;"); - $init->add("\tcv=perl_get_cv($origname,TRUE);"); - $init->add("\tGvCV($sym)=cv;"); - $init->add("\tSvREFCNT_inc((SV *)cv);"); - $init->add("}"); - } else { - $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save)); -# warn "GV::save &$name\n"; # debug - } - } - $init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE))); -# warn "GV::save GvFILE(*$name)\n"; # debug - my $gvform = $gv->FORM; - if ($$gvform) { - $gvform->save; - $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform)); -# warn "GV::save GvFORM(*$name)\n"; # debug - } - my $gvio = $gv->IO; - if ($$gvio) { - $gvio->save; - $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio)); -# warn "GV::save GvIO(*$name)\n"; # debug - } - } - return $sym; -} -sub B::AV::save { - my ($av) = @_; - my $sym = objsym($av); - return $sym if defined $sym; - my $avflags = $av->AvFLAGS; - $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x", - $avflags)); - $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x", - $xpvavsect->index, $av->REFCNT , $av->FLAGS)); - my $sv_list_index = $svsect->index; - my $fill = $av->FILL; - $av->save_magic; - warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags) - if $debug_av; - # XXX AVf_REAL is wrong test: need to save comppadlist but not stack - #if ($fill > -1 && ($avflags & AVf_REAL)) { - if ($fill > -1) { - my @array = $av->ARRAY; - if ($debug_av) { - my $el; - my $i = 0; - foreach $el (@array) { - warn sprintf("AV 0x%x[%d] = %s 0x%x\n", - $$av, $i++, class($el), $$el); - } - } - my @names = map($_->save, @array); - # XXX Better ways to write loop? - # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...; - # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...; - $init->add("{", - "\tSV **svp;", - "\tAV *av = (AV*)&sv_list[$sv_list_index];", - "\tav_extend(av, $fill);", - "\tsvp = AvARRAY(av);", - map("\t*svp++ = (SV*)$_;", @names), - "\tAvFILLp(av) = $fill;", - "}"); - } else { - my $max = $av->MAX; - $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);") - if $max > -1; - } - return savesym($av, "(AV*)&sv_list[$sv_list_index]"); -} - -sub B::HV::save { - my ($hv) = @_; - my $sym = objsym($hv); - return $sym if defined $sym; - my $name = $hv->NAME; - if ($name) { - # It's a stash - - # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually - # the only symptom is that sv_reset tries to reset the PMf_USED flag of - # a trashed op but we look at the trashed op_type and segfault. - #my $adpmroot = ${$hv->PMROOT}; - my $adpmroot = 0; - $decl->add("static HV *hv$hv_index;"); - # XXX Beware of weird package names containing double-quotes, \n, ...? - $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]); - if ($adpmroot) { - $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;", - $adpmroot)); - } - $sym = savesym($hv, "hv$hv_index"); - $hv_index++; - return $sym; - } - # It's just an ordinary HV - $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0", - $hv->MAX, $hv->RITER)); - $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x", - $xpvhvsect->index, $hv->REFCNT , $hv->FLAGS)); - my $sv_list_index = $svsect->index; - my @contents = $hv->ARRAY; - if (@contents) { - my $i; - for ($i = 1; $i < @contents; $i += 2) { - $contents[$i] = $contents[$i]->save; - } - $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];"); - while (@contents) { - my ($key, $value) = splice(@contents, 0, 2); - $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);", - cstring($key),length($key),$value, hash($key))); -# $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);", -# cstring($key),length($key),$value, 0)); - } - $init->add("}"); - } - $hv->save_magic(); - return savesym($hv, "(HV*)&sv_list[$sv_list_index]"); -} - -sub B::IO::save { - my ($io) = @_; - my $sym = objsym($io); - return $sym if defined $sym; - my $pv = $io->PV; - $pv = '' unless defined $pv; - my $len = length($pv); - $xpviosect->add(sprintf("0, %u, %u, %d, %s, 0, 0, 0, 0, 0, %d, %d, %d, %d, %s, Nullgv, %s, Nullgv, %s, Nullgv, %d, %s, 0x%x", - $len, $len+1, $io->IVX, $io->NVX, $io->LINES, - $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT, - cstring($io->TOP_NAME), cstring($io->FMT_NAME), - cstring($io->BOTTOM_NAME), $io->SUBPROCESS, - cchar($io->IoTYPE), $io->IoFLAGS)); - $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x", - $xpviosect->index, $io->REFCNT , $io->FLAGS)); - $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index)); - my ($field, $fsym); - foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) { - $fsym = $io->$field(); - if ($$fsym) { - $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym)); - $fsym->save; - } - } - $io->save_magic; - return $sym; -} - -sub B::SV::save { - my $sv = shift; - # This is where we catch an honest-to-goodness Nullsv (which gets - # blessed into B::SV explicitly) and any stray erroneous SVs. - return 0 unless $$sv; - confess sprintf("cannot save that type of SV: %s (0x%x)\n", - class($sv), $$sv); -} - -sub output_all { - my $init_name = shift; - my $section; - my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect, - $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect, - $loopsect, $copsect, $svsect, $xpvsect, - $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, - $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect); - $symsect->output(\*STDOUT, "#define %s\n"); - print "\n"; - output_declarations(); - foreach $section (@sections) { - my $lines = $section->index + 1; - if ($lines) { - my $name = $section->name; - my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name); - print "Static $typename ${name}_list[$lines];\n"; - } - } - $decl->output(\*STDOUT, "%s\n"); - print "\n"; - foreach $section (@sections) { - my $lines = $section->index + 1; - if ($lines) { - my $name = $section->name; - my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name); - printf "static %s %s_list[%u] = {\n", $typename, $name, $lines; - $section->output(\*STDOUT, "\t{ %s },\n"); - print "};\n\n"; - } - } - - print <<"EOT"; -static int $init_name() -{ - dTARG; - dSP; -EOT - $init->output(\*STDOUT, "\t%s\n"); - print "\treturn 0;\n}\n"; - if ($verbose) { - warn compile_stats(); - warn "NULLOP count: $nullop_count\n"; - } -} - -sub output_declarations { - print <<'EOT'; -#ifdef BROKEN_STATIC_REDECL -#define Static extern -#else -#define Static static -#endif /* BROKEN_STATIC_REDECL */ - -#ifdef BROKEN_UNION_INIT -/* - * Cribbed from cv.h with ANY (a union) replaced by void*. - * Some pre-Standard compilers can't cope with initialising unions. Ho hum. - */ -typedef struct { - char * xpv_pv; /* pointer to malloced string */ - STRLEN xpv_cur; /* length of xp_pv as a C string */ - STRLEN xpv_len; /* allocated size */ - IV xof_off; /* integer value */ - NV xnv_nv; /* numeric value, if any */ - MAGIC* xmg_magic; /* magic for scalar array */ - HV* xmg_stash; /* class package */ - - HV * xcv_stash; - OP * xcv_start; - OP * xcv_root; - void (*xcv_xsub) (pTHXo_ CV*); - ANY xcv_xsubany; - GV * xcv_gv; - char * xcv_file; - long xcv_depth; /* >= 2 indicates recursive call */ - AV * xcv_padlist; - CV * xcv_outside; -#ifdef USE_THREADS - perl_mutex *xcv_mutexp; - struct perl_thread *xcv_owner; /* current owner thread */ -#endif /* USE_THREADS */ - cv_flags_t xcv_flags; -} XPVCV_or_similar; -#define ANYINIT(i) i -#else -#define XPVCV_or_similar XPVCV -#define ANYINIT(i) {i} -#endif /* BROKEN_UNION_INIT */ -#define Nullany ANYINIT(0) - -#define UNUSED 0 -#define sym_0 0 - -EOT - print "static GV *gv_list[$gv_index];\n" if $gv_index; - print "\n"; -} - - -sub output_boilerplate { - print <<'EOT'; -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -/* Workaround for mapstart: the only op which needs a different ppaddr */ -#undef Perl_pp_mapstart -#define Perl_pp_mapstart Perl_pp_grepstart -#define XS_DynaLoader_boot_DynaLoader boot_DynaLoader -EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); - -static void xs_init (pTHX); -static void dl_init (pTHX); -static PerlInterpreter *my_perl; -EOT -} - -sub output_main { - print <<'EOT'; -int -main(int argc, char **argv, char **env) -{ - int exitstatus; - int i; - char **fakeargv; - - PERL_SYS_INIT3(&argc,&argv,&env); - - if (!PL_do_undump) { - my_perl = perl_alloc(); - if (!my_perl) - exit(1); - perl_construct( my_perl ); - PL_perl_destruct_level = 0; - } - -#ifdef CSH - if (!PL_cshlen) - PL_cshlen = strlen(PL_cshname); -#endif - -#ifdef ALLOW_PERL_OPTIONS -#define EXTRA_OPTIONS 2 -#else -#define EXTRA_OPTIONS 3 -#endif /* ALLOW_PERL_OPTIONS */ - New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *); - fakeargv[0] = argv[0]; - fakeargv[1] = "-e"; - fakeargv[2] = ""; -#ifndef ALLOW_PERL_OPTIONS - fakeargv[3] = "--"; -#endif /* ALLOW_PERL_OPTIONS */ - for (i = 1; i < argc; i++) - fakeargv[i + EXTRA_OPTIONS] = argv[i]; - fakeargv[argc + EXTRA_OPTIONS] = 0; - - exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS, - fakeargv, NULL); - if (exitstatus) - exit( exitstatus ); - - sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]); - PL_main_cv = PL_compcv; - PL_compcv = 0; - - exitstatus = perl_init(); - if (exitstatus) - exit( exitstatus ); - dl_init(aTHX); - - exitstatus = perl_run( my_perl ); - - perl_destruct( my_perl ); - perl_free( my_perl ); - - PERL_SYS_TERM(); - - exit( exitstatus ); -} - -/* yanked from perl.c */ -static void -xs_init(pTHX) -{ - char *file = __FILE__; - dTARG; - dSP; -EOT - print "\n#ifdef USE_DYNAMIC_LOADING"; - print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/; - print "\n#endif\n" ; - # delete $xsub{'DynaLoader'}; - delete $xsub{'UNIVERSAL'}; - print("/* bootstrapping code*/\n\tSAVETMPS;\n"); - print("\ttarg=sv_newmortal();\n"); - print "#ifdef DYNALOADER_BOOTSTRAP\n"; - print "\tPUSHMARK(sp);\n"; - print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/; - print qq/\tPUTBACK;\n/; - print "\tboot_DynaLoader(aTHX_ NULL);\n"; - print qq/\tSPAGAIN;\n/; - print "#endif\n"; - foreach my $stashname (keys %xsub){ - if ($xsub{$stashname} ne 'Dynamic') { - my $stashxsub=$stashname; - $stashxsub =~ s/::/__/g; - print "\tPUSHMARK(sp);\n"; - print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/; - print qq/\tPUTBACK;\n/; - print "\tboot_$stashxsub(aTHX_ NULL);\n"; - print qq/\tSPAGAIN;\n/; - } - } - print("\tFREETMPS;\n/* end bootstrapping code */\n"); - print "}\n"; - -print <<'EOT'; -static void -dl_init(pTHX) -{ - char *file = __FILE__; - dTARG; - dSP; -EOT - print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n"); - print("\ttarg=sv_newmortal();\n"); - foreach my $stashname (@DynaLoader::dl_modules) { - warn "Loaded $stashname\n"; - if (exists($xsub{$stashname}) && $xsub{$stashname} eq 'Dynamic') { - my $stashxsub=$stashname; - $stashxsub =~ s/::/__/g; - print "\tPUSHMARK(sp);\n"; - print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/; - print qq/\tPUTBACK;\n/; - print "#ifdef DYNALOADER_BOOTSTRAP\n"; - warn "bootstrapping $stashname added to xs_init\n"; - print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/; - print "\n#else\n"; - print "\tboot_$stashxsub(aTHX_ NULL);\n"; - print "#endif\n"; - print qq/\tSPAGAIN;\n/; - } - } - print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n"); - print "}\n"; -} -sub dump_symtable { - # For debugging - my ($sym, $val); - warn "----Symbol table:\n"; - while (($sym, $val) = each %symtable) { - warn "$sym => $val\n"; - } - warn "---End of symbol table\n"; -} - -sub save_object { - my $sv; - foreach $sv (@_) { - svref_2object($sv)->save; - } -} - -sub Dummy_BootStrap { } - -sub B::GV::savecv -{ - my $gv = shift; - my $package=$gv->STASH->NAME; - my $name = $gv->NAME; - my $cv = $gv->CV; - my $sv = $gv->SV; - my $av = $gv->AV; - my $hv = $gv->HV; - - # We may be looking at this package just because it is a branch in the - # symbol table which is on the path to a package which we need to save - # e.g. this is 'Getopt' and we need to save 'Getopt::Long' - # - return unless ($unused_sub_packages{$package}); - return unless ($$cv || $$av || $$sv || $$hv); - $gv->save; -} - -sub mark_package -{ - my $package = shift; - unless ($unused_sub_packages{$package}) - { - no strict 'refs'; - $unused_sub_packages{$package} = 1; - if (defined @{$package.'::ISA'}) - { - foreach my $isa (@{$package.'::ISA'}) - { - if ($isa eq 'DynaLoader') - { - unless (defined(&{$package.'::bootstrap'})) - { - warn "Forcing bootstrap of $package\n"; - eval { $package->bootstrap }; - } - } -# else - { - unless ($unused_sub_packages{$isa}) - { - warn "$isa saved (it is in $package\'s \@ISA)\n"; - mark_package($isa); - } - } - } - } - } - return 1; -} - -sub should_save -{ - no strict qw(vars refs); - my $package = shift; - $package =~ s/::$//; - return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc. - # warn "Considering $package\n";#debug - foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages)) - { - # If this package is a prefix to something we are saving, traverse it - # but do not mark it for saving if it is not already - # e.g. to get to Getopt::Long we need to traverse Getopt but need - # not save Getopt - return 1 if ($u =~ /^$package\:\:/); - } - if (exists $unused_sub_packages{$package}) - { - # warn "Cached $package is ".$unused_sub_packages{$package}."\n"; - delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ; - return $unused_sub_packages{$package}; - } - # Omit the packages which we use (and which cause grief - # because of fancy "goto &$AUTOLOAD" stuff). - # XXX Surely there must be a nicer way to do this. - if ($package eq "FileHandle" || $package eq "Config" || - $package eq "SelectSaver" || $package =~/^(B|IO)::/) - { - delete_unsaved_hashINC($package); - return $unused_sub_packages{$package} = 0; - } - # Now see if current package looks like an OO class this is probably too strong. - foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE)) - { - if (UNIVERSAL::can($package, $m)) - { - warn "$package has method $m: saving package\n";#debug - return mark_package($package); - } - } - delete_unsaved_hashINC($package); - return $unused_sub_packages{$package} = 0; -} -sub delete_unsaved_hashINC{ - my $packname=shift; - $packname =~ s/\:\:/\//g; - $packname .= '.pm'; -# warn "deleting $packname" if $INC{$packname} ;# debug - delete $INC{$packname}; -} -sub walkpackages -{ - my ($symref, $recurse, $prefix) = @_; - my $sym; - my $ref; - no strict 'vars'; - local(*glob); - $prefix = '' unless defined $prefix; - while (($sym, $ref) = each %$symref) - { - *glob = $ref; - if ($sym =~ /::$/) - { - $sym = $prefix . $sym; - if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym)) - { - walkpackages(\%glob, $recurse, $sym); - } - } - } -} - - -sub save_unused_subs -{ - no strict qw(refs); - &descend_marked_unused; - warn "Prescan\n"; - walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 }); - warn "Saving methods\n"; - walksymtable(\%{"main::"}, "savecv", \&should_save); -} - -sub save_context -{ - my $curpad_nam = (comppadlist->ARRAY)[0]->save; - my $curpad_sym = (comppadlist->ARRAY)[1]->save; - my $inc_hv = svref_2object(\%INC)->save; - my $inc_av = svref_2object(\@INC)->save; - my $amagic_generate= amagic_generation; - $init->add( "PL_curpad = AvARRAY($curpad_sym);", - "GvHV(PL_incgv) = $inc_hv;", - "GvAV(PL_incgv) = $inc_av;", - "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));", - "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));", - "PL_amagic_generation= $amagic_generate;" ); -} - -sub descend_marked_unused { - foreach my $pack (keys %unused_sub_packages) - { - mark_package($pack); - } -} - -sub save_main { - warn "Starting compile\n"; - warn "Walking tree\n"; - seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output - walkoptree(main_root, "save"); - warn "done main optree, walking symtable for extras\n" if $debug_cv; - save_unused_subs(); - my $init_av = init_av->save; - $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}), - sprintf("PL_main_start = s\\_%x;", ${main_start()}), - "PL_initav = (AV *) $init_av;"); - save_context(); - warn "Writing output\n"; - output_boilerplate(); - print "\n"; - output_all("perl_init"); - print "\n"; - output_main(); -} - -sub init_sections { - my @sections = (init => \$init, decl => \$decl, sym => \$symsect, - binop => \$binopsect, condop => \$condopsect, - cop => \$copsect, padop => \$padopsect, - listop => \$listopsect, logop => \$logopsect, - loop => \$loopsect, op => \$opsect, pmop => \$pmopsect, - pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect, - sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect, - xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect, - xpviv => \$xpvivsect, xpvnv => \$xpvnvsect, - xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect, - xrv => \$xrvsect, xpvbm => \$xpvbmsect, - xpvio => \$xpviosect); - my ($name, $sectref); - while (($name, $sectref) = splice(@sections, 0, 2)) { - $$sectref = new B::C::Section $name, \%symtable, 0; - } -} - -sub mark_unused -{ - my ($arg,$val) = @_; - $unused_sub_packages{$arg} = $val; -} - -sub compile { - my @options = @_; - my ($option, $opt, $arg); - OPTION: - while ($option = shift @options) { - if ($option =~ /^-(.)(.*)/) { - $opt = $1; - $arg = $2; - } else { - unshift @options, $option; - last OPTION; - } - if ($opt eq "-" && $arg eq "-") { - shift @options; - last OPTION; - } - if ($opt eq "w") { - $warn_undefined_syms = 1; - } elsif ($opt eq "D") { - $arg ||= shift @options; - foreach $arg (split(//, $arg)) { - if ($arg eq "o") { - B->debug(1); - } elsif ($arg eq "c") { - $debug_cops = 1; - } elsif ($arg eq "A") { - $debug_av = 1; - } elsif ($arg eq "C") { - $debug_cv = 1; - } elsif ($arg eq "M") { - $debug_mg = 1; - } else { - warn "ignoring unknown debug option: $arg\n"; - } - } - } elsif ($opt eq "o") { - $arg ||= shift @options; - open(STDOUT, ">$arg") or return "$arg: $!\n"; - } elsif ($opt eq "v") { - $verbose = 1; - } elsif ($opt eq "u") { - $arg ||= shift @options; - mark_unused($arg,undef); - } elsif ($opt eq "f") { - $arg ||= shift @options; - if ($arg eq "cog") { - $pv_copy_on_grow = 1; - } elsif ($arg eq "no-cog") { - $pv_copy_on_grow = 0; - } - } elsif ($opt eq "O") { - $arg = 1 if $arg eq ""; - $pv_copy_on_grow = 0; - if ($arg >= 1) { - # Optimisations for -O1 - $pv_copy_on_grow = 1; - } - } elsif ($opt eq "l") { - $max_string_len = $arg; - } - } - init_sections(); - if (@options) { - return sub { - my $objname; - foreach $objname (@options) { - eval "save_object(\\$objname)"; - } - output_all(); - } - } else { - return sub { save_main() }; - } -} - -1; - -__END__ - -=head1 NAME - -B::C - Perl compiler's C backend - -=head1 SYNOPSIS - - perl -MO=C[,OPTIONS] foo.pl - -=head1 DESCRIPTION - -This compiler backend takes Perl source and generates C source code -corresponding to the internal structures that perl uses to run -your program. When the generated C source is compiled and run, it -cuts out the time which perl would have taken to load and parse -your program into its internal semi-compiled form. That means that -compiling with this backend will not help improve the runtime -execution speed of your program but may improve the start-up time. -Depending on the environment in which your program runs this may be -either a help or a hindrance. - -=head1 OPTIONS - -If there are any non-option arguments, they are taken to be -names of objects to be saved (probably doesn't work properly yet). -Without extra arguments, it saves the main program. - -=over 4 - -=item B<-ofilename> - -Output to filename instead of STDOUT - -=item B<-v> - -Verbose compilation (currently gives a few compilation statistics). - -=item B<--> - -Force end of options - -=item B<-uPackname> - -Force apparently unused subs from package Packname to be compiled. -This allows programs to use eval "foo()" even when sub foo is never -seen to be used at compile time. The down side is that any subs which -really are never used also have code generated. This option is -necessary, for example, if you have a signal handler foo which you -initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just -to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u> -options. The compiler tries to figure out which packages may possibly -have subs in which need compiling but the current version doesn't do -it very well. In particular, it is confused by nested packages (i.e. -of the form C<A::B>) where package C<A> does not contain any subs. - -=item B<-D> - -Debug options (concatenated or separate flags like C<perl -D>). - -=item B<-Do> - -OPs, prints each OP as it's processed - -=item B<-Dc> - -COPs, prints COPs as processed (incl. file & line num) - -=item B<-DA> - -prints AV information on saving - -=item B<-DC> - -prints CV information on saving - -=item B<-DM> - -prints MAGIC information on saving - -=item B<-f> - -Force optimisations on or off one at a time. - -=item B<-fcog> - -Copy-on-grow: PVs declared and initialised statically. - -=item B<-fno-cog> - -No copy-on-grow. - -=item B<-On> - -Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently, -B<-O1> and higher set B<-fcog>. - -=item B<-llimit> - -Some C compilers impose an arbitrary limit on the length of string -constants (e.g. 2048 characters for Microsoft Visual C++). The -B<-llimit> options tells the C backend not to generate string literals -exceeding that limit. - -=back - -=head1 EXAMPLES - - perl -MO=C,-ofoo.c foo.pl - perl cc_harness -o foo foo.c - -Note that C<cc_harness> lives in the C<B> subdirectory of your perl -library directory. The utility called C<perlcc> may also be used to -help make use of this compiler. - - perl -MO=C,-v,-DcA,-l2048 bar.pl > /dev/null - -=head1 BUGS - -Plenty. Current status: experimental. - -=head1 AUTHOR - -Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> - -=cut diff --git a/contrib/perl5/ext/B/B/CC.pm b/contrib/perl5/ext/B/B/CC.pm deleted file mode 100644 index 51922ee..0000000 --- a/contrib/perl5/ext/B/B/CC.pm +++ /dev/null @@ -1,2002 +0,0 @@ -# CC.pm -# -# Copyright (c) 1996, 1997, 1998 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. -# -package B::CC; -use Config; -use strict; -use B qw(main_start main_root class comppadlist peekop svref_2object - timing_info init_av sv_undef amagic_generation - OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL - OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV - OPpDEREF OPpFLIP_LINENUM G_ARRAY G_SCALAR - CXt_NULL CXt_SUB CXt_EVAL CXt_LOOP CXt_SUBST CXt_BLOCK - ); -use B::C qw(save_unused_subs objsym init_sections mark_unused - output_all output_boilerplate output_main); -use B::Bblock qw(find_leaders); -use B::Stackobj qw(:types :flags); - -# These should probably be elsewhere -# Flags for $op->flags - -my $module; # module name (when compiled with -m) -my %done; # hash keyed by $$op of leaders of basic blocks - # which have already been done. -my $leaders; # ref to hash of basic block leaders. Keys are $$op - # addresses, values are the $op objects themselves. -my @bblock_todo; # list of leaders of basic blocks that need visiting - # sometime. -my @cc_todo; # list of tuples defining what PP code needs to be - # saved (e.g. CV, main or PMOP repl code). Each tuple - # is [$name, $root, $start, @padlist]. PMOP repl code - # tuples inherit padlist. -my @stack; # shadows perl's stack when contents are known. - # Values are objects derived from class B::Stackobj -my @pad; # Lexicals in current pad as Stackobj-derived objects -my @padlist; # Copy of current padlist so PMOP repl code can find it -my @cxstack; # Shadows the (compile-time) cxstack for next,last,redo -my $jmpbuf_ix = 0; # Next free index for dynamically allocated jmpbufs -my %constobj; # OP_CONST constants as Stackobj-derived objects - # keyed by $$sv. -my $need_freetmps = 0; # We may postpone FREETMPS to the end of each basic - # block or even to the end of each loop of blocks, - # depending on optimisation options. -my $know_op = 0; # Set when C variable op already holds the right op - # (from an immediately preceding DOOP(ppname)). -my $errors = 0; # Number of errors encountered -my %skip_stack; # Hash of PP names which don't need write_back_stack -my %skip_lexicals; # Hash of PP names which don't need write_back_lexicals -my %skip_invalidate; # Hash of PP names which don't need invalidate_lexicals -my %ignore_op; # Hash of ops which do nothing except returning op_next -my %need_curcop; # Hash of ops which need PL_curcop - -my %lexstate; #state of padsvs at the start of a bblock - -BEGIN { - foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) { - $ignore_op{$_} = 1; - } -} - -my ($module_name); -my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime, - $debug_shadow, $debug_queue, $debug_lineno, $debug_timings); - -# Optimisation options. On the command line, use hyphens instead of -# underscores for compatibility with gcc-style options. We use -# underscores here because they are OK in (strict) barewords. -my ($freetmps_each_bblock, $freetmps_each_loop, $omit_taint); -my %optimise = (freetmps_each_bblock => \$freetmps_each_bblock, - freetmps_each_loop => \$freetmps_each_loop, - omit_taint => \$omit_taint); -# perl patchlevel to generate code for (defaults to current patchlevel) -my $patchlevel = int(0.5 + 1000 * ($] - 5)); - -# Could rewrite push_runtime() and output_runtime() to use a -# temporary file if memory is at a premium. -my $ppname; # name of current fake PP function -my $runtime_list_ref; -my $declare_ref; # Hash ref keyed by C variable type of declarations. - -my @pp_list; # list of [$ppname, $runtime_list_ref, $declare_ref] - # tuples to be written out. - -my ($init, $decl); - -sub init_hash { map { $_ => 1 } @_ } - -# -# Initialise the hashes for the default PP functions where we can avoid -# either write_back_stack, write_back_lexicals or invalidate_lexicals. -# -%skip_lexicals = init_hash qw(pp_enter pp_enterloop); -%skip_invalidate = init_hash qw(pp_enter pp_enterloop); -%need_curcop = init_hash qw(pp_rv2gv pp_bless pp_repeat pp_sort pp_caller - pp_reset pp_rv2cv pp_entereval pp_require pp_dofile - pp_entertry pp_enterloop pp_enteriter pp_entersub - pp_enter pp_method); - -sub debug { - if ($debug_runtime) { - warn(@_); - } else { - my @tmp=@_; - runtime(map { chomp; "/* $_ */"} @tmp); - } -} - -sub declare { - my ($type, $var) = @_; - push(@{$declare_ref->{$type}}, $var); -} - -sub push_runtime { - push(@$runtime_list_ref, @_); - warn join("\n", @_) . "\n" if $debug_runtime; -} - -sub save_runtime { - push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]); -} - -sub output_runtime { - my $ppdata; - print qq(#include "cc_runtime.h"\n); - foreach $ppdata (@pp_list) { - my ($name, $runtime, $declare) = @$ppdata; - print "\nstatic\nCCPP($name)\n{\n"; - my ($type, $varlist, $line); - while (($type, $varlist) = each %$declare) { - print "\t$type ", join(", ", @$varlist), ";\n"; - } - foreach $line (@$runtime) { - print $line, "\n"; - } - print "}\n"; - } -} - -sub runtime { - my $line; - foreach $line (@_) { - push_runtime("\t$line"); - } -} - -sub init_pp { - $ppname = shift; - $runtime_list_ref = []; - $declare_ref = {}; - runtime("dSP;"); - declare("I32", "oldsave"); - declare("SV", "**svp"); - map { declare("SV", "*$_") } qw(sv src dst left right); - declare("MAGIC", "*mg"); - $decl->add("static OP * $ppname (pTHX);"); - debug "init_pp: $ppname\n" if $debug_queue; -} - -# Initialise runtime_callback function for Stackobj class -BEGIN { B::Stackobj::set_callback(\&runtime) } - -# Initialise saveoptree_callback for B::C class -sub cc_queue { - my ($name, $root, $start, @pl) = @_; - debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n" - if $debug_queue; - if ($name eq "*ignore*") { - $name = 0; - } else { - push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]); - } - my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name); - $start = $fakeop->save; - debug "cc_queue: name $name returns $start\n" if $debug_queue; - return $start; -} -BEGIN { B::C::set_callback(\&cc_queue) } - -sub valid_int { $_[0]->{flags} & VALID_INT } -sub valid_double { $_[0]->{flags} & VALID_DOUBLE } -sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) } -sub valid_sv { $_[0]->{flags} & VALID_SV } - -sub top_int { @stack ? $stack[-1]->as_int : "TOPi" } -sub top_double { @stack ? $stack[-1]->as_double : "TOPn" } -sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" } -sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" } -sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" } - -sub pop_int { @stack ? (pop @stack)->as_int : "POPi" } -sub pop_double { @stack ? (pop @stack)->as_double : "POPn" } -sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" } -sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" } -sub pop_bool { - if (@stack) { - return ((pop @stack)->as_bool); - } else { - # Careful: POPs has an auto-decrement and SvTRUE evaluates - # its argument more than once. - runtime("sv = POPs;"); - return "SvTRUE(sv)"; - } -} - -sub write_back_lexicals { - my $avoid = shift || 0; - debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n" - if $debug_shadow; - my $lex; - foreach $lex (@pad) { - next unless ref($lex); - $lex->write_back unless $lex->{flags} & $avoid; - } -} - -sub save_or_restore_lexical_state { - my $bblock=shift; - unless( exists $lexstate{$bblock}){ - foreach my $lex (@pad) { - next unless ref($lex); - ${$lexstate{$bblock}}{$lex->{iv}} = $lex->{flags} ; - } - } - else { - foreach my $lex (@pad) { - next unless ref($lex); - my $old_flags=${$lexstate{$bblock}}{$lex->{iv}} ; - next if ( $old_flags eq $lex->{flags}); - if (($old_flags & VALID_SV) && !($lex->{flags} & VALID_SV)){ - $lex->write_back; - } - if (($old_flags & VALID_DOUBLE) && !($lex->{flags} & VALID_DOUBLE)){ - $lex->load_double; - } - if (($old_flags & VALID_INT) && !($lex->{flags} & VALID_INT)){ - $lex->load_int; - } - } - } -} - -sub write_back_stack { - my $obj; - return unless @stack; - runtime(sprintf("EXTEND(sp, %d);", scalar(@stack))); - foreach $obj (@stack) { - runtime(sprintf("PUSHs((SV*)%s);", $obj->as_sv)); - } - @stack = (); -} - -sub invalidate_lexicals { - my $avoid = shift || 0; - debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n" - if $debug_shadow; - my $lex; - foreach $lex (@pad) { - next unless ref($lex); - $lex->invalidate unless $lex->{flags} & $avoid; - } -} - -sub reload_lexicals { - my $lex; - foreach $lex (@pad) { - next unless ref($lex); - my $type = $lex->{type}; - if ($type == T_INT) { - $lex->as_int; - } elsif ($type == T_DOUBLE) { - $lex->as_double; - } else { - $lex->as_sv; - } - } -} - -{ - package B::Pseudoreg; - # - # This class allocates pseudo-registers (OK, so they're C variables). - # - my %alloc; # Keyed by variable name. A value of 1 means the - # variable has been declared. A value of 2 means - # it's in use. - - sub new_scope { %alloc = () } - - sub new ($$$) { - my ($class, $type, $prefix) = @_; - my ($ptr, $i, $varname, $status, $obj); - $prefix =~ s/^(\**)//; - $ptr = $1; - $i = 0; - do { - $varname = "$prefix$i"; - $status = $alloc{$varname}; - } while $status == 2; - if ($status != 1) { - # Not declared yet - B::CC::declare($type, "$ptr$varname"); - $alloc{$varname} = 2; # declared and in use - } - $obj = bless \$varname, $class; - return $obj; - } - sub DESTROY { - my $obj = shift; - $alloc{$$obj} = 1; # no longer in use but still declared - } -} -{ - package B::Shadow; - # - # This class gives a standard API for a perl object to shadow a - # C variable and only generate reloads/write-backs when necessary. - # - # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo"). - # Use $obj->write_back whenever shadowed_c_var needs to be up to date. - # Use $obj->invalidate whenever an unknown function may have - # set shadow itself. - - sub new { - my ($class, $write_back) = @_; - # Object fields are perl shadow variable, validity flag - # (for *C* variable) and callback sub for write_back - # (passed perl shadow variable as argument). - bless [undef, 1, $write_back], $class; - } - sub load { - my ($obj, $newval) = @_; - $obj->[1] = 0; # C variable no longer valid - $obj->[0] = $newval; - } - sub write_back { - my $obj = shift; - if (!($obj->[1])) { - $obj->[1] = 1; # C variable will now be valid - &{$obj->[2]}($obj->[0]); - } - } - sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid -} -my $curcop = new B::Shadow (sub { - my $opsym = shift->save; - runtime("PL_curcop = (COP*)$opsym;"); -}); - -# -# Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on. -# -sub dopoptoloop { - my $cxix = $#cxstack; - while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP) { - $cxix--; - } - debug "dopoptoloop: returning $cxix" if $debug_cxstack; - return $cxix; -} - -sub dopoptolabel { - my $label = shift; - my $cxix = $#cxstack; - while ($cxix >= 0 && - ($cxstack[$cxix]->{type} != CXt_LOOP || - $cxstack[$cxix]->{label} ne $label)) { - $cxix--; - } - debug "dopoptolabel: returning $cxix" if $debug_cxstack; - return $cxix; -} - -sub error { - my $format = shift; - my $file = $curcop->[0]->file; - my $line = $curcop->[0]->line; - $errors++; - if (@_) { - warn sprintf("%s:%d: $format\n", $file, $line, @_); - } else { - warn sprintf("%s:%d: %s\n", $file, $line, $format); - } -} - -# -# Load pad takes (the elements of) a PADLIST as arguments and loads -# up @pad with Stackobj-derived objects which represent those lexicals. -# If/when perl itself can generate type information (my int $foo) then -# we'll take advantage of that here. Until then, we'll use various hacks -# to tell the compiler when we want a lexical to be a particular type -# or to be a register. -# -sub load_pad { - my ($namelistav, $valuelistav) = @_; - @padlist = @_; - my @namelist = $namelistav->ARRAY; - my @valuelist = $valuelistav->ARRAY; - my $ix; - @pad = (); - debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad; - # Temporary lexicals don't get named so it's possible for @valuelist - # to be strictly longer than @namelist. We count $ix up to the end of - # @valuelist but index into @namelist for the name. Any temporaries which - # run off the end of @namelist will make $namesv undefined and we treat - # that the same as having an explicit SPECIAL sv_undef object in @namelist. - # [XXX If/when @_ becomes a lexical, we must start at 0 here.] - for ($ix = 1; $ix < @valuelist; $ix++) { - my $namesv = $namelist[$ix]; - my $type = T_UNKNOWN; - my $flags = 0; - my $name = "tmp$ix"; - my $class = class($namesv); - if (!defined($namesv) || $class eq "SPECIAL") { - # temporaries have &PL_sv_undef instead of a PVNV for a name - $flags = VALID_SV|TEMPORARY|REGISTER; - } else { - if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) { - $name = $1; - if ($2 eq "i") { - $type = T_INT; - $flags = VALID_SV|VALID_INT; - } elsif ($2 eq "d") { - $type = T_DOUBLE; - $flags = VALID_SV|VALID_DOUBLE; - } - $flags |= REGISTER if $3; - } - } - $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix, - "i_$name", "d_$name"); - - debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad; - } -} - -sub declare_pad { - my $ix; - for ($ix = 1; $ix <= $#pad; $ix++) { - my $type = $pad[$ix]->{type}; - declare("IV", $type == T_INT ? - sprintf("%s=0",$pad[$ix]->{iv}):$pad[$ix]->{iv}) if $pad[$ix]->save_int; - declare("double", $type == T_DOUBLE ? - sprintf("%s = 0",$pad[$ix]->{nv}):$pad[$ix]->{nv} )if $pad[$ix]->save_double; - - } -} -# -# Debugging stuff -# -sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) } - -# -# OP stuff -# - -sub label { - my $op = shift; - # XXX Preserve original label name for "real" labels? - return sprintf("lab_%x", $$op); -} - -sub write_label { - my $op = shift; - push_runtime(sprintf(" %s:", label($op))); -} - -sub loadop { - my $op = shift; - my $opsym = $op->save; - runtime("PL_op = $opsym;") unless $know_op; - return $opsym; -} - -sub doop { - my $op = shift; - my $ppname = $op->ppaddr; - my $sym = loadop($op); - runtime("DOOP($ppname);"); - $know_op = 1; - return $sym; -} - -sub gimme { - my $op = shift; - my $flags = $op->flags; - return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "dowantarray()"); -} - -# -# Code generation for PP code -# - -sub pp_null { - my $op = shift; - return $op->next; -} - -sub pp_stub { - my $op = shift; - my $gimme = gimme($op); - if ($gimme != G_ARRAY) { - my $obj= new B::Stackobj::Const(sv_undef); - push(@stack, $obj); - # XXX Change to push a constant sv_undef Stackobj onto @stack - #write_back_stack(); - #runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);"); - } - return $op->next; -} - -sub pp_unstack { - my $op = shift; - @stack = (); - runtime("PP_UNSTACK;"); - return $op->next; -} - -sub pp_and { - my $op = shift; - my $next = $op->next; - reload_lexicals(); - unshift(@bblock_todo, $next); - if (@stack >= 1) { - my $bool = pop_bool(); - write_back_stack(); - save_or_restore_lexical_state($$next); - runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next))); - } else { - save_or_restore_lexical_state($$next); - runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)), - "*sp--;"); - } - return $op->other; -} - -sub pp_or { - my $op = shift; - my $next = $op->next; - reload_lexicals(); - unshift(@bblock_todo, $next); - if (@stack >= 1) { - my $bool = pop_bool @stack; - write_back_stack(); - save_or_restore_lexical_state($$next); - runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }", - $bool, label($next))); - } else { - save_or_restore_lexical_state($$next); - runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)), - "*sp--;"); - } - return $op->other; -} - -sub pp_cond_expr { - my $op = shift; - my $false = $op->next; - unshift(@bblock_todo, $false); - reload_lexicals(); - my $bool = pop_bool(); - write_back_stack(); - save_or_restore_lexical_state($$false); - runtime(sprintf("if (!$bool) goto %s;", label($false))); - return $op->other; -} - -sub pp_padsv { - my $op = shift; - my $ix = $op->targ; - push(@stack, $pad[$ix]); - if ($op->flags & OPf_MOD) { - my $private = $op->private; - if ($private & OPpLVAL_INTRO) { - runtime("SAVECLEARSV(PL_curpad[$ix]);"); - } elsif ($private & OPpDEREF) { - runtime(sprintf("vivify_ref(PL_curpad[%d], %d);", - $ix, $private & OPpDEREF)); - $pad[$ix]->invalidate; - } - } - return $op->next; -} - -sub pp_const { - my $op = shift; - my $sv = $op->sv; - my $obj; - # constant could be in the pad (under useithreads) - if ($$sv) { - $obj = $constobj{$$sv}; - if (!defined($obj)) { - $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv); - } - } - else { - $obj = $pad[$op->targ]; - } - push(@stack, $obj); - return $op->next; -} - -sub pp_nextstate { - my $op = shift; - $curcop->load($op); - @stack = (); - debug(sprintf("%s:%d\n", $op->file, $op->line)) if $debug_lineno; - runtime("TAINT_NOT;") unless $omit_taint; - runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;"); - if ($freetmps_each_bblock || $freetmps_each_loop) { - $need_freetmps = 1; - } else { - runtime("FREETMPS;"); - } - return $op->next; -} - -sub pp_dbstate { - my $op = shift; - $curcop->invalidate; # XXX? - return default_pp($op); -} - -#default_pp will handle this: -#sub pp_bless { $curcop->write_back; default_pp(@_) } -#sub pp_repeat { $curcop->write_back; default_pp(@_) } -# The following subs need $curcop->write_back if we decide to support arybase: -# pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice -#sub pp_caller { $curcop->write_back; default_pp(@_) } -#sub pp_reset { $curcop->write_back; default_pp(@_) } - -sub pp_rv2gv{ - my $op =shift; - $curcop->write_back; - write_back_lexicals() unless $skip_lexicals{$ppname}; - write_back_stack() unless $skip_stack{$ppname}; - my $sym=doop($op); - if ($op->private & OPpDEREF) { - $init->add(sprintf("((UNOP *)$sym)->op_first = $sym;")); - $init->add(sprintf("((UNOP *)$sym)->op_type = %d;", - $op->first->type)); - } - return $op->next; -} -sub pp_sort { - my $op = shift; - my $ppname = $op->ppaddr; - if ( $op->flags & OPf_SPECIAL && $op->flags & OPf_STACKED){ - #this indicates the sort BLOCK Array case - #ugly surgery required. - my $root=$op->first->sibling->first; - my $start=$root->first; - $op->first->save; - $op->first->sibling->save; - $root->save; - my $sym=$start->save; - my $fakeop=cc_queue("pp_sort".$$op,$root,$start); - $init->add(sprintf("(%s)->op_next=%s;",$sym,$fakeop)); - } - $curcop->write_back; - write_back_lexicals(); - write_back_stack(); - doop($op); - return $op->next; -} - -sub pp_gv { - my $op = shift; - my $gvsym; - if ($Config{useithreads}) { - $gvsym = $pad[$op->padix]->as_sv; - } - else { - $gvsym = $op->gv->save; - } - write_back_stack(); - runtime("XPUSHs((SV*)$gvsym);"); - return $op->next; -} - -sub pp_gvsv { - my $op = shift; - my $gvsym; - if ($Config{useithreads}) { - $gvsym = $pad[$op->padix]->as_sv; - } - else { - $gvsym = $op->gv->save; - } - write_back_stack(); - if ($op->private & OPpLVAL_INTRO) { - runtime("XPUSHs(save_scalar($gvsym));"); - } else { - runtime("XPUSHs(GvSV($gvsym));"); - } - return $op->next; -} - -sub pp_aelemfast { - my $op = shift; - my $gvsym; - if ($Config{useithreads}) { - $gvsym = $pad[$op->padix]->as_sv; - } - else { - $gvsym = $op->gv->save; - } - my $ix = $op->private; - my $flag = $op->flags & OPf_MOD; - write_back_stack(); - runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);", - "PUSHs(svp ? *svp : &PL_sv_undef);"); - return $op->next; -} - -sub int_binop { - my ($op, $operator) = @_; - if ($op->flags & OPf_STACKED) { - my $right = pop_int(); - if (@stack >= 1) { - my $left = top_int(); - $stack[-1]->set_int(&$operator($left, $right)); - } else { - runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right))); - } - } else { - my $targ = $pad[$op->targ]; - my $right = new B::Pseudoreg ("IV", "riv"); - my $left = new B::Pseudoreg ("IV", "liv"); - runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int)); - $targ->set_int(&$operator($$left, $$right)); - push(@stack, $targ); - } - return $op->next; -} - -sub INTS_CLOSED () { 0x1 } -sub INT_RESULT () { 0x2 } -sub NUMERIC_RESULT () { 0x4 } - -sub numeric_binop { - my ($op, $operator, $flags) = @_; - my $force_int = 0; - $force_int ||= ($flags & INT_RESULT); - $force_int ||= ($flags & INTS_CLOSED && @stack >= 2 - && valid_int($stack[-2]) && valid_int($stack[-1])); - if ($op->flags & OPf_STACKED) { - my $right = pop_numeric(); - if (@stack >= 1) { - my $left = top_numeric(); - if ($force_int) { - $stack[-1]->set_int(&$operator($left, $right)); - } else { - $stack[-1]->set_numeric(&$operator($left, $right)); - } - } else { - if ($force_int) { - my $rightruntime = new B::Pseudoreg ("IV", "riv"); - runtime(sprintf("$$rightruntime = %s;",$right)); - runtime(sprintf("sv_setiv(TOPs, %s);", - &$operator("TOPi", $$rightruntime))); - } else { - my $rightruntime = new B::Pseudoreg ("double", "rnv"); - runtime(sprintf("$$rightruntime = %s;",$right)); - runtime(sprintf("sv_setnv(TOPs, %s);", - &$operator("TOPn",$$rightruntime))); - } - } - } else { - my $targ = $pad[$op->targ]; - $force_int ||= ($targ->{type} == T_INT); - if ($force_int) { - my $right = new B::Pseudoreg ("IV", "riv"); - my $left = new B::Pseudoreg ("IV", "liv"); - runtime(sprintf("$$right = %s; $$left = %s;", - pop_numeric(), pop_numeric)); - $targ->set_int(&$operator($$left, $$right)); - } else { - my $right = new B::Pseudoreg ("double", "rnv"); - my $left = new B::Pseudoreg ("double", "lnv"); - runtime(sprintf("$$right = %s; $$left = %s;", - pop_numeric(), pop_numeric)); - $targ->set_numeric(&$operator($$left, $$right)); - } - push(@stack, $targ); - } - return $op->next; -} - -sub pp_ncmp { - my ($op) = @_; - if ($op->flags & OPf_STACKED) { - my $right = pop_numeric(); - if (@stack >= 1) { - my $left = top_numeric(); - runtime sprintf("if (%s > %s){",$left,$right); - $stack[-1]->set_int(1); - $stack[-1]->write_back(); - runtime sprintf("}else if (%s < %s ) {",$left,$right); - $stack[-1]->set_int(-1); - $stack[-1]->write_back(); - runtime sprintf("}else if (%s == %s) {",$left,$right); - $stack[-1]->set_int(0); - $stack[-1]->write_back(); - runtime sprintf("}else {"); - $stack[-1]->set_sv("&PL_sv_undef"); - runtime "}"; - } else { - my $rightruntime = new B::Pseudoreg ("double", "rnv"); - runtime(sprintf("$$rightruntime = %s;",$right)); - runtime sprintf(qq/if ("TOPn" > %s){/,$rightruntime); - runtime sprintf("sv_setiv(TOPs,1);"); - runtime sprintf(qq/}else if ( "TOPn" < %s ) {/,$$rightruntime); - runtime sprintf("sv_setiv(TOPs,-1);"); - runtime sprintf(qq/} else if ("TOPn" == %s) {/,$$rightruntime); - runtime sprintf("sv_setiv(TOPs,0);"); - runtime sprintf(qq/}else {/); - runtime sprintf("sv_setiv(TOPs,&PL_sv_undef;"); - runtime "}"; - } - } else { - my $targ = $pad[$op->targ]; - my $right = new B::Pseudoreg ("double", "rnv"); - my $left = new B::Pseudoreg ("double", "lnv"); - runtime(sprintf("$$right = %s; $$left = %s;", - pop_numeric(), pop_numeric)); - runtime sprintf("if (%s > %s){",$$left,$$right); - $targ->set_int(1); - $targ->write_back(); - runtime sprintf("}else if (%s < %s ) {",$$left,$$right); - $targ->set_int(-1); - $targ->write_back(); - runtime sprintf("}else if (%s == %s) {",$$left,$$right); - $targ->set_int(0); - $targ->write_back(); - runtime sprintf("}else {"); - $targ->set_sv("&PL_sv_undef"); - runtime "}"; - push(@stack, $targ); - } - return $op->next; -} - -sub sv_binop { - my ($op, $operator, $flags) = @_; - if ($op->flags & OPf_STACKED) { - my $right = pop_sv(); - if (@stack >= 1) { - my $left = top_sv(); - if ($flags & INT_RESULT) { - $stack[-1]->set_int(&$operator($left, $right)); - } elsif ($flags & NUMERIC_RESULT) { - $stack[-1]->set_numeric(&$operator($left, $right)); - } else { - # XXX Does this work? - runtime(sprintf("sv_setsv($left, %s);", - &$operator($left, $right))); - $stack[-1]->invalidate; - } - } else { - my $f; - if ($flags & INT_RESULT) { - $f = "sv_setiv"; - } elsif ($flags & NUMERIC_RESULT) { - $f = "sv_setnv"; - } else { - $f = "sv_setsv"; - } - runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right))); - } - } else { - my $targ = $pad[$op->targ]; - runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv)); - if ($flags & INT_RESULT) { - $targ->set_int(&$operator("left", "right")); - } elsif ($flags & NUMERIC_RESULT) { - $targ->set_numeric(&$operator("left", "right")); - } else { - # XXX Does this work? - runtime(sprintf("sv_setsv(%s, %s);", - $targ->as_sv, &$operator("left", "right"))); - $targ->invalidate; - } - push(@stack, $targ); - } - return $op->next; -} - -sub bool_int_binop { - my ($op, $operator) = @_; - my $right = new B::Pseudoreg ("IV", "riv"); - my $left = new B::Pseudoreg ("IV", "liv"); - runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int())); - my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b")); - $bool->set_int(&$operator($$left, $$right)); - push(@stack, $bool); - return $op->next; -} - -sub bool_numeric_binop { - my ($op, $operator) = @_; - my $right = new B::Pseudoreg ("double", "rnv"); - my $left = new B::Pseudoreg ("double", "lnv"); - runtime(sprintf("$$right = %s; $$left = %s;", - pop_numeric(), pop_numeric())); - my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b")); - $bool->set_numeric(&$operator($$left, $$right)); - push(@stack, $bool); - return $op->next; -} - -sub bool_sv_binop { - my ($op, $operator) = @_; - runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv())); - my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b")); - $bool->set_numeric(&$operator("left", "right")); - push(@stack, $bool); - return $op->next; -} - -sub infix_op { - my $opname = shift; - return sub { "$_[0] $opname $_[1]" } -} - -sub prefix_op { - my $opname = shift; - return sub { sprintf("%s(%s)", $opname, join(", ", @_)) } -} - -BEGIN { - my $plus_op = infix_op("+"); - my $minus_op = infix_op("-"); - my $multiply_op = infix_op("*"); - my $divide_op = infix_op("/"); - my $modulo_op = infix_op("%"); - my $lshift_op = infix_op("<<"); - my $rshift_op = infix_op(">>"); - my $scmp_op = prefix_op("sv_cmp"); - my $seq_op = prefix_op("sv_eq"); - my $sne_op = prefix_op("!sv_eq"); - my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" }; - my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" }; - my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" }; - my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" }; - my $eq_op = infix_op("=="); - my $ne_op = infix_op("!="); - my $lt_op = infix_op("<"); - my $gt_op = infix_op(">"); - my $le_op = infix_op("<="); - my $ge_op = infix_op(">="); - - # - # XXX The standard perl PP code has extra handling for - # some special case arguments of these operators. - # - sub pp_add { numeric_binop($_[0], $plus_op) } - sub pp_subtract { numeric_binop($_[0], $minus_op) } - sub pp_multiply { numeric_binop($_[0], $multiply_op) } - sub pp_divide { numeric_binop($_[0], $divide_op) } - sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's - - sub pp_left_shift { int_binop($_[0], $lshift_op) } - sub pp_right_shift { int_binop($_[0], $rshift_op) } - sub pp_i_add { int_binop($_[0], $plus_op) } - sub pp_i_subtract { int_binop($_[0], $minus_op) } - sub pp_i_multiply { int_binop($_[0], $multiply_op) } - sub pp_i_divide { int_binop($_[0], $divide_op) } - sub pp_i_modulo { int_binop($_[0], $modulo_op) } - - sub pp_eq { bool_numeric_binop($_[0], $eq_op) } - sub pp_ne { bool_numeric_binop($_[0], $ne_op) } - sub pp_lt { bool_numeric_binop($_[0], $lt_op) } - sub pp_gt { bool_numeric_binop($_[0], $gt_op) } - sub pp_le { bool_numeric_binop($_[0], $le_op) } - sub pp_ge { bool_numeric_binop($_[0], $ge_op) } - - sub pp_i_eq { bool_int_binop($_[0], $eq_op) } - sub pp_i_ne { bool_int_binop($_[0], $ne_op) } - sub pp_i_lt { bool_int_binop($_[0], $lt_op) } - sub pp_i_gt { bool_int_binop($_[0], $gt_op) } - sub pp_i_le { bool_int_binop($_[0], $le_op) } - sub pp_i_ge { bool_int_binop($_[0], $ge_op) } - - sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) } - sub pp_slt { bool_sv_binop($_[0], $slt_op) } - sub pp_sgt { bool_sv_binop($_[0], $sgt_op) } - sub pp_sle { bool_sv_binop($_[0], $sle_op) } - sub pp_sge { bool_sv_binop($_[0], $sge_op) } - sub pp_seq { bool_sv_binop($_[0], $seq_op) } - sub pp_sne { bool_sv_binop($_[0], $sne_op) } -} - - -sub pp_sassign { - my $op = shift; - my $backwards = $op->private & OPpASSIGN_BACKWARDS; - my ($dst, $src); - if (@stack >= 2) { - $dst = pop @stack; - $src = pop @stack; - ($src, $dst) = ($dst, $src) if $backwards; - my $type = $src->{type}; - if ($type == T_INT) { - $dst->set_int($src->as_int,$src->{flags} & VALID_UNSIGNED); - } elsif ($type == T_DOUBLE) { - $dst->set_numeric($src->as_numeric); - } else { - $dst->set_sv($src->as_sv); - } - push(@stack, $dst); - } elsif (@stack == 1) { - if ($backwards) { - my $src = pop @stack; - my $type = $src->{type}; - runtime("if (PL_tainting && PL_tainted) TAINT_NOT;"); - if ($type == T_INT) { - if ($src->{flags} & VALID_UNSIGNED){ - runtime sprintf("sv_setuv(TOPs, %s);", $src->as_int); - }else{ - runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int); - } - } elsif ($type == T_DOUBLE) { - runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double); - } else { - runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv); - } - runtime("SvSETMAGIC(TOPs);"); - } else { - my $dst = $stack[-1]; - my $type = $dst->{type}; - runtime("sv = POPs;"); - runtime("MAYBE_TAINT_SASSIGN_SRC(sv);"); - if ($type == T_INT) { - $dst->set_int("SvIV(sv)"); - } elsif ($type == T_DOUBLE) { - $dst->set_double("SvNV(sv)"); - } else { - runtime("SvSetMagicSV($dst->{sv}, sv);"); - $dst->invalidate; - } - } - } else { - if ($backwards) { - runtime("src = POPs; dst = TOPs;"); - } else { - runtime("dst = POPs; src = TOPs;"); - } - runtime("MAYBE_TAINT_SASSIGN_SRC(src);", - "SvSetSV(dst, src);", - "SvSETMAGIC(dst);", - "SETs(dst);"); - } - return $op->next; -} - -sub pp_preinc { - my $op = shift; - if (@stack >= 1) { - my $obj = $stack[-1]; - my $type = $obj->{type}; - if ($type == T_INT || $type == T_DOUBLE) { - $obj->set_int($obj->as_int . " + 1"); - } else { - runtime sprintf("PP_PREINC(%s);", $obj->as_sv); - $obj->invalidate(); - } - } else { - runtime sprintf("PP_PREINC(TOPs);"); - } - return $op->next; -} - - -sub pp_pushmark { - my $op = shift; - write_back_stack(); - runtime("PUSHMARK(sp);"); - return $op->next; -} - -sub pp_list { - my $op = shift; - write_back_stack(); - my $gimme = gimme($op); - if ($gimme == G_ARRAY) { # sic - runtime("POPMARK;"); # need this even though not a "full" pp_list - } else { - runtime("PP_LIST($gimme);"); - } - return $op->next; -} - -sub pp_entersub { - my $op = shift; - $curcop->write_back; - write_back_lexicals(REGISTER|TEMPORARY); - write_back_stack(); - my $sym = doop($op); - runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){"); - runtime("PL_op = (*PL_op->op_ppaddr)(aTHX);"); - runtime("SPAGAIN;}"); - $know_op = 0; - invalidate_lexicals(REGISTER|TEMPORARY); - return $op->next; -} -sub pp_formline { - my $op = shift; - my $ppname = $op->ppaddr; - write_back_lexicals() unless $skip_lexicals{$ppname}; - write_back_stack() unless $skip_stack{$ppname}; - my $sym=doop($op); - # See comment in pp_grepwhile to see why! - $init->add("((LISTOP*)$sym)->op_first = $sym;"); - runtime("if (PL_op == ((LISTOP*)($sym))->op_first){"); - save_or_restore_lexical_state(${$op->first}); - runtime( sprintf("goto %s;",label($op->first))); - runtime("}"); - return $op->next; -} - -sub pp_goto{ - - my $op = shift; - my $ppname = $op->ppaddr; - write_back_lexicals() unless $skip_lexicals{$ppname}; - write_back_stack() unless $skip_stack{$ppname}; - my $sym=doop($op); - runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}"); - invalidate_lexicals() unless $skip_invalidate{$ppname}; - return $op->next; -} -sub pp_enterwrite { - my $op = shift; - pp_entersub($op); -} -sub pp_leavesub{ - my $op = shift; - write_back_lexicals() unless $skip_lexicals{$ppname}; - write_back_stack() unless $skip_stack{$ppname}; - runtime("if (PL_curstackinfo->si_type == PERLSI_SORT){"); - runtime("\tPUTBACK;return 0;"); - runtime("}"); - doop($op); - return $op->next; -} -sub pp_leavewrite { - my $op = shift; - write_back_lexicals(REGISTER|TEMPORARY); - write_back_stack(); - my $sym = doop($op); - # XXX Is this the right way to distinguish between it returning - # CvSTART(cv) (via doform) and pop_return()? - #runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(aTHX);"); - runtime("SPAGAIN;"); - $know_op = 0; - invalidate_lexicals(REGISTER|TEMPORARY); - return $op->next; -} - -sub doeval { - my $op = shift; - $curcop->write_back; - write_back_lexicals(REGISTER|TEMPORARY); - write_back_stack(); - my $sym = loadop($op); - my $ppaddr = $op->ppaddr; - #runtime(qq/printf("$ppaddr type eval\n");/); - runtime("PP_EVAL($ppaddr, ($sym)->op_next);"); - $know_op = 1; - invalidate_lexicals(REGISTER|TEMPORARY); - return $op->next; -} - -sub pp_entereval { doeval(@_) } -sub pp_dofile { doeval(@_) } - -#pp_require is protected by pp_entertry, so no protection for it. -sub pp_require { - my $op = shift; - $curcop->write_back; - write_back_lexicals(REGISTER|TEMPORARY); - write_back_stack(); - my $sym = doop($op); - runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){"); - runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);"); - runtime("SPAGAIN;}"); - $know_op = 1; - invalidate_lexicals(REGISTER|TEMPORARY); - return $op->next; -} - - -sub pp_entertry { - my $op = shift; - $curcop->write_back; - write_back_lexicals(REGISTER|TEMPORARY); - write_back_stack(); - my $sym = doop($op); - my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++); - declare("JMPENV", $jmpbuf); - runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next))); - invalidate_lexicals(REGISTER|TEMPORARY); - return $op->next; -} - -sub pp_leavetry{ - my $op=shift; - default_pp($op); - runtime("PP_LEAVETRY;"); - return $op->next; -} - -sub pp_grepstart { - my $op = shift; - if ($need_freetmps && $freetmps_each_loop) { - runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up - $need_freetmps = 0; - } - write_back_stack(); - my $sym= doop($op); - my $next=$op->next; - $next->save; - my $nexttonext=$next->next; - $nexttonext->save; - save_or_restore_lexical_state($$nexttonext); - runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;", - label($nexttonext))); - return $op->next->other; -} - -sub pp_mapstart { - my $op = shift; - if ($need_freetmps && $freetmps_each_loop) { - runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up - $need_freetmps = 0; - } - write_back_stack(); - # pp_mapstart can return either op_next->op_next or op_next->op_other and - # we need to be able to distinguish the two at runtime. - my $sym= doop($op); - my $next=$op->next; - $next->save; - my $nexttonext=$next->next; - $nexttonext->save; - save_or_restore_lexical_state($$nexttonext); - runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;", - label($nexttonext))); - return $op->next->other; -} - -sub pp_grepwhile { - my $op = shift; - my $next = $op->next; - unshift(@bblock_todo, $next); - write_back_lexicals(); - write_back_stack(); - my $sym = doop($op); - # pp_grepwhile can return either op_next or op_other and we need to - # be able to distinguish the two at runtime. Since it's possible for - # both ops to be "inlined", the fields could both be zero. To get - # around that, we hack op_next to be our own op (purely because we - # know it's a non-NULL pointer and can't be the same as op_other). - $init->add("((LOGOP*)$sym)->op_next = $sym;"); - save_or_restore_lexical_state($$next); - runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next))); - $know_op = 0; - return $op->other; -} - -sub pp_mapwhile { - pp_grepwhile(@_); -} - -sub pp_return { - my $op = shift; - write_back_lexicals(REGISTER|TEMPORARY); - write_back_stack(); - doop($op); - runtime("PUTBACK;", "return PL_op;"); - $know_op = 0; - return $op->next; -} - -sub nyi { - my $op = shift; - warn sprintf("%s not yet implemented properly\n", $op->ppaddr); - return default_pp($op); -} - -sub pp_range { - my $op = shift; - my $flags = $op->flags; - if (!($flags & OPf_WANT)) { - error("context of range unknown at compile-time"); - } - write_back_lexicals(); - write_back_stack(); - unless (($flags & OPf_WANT)== OPf_WANT_LIST) { - # We need to save our UNOP structure since pp_flop uses - # it to find and adjust out targ. We don't need it ourselves. - $op->save; - save_or_restore_lexical_state(${$op->other}); - runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;", - $op->targ, label($op->other)); - unshift(@bblock_todo, $op->other); - } - return $op->next; -} - -sub pp_flip { - my $op = shift; - my $flags = $op->flags; - if (!($flags & OPf_WANT)) { - error("context of flip unknown at compile-time"); - } - if (($flags & OPf_WANT)==OPf_WANT_LIST) { - return $op->first->other; - } - write_back_lexicals(); - write_back_stack(); - # We need to save our UNOP structure since pp_flop uses - # it to find and adjust out targ. We don't need it ourselves. - $op->save; - my $ix = $op->targ; - my $rangeix = $op->first->targ; - runtime(($op->private & OPpFLIP_LINENUM) ? - "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {" - : "if (SvTRUE(TOPs)) {"); - runtime("\tsv_setiv(PL_curpad[$rangeix], 1);"); - if ($op->flags & OPf_SPECIAL) { - runtime("sv_setiv(PL_curpad[$ix], 1);"); - } else { - save_or_restore_lexical_state(${$op->first->other}); - runtime("\tsv_setiv(PL_curpad[$ix], 0);", - "\tsp--;", - sprintf("\tgoto %s;", label($op->first->other))); - } - runtime("}", - qq{sv_setpv(PL_curpad[$ix], "");}, - "SETs(PL_curpad[$ix]);"); - $know_op = 0; - return $op->next; -} - -sub pp_flop { - my $op = shift; - default_pp($op); - $know_op = 0; - return $op->next; -} - -sub enterloop { - my $op = shift; - my $nextop = $op->nextop; - my $lastop = $op->lastop; - my $redoop = $op->redoop; - $curcop->write_back; - debug "enterloop: pushing on cxstack" if $debug_cxstack; - push(@cxstack, { - type => CXt_LOOP, - op => $op, - "label" => $curcop->[0]->label, - nextop => $nextop, - lastop => $lastop, - redoop => $redoop - }); - $nextop->save; - $lastop->save; - $redoop->save; - return default_pp($op); -} - -sub pp_enterloop { enterloop(@_) } -sub pp_enteriter { enterloop(@_) } - -sub pp_leaveloop { - my $op = shift; - if (!@cxstack) { - die "panic: leaveloop"; - } - debug "leaveloop: popping from cxstack" if $debug_cxstack; - pop(@cxstack); - return default_pp($op); -} - -sub pp_next { - my $op = shift; - my $cxix; - if ($op->flags & OPf_SPECIAL) { - $cxix = dopoptoloop(); - if ($cxix < 0) { - error('"next" used outside loop'); - return $op->next; # ignore the op - } - } else { - $cxix = dopoptolabel($op->pv); - if ($cxix < 0) { - error('Label not found at compile time for "next %s"', $op->pv); - return $op->next; # ignore the op - } - } - default_pp($op); - my $nextop = $cxstack[$cxix]->{nextop}; - push(@bblock_todo, $nextop); - save_or_restore_lexical_state($$nextop); - runtime(sprintf("goto %s;", label($nextop))); - return $op->next; -} - -sub pp_redo { - my $op = shift; - my $cxix; - if ($op->flags & OPf_SPECIAL) { - $cxix = dopoptoloop(); - if ($cxix < 0) { - error('"redo" used outside loop'); - return $op->next; # ignore the op - } - } else { - $cxix = dopoptolabel($op->pv); - if ($cxix < 0) { - error('Label not found at compile time for "redo %s"', $op->pv); - return $op->next; # ignore the op - } - } - default_pp($op); - my $redoop = $cxstack[$cxix]->{redoop}; - push(@bblock_todo, $redoop); - save_or_restore_lexical_state($$redoop); - runtime(sprintf("goto %s;", label($redoop))); - return $op->next; -} - -sub pp_last { - my $op = shift; - my $cxix; - if ($op->flags & OPf_SPECIAL) { - $cxix = dopoptoloop(); - if ($cxix < 0) { - error('"last" used outside loop'); - return $op->next; # ignore the op - } - } else { - $cxix = dopoptolabel($op->pv); - if ($cxix < 0) { - error('Label not found at compile time for "last %s"', $op->pv); - return $op->next; # ignore the op - } - # XXX Add support for "last" to leave non-loop blocks - if ($cxstack[$cxix]->{type} != CXt_LOOP) { - error('Use of "last" for non-loop blocks is not yet implemented'); - return $op->next; # ignore the op - } - } - default_pp($op); - my $lastop = $cxstack[$cxix]->{lastop}->next; - push(@bblock_todo, $lastop); - save_or_restore_lexical_state($$lastop); - runtime(sprintf("goto %s;", label($lastop))); - return $op->next; -} - -sub pp_subst { - my $op = shift; - write_back_lexicals(); - write_back_stack(); - my $sym = doop($op); - my $replroot = $op->pmreplroot; - if ($$replroot) { - save_or_restore_lexical_state($$replroot); - runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;", - $sym, label($replroot)); - $op->pmreplstart->save; - push(@bblock_todo, $replroot); - } - invalidate_lexicals(); - return $op->next; -} - -sub pp_substcont { - my $op = shift; - write_back_lexicals(); - write_back_stack(); - doop($op); - my $pmop = $op->other; - # warn sprintf("substcont: op = %s, pmop = %s\n", - # peekop($op), peekop($pmop));#debug -# my $pmopsym = objsym($pmop); - my $pmopsym = $pmop->save; # XXX can this recurse? -# warn "pmopsym = $pmopsym\n";#debug - save_or_restore_lexical_state(${$pmop->pmreplstart}); - runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;", - $pmopsym, label($pmop->pmreplstart)); - invalidate_lexicals(); - return $pmop->next; -} - -sub default_pp { - my $op = shift; - my $ppname = "pp_" . $op->name; - if ($curcop and $need_curcop{$ppname}){ - $curcop->write_back; - } - write_back_lexicals() unless $skip_lexicals{$ppname}; - write_back_stack() unless $skip_stack{$ppname}; - doop($op); - # XXX If the only way that ops can write to a TEMPORARY lexical is - # when it's named in $op->targ then we could call - # invalidate_lexicals(TEMPORARY) and avoid having to write back all - # the temporaries. For now, we'll play it safe and write back the lot. - invalidate_lexicals() unless $skip_invalidate{$ppname}; - return $op->next; -} - -sub compile_op { - my $op = shift; - my $ppname = "pp_" . $op->name; - if (exists $ignore_op{$ppname}) { - return $op->next; - } - debug peek_stack() if $debug_stack; - if ($debug_op) { - debug sprintf("%s [%s]\n", - peekop($op), - $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ); - } - no strict 'refs'; - if (defined(&$ppname)) { - $know_op = 0; - return &$ppname($op); - } else { - return default_pp($op); - } -} - -sub compile_bblock { - my $op = shift; - #warn "compile_bblock: ", peekop($op), "\n"; # debug - save_or_restore_lexical_state($$op); - write_label($op); - $know_op = 0; - do { - $op = compile_op($op); - } while (defined($op) && $$op && !exists($leaders->{$$op})); - write_back_stack(); # boo hoo: big loss - reload_lexicals(); - return $op; -} - -sub cc { - my ($name, $root, $start, @padlist) = @_; - my $op; - if($done{$$start}){ - #warn "repeat=>".ref($start)."$name,\n";#debug - $decl->add(sprintf("#define $name %s",$done{$$start})); - return; - } - init_pp($name); - load_pad(@padlist); - %lexstate=(); - B::Pseudoreg->new_scope; - @cxstack = (); - if ($debug_timings) { - warn sprintf("Basic block analysis at %s\n", timing_info); - } - $leaders = find_leaders($root, $start); - my @leaders= keys %$leaders; - if ($#leaders > -1) { - @bblock_todo = ($start, values %$leaders) ; - } else{ - runtime("return PL_op?PL_op->op_next:0;"); - } - if ($debug_timings) { - warn sprintf("Compilation at %s\n", timing_info); - } - while (@bblock_todo) { - $op = shift @bblock_todo; - #warn sprintf("Considering basic block %s\n", peekop($op)); # debug - next if !defined($op) || !$$op || $done{$$op}; - #warn "...compiling it\n"; # debug - do { - $done{$$op} = $name; - $op = compile_bblock($op); - if ($need_freetmps && $freetmps_each_bblock) { - runtime("FREETMPS;"); - $need_freetmps = 0; - } - } while defined($op) && $$op && !$done{$$op}; - if ($need_freetmps && $freetmps_each_loop) { - runtime("FREETMPS;"); - $need_freetmps = 0; - } - if (!$$op) { - runtime("PUTBACK;","return PL_op;"); - } elsif ($done{$$op}) { - save_or_restore_lexical_state($$op); - runtime(sprintf("goto %s;", label($op))); - } - } - if ($debug_timings) { - warn sprintf("Saving runtime at %s\n", timing_info); - } - declare_pad(@padlist) ; - save_runtime(); -} - -sub cc_recurse { - my $ccinfo; - my $start; - $start = cc_queue(@_) if @_; - while ($ccinfo = shift @cc_todo) { - cc(@$ccinfo); - } - return $start; -} - -sub cc_obj { - my ($name, $cvref) = @_; - my $cv = svref_2object($cvref); - my @padlist = $cv->PADLIST->ARRAY; - my $curpad_sym = $padlist[1]->save; - cc_recurse($name, $cv->ROOT, $cv->START, @padlist); -} - -sub cc_main { - my @comppadlist = comppadlist->ARRAY; - my $curpad_nam = $comppadlist[0]->save; - my $curpad_sym = $comppadlist[1]->save; - my $init_av = init_av->save; - my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist); - # Do save_unused_subs before saving inc_hv - save_unused_subs(); - cc_recurse(); - - my $inc_hv = svref_2object(\%INC)->save; - my $inc_av = svref_2object(\@INC)->save; - my $amagic_generate= amagic_generation; - return if $errors; - if (!defined($module)) { - $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}), - "PL_main_start = $start;", - "PL_curpad = AvARRAY($curpad_sym);", - "PL_initav = (AV *) $init_av;", - "GvHV(PL_incgv) = $inc_hv;", - "GvAV(PL_incgv) = $inc_av;", - "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));", - "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));", - "PL_amagic_generation= $amagic_generate;", - ); - - } - seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output - output_boilerplate(); - print "\n"; - output_all("perl_init"); - output_runtime(); - print "\n"; - output_main(); - if (defined($module)) { - my $cmodule = $module; - $cmodule =~ s/::/__/g; - print <<"EOT"; - -#include "XSUB.h" -XS(boot_$cmodule) -{ - dXSARGS; - perl_init(); - ENTER; - SAVETMPS; - SAVEVPTR(PL_curpad); - SAVEVPTR(PL_op); - PL_curpad = AvARRAY($curpad_sym); - PL_op = $start; - pp_main(aTHX); - FREETMPS; - LEAVE; - ST(0) = &PL_sv_yes; - XSRETURN(1); -} -EOT - } - if ($debug_timings) { - warn sprintf("Done at %s\n", timing_info); - } -} - -sub compile { - my @options = @_; - my ($option, $opt, $arg); - OPTION: - while ($option = shift @options) { - if ($option =~ /^-(.)(.*)/) { - $opt = $1; - $arg = $2; - } else { - unshift @options, $option; - last OPTION; - } - if ($opt eq "-" && $arg eq "-") { - shift @options; - last OPTION; - } elsif ($opt eq "o") { - $arg ||= shift @options; - open(STDOUT, ">$arg") or return "open '>$arg': $!\n"; - } elsif ($opt eq "n") { - $arg ||= shift @options; - $module_name = $arg; - } elsif ($opt eq "u") { - $arg ||= shift @options; - mark_unused($arg,undef); - } elsif ($opt eq "f") { - $arg ||= shift @options; - my $value = $arg !~ s/^no-//; - $arg =~ s/-/_/g; - my $ref = $optimise{$arg}; - if (defined($ref)) { - $$ref = $value; - } else { - warn qq(ignoring unknown optimisation option "$arg"\n); - } - } elsif ($opt eq "O") { - $arg = 1 if $arg eq ""; - my $ref; - foreach $ref (values %optimise) { - $$ref = 0; - } - if ($arg >= 2) { - $freetmps_each_loop = 1; - } - if ($arg >= 1) { - $freetmps_each_bblock = 1 unless $freetmps_each_loop; - } - } elsif ($opt eq "m") { - $arg ||= shift @options; - $module = $arg; - mark_unused($arg,undef); - } elsif ($opt eq "p") { - $arg ||= shift @options; - $patchlevel = $arg; - } elsif ($opt eq "D") { - $arg ||= shift @options; - foreach $arg (split(//, $arg)) { - if ($arg eq "o") { - B->debug(1); - } elsif ($arg eq "O") { - $debug_op = 1; - } elsif ($arg eq "s") { - $debug_stack = 1; - } elsif ($arg eq "c") { - $debug_cxstack = 1; - } elsif ($arg eq "p") { - $debug_pad = 1; - } elsif ($arg eq "r") { - $debug_runtime = 1; - } elsif ($arg eq "S") { - $debug_shadow = 1; - } elsif ($arg eq "q") { - $debug_queue = 1; - } elsif ($arg eq "l") { - $debug_lineno = 1; - } elsif ($arg eq "t") { - $debug_timings = 1; - } - } - } - } - init_sections(); - $init = B::Section->get("init"); - $decl = B::Section->get("decl"); - - if (@options) { - return sub { - my ($objname, $ppname); - foreach $objname (@options) { - $objname = "main::$objname" unless $objname =~ /::/; - ($ppname = $objname) =~ s/^.*?:://; - eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)"; - die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@; - return if $errors; - } - output_boilerplate(); - print "\n"; - output_all($module_name || "init_module"); - output_runtime(); - } - } else { - return sub { cc_main() }; - } -} - -1; - -__END__ - -=head1 NAME - -B::CC - Perl compiler's optimized C translation backend - -=head1 SYNOPSIS - - perl -MO=CC[,OPTIONS] foo.pl - -=head1 DESCRIPTION - -This compiler backend takes Perl source and generates C source code -corresponding to the flow of your program. In other words, this -backend is somewhat a "real" compiler in the sense that many people -think about compilers. Note however that, currently, it is a very -poor compiler in that although it generates (mostly, or at least -sometimes) correct code, it performs relatively few optimisations. -This will change as the compiler develops. The result is that -running an executable compiled with this backend may start up more -quickly than running the original Perl program (a feature shared -by the B<C> compiler backend--see F<B::C>) and may also execute -slightly faster. This is by no means a good optimising compiler--yet. - -=head1 OPTIONS - -If there are any non-option arguments, they are taken to be -names of objects to be saved (probably doesn't work properly yet). -Without extra arguments, it saves the main program. - -=over 4 - -=item B<-ofilename> - -Output to filename instead of STDOUT - -=item B<-v> - -Verbose compilation (currently gives a few compilation statistics). - -=item B<--> - -Force end of options - -=item B<-uPackname> - -Force apparently unused subs from package Packname to be compiled. -This allows programs to use eval "foo()" even when sub foo is never -seen to be used at compile time. The down side is that any subs which -really are never used also have code generated. This option is -necessary, for example, if you have a signal handler foo which you -initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just -to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u> -options. The compiler tries to figure out which packages may possibly -have subs in which need compiling but the current version doesn't do -it very well. In particular, it is confused by nested packages (i.e. -of the form C<A::B>) where package C<A> does not contain any subs. - -=item B<-mModulename> - -Instead of generating source for a runnable executable, generate -source for an XSUB module. The boot_Modulename function (which -DynaLoader can look for) does the appropriate initialisation and runs -the main part of the Perl source that is being compiled. - - -=item B<-D> - -Debug options (concatenated or separate flags like C<perl -D>). - -=item B<-Dr> - -Writes debugging output to STDERR just as it's about to write to the -program's runtime (otherwise writes debugging info as comments in -its C output). - -=item B<-DO> - -Outputs each OP as it's compiled - -=item B<-Ds> - -Outputs the contents of the shadow stack at each OP - -=item B<-Dp> - -Outputs the contents of the shadow pad of lexicals as it's loaded for -each sub or the main program. - -=item B<-Dq> - -Outputs the name of each fake PP function in the queue as it's about -to process it. - -=item B<-Dl> - -Output the filename and line number of each original line of Perl -code as it's processed (C<pp_nextstate>). - -=item B<-Dt> - -Outputs timing information of compilation stages. - -=item B<-f> - -Force optimisations on or off one at a time. - -=item B<-ffreetmps-each-bblock> - -Delays FREETMPS from the end of each statement to the end of the each -basic block. - -=item B<-ffreetmps-each-loop> - -Delays FREETMPS from the end of each statement to the end of the group -of basic blocks forming a loop. At most one of the freetmps-each-* -options can be used. - -=item B<-fomit-taint> - -Omits generating code for handling perl's tainting mechanism. - -=item B<-On> - -Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. -Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2> -sets B<-ffreetmps-each-loop>. - -=back - -=head1 EXAMPLES - - perl -MO=CC,-O2,-ofoo.c foo.pl - perl cc_harness -o foo foo.c - -Note that C<cc_harness> lives in the C<B> subdirectory of your perl -library directory. The utility called C<perlcc> may also be used to -help make use of this compiler. - - perl -MO=CC,-mFoo,-oFoo.c Foo.pm - perl cc_harness -shared -c -o Foo.so Foo.c - -=head1 BUGS - -Plenty. Current status: experimental. - -=head1 DIFFERENCES - -These aren't really bugs but they are constructs which are heavily -tied to perl's compile-and-go implementation and with which this -compiler backend cannot cope. - -=head2 Loops - -Standard perl calculates the target of "next", "last", and "redo" -at run-time. The compiler calculates the targets at compile-time. -For example, the program - - sub skip_on_odd { next NUMBER if $_[0] % 2 } - NUMBER: for ($i = 0; $i < 5; $i++) { - skip_on_odd($i); - print $i; - } - -produces the output - - 024 - -with standard perl but gives a compile-time error with the compiler. - -=head2 Context of ".." - -The context (scalar or array) of the ".." operator determines whether -it behaves as a range or a flip/flop. Standard perl delays until -runtime the decision of which context it is in but the compiler needs -to know the context at compile-time. For example, - - @a = (4,6,1,0,0,1); - sub range { (shift @a)..(shift @a) } - print range(); - while (@a) { print scalar(range()) } - -generates the output - - 456123E0 - -with standard Perl but gives a compile-time error with compiled Perl. - -=head2 Arithmetic - -Compiled Perl programs use native C arithemtic much more frequently -than standard perl. Operations on large numbers or on boundary -cases may produce different behaviour. - -=head2 Deprecated features - -Features of standard perl such as C<$[> which have been deprecated -in standard perl since Perl5 was released have not been implemented -in the compiler. - -=head1 AUTHOR - -Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> - -=cut diff --git a/contrib/perl5/ext/B/B/Concise.pm b/contrib/perl5/ext/B/B/Concise.pm deleted file mode 100644 index cb352eb..0000000 --- a/contrib/perl5/ext/B/B/Concise.pm +++ /dev/null @@ -1,823 +0,0 @@ -package B::Concise; -# Copyright (C) 2000, 2001 Stephen McCamant. All rights reserved. -# This program is free software; you can redistribute and/or modify it -# under the same terms as Perl itself. - -our $VERSION = "0.51"; -use strict; -use B qw(class ppname main_start main_root main_cv cstring svref_2object - SVf_IOK SVf_NOK SVf_POK OPf_KIDS); - -my %style = - ("terse" => - ["(?(#label =>\n)?)(*( )*)#class (#addr) #name (?([#targ])?) " - . "#svclass~(?((#svaddr))?)~#svval~(?(label \"#coplabel\")?)\n", - "(*( )*)goto #class (#addr)\n", - "#class pp_#name"], - "concise" => - ["#hyphseq2 (*( (x( ;)x))*)<#classsym> " - . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x)\n", - " (*( )*) goto #seq\n", - "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"], - "linenoise" => - ["(x(;(*( )*))x)#noise#arg(?([#targarg])?)(x( ;\n)x)", - "gt_#seq ", - "(?(#seq)?)#noise#arg(?([#targarg])?)"], - "debug" => - ["#class (#addr)\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t" - . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n\top_seq\t\t" - . "#seqnum\n\top_flags\t#flagval\n\top_private\t#privval\n" - . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)" - . "(?(\top_sv\t\t#svaddr\n)?)", - " GOTO #addr\n", - "#addr"], - "env" => [$ENV{B_CONCISE_FORMAT}, $ENV{B_CONCISE_GOTO_FORMAT}, - $ENV{B_CONCISE_TREE_FORMAT}], - ); - -my($format, $gotofmt, $treefmt); -my $curcv; -my($seq_base, $cop_seq_base); - -sub concise_cv { - my ($order, $cvref) = @_; - my $cv = svref_2object($cvref); - $curcv = $cv; - if ($order eq "exec") { - walk_exec($cv->START); - } elsif ($order eq "basic") { - walk_topdown($cv->ROOT, sub { $_[0]->concise($_[1]) }, 0); - } else { - print tree($cv->ROOT, 0) - } -} - -my $start_sym = "\e(0"; # "\cN" sometimes also works -my $end_sym = "\e(B"; # "\cO" respectively - -my @tree_decorations = - ([" ", "--", "+-", "|-", "| ", "`-", "-", 1], - [" ", "-", "+", "+", "|", "`", "", 0], - [" ", map("$start_sym$_$end_sym", "qq", "wq", "tq", "x ", "mq", "q"), 1], - [" ", map("$start_sym$_$end_sym", "q", "w", "t", "x", "m"), "", 0], - ); -my $tree_style = 0; - -my $base = 36; -my $big_endian = 1; - -my $order = "basic"; - -sub compile { - my @options = grep(/^-/, @_); - my @args = grep(!/^-/, @_); - my $do_main = 0; - ($format, $gotofmt, $treefmt) = @{$style{"concise"}}; - for my $o (@options) { - if ($o eq "-basic") { - $order = "basic"; - } elsif ($o eq "-exec") { - $order = "exec"; - } elsif ($o eq "-tree") { - $order = "tree"; - } elsif ($o eq "-compact") { - $tree_style |= 1; - } elsif ($o eq "-loose") { - $tree_style &= ~1; - } elsif ($o eq "-vt") { - $tree_style |= 2; - } elsif ($o eq "-ascii") { - $tree_style &= ~2; - } elsif ($o eq "-main") { - $do_main = 1; - } elsif ($o =~ /^-base(\d+)$/) { - $base = $1; - } elsif ($o eq "-bigendian") { - $big_endian = 1; - } elsif ($o eq "-littleendian") { - $big_endian = 0; - } elsif (exists $style{substr($o, 1)}) { - ($format, $gotofmt, $treefmt) = @{$style{substr($o, 1)}}; - } else { - warn "Option $o unrecognized"; - } - } - if (@args) { - return sub { - for my $objname (@args) { - $objname = "main::" . $objname unless $objname =~ /::/; - eval "concise_cv(\$order, \\&$objname)"; - die "concise_cv($order, \\&$objname) failed: $@" if $@; - } - } - } - if (!@args or $do_main) { - if ($order eq "exec") { - return sub { return if class(main_start) eq "NULL"; - $curcv = main_cv; - walk_exec(main_start) } - } elsif ($order eq "tree") { - return sub { return if class(main_root) eq "NULL"; - $curcv = main_cv; - print tree(main_root, 0) } - } elsif ($order eq "basic") { - return sub { return if class(main_root) eq "NULL"; - $curcv = main_cv; - walk_topdown(main_root, - sub { $_[0]->concise($_[1]) }, 0); } - } - } -} - -my %labels; -my $lastnext; - -my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|", - 'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*", - 'PVOP' => '"', 'LOOP' => "{", 'COP' => ";"); - -my @linenoise = - qw'# () sc ( @? 1 $* gv *{ m$ m@ m% m? p/ *$ $ $# & a& pt \\ s\\ rf bl - ` *? <> ?? ?/ r/ c/ // qr s/ /c y/ = @= C sC Cp sp df un BM po +1 +I - -1 -I 1+ I+ 1- I- ** * i* / i/ %$ i% x + i+ - i- . " << >> < i< - > i> <= i, >= i. == i= != i! <? i? s< s> s, s. s= s! s? b& b^ b| -0 -i - ! ~ a2 si cs rd sr e^ lg sq in %x %o ab le ss ve ix ri sf FL od ch cy - uf lf uc lc qm @ [f [ @[ eh vl ky dl ex % ${ @{ uk pk st jn ) )[ a@ - a% sl +] -] [- [+ so rv GS GW MS MW .. f. .f && || ^^ ?: &= |= -> s{ s} - v} ca wa di rs ;; ; ;d }{ { } {} f{ it {l l} rt }l }n }r dm }g }e ^o - ^c ^| ^# um bm t~ u~ ~d DB db ^s se ^g ^r {w }w pf pr ^O ^K ^R ^W ^d ^v - ^e ^t ^k t. fc ic fl .s .p .b .c .l .a .h g1 s1 g2 s2 ?. l? -R -W -X -r - -w -x -e -o -O -z -s -M -A -C -S -c -b -f -d -p -l -u -g -k -t -T -B cd - co cr u. cm ut r. l@ s@ r@ mD uD oD rD tD sD wD cD f$ w$ p$ sh e$ k$ g3 - g4 s4 g5 s5 T@ C@ L@ G@ A@ S@ Hg Hc Hr Hw Mg Mc Ms Mr Sg Sc So rq do {e - e} {t t} g6 G6 6e g7 G7 7e g8 G8 8e g9 G9 9e 6s 7s 8s 9s 6E 7E 8E 9E Pn - Pu GP SP EP Gn Gg GG SG EG g0 c$ lk t$ ;s n>'; - -my $chars = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"; - -sub op_flags { - my($x) = @_; - my(@v); - push @v, "v" if ($x & 3) == 1; - push @v, "s" if ($x & 3) == 2; - push @v, "l" if ($x & 3) == 3; - push @v, "K" if $x & 4; - push @v, "P" if $x & 8; - push @v, "R" if $x & 16; - push @v, "M" if $x & 32; - push @v, "S" if $x & 64; - push @v, "*" if $x & 128; - return join("", @v); -} - -sub base_n { - my $x = shift; - return "-" . base_n(-$x) if $x < 0; - my $str = ""; - do { $str .= substr($chars, $x % $base, 1) } while $x = int($x / $base); - $str = reverse $str if $big_endian; - return $str; -} - -sub seq { return $_[0]->seq ? base_n($_[0]->seq - $seq_base) : "-" } - -sub walk_topdown { - my($op, $sub, $level) = @_; - $sub->($op, $level); - if ($op->flags & OPf_KIDS) { - for (my $kid = $op->first; $$kid; $kid = $kid->sibling) { - walk_topdown($kid, $sub, $level + 1); - } - } - if (class($op) eq "PMOP" and $ {$op->pmreplroot} - and $op->pmreplroot->isa("B::OP")) { - walk_topdown($op->pmreplroot, $sub, $level + 1); - } -} - -sub walklines { - my($ar, $level) = @_; - for my $l (@$ar) { - if (ref($l) eq "ARRAY") { - walklines($l, $level + 1); - } else { - $l->concise($level); - } - } -} - -sub walk_exec { - my($top, $level) = @_; - my %opsseen; - my @lines; - my @todo = ([$top, \@lines]); - while (@todo and my($op, $targ) = @{shift @todo}) { - for (; $$op; $op = $op->next) { - last if $opsseen{$$op}++; - push @$targ, $op; - my $name = $op->name; - if ($name - =~ /^(or|and|(map|grep)while|entertry|range|cond_expr)$/) { - my $ar = []; - push @$targ, $ar; - push @todo, [$op->other, $ar]; - } elsif ($name eq "subst" and $ {$op->pmreplstart}) { - my $ar = []; - push @$targ, $ar; - push @todo, [$op->pmreplstart, $ar]; - } elsif ($name =~ /^enter(loop|iter)$/) { - $labels{$op->nextop->seq} = "NEXT"; - $labels{$op->lastop->seq} = "LAST"; - $labels{$op->redoop->seq} = "REDO"; - } - } - } - walklines(\@lines, 0); -} - -sub fmt_line { - my($hr, $fmt, $level) = @_; - my $text = $fmt; - $text =~ s/\(\?\(([^\#]*?)\#(\w+)([^\#]*?)\)\?\)/ - $hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg; - $text =~ s/\(x\((.*?);(.*?)\)x\)/$order eq "exec" ? $1 : $2/egs; - $text =~ s/\(\*\(([^;]*?)\)\*\)/$1 x $level/egs; - $text =~ s/\(\*\((.*?);(.*?)\)\*\)/$1 x ($level - 1) . $2 x ($level>0)/egs; - $text =~ s/#([a-zA-Z]+)(\d+)/sprintf("%-$2s", $hr->{$1})/eg; - $text =~ s/#([a-zA-Z]+)/$hr->{$1}/eg; - $text =~ s/[ \t]*~+[ \t]*/ /g; - return $text; -} - -my %priv; -$priv{$_}{128} = "LVINTRO" - for ("pos", "substr", "vec", "threadsv", "gvsv", "rv2sv", "rv2hv", "rv2gv", - "rv2av", "rv2arylen", "aelem", "helem", "aslice", "hslice", "padsv", - "padav", "padhv"); -$priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite"); -$priv{"aassign"}{64} = "COMMON"; -$priv{"aassign"}{32} = "PHASH"; -$priv{"sassign"}{64} = "BKWARD"; -$priv{$_}{64} = "RTIME" for ("match", "subst", "substcont"); -@{$priv{"trans"}}{1,2,4,8,16,64} = ("<UTF", ">UTF", "IDENT", "SQUASH", "DEL", - "COMPL", "GROWS"); -$priv{"repeat"}{64} = "DOLIST"; -$priv{"leaveloop"}{64} = "CONT"; -@{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV") - for ("entersub", map("rv2${_}v", "a", "s", "h", "g"), "aelem", "helem"); -$priv{"entersub"}{16} = "DBG"; -$priv{"entersub"}{32} = "TARG"; -@{$priv{$_}}{4,8,128} = ("INARGS","AMPER","NO()") for ("entersub", "rv2cv"); -$priv{"gv"}{32} = "EARLYCV"; -$priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER"; -$priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv"); -$priv{$_}{16} = "TARGMY" - for (map(($_,"s$_"),"chop", "chomp"), - map(($_,"i_$_"), "postinc", "postdec", "multiply", "divide", "modulo", - "add", "subtract", "negate"), "pow", "concat", "stringify", - "left_shift", "right_shift", "bit_and", "bit_xor", "bit_or", - "complement", "atan2", "sin", "cos", "rand", "exp", "log", "sqrt", - "int", "hex", "oct", "abs", "length", "index", "rindex", "sprintf", - "ord", "chr", "crypt", "quotemeta", "join", "push", "unshift", "flock", - "chdir", "chown", "chroot", "unlink", "chmod", "utime", "rename", - "link", "symlink", "mkdir", "rmdir", "wait", "waitpid", "system", - "exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority", - "setpriority", "time", "sleep"); -@{$priv{"const"}}{8,16,32,64,128} = ("STRICT","ENTERED", "$[", "BARE", "WARN"); -$priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM"; -$priv{"list"}{64} = "GUESSED"; -$priv{"delete"}{64} = "SLICE"; -$priv{"exists"}{64} = "SUB"; -$priv{$_}{64} = "LOCALE" - for ("sort", "prtf", "sprintf", "slt", "sle", "seq", "sne", "sgt", "sge", - "scmp", "lc", "uc", "lcfirst", "ucfirst"); -@{$priv{"sort"}}{1,2,4} = ("NUM", "INT", "REV"); -$priv{"threadsv"}{64} = "SVREFd"; -$priv{$_}{16} = "INBIN" for ("open", "backtick"); -$priv{$_}{32} = "INCR" for ("open", "backtick"); -$priv{$_}{64} = "OUTBIN" for ("open", "backtick"); -$priv{$_}{128} = "OUTCR" for ("open", "backtick"); -$priv{"exit"}{128} = "VMS"; - -sub private_flags { - my($name, $x) = @_; - my @s; - for my $flag (128, 96, 64, 32, 16, 8, 4, 2, 1) { - if ($priv{$name}{$flag} and $x & $flag and $x >= $flag) { - $x -= $flag; - push @s, $priv{$name}{$flag}; - } - } - push @s, $x if $x; - return join(",", @s); -} - -sub concise_op { - my ($op, $level, $format) = @_; - my %h; - $h{exname} = $h{name} = $op->name; - $h{NAME} = uc $h{name}; - $h{class} = class($op); - $h{extarg} = $h{targ} = $op->targ; - $h{extarg} = "" unless $h{extarg}; - if ($h{name} eq "null" and $h{targ}) { - $h{exname} = "ex-" . substr(ppname($h{targ}), 3); - $h{extarg} = ""; - } elsif ($h{targ}) { - my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}]; - if (defined $padname and class($padname) ne "SPECIAL") { - $h{targarg} = $padname->PVX; - my $intro = $padname->NVX - $cop_seq_base; - my $finish = int($padname->IVX) - $cop_seq_base; - $finish = "end" if $finish == 999999999 - $cop_seq_base; - $h{targarglife} = "$h{targarg}:$intro,$finish"; - } else { - $h{targarglife} = $h{targarg} = "t" . $h{targ}; - } - } - $h{arg} = ""; - $h{svclass} = $h{svaddr} = $h{svval} = ""; - if ($h{class} eq "PMOP") { - my $precomp = $op->precomp; - $precomp = defined($precomp) ? "/$precomp/" : ""; - my $pmreplroot = $op->pmreplroot; - my ($pmreplroot, $pmreplstart); - if ($ {$pmreplroot = $op->pmreplroot} && $pmreplroot->isa("B::GV")) { - # with C<@stash_array = split(/pat/, str);>, - # *stash_array is stored in pmreplroot. - $h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")"; - } elsif ($ {$op->pmreplstart}) { - undef $lastnext; - $pmreplstart = "replstart->" . seq($op->pmreplstart); - $h{arg} = "(" . join(" ", $precomp, $pmreplstart) . ")"; - } else { - $h{arg} = "($precomp)"; - } - } elsif ($h{class} eq "PVOP" and $h{name} ne "trans") { - $h{arg} = '("' . $op->pv . '")'; - $h{svval} = '"' . $op->pv . '"'; - } elsif ($h{class} eq "COP") { - my $label = $op->label; - $h{coplabel} = $label; - $label = $label ? "$label: " : ""; - my $loc = $op->file; - $loc =~ s[.*/][]; - $loc .= ":" . $op->line; - my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base); - my $arybase = $op->arybase; - $arybase = $arybase ? ' $[=' . $arybase : ""; - $h{arg} = "($label$stash $cseq $loc$arybase)"; - } elsif ($h{class} eq "LOOP") { - $h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop) - . " redo->" . seq($op->redoop) . ")"; - } elsif ($h{class} eq "LOGOP") { - undef $lastnext; - $h{arg} = "(other->" . seq($op->other) . ")"; - } elsif ($h{class} eq "SVOP") { - my $sv = $op->sv; - $h{svclass} = class($sv); - $h{svaddr} = sprintf("%#x", $$sv); - if ($h{svclass} eq "GV") { - my $gv = $sv; - my $stash = $gv->STASH->NAME; - if ($stash eq "main") { - $stash = ""; - } else { - $stash = $stash . "::"; - } - $h{arg} = "(*$stash" . $gv->SAFENAME . ")"; - $h{svval} = "*$stash" . $gv->SAFENAME; - } else { - while (class($sv) eq "RV") { - $h{svval} .= "\\"; - $sv = $sv->RV; - } - if (class($sv) eq "SPECIAL") { - $h{svval} = ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv]; - } elsif ($sv->FLAGS & SVf_NOK) { - $h{svval} = $sv->NV; - } elsif ($sv->FLAGS & SVf_IOK) { - $h{svval} = $sv->IV; - } elsif ($sv->FLAGS & SVf_POK) { - $h{svval} = cstring($sv->PV); - } - $h{arg} = "($h{svclass} $h{svval})"; - } - } - $h{seq} = $h{hyphseq} = seq($op); - $h{seq} = "" if $h{seq} eq "-"; - $h{seqnum} = $op->seq; - $h{next} = $op->next; - $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next}); - $h{nextaddr} = sprintf("%#x", $ {$op->next}); - $h{sibaddr} = sprintf("%#x", $ {$op->sibling}); - $h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first"); - $h{lastaddr} = sprintf("%#x", $ {$op->last}) if $op->can("last"); - - $h{classsym} = $opclass{$h{class}}; - $h{flagval} = $op->flags; - $h{flags} = op_flags($op->flags); - $h{privval} = $op->private; - $h{private} = private_flags($h{name}, $op->private); - $h{addr} = sprintf("%#x", $$op); - $h{label} = $labels{$op->seq}; - $h{typenum} = $op->type; - $h{noise} = $linenoise[$op->type]; - return fmt_line(\%h, $format, $level); -} - -sub B::OP::concise { - my($op, $level) = @_; - if ($order eq "exec" and $lastnext and $$lastnext != $$op) { - my $h = {"seq" => seq($lastnext), "class" => class($lastnext), - "addr" => sprintf("%#x", $$lastnext)}; - print fmt_line($h, $gotofmt, $level+1); - } - $lastnext = $op->next; - print concise_op($op, $level, $format); -} - -sub tree { - my $op = shift; - my $level = shift; - my $style = $tree_decorations[$tree_style]; - my($space, $single, $kids, $kid, $nokid, $last, $lead, $size) = @$style; - my $name = concise_op($op, $level, $treefmt); - if (not $op->flags & OPf_KIDS) { - return $name . "\n"; - } - my @lines; - for (my $kid = $op->first; $$kid; $kid = $kid->sibling) { - push @lines, tree($kid, $level+1); - } - my $i; - for ($i = $#lines; substr($lines[$i], 0, 1) eq " "; $i--) { - $lines[$i] = $space . $lines[$i]; - } - if ($i > 0) { - $lines[$i] = $last . $lines[$i]; - while ($i-- > 1) { - if (substr($lines[$i], 0, 1) eq " ") { - $lines[$i] = $nokid . $lines[$i]; - } else { - $lines[$i] = $kid . $lines[$i]; - } - } - $lines[$i] = $kids . $lines[$i]; - } else { - $lines[0] = $single . $lines[0]; - } - return("$name$lead" . shift @lines, - map(" " x (length($name)+$size) . $_, @lines)); -} - -# This is a bit of a hack; the 2 and 15 were determined empirically. -# These need to stay the last things in the module. -$cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + 2; -$seq_base = svref_2object(eval 'sub{}')->START->seq + 15; - -1; - -__END__ - -=head1 NAME - -B::Concise - Walk Perl syntax tree, printing concise info about ops - -=head1 SYNOPSIS - - perl -MO=Concise[,OPTIONS] foo.pl - -=head1 DESCRIPTION - -This compiler backend prints the internal OPs of a Perl program's syntax -tree in one of several space-efficient text formats suitable for debugging -the inner workings of perl or other compiler backends. It can print OPs in -the order they appear in the OP tree, in the order they will execute, or -in a text approximation to their tree structure, and the format of the -information displyed is customizable. Its function is similar to that of -perl's B<-Dx> debugging flag or the B<B::Terse> module, but it is more -sophisticated and flexible. - -=head1 OPTIONS - -Arguments that don't start with a hyphen are taken to be the names of -subroutines to print the OPs of; if no such functions are specified, the -main body of the program (outside any subroutines, and not including use'd -or require'd files) is printed. - -=over 4 - -=item B<-basic> - -Print OPs in the order they appear in the OP tree (a preorder -traversal, starting at the root). The indentation of each OP shows its -level in the tree. This mode is the default, so the flag is included -simply for completeness. - -=item B<-exec> - -Print OPs in the order they would normally execute (for the majority -of constructs this is a postorder traversal of the tree, ending at the -root). In most cases the OP that usually follows a given OP will -appear directly below it; alternate paths are shown by indentation. In -cases like loops when control jumps out of a linear path, a 'goto' -line is generated. - -=item B<-tree> - -Print OPs in a text approximation of a tree, with the root of the tree -at the left and 'left-to-right' order of children transformed into -'top-to-bottom'. Because this mode grows both to the right and down, -it isn't suitable for large programs (unless you have a very wide -terminal). - -=item B<-compact> - -Use a tree format in which the minimum amount of space is used for the -lines connecting nodes (one character in most cases). This squeezes out -a few precious columns of screen real estate. - -=item B<-loose> - -Use a tree format that uses longer edges to separate OP nodes. This format -tends to look better than the compact one, especially in ASCII, and is -the default. - -=item B<-vt> - -Use tree connecting characters drawn from the VT100 line-drawing set. -This looks better if your terminal supports it. - -=item B<-ascii> - -Draw the tree with standard ASCII characters like C<+> and C<|>. These don't -look as clean as the VT100 characters, but they'll work with almost any -terminal (or the horizontal scrolling mode of less(1)) and are suitable -for text documentation or email. This is the default. - -=item B<-main> - -Include the main program in the output, even if subroutines were also -specified. - -=item B<-base>I<n> - -Print OP sequence numbers in base I<n>. If I<n> is greater than 10, the -digit for 11 will be 'a', and so on. If I<n> is greater than 36, the digit -for 37 will be 'A', and so on until 62. Values greater than 62 are not -currently supported. The default is 36. - -=item B<-bigendian> - -Print sequence numbers with the most significant digit first. This is the -usual convention for Arabic numerals, and the default. - -=item B<-littleendian> - -Print seqence numbers with the least significant digit first. - -=item B<-concise> - -Use the author's favorite set of formatting conventions. This is the -default, of course. - -=item B<-terse> - -Use formatting conventions that emulate the ouput of B<B::Terse>. The -basic mode is almost indistinguishable from the real B<B::Terse>, and the -exec mode looks very similar, but is in a more logical order and lacks -curly brackets. B<B::Terse> doesn't have a tree mode, so the tree mode -is only vaguely reminiscient of B<B::Terse>. - -=item B<-linenoise> - -Use formatting conventions in which the name of each OP, rather than being -written out in full, is represented by a one- or two-character abbreviation. -This is mainly a joke. - -=item B<-debug> - -Use formatting conventions reminiscient of B<B::Debug>; these aren't -very concise at all. - -=item B<-env> - -Use formatting conventions read from the environment variables -C<B_CONCISE_FORMAT>, C<B_CONCISE_GOTO_FORMAT>, and C<B_CONCISE_TREE_FORMAT>. - -=back - -=head1 FORMATTING SPECIFICATIONS - -For each general style ('concise', 'terse', 'linenoise', etc.) there are -three specifications: one of how OPs should appear in the basic or exec -modes, one of how 'goto' lines should appear (these occur in the exec -mode only), and one of how nodes should appear in tree mode. Each has the -same format, described below. Any text that doesn't match a special -pattern is copied verbatim. - -=over 4 - -=item B<(x(>I<exec_text>B<;>I<basic_text>B<)x)> - -Generates I<exec_text> in exec mode, or I<basic_text> in basic mode. - -=item B<(*(>I<text>B<)*)> - -Generates one copy of I<text> for each indentation level. - -=item B<(*(>I<text1>B<;>I<text2>B<)*)> - -Generates one fewer copies of I<text1> than the indentation level, followed -by one copy of I<text2> if the indentation level is more than 0. - -=item B<(?(>I<text1>B<#>I<var>I<Text2>B<)?)> - -If the value of I<var> is true (not empty or zero), generates the -value of I<var> surrounded by I<text1> and I<Text2>, otherwise -nothing. - -=item B<#>I<var> - -Generates the value of the variable I<var>. - -=item B<#>I<var>I<N> - -Generates the value of I<var>, left jutified to fill I<N> spaces. - -=item B<~> - -Any number of tildes and surrounding whitespace will be collapsed to -a single space. - -=back - -The following variables are recognized: - -=over 4 - -=item B<#addr> - -The address of the OP, in hexidecimal. - -=item B<#arg> - -The OP-specific information of the OP (such as the SV for an SVOP, the -non-local exit pointers for a LOOP, etc.) enclosed in paretheses. - -=item B<#class> - -The B-determined class of the OP, in all caps. - -=item B<#classym> - -A single symbol abbreviating the class of the OP. - -=item B<#coplabel> - -The label of the statement or block the OP is the start of, if any. - -=item B<#exname> - -The name of the OP, or 'ex-foo' if the OP is a null that used to be a foo. - -=item B<#extarg> - -The target of the OP, or nothing for a nulled OP. - -=item B<#firstaddr> - -The address of the OP's first child, in hexidecimal. - -=item B<#flags> - -The OP's flags, abbreviated as a series of symbols. - -=item B<#flagval> - -The numeric value of the OP's flags. - -=item B<#hyphenseq> - -The sequence number of the OP, or a hyphen if it doesn't have one. - -=item B<#label> - -'NEXT', 'LAST', or 'REDO' if the OP is a target of one of those in exec -mode, or empty otherwise. - -=item B<#lastaddr> - -The address of the OP's last child, in hexidecimal. - -=item B<#name> - -The OP's name. - -=item B<#NAME> - -The OP's name, in all caps. - -=item B<#next> - -The sequence number of the OP's next OP. - -=item B<#nextaddr> - -The address of the OP's next OP, in hexidecimal. - -=item B<#noise> - -The two-character abbreviation for the OP's name. - -=item B<#private> - -The OP's private flags, rendered with abbreviated names if possible. - -=item B<#privval> - -The numeric value of the OP's private flags. - -=item B<#seq> - -The sequence number of the OP. - -=item B<#seqnum> - -The real sequence number of the OP, as a regular number and not adjusted -to be relative to the start of the real program. (This will generally be -a fairly large number because all of B<B::Concise> is compiled before -your program is). - -=item B<#sibaddr> - -The address of the OP's next youngest sibling, in hexidecimal. - -=item B<#svaddr> - -The address of the OP's SV, if it has an SV, in hexidecimal. - -=item B<#svclass> - -The class of the OP's SV, if it has one, in all caps (e.g., 'IV'). - -=item B<#svval> - -The value of the OP's SV, if it has one, in a short human-readable format. - -=item B<#targ> - -The numeric value of the OP's targ. - -=item B<#targarg> - -The name of the variable the OP's targ refers to, if any, otherwise the -letter t followed by the OP's targ in decimal. - -=item B<#targarglife> - -Same as B<#targarg>, but followed by the COP sequence numbers that delimit -the variable's lifetime (or 'end' for a variable in an open scope) for a -variable. - -=item B<#typenum> - -The numeric value of the OP's type, in decimal. - -=back - -=head1 ABBREVIATIONS - -=head2 OP flags abbreviations - - v OPf_WANT_VOID Want nothing (void context) - s OPf_WANT_SCALAR Want single value (scalar context) - l OPf_WANT_LIST Want list of any length (list context) - K OPf_KIDS There is a firstborn child. - P OPf_PARENS This operator was parenthesized. - (Or block needs explicit scope entry.) - R OPf_REF Certified reference. - (Return container, not containee). - M OPf_MOD Will modify (lvalue). - S OPf_STACKED Some arg is arriving on the stack. - * OPf_SPECIAL Do something weird for this op (see op.h) - -=head2 OP class abbreviations - - 0 OP (aka BASEOP) An OP with no children - 1 UNOP An OP with one child - 2 BINOP An OP with two children - | LOGOP A control branch OP - @ LISTOP An OP that could have lots of children - / PMOP An OP with a regular expression - $ SVOP An OP with an SV - " PVOP An OP with a string - { LOOP An OP that holds pointers for a loop - ; COP An OP that marks the start of a statement - -=head1 AUTHOR - -Stephen McCamant, C<smcc@CSUA.Berkeley.EDU> - -=cut diff --git a/contrib/perl5/ext/B/B/Debug.pm b/contrib/perl5/ext/B/B/Debug.pm deleted file mode 100644 index 049195b..0000000 --- a/contrib/perl5/ext/B/B/Debug.pm +++ /dev/null @@ -1,283 +0,0 @@ -package B::Debug; -use strict; -use B qw(peekop class walkoptree walkoptree_exec - main_start main_root cstring sv_undef); -use B::Asmdata qw(@specialsv_name); - -my %done_gv; - -sub B::OP::debug { - my ($op) = @_; - printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type, $op->seq, $op->flags, $op->private; -%s (0x%lx) - op_next 0x%x - op_sibling 0x%x - op_ppaddr %s - op_targ %d - op_type %d - op_seq %d - op_flags %d - op_private %d -EOT -} - -sub B::UNOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_first\t0x%x\n", ${$op->first}; -} - -sub B::BINOP::debug { - my ($op) = @_; - $op->B::UNOP::debug(); - printf "\top_last\t\t0x%x\n", ${$op->last}; -} - -sub B::LOOP::debug { - my ($op) = @_; - $op->B::BINOP::debug(); - printf <<'EOT', ${$op->redoop}, ${$op->nextop}, ${$op->lastop}; - op_redoop 0x%x - op_nextop 0x%x - op_lastop 0x%x -EOT -} - -sub B::LOGOP::debug { - my ($op) = @_; - $op->B::UNOP::debug(); - printf "\top_other\t0x%x\n", ${$op->other}; -} - -sub B::LISTOP::debug { - my ($op) = @_; - $op->B::BINOP::debug(); - printf "\top_children\t%d\n", $op->children; -} - -sub B::PMOP::debug { - my ($op) = @_; - $op->B::LISTOP::debug(); - printf "\top_pmreplroot\t0x%x\n", ${$op->pmreplroot}; - printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart}; - printf "\top_pmnext\t0x%x\n", ${$op->pmnext}; - printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp); - printf "\top_pmflags\t0x%x\n", $op->pmflags; - $op->pmreplroot->debug; -} - -sub B::COP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->seq, $op->arybase, $op->line, ${$op->warnings}; - cop_label %s - cop_stashpv %s - cop_file %s - cop_seq %d - cop_arybase %d - cop_line %d - cop_warnings 0x%x -EOT -} - -sub B::SVOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_sv\t\t0x%x\n", ${$op->sv}; - $op->sv->debug; -} - -sub B::PVOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_pv\t\t0x%x\n", $op->pv; -} - -sub B::PADOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_padix\t\t%ld\n", $op->padix; -} - -sub B::CVOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_cv\t\t0x%x\n", ${$op->cv}; -} - -sub B::NULL::debug { - my ($sv) = @_; - if ($$sv == ${sv_undef()}) { - print "&sv_undef\n"; - } else { - printf "NULL (0x%x)\n", $$sv; - } -} - -sub B::SV::debug { - my ($sv) = @_; - if (!$$sv) { - print class($sv), " = NULL\n"; - return; - } - printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS; -%s (0x%x) - REFCNT %d - FLAGS 0x%x -EOT -} - -sub B::PV::debug { - my ($sv) = @_; - $sv->B::SV::debug(); - my $pv = $sv->PV(); - printf <<'EOT', cstring($pv), length($pv); - xpv_pv %s - xpv_cur %d -EOT -} - -sub B::IV::debug { - my ($sv) = @_; - $sv->B::SV::debug(); - printf "\txiv_iv\t\t%d\n", $sv->IV; -} - -sub B::NV::debug { - my ($sv) = @_; - $sv->B::IV::debug(); - printf "\txnv_nv\t\t%s\n", $sv->NV; -} - -sub B::PVIV::debug { - my ($sv) = @_; - $sv->B::PV::debug(); - printf "\txiv_iv\t\t%d\n", $sv->IV; -} - -sub B::PVNV::debug { - my ($sv) = @_; - $sv->B::PVIV::debug(); - printf "\txnv_nv\t\t%s\n", $sv->NV; -} - -sub B::PVLV::debug { - my ($sv) = @_; - $sv->B::PVNV::debug(); - printf "\txlv_targoff\t%d\n", $sv->TARGOFF; - printf "\txlv_targlen\t%u\n", $sv->TARGLEN; - printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE)); -} - -sub B::BM::debug { - my ($sv) = @_; - $sv->B::PVNV::debug(); - printf "\txbm_useful\t%d\n", $sv->USEFUL; - printf "\txbm_previous\t%u\n", $sv->PREVIOUS; - printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE)); -} - -sub B::CV::debug { - my ($sv) = @_; - $sv->B::PVNV::debug(); - my ($stash) = $sv->STASH; - my ($start) = $sv->START; - my ($root) = $sv->ROOT; - my ($padlist) = $sv->PADLIST; - my ($file) = $sv->FILE; - my ($gv) = $sv->GV; - printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}; - STASH 0x%x - START 0x%x - ROOT 0x%x - GV 0x%x - FILE %s - DEPTH %d - PADLIST 0x%x - OUTSIDE 0x%x -EOT - $start->debug if $start; - $root->debug if $root; - $gv->debug if $gv; - $padlist->debug if $padlist; -} - -sub B::AV::debug { - my ($av) = @_; - $av->B::SV::debug; - my(@array) = $av->ARRAY; - print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n"; - printf <<'EOT', scalar(@array), $av->MAX, $av->OFF, $av->AvFLAGS; - FILL %d - MAX %d - OFF %d - AvFLAGS %d -EOT -} - -sub B::GV::debug { - my ($gv) = @_; - if ($done_gv{$$gv}++) { - printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME; - return; - } - my ($sv) = $gv->SV; - my ($av) = $gv->AV; - my ($cv) = $gv->CV; - $gv->B::SV::debug; - printf <<'EOT', $gv->SAFENAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS; - NAME %s - STASH %s (0x%x) - SV 0x%x - GvREFCNT %d - FORM 0x%x - AV 0x%x - HV 0x%x - EGV 0x%x - CV 0x%x - CVGEN %d - LINE %d - FILE %s - GvFLAGS 0x%x -EOT - $sv->debug if $sv; - $av->debug if $av; - $cv->debug if $cv; -} - -sub B::SPECIAL::debug { - my $sv = shift; - print $specialsv_name[$$sv], "\n"; -} - -sub compile { - my $order = shift; - B::clearsym(); - if ($order && $order eq "exec") { - return sub { walkoptree_exec(main_start, "debug") } - } else { - return sub { walkoptree(main_root, "debug") } - } -} - -1; - -__END__ - -=head1 NAME - -B::Debug - Walk Perl syntax tree, printing debug info about ops - -=head1 SYNOPSIS - - perl -MO=Debug[,OPTIONS] foo.pl - -=head1 DESCRIPTION - -See F<ext/B/README>. - -=head1 AUTHOR - -Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> - -=cut diff --git a/contrib/perl5/ext/B/B/Deparse.pm b/contrib/perl5/ext/B/B/Deparse.pm deleted file mode 100644 index ead02e1..0000000 --- a/contrib/perl5/ext/B/B/Deparse.pm +++ /dev/null @@ -1,3128 +0,0 @@ -# B::Deparse.pm -# 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. - -# This is based on the module of the same name by Malcolm Beattie, -# but essentially none of his code remains. - -package B::Deparse; -use Carp 'cluck', 'croak'; -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 - OPpLVAL_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE - OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY - SVf_IOK SVf_NOK SVf_ROK SVf_POK - CVf_METHOD CVf_LOCKED CVf_LVALUE - PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE - PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED); -$VERSION = 0.60; -use strict; - -# Changes between 0.50 and 0.51: -# - fixed nulled leave with live enter in sort { } -# - fixed reference constants (\"str") -# - handle empty programs gracefully -# - handle infinte loops (for (;;) {}, while (1) {}) -# - differentiate between `for my $x ...' and `my $x; for $x ...' -# - various minor cleanups -# - moved globals into an object -# - added `-u', like B::C -# - package declarations using cop_stash -# - subs, formats and code sorted by cop_seq -# Changes between 0.51 and 0.52: -# - added pp_threadsv (special variables under USE_THREADS) -# - added documentation -# Changes between 0.52 and 0.53: -# - many changes adding precedence contexts and associativity -# - added `-p' and `-s' output style options -# - various other minor fixes -# Changes between 0.53 and 0.54: -# - added support for new `for (1..100)' optimization, -# thanks to Gisle Aas -# Changes between 0.54 and 0.55: -# - added support for new qr// construct -# - added support for new pp_regcreset OP -# Changes between 0.55 and 0.56: -# - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t -# - fixed $# on non-lexicals broken in last big rewrite -# - added temporary fix for change in opcode of OP_STRINGIFY -# - fixed problem in 0.54's for() patch in `for (@ary)' -# - fixed precedence in conditional of ?: -# - tweaked list paren elimination in `my($x) = @_' -# - made continue-block detection trickier wrt. null ops -# - fixed various prototype problems in pp_entersub -# - added support for sub prototypes that never get GVs -# - added unquoting for special filehandle first arg in truncate -# - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV' -# - added semicolons at the ends of blocks -# - added -l `#line' declaration option -- fixes cmd/subval.t 27,28 -# Changes between 0.56 and 0.561: -# - fixed multiply-declared my var in pp_truncate (thanks to Sarathy) -# - used new B.pm symbolic constants (done by Nick Ing-Simmons) -# Changes between 0.561 and 0.57: -# - stylistic changes to symbolic constant stuff -# - handled scope in s///e replacement code -# - added unquote option for expanding "" into concats, etc. -# - split method and proto parts of pp_entersub into separate functions -# - various minor cleanups -# Changes after 0.57: -# - added parens in \&foo (patch by Albert Dvornik) -# Changes between 0.57 and 0.58: -# - fixed `0' statements that weren't being printed -# - added methods for use from other programs -# (based on patches from James Duncan and Hugo van der Sanden) -# - added -si and -sT to control indenting (also based on a patch from Hugo) -# - added -sv to print something else instead of '???' -# - preliminary version of utf8 tr/// handling -# Changes after 0.58: -# - uses of $op->ppaddr changed to new $op->name (done by Sarathy) -# - added support for Hugo's new OP_SETSTATE (like nextstate) -# Changes between 0.58 and 0.59 -# - added support for Chip's OP_METHOD_NAMED -# - added support for Ilya's OPpTARGET_MY optimization -# - elided arrows before `()' subscripts when possible -# Changes between 0.59 and 0.60 -# - support for method attribues was added -# - some warnings fixed -# - separate recognition of constant subs -# - rewrote continue block handling, now recoginizing for loops -# - added more control of expanding control structures - -# Todo: -# - finish tr/// changes -# - add option for even more parens (generalize \&foo change) -# - {} around variables in strings ("${var}letters") -# base/lex.t 25-27 -# comp/term.t 11 -# - left/right context -# - recognize `use utf8', `use integer', etc -# - treat top-level block specially for incremental output -# - interpret high bit chars in string as utf8 \x{...} (when?) -# - copy comments (look at real text with $^P?) -# - avoid semis in one-statement blocks -# - associativity of &&=, ||=, ?: -# - ',' => '=>' (auto-unquote?) -# - break long lines ("\r" as discretionary break?) -# - configurable syntax highlighting: ANSI color, HTML, TeX, etc. -# - more style options: brace style, hex vs. octal, quotes, ... -# - print big ints as hex/octal instead of decimal (heuristic?) -# - handle `my $x if 0'? -# - include values of variables (e.g. set in BEGIN) -# - coordinate with Data::Dumper (both directions? see previous) -# - version using op_next instead of op_first/sibling? -# - avoid string copies (pass arrays, one big join?) -# - auto-apply `-u'? -# - -uPackage:: descend recursively? -# - here-docs? -# - <DATA>? - -# Tests that will always fail: -# comp/redef.t -- all (redefinition happens at compile time) - -# Object fields (were globals): -# -# avoid_local: -# (local($a), local($b)) and local($a, $b) have the same internal -# representation but the short form looks better. We notice we can -# use a large-scale local when checking the list, but need to prevent -# individual locals too. This hash holds the addresses of OPs that -# have already had their local-ness accounted for. The same thing -# is done with my(). -# -# curcv: -# CV for current sub (or main program) being deparsed -# -# curstash: -# name of the current package for deparsed code -# -# subs_todo: -# array of [cop_seq, GV, is_format?] for subs and formats we still -# want to deparse -# -# protos_todo: -# as above, but [name, prototype] for subs that never got a GV -# -# subs_done, forms_done: -# keys are addresses of GVs for subs and formats we've already -# deparsed (or at least put into subs_todo) -# -# parens: -p -# linenums: -l -# unquote: -q -# cuddle: ` ' or `\n', depending on -sC -# indent_size: -si -# use_tabs: -sT -# ex_const: -sv - -# A little explanation of how precedence contexts and associativity -# work: -# -# deparse() calls each per-op subroutine with an argument $cx (short -# for context, but not the same as the cx* in the perl core), which is -# a number describing the op's parents in terms of precedence, whether -# they're inside an expression or at statement level, etc. (see -# chart below). When ops with children call deparse on them, they pass -# along their precedence. Fractional values are used to implement -# associativity (`($x + $y) + $z' => `$x + $y + $y') and related -# parentheses hacks. The major disadvantage of this scheme is that -# it doesn't know about right sides and left sides, so say if you -# assign a listop to a variable, it can't tell it's allowed to leave -# the parens off the listop. - -# Precedences: -# 26 [TODO] inside interpolation context ("") -# 25 left terms and list operators (leftward) -# 24 left -> -# 23 nonassoc ++ -- -# 22 right ** -# 21 right ! ~ \ and unary + and - -# 20 left =~ !~ -# 19 left * / % x -# 18 left + - . -# 17 left << >> -# 16 nonassoc named unary operators -# 15 nonassoc < > <= >= lt gt le ge -# 14 nonassoc == != <=> eq ne cmp -# 13 left & -# 12 left | ^ -# 11 left && -# 10 left || -# 9 nonassoc .. ... -# 8 right ?: -# 7 right = += -= *= etc. -# 6 left , => -# 5 nonassoc list operators (rightward) -# 4 right not -# 3 left and -# 2 left or xor -# 1 statement modifiers -# 0 statement level - -# Nonprinting characters with special meaning: -# \cS - steal parens (see maybe_parens_unop) -# \n - newline and indent -# \t - increase indent -# \b - decrease indent (`outdent') -# \f - flush left (no indent) -# \cK - kill following semicolon, if any - -sub null { - my $op = shift; - return class($op) eq "NULL"; -} - -sub todo { - my $self = shift; - my($gv, $cv, $is_form) = @_; - my $seq; - if (!null($cv->START) and is_state($cv->START)) { - $seq = $cv->START->cop_seq; - } else { - $seq = 0; - } - push @{$self->{'subs_todo'}}, [$seq, $gv, $is_form]; -} - -sub next_todo { - my $self = shift; - my $ent = shift @{$self->{'subs_todo'}}; - my $name = $self->gv_name($ent->[1]); - if ($ent->[2]) { - return "format $name =\n" - . $self->deparse_format($ent->[1]->FORM). "\n"; - } else { - return "sub $name " . $self->deparse_sub($ent->[1]->CV); - } -} - -sub walk_tree { - my($op, $sub) = @_; - $sub->($op); - if ($op->flags & OPf_KIDS) { - my $kid; - for ($kid = $op->first; not null $kid; $kid = $kid->sibling) { - walk_tree($kid, $sub); - } - } -} - -sub walk_sub { - my $self = shift; - my $cv = shift; - my $op = $cv->ROOT; - $op = shift if null $op; - return if !$op or null $op; - walk_tree($op, sub { - my $op = shift; - if ($op->name eq "gv") { - my $gv = $self->gv_or_padgv($op); - if ($op->next->name eq "entersub") { - 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")) { - return if $self->{'forms_done'}{$$gv}++; - return if class($gv->FORM) eq "SPECIAL"; - $self->todo($gv, $gv->FORM, 1); - $self->walk_sub($gv->FORM); - } - } - }); -} - -sub stash_subs { - my $self = shift; - my $pack = shift; - my(%stash, @ret); - { no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY } - if ($pack eq "main") { - $pack = ""; - } else { - $pack = $pack . "::"; - } - my($key, $val); - while (($key, $val) = each %stash) { - my $class = class($val); - if ($class eq "PV") { - # Just a prototype - push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV]; - } elsif ($class eq "IV") { - # Just a name - push @{$self->{'protos_todo'}}, [$pack . $key, undef]; - } elsif ($class eq "GV") { - if (class($val->CV) ne "SPECIAL") { - next if $self->{'subs_done'}{$$val}++; - $self->todo($val, $val->CV, 0); - $self->walk_sub($val->CV); - } - if (class($val->FORM) ne "SPECIAL") { - next if $self->{'forms_done'}{$$val}++; - $self->todo($val, $val->FORM, 1); - $self->walk_sub($val->FORM); - } - } - } -} - -sub print_protos { - my $self = shift; - my $ar; - my @ret; - foreach $ar (@{$self->{'protos_todo'}}) { - my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : ""); - push @ret, "sub " . $ar->[0] . "$proto;\n"; - } - delete $self->{'protos_todo'}; - return @ret; -} - -sub style_opts { - my $self = shift; - my $opts = shift; - my $opt; - while (length($opt = substr($opts, 0, 1))) { - if ($opt eq "C") { - $self->{'cuddle'} = " "; - $opts = substr($opts, 1); - } elsif ($opt eq "i") { - $opts =~ s/^i(\d+)//; - $self->{'indent_size'} = $1; - } elsif ($opt eq "T") { - $self->{'use_tabs'} = 1; - $opts = substr($opts, 1); - } elsif ($opt eq "v") { - $opts =~ s/^v([^.]*)(.|$)//; - $self->{'ex_const'} = $1; - } - } -} - -sub new { - my $class = shift; - my $self = bless {}, $class; - $self->{'subs_todo'} = []; - $self->{'curstash'} = "main"; - $self->{'cuddle'} = "\n"; - $self->{'indent_size'} = 4; - $self->{'use_tabs'} = 0; - $self->{'expand'} = 0; - $self->{'unquote'} = 0; - $self->{'linenums'} = 0; - $self->{'parens'} = 0; - $self->{'ex_const'} = "'???'"; - while (my $arg = shift @_) { - if (substr($arg, 0, 2) eq "-u") { - $self->stash_subs(substr($arg, 2)); - } elsif ($arg eq "-p") { - $self->{'parens'} = 1; - } elsif ($arg eq "-l") { - $self->{'linenums'} = 1; - } elsif ($arg eq "-q") { - $self->{'unquote'} = 1; - } elsif (substr($arg, 0, 2) eq "-s") { - $self->style_opts(substr $arg, 2); - } elsif ($arg =~ /^-x(\d)$/) { - $self->{'expand'} = $1; - } - } - return $self; -} - -sub compile { - my(@args) = @_; - return sub { - my $self = B::Deparse->new(@args); - $self->stash_subs("main"); - $self->{'curcv'} = main_cv; - $self->walk_sub(main_cv, main_start); - print $self->print_protos; - @{$self->{'subs_todo'}} = - sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}; - print $self->indent($self->deparse(main_root, 0)), "\n" - unless null main_root; - my @text; - while (scalar(@{$self->{'subs_todo'}})) { - push @text, $self->next_todo; - } - print $self->indent(join("", @text)), "\n" if @text; - } -} - -sub coderef2text { - my $self = shift; - my $sub = shift; - croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE"; - return $self->indent($self->deparse_sub(svref_2object($sub))); -} - -sub deparse { - my $self = shift; - my($op, $cx) = @_; -# cluck if class($op) eq "NULL"; -# cluck unless $op; -# return $self->$ {\("pp_" . $op->name)}($op, $cx); - my $meth = "pp_" . $op->name; - return $self->$meth($op, $cx); -} - -sub indent { - my $self = shift; - my $txt = shift; - my @lines = split(/\n/, $txt); - my $leader = ""; - my $level = 0; - my $line; - for $line (@lines) { - my $cmd = substr($line, 0, 1); - if ($cmd eq "\t" or $cmd eq "\b") { - $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'}; - if ($self->{'use_tabs'}) { - $leader = "\t" x ($level / 8) . " " x ($level % 8); - } else { - $leader = " " x $level; - } - $line = substr($line, 1); - } - if (substr($line, 0, 1) eq "\f") { - $line = substr($line, 1); # no indent - } else { - $line = $leader . $line; - } - $line =~ s/\cK;?//g; - } - return join("\n", @lines); -} - -sub deparse_sub { - my $self = shift; - my $cv = shift; - my $proto = ""; - if ($cv->FLAGS & SVf_POK) { - $proto = "(". $cv->PV . ") "; - } - if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) { - $proto .= ": "; - $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE; - $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED; - $proto .= "method " if $cv->CvFLAGS & CVf_METHOD; - } - - local($self->{'curcv'}) = $cv; - local($self->{'curstash'}) = $self->{'curstash'}; - if (not null $cv->ROOT) { - # skip leavesub - return $proto . "{\n\t" . - $self->deparse($cv->ROOT->first, 0) . "\n\b}\n"; - } else { # XSUB? - return $proto . "{}\n"; - } -} - -sub deparse_format { - my $self = shift; - my $form = shift; - my @text; - local($self->{'curcv'}) = $form; - local($self->{'curstash'}) = $self->{'curstash'}; - my $op = $form->ROOT; - my $kid; - $op = $op->first->first; # skip leavewrite, lineseq - while (not null $op) { - $op = $op->sibling; # skip nextstate - my @exprs; - $kid = $op->first->sibling; # skip pushmark - push @text, $self->const_sv($kid)->PV; - $kid = $kid->sibling; - for (; not null $kid; $kid = $kid->sibling) { - push @exprs, $self->deparse($kid, 0); - } - push @text, join(", ", @exprs)."\n" if @exprs; - $op = $op->sibling; - } - return join("", @text) . "."; -} - -sub is_scope { - my $op = shift; - return $op->name eq "leave" || $op->name eq "scope" - || $op->name eq "lineseq" - || ($op->name eq "null" && class($op) eq "UNOP" - && (is_scope($op->first) || $op->first->name eq "enter")); -} - -sub is_state { - my $name = $_[0]->name; - return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate"; -} - -sub is_miniwhile { # check for one-line loop (`foo() while $y--') - my $op = shift; - return (!null($op) and null($op->sibling) - and $op->name eq "null" and class($op) eq "UNOP" - and (($op->first->name =~ /^(and|or)$/ - and $op->first->first->sibling->name eq "lineseq") - or ($op->first->name eq "lineseq" - and not null $op->first->first->sibling - and $op->first->first->sibling->name eq "unstack") - )); -} - -sub is_scalar { - my $op = shift; - return ($op->name eq "rv2sv" or - $op->name eq "padsv" or - $op->name eq "gv" or # only in array/hash constructs - $op->flags & OPf_KIDS && !null($op->first) - && $op->first->name eq "gvsv"); -} - -sub maybe_parens { - my $self = shift; - my($text, $cx, $prec) = @_; - if ($prec < $cx # unary ops nest just fine - or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21 - or $self->{'parens'}) - { - $text = "($text)"; - # In a unop, let parent reuse our parens; see maybe_parens_unop - $text = "\cS" . $text if $cx == 16; - return $text; - } else { - return $text; - } -} - -# same as above, but get around the `if it looks like a function' rule -sub maybe_parens_unop { - my $self = shift; - my($name, $kid, $cx) = @_; - if ($cx > 16 or $self->{'parens'}) { - return "$name(" . $self->deparse($kid, 1) . ")"; - } else { - $kid = $self->deparse($kid, 16); - if (substr($kid, 0, 1) eq "\cS") { - # use kid's parens - return $name . substr($kid, 1); - } elsif (substr($kid, 0, 1) eq "(") { - # avoid looks-like-a-function trap with extra parens - # (`+' can lead to ambiguities) - return "$name(" . $kid . ")"; - } else { - return "$name $kid"; - } - } -} - -sub maybe_parens_func { - my $self = shift; - my($func, $text, $cx, $prec) = @_; - if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) { - return "$func($text)"; - } else { - return "$func $text"; - } -} - -sub maybe_local { - my $self = shift; - my($op, $cx, $text) = @_; - if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { - if (want_scalar($op)) { - return "local $text"; - } else { - return $self->maybe_parens_func("local", $text, $cx, 16); - } - } else { - return $text; - } -} - -sub maybe_targmy { - my $self = shift; - my($op, $cx, $func, @args) = @_; - if ($op->private & OPpTARGET_MY) { - my $var = $self->padname($op->targ); - my $val = $func->($self, $op, 7, @args); - return $self->maybe_parens("$var = $val", $cx, 7); - } else { - return $func->($self, $op, $cx, @args); - } -} - -sub padname_sv { - my $self = shift; - my $targ = shift; - return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ]; -} - -sub maybe_my { - my $self = shift; - my($op, $cx, $text) = @_; - if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { - if (want_scalar($op)) { - return "my $text"; - } else { - return $self->maybe_parens_func("my", $text, $cx, 16); - } - } else { - return $text; - } -} - -# The following OPs don't have functions: - -# pp_padany -- does not exist after parsing -# pp_rcatline -- does not exist - -sub pp_enter { # see also leave - cluck "unexpected OP_ENTER"; - return "XXX"; -} - -sub pp_pushmark { # see also list - cluck "unexpected OP_PUSHMARK"; - return "XXX"; -} - -sub pp_leavesub { # see also deparse_sub - cluck "unexpected OP_LEAVESUB"; - return "XXX"; -} - -sub pp_leavewrite { # see also deparse_format - cluck "unexpected OP_LEAVEWRITE"; - return "XXX"; -} - -sub pp_method { # see also entersub - cluck "unexpected OP_METHOD"; - return "XXX"; -} - -sub pp_regcmaybe { # see also regcomp - cluck "unexpected OP_REGCMAYBE"; - return "XXX"; -} - -sub pp_regcreset { # see also regcomp - cluck "unexpected OP_REGCRESET"; - return "XXX"; -} - -sub pp_substcont { # see also subst - cluck "unexpected OP_SUBSTCONT"; - return "XXX"; -} - -sub pp_grepstart { # see also grepwhile - cluck "unexpected OP_GREPSTART"; - return "XXX"; -} - -sub pp_mapstart { # see also mapwhile - cluck "unexpected OP_MAPSTART"; - return "XXX"; -} - -sub pp_flip { # see also flop - cluck "unexpected OP_FLIP"; - return "XXX"; -} - -sub pp_iter { # see also leaveloop - cluck "unexpected OP_ITER"; - return "XXX"; -} - -sub pp_enteriter { # see also leaveloop - cluck "unexpected OP_ENTERITER"; - return "XXX"; -} - -sub pp_enterloop { # see also leaveloop - cluck "unexpected OP_ENTERLOOP"; - return "XXX"; -} - -sub pp_leaveeval { # see also entereval - cluck "unexpected OP_LEAVEEVAL"; - return "XXX"; -} - -sub pp_entertry { # see also leavetry - cluck "unexpected OP_ENTERTRY"; - return "XXX"; -} - -sub lineseq { - my $self = shift; - my(@ops) = @_; - my($expr, @exprs); - for (my $i = 0; $i < @ops; $i++) { - $expr = ""; - if (is_state $ops[$i]) { - $expr = $self->deparse($ops[$i], 0); - $i++; - last if $i > $#ops; - } - if (!is_state $ops[$i] and $ops[$i+1] and !null($ops[$i+1]) and - $ops[$i+1]->name eq "leaveloop" and $self->{'expand'} < 3) - { - push @exprs, $expr . $self->for_loop($ops[$i], 0); - $i++; - next; - } - $expr .= $self->deparse($ops[$i], 0); - push @exprs, $expr if length $expr; - } - return join(";\n", @exprs); -} - -sub scopeop { - my($real_block, $self, $op, $cx) = @_; - my $kid; - my @kids; - local($self->{'curstash'}) = $self->{'curstash'} if $real_block; - if ($real_block) { - $kid = $op->first->sibling; # skip enter - if (is_miniwhile($kid)) { - my $top = $kid->first; - my $name = $top->name; - if ($name eq "and") { - $name = "while"; - } elsif ($name eq "or") { - $name = "until"; - } else { # no conditional -> while 1 or until 0 - return $self->deparse($top->first, 1) . " while 1"; - } - my $cond = $top->first; - my $body = $cond->sibling->first; # skip lineseq - $cond = $self->deparse($cond, 1); - $body = $self->deparse($body, 1); - return "$body $name $cond"; - } - } else { - $kid = $op->first; - } - for (; !null($kid); $kid = $kid->sibling) { - push @kids, $kid; - } - if ($cx > 0) { # inside an expression, (a do {} while for lineseq) - return "do { " . $self->lineseq(@kids) . " }"; - } else { - return $self->lineseq(@kids) . ";"; - } -} - -sub pp_scope { scopeop(0, @_); } -sub pp_lineseq { scopeop(0, @_); } -sub pp_leave { scopeop(1, @_); } - -# The BEGIN {} is used here because otherwise this code isn't executed -# when you run B::Deparse on itself. -my %globalnames; -BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC", - "ENV", "ARGV", "ARGVOUT", "_"); } - -sub gv_name { - my $self = shift; - my $gv = shift; - my $stash = $gv->STASH->NAME; - my $name = $gv->SAFENAME; - if ($stash eq $self->{'curstash'} or $globalnames{$name} - or $name =~ /^[^A-Za-z_]/) - { - $stash = ""; - } else { - $stash = $stash . "::"; - } - if ($name =~ /^\^../) { - $name = "{$name}"; # ${^WARNING_BITS} etc - } - return $stash . $name; -} - -# Notice how subs and formats are inserted between statements here -sub pp_nextstate { - my $self = shift; - my($op, $cx) = @_; - my @text; - @text = $op->label . ": " if $op->label; - my $seq = $op->cop_seq; - while (scalar(@{$self->{'subs_todo'}}) - and $seq > $self->{'subs_todo'}[0][0]) { - push @text, $self->next_todo; - } - my $stash = $op->stashpv; - if ($stash ne $self->{'curstash'}) { - push @text, "package $stash;\n"; - $self->{'curstash'} = $stash; - } - if ($self->{'linenums'}) { - push @text, "\f#line " . $op->line . - ' "' . $op->file, qq'"\n'; - } - return join("", @text); -} - -sub pp_dbstate { pp_nextstate(@_) } -sub pp_setstate { pp_nextstate(@_) } - -sub pp_unstack { return "" } # see also leaveloop - -sub baseop { - my $self = shift; - my($op, $cx, $name) = @_; - return $name; -} - -sub pp_stub { baseop(@_, "()") } -sub pp_wantarray { baseop(@_, "wantarray") } -sub pp_fork { baseop(@_, "fork") } -sub pp_wait { maybe_targmy(@_, \&baseop, "wait") } -sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") } -sub pp_time { maybe_targmy(@_, \&baseop, "time") } -sub pp_tms { baseop(@_, "times") } -sub pp_ghostent { baseop(@_, "gethostent") } -sub pp_gnetent { baseop(@_, "getnetent") } -sub pp_gprotoent { baseop(@_, "getprotoent") } -sub pp_gservent { baseop(@_, "getservent") } -sub pp_ehostent { baseop(@_, "endhostent") } -sub pp_enetent { baseop(@_, "endnetent") } -sub pp_eprotoent { baseop(@_, "endprotoent") } -sub pp_eservent { baseop(@_, "endservent") } -sub pp_gpwent { baseop(@_, "getpwent") } -sub pp_spwent { baseop(@_, "setpwent") } -sub pp_epwent { baseop(@_, "endpwent") } -sub pp_ggrent { baseop(@_, "getgrent") } -sub pp_sgrent { baseop(@_, "setgrent") } -sub pp_egrent { baseop(@_, "endgrent") } -sub pp_getlogin { baseop(@_, "getlogin") } - -sub POSTFIX () { 1 } - -# I couldn't think of a good short name, but this is the category of -# symbolic unary operators with interesting precedence - -sub pfixop { - my $self = shift; - my($op, $cx, $name, $prec, $flags) = (@_, 0); - my $kid = $op->first; - $kid = $self->deparse($kid, $prec); - return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid", - $cx, $prec); -} - -sub pp_preinc { pfixop(@_, "++", 23) } -sub pp_predec { pfixop(@_, "--", 23) } -sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) } -sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) } -sub pp_i_preinc { pfixop(@_, "++", 23) } -sub pp_i_predec { pfixop(@_, "--", 23) } -sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) } -sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) } -sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) } - -sub pp_negate { maybe_targmy(@_, \&real_negate) } -sub real_negate { - my $self = shift; - my($op, $cx) = @_; - if ($op->first->name =~ /^(i_)?negate$/) { - # avoid --$x - $self->pfixop($op, $cx, "-", 21.5); - } else { - $self->pfixop($op, $cx, "-", 21); - } -} -sub pp_i_negate { pp_negate(@_) } - -sub pp_not { - my $self = shift; - my($op, $cx) = @_; - if ($cx <= 4) { - $self->pfixop($op, $cx, "not ", 4); - } else { - $self->pfixop($op, $cx, "!", 21); - } -} - -sub unop { - my $self = shift; - my($op, $cx, $name) = @_; - my $kid; - if ($op->flags & OPf_KIDS) { - $kid = $op->first; - return $self->maybe_parens_unop($name, $kid, $cx); - } else { - return $name . ($op->flags & OPf_SPECIAL ? "()" : ""); - } -} - -sub pp_chop { maybe_targmy(@_, \&unop, "chop") } -sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") } -sub pp_schop { maybe_targmy(@_, \&unop, "chop") } -sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") } -sub pp_defined { unop(@_, "defined") } -sub pp_undef { unop(@_, "undef") } -sub pp_study { unop(@_, "study") } -sub pp_ref { unop(@_, "ref") } -sub pp_pos { maybe_local(@_, unop(@_, "pos")) } - -sub pp_sin { maybe_targmy(@_, \&unop, "sin") } -sub pp_cos { maybe_targmy(@_, \&unop, "cos") } -sub pp_rand { maybe_targmy(@_, \&unop, "rand") } -sub pp_srand { unop(@_, "srand") } -sub pp_exp { maybe_targmy(@_, \&unop, "exp") } -sub pp_log { maybe_targmy(@_, \&unop, "log") } -sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") } -sub pp_int { maybe_targmy(@_, \&unop, "int") } -sub pp_hex { maybe_targmy(@_, \&unop, "hex") } -sub pp_oct { maybe_targmy(@_, \&unop, "oct") } -sub pp_abs { maybe_targmy(@_, \&unop, "abs") } - -sub pp_length { maybe_targmy(@_, \&unop, "length") } -sub pp_ord { maybe_targmy(@_, \&unop, "ord") } -sub pp_chr { maybe_targmy(@_, \&unop, "chr") } - -sub pp_each { unop(@_, "each") } -sub pp_values { unop(@_, "values") } -sub pp_keys { unop(@_, "keys") } -sub pp_pop { unop(@_, "pop") } -sub pp_shift { unop(@_, "shift") } - -sub pp_caller { unop(@_, "caller") } -sub pp_reset { unop(@_, "reset") } -sub pp_exit { unop(@_, "exit") } -sub pp_prototype { unop(@_, "prototype") } - -sub pp_close { unop(@_, "close") } -sub pp_fileno { unop(@_, "fileno") } -sub pp_umask { unop(@_, "umask") } -sub pp_untie { unop(@_, "untie") } -sub pp_tied { unop(@_, "tied") } -sub pp_dbmclose { unop(@_, "dbmclose") } -sub pp_getc { unop(@_, "getc") } -sub pp_eof { unop(@_, "eof") } -sub pp_tell { unop(@_, "tell") } -sub pp_getsockname { unop(@_, "getsockname") } -sub pp_getpeername { unop(@_, "getpeername") } - -sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") } -sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") } -sub pp_readlink { unop(@_, "readlink") } -sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") } -sub pp_readdir { unop(@_, "readdir") } -sub pp_telldir { unop(@_, "telldir") } -sub pp_rewinddir { unop(@_, "rewinddir") } -sub pp_closedir { unop(@_, "closedir") } -sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") } -sub pp_localtime { unop(@_, "localtime") } -sub pp_gmtime { unop(@_, "gmtime") } -sub pp_alarm { unop(@_, "alarm") } -sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") } - -sub pp_dofile { unop(@_, "do") } -sub pp_entereval { unop(@_, "eval") } - -sub pp_ghbyname { unop(@_, "gethostbyname") } -sub pp_gnbyname { unop(@_, "getnetbyname") } -sub pp_gpbyname { unop(@_, "getprotobyname") } -sub pp_shostent { unop(@_, "sethostent") } -sub pp_snetent { unop(@_, "setnetent") } -sub pp_sprotoent { unop(@_, "setprotoent") } -sub pp_sservent { unop(@_, "setservent") } -sub pp_gpwnam { unop(@_, "getpwnam") } -sub pp_gpwuid { unop(@_, "getpwuid") } -sub pp_ggrnam { unop(@_, "getgrnam") } -sub pp_ggrgid { unop(@_, "getgrgid") } - -sub pp_lock { unop(@_, "lock") } - -sub pp_exists { - my $self = shift; - my($op, $cx) = @_; - return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16), - $cx, 16); -} - -sub pp_delete { - my $self = shift; - my($op, $cx) = @_; - my $arg; - if ($op->private & OPpSLICE) { - return $self->maybe_parens_func("delete", - $self->pp_hslice($op->first, 16), - $cx, 16); - } else { - return $self->maybe_parens_func("delete", - $self->pp_helem($op->first, 16), - $cx, 16); - } -} - -sub pp_require { - my $self = shift; - my($op, $cx) = @_; - if (class($op) eq "UNOP" and $op->first->name eq "const" - and $op->first->private & OPpCONST_BARE) - { - my $name = $self->const_sv($op->first)->PV; - $name =~ s[/][::]g; - $name =~ s/\.pm//g; - return "require($name)"; - } else { - $self->unop($op, $cx, "require"); - } -} - -sub pp_scalar { - my $self = shift; - my($op, $cv) = @_; - my $kid = $op->first; - if (not null $kid->sibling) { - # XXX Was a here-doc - return $self->dquote($op); - } - $self->unop(@_, "scalar"); -} - - -sub padval { - my $self = shift; - my $targ = shift; - #cluck "curcv was undef" unless $self->{curcv}; - return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ]; -} - -sub pp_refgen { - my $self = shift; - my($op, $cx) = @_; - my $kid = $op->first; - if ($kid->name eq "null") { - $kid = $kid->first; - if ($kid->name eq "anonlist" || $kid->name eq "anonhash") { - my($pre, $post) = @{{"anonlist" => ["[","]"], - "anonhash" => ["{","}"]}->{$kid->name}}; - my($expr, @exprs); - $kid = $kid->first->sibling; # skip pushmark - for (; !null($kid); $kid = $kid->sibling) { - $expr = $self->deparse($kid, 6); - push @exprs, $expr; - } - return $pre . join(", ", @exprs) . $post; - } elsif (!null($kid->sibling) and - $kid->sibling->name eq "anoncode") { - return "sub " . - $self->deparse_sub($self->padval($kid->sibling->targ)); - } elsif ($kid->name eq "pushmark") { - my $sib_name = $kid->sibling->name; - if ($sib_name =~ /^(pad|rv2)[ah]v$/ - and not $kid->sibling->flags & OPf_REF) - { - # The @a in \(@a) isn't in ref context, but only when the - # parens are there. - return "\\(" . $self->deparse($kid->sibling, 1) . ")"; - } elsif ($sib_name eq 'entersub') { - my $text = $self->deparse($kid->sibling, 1); - # Always show parens for \(&func()), but only with -p otherwise - $text = "($text)" if $self->{'parens'} - or $kid->sibling->private & OPpENTERSUB_AMPER; - return "\\$text"; - } - } - } - $self->pfixop($op, $cx, "\\", 20); -} - -sub pp_srefgen { pp_refgen(@_) } - -sub pp_readline { - my $self = shift; - my($op, $cx) = @_; - my $kid = $op->first; - $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh> - return "<" . $self->deparse($kid, 1) . ">"; -} - -# Unary operators that can occur as pseudo-listops inside double quotes -sub dq_unop { - my $self = shift; - my($op, $cx, $name, $prec, $flags) = (@_, 0, 0); - my $kid; - if ($op->flags & OPf_KIDS) { - $kid = $op->first; - # If there's more than one kid, the first is an ex-pushmark. - $kid = $kid->sibling if not null $kid->sibling; - return $self->maybe_parens_unop($name, $kid, $cx); - } else { - return $name . ($op->flags & OPf_SPECIAL ? "()" : ""); - } -} - -sub pp_ucfirst { dq_unop(@_, "ucfirst") } -sub pp_lcfirst { dq_unop(@_, "lcfirst") } -sub pp_uc { dq_unop(@_, "uc") } -sub pp_lc { dq_unop(@_, "lc") } -sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") } - -sub loopex { - my $self = shift; - my ($op, $cx, $name) = @_; - if (class($op) eq "PVOP") { - return "$name " . $op->pv; - } elsif (class($op) eq "OP") { - return $name; - } elsif (class($op) eq "UNOP") { - # Note -- loop exits are actually exempt from the - # looks-like-a-func rule, but a few extra parens won't hurt - return $self->maybe_parens_unop($name, $op->first, $cx); - } -} - -sub pp_last { loopex(@_, "last") } -sub pp_next { loopex(@_, "next") } -sub pp_redo { loopex(@_, "redo") } -sub pp_goto { loopex(@_, "goto") } -sub pp_dump { loopex(@_, "dump") } - -sub ftst { - my $self = shift; - my($op, $cx, $name) = @_; - if (class($op) eq "UNOP") { - # Genuine `-X' filetests are exempt from the LLAFR, but not - # l?stat(); for the sake of clarity, give'em all parens - return $self->maybe_parens_unop($name, $op->first, $cx); - } elsif (class($op) eq "SVOP") { - return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16); - } else { # I don't think baseop filetests ever survive ck_ftst, but... - return $name; - } -} - -sub pp_lstat { ftst(@_, "lstat") } -sub pp_stat { ftst(@_, "stat") } -sub pp_ftrread { ftst(@_, "-R") } -sub pp_ftrwrite { ftst(@_, "-W") } -sub pp_ftrexec { ftst(@_, "-X") } -sub pp_fteread { ftst(@_, "-r") } -sub pp_ftewrite { ftst(@_, "-r") } -sub pp_fteexec { ftst(@_, "-r") } -sub pp_ftis { ftst(@_, "-e") } -sub pp_fteowned { ftst(@_, "-O") } -sub pp_ftrowned { ftst(@_, "-o") } -sub pp_ftzero { ftst(@_, "-z") } -sub pp_ftsize { ftst(@_, "-s") } -sub pp_ftmtime { ftst(@_, "-M") } -sub pp_ftatime { ftst(@_, "-A") } -sub pp_ftctime { ftst(@_, "-C") } -sub pp_ftsock { ftst(@_, "-S") } -sub pp_ftchr { ftst(@_, "-c") } -sub pp_ftblk { ftst(@_, "-b") } -sub pp_ftfile { ftst(@_, "-f") } -sub pp_ftdir { ftst(@_, "-d") } -sub pp_ftpipe { ftst(@_, "-p") } -sub pp_ftlink { ftst(@_, "-l") } -sub pp_ftsuid { ftst(@_, "-u") } -sub pp_ftsgid { ftst(@_, "-g") } -sub pp_ftsvtx { ftst(@_, "-k") } -sub pp_fttty { ftst(@_, "-t") } -sub pp_fttext { ftst(@_, "-T") } -sub pp_ftbinary { ftst(@_, "-B") } - -sub SWAP_CHILDREN () { 1 } -sub ASSIGN () { 2 } # has OP= variant - -my(%left, %right); - -sub assoc_class { - my $op = shift; - my $name = $op->name; - if ($name eq "concat" and $op->first->name eq "concat") { - # avoid spurious `=' -- see comment in pp_concat - return "concat"; - } - if ($name eq "null" and class($op) eq "UNOP" - and $op->first->name =~ /^(and|x?or)$/ - and null $op->first->sibling) - { - # Like all conditional constructs, OP_ANDs and OP_ORs are topped - # with a null that's used as the common end point of the two - # flows of control. For precedence purposes, ignore it. - # (COND_EXPRs have these too, but we don't bother with - # their associativity). - return assoc_class($op->first); - } - return $name . ($op->flags & OPf_STACKED ? "=" : ""); -} - -# Left associative operators, like `+', for which -# $a + $b + $c is equivalent to ($a + $b) + $c - -BEGIN { - %left = ('multiply' => 19, 'i_multiply' => 19, - 'divide' => 19, 'i_divide' => 19, - 'modulo' => 19, 'i_modulo' => 19, - 'repeat' => 19, - 'add' => 18, 'i_add' => 18, - 'subtract' => 18, 'i_subtract' => 18, - 'concat' => 18, - 'left_shift' => 17, 'right_shift' => 17, - 'bit_and' => 13, - 'bit_or' => 12, 'bit_xor' => 12, - 'and' => 3, - 'or' => 2, 'xor' => 2, - ); -} - -sub deparse_binop_left { - my $self = shift; - my($op, $left, $prec) = @_; - if ($left{assoc_class($op)} && $left{assoc_class($left)} - and $left{assoc_class($op)} == $left{assoc_class($left)}) - { - return $self->deparse($left, $prec - .00001); - } else { - return $self->deparse($left, $prec); - } -} - -# Right associative operators, like `=', for which -# $a = $b = $c is equivalent to $a = ($b = $c) - -BEGIN { - %right = ('pow' => 22, - 'sassign=' => 7, 'aassign=' => 7, - 'multiply=' => 7, 'i_multiply=' => 7, - 'divide=' => 7, 'i_divide=' => 7, - 'modulo=' => 7, 'i_modulo=' => 7, - 'repeat=' => 7, - 'add=' => 7, 'i_add=' => 7, - 'subtract=' => 7, 'i_subtract=' => 7, - 'concat=' => 7, - 'left_shift=' => 7, 'right_shift=' => 7, - 'bit_and=' => 7, - 'bit_or=' => 7, 'bit_xor=' => 7, - 'andassign' => 7, - 'orassign' => 7, - ); -} - -sub deparse_binop_right { - my $self = shift; - my($op, $right, $prec) = @_; - if ($right{assoc_class($op)} && $right{assoc_class($right)} - and $right{assoc_class($op)} == $right{assoc_class($right)}) - { - return $self->deparse($right, $prec - .00001); - } else { - return $self->deparse($right, $prec); - } -} - -sub binop { - my $self = shift; - my ($op, $cx, $opname, $prec, $flags) = (@_, 0); - my $left = $op->first; - my $right = $op->last; - my $eq = ""; - if ($op->flags & OPf_STACKED && $flags & ASSIGN) { - $eq = "="; - $prec = 7; - } - if ($flags & SWAP_CHILDREN) { - ($left, $right) = ($right, $left); - } - $left = $self->deparse_binop_left($op, $left, $prec); - $right = $self->deparse_binop_right($op, $right, $prec); - return $self->maybe_parens("$left $opname$eq $right", $cx, $prec); -} - -sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) } -sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) } -sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) } -sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) } -sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) } -sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) } -sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) } -sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) } -sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) } -sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) } -sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) } - -sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) } -sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) } -sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) } -sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) } -sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) } - -sub pp_eq { binop(@_, "==", 14) } -sub pp_ne { binop(@_, "!=", 14) } -sub pp_lt { binop(@_, "<", 15) } -sub pp_gt { binop(@_, ">", 15) } -sub pp_ge { binop(@_, ">=", 15) } -sub pp_le { binop(@_, "<=", 15) } -sub pp_ncmp { binop(@_, "<=>", 14) } -sub pp_i_eq { binop(@_, "==", 14) } -sub pp_i_ne { binop(@_, "!=", 14) } -sub pp_i_lt { binop(@_, "<", 15) } -sub pp_i_gt { binop(@_, ">", 15) } -sub pp_i_ge { binop(@_, ">=", 15) } -sub pp_i_le { binop(@_, "<=", 15) } -sub pp_i_ncmp { binop(@_, "<=>", 14) } - -sub pp_seq { binop(@_, "eq", 14) } -sub pp_sne { binop(@_, "ne", 14) } -sub pp_slt { binop(@_, "lt", 15) } -sub pp_sgt { binop(@_, "gt", 15) } -sub pp_sge { binop(@_, "ge", 15) } -sub pp_sle { binop(@_, "le", 15) } -sub pp_scmp { binop(@_, "cmp", 14) } - -sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) } -sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) } - -# `.' is special because concats-of-concats are optimized to save copying -# by making all but the first concat stacked. The effect is as if the -# programmer had written `($a . $b) .= $c', except legal. -sub pp_concat { maybe_targmy(@_, \&real_concat) } -sub real_concat { - my $self = shift; - my($op, $cx) = @_; - my $left = $op->first; - my $right = $op->last; - my $eq = ""; - my $prec = 18; - if ($op->flags & OPf_STACKED and $op->first->name ne "concat") { - $eq = "="; - $prec = 7; - } - $left = $self->deparse_binop_left($op, $left, $prec); - $right = $self->deparse_binop_right($op, $right, $prec); - return $self->maybe_parens("$left .$eq $right", $cx, $prec); -} - -# `x' is weird when the left arg is a list -sub pp_repeat { - my $self = shift; - my($op, $cx) = @_; - my $left = $op->first; - my $right = $op->last; - my $eq = ""; - my $prec = 19; - if ($op->flags & OPf_STACKED) { - $eq = "="; - $prec = 7; - } - if (null($right)) { # list repeat; count is inside left-side ex-list - my $kid = $left->first->sibling; # skip pushmark - my @exprs; - for (; !null($kid->sibling); $kid = $kid->sibling) { - push @exprs, $self->deparse($kid, 6); - } - $right = $kid; - $left = "(" . join(", ", @exprs). ")"; - } else { - $left = $self->deparse_binop_left($op, $left, $prec); - } - $right = $self->deparse_binop_right($op, $right, $prec); - return $self->maybe_parens("$left x$eq $right", $cx, $prec); -} - -sub range { - my $self = shift; - my ($op, $cx, $type) = @_; - my $left = $op->first; - my $right = $left->sibling; - $left = $self->deparse($left, 9); - $right = $self->deparse($right, 9); - return $self->maybe_parens("$left $type $right", $cx, 9); -} - -sub pp_flop { - my $self = shift; - my($op, $cx) = @_; - my $flip = $op->first; - my $type = ($flip->flags & OPf_SPECIAL) ? "..." : ".."; - return $self->range($flip->first, $cx, $type); -} - -# one-line while/until is handled in pp_leave - -sub logop { - my $self = shift; - my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_; - my $left = $op->first; - my $right = $op->first->sibling; - if ($cx == 0 and is_scope($right) and $blockname - and $self->{'expand'} < 7) - { # if ($a) {$b} - $left = $self->deparse($left, 1); - $right = $self->deparse($right, 0); - return "$blockname ($left) {\n\t$right\n\b}\cK"; - } elsif ($cx == 0 and $blockname and not $self->{'parens'} - and $self->{'expand'} < 7) { # $b if $a - $right = $self->deparse($right, 1); - $left = $self->deparse($left, 1); - return "$right $blockname $left"; - } elsif ($cx > $lowprec and $highop) { # $a && $b - $left = $self->deparse_binop_left($op, $left, $highprec); - $right = $self->deparse_binop_right($op, $right, $highprec); - return $self->maybe_parens("$left $highop $right", $cx, $highprec); - } else { # $a and $b - $left = $self->deparse_binop_left($op, $left, $lowprec); - $right = $self->deparse_binop_right($op, $right, $lowprec); - return $self->maybe_parens("$left $lowop $right", $cx, $lowprec); - } -} - -sub pp_and { logop(@_, "and", 3, "&&", 11, "if") } -sub pp_or { logop(@_, "or", 2, "||", 10, "unless") } - -# xor is syntactically a logop, but it's really a binop (contrary to -# old versions of opcode.pl). Syntax is what matters here. -sub pp_xor { logop(@_, "xor", 2, "", 0, "") } - -sub logassignop { - my $self = shift; - my ($op, $cx, $opname) = @_; - my $left = $op->first; - my $right = $op->first->sibling->first; # skip sassign - $left = $self->deparse($left, 7); - $right = $self->deparse($right, 7); - return $self->maybe_parens("$left $opname $right", $cx, 7); -} - -sub pp_andassign { logassignop(@_, "&&=") } -sub pp_orassign { logassignop(@_, "||=") } - -sub listop { - my $self = shift; - my($op, $cx, $name) = @_; - my(@exprs); - my $parens = ($cx >= 5) || $self->{'parens'}; - my $kid = $op->first->sibling; - return $name if null $kid; - my $first = $self->deparse($kid, 6); - $first = "+$first" if not $parens and substr($first, 0, 1) eq "("; - push @exprs, $first; - $kid = $kid->sibling; - for (; !null($kid); $kid = $kid->sibling) { - push @exprs, $self->deparse($kid, 6); - } - if ($parens) { - return "$name(" . join(", ", @exprs) . ")"; - } else { - return "$name " . join(", ", @exprs); - } -} - -sub pp_bless { listop(@_, "bless") } -sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") } -sub pp_substr { maybe_local(@_, listop(@_, "substr")) } -sub pp_vec { maybe_local(@_, listop(@_, "vec")) } -sub pp_index { maybe_targmy(@_, \&listop, "index") } -sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") } -sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") } -sub pp_formline { listop(@_, "formline") } # see also deparse_format -sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") } -sub pp_unpack { listop(@_, "unpack") } -sub pp_pack { listop(@_, "pack") } -sub pp_join { maybe_targmy(@_, \&listop, "join") } -sub pp_splice { listop(@_, "splice") } -sub pp_push { maybe_targmy(@_, \&listop, "push") } -sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") } -sub pp_reverse { listop(@_, "reverse") } -sub pp_warn { listop(@_, "warn") } -sub pp_die { listop(@_, "die") } -# Actually, return is exempt from the LLAFR (see examples in this very -# module!), but for consistency's sake, ignore that fact -sub pp_return { listop(@_, "return") } -sub pp_open { listop(@_, "open") } -sub pp_pipe_op { listop(@_, "pipe") } -sub pp_tie { listop(@_, "tie") } -sub pp_binmode { listop(@_, "binmode") } -sub pp_dbmopen { listop(@_, "dbmopen") } -sub pp_sselect { listop(@_, "select") } -sub pp_select { listop(@_, "select") } -sub pp_read { listop(@_, "read") } -sub pp_sysopen { listop(@_, "sysopen") } -sub pp_sysseek { listop(@_, "sysseek") } -sub pp_sysread { listop(@_, "sysread") } -sub pp_syswrite { listop(@_, "syswrite") } -sub pp_send { listop(@_, "send") } -sub pp_recv { listop(@_, "recv") } -sub pp_seek { listop(@_, "seek") } -sub pp_fcntl { listop(@_, "fcntl") } -sub pp_ioctl { listop(@_, "ioctl") } -sub pp_flock { maybe_targmy(@_, \&listop, "flock") } -sub pp_socket { listop(@_, "socket") } -sub pp_sockpair { listop(@_, "sockpair") } -sub pp_bind { listop(@_, "bind") } -sub pp_connect { listop(@_, "connect") } -sub pp_listen { listop(@_, "listen") } -sub pp_accept { listop(@_, "accept") } -sub pp_shutdown { listop(@_, "shutdown") } -sub pp_gsockopt { listop(@_, "getsockopt") } -sub pp_ssockopt { listop(@_, "setsockopt") } -sub pp_chown { maybe_targmy(@_, \&listop, "chown") } -sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") } -sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") } -sub pp_utime { maybe_targmy(@_, \&listop, "utime") } -sub pp_rename { maybe_targmy(@_, \&listop, "rename") } -sub pp_link { maybe_targmy(@_, \&listop, "link") } -sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") } -sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") } -sub pp_open_dir { listop(@_, "opendir") } -sub pp_seekdir { listop(@_, "seekdir") } -sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") } -sub pp_system { maybe_targmy(@_, \&listop, "system") } -sub pp_exec { maybe_targmy(@_, \&listop, "exec") } -sub pp_kill { maybe_targmy(@_, \&listop, "kill") } -sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") } -sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") } -sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") } -sub pp_shmget { listop(@_, "shmget") } -sub pp_shmctl { listop(@_, "shmctl") } -sub pp_shmread { listop(@_, "shmread") } -sub pp_shmwrite { listop(@_, "shmwrite") } -sub pp_msgget { listop(@_, "msgget") } -sub pp_msgctl { listop(@_, "msgctl") } -sub pp_msgsnd { listop(@_, "msgsnd") } -sub pp_msgrcv { listop(@_, "msgrcv") } -sub pp_semget { listop(@_, "semget") } -sub pp_semctl { listop(@_, "semctl") } -sub pp_semop { listop(@_, "semop") } -sub pp_ghbyaddr { listop(@_, "gethostbyaddr") } -sub pp_gnbyaddr { listop(@_, "getnetbyaddr") } -sub pp_gpbynumber { listop(@_, "getprotobynumber") } -sub pp_gsbyname { listop(@_, "getservbyname") } -sub pp_gsbyport { listop(@_, "getservbyport") } -sub pp_syscall { listop(@_, "syscall") } - -sub pp_glob { - my $self = shift; - my($op, $cx) = @_; - my $text = $self->dq($op->first->sibling); # skip pushmark - if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline - or $text =~ /[<>]/) { - return 'glob(' . single_delim('qq', '"', $text) . ')'; - } else { - return '<' . $text . '>'; - } -} - -# Truncate is special because OPf_SPECIAL makes a bareword first arg -# be a filehandle. This could probably be better fixed in the core -# by moving the GV lookup into ck_truc. - -sub pp_truncate { - my $self = shift; - my($op, $cx) = @_; - my(@exprs); - my $parens = ($cx >= 5) || $self->{'parens'}; - my $kid = $op->first->sibling; - my $fh; - if ($op->flags & OPf_SPECIAL) { - # $kid is an OP_CONST - $fh = $self->const_sv($kid)->PV; - } else { - $fh = $self->deparse($kid, 6); - $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "("; - } - my $len = $self->deparse($kid->sibling, 6); - if ($parens) { - return "truncate($fh, $len)"; - } else { - return "truncate $fh, $len"; - } -} - -sub indirop { - my $self = shift; - my($op, $cx, $name) = @_; - my($expr, @exprs); - my $kid = $op->first->sibling; - my $indir = ""; - if ($op->flags & OPf_STACKED) { - $indir = $kid; - $indir = $indir->first; # skip rv2gv - if (is_scope($indir)) { - $indir = "{" . $self->deparse($indir, 0) . "}"; - } else { - $indir = $self->deparse($indir, 24); - } - $indir = $indir . " "; - $kid = $kid->sibling; - } - for (; !null($kid); $kid = $kid->sibling) { - $expr = $self->deparse($kid, 6); - push @exprs, $expr; - } - return $self->maybe_parens_func($name, $indir . join(", ", @exprs), - $cx, 5); -} - -sub pp_prtf { indirop(@_, "printf") } -sub pp_print { indirop(@_, "print") } -sub pp_sort { indirop(@_, "sort") } - -sub mapop { - my $self = shift; - my($op, $cx, $name) = @_; - my($expr, @exprs); - my $kid = $op->first; # this is the (map|grep)start - $kid = $kid->first->sibling; # skip a pushmark - my $code = $kid->first; # skip a null - if (is_scope $code) { - $code = "{" . $self->deparse($code, 0) . "} "; - } else { - $code = $self->deparse($code, 24) . ", "; - } - $kid = $kid->sibling; - for (; !null($kid); $kid = $kid->sibling) { - $expr = $self->deparse($kid, 6); - push @exprs, $expr if $expr; - } - return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5); -} - -sub pp_mapwhile { mapop(@_, "map") } -sub pp_grepwhile { mapop(@_, "grep") } - -sub pp_list { - my $self = shift; - my($op, $cx) = @_; - my($expr, @exprs); - my $kid = $op->first->sibling; # skip pushmark - my $lop; - my $local = "either"; # could be local(...) or my(...) - for ($lop = $kid; !null($lop); $lop = $lop->sibling) { - # This assumes that no other private flags equal 128, and that - # OPs that store things other than flags in their op_private, - # like OP_AELEMFAST, won't be immediate children of a list. - unless ($lop->private & OPpLVAL_INTRO or $lop->name eq "undef") - { - $local = ""; # or not - last; - } - if ($lop->name =~ /^pad[ash]v$/) { # my() - ($local = "", last) if $local eq "local"; - $local = "my"; - } elsif ($lop->name ne "undef") { # local() - ($local = "", last) if $local eq "my"; - $local = "local"; - } - } - $local = "" if $local eq "either"; # no point if it's all undefs - return $self->deparse($kid, $cx) if null $kid->sibling and not $local; - for (; !null($kid); $kid = $kid->sibling) { - if ($local) { - if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") { - $lop = $kid->first; - } else { - $lop = $kid; - } - $self->{'avoid_local'}{$$lop}++; - $expr = $self->deparse($kid, 6); - delete $self->{'avoid_local'}{$$lop}; - } else { - $expr = $self->deparse($kid, 6); - } - push @exprs, $expr; - } - if ($local) { - return "$local(" . join(", ", @exprs) . ")"; - } else { - return $self->maybe_parens( join(", ", @exprs), $cx, 6); - } -} - -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) = @_; - my $cond = $op->first; - my $true = $cond->sibling; - my $false = $true->sibling; - my $cuddle = $self->{'cuddle'}; - unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and - (is_scope($false) || is_ifelse_cont($false)) - and $self->{'expand'} < 7) { - $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); - 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"; - } - return $head . join($cuddle, "", @elsifs) . $false; -} - -sub loop_common { - my $self = shift; - my($op, $cx, $init) = @_; - my $enter = $op->first; - my $kid = $enter->sibling; - local($self->{'curstash'}) = $self->{'curstash'}; - my $head = ""; - my $bare = 0; - my $body; - my $cond = undef; - if ($kid->name eq "lineseq") { # bare or infinite loop - if (is_state $kid->last) { # infinite - $head = "for (;;) "; # shorter than while (1) - $cond = ""; - } else { - $bare = 1; - } - $body = $kid; - } elsif ($enter->name eq "enteriter") { # foreach - my $ary = $enter->first->sibling; # first was pushmark - my $var = $ary->sibling; - if ($enter->flags & OPf_STACKED - and not null $ary->first->sibling->sibling) - { - $ary = $self->deparse($ary->first->sibling, 9) . " .. " . - $self->deparse($ary->first->sibling->sibling, 9); - } else { - $ary = $self->deparse($ary, 1); - } - if (null $var) { - if ($enter->flags & OPf_SPECIAL) { # thread special var - $var = $self->pp_threadsv($enter, 1); - } else { # regular my() variable - $var = $self->pp_padsv($enter, 1); - if ($self->padname_sv($enter->targ)->IVX == - $kid->first->first->sibling->last->cop_seq) - { - # If the scope of this variable closes at the last - # statement of the loop, it must have been - # declared here. - $var = "my " . $var; - } - } - } elsif ($var->name eq "rv2gv") { - $var = $self->pp_rv2sv($var, 1); - } elsif ($var->name eq "gv") { - $var = "\$" . $self->deparse($var, 1); - } - $head = "foreach $var ($ary) "; - $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER - } elsif ($kid->name eq "null") { # while/until - $kid = $kid->first; - my $name = {"and" => "while", "or" => "until"}->{$kid->name}; - $cond = $self->deparse($kid->first, 1); - $head = "$name ($cond) "; - $body = $kid->first->sibling; - } elsif ($kid->name eq "stub") { # bare and empty - return "{;}"; # {} could be a hashref - } - # If there isn't a continue block, then the next pointer for the loop - # will point to the unstack, which is kid's penultimate child, except - # in a bare loop, when it will point to the leaveloop. When neither of - # these conditions hold, then the third-to-last child in the continue - # block (or the last in a bare loop). - my $cont_start = $enter->nextop; - my $cont; - if ($$cont_start != $$op and $ {$cont_start->sibling} != $ {$body->last}) { - if ($bare) { - $cont = $body->last; - } else { - $cont = $body->first; - while (!null($cont->sibling->sibling->sibling)) { - $cont = $cont->sibling; - } - } - my $state = $body->first; - my $cuddle = $self->{'cuddle'}; - my @states; - for (; $$state != $$cont; $state = $state->sibling) { - push @states, $state; - } - $body = $self->lineseq(@states); - if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) { - $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") "; - $cont = "\cK"; - } else { - $cont = $cuddle . "continue {\n\t" . - $self->deparse($cont, 0) . "\n\b}\cK"; - } - } else { - $cont = "\cK"; - $body = $self->deparse($body, 0); - } - return $head . "{\n\t" . $body . "\n\b}" . $cont; -} - -sub pp_leaveloop { loop_common(@_, "") } - -sub for_loop { - my $self = shift; - my($op, $cx) = @_; - my $init = $self->deparse($op, 1); - return $self->loop_common($op->sibling, $cx, $init); -} - -sub pp_leavetry { - my $self = shift; - return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}"; -} - -BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" } -BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" } - -sub pp_null { - my $self = shift; - my($op, $cx) = @_; - if (class($op) eq "OP") { - # old value is lost - return $self->{'ex_const'} if $op->targ == OP_CONST; - } elsif ($op->first->name eq "pushmark") { - return $self->pp_list($op, $cx); - } elsif ($op->first->name eq "enter") { - return $self->pp_leave($op, $cx); - } elsif ($op->targ == OP_STRINGIFY) { - return $self->dquote($op, $cx); - } elsif (!null($op->first->sibling) and - $op->first->sibling->name eq "readline" and - $op->first->sibling->flags & OPf_STACKED) { - return $self->maybe_parens($self->deparse($op->first, 7) . " = " - . $self->deparse($op->first->sibling, 7), - $cx, 7); - } elsif (!null($op->first->sibling) and - $op->first->sibling->name eq "trans" and - $op->first->sibling->flags & OPf_STACKED) { - return $self->maybe_parens($self->deparse($op->first, 20) . " =~ " - . $self->deparse($op->first->sibling, 20), - $cx, 20); - } else { - return $self->deparse($op->first, $cx); - } -} - -sub padname { - my $self = shift; - my $targ = shift; - return $self->padname_sv($targ)->PVX; -} - -sub padany { - my $self = shift; - my $op = shift; - return substr($self->padname($op->targ), 1); # skip $/@/% -} - -sub pp_padsv { - my $self = shift; - my($op, $cx) = @_; - return $self->maybe_my($op, $cx, $self->padname($op->targ)); -} - -sub pp_padav { pp_padsv(@_) } -sub pp_padhv { pp_padsv(@_) } - -my @threadsv_names; - -BEGIN { - @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9", - "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";", - "^", "-", "%", "=", "|", "~", ":", "^A", "^E", - "!", "@"); -} - -sub pp_threadsv { - my $self = shift; - my($op, $cx) = @_; - return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]); -} - -sub gv_or_padgv { - my $self = shift; - my $op = shift; - if (class($op) eq "PADOP") { - return $self->padval($op->padix); - } else { # class($op) eq "SVOP" - return $op->gv; - } -} - -sub pp_gvsv { - my $self = shift; - my($op, $cx) = @_; - 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->gv_or_padgv($op); - return $self->gv_name($gv); -} - -sub pp_aelemfast { - my $self = shift; - my($op, $cx) = @_; - my $gv = $self->gv_or_padgv($op); - return "\$" . $self->gv_name($gv) . "[" . $op->private . "]"; -} - -sub rv2x { - my $self = shift; - my($op, $cx, $type) = @_; - my $kid = $op->first; - my $str = $self->deparse($kid, 0); - return $type . (is_scalar($kid) ? $str : "{$str}"); -} - -sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) } -sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) } -sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) } - -# skip rv2av -sub pp_av2arylen { - my $self = shift; - my($op, $cx) = @_; - if ($op->first->name eq "padav") { - return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first)); - } else { - return $self->maybe_local($op, $cx, - $self->rv2x($op->first, $cx, '$#')); - } -} - -# skip down to the old, ex-rv2cv -sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") } - -sub pp_rv2av { - my $self = shift; - my($op, $cx) = @_; - my $kid = $op->first; - if ($kid->name eq "const") { # constant list - my $av = $self->const_sv($kid); - return "(" . join(", ", map(const($_), $av->ARRAY)) . ")"; - } else { - return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@")); - } - } - -sub is_subscriptable { - my $op = shift; - if ($op->name =~ /^[ahg]elem/) { - return 1; - } elsif ($op->name eq "entersub") { - my $kid = $op->first; - return 0 unless null $kid->sibling; - $kid = $kid->first; - $kid = $kid->sibling until null $kid->sibling; - return 0 if is_scope($kid); - $kid = $kid->first; - return 0 if $kid->name eq "gv"; - return 0 if is_scalar($kid); - return is_subscriptable($kid); - } else { - return 0; - } -} - -sub elem { - my $self = shift; - my ($op, $cx, $left, $right, $padname) = @_; - my($array, $idx) = ($op->first, $op->first->sibling); - unless ($array->name eq $padname) { # Maybe this has been fixed - $array = $array->first; # skip rv2av (or ex-rv2av in _53+) - } - if ($array->name eq $padname) { - $array = $self->padany($array); - } elsif (is_scope($array)) { # ${expr}[0] - $array = "{" . $self->deparse($array, 0) . "}"; - } elsif (is_scalar $array) { # $x[0], $$x[0], ... - $array = $self->deparse($array, 24); - } else { - # $x[20][3]{hi} or expr->[20] - my $arrow = is_subscriptable($array) ? "" : "->"; - return $self->deparse($array, 24) . $arrow . - $left . $self->deparse($idx, 1) . $right; - } - $idx = $self->deparse($idx, 1); - return "\$" . $array . $left . $idx . $right; -} - -sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) } -sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) } - -sub pp_gelem { - my $self = shift; - my($op, $cx) = @_; - my($glob, $part) = ($op->first, $op->last); - $glob = $glob->first; # skip rv2gv - $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug - my $scope = is_scope($glob); - $glob = $self->deparse($glob, 0); - $part = $self->deparse($part, 1); - return "*" . ($scope ? "{$glob}" : $glob) . "{$part}"; -} - -sub slice { - my $self = shift; - my ($op, $cx, $left, $right, $regname, $padname) = @_; - my $last; - my(@elems, $kid, $array, $list); - if (class($op) eq "LISTOP") { - $last = $op->last; - } else { # ex-hslice inside delete() - for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {} - $last = $kid; - } - $array = $last; - $array = $array->first - if $array->name eq $regname or $array->name eq "null"; - if (is_scope($array)) { - $array = "{" . $self->deparse($array, 0) . "}"; - } elsif ($array->name eq $padname) { - $array = $self->padany($array); - } else { - $array = $self->deparse($array, 24); - } - $kid = $op->first->sibling; # skip pushmark - if ($kid->name eq "list") { - $kid = $kid->first->sibling; # skip list, pushmark - for (; !null $kid; $kid = $kid->sibling) { - push @elems, $self->deparse($kid, 6); - } - $list = join(", ", @elems); - } else { - $list = $self->deparse($kid, 1); - } - return "\@" . $array . $left . $list . $right; -} - -sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) } -sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) } - -sub pp_lslice { - my $self = shift; - my($op, $cx) = @_; - my $idx = $op->first; - my $list = $op->last; - my(@elems, $kid); - $list = $self->deparse($list, 1); - $idx = $self->deparse($idx, 1); - return "($list)" . "[$idx]"; -} - -sub want_scalar { - my $op = shift; - return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR; -} - -sub want_list { - my $op = shift; - return ($op->flags & OPf_WANT) == OPf_WANT_LIST; -} - -sub method { - my $self = shift; - my($op, $cx) = @_; - my $kid = $op->first->sibling; # skip pushmark - my($meth, $obj, @exprs); - if ($kid->name eq "list" and want_list $kid) { - # When an indirect object isn't a bareword but the args are in - # parens, the parens aren't part of the method syntax (the LLAFR - # doesn't apply), but they make a list with OPf_PARENS set that - # doesn't get flattened by the append_elem that adds the method, - # making a (object, arg1, arg2, ...) list where the object - # usually is. This can be distinguished from - # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an - # object) because in the later the list is in scalar context - # as the left side of -> always is, while in the former - # the list is in list context as method arguments always are. - # (Good thing there aren't method prototypes!) - $meth = $kid->sibling; - $kid = $kid->first->sibling; # skip pushmark - $obj = $kid; - $kid = $kid->sibling; - for (; not null $kid; $kid = $kid->sibling) { - push @exprs, $self->deparse($kid, 6); - } - } else { - $obj = $kid; - $kid = $kid->sibling; - for (; not null $kid->sibling; $kid = $kid->sibling) { - push @exprs, $self->deparse($kid, 6); - } - $meth = $kid; - } - $obj = $self->deparse($obj, 24); - if ($meth->name eq "method_named") { - $meth = $self->const_sv($meth)->PV; - } else { - $meth = $meth->first; - if ($meth->name eq "const") { - # As of 5.005_58, this case is probably obsoleted by the - # method_named case above - $meth = $self->const_sv($meth)->PV; # needs to be bare - } else { - $meth = $self->deparse($meth, 1); - } - } - my $args = join(", ", @exprs); - $kid = $obj . "->" . $meth; - if ($args) { - return $kid . "(" . $args . ")"; # parens mandatory - } else { - return $kid; - } -} - -# returns "&" if the prototype doesn't match the args, -# or ("", $args_after_prototype_demunging) if it does. -sub check_proto { - my $self = shift; - my($proto, @args) = @_; - my($arg, $real); - my $doneok = 0; - my @reals; - # An unbackslashed @ or % gobbles up the rest of the args - $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/; - while ($proto) { - $proto =~ s/^ *([\\]?[\$\@&%*]|;)//; - my $chr = $1; - if ($chr eq "") { - return "&" if @args; - } elsif ($chr eq ";") { - $doneok = 1; - } elsif ($chr eq "@" or $chr eq "%") { - push @reals, map($self->deparse($_, 6), @args); - @args = (); - } else { - $arg = shift @args; - last unless $arg; - if ($chr eq "\$") { - if (want_scalar $arg) { - push @reals, $self->deparse($arg, 6); - } else { - return "&"; - } - } elsif ($chr eq "&") { - if ($arg->name =~ /^(s?refgen|undef)$/) { - push @reals, $self->deparse($arg, 6); - } else { - return "&"; - } - } elsif ($chr eq "*") { - if ($arg->name =~ /^s?refgen$/ - and $arg->first->first->name eq "rv2gv") - { - $real = $arg->first->first; # skip refgen, null - if ($real->first->name eq "gv") { - push @reals, $self->deparse($real, 6); - } else { - push @reals, $self->deparse($real->first, 6); - } - } else { - return "&"; - } - } elsif (substr($chr, 0, 1) eq "\\") { - $chr = substr($chr, 1); - if ($arg->name =~ /^s?refgen$/ and - !null($real = $arg->first) and - ($chr eq "\$" && is_scalar($real->first) - or ($chr eq "\@" - && $real->first->sibling->name - =~ /^(rv2|pad)av$/) - or ($chr eq "%" - && $real->first->sibling->name - =~ /^(rv2|pad)hv$/) - #or ($chr eq "&" # This doesn't work - # && $real->first->name eq "rv2cv") - or ($chr eq "*" - && $real->first->name eq "rv2gv"))) - { - push @reals, $self->deparse($real, 6); - } else { - return "&"; - } - } - } - } - return "&" if $proto and !$doneok; # too few args and no `;' - return "&" if @args; # too many args - return ("", join ", ", @reals); -} - -sub pp_entersub { - my $self = shift; - my($op, $cx) = @_; - return $self->method($op, $cx) unless null $op->first->sibling; - my $prefix = ""; - my $amper = ""; - my($kid, @exprs); - if ($op->flags & OPf_SPECIAL) { - $prefix = "do "; - } elsif ($op->private & OPpENTERSUB_AMPER) { - $amper = "&"; - } - $kid = $op->first; - $kid = $kid->first->sibling; # skip ex-list, pushmark - for (; not null $kid->sibling; $kid = $kid->sibling) { - push @exprs, $kid; - } - my $simple = 0; - my $proto = undef; - if (is_scope($kid)) { - $amper = "&"; - $kid = "{" . $self->deparse($kid, 0) . "}"; - } elsif ($kid->first->name eq "gv") { - my $gv = $self->gv_or_padgv($kid->first); - if (class($gv->CV) ne "SPECIAL") { - $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK; - } - $simple = 1; # only calls of named functions can be prototyped - $kid = $self->deparse($kid, 24); - } elsif (is_scalar $kid->first) { - $amper = "&"; - $kid = $self->deparse($kid, 24); - } else { - $prefix = ""; - my $arrow = is_subscriptable($kid->first) ? "" : "->"; - $kid = $self->deparse($kid, 24) . $arrow; - } - my $args; - if (defined $proto and not $amper) { - ($amper, $args) = $self->check_proto($proto, @exprs); - if ($amper eq "&") { - $args = join(", ", map($self->deparse($_, 6), @exprs)); - } - } else { - $args = join(", ", map($self->deparse($_, 6), @exprs)); - } - if ($prefix or $amper) { - if ($op->flags & OPf_STACKED) { - return $prefix . $amper . $kid . "(" . $args . ")"; - } else { - return $prefix . $amper. $kid; - } - } else { - if (defined $proto and $proto eq "") { - return $kid; - } elsif (defined $proto and $proto eq "\$") { - return $self->maybe_parens_func($kid, $args, $cx, 16); - } elsif (defined($proto) && $proto or $simple) { - return $self->maybe_parens_func($kid, $args, $cx, 5); - } else { - return "$kid(" . $args . ")"; - } - } -} - -sub pp_enterwrite { unop(@_, "write") } - -# escape things that cause interpolation in double quotes, -# but not character escapes -sub uninterp { - my($str) = @_; - $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g; - return $str; -} - -# the same, but treat $|, $), and $ at the end of the string differently -sub re_uninterp { - my($str) = @_; - $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g; - $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g; - return $str; -} - -# character escapes, but not delimiters that might need to be escaped -sub escape_str { # ASCII - my($str) = @_; - $str =~ s/\a/\\a/g; -# $str =~ s/\cH/\\b/g; # \b means someting different in a regex - $str =~ s/\t/\\t/g; - $str =~ s/\n/\\n/g; - $str =~ s/\e/\\e/g; - $str =~ s/\f/\\f/g; - $str =~ s/\r/\\r/g; - $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge; - $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge; - return $str; -} - -# Don't do this for regexen -sub unback { - my($str) = @_; - $str =~ s/\\/\\\\/g; - return $str; -} - -sub balanced_delim { - my($str) = @_; - my @str = split //, $str; - my($ar, $open, $close, $fail, $c, $cnt); - for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) { - ($open, $close) = @$ar; - $fail = 0; $cnt = 0; - for $c (@str) { - if ($c eq $open) { - $cnt++; - } elsif ($c eq $close) { - $cnt--; - if ($cnt < 0) { - # qq()() isn't ")(" - $fail = 1; - last; - } - } - } - $fail = 1 if $cnt != 0; - return ($open, "$open$str$close") if not $fail; - } - return ("", $str); -} - -sub single_delim { - my($q, $default, $str) = @_; - return "$default$str$default" if $default and index($str, $default) == -1; - my($succeed, $delim); - ($succeed, $str) = balanced_delim($str); - return "$q$str" if $succeed; - for $delim ('/', '"', '#') { - return "$q$delim" . $str . $delim if index($str, $delim) == -1; - } - if ($default) { - $str =~ s/$default/\\$default/g; - return "$default$str$default"; - } else { - $str =~ s[/][\\/]g; - return "$q/$str/"; - } -} - -sub const { - my $sv = shift; - if (class($sv) eq "SPECIAL") { - return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no - } elsif ($sv->FLAGS & SVf_IOK) { - return $sv->int_value; - } elsif ($sv->FLAGS & SVf_NOK) { - return $sv->NV; - } elsif ($sv->FLAGS & SVf_ROK) { - return "\\(" . const($sv->RV) . ")"; # constant folded - } else { - my $str = $sv->PV; - if ($str =~ /[^ -~]/) { # ASCII for non-printing - return single_delim("qq", '"', uninterp escape_str unback $str); - } else { - return single_delim("q", "'", unback $str); - } - } -} - -sub const_sv { - my $self = shift; - my $op = shift; - my $sv = $op->sv; - # the constant could be in the pad (under useithreads) - $sv = $self->padval($op->targ) unless $$sv; - return $sv; -} - -sub pp_const { - my $self = shift; - my($op, $cx) = @_; -# if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting -# return $self->const_sv($op)->PV; -# } - my $sv = $self->const_sv($op); -# return const($sv); - my $c = const $sv; - return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c; -} - -sub dq { - my $self = shift; - my $op = shift; - my $type = $op->name; - if ($type eq "const") { - return uninterp(escape_str(unback($self->const_sv($op)->PV))); - } elsif ($type eq "concat") { - my $first = $self->dq($op->first); - my $last = $self->dq($op->last); - # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]" - if ($last =~ /^[{\[\w]/) { - $first =~ s/([%\$@])([A-Za-z_]\w*)$/${1}{$2}/; - } - return $first . $last; - } elsif ($type eq "uc") { - return '\U' . $self->dq($op->first->sibling) . '\E'; - } elsif ($type eq "lc") { - return '\L' . $self->dq($op->first->sibling) . '\E'; - } elsif ($type eq "ucfirst") { - return '\u' . $self->dq($op->first->sibling); - } elsif ($type eq "lcfirst") { - return '\l' . $self->dq($op->first->sibling); - } elsif ($type eq "quotemeta") { - return '\Q' . $self->dq($op->first->sibling) . '\E'; - } elsif ($type eq "join") { - return $self->deparse($op->last, 26); # was join($", @ary) - } else { - return $self->deparse($op, 26); - } -} - -sub pp_backtick { - my $self = shift; - my($op, $cx) = @_; - # skip pushmark - return single_delim("qx", '`', $self->dq($op->first->sibling)); -} - -sub dquote { - my $self = 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, - sub {single_delim("qq", '"', $self->dq($_[1]))}); -} - -# OP_STRINGIFY is a listop, but it only ever has one arg -sub pp_stringify { maybe_targmy(@_, \&dquote) } - -# tr/// and s/// (and tr[][], tr[]//, tr###, etc) -# note that tr(from)/to/ is OK, but not tr/from/(to) -sub double_delim { - my($from, $to) = @_; - my($succeed, $delim); - if ($from !~ m[/] and $to !~ m[/]) { - return "/$from/$to/"; - } elsif (($succeed, $from) = balanced_delim($from) and $succeed) { - if (($succeed, $to) = balanced_delim($to) and $succeed) { - return "$from$to"; - } else { - for $delim ('/', '"', '#') { # note no `'' -- s''' is special - return "$from$delim$to$delim" if index($to, $delim) == -1; - } - $to =~ s[/][\\/]g; - return "$from/$to/"; - } - } else { - for $delim ('/', '"', '#') { # note no ' - return "$delim$from$delim$to$delim" - if index($to . $from, $delim) == -1; - } - $from =~ s[/][\\/]g; - $to =~ s[/][\\/]g; - return "/$from/$to/"; - } -} - -sub pchr { # ASCII - my($n) = @_; - if ($n == ord '\\') { - return '\\\\'; - } elsif ($n >= ord(' ') and $n <= ord('~')) { - return chr($n); - } elsif ($n == ord "\a") { - return '\\a'; - } elsif ($n == ord "\b") { - return '\\b'; - } elsif ($n == ord "\t") { - return '\\t'; - } elsif ($n == ord "\n") { - return '\\n'; - } elsif ($n == ord "\e") { - return '\\e'; - } elsif ($n == ord "\f") { - return '\\f'; - } elsif ($n == ord "\r") { - return '\\r'; - } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) { - return '\\c' . chr(ord("@") + $n); - } else { -# return '\x' . sprintf("%02x", $n); - return '\\' . sprintf("%03o", $n); - } -} - -sub collapse { - my(@chars) = @_; - my($str, $c, $tr) = (""); - for ($c = 0; $c < @chars; $c++) { - $tr = $chars[$c]; - $str .= pchr($tr); - if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and - $chars[$c + 2] == $tr + 2) - { - for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++) - {} - $str .= "-"; - $str .= pchr($chars[$c]); - } - } - return $str; -} - -# XXX This has trouble with hyphens in the replacement (tr/bac/-AC/), -# and backslashes. - -sub tr_decode_byte { - my($table, $flags) = @_; - my(@table) = unpack("s256", $table); - my($c, $tr, @from, @to, @delfrom, $delhyphen); - if ($table[ord "-"] != -1 and - $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1) - { - $tr = $table[ord "-"]; - $table[ord "-"] = -1; - if ($tr >= 0) { - @from = ord("-"); - @to = $tr; - } else { # -2 ==> delete - $delhyphen = 1; - } - } - for ($c = 0; $c < 256; $c++) { - $tr = $table[$c]; - if ($tr >= 0) { - push @from, $c; push @to, $tr; - } elsif ($tr == -2) { - push @delfrom, $c; - } - } - @from = (@from, @delfrom); - if ($flags & OPpTRANS_COMPLEMENT) { - my @newfrom = (); - my %from; - @from{@from} = (1) x @from; - for ($c = 0; $c < 256; $c++) { - push @newfrom, $c unless $from{$c}; - } - @from = @newfrom; - } - unless ($flags & OPpTRANS_DELETE || !@to) { - pop @to while $#to and $to[$#to] == $to[$#to -1]; - } - my($from, $to); - $from = collapse(@from); - $to = collapse(@to); - $from .= "-" if $delhyphen; - return ($from, $to); -} - -sub tr_chr { - my $x = shift; - if ($x == ord "-") { - return "\\-"; - } else { - return chr $x; - } -} - -# XXX This doesn't yet handle all cases correctly either - -sub tr_decode_utf8 { - my($swash_hv, $flags) = @_; - my %swash = $swash_hv->ARRAY; - my $final = undef; - $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'}; - my $none = $swash{"NONE"}->IV; - my $extra = $none + 1; - my(@from, @delfrom, @to); - my $line; - foreach $line (split /\n/, $swash{'LIST'}->PV) { - my($min, $max, $result) = split(/\t/, $line); - $min = hex $min; - if (length $max) { - $max = hex $max; - } else { - $max = $min; - } - $result = hex $result; - if ($result == $extra) { - push @delfrom, [$min, $max]; - } else { - push @from, [$min, $max]; - push @to, [$result, $result + $max - $min]; - } - } - for my $i (0 .. $#from) { - if ($from[$i][0] == ord '-') { - unshift @from, splice(@from, $i, 1); - unshift @to, splice(@to, $i, 1); - last; - } elsif ($from[$i][1] == ord '-') { - $from[$i][1]--; - $to[$i][1]--; - unshift @from, ord '-'; - unshift @to, ord '-'; - last; - } - } - for my $i (0 .. $#delfrom) { - if ($delfrom[$i][0] == ord '-') { - push @delfrom, splice(@delfrom, $i, 1); - last; - } elsif ($delfrom[$i][1] == ord '-') { - $delfrom[$i][1]--; - push @delfrom, ord '-'; - last; - } - } - if (defined $final and $to[$#to][1] != $final) { - push @to, [$final, $final]; - } - push @from, @delfrom; - if ($flags & OPpTRANS_COMPLEMENT) { - my @newfrom; - my $next = 0; - for my $i (0 .. $#from) { - push @newfrom, [$next, $from[$i][0] - 1]; - $next = $from[$i][1] + 1; - } - @from = (); - for my $range (@newfrom) { - if ($range->[0] <= $range->[1]) { - push @from, $range; - } - } - } - my($from, $to, $diff); - for my $chunk (@from) { - $diff = $chunk->[1] - $chunk->[0]; - if ($diff > 1) { - $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]); - } elsif ($diff == 1) { - $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]); - } else { - $from .= tr_chr($chunk->[0]); - } - } - for my $chunk (@to) { - $diff = $chunk->[1] - $chunk->[0]; - if ($diff > 1) { - $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]); - } elsif ($diff == 1) { - $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]); - } else { - $to .= tr_chr($chunk->[0]); - } - } - #$final = sprintf("%04x", $final) if defined $final; - #$none = sprintf("%04x", $none) if defined $none; - #$extra = sprintf("%04x", $extra) if defined $extra; - #print STDERR "final: $final\n none: $none\nextra: $extra\n"; - #print STDERR $swash{'LIST'}->PV; - return (escape_str($from), escape_str($to)); -} - -sub pp_trans { - my $self = shift; - my($op, $cx) = @_; - my($from, $to); - if (class($op) eq "PVOP") { - ($from, $to) = tr_decode_byte($op->pv, $op->private); - } else { # class($op) eq "SVOP" - ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private); - } - my $flags = ""; - $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT; - $flags .= "d" if $op->private & OPpTRANS_DELETE; - $to = "" if $from eq $to and $flags eq ""; - $flags .= "s" if $op->private & OPpTRANS_SQUASH; - return "tr" . double_delim($from, $to) . $flags; -} - -# Like dq(), but different -sub re_dq { - my $self = shift; - my $op = shift; - my $type = $op->name; - if ($type eq "const") { - return re_uninterp($self->const_sv($op)->PV); - } elsif ($type eq "concat") { - my $first = $self->re_dq($op->first); - my $last = $self->re_dq($op->last); - # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]" - if ($last =~ /^[{\[\w]/) { - $first =~ s/([%\$@])([A-Za-z_]\w*)$/${1}{$2}/; - } - return $first . $last; - } elsif ($type eq "uc") { - return '\U' . $self->re_dq($op->first->sibling) . '\E'; - } elsif ($type eq "lc") { - return '\L' . $self->re_dq($op->first->sibling) . '\E'; - } elsif ($type eq "ucfirst") { - return '\u' . $self->re_dq($op->first->sibling); - } elsif ($type eq "lcfirst") { - return '\l' . $self->re_dq($op->first->sibling); - } elsif ($type eq "quotemeta") { - return '\Q' . $self->re_dq($op->first->sibling) . '\E'; - } elsif ($type eq "join") { - return $self->deparse($op->last, 26); # was join($", @ary) - } else { - return $self->deparse($op, 26); - } -} - -sub pp_regcomp { - my $self = shift; - my($op, $cx) = @_; - my $kid = $op->first; - $kid = $kid->first if $kid->name eq "regcmaybe"; - $kid = $kid->first if $kid->name eq "regcreset"; - return $self->re_dq($kid); -} - -# osmic acid -- see osmium tetroxide - -my %matchwords; -map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs', - 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic', - 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi'); - -sub matchop { - my $self = shift; - my($op, $cx, $name, $delim) = @_; - my $kid = $op->first; - my ($binop, $var, $re) = ("", "", ""); - if ($op->flags & OPf_STACKED) { - $binop = 1; - $var = $self->deparse($kid, 20); - $kid = $kid->sibling; - } - if (null $kid) { - $re = re_uninterp(escape_str($op->precomp)); - } else { - $re = $self->deparse($kid, 1); - } - my $flags = ""; - $flags .= "c" if $op->pmflags & PMf_CONTINUE; - $flags .= "g" if $op->pmflags & PMf_GLOBAL; - $flags .= "i" if $op->pmflags & PMf_FOLD; - $flags .= "m" if $op->pmflags & PMf_MULTILINE; - $flags .= "o" if $op->pmflags & PMf_KEEP; - $flags .= "s" if $op->pmflags & PMf_SINGLELINE; - $flags .= "x" if $op->pmflags & PMf_EXTENDED; - $flags = $matchwords{$flags} if $matchwords{$flags}; - if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here - $re =~ s/\?/\\?/g; - $re = "?$re?"; - } else { - $re = single_delim($name, $delim, $re); - } - $re = $re . $flags; - if ($binop) { - return $self->maybe_parens("$var =~ $re", $cx, 20); - } else { - return $re; - } -} - -sub pp_match { matchop(@_, "m", "/") } -sub pp_pushre { matchop(@_, "m", "/") } -sub pp_qr { matchop(@_, "qr", "") } - -sub pp_split { - my $self = shift; - my($op, $cx) = @_; - my($kid, @exprs, $ary, $expr); - $kid = $op->first; - if ($ {$kid->pmreplroot}) { - $ary = '@' . $self->gv_name($kid->pmreplroot); - } - for (; !null($kid); $kid = $kid->sibling) { - push @exprs, $self->deparse($kid, 6); - } - $expr = "split(" . join(", ", @exprs) . ")"; - if ($ary) { - return $self->maybe_parens("$ary = $expr", $cx, 7); - } else { - return $expr; - } -} - -# oxime -- any of various compounds obtained chiefly by the action of -# hydroxylamine on aldehydes and ketones and characterized by the -# bivalent grouping C=NOH [Webster's Tenth] - -my %substwords; -map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em', - 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me', - 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem', - 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi'); - -sub pp_subst { - my $self = shift; - my($op, $cx) = @_; - my $kid = $op->first; - my($binop, $var, $re, $repl) = ("", "", "", ""); - if ($op->flags & OPf_STACKED) { - $binop = 1; - $var = $self->deparse($kid, 20); - $kid = $kid->sibling; - } - my $flags = ""; - if (null($op->pmreplroot)) { - $repl = $self->dq($kid); - $kid = $kid->sibling; - } else { - $repl = $op->pmreplroot->first; # skip substcont - while ($repl->name eq "entereval") { - $repl = $repl->first; - $flags .= "e"; - } - if ($op->pmflags & PMf_EVAL) { - $repl = $self->deparse($repl, 0); - } else { - $repl = $self->dq($repl); - } - } - if (null $kid) { - $re = re_uninterp(escape_str($op->precomp)); - } else { - $re = $self->deparse($kid, 1); - } - $flags .= "e" if $op->pmflags & PMf_EVAL; - $flags .= "g" if $op->pmflags & PMf_GLOBAL; - $flags .= "i" if $op->pmflags & PMf_FOLD; - $flags .= "m" if $op->pmflags & PMf_MULTILINE; - $flags .= "o" if $op->pmflags & PMf_KEEP; - $flags .= "s" if $op->pmflags & PMf_SINGLELINE; - $flags .= "x" if $op->pmflags & PMf_EXTENDED; - $flags = $substwords{$flags} if $substwords{$flags}; - if ($binop) { - return $self->maybe_parens("$var =~ s" - . double_delim($re, $repl) . $flags, - $cx, 20); - } else { - return "s". double_delim($re, $repl) . $flags; - } -} - -1; -__END__ - -=head1 NAME - -B::Deparse - Perl compiler backend to produce perl code - -=head1 SYNOPSIS - -B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>] - [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl> - -=head1 DESCRIPTION - -B::Deparse is a backend module for the Perl compiler that generates -perl source code, based on the internal compiled structure that perl -itself creates after parsing a program. The output of B::Deparse won't -be exactly the same as the original source, since perl doesn't keep -track of comments or whitespace, and there isn't a one-to-one -correspondence between perl's syntactical constructions and their -compiled form, but it will often be close. When you use the B<-p> -option, the output also includes parentheses even when they are not -required by precedence, which can make it easy to see if perl is -parsing your expressions the way you intended. - -Please note that this module is mainly new and untested code and is -still under development, so it may change in the future. - -=head1 OPTIONS - -As with all compiler backend options, these must follow directly after -the '-MO=Deparse', separated by a comma but not any white space. - -=over 4 - -=item B<-l> - -Add '#line' declarations to the output based on the line and file -locations of the original code. - -=item B<-p> - -Print extra parentheses. Without this option, B::Deparse includes -parentheses in its output only when they are needed, based on the -structure of your program. With B<-p>, it uses parentheses (almost) -whenever they would be legal. This can be useful if you are used to -LISP, or if you want to see how perl parses your input. If you say - - if ($var & 0x7f == 65) {print "Gimme an A!"} - print ($which ? $a : $b), "\n"; - $name = $ENV{USER} or "Bob"; - -C<B::Deparse,-p> will print - - if (($var & 0)) { - print('Gimme an A!') - }; - (print(($which ? $a : $b)), '???'); - (($name = $ENV{'USER'}) or '???') - -which probably isn't what you intended (the C<'???'> is a sign that -perl optimized away a constant value). - -=item B<-q> - -Expand double-quoted strings into the corresponding combinations of -concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For -instance, print - - print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!"; - -as - - print 'Hello, ' . $world . ', ' . join($", @ladies) . ', ' - . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!'); - -Note that the expanded form represents the way perl handles such -constructions internally -- this option actually turns off the reverse -translation that B::Deparse usually does. On the other hand, note that -C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value -of $y into a string before doing the assignment. - -=item B<-u>I<PACKAGE> - -Normally, B::Deparse deparses the main code of a program, all the subs -called by the main program (and all the subs called by them, -recursively), and any other subs in the main:: package. To include -subs in other packages that aren't called directly, such as AUTOLOAD, -DESTROY, other subs called automatically by perl, and methods (which -aren't resolved to subs until runtime), use the B<-u> option. The -argument to B<-u> is the name of a package, and should follow directly -after the 'u'. Multiple B<-u> options may be given, separated by -commas. Note that unlike some other backends, B::Deparse doesn't -(yet) try to guess automatically when B<-u> is needed -- you must -invoke it yourself. - -=item B<-s>I<LETTERS> - -Tweak the style of B::Deparse's output. The letters should follow -directly after the 's', with no space or punctuation. The following -options are available: - -=over 4 - -=item B<C> - -Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print - - if (...) { - ... - } else { - ... - } - -instead of - - if (...) { - ... - } - else { - ... - } - -The default is not to cuddle. - -=item B<i>I<NUMBER> - -Indent lines by multiples of I<NUMBER> columns. The default is 4 columns. - -=item B<T> - -Use tabs for each 8 columns of indent. The default is to use only spaces. -For instance, if the style options are B<-si4T>, a line that's indented -3 times will be preceded by one tab and four spaces; if the options were -B<-si8T>, the same line would be preceded by three tabs. - -=item B<v>I<STRING>B<.> - -Print I<STRING> for the value of a constant that can't be determined -because it was optimized away (mnemonic: this happens when a constant -is used in B<v>oid context). The end of the string is marked by a period. -The string should be a valid perl expression, generally a constant. -Note that unless it's a number, it probably needs to be quoted, and on -a command line quotes need to be protected from the shell. Some -conventional values include 0, 1, 42, '', 'foo', and -'Useless use of constant omitted' (which may need to be -B<-sv"'Useless use of constant omitted'."> -or something similar depending on your shell). The default is '???'. -If you're using B::Deparse on a module or other file that's require'd, -you shouldn't use a value that evaluates to false, since the customary -true constant at the end of a module will be in void context when the -file is compiled as a main program. - -=back - -=item B<-x>I<LEVEL> - -Expand conventional syntax constructions into equivalent ones that expose -their internal operation. I<LEVEL> should be a digit, with higher values -meaning more expansion. As with B<-q>, this actually involves turning off -special cases in B::Deparse's normal operations. - -If I<LEVEL> is at least 3, for loops will be translated into equivalent -while loops with continue blocks; for instance - - for ($i = 0; $i < 10; ++$i) { - print $i; - } - -turns into - - $i = 0; - while ($i < 10) { - print $i; - } continue { - ++$i - } - -Note that in a few cases this translation can't be perfectly carried back -into the source code -- if the loop's initializer declares a my variable, -for instance, it won't have the correct scope outside of the loop. - -If I<LEVEL> is at least 7, if statements will be translated into equivalent -expressions using C<&&>, C<?:> and C<do {}>; for instance - - print 'hi' if $nice; - if ($nice) { - print 'hi'; - } - if ($nice) { - print 'hi'; - } else { - print 'bye'; - } - -turns into - - $nice and print 'hi'; - $nice and do { print 'hi' }; - $nice ? do { print 'hi' } : do { print 'bye' }; - -Long sequences of elsifs will turn into nested ternary operators, which -B::Deparse doesn't know how to indent nicely. - -=back - -=head1 USING B::Deparse AS A MODULE - -=head2 Synopsis - - use B::Deparse; - $deparse = B::Deparse->new("-p", "-sC"); - $body = $deparse->coderef2text(\&func); - eval "sub func $body"; # the inverse operation - -=head2 Description - -B::Deparse can also be used on a sub-by-sub basis from other perl -programs. - -=head2 new - - $deparse = B::Deparse->new(OPTIONS) - -Create an object to store the state of a deparsing operation and any -options. The options are the same as those that can be given on the -command line (see L</OPTIONS>); options that are separated by commas -after B<-MO=Deparse> should be given as separate strings. Some -options, like B<-u>, don't make sense for a single subroutine, so -don't pass them. - -=head2 coderef2text - - $body = $deparse->coderef2text(\&func) - $body = $deparse->coderef2text(sub ($$) { ... }) - -Return source code for the body of a subroutine (a block, optionally -preceded by a prototype in parens), given a reference to the -sub. Because a subroutine can have no names, or more than one name, -this method doesn't return a complete subroutine definition -- if you -want to eval the result, you should prepend "sub subname ", or "sub " -for an anonymous function constructor. Unless the sub was defined in -the main:: package, the code will include a package declaration. - -=head1 BUGS - -See the 'to do' list at the beginning of the module file. - -=head1 AUTHOR - -Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier -version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with -contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van -der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons. - -=cut diff --git a/contrib/perl5/ext/B/B/Disassembler.pm b/contrib/perl5/ext/B/B/Disassembler.pm deleted file mode 100644 index 212532b..0000000 --- a/contrib/perl5/ext/B/B/Disassembler.pm +++ /dev/null @@ -1,185 +0,0 @@ -# Disassembler.pm -# -# Copyright (c) 1996 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. -package B::Disassembler::BytecodeStream; -use FileHandle; -use Carp; -use B qw(cstring cast_I32); -@ISA = qw(FileHandle); -sub readn { - my ($fh, $len) = @_; - my $data; - read($fh, $data, $len); - croak "reached EOF while reading $len bytes" unless length($data) == $len; - return $data; -} - -sub GET_U8 { - my $fh = shift; - my $c = $fh->getc; - croak "reached EOF while reading U8" unless defined($c); - return ord($c); -} - -sub GET_U16 { - my $fh = shift; - my $str = $fh->readn(2); - croak "reached EOF while reading U16" unless length($str) == 2; - 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); - croak "reached EOF while reading U32" unless length($str) == 4; - return unpack("N", $str); -} - -sub GET_I32 { - my $fh = shift; - my $str = $fh->readn(4); - croak "reached EOF while reading I32" unless length($str) == 4; - return cast_I32(unpack("N", $str)); -} - -sub GET_objindex { - my $fh = shift; - my $str = $fh->readn(4); - croak "reached EOF while reading objindex" unless length($str) == 4; - return unpack("N", $str); -} - -sub GET_opindex { - my $fh = shift; - my $str = $fh->readn(4); - croak "reached EOF while reading opindex" unless length($str) == 4; - return unpack("N", $str); -} - -sub GET_svindex { - my $fh = shift; - my $str = $fh->readn(4); - croak "reached EOF while reading svindex" unless length($str) == 4; - return unpack("N", $str); -} - -sub GET_strconst { - my $fh = shift; - my ($str, $c); - while (defined($c = $fh->getc) && $c ne "\0") { - $str .= $c; - } - croak "reached EOF while reading strconst" unless defined($c); - return cstring($str); -} - -sub GET_pvcontents {} - -sub GET_PV { - my $fh = shift; - my $str; - my $len = $fh->GET_U32; - if ($len) { - read($fh, $str, $len); - croak "reached EOF while reading PV" unless length($str) == $len; - return cstring($str); - } else { - return '""'; - } -} - -sub GET_comment_t { - my $fh = shift; - my ($str, $c); - while (defined($c = $fh->getc) && $c ne "\n") { - $str .= $c; - } - croak "reached EOF while reading comment" unless defined($c); - return cstring($str); -} - -sub GET_double { - my $fh = shift; - my ($str, $c); - while (defined($c = $fh->getc) && $c ne "\0") { - $str .= $c; - } - croak "reached EOF while reading double" unless defined($c); - return $str; -} - -sub GET_none {} - -sub GET_op_tr_array { - my $fh = shift; - my @ary = unpack("n256", $fh->readn(256 * 2)); - return join(",", @ary); -} - -sub GET_IV64 { - my $fh = shift; - my ($hi, $lo) = unpack("NN", $fh->readn(8)); - return sprintf("0x%4x%04x", $hi, $lo); # cheat -} - -package B::Disassembler; -use Exporter; -@ISA = qw(Exporter); -@EXPORT_OK = qw(disassemble_fh); -use Carp; -use strict; - -use B::Asmdata qw(%insn_data @insn_name); - -sub disassemble_fh { - my ($fh, $out) = @_; - my ($c, $getmeth, $insn, $arg); - bless $fh, "B::Disassembler::BytecodeStream"; - while (defined($c = $fh->getc)) { - $c = ord($c); - $insn = $insn_name[$c]; - if (!defined($insn) || $insn eq "unused") { - my $pos = $fh->tell - 1; - die "Illegal instruction code $c at stream offset $pos\n"; - } - $getmeth = $insn_data{$insn}->[2]; - $arg = $fh->$getmeth(); - if (defined($arg)) { - &$out($insn, $arg); - } else { - &$out($insn); - } - } -} - -1; - -__END__ - -=head1 NAME - -B::Disassembler - Disassemble Perl bytecode - -=head1 SYNOPSIS - - use Disassembler; - -=head1 DESCRIPTION - -See F<ext/B/B/Disassembler.pm>. - -=head1 AUTHOR - -Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> - -=cut diff --git a/contrib/perl5/ext/B/B/Lint.pm b/contrib/perl5/ext/B/B/Lint.pm deleted file mode 100644 index 094b3cf..0000000 --- a/contrib/perl5/ext/B/B/Lint.pm +++ /dev/null @@ -1,362 +0,0 @@ -package B::Lint; - -=head1 NAME - -B::Lint - Perl lint - -=head1 SYNOPSIS - -perl -MO=Lint[,OPTIONS] foo.pl - -=head1 DESCRIPTION - -The B::Lint module is equivalent to an extended version of the B<-w> -option of B<perl>. It is named after the program B<lint> which carries -out a similar process for C programs. - -=head1 OPTIONS AND LINT CHECKS - -Option words are separated by commas (not whitespace) and follow the -usual conventions of compiler backend options. Following any options -(indicated by a leading B<->) come lint check arguments. Each such -argument (apart from the special B<all> and B<none> options) is a -word representing one possible lint check (turning on that check) or -is B<no-foo> (turning off that check). Before processing the check -arguments, a standard list of checks is turned on. Later options -override earlier ones. Available options are: - -=over 8 - -=item B<context> - -Produces a warning whenever an array is used in an implicit scalar -context. For example, both of the lines - - $foo = length(@bar); - $foo = @bar; -will elicit a warning. Using an explicit B<scalar()> silences the -warning. For example, - - $foo = scalar(@bar); - -=item B<implicit-read> and B<implicit-write> - -These options produce a warning whenever an operation implicitly -reads or (respectively) writes to one of Perl's special variables. -For example, B<implicit-read> will warn about these: - - /foo/; - -and B<implicit-write> will warn about these: - - s/foo/bar/; - -Both B<implicit-read> and B<implicit-write> warn about this: - - for (@a) { ... } - -=item B<dollar-underscore> - -This option warns whenever $_ is used either explicitly anywhere or -as the implicit argument of a B<print> statement. - -=item B<private-names> - -This option warns on each use of any variable, subroutine or -method name that lives in a non-current package but begins with -an underscore ("_"). Warnings aren't issued for the special case -of the single character name "_" by itself (e.g. $_ and @_). - -=item B<undefined-subs> - -This option warns whenever an undefined subroutine is invoked. -This option will only catch explicitly invoked subroutines such -as C<foo()> and not indirect invocations such as C<&$subref()> -or C<$obj-E<gt>meth()>. Note that some programs or modules delay -definition of subs until runtime by means of the AUTOLOAD -mechanism. - -=item B<regexp-variables> - -This option warns whenever one of the regexp variables $', $& or -$' is used. Any occurrence of any of these variables in your -program can slow your whole program down. See L<perlre> for -details. - -=item B<all> - -Turn all warnings on. - -=item B<none> - -Turn all warnings off. - -=back - -=head1 NON LINT-CHECK OPTIONS - -=over 8 - -=item B<-u Package> - -Normally, Lint only checks the main code of the program together -with all subs defined in package main. The B<-u> option lets you -include other package names whose subs are then checked by Lint. - -=back - -=head1 BUGS - -This is only a very preliminary version. - -=head1 AUTHOR - -Malcolm Beattie, mbeattie@sable.ox.ac.uk. - -=cut - -use strict; -use B qw(walkoptree main_root walksymtable svref_2object parents - OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY - ); - -my $file = "unknown"; # shadows current filename -my $line = 0; # shadows current line number -my $curstash = "main"; # shadows current stash - -# Lint checks -my %check; -my %implies_ok_context; -BEGIN { - map($implies_ok_context{$_}++, - qw(scalar av2arylen aelem aslice helem hslice - keys values hslice defined undef delete)); -} - -# Lint checks turned on by default -my @default_checks = qw(context); - -my %valid_check; -# All valid checks -BEGIN { - map($valid_check{$_}++, - qw(context implicit_read implicit_write dollar_underscore - private_names undefined_subs regexp_variables)); -} - -# Debugging options -my ($debug_op); - -my %done_cv; # used to mark which subs have already been linted -my @extra_packages; # Lint checks mainline code and all subs which are - # in main:: or in one of these packages. - -sub warning { - my $format = (@_ < 2) ? "%s" : shift; - warn sprintf("$format at %s line %d\n", @_, $file, $line); -} - -# This gimme can't cope with context that's only determined -# at runtime via dowantarray(). -sub gimme { - my $op = shift; - my $flags = $op->flags; - if ($flags & OPf_WANT) { - return(($flags & OPf_WANT_LIST) ? 1 : 0); - } - return undef; -} - -sub B::OP::lint {} - -sub B::COP::lint { - my $op = shift; - if ($op->name eq "nextstate") { - $file = $op->file; - $line = $op->line; - $curstash = $op->stash->NAME; - } -} - -sub B::UNOP::lint { - my $op = shift; - my $opname = $op->name; - if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) { - my $parent = parents->[0]; - my $pname = $parent->name; - return if gimme($op) || $implies_ok_context{$pname}; - # Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}" - # null out the parent so we have to check for a parent of pp_null and - # a grandparent of pp_enteriter or pp_delete - if ($pname eq "null") { - my $gpname = parents->[1]->name; - return if $gpname eq "enteriter" || $gpname eq "delete"; - } - warning("Implicit scalar context for %s in %s", - $opname eq "rv2av" ? "array" : "hash", $parent->desc); - } - if ($check{private_names} && $opname eq "method") { - my $methop = $op->first; - if ($methop->name eq "const") { - my $method = $methop->sv->PV; - if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) { - warning("Illegal reference to private method name $method"); - } - } - } -} - -sub B::PMOP::lint { - my $op = shift; - if ($check{implicit_read}) { - if ($op->name eq "match" && !($op->flags & OPf_STACKED)) { - warning('Implicit match on $_'); - } - } - if ($check{implicit_write}) { - if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) { - warning('Implicit substitution on $_'); - } - } -} - -sub B::LOOP::lint { - my $op = shift; - if ($check{implicit_read} || $check{implicit_write}) { - if ($op->name eq "enteriter") { - my $last = $op->last; - if ($last->name eq "gv" && $last->gv->NAME eq "_") { - warning('Implicit use of $_ in foreach'); - } - } - } -} - -sub B::SVOP::lint { - my $op = shift; - if ($check{dollar_underscore} && $op->name eq "gvsv" - && $op->gv->NAME eq "_") - { - warning('Use of $_'); - } - if ($check{private_names}) { - my $opname = $op->name; - if ($opname eq "gv" || $opname eq "gvsv") { - my $gv = $op->gv; - if ($gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) { - warning('Illegal reference to private name %s', $gv->NAME); - } - } - } - if ($check{undefined_subs}) { - if ($op->name eq "gv" - && $op->next->name eq "entersub") - { - my $gv = $op->gv; - my $subname = $gv->STASH->NAME . "::" . $gv->NAME; - no strict 'refs'; - if (!defined(&$subname)) { - $subname =~ s/^main:://; - warning('Undefined subroutine %s called', $subname); - } - } - } - if ($check{regexp_variables} && $op->name eq "gvsv") { - my $name = $op->gv->NAME; - if ($name =~ /^[&'`]$/) { - warning('Use of regexp variable $%s', $name); - } - } -} - -sub B::GV::lintcv { - my $gv = shift; - my $cv = $gv->CV; - #warn sprintf("lintcv: %s::%s (done=%d)\n", - # $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug - return if !$$cv || $done_cv{$$cv}++; - my $root = $cv->ROOT; - #warn " root = $root (0x$$root)\n";#debug - walkoptree($root, "lint") if $$root; -} - -sub do_lint { - my %search_pack; - walkoptree(main_root, "lint") if ${main_root()}; - - # Now do subs in main - no strict qw(vars refs); - my $sym; - local(*glob); - while (($sym, *glob) = each %{"main::"}) { - #warn "Trying $sym\n";#debug - svref_2object(\*glob)->EGV->lintcv unless $sym =~ /::$/; - } - - # Now do subs in non-main packages given by -u options - map { $search_pack{$_} = 1 } @extra_packages; - walksymtable(\%{"main::"}, "lintcv", sub { - my $package = shift; - $package =~ s/::$//; - #warn "Considering $package\n";#debug - return exists $search_pack{$package}; - }); -} - -sub compile { - my @options = @_; - my ($option, $opt, $arg); - # Turn on default lint checks - for $opt (@default_checks) { - $check{$opt} = 1; - } - OPTION: - while ($option = shift @options) { - if ($option =~ /^-(.)(.*)/) { - $opt = $1; - $arg = $2; - } else { - unshift @options, $option; - last OPTION; - } - if ($opt eq "-" && $arg eq "-") { - shift @options; - last OPTION; - } elsif ($opt eq "D") { - $arg ||= shift @options; - foreach $arg (split(//, $arg)) { - if ($arg eq "o") { - B->debug(1); - } elsif ($arg eq "O") { - $debug_op = 1; - } - } - } elsif ($opt eq "u") { - $arg ||= shift @options; - push(@extra_packages, $arg); - } - } - foreach $opt (@default_checks, @options) { - $opt =~ tr/-/_/; - if ($opt eq "all") { - %check = %valid_check; - } - elsif ($opt eq "none") { - %check = (); - } - else { - if ($opt =~ s/^no-//) { - $check{$opt} = 0; - } - else { - $check{$opt} = 1; - } - warn "No such check: $opt\n" unless defined $valid_check{$opt}; - } - } - # Remaining arguments are things to check - - return \&do_lint; -} - -1; diff --git a/contrib/perl5/ext/B/B/Showlex.pm b/contrib/perl5/ext/B/B/Showlex.pm deleted file mode 100644 index 842ca3e..0000000 --- a/contrib/perl5/ext/B/B/Showlex.pm +++ /dev/null @@ -1,97 +0,0 @@ -package B::Showlex; -use strict; -use B qw(svref_2object comppadlist class); -use B::Terse (); - -# -# Invoke as -# perl -MO=Showlex,foo bar.pl -# to see the names of lexical variables used by &foo -# or as -# perl -MO=Showlex bar.pl -# to see the names of file scope lexicals used by bar.pl -# - -sub shownamearray { - my ($name, $av) = @_; - my @els = $av->ARRAY; - my $count = @els; - my $i; - print "$name has $count entries\n"; - for ($i = 0; $i < $count; $i++) { - print "$i: "; - my $sv = $els[$i]; - if (class($sv) ne "SPECIAL") { - printf "%s (0x%lx) %s\n", class($sv), $$sv, $sv->PVX; - } else { - $sv->terse; - } - } -} - -sub showvaluearray { - my ($name, $av) = @_; - my @els = $av->ARRAY; - my $count = @els; - my $i; - print "$name has $count entries\n"; - for ($i = 0; $i < $count; $i++) { - print "$i: "; - $els[$i]->terse; - } -} - -sub showlex { - my ($objname, $namesav, $valsav) = @_; - shownamearray("Pad of lexical names for $objname", $namesav); - showvaluearray("Pad of lexical values for $objname", $valsav); -} - -sub showlex_obj { - my ($objname, $obj) = @_; - $objname =~ s/^&main::/&/; - showlex($objname, svref_2object($obj)->PADLIST->ARRAY); -} - -sub showlex_main { - showlex("comppadlist", comppadlist->ARRAY); -} - -sub compile { - my @options = @_; - if (@options) { - return sub { - my $objname; - foreach $objname (@options) { - $objname = "main::$objname" unless $objname =~ /::/; - eval "showlex_obj('&$objname', \\&$objname)"; - } - } - } else { - return \&showlex_main; - } -} - -1; - -__END__ - -=head1 NAME - -B::Showlex - Show lexical variables used in functions or files - -=head1 SYNOPSIS - - perl -MO=Showlex[,SUBROUTINE] foo.pl - -=head1 DESCRIPTION - -When a subroutine name is provided in OPTIONS, prints the lexical -variables used in that subroutine. Otherwise, prints the file-scope -lexicals in the file. - -=head1 AUTHOR - -Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> - -=cut diff --git a/contrib/perl5/ext/B/B/Stackobj.pm b/contrib/perl5/ext/B/B/Stackobj.pm deleted file mode 100644 index 0db3e33..0000000 --- a/contrib/perl5/ext/B/B/Stackobj.pm +++ /dev/null @@ -1,346 +0,0 @@ -# Stackobj.pm -# -# Copyright (c) 1996 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. -# -package B::Stackobj; -use Exporter (); -@ISA = qw(Exporter); -@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT VALID_UNSIGNED - VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY); -%EXPORT_TAGS = (types => [qw(T_UNKNOWN T_DOUBLE T_INT)], - flags => [qw(VALID_INT VALID_DOUBLE VALID_SV - VALID_UNSIGNED REGISTER TEMPORARY)]); - -use Carp qw(confess); -use strict; -use B qw(class SVf_IOK SVf_NOK SVf_IVisUV); - -# Types -sub T_UNKNOWN () { 0 } -sub T_DOUBLE () { 1 } -sub T_INT () { 2 } -sub T_SPECIAL () { 3 } - -# Flags -sub VALID_INT () { 0x01 } -sub VALID_UNSIGNED () { 0x02 } -sub VALID_DOUBLE () { 0x04 } -sub VALID_SV () { 0x08 } -sub REGISTER () { 0x10 } # no implicit write-back when calling subs -sub TEMPORARY () { 0x20 } # no implicit write-back needed at all -sub SAVE_INT () { 0x40 } #if int part needs to be saved at all -sub SAVE_DOUBLE () { 0x80 } #if double part needs to be saved at all - - -# -# Callback for runtime code generation -# -my $runtime_callback = sub { confess "set_callback not yet called" }; -sub set_callback (&) { $runtime_callback = shift } -sub runtime { &$runtime_callback(@_) } - -# -# Methods -# - -sub write_back { confess "stack object does not implement write_back" } - -sub invalidate { shift->{flags} &= ~(VALID_INT |VALID_UNSIGNED | VALID_DOUBLE) } - -sub as_sv { - my $obj = shift; - if (!($obj->{flags} & VALID_SV)) { - $obj->write_back; - $obj->{flags} |= VALID_SV; - } - return $obj->{sv}; -} - -sub as_int { - my $obj = shift; - if (!($obj->{flags} & VALID_INT)) { - $obj->load_int; - $obj->{flags} |= VALID_INT|SAVE_INT; - } - return $obj->{iv}; -} - -sub as_double { - my $obj = shift; - if (!($obj->{flags} & VALID_DOUBLE)) { - $obj->load_double; - $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE; - } - return $obj->{nv}; -} - -sub as_numeric { - my $obj = shift; - return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double; -} - -sub as_bool { - my $obj=shift; - if ($obj->{flags} & VALID_INT ){ - return $obj->{iv}; - } - if ($obj->{flags} & VALID_DOUBLE ){ - return $obj->{nv}; - } - return sprintf("(SvTRUE(%s))", $obj->as_sv) ; -} - -# -# Debugging methods -# -sub peek { - my $obj = shift; - my $type = $obj->{type}; - my $flags = $obj->{flags}; - my @flags; - if ($type == T_UNKNOWN) { - $type = "T_UNKNOWN"; - } elsif ($type == T_INT) { - $type = "T_INT"; - } elsif ($type == T_DOUBLE) { - $type = "T_DOUBLE"; - } else { - $type = "(illegal type $type)"; - } - push(@flags, "VALID_INT") if $flags & VALID_INT; - push(@flags, "VALID_DOUBLE") if $flags & VALID_DOUBLE; - push(@flags, "VALID_SV") if $flags & VALID_SV; - push(@flags, "REGISTER") if $flags & REGISTER; - push(@flags, "TEMPORARY") if $flags & TEMPORARY; - @flags = ("none") unless @flags; - return sprintf("%s type=$type flags=%s sv=$obj->{sv}", - class($obj), join("|", @flags)); -} - -sub minipeek { - my $obj = shift; - my $type = $obj->{type}; - my $flags = $obj->{flags}; - if ($type == T_INT || $flags & VALID_INT) { - return $obj->{iv}; - } elsif ($type == T_DOUBLE || $flags & VALID_DOUBLE) { - return $obj->{nv}; - } else { - return $obj->{sv}; - } -} - -# -# Caller needs to ensure that set_int, set_double, -# set_numeric and set_sv are only invoked on legal lvalues. -# -sub set_int { - my ($obj, $expr,$unsigned) = @_; - runtime("$obj->{iv} = $expr;"); - $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE); - $obj->{flags} |= VALID_INT|SAVE_INT; - $obj->{flags} |= VALID_UNSIGNED if $unsigned; -} - -sub set_double { - my ($obj, $expr) = @_; - runtime("$obj->{nv} = $expr;"); - $obj->{flags} &= ~(VALID_SV | VALID_INT); - $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE; -} - -sub set_numeric { - my ($obj, $expr) = @_; - if ($obj->{type} == T_INT) { - $obj->set_int($expr); - } else { - $obj->set_double($expr); - } -} - -sub set_sv { - my ($obj, $expr) = @_; - runtime("SvSetSV($obj->{sv}, $expr);"); - $obj->invalidate; - $obj->{flags} |= VALID_SV; -} - -# -# Stackobj::Padsv -# - -@B::Stackobj::Padsv::ISA = 'B::Stackobj'; -sub B::Stackobj::Padsv::new { - my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_; - $extra_flags |= SAVE_INT if $extra_flags & VALID_INT; - $extra_flags |= SAVE_DOUBLE if $extra_flags & VALID_DOUBLE; - bless { - type => $type, - flags => VALID_SV | $extra_flags, - sv => "PL_curpad[$ix]", - iv => "$iname", - nv => "$dname" - }, $class; -} - -sub B::Stackobj::Padsv::load_int { - my $obj = shift; - if ($obj->{flags} & VALID_DOUBLE) { - runtime("$obj->{iv} = $obj->{nv};"); - } else { - runtime("$obj->{iv} = SvIV($obj->{sv});"); - } - $obj->{flags} |= VALID_INT|SAVE_INT; -} - -sub B::Stackobj::Padsv::load_double { - my $obj = shift; - $obj->write_back; - runtime("$obj->{nv} = SvNV($obj->{sv});"); - $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE; -} -sub B::Stackobj::Padsv::save_int { - my $obj = shift; - return $obj->{flags} & SAVE_INT; -} - -sub B::Stackobj::Padsv::save_double { - my $obj = shift; - return $obj->{flags} & SAVE_DOUBLE; -} - -sub B::Stackobj::Padsv::write_back { - my $obj = shift; - my $flags = $obj->{flags}; - return if $flags & VALID_SV; - if ($flags & VALID_INT) { - if ($flags & VALID_UNSIGNED ){ - runtime("sv_setuv($obj->{sv}, $obj->{iv});"); - }else{ - runtime("sv_setiv($obj->{sv}, $obj->{iv});"); - } - } elsif ($flags & VALID_DOUBLE) { - runtime("sv_setnv($obj->{sv}, $obj->{nv});"); - } else { - confess "write_back failed for lexical @{[$obj->peek]}\n"; - } - $obj->{flags} |= VALID_SV; -} - -# -# Stackobj::Const -# - -@B::Stackobj::Const::ISA = 'B::Stackobj'; -sub B::Stackobj::Const::new { - my ($class, $sv) = @_; - my $obj = bless { - flags => 0, - sv => $sv # holds the SV object until write_back happens - }, $class; - if ( ref($sv) eq "B::SPECIAL" ){ - $obj->{type}= T_SPECIAL; - }else{ - my $svflags = $sv->FLAGS; - if ($svflags & SVf_IOK) { - $obj->{flags} = VALID_INT|VALID_DOUBLE; - $obj->{type} = T_INT; - if ($svflags & SVf_IVisUV){ - $obj->{flags} |= VALID_UNSIGNED; - $obj->{nv} = $obj->{iv} = $sv->UVX; - }else{ - $obj->{nv} = $obj->{iv} = $sv->IV; - } - } elsif ($svflags & SVf_NOK) { - $obj->{flags} = VALID_INT|VALID_DOUBLE; - $obj->{type} = T_DOUBLE; - $obj->{iv} = $obj->{nv} = $sv->NV; - } else { - $obj->{type} = T_UNKNOWN; - } - } - return $obj; -} - -sub B::Stackobj::Const::write_back { - my $obj = shift; - return if $obj->{flags} & VALID_SV; - # Save the SV object and replace $obj->{sv} by its C source code name - $obj->{sv} = $obj->{sv}->save; - $obj->{flags} |= VALID_SV|VALID_INT|VALID_DOUBLE; -} - -sub B::Stackobj::Const::load_int { - my $obj = shift; - if (ref($obj->{sv}) eq "B::RV"){ - $obj->{iv} = int($obj->{sv}->RV->PV); - }else{ - $obj->{iv} = int($obj->{sv}->PV); - } - $obj->{flags} |= VALID_INT; -} - -sub B::Stackobj::Const::load_double { - my $obj = shift; - if (ref($obj->{sv}) eq "B::RV"){ - $obj->{nv} = $obj->{sv}->RV->PV + 0.0; - }else{ - $obj->{nv} = $obj->{sv}->PV + 0.0; - } - $obj->{flags} |= VALID_DOUBLE; -} - -sub B::Stackobj::Const::invalidate {} - -# -# Stackobj::Bool -# - -@B::Stackobj::Bool::ISA = 'B::Stackobj'; -sub B::Stackobj::Bool::new { - my ($class, $preg) = @_; - my $obj = bless { - type => T_INT, - flags => VALID_INT|VALID_DOUBLE, - iv => $$preg, - nv => $$preg, - preg => $preg # this holds our ref to the pseudo-reg - }, $class; - return $obj; -} - -sub B::Stackobj::Bool::write_back { - my $obj = shift; - return if $obj->{flags} & VALID_SV; - $obj->{sv} = "($obj->{iv} ? &PL_sv_yes : &PL_sv_no)"; - $obj->{flags} |= VALID_SV; -} - -# XXX Might want to handle as_double/set_double/load_double? - -sub B::Stackobj::Bool::invalidate {} - -1; - -__END__ - -=head1 NAME - -B::Stackobj - Helper module for CC backend - -=head1 SYNOPSIS - - use B::Stackobj; - -=head1 DESCRIPTION - -See F<ext/B/README>. - -=head1 AUTHOR - -Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> - -=cut diff --git a/contrib/perl5/ext/B/B/Stash.pm b/contrib/perl5/ext/B/B/Stash.pm deleted file mode 100644 index f3a8247..0000000 --- a/contrib/perl5/ext/B/B/Stash.pm +++ /dev/null @@ -1,50 +0,0 @@ -# Stash.pm -- show what stashes are loaded -# vishalb@hotmail.com -package B::Stash; - -=pod - -=head1 NAME - -B::Stash - show what stashes are loaded - -=cut - -BEGIN { %Seen = %INC } - -CHECK { - my @arr=scan($main::{"main::"}); - @arr=map{s/\:\:$//;$_ eq "<none>"?():$_;} @arr; - print "-umain,-u", join (",-u",@arr) ,"\n"; -} -sub scan{ - my $start=shift; - my $prefix=shift; - $prefix = '' unless defined $prefix; - my @return; - foreach my $key ( keys %{$start}){ -# print $prefix,$key,"\n"; - if ($key =~ /::$/){ - unless ($start eq ${$start}{$key} or $key eq "B::" ){ - push @return, $key unless omit($prefix.$key); - foreach my $subscan ( scan(${$start}{$key},$prefix.$key)){ - push @return, "$key".$subscan; - } - } - } - } - return @return; -} -sub omit{ - my $module = shift; - my %omit=("DynaLoader::" => 1 , "XSLoader::" => 1, "CORE::" => 1 , - "CORE::GLOBAL::" => 1, "UNIVERSAL::" => 1 ); - return 1 if $omit{$module}; - if ($module eq "IO::" or $module eq "IO::Handle::"){ - $module =~ s/::/\//g; - return 1 unless $INC{$module}; - } - - return 0; -} -1; diff --git a/contrib/perl5/ext/B/B/Terse.pm b/contrib/perl5/ext/B/B/Terse.pm deleted file mode 100644 index 52f0549..0000000 --- a/contrib/perl5/ext/B/B/Terse.pm +++ /dev/null @@ -1,153 +0,0 @@ -package B::Terse; -use strict; -use B qw(peekop class walkoptree walkoptree_exec walkoptree_slow - main_start main_root cstring svref_2object SVf_IVisUV); -use B::Asmdata qw(@specialsv_name); - -sub terse { - my ($order, $cvref) = @_; - my $cv = svref_2object($cvref); - if ($order eq "exec") { - walkoptree_exec($cv->START, "terse"); - } else { - walkoptree_slow($cv->ROOT, "terse"); - } -} - -sub compile { - my $order = @_ ? shift : ""; - my @options = @_; - B::clearsym(); - if (@options) { - return sub { - my $objname; - foreach $objname (@options) { - $objname = "main::$objname" unless $objname =~ /::/; - eval "terse(\$order, \\&$objname)"; - die "terse($order, \\&$objname) failed: $@" if $@; - } - } - } else { - if ($order eq "exec") { - return sub { walkoptree_exec(main_start, "terse") } - } else { - return sub { walkoptree_slow(main_root, "terse") } - } - } -} - -sub indent { - my $level = @_ ? shift : 0; - return " " x $level; -} - -sub B::OP::terse { - my ($op, $level) = @_; - my $targ = $op->targ; - $targ = ($targ > 0) ? " [$targ]" : ""; - print indent($level), peekop($op), $targ, "\n"; -} - -sub B::SVOP::terse { - my ($op, $level) = @_; - print indent($level), peekop($op), " "; - $op->sv->terse(0); -} - -sub B::PADOP::terse { - my ($op, $level) = @_; - print indent($level), peekop($op), " ", $op->padix, "\n"; -} - -sub B::PMOP::terse { - my ($op, $level) = @_; - my $precomp = $op->precomp; - print indent($level), peekop($op), - defined($precomp) ? " /$precomp/\n" : " (regexp not compiled)\n"; - -} - -sub B::PVOP::terse { - my ($op, $level) = @_; - print indent($level), peekop($op), " ", cstring($op->pv), "\n"; -} - -sub B::COP::terse { - my ($op, $level) = @_; - my $label = $op->label; - if ($label) { - $label = " label ".cstring($label); - } - print indent($level), peekop($op), $label || "", "\n"; -} - -sub B::PV::terse { - my ($sv, $level) = @_; - print indent($level); - printf "%s (0x%lx) %s\n", class($sv), $$sv, cstring($sv->PV); -} - -sub B::AV::terse { - my ($sv, $level) = @_; - print indent($level); - printf "%s (0x%lx) FILL %d\n", class($sv), $$sv, $sv->FILL; -} - -sub B::GV::terse { - my ($gv, $level) = @_; - my $stash = $gv->STASH->NAME; - if ($stash eq "main") { - $stash = ""; - } else { - $stash = $stash . "::"; - } - print indent($level); - printf "%s (0x%lx) *%s%s\n", class($gv), $$gv, $stash, $gv->SAFENAME; -} - -sub B::IV::terse { - my ($sv, $level) = @_; - print indent($level); - my $v = $sv->FLAGS & SVf_IVisUV ? "%u" : "%d"; - printf "%s (0x%lx) $v\n", class($sv), $$sv, $sv->int_value; -} - -sub B::NV::terse { - my ($sv, $level) = @_; - print indent($level); - printf "%s (0x%lx) %s\n", class($sv), $$sv, $sv->NV; -} - -sub B::NULL::terse { - my ($sv, $level) = @_; - print indent($level); - printf "%s (0x%lx)\n", class($sv), $$sv; -} - -sub B::SPECIAL::terse { - my ($sv, $level) = @_; - print indent($level); - printf "%s #%d %s\n", class($sv), $$sv, $specialsv_name[$$sv]; -} - -1; - -__END__ - -=head1 NAME - -B::Terse - Walk Perl syntax tree, printing terse info about ops - -=head1 SYNOPSIS - - perl -MO=Terse[,OPTIONS] foo.pl - -=head1 DESCRIPTION - -See F<ext/B/README>. - -=head1 AUTHOR - -Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> - -=cut diff --git a/contrib/perl5/ext/B/B/Xref.pm b/contrib/perl5/ext/B/B/Xref.pm deleted file mode 100644 index b4078b8..0000000 --- a/contrib/perl5/ext/B/B/Xref.pm +++ /dev/null @@ -1,420 +0,0 @@ -package B::Xref; - -=head1 NAME - -B::Xref - Generates cross reference reports for Perl programs - -=head1 SYNOPSIS - -perl -MO=Xref[,OPTIONS] foo.pl - -=head1 DESCRIPTION - -The B::Xref module is used to generate a cross reference listing of all -definitions and uses of variables, subroutines and formats in a Perl program. -It is implemented as a backend for the Perl compiler. - -The report generated is in the following format: - - File filename1 - Subroutine subname1 - Package package1 - object1 C<line numbers> - object2 C<line numbers> - ... - Package package2 - ... - -Each B<File> section reports on a single file. Each B<Subroutine> section -reports on a single subroutine apart from the special cases -"(definitions)" and "(main)". These report, respectively, on subroutine -definitions found by the initial symbol table walk and on the main part of -the program or module external to all subroutines. - -The report is then grouped by the B<Package> of each variable, -subroutine or format with the special case "(lexicals)" meaning -lexical variables. Each B<object> name (implicitly qualified by its -containing B<Package>) includes its type character(s) at the beginning -where possible. Lexical variables are easier to track and even -included dereferencing information where possible. - -The C<line numbers> are a comma separated list of line numbers (some -preceded by code letters) where that object is used in some way. -Simple uses aren't preceded by a code letter. Introductions (such as -where a lexical is first defined with C<my>) are indicated with the -letter "i". Subroutine and method calls are indicated by the character -"&". Subroutine definitions are indicated by "s" and format -definitions by "f". - -=head1 OPTIONS - -Option words are separated by commas (not whitespace) and follow the -usual conventions of compiler backend options. - -=over 8 - -=item C<-oFILENAME> - -Directs output to C<FILENAME> instead of standard output. - -=item C<-r> - -Raw output. Instead of producing a human-readable report, outputs a line -in machine-readable form for each definition/use of a variable/sub/format. - -=item C<-D[tO]> - -(Internal) debug options, probably only useful if C<-r> included. -The C<t> option prints the object on the top of the stack as it's -being tracked. The C<O> option prints each operator as it's being -processed in the execution order of the program. - -=back - -=head1 BUGS - -Non-lexical variables are quite difficult to track through a program. -Sometimes the type of a non-lexical variable's use is impossible to -determine. Introductions of non-lexical non-scalars don't seem to be -reported properly. - -=head1 AUTHOR - -Malcolm Beattie, mbeattie@sable.ox.ac.uk. - -=cut - -use strict; -use Config; -use B qw(peekop class comppadlist main_start svref_2object walksymtable - OPpLVAL_INTRO SVf_POK - ); - -sub UNKNOWN { ["?", "?", "?"] } - -my @pad; # lexicals in current pad - # as ["(lexical)", type, name] -my %done; # keyed by $$op: set when each $op is done -my $top = UNKNOWN; # shadows top element of stack as - # [pack, type, name] (pack can be "(lexical)") -my $file; # shadows current filename -my $line; # shadows current line number -my $subname; # shadows current sub name -my %table; # Multi-level hash to record all uses etc. -my @todo = (); # List of CVs that need processing - -my %code = (intro => "i", used => "", - subdef => "s", subused => "&", - formdef => "f", meth => "->"); - - -# Options -my ($debug_op, $debug_top, $nodefs, $raw); - -sub process { - my ($var, $event) = @_; - my ($pack, $type, $name) = @$var; - if ($type eq "*") { - if ($event eq "used") { - return; - } elsif ($event eq "subused") { - $type = "&"; - } - } - $type =~ s/(.)\*$/$1/g; - if ($raw) { - printf "%-16s %-12s %5d %-12s %4s %-16s %s\n", - $file, $subname, $line, $pack, $type, $name, $event; - } else { - # Wheee - push(@{$table{$file}->{$subname}->{$pack}->{$type.$name}->{$event}}, - $line); - } -} - -sub load_pad { - my $padlist = shift; - my ($namelistav, $vallistav, @namelist, $ix); - @pad = (); - return if class($padlist) eq "SPECIAL"; - ($namelistav,$vallistav) = $padlist->ARRAY; - @namelist = $namelistav->ARRAY; - for ($ix = 1; $ix < @namelist; $ix++) { - my $namesv = $namelist[$ix]; - next if class($namesv) eq "SPECIAL"; - my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/; - $pad[$ix] = ["(lexical)", $type, $name]; - } - if ($Config{useithreads}) { - my (@vallist); - @vallist = $vallistav->ARRAY; - for ($ix = 1; $ix < @vallist; $ix++) { - my $valsv = $vallist[$ix]; - next unless class($valsv) eq "GV"; - # these pad GVs don't have corresponding names, so same @pad - # array can be used without collisions - $pad[$ix] = [$valsv->STASH->NAME, "*", $valsv->NAME]; - } - } -} - -sub xref { - my $start = shift; - my $op; - for ($op = $start; $$op; $op = $op->next) { - last if $done{$$op}++; - warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top; - warn peekop($op), "\n" if $debug_op; - my $opname = $op->name; - if ($opname =~ /^(or|and|mapwhile|grepwhile|range|cond_expr)$/) { - xref($op->other); - } elsif ($opname eq "match" || $opname eq "subst") { - xref($op->pmreplstart); - } elsif ($opname eq "substcont") { - xref($op->other->pmreplstart); - $op = $op->other; - redo; - } elsif ($opname eq "enterloop") { - xref($op->redoop); - xref($op->nextop); - xref($op->lastop); - } elsif ($opname eq "subst") { - xref($op->pmreplstart); - } else { - no strict 'refs'; - my $ppname = "pp_$opname"; - &$ppname($op) if defined(&$ppname); - } - } -} - -sub xref_cv { - my $cv = shift; - my $pack = $cv->GV->STASH->NAME; - $subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME; - load_pad($cv->PADLIST); - xref($cv->START); - $subname = "(main)"; -} - -sub xref_object { - my $cvref = shift; - xref_cv(svref_2object($cvref)); -} - -sub xref_main { - $subname = "(main)"; - load_pad(comppadlist); - xref(main_start); - while (@todo) { - xref_cv(shift @todo); - } -} - -sub pp_nextstate { - my $op = shift; - $file = $op->file; - $line = $op->line; - $top = UNKNOWN; -} - -sub pp_padsv { - my $op = shift; - $top = $pad[$op->targ]; - process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); -} - -sub pp_padav { pp_padsv(@_) } -sub pp_padhv { pp_padsv(@_) } - -sub deref { - my ($var, $as) = @_; - $var->[1] = $as . $var->[1]; - process($var, "used"); -} - -sub pp_rv2cv { deref($top, "&"); } -sub pp_rv2hv { deref($top, "%"); } -sub pp_rv2sv { deref($top, "\$"); } -sub pp_rv2av { deref($top, "\@"); } -sub pp_rv2gv { deref($top, "*"); } - -sub pp_gvsv { - my $op = shift; - my $gv; - if ($Config{useithreads}) { - $top = $pad[$op->padix]; - $top = UNKNOWN unless $top; - $top->[1] = '$'; - } - else { - $gv = $op->gv; - $top = [$gv->STASH->NAME, '$', $gv->NAME]; - } - process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); -} - -sub pp_gv { - my $op = shift; - my $gv; - if ($Config{useithreads}) { - $top = $pad[$op->padix]; - $top = UNKNOWN unless $top; - $top->[1] = '*'; - } - else { - $gv = $op->gv; - $top = [$gv->STASH->NAME, "*", $gv->NAME]; - } - process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); -} - -sub pp_const { - my $op = shift; - my $sv = $op->sv; - # constant could be in the pad (under useithreads) - if ($$sv) { - $top = ["?", "", - (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"]; - } - else { - $top = $pad[$op->targ]; - } -} - -sub pp_method { - my $op = shift; - $top = ["(method)", "->".$top->[1], $top->[2]]; -} - -sub pp_entersub { - my $op = shift; - if ($top->[1] eq "m") { - process($top, "meth"); - } else { - process($top, "subused"); - } - $top = UNKNOWN; -} - -# -# Stuff for cross referencing definitions of variables and subs -# - -sub B::GV::xref { - my $gv = shift; - my $cv = $gv->CV; - if ($$cv) { - #return if $done{$$cv}++; - $file = $gv->FILE; - $line = $gv->LINE; - process([$gv->STASH->NAME, "&", $gv->NAME], "subdef"); - push(@todo, $cv); - } - my $form = $gv->FORM; - if ($$form) { - return if $done{$$form}++; - $file = $gv->FILE; - $line = $gv->LINE; - process([$gv->STASH->NAME, "", $gv->NAME], "formdef"); - } -} - -sub xref_definitions { - my ($pack, %exclude); - return if $nodefs; - $subname = "(definitions)"; - foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS - strict vars FileHandle Exporter Carp)) { - $exclude{$pack."::"} = 1; - } - no strict qw(vars refs); - walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) }); -} - -sub output { - return if $raw; - my ($file, $subname, $pack, $name, $ev, $perfile, $persubname, - $perpack, $pername, $perev); - foreach $file (sort(keys(%table))) { - $perfile = $table{$file}; - print "File $file\n"; - foreach $subname (sort(keys(%$perfile))) { - $persubname = $perfile->{$subname}; - print " Subroutine $subname\n"; - foreach $pack (sort(keys(%$persubname))) { - $perpack = $persubname->{$pack}; - print " Package $pack\n"; - foreach $name (sort(keys(%$perpack))) { - $pername = $perpack->{$name}; - my @lines; - foreach $ev (qw(intro formdef subdef meth subused used)) { - $perev = $pername->{$ev}; - if (defined($perev) && @$perev) { - my $code = $code{$ev}; - push(@lines, map("$code$_", @$perev)); - } - } - printf " %-16s %s\n", $name, join(", ", @lines); - } - } - } - } -} - -sub compile { - my @options = @_; - my ($option, $opt, $arg); - OPTION: - while ($option = shift @options) { - if ($option =~ /^-(.)(.*)/) { - $opt = $1; - $arg = $2; - } else { - unshift @options, $option; - last OPTION; - } - if ($opt eq "-" && $arg eq "-") { - shift @options; - last OPTION; - } elsif ($opt eq "o") { - $arg ||= shift @options; - open(STDOUT, ">$arg") or return "$arg: $!\n"; - } elsif ($opt eq "d") { - $nodefs = 1; - } elsif ($opt eq "r") { - $raw = 1; - } elsif ($opt eq "D") { - $arg ||= shift @options; - foreach $arg (split(//, $arg)) { - if ($arg eq "o") { - B->debug(1); - } elsif ($arg eq "O") { - $debug_op = 1; - } elsif ($arg eq "t") { - $debug_top = 1; - } - } - } - } - if (@options) { - return sub { - my $objname; - xref_definitions(); - foreach $objname (@options) { - $objname = "main::$objname" unless $objname =~ /::/; - eval "xref_object(\\&$objname)"; - die "xref_object(\\&$objname) failed: $@" if $@; - } - output(); - } - } else { - return sub { - xref_definitions(); - xref_main(); - output(); - } - } -} - -1; diff --git a/contrib/perl5/ext/B/B/assemble b/contrib/perl5/ext/B/B/assemble deleted file mode 100755 index 43cc5bc..0000000 --- a/contrib/perl5/ext/B/B/assemble +++ /dev/null @@ -1,30 +0,0 @@ -use B::Assembler qw(assemble_fh); -use FileHandle; - -my ($filename, $fh, $out); - -if ($ARGV[0] eq "-d") { - B::Assembler::debug(1); - shift; -} - -$out = \*STDOUT; - -if (@ARGV == 0) { - $fh = \*STDIN; - $filename = "-"; -} elsif (@ARGV == 1) { - $filename = $ARGV[0]; - $fh = new FileHandle "<$filename"; -} elsif (@ARGV == 2) { - $filename = $ARGV[0]; - $fh = new FileHandle "<$filename"; - $out = new FileHandle ">$ARGV[1]"; -} else { - die "Usage: assemble [filename] [outfilename]\n"; -} - -binmode $out; -$SIG{__WARN__} = sub { warn "$filename:@_" }; -$SIG{__DIE__} = sub { die "$filename: @_" }; -assemble_fh($fh, sub { print $out @_ }); diff --git a/contrib/perl5/ext/B/B/cc_harness b/contrib/perl5/ext/B/B/cc_harness deleted file mode 100644 index 79f8727..0000000 --- a/contrib/perl5/ext/B/B/cc_harness +++ /dev/null @@ -1,12 +0,0 @@ -use Config; - -$libdir = $ENV{PERL_SRC} || "$Config{installarchlib}/CORE"; - -if (!grep(/^-[cS]$/, @ARGV)) { - $linkargs = sprintf("%s $libdir/$Config{libperl} %s", - @Config{qw(ldflags libs)}); -} - -$cccmd = "$Config{cc} $Config{ccflags} -I$libdir @ARGV $linkargs"; -print "$cccmd\n"; -exec $cccmd; diff --git a/contrib/perl5/ext/B/B/disassemble b/contrib/perl5/ext/B/B/disassemble deleted file mode 100755 index 6530b80..0000000 --- a/contrib/perl5/ext/B/B/disassemble +++ /dev/null @@ -1,22 +0,0 @@ -use B::Disassembler qw(disassemble_fh); -use FileHandle; - -my $fh; -if (@ARGV == 0) { - $fh = \*STDIN; -} elsif (@ARGV == 1) { - $fh = new FileHandle "<$ARGV[0]"; -} else { - die "Usage: disassemble [filename]\n"; -} - -sub print_insn { - my ($insn, $arg) = @_; - if (defined($arg)) { - printf "%s %s\n", $insn, $arg; - } else { - print $insn, "\n"; - } -} - -disassemble_fh($fh, \&print_insn); diff --git a/contrib/perl5/ext/B/B/makeliblinks b/contrib/perl5/ext/B/B/makeliblinks deleted file mode 100644 index 8256078..0000000 --- a/contrib/perl5/ext/B/B/makeliblinks +++ /dev/null @@ -1,54 +0,0 @@ -use File::Find; -use Config; - -if (@ARGV != 2) { - warn <<"EOT"; -Usage: makeliblinks libautodir targetdir -where libautodir is the architecture-dependent auto directory -(e.g. $Config::Config{archlib}/auto). -EOT - exit 2; -} - -my ($libautodir, $targetdir) = @ARGV; - -# Calculate relative path prefix from $targetdir to $libautodir -sub relprefix { - my ($to, $from) = @_; - my $up; - for ($up = 0; substr($to, 0, length($from)) ne $from; $up++) { - $from =~ s( - [^/]+ (?# a group of non-slashes) - /* (?# maybe with some trailing slashes) - $ (?# at the end of the path) - )()x; - } - return (("../" x $up) . substr($to, length($from))); -} - -my $relprefix = relprefix($libautodir, $targetdir); - -my ($dlext, $lib_ext) = @Config::Config{qw(dlext lib_ext)}; - -sub link_if_library { - if (/\.($dlext|$lib_ext)$/o) { - my $ext = $1; - my $name = $File::Find::name; - if (substr($name, 0, length($libautodir) + 1) ne "$libautodir/") { - die "directory of $name doesn't match $libautodir\n"; - } - substr($name, 0, length($libautodir) + 1) = ''; - my @parts = split(m(/), $name); - if ($parts[-1] ne "$parts[-2].$ext") { - die "module name $_ doesn't match its directory $libautodir\n"; - } - pop @parts; - my $libpath = "$targetdir/lib" . join("__", @parts) . ".$ext"; - print "$libpath -> $relprefix/$name\n"; - symlink("$relprefix/$name", $libpath) - or warn "above link failed with error: $!\n"; - } -} - -find(\&link_if_library, $libautodir); -exit 0; diff --git a/contrib/perl5/ext/B/Makefile.PL b/contrib/perl5/ext/B/Makefile.PL deleted file mode 100644 index dcf6a1d..0000000 --- a/contrib/perl5/ext/B/Makefile.PL +++ /dev/null @@ -1,48 +0,0 @@ -use ExtUtils::MakeMaker; -use Config; -use File::Spec; - -my $e = $Config{'exe_ext'}; -my $o = $Config{'obj_ext'}; -my $exeout_flag = '-o '; -if ($^O eq 'MSWin32') { - if ($Config{'cc'} =~ /^cl/i) { - $exeout_flag = '-Fe'; - } - elsif ($Config{'cc'} =~ /^bcc/i) { - $exeout_flag = '-e'; - } -} - -WriteMakefile( - NAME => "B", - VERSION => "a5", - PL_FILES => { 'defsubs_h.PL' => 'defsubs.h' }, - MAN3PODS => {}, - clean => { - FILES => "perl$e *$o B.c defsubs.h *~" - } -); - -package MY; - -sub post_constants { - "\nLIBS = $Config::Config{libs}\n" -} - -sub upupfile { - File::Spec->catfile(File::Spec->updir, - File::Spec->updir, $_[0]); -} - -sub MY::postamble { - my $op_h = upupfile('op.h'); - my $cop_h = upupfile('cop.h'); - my $noecho = shift->{NOECHO}; -" -B\$(OBJ_EXT) : defsubs.h - -defsubs.h :: $op_h $cop_h - $noecho \$(NOOP) -" -} diff --git a/contrib/perl5/ext/B/NOTES b/contrib/perl5/ext/B/NOTES deleted file mode 100644 index 89d03ba..0000000 --- a/contrib/perl5/ext/B/NOTES +++ /dev/null @@ -1,168 +0,0 @@ -C backend invocation - If there are any non-option arguments, they are taken to be - names of objects to be saved (probably doesn't work properly yet). - Without extra arguments, it saves the main program. - -ofilename Output to filename instead of STDOUT - -v Verbose (currently gives a few compilation statistics) - -- Force end of options - -uPackname Force apparently unused subs from package Packname to - be compiled. This allows programs to use eval "foo()" - even when sub foo is never seen to be used at compile - time. The down side is that any subs which really are - never used also have code generated. This option is - necessary, for example, if you have a signal handler - foo which you initialise with $SIG{BAR} = "foo". - A better fix, though, is just to change it to - $SIG{BAR} = \&foo. You can have multiple -u options. - -D Debug options (concat or separate flags like perl -D) - o OPs, prints each OP as it's processed - c COPs, prints COPs as processed (incl. file & line num) - A prints AV information on saving - C prints CV information on saving - M prints MAGIC information on saving - -f Force optimisations on or off one at a time. - cog Copy-on-grow: PVs declared and initialised statically - no-cog No copy-on-grow - -On Optimisation level (n = 0, 1, 2, ...). -O means -O1. - Currently, -O1 and higher set -fcog. - -Examples - perl -MO=C foo.pl > foo.c - perl cc_harness -o foo foo.c - - perl -MO=C,-v,-DcA bar.pl > /dev/null - -CC backend invocation - If there are any non-option arguments, they are taken to be names of - subs to be saved. Without extra arguments, it saves the main program. - -ofilename Output to filename instead of STDOUT - -- Force end of options - -uPackname Force apparently unused subs from package Packname to - be compiled. This allows programs to use eval "foo()" - even when sub foo is never seen to be used at compile - time. The down side is that any subs which really are - never used also have code generated. This option is - necessary, for example, if you have a signal handler - foo which you initialise with $SIG{BAR} = "foo". - A better fix, though, is just to change it to - $SIG{BAR} = \&foo. You can have multiple -u options. - -mModulename Instead of generating source for a runnable executable, - generate source for an XSUB module. The - boot_Modulename function (which DynaLoader can look - for) does the appropriate initialisation and runs the - main part of the Perl source that is being compiled. - -pn Generate code for perl patchlevel n (e.g. 3 or 4). - The default is to generate C code which will link - with the currently executing version of perl. - running the perl compiler. - -D Debug options (concat or separate flags like perl -D) - r Writes debugging output to STDERR just as it's about - to write to the program's runtime (otherwise writes - debugging info as comments in its C output). - O Outputs each OP as it's compiled - s Outputs the contents of the shadow stack at each OP - p Outputs the contents of the shadow pad of lexicals as - it's loaded for each sub or the main program. - q Outputs the name of each fake PP function in the queue - as it's about to processes. - l Output the filename and line number of each original - line of Perl code as it's processed (pp_nextstate). - t Outputs timing information of compilation stages - -f Force optimisations on or off one at a time. - [ - cog Copy-on-grow: PVs declared and initialised statically - no-cog No copy-on-grow - These two not in CC yet. - ] - freetmps-each-bblock Delays FREETMPS from the end of each - statement to the end of the each basic - block. - freetmps-each-loop Delays FREETMPS from the end of each - statement to the end of the group of - basic blocks forming a loop. At most - one of the freetmps-each-* options can - be used. - omit-taint Omits generating code for handling - perl's tainting mechanism. - -On Optimisation level (n = 0, 1, 2, ...). -O means -O1. - Currently, -O1 sets -ffreetmps-each-bblock and -O2 - sets -ffreetmps-each-loop. - -Example - perl -MO=CC,-O2,-ofoo.c foo.pl - perl cc_harness -o foo foo.c - - perl -MO=CC,-mFoo,-oFoo.c Foo.pm - perl cc_harness -shared -c -o Foo.so Foo.c - - -Bytecode backend invocation - - If there are any non-option arguments, they are taken to be - names of objects to be saved (probably doesn't work properly yet). - Without extra arguments, it saves the main program. - -ofilename Output to filename instead of STDOUT. - -- Force end of options. - -f Force optimisations on or off one at a time. - Each can be preceded by no- to turn the option off. - compress-nullops - Only fills in the necessary fields of ops which have - been optimised away by perl's internal compiler. - omit-sequence-numbers - Leaves out code to fill in the op_seq field of all ops - which is only used by perl's internal compiler. - bypass-nullops - If op->op_next ever points to a NULLOP, replaces the - op_next field with the first non-NULLOP in the path - of execution. - strip-syntax-tree - Leaves out code to fill in the pointers which link the - internal syntax tree together. They're not needed at - run-time but leaving them out will make it impossible - to recompile or disassemble the resulting program. - It will also stop "goto label" statements from working. - -On Optimisation level (n = 0, 1, 2, ...). -O means -O1. - -O1 sets -fcompress-nullops -fomit-sequence numbers. - -O6 adds -fstrip-syntax-tree. - -D Debug options (concat or separate flags like perl -D) - o OPs, prints each OP as it's processed. - b print debugging information about bytecompiler progress - a tells the assembler to include source assembler lines - in its output as bytecode comments. - C prints each CV taken from the final symbol tree walk. - -S Output assembler source rather than piping it - through the assembler and outputting bytecode. - -m Compile as a module rather than a standalone program. - Currently this just means that the bytecodes for - initialising main_start, main_root and curpad are - omitted. - -Example - perl -MO=Bytecode,-O6,-o,foo.plc foo.pl - - perl -MO=Bytecode,-S foo.pl > foo.S - assemble foo.S > foo.plc - byteperl foo.plc - - perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm - -Backends for debugging - perl -MO=Terse,exec foo.pl - perl -MO=Debug bar.pl - -O module - Used with "perl -MO=Backend,foo,bar prog.pl" to invoke the backend - B::Backend with options foo and bar. O invokes the sub - B::Backend::compile() with arguments foo and bar at BEGIN time. - That compile() sub must do any inital argument processing replied. - If unsuccessful, it should return a string which O arranges to be - printed as an error message followed by a clean error exit. In the - normal case where any option processing in compile() is successful, - it should return a sub ref (usually a closure) to perform the - actual compilation. When O regains control, it ensures that the - "-c" option is forced (so that the program being compiled doesn't - end up running) and registers a CHECK block to call back the sub ref - returned from the backend's compile(). Perl then continues by - parsing prog.pl (just as it would with "perl -c prog.pl") and after - doing so, assuming there are no parse-time errors, the CHECK block - of O gets called and the actual backend compilation happens. Phew. diff --git a/contrib/perl5/ext/B/O.pm b/contrib/perl5/ext/B/O.pm deleted file mode 100644 index 2ef91ed..0000000 --- a/contrib/perl5/ext/B/O.pm +++ /dev/null @@ -1,86 +0,0 @@ -package O; -use B qw(minus_c save_BEGINs); -use Carp; - -sub import { - my ($class, $backend, @options) = @_; - eval "use B::$backend ()"; - if ($@) { - croak "use of backend $backend failed: $@"; - } - my $compilesub = &{"B::${backend}::compile"}(@options); - if (ref($compilesub) eq "CODE") { - minus_c; - save_BEGINs; - eval 'CHECK { &$compilesub() }'; - } else { - die $compilesub; - } -} - -1; - -__END__ - -=head1 NAME - -O - Generic interface to Perl Compiler backends - -=head1 SYNOPSIS - - perl -MO=Backend[,OPTIONS] foo.pl - -=head1 DESCRIPTION - -This is the module that is used as a frontend to the Perl Compiler. - -=head1 CONVENTIONS - -Most compiler backends use the following conventions: OPTIONS -consists of a comma-separated list of words (no white-space). -The C<-v> option usually puts the backend into verbose mode. -The C<-ofile> option generates output to B<file> instead of -stdout. The C<-D> option followed by various letters turns on -various internal debugging flags. See the documentation for the -desired backend (named C<B::Backend> for the example above) to -find out about that backend. - -=head1 IMPLEMENTATION - -This section is only necessary for those who want to write a -compiler backend module that can be used via this module. - -The command-line mentioned in the SYNOPSIS section corresponds to -the Perl code - - use O ("Backend", OPTIONS); - -The C<import> function which that calls loads in the appropriate -C<B::Backend> module and calls the C<compile> function in that -package, passing it OPTIONS. That function is expected to return -a sub reference which we'll call CALLBACK. Next, the "compile-only" -flag is switched on (equivalent to the command-line option C<-c>) -and a CHECK block is registered which calls CALLBACK. Thus the main -Perl program mentioned on the command-line is read in, parsed and -compiled into internal syntax tree form. Since the C<-c> flag is -set, the program does not start running (excepting BEGIN blocks of -course) but the CALLBACK function registered by the compiler -backend is called. - -In summary, a compiler backend module should be called "B::Foo" -for some foo and live in the appropriate directory for that name. -It should define a function called C<compile>. When the user types - - perl -MO=Foo,OPTIONS foo.pl - -that function is called and is passed those OPTIONS (split on -commas). It should return a sub ref to the main compilation function. -After the user's program is loaded and parsed, that returned sub ref -is invoked which can then go ahead and do the compilation, usually by -making use of the C<B> module's functionality. - -=head1 AUTHOR - -Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> - -=cut diff --git a/contrib/perl5/ext/B/README b/contrib/perl5/ext/B/README deleted file mode 100644 index fa3f085..0000000 --- a/contrib/perl5/ext/B/README +++ /dev/null @@ -1,325 +0,0 @@ - Perl Compiler Kit, Version alpha4 - - Copyright (c) 1996, 1997, Malcolm Beattie - - This program is free software; you can redistribute it and/or modify - it under the terms of either: - - a) the GNU General Public License as published by the Free - Software Foundation; either version 1, or (at your option) any - later version, or - - b) the "Artistic License" which comes with this kit. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either - the GNU General Public License or the Artistic License for more details. - - You should have received a copy of the Artistic License with this kit, - in the file named "Artistic". If not, you can get one from the Perl - distribution. You should also have received a copy of the GNU General - Public License, in the file named "Copying". If not, you can get one - from the Perl distribution or else write to the Free Software Foundation, - Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA. - -CHANGES - -New since alpha3 - Anonymous subs work properly with C and CC. - Heuristics for forcing compilation of apparently unused subs/methods. - Subs which use the AutoLoader module are forcibly loaded at compile-time. - Slightly faster compilation. - Handles slightly more complex code within a BEGIN { }. - Minor bug fixes. - -New since alpha2 - CC backend now supports ".." and s//e. - Xref backend generates cross-reference reports - Cleanups to fix benign but irritating "-w" warnings - Minor cxstack fix -New since alpha1 - Working CC backend - Shared globs and pre-initialised hash support - Some XSUB support - Assorted bug fixes - -INSTALLATION - -(1) You need perl5.002 or later. - -(2) If you want to compile and run programs with the C or CC backends -which undefine (or redefine) subroutines, then you need to apply a -one-line patch to perl itself. One or two of the programs in perl's -own test suite do this. The patch is in file op.patch. It prevents -perl from calling free() on OPs with the magic sequence number (U16)-1. -The compiler declares all OPs as static structures and uses that magic -sequence number. - -(3) Type - perl Makefile.PL -to write a personalised Makefile for your system. If you want the -bytecode modules to support reading bytecode from strings (instead of -just from files) then add the option - -DINDIRECT_BGET_MACROS -into the middle of the definition of the CCCMD macro in the Makefile. -Your C compiler may need to be able to cope with Standard C for this. -I haven't tested this option yet with an old pre-Standard compiler. - -(4) If your platform supports dynamic loading then just type - make -and you can then use - perl -Iblib/arch -MO=foo bar -to use the compiler modules (see later for details). -If you need/want instead to make a statically linked perl which -contains the appropriate modules, then type - make perl - make byteperl -and you can then use - ./perl -MO=foo bar -to use the compiler modules. -In both cases, the byteperl executable is required for running standalone -bytecode programs. It is *not* a standard perl+XSUB perl executable. - -USAGE - -As of the alpha3 release, the Bytecode, C and CC backends are now all -functional enough to compile almost the whole of the main perl test -suite. In the case of the CC backend, any failures are all due to -differences and/or known bugs documented below. See the file TESTS. -In the following examples, you'll need to replace "perl" by - perl -Iblib/arch -if you have built the extensions for a dynamic loading platform but -haven't installed the extensions completely. You'll need to replace -"perl" by - ./perl -if you have built the extensions into a statically linked perl binary. - -(1) To compile perl program foo.pl with the C backend, do - perl -MO=C,-ofoo.c foo.pl -Then use the cc_harness perl program to compile the resulting C source: - perl cc_harness -O2 -o foo foo.c - -If you are using a non-ANSI pre-Standard C compiler that can't handle -pre-declaring static arrays, then add -DBROKEN_STATIC_REDECL to the -options you use: - perl cc_harness -O2 -o foo -DBROKEN_STATIC_REDECL foo.c -If you are using a non-ANSI pre-Standard C compiler that can't handle -static initialisation of structures with union members then add --DBROKEN_UNION_INIT to the options you use. If you want command line -arguments passed to your executable to be interpreted by perl (e.g. -Dx) -then compile foo.c with -DALLOW_PERL_OPTIONS. Otherwise, all command line -arguments passed to foo will appear directly in @ARGV. The resulting -executable foo is the compiled version of foo.pl. See the file NOTES for -extra options you can pass to -MO=C. - -There are some constraints on the contents on foo.pl if you want to be -able to compile it successfully. Some problems can be fixed fairly easily -by altering foo.pl; some problems with the compiler are known to be -straightforward to solve and I'll do so soon. The file Todo lists a -number of known problems. See the XSUB section lower down for information -about compiling programs which use XSUBs. - -(2) To compile foo.pl with the CC backend (which generates actual -optimised C code for the execution path of your perl program), use - perl -MO=CC,-ofoo.c foo.pl - -and proceed just as with the C backend. You should almost certainly -use an option such as -O2 with the subsequent cc_harness invocation -so that your C compiler uses optimisation. The C code generated by -the Perl compiler's CC backend looks ugly to humans but is easily -optimised by C compilers. - -To make the most of this compiler backend, you need to tell the -compiler when you're using int or double variables so that it can -optimise appropriately (although this part of the compiler is the most -buggy). You currently do that by naming lexical variables ending in -"_i" for ints, "_d" for doubles, "_ir" for int "register" variables or -"_dr" for double "register" variables. Here "register" is a promise -that you won't pass a reference to the variable into a sub which then -modifies the variable. The compiler ought to catch attempts to use -"\$i" just as C compilers catch attempts to do "&i" for a register int -i but it doesn't at the moment. Bugs in the CC backend may make your -program fail in mysterious ways and give wrong answers rather than just -crash in boring ways. But, hey, this is an alpha release so you knew -that anyway. See the XSUB section lower down for information about -compiling programs which use XSUBs. - -If your program uses classes which define methods (or other subs which -are not exported and not apparently used until runtime) then you'll -need to use -u compile-time options (see the NOTES file) to force the -subs to be compiled. Future releases will probably default the other -way, do more auto-detection and provide more fine-grained control. - -Since compiled executables need linking with libperl, you may want -to turn libperl.a into a shared library if your platform supports -it. For example, with Digital UNIX, do something like - ld -shared -o libperl.so -all libperl.a -none -lc -and with Linux/ELF, rebuild the perl .c files with -fPIC (and I -also suggest -fomit-frame-pointer for Linux on Intel architetcures), -do "make libperl.a" and then do - gcc -shared -Wl,-soname,libperl.so.5 -o libperl.so.5.3 `ar t libperl.a` -and then - # cp libperl.so.5.3 /usr/lib - # cd /usr/lib - # ln -s libperl.so.5.3 libperl.so.5 - # ln -s libperl.so.5 libperl.so - # ldconfig -When you compile perl executables with cc_harness, append -L/usr/lib -otherwise the -L for the perl source directory will override it. For -example, - perl -Iblib/arch -MO=CC,-O2,-ofoo3.c foo3.bench - perl cc_harness -o foo3 -O2 foo3.c -L/usr/lib - ls -l foo3 - -rwxr-xr-x 1 mbeattie xzdg 11218 Jul 1 15:28 foo3 -You'll probably also want to link your main perl executable against -libperl.so; it's nice having an 11K perl executable. - -(3) To compile foo.pl into bytecode do - perl -MO=Bytecode,-ofoo foo.pl -To run the resulting bytecode file foo as a standalone program, you -use the program byteperl which should have been built along with the -extensions. - ./byteperl foo -Any extra arguments are passed in as @ARGV; they are not interpreted -as perl options. If you want to load chunks of bytecode into an already -running perl program then use the -m option and investigate the -byteload_fh and byteload_string functions exported by the B module. -See the NOTES file for details of these and other options (including -optimisation options and ways of getting at the intermediate "assembler" -code that the Bytecode backend uses). - -(3) There are little Bourne shell scripts and perl programs to aid with -some common operations: assemble, disassemble, run_bytecode_test, -run_test, cc_harness, test_harness, test_harness_bytecode. - -(4) Walk the op tree in execution order printing terse info about each op - perl -MO=Terse,exec foo.pl - -(5) Walk the op tree in syntax order printing lengthier debug info about -each op. You can also append ",exec" to walk in execution order, but the -formatting is designed to look nice with Terse rather than Debug. - perl -MO=Debug foo.pl - -(6) Produce a cross-reference report of the line numbers at which all -variables, subs and formats are defined and used. - perl -MO=Xref foo.pl - -XSUBS - -The C and CC backends can successfully compile some perl programs which -make use of XSUB extensions. [I'll add more detail to this section in a -later release.] As a prerequisite, such extensions must not need to do -anything in their BOOT: section which needs to be done at runtime rather -than compile time. Normally, the only code in the boot_Foo() function is -a list of newXS() calls which xsubpp puts there and the compiler handles -saving those XS subs itself. For each XSUB used, the C and CC compiler -will generate an initialiser in their C output which refers to the name -of the relevant C function (XS_Foo_somesub). What is not yet automated -is the necessary commands and cc command-line options (e.g. via -"perl cc_harness") which link against the extension libraries. For now, -you need the XSUB extension to have installed files in the right format -for using as C libraries (e.g. Foo.a or Foo.so). As the Foo.so files (or -your platform's version) aren't suitable for linking against, you will -have to reget the extension source and rebuild it as a static extension -to force the generation of a suitable Foo.a file. Then you need to make -a symlink (or copy or rename) of that file into a libFoo.a suitable for -cc linking. Then add the appropriate -L and -l options to your -"perl cc_harness" command line to find and link against those libraries. -You may also need to fix up some platform-dependent environment variable -to ensure that linked-against .so files are found at runtime too. - -DIFFERENCES - -The result of running a compiled Perl program can sometimes be different -from running the same program with standard perl. Think of the compiler -as having a slightly different implementation of the language Perl. -Unfortunately, since Perl has had a single implementation until now, -there are no formal standards or documents defining what behaviour is -guaranteed of Perl the language and what just "happens to work". -Some of the differences below are almost impossible to change because of -the way the compiler works. Others can be changed to produce "standard" -perl behaviour if it's deemed proper and the resulting performance hit -is accepted. I'll use "standard perl" to mean the result of running a -Perl program using the perl executable from the perl distribution. -I'll use "compiled Perl program" to mean running an executable produced -by this compiler kit ("the compiler") with the CC backend. - -Loops - Standard perl calculates the target of "next", "last", and "redo" - at run-time. The compiler calculates the targets at compile-time. - For example, the program - - sub skip_on_odd { next NUMBER if $_[0] % 2 } - NUMBER: for ($i = 0; $i < 5; $i++) { - skip_on_odd($i); - print $i; - } - - produces the output - 024 - with standard perl but gives a compile-time error with the compiler. - -Context of ".." - The context (scalar or array) of the ".." operator determines whether - it behaves as a range or a flip/flop. Standard perl delays until - runtime the decision of which context it is in but the compiler needs - to know the context at compile-time. For example, - @a = (4,6,1,0,0,1); - sub range { (shift @a)..(shift @a) } - print range(); - while (@a) { print scalar(range()) } - generates the output - 456123E0 - with standard Perl but gives a compile-time error with compiled Perl. - -Arithmetic - Compiled Perl programs use native C arithemtic much more frequently - than standard perl. Operations on large numbers or on boundary - cases may produce different behaviour. - -Deprecated features - Features of standard perl such as $[ which have been deprecated - in standard perl since version 5 was released have not been - implemented in the compiler. - -Others - I'll add to this list as I remember what they are. - -BUGS - -Here are some things which may cause the compiler problems. - -The following render the compiler useless (without serious hacking): -* Use of the DATA filehandle (via __END__ or __DATA__ tokens) -* Operator overloading with %OVERLOAD -* The (deprecated) magic array-offset variable $[ does not work -* The following operators are not yet implemented for CC - goto - sort with a non-default comparison (i.e. a named sub or inline block) -* You can't use "last" to exit from a non-loop block. - -The following may give significant problems: -* BEGIN blocks containing complex initialisation code -* Code which is only ever referred to at runtime (e.g. via eval "..." or - via method calls): see the -u option for the C and CC backends. -* Run-time lookups of lexical variables in "outside" closures - -The following may cause problems (not thoroughly tested): -* Dependencies on whether values of some "magic" Perl variables are - determined at compile-time or runtime. -* For the C and CC backends: compile-time strings which are longer than - your C compiler can cope with in a single line or definition. -* Reliance on intimate details of global destruction -* For the Bytecode backend: high -On optimisation numbers with code - that has complex flow of control. -* Any "-w" option in the first line of your perl program is seen and - acted on by perl itself before the compiler starts. The compiler - itself then runs with warnings turned on. This may cause perl to - print out warnings about the compiler itself since I haven't tested - it thoroughly with warnings turned on. - -There is a terser but more complete list in the Todo file. - -Malcolm Beattie -2 September 1996 diff --git a/contrib/perl5/ext/B/TESTS b/contrib/perl5/ext/B/TESTS deleted file mode 100644 index e050f6c..0000000 --- a/contrib/perl5/ext/B/TESTS +++ /dev/null @@ -1,78 +0,0 @@ -Test results from compiling t/*/*.t - C Bytecode CC - -base/cond.t OK ok OK -base/if.t OK ok OK -base/lex.t OK ok OK -base/pat.t OK ok OK -base/term.t OK ok OK -cmd/elsif.t OK ok OK -cmd/for.t OK ok ok 1, 2, 3, panic: pp_iter -cmd/mod.t OK ok ok -cmd/subval.t OK ok 1..34, not ok 27,28 (simply - because filename changes). -cmd/switch.t OK ok ok -cmd/while.t OK ok ok -io/argv.t OK ok ok -io/dup.t OK ok ok -io/fs.t OK ok ok -io/inplace.t OK ok ok -io/pipe.t OK ok ok with -umain -io/print.t OK ok ok -io/tell.t OK ok ok -op/append.t OK ok OK -op/array.t OK ok 1..36, not ok 7,10 (no $[) -op/auto.t OK ok OK -op/chop.t OK ok OK -op/cond.t OK ok OK -op/delete.t OK ok OK -op/do.t OK ok OK -op/each.t OK ok OK -op/eval.t OK ok ok 1-6 of 16 then exits -op/exec.t OK ok OK -op/exp.t OK ok OK -op/flip.t OK ok OK -op/fork.t OK ok OK -op/glob.t OK ok OK -op/goto.t OK ok 1..9, Can't find label label1. -op/groups.t OK (s/ucb/bin/ under Linux) OK 1..0 for now. -op/index.t OK ok OK -op/int.t OK ok OK -op/join.t OK ok OK -op/list.t OK ok OK -op/local.t OK ok OK -op/magic.t OK ok OK -op/misc.t no DATA filehandle so succeeds trivially with 1..0 -op/mkdir.t OK ok OK -op/my.t OK ok OK -op/oct.t OK ok OK (C large const warnings) -op/ord.t OK ok OK -op/overload.t Mostly not ok Mostly not ok C errors. -op/pack.t OK ok OK -op/pat.t omit 26 (reset) ok [lots of memory for compile] -op/push.t OK ok OK -op/quotemeta.t OK ok OK -op/rand.t OK ok -op/range.t OK ok OK -op/read.t OK ok OK -op/readdir.t OK ok OK (substcont works too) -op/ref.t omits "ok 40" (lex destruction) ok (Bytecode) - CC: need -u for OBJ,BASEOBJ, - UNIVERSAL,WHATEVER,main. - 1..41, ok1-33,36-38, - then ok 41, ok 39.DESTROY probs -op/regexp.t OK ok ok (trivially all eval'd) -op/repeat.t OK ok ok -op/sleep.t OK ok ok -op/sort.t OK ok 1..10, ok 1, Out of memory! -op/split.t OK ok ok -op/sprintf.t OK ok ok -op/stat.t OK ok ok -op/study.t OK ok ok -op/subst.t OK ok ok -op/substr.t OK ok ok1-22 except 7-9,11 (all $[) -op/time.t OK ok ok -op/undef.t omit 21 ok ok -op/unshift.t OK ok ok -op/vec.t OK ok ok -op/write.t not ok 3 (no CvOUTSIDE lex from runtime eval). CC: 1..3, hang diff --git a/contrib/perl5/ext/B/Todo b/contrib/perl5/ext/B/Todo deleted file mode 100644 index 495be2e..0000000 --- a/contrib/perl5/ext/B/Todo +++ /dev/null @@ -1,37 +0,0 @@ -* Fixes - -CC backend: goto, sort with non-default comparison. last for non-loop blocks. -Version checking -improve XSUB handling (both static and dynamic) -sv_magic can do SvREFCNT_inc(obj) which messes up precalculated refcounts -allocation of XPV[INAHC]V structures needs fixing: Perl tries to free -them whereas the compiler expects them to be linked to a xpv[inahc]v_root -list the same as X[IPR]V structures. -ref counts -perl_parse replacement -fix cstring for long strings -compile-time initialisation of AvARRAYs -signed/unsigned problems with NV (and IV?) initialisation and elsewhere? -CvOUTSIDE for ordinary subs -DATA filehandle for standalone Bytecode program (easy) -DATA filehandle for multiple bytecode-compiled modules (harder) -DATA filehandle for C-compiled program (yet harder) - -* Features - -type checking -compile time v. runtime initialisation -save PMOPs in compiled form -selection of what to dump -options for cutting out line info etc. -comment output -shared constants -module dependencies - -* Optimisations -collapse LISTOPs to UNOPs or BASEOPs -compile-time qw(), constant subs -global analysis of variables, type hints etc. -demand-loaded bytecode (leader of each basic block replaced by an op -which loads in bytecode for its block) -fast sub calls for CC backend diff --git a/contrib/perl5/ext/B/defsubs_h.PL b/contrib/perl5/ext/B/defsubs_h.PL deleted file mode 100644 index da6566b..0000000 --- a/contrib/perl5/ext/B/defsubs_h.PL +++ /dev/null @@ -1,42 +0,0 @@ -# Do not remove the following line; MakeMaker relies on it to identify -# this file as a template for defsubs.h -# Extracting defsubs.h (with variable substitutions) -#!perl -my ($out) = __FILE__ =~ /(^.*)\.PL/i; -$out =~ s/_h$/.h/; -open(OUT,">$out") || die "Cannot open $file:$!"; -print "Extracting $out...\n"; -foreach my $const (qw( - AVf_REAL - HEf_SVKEY - SVf_READONLY SVTYPEMASK - GVf_IMPORTED_AV GVf_IMPORTED_HV - GVf_IMPORTED_SV GVf_IMPORTED_CV - CVf_METHOD CVf_LOCKED CVf_LVALUE - SVf_IOK SVf_IVisUV SVf_NOK SVf_POK - SVf_ROK SVp_IOK SVp_POK SVp_NOK - )) - { - doconst($const); - } -foreach my $file (qw(op.h cop.h)) - { - my $path = $^O eq 'MacOS' ? ":::$file" : "../../$file"; - open(OPH,"$path") || die "Cannot open $path:$!"; - while (<OPH>) - { - doconst($1) if (/#define\s+(\w+)\s+([\(\)\|\dx]+)\s*(?:$|\/\*)/); - } - close(OPH); - } -close(OUT); - -sub doconst -{ - my $sym = shift; - my $l = length($sym); - print OUT <<"END"; - newCONSTSUB(stash,"$sym",newSViv($sym)); - av_push(export_ok,newSVpvn("$sym",$l)); -END -} diff --git a/contrib/perl5/ext/B/ramblings/cc.notes b/contrib/perl5/ext/B/ramblings/cc.notes deleted file mode 100644 index 47bd65a..0000000 --- a/contrib/perl5/ext/B/ramblings/cc.notes +++ /dev/null @@ -1,32 +0,0 @@ -At entry to each basic block, the following can be assumed (and hence -must be forced where necessary at the end of each basic block): - -The shadow stack @stack is empty. -For each lexical object in @pad, VALID_IV holds for each T_INT, -VALID_DOUBLE holds for each T_DOUBLE and VALID_SV holds otherwise. -The C shadow variable sp holds the stack pointer (not necessarily stack_sp). - -write_back_stack - Writes the contents of the shadow stack @stack back to the real stack. - A write-back of each object in the stack is forced so that its - backing SV contains the right value and that SV is then pushed onto the - real stack. On return, @stack is empty. - -write_back_lexicals - Forces a write-back (i.e. achieves VALID_SV), where necessary, for each - lexical object in @pad. Objects with the TEMPORARY flag are skipped. If - write_back_lexicals is called with an (optional) argument, then it is - taken to be a bitmask of more flags: any lexical object with one of those - flags set is also skipped and not written back to its SV. - -invalidate_lexicals($avoid) - The VALID_INT and VALID_DOUBLE flags are turned off for each lexical - object in @pad whose flags field doesn't overlap with $avoid. - -reload_lexicals - For each necessary lexical object in @pad, makes sure that VALID_IV - holds for objects of type T_INT, VALID_DOUBLE holds for objects for - type T_DOUBLE, and VALID_SV holds for other objects. An object is - considered for reloading if its flags field does not overlap with the - (optional) argument passed to reload_lexicals. - diff --git a/contrib/perl5/ext/B/ramblings/curcop.runtime b/contrib/perl5/ext/B/ramblings/curcop.runtime deleted file mode 100644 index 9b8b7d5..0000000 --- a/contrib/perl5/ext/B/ramblings/curcop.runtime +++ /dev/null @@ -1,39 +0,0 @@ -PP code uses of curcop ----------------------- - -pp_rv2gv - when a new glob is created for an OPpLVAL_INTRO, - curcop->cop_line is stored as GvLINE() in the new GP. -pp_bless - curcop->cop_stash is used as the stash in the one-arg form of bless - -pp_repeat - tests (curcop != &compiling) to warn "Can't x= to readonly value" - -pp_pos -pp_substr -pp_index -pp_rindex -pp_aslice -pp_lslice -pp_splice - curcop->cop_arybase - -pp_sort - curcop->cop_stash used to determine whether to gv_fetchpv $a and $b - -pp_caller - tests (curcop->cop_stash == debstash) to determine whether - to set DB::args - -pp_reset - resets vars in curcop->cop_stash - -pp_dbstate - sets curcop = (COP*)op - -doeval - compiles into curcop->cop_stash - -pp_nextstate - sets curcop = (COP*)op diff --git a/contrib/perl5/ext/B/ramblings/flip-flop b/contrib/perl5/ext/B/ramblings/flip-flop deleted file mode 100644 index e08333d..0000000 --- a/contrib/perl5/ext/B/ramblings/flip-flop +++ /dev/null @@ -1,54 +0,0 @@ -PP(pp_range) -{ - if (GIMME == G_ARRAY) - return NORMAL; - if (SvTRUEx(PAD_SV(PL_op->op_targ))) - return cLOGOP->op_other; - else - return NORMAL; -} - -pp_range is a LOGOP. -In list context, it just returns op_next. -In scalar context it checks the truth of targ and returns -op_other if true, op_next if false. - -flip is an UNOP. -It "looks after" its child which is always a pp_range LOGOP. -In list context, it just returns the child's op_other. -In scalar context, there are three possible outcomes: - (1) set child's targ to 1, our targ to 1 and return op_next. - (2) set child's targ to 1, our targ to 0, sp-- and return child's op_other. - (3) Blank targ and TOPs and return op_next. -Case 1 happens for a "..." with a matching lineno... or true TOPs. -Case 2 happens for a ".." with a matching lineno... or true TOPs. -Case 3 happens for a non-matching lineno or false TOPs. - - $a = lhs..rhs; - - ,-------> range - ^ / \ - | true/ \false - | / \ - first| lhs rhs - | \ first / - ^--- flip <----- flop - \ / - \ / - sassign - - -/* range */ -if (SvTRUE(curpad[op->op_targ])) - goto label(op_other); -/* op_next */ -... -/* flip */ -/* For "..." returns op_next. For ".." returns op_next or op_first->op_other */ -/* end of basic block */ -goto out; -label(range op_other): -... -/* flop */ -out: -... diff --git a/contrib/perl5/ext/B/ramblings/magic b/contrib/perl5/ext/B/ramblings/magic deleted file mode 100644 index e41930a..0000000 --- a/contrib/perl5/ext/B/ramblings/magic +++ /dev/null @@ -1,93 +0,0 @@ -sv_magic() ----------- -av.c -av_store() - Storing a non-undef element into an SMAGICAL array, av, - assigns the equivalent lowercase form of magic (of the first - MAGIC in the chain) to the value (with obj = av, name = 0 and - namlen = array index). - -gv.c -gv_init() - Initialising gv assigns '*' magic to it with obj = gv, name = - GvNAME and namlen = GvNAMELEN. -gv_fetchpv() - @ISA gets 'I' magic with obj = gv, zero name and namlen. - %OVERLOAD gets 'A' magic with obj = gv, zero name and namlen. - $1 to $9, $&, $`, $', $+ get '\0' magic with obj = gv, - name = GvNAME and namlen = len ( = 1 presumably). -Gv_AMupdate() - Stashes for overload magic seem to get 'c' magic with obj = 0, - name = &amt and namlen = sizeof(amt). -hv_magic(hv, gv, how) - Gives magic how to hv with obj = gv and zero name and namlen. - -mg.c -mg_copy(sv, nsv, key, klen) - Traverses the magic chain of sv. Upper case forms of magic - (only) are copied across to nsv, preserving obj but using - name = key and namlen = klen. -magic_setpos() - LvTARG of a PVLV gets 'g' magic with obj = name = 0 and namlen = pos. - -op.c -mod() - PVLV operators give magic to their targs with - obj = name = namlen = 0. OP_POS gives '.', OP_VEC gives 'v' - and OP_SUBSTR gives 'x'. - -perl.c -magicname(sym, name, namlen) - Fetches/creates a GV with name sym and gives it '\0' magic - with obj = gv, name and namlen as passed. -init_postdump_symbols() - Elements of the environment get given SVs with 'e' magic. - obj = sv and name and namlen point to the actual string - within env. - -pp.c -pp_av2arylen() - $#foo gives '#' magic to the new SV with obj = av and - name = namlen = 0. -pp_study() - SV gets 'g' magic with obj = name = namlen = 0. -pp_substr() - PVLV gets 'x' magic with obj = name = namlen = 0. -pp_vec() - PVLV gets 'x' magic with obj = name = namlen = 0. - -pp_hot.c -pp_match() - m//g gets 'g' magic with obj = name = namlen = 0. - -pp_sys.c -pp_tie() - sv gets magic with obj = sv and name = namlen = 0. - If an HV or an AV, it gets 'P' magic, otherwise 'q' magic. -pp_dbmopen() - 'P' magic for the HV just as with pp_tie(). -pp_sysread() - If tainting, the buffer SV gets 't' magic with - obj = name = namlen = 0. - -sv.c -sv_setsv() - Doing sv_setsv(dstr, gv) gives '*' magic to dstr with - obj = dstr, name = GvNAME, namlen = GvNAMELEN. - -util.c -fbm_compile() - The PVBM gets 'B' magic with obj = name = namlen = 0 and SvVALID - is set to indicate that the Boyer-Moore table is valid. - magic_setbm() just clears the SvVALID flag. - -hv_magic() ----------- - -gv.c -gv_fetchfile() - With perldb, the HV of a gvfile gv gets 'L' magic with obj = gv. -gv_fetchpv() - %SIG gets 'S' magic with obj = siggv. -init_postdump_symbols() - %ENV gets 'E' magic with obj = envgv. diff --git a/contrib/perl5/ext/B/ramblings/reg.alloc b/contrib/perl5/ext/B/ramblings/reg.alloc deleted file mode 100644 index 7fd69f2..0000000 --- a/contrib/perl5/ext/B/ramblings/reg.alloc +++ /dev/null @@ -1,32 +0,0 @@ -while ($i--) { - foo(); -} -exit - - PP code if i an int register if i an int but not a - (i.e. can't be register (i.e. can be - implicitly invalidated) implicitly invalidated) - nextstate - enterloop - - - loop: - gvsv GV (0xe6078) *i validates i validates i - postdec invalidates $i invalidates $i - and if_false goto out; - i valid; $i invalid i valid; $i invalid - - i valid; $i invalid i valid; $i invalid - nextstate - pushmark - gv GV (0xe600c) *foo - entersub validates $i; invals i - - unstack - goto loop: - - i valid; $i invalid - out: - leaveloop - nextstate - exit diff --git a/contrib/perl5/ext/B/ramblings/runtime.porting b/contrib/perl5/ext/B/ramblings/runtime.porting deleted file mode 100644 index d58b011..0000000 --- a/contrib/perl5/ext/B/ramblings/runtime.porting +++ /dev/null @@ -1,357 +0,0 @@ -Notes on porting the perl runtime PP engine. -Importance: 1 = who cares?, 10 = vital -Difficulty: 1 = trivial, 10 = very difficult. Level assumes a -reasonable implementation of the SV and OP API already ported. - -OP Import Diff Comments -null 10 1 -stub 10 1 -scalar 10 1 -pushmark 10 1 PUSHMARK -wantarray 7 3 cxstack, dopoptosub -const 10 1 -gvsv 10 1 save_scalar -gv 10 1 -gelem 3 3 -padsv 10 2 SAVECLEARSV, provide_ref -padav 10 2 -padhv 10 2 -padany 1 1 -pushre 7 3 pushes an op. Blech. -rv2gv 6 5 -rv2sv 10 4 -av2arylen 7 3 sv_magic -rv2cv 8 5 sv_2cv -anoncode 7 6 cv_clone -prototype 4 4 sv_2cv -refgen 8 3 -srefgen 8 2 -ref 8 3 -bless 7 3 -backtick 5 4 -glob 5 2 do_readline -readline 8 2 do_readline -rcatline 8 2 -regcmaybe 8 1 -regcreset 8 1 -regcomp 8 9 pregcomp -match 8 10 -qr 8 1 -subst 8 10 -substcont 8 7 -trans 7 4 do_trans -sassign 10 3 mg_find, SvSETMAGIC -aassign 10 5 -chop 8 3 do_chop -schop 8 3 do_chop -chomp 8 3 do_chomp -schomp 8 3 do_chomp -defined 10 2 -undef 10 3 -study 4 5 -pos 8 3 PVLV, mg_find -preinc 10 2 sv_inc, SvSETMAGIC -i_preinc -predec 10 2 sv_dec, SvSETMAGIC -i_predec -postinc 10 2 sv_dec, SvSETMAGIC -i_postinc -postdec 10 2 sv_dec, SvSETMAGIC -i_postdec -pow 10 1 -multiply 10 1 -i_multiply 10 1 -divide 10 2 -i_divide 10 1 -modulo 10 2 -i_modulo 10 1 -repeat 6 4 -add 10 1 -i_add 10 1 -subtract 10 1 -i_subtract 10 1 -concat 10 2 mg_get -stringify 10 2 sv_setpvn -left_shift 10 1 -right_shift 10 1 -lt 10 1 -i_lt 10 1 -gt 10 1 -i_gt 10 1 -le 10 1 -i_le 10 1 -ge 10 1 -i_ge 10 1 -eq 10 1 -i_eq 10 1 -ne 10 1 -i_ne 10 1 -ncmp 10 1 -i_ncmp 10 1 -slt 10 2 -sgt 10 2 -sle 10 2 -sge 10 2 -seq 10 2 sv_eq -sne 10 2 -scmp 10 2 -bit_and 10 2 -bit_xor 10 2 -bit_or 10 2 -negate 10 3 -i_negate 10 1 -not 10 1 -complement 10 3 -atan2 6 1 -sin 6 1 -cos 6 1 -rand 5 2 -srand 5 2 -exp 6 1 -log 6 2 -sqrt 6 2 -int 10 2 -hex 9 2 -oct 9 2 -abs 10 1 -length 10 1 -substr 10 4 PVLV -vec 5 4 -index 9 3 -rindex 9 3 -sprintf 9 4 do_sprintf -formline 6 7 -ord 6 2 -chr 6 2 -crypt 3 2 -ucfirst 6 2 -lcfirst 6 2 -uc 6 2 -lc 6 2 -quotemeta 6 3 -rv2av 10 3 save_svref, mg_get, save_ary -aelemfast 10 2 av_fetch -aelem 10 3 -aslice 9 4 -each 10 3 hv_iternext -values 10 3 do_kv -keys 10 3 do_kv -delete 10 3 -exists 10 3 -rv2hv 10 3 save_svref, mg_get, save_ary, do_kv -helem 10 3 save_svref, provide_ref -hslice 9 4 -unpack 9 6 lengthy -pack 9 6 lengthy -split 9 9 -join 10 4 do_join -list 10 2 -lslice 9 4 -anonlist 10 2 -anonhash 10 3 -splice 9 6 -push 10 2 -pop 10 2 -shift 10 2 -unshift 10 2 -sort 6 7 -reverse 9 4 -grepstart 6 5 modifies flow of control -grepwhile 6 5 modifies flow of control -mapstart 1 1 -mapwhile 6 5 modifies flow of control -range 7 3 modifies flow of control -flip 7 4 modifies flow of control -flop 7 4 modifies flow of control -and 10 3 modifies flow of control -or 10 3 modifies flow of control -xor -cond_expr 10 3 modifies flow of control -andassign 7 3 modifies flow of control -orassign 7 3 modifies flow of control -method 8 5 -entersub 10 7 -leavesub 10 5 -leavesublv -caller 2 8 -warn 9 3 -die 9 3 -reset 2 2 -lineseq 1 1 -nextstate 10 1 Update stack_sp from cxstack. FREETMPS. -dbstate 3 7 -unstack -enter 10 3 cxstack, ENTER, SAVETMPS, PUSHBLOCK -leave 10 3 cxstack, SAVETMPS, LEAVE, POPBLOCK -scope 1 1 -enteriter 9 4 cxstack -iter 9 3 cxstack -enterloop 10 4 -leaveloop 10 4 -return 10 5 -last 9 6 -next 9 6 -redo 9 6 -dump 1 9 pp_goto -goto 6 9 -exit 9 2 my_exit -open 9 5 do_open -close 9 3 do_close -pipe_op 7 4 -fileno 9 2 -umask 4 2 -binmode 4 2 -tie 5 5 pp_entersub -untie 5 2 sv_unmagic -tied 5 2 -dbmopen 4 5 -dbmclose 4 2 -sselect 4 4 -select 7 3 -getc 7 2 -read 8 2 pp_sysread -enterwrite 4 4 doform -leavewrite 4 5 -prtf 4 4 do_sprintf -print 8 6 -sysopen 8 2 -sysseek 8 2 -sysread 8 4 -syswrite 8 4 pp_send -send 8 4 -recv 8 4 pp_sysread -eof 9 2 -tell 9 3 -seek 9 2 -truncate 8 3 -fcntl 8 4 pp_ioctl -ioctl 8 4 -flock 8 2 -socket 5 3 -sockpair 5 3 -bind 5 3 -connect 5 3 -listen 5 3 -accept 5 3 -shutdown 5 2 -gsockopt 5 3 pp_ssockopt -ssockopt 5 3 -getsockname 5 3 pp_getpeername -getpeername 5 3 -lstat 5 4 pp_stat -stat 5 4 lengthy -ftrread 5 2 cando -ftrwrite 5 2 cando -ftrexec 5 2 cando -fteread 5 2 cando -ftewrite 5 2 cando -fteexec 5 2 cando -ftis 5 2 cando -fteowned 5 2 cando -ftrowned 5 2 cando -ftzero 5 2 cando -ftsize 5 2 cando -ftmtime 5 2 cando -ftatime 5 2 cando -ftctime 5 2 cando -ftsock 5 2 cando -ftchr 5 2 cando -ftblk 5 2 cando -ftfile 5 2 cando -ftdir 5 2 cando -ftpipe 5 2 cando -ftlink 5 2 cando -ftsuid 5 2 cando -ftsgid 5 2 cando -ftsvtx 5 2 cando -fttty 5 2 cando -fttext 5 4 -ftbinary 5 4 fttext -chdir -chown -chroot -unlink -chmod -utime -rename -link -symlink -readlink -mkdir -rmdir -open_dir -readdir -telldir -seekdir -rewinddir -closedir -fork -wait -waitpid -system -exec -kill -getppid -getpgrp -setpgrp -getpriority -setpriority -time -tms -localtime -gmtime -alarm -sleep -shmget -shmctl -shmread -shmwrite -msgget -msgctl -msgsnd -msgrcv -semget -semctl -semop -require 6 9 doeval -dofile 6 9 doeval -entereval 6 9 doeval -leaveeval 6 5 -entertry 7 4 modifies flow of control -leavetry 7 3 -ghbyname -ghbyaddr -ghostent -gnbyname -gnbyaddr -gnetent -gpbyname -gpbynumber -gprotoent -gsbyname -gsbyport -gservent -shostent -snetent -sprotoent -sservent -ehostent -enetent -eprotoent -eservent -gpwnam -gpwuid -gpwent -spwent -epwent -ggrnam -ggrgid -ggrent -sgrent -egrent -getlogin -syscall -lock 6 1 -threadsv 6 2 unused if not USE_THREADS -setstate 1 1 currently unused anywhere -method_named 10 2 diff --git a/contrib/perl5/ext/B/typemap b/contrib/perl5/ext/B/typemap deleted file mode 100644 index bafba1c..0000000 --- a/contrib/perl5/ext/B/typemap +++ /dev/null @@ -1,69 +0,0 @@ -TYPEMAP - -B::OP T_OP_OBJ -B::UNOP T_OP_OBJ -B::BINOP T_OP_OBJ -B::LOGOP T_OP_OBJ -B::LISTOP T_OP_OBJ -B::PMOP T_OP_OBJ -B::SVOP T_OP_OBJ -B::PADOP T_OP_OBJ -B::PVOP T_OP_OBJ -B::CVOP T_OP_OBJ -B::LOOP T_OP_OBJ -B::COP T_OP_OBJ - -B::SV T_SV_OBJ -B::PV T_SV_OBJ -B::IV T_SV_OBJ -B::NV T_SV_OBJ -B::PVMG T_SV_OBJ -B::PVLV T_SV_OBJ -B::BM T_SV_OBJ -B::RV T_SV_OBJ -B::GV T_SV_OBJ -B::CV T_SV_OBJ -B::HV T_SV_OBJ -B::AV T_SV_OBJ -B::IO T_SV_OBJ - -B::MAGIC T_MG_OBJ -SSize_t T_IV -STRLEN T_IV -PADOFFSET T_UV - -INPUT -T_OP_OBJ - if (SvROK($arg)) { - IV tmp = SvIV((SV*)SvRV($arg)); - $var = INT2PTR($type,tmp); - } - else - croak(\"$var is not a reference\") - -T_SV_OBJ - if (SvROK($arg)) { - IV tmp = SvIV((SV*)SvRV($arg)); - $var = INT2PTR($type,tmp); - } - else - croak(\"$var is not a reference\") - -T_MG_OBJ - if (SvROK($arg)) { - IV tmp = SvIV((SV*)SvRV($arg)); - $var = INT2PTR($type,tmp); - } - else - croak(\"$var is not a reference\") - -OUTPUT -T_OP_OBJ - sv_setiv(newSVrv($arg, cc_opclassname(aTHX_ (OP*)$var)), PTR2IV($var)); - -T_SV_OBJ - make_sv_object(aTHX_ ($arg), (SV*)($var)); - - -T_MG_OBJ - sv_setiv(newSVrv($arg, "B::MAGIC"), PTR2IV($var)); diff --git a/contrib/perl5/ext/ByteLoader/ByteLoader.pm b/contrib/perl5/ext/ByteLoader/ByteLoader.pm deleted file mode 100644 index 9c8c84d..0000000 --- a/contrib/perl5/ext/ByteLoader/ByteLoader.pm +++ /dev/null @@ -1,40 +0,0 @@ -package ByteLoader; - -use XSLoader (); - -$VERSION = 0.04; - -XSLoader::load 'ByteLoader', $VERSION; - -# Preloaded methods go here. - -1; -__END__ - -=head1 NAME - -ByteLoader - load byte compiled perl code - -=head1 SYNOPSIS - - use ByteLoader 0.04; - <byte code> - - use ByteLoader 0.04; - <byte code> - -=head1 DESCRIPTION - -This module is used to load byte compiled perl code. It uses the source -filter mechanism to read the byte code and insert it into the compiled -code at the appropriate point. - -=head1 AUTHOR - -Tom Hughes <tom@compton.nu> based on the ideas of Tim Bunce and others. - -=head1 SEE ALSO - -perl(1). - -=cut diff --git a/contrib/perl5/ext/ByteLoader/ByteLoader.xs b/contrib/perl5/ext/ByteLoader/ByteLoader.xs deleted file mode 100644 index 05b795c..0000000 --- a/contrib/perl5/ext/ByteLoader/ByteLoader.xs +++ /dev/null @@ -1,131 +0,0 @@ -#define PERL_NO_GET_CONTEXT -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" -#include "byterun.h" - -/* Something arbitary for a buffer size */ -#define BYTELOADER_BUFFER 8096 - -int -bl_getc(struct byteloader_fdata *data) -{ - dTHX; - if (SvCUR(data->datasv) <= data->next_out) { - int result; - /* Run out of buffered data, so attempt to read some more */ - *(SvPV_nolen (data->datasv)) = '\0'; - SvCUR_set (data->datasv, 0); - data->next_out = 0; - result = FILTER_READ (data->idx + 1, data->datasv, BYTELOADER_BUFFER); - - /* Filter returned error, or we got EOF and no data, then return EOF. - Not sure if filter is allowed to return EOF and add data simultaneously - Think not, but will bullet proof against it. */ - if (result < 0 || SvCUR(data->datasv) == 0) - return EOF; - /* Else there must be at least one byte present, which is good enough */ - } - - return *((char *) SvPV_nolen (data->datasv) + data->next_out++); -} - -int -bl_read(struct byteloader_fdata *data, char *buf, size_t size, size_t n) -{ - dTHX; - char *start; - STRLEN len; - size_t wanted = size * n; - - start = SvPV (data->datasv, len); - if (len < (data->next_out + wanted)) { - int result; - - /* Shuffle data to start of buffer */ - len -= data->next_out; - if (len) { - memmove (start, start + data->next_out, len + 1); - SvCUR_set (data->datasv, len); - } else { - *start = '\0'; /* Avoid call to memmove. */ - SvCUR_set (data->datasv, 0); - } - data->next_out = 0; - - /* Attempt to read more data. */ - do { - result = FILTER_READ (data->idx + 1, data->datasv, BYTELOADER_BUFFER); - - start = SvPV (data->datasv, len); - } while (result > 0 && len < wanted); - /* Loop while not (EOF || error) and short reads */ - - /* If not enough data read, truncate copy */ - if (wanted > len) - wanted = len; - } - - if (wanted > 0) { - memcpy (buf, start + data->next_out, wanted); - data->next_out += wanted; - wanted /= size; - } - return (int) wanted; -} - -static I32 -byteloader_filter(pTHXo_ int idx, SV *buf_sv, int maxlen) -{ - OP *saveroot = PL_main_root; - OP *savestart = PL_main_start; - struct byteloader_state bstate; - struct byteloader_fdata data; - - data.next_out = 0; - data.datasv = FILTER_DATA(idx); - data.idx = idx; - - bstate.bs_fdata = &data; - bstate.bs_obj_list = Null(void**); - bstate.bs_obj_list_fill = -1; - bstate.bs_sv = Nullsv; - bstate.bs_iv_overflows = 0; - - byterun(aTHXo_ &bstate); - - if (PL_in_eval) { - OP *o; - - PL_eval_start = PL_main_start; - - o = newSVOP(OP_CONST, 0, newSViv(1)); - PL_eval_root = newLISTOP(OP_LINESEQ, 0, PL_main_root, o); - PL_main_root->op_next = o; - PL_eval_root = newUNOP(OP_LEAVEEVAL, 0, PL_eval_root); - o->op_next = PL_eval_root; - - PL_main_root = saveroot; - PL_main_start = savestart; - } - - return 0; -} - -MODULE = ByteLoader PACKAGE = ByteLoader - -PROTOTYPES: ENABLE - -void -import(...) - PREINIT: - SV *sv = newSVpvn ("", 0); - PPCODE: - if (!sv) - croak ("Could not allocate ByteLoader buffers"); - filter_add(byteloader_filter, sv); - -void -unimport(...) - PPCODE: - filter_del(byteloader_filter); diff --git a/contrib/perl5/ext/ByteLoader/Makefile.PL b/contrib/perl5/ext/ByteLoader/Makefile.PL deleted file mode 100644 index c3cfcc7..0000000 --- a/contrib/perl5/ext/ByteLoader/Makefile.PL +++ /dev/null @@ -1,9 +0,0 @@ -use ExtUtils::MakeMaker; - -WriteMakefile( - NAME => 'ByteLoader', - VERSION_FROM => 'ByteLoader.pm', - XSPROTOARG => '-noprototypes', - MAN3PODS => {}, # Pods will be built by installman. - OBJECT => 'byterun$(OBJ_EXT) ByteLoader$(OBJ_EXT)', -); diff --git a/contrib/perl5/ext/ByteLoader/bytecode.h b/contrib/perl5/ext/ByteLoader/bytecode.h deleted file mode 100644 index c6acd28..0000000 --- a/contrib/perl5/ext/ByteLoader/bytecode.h +++ /dev/null @@ -1,257 +0,0 @@ -typedef char *pvcontents; -typedef char *strconst; -typedef U32 PV; -typedef char *op_tr_array; -typedef int comment_t; -typedef SV *svindex; -typedef OP *opindex; -typedef char *pvindex; -typedef IV IV64; - -#define BGET_FREAD(argp, len, nelem) \ - bl_read(bstate->bs_fdata,(char*)(argp),(len),(nelem)) -#define BGET_FGETC() bl_getc(bstate->bs_fdata) - -#define BGET_U32(arg) \ - BGET_FREAD(&arg, sizeof(U32), 1) -#define BGET_I32(arg) \ - BGET_FREAD(&arg, sizeof(I32), 1) -#define BGET_U16(arg) \ - BGET_FREAD(&arg, sizeof(U16), 1) -#define BGET_U8(arg) arg = BGET_FGETC() - -#define BGET_PV(arg) STMT_START { \ - BGET_U32(arg); \ - if (arg) { \ - New(666, bstate->bs_pv.xpv_pv, arg, char); \ - bl_read(bstate->bs_fdata, (void*)bstate->bs_pv.xpv_pv, arg, 1); \ - bstate->bs_pv.xpv_len = arg; \ - bstate->bs_pv.xpv_cur = arg - 1; \ - } else { \ - bstate->bs_pv.xpv_pv = 0; \ - bstate->bs_pv.xpv_len = 0; \ - bstate->bs_pv.xpv_cur = 0; \ - } \ - } STMT_END - -#ifdef BYTELOADER_LOG_COMMENTS -# define BGET_comment_t(arg) \ - STMT_START { \ - char buf[1024]; \ - int i = 0; \ - do { \ - arg = BGET_FGETC(); \ - buf[i++] = (char)arg; \ - } while (arg != '\n' && arg != EOF); \ - buf[i] = '\0'; \ - PerlIO_printf(PerlIO_stderr(), "%s", buf); \ - } STMT_END -#else -# define BGET_comment_t(arg) \ - do { arg = BGET_FGETC(); } while (arg != '\n' && arg != EOF) -#endif - -/* - * In the following, sizeof(IV)*4 is just a way of encoding 32 on 64-bit-IV - * machines such that 32-bit machine compilers don't whine about the shift - * count being too high even though the code is never reached there. - */ -#define BGET_IV64(arg) STMT_START { \ - U32 hi, lo; \ - BGET_U32(hi); \ - BGET_U32(lo); \ - if (sizeof(IV) == 8) \ - arg = ((IV)hi << (sizeof(IV)*4) | (IV)lo); \ - else if (((I32)hi == -1 && (I32)lo < 0) \ - || ((I32)hi == 0 && (I32)lo >= 0)) { \ - arg = (I32)lo; \ - } \ - else { \ - bstate->bs_iv_overflows++; \ - arg = 0; \ - } \ - } STMT_END - -#define BGET_op_tr_array(arg) do { \ - unsigned short *ary; \ - int i; \ - New(666, ary, 256, unsigned short); \ - BGET_FREAD(ary, sizeof(unsigned short), 256); \ - arg = (char *) ary; \ - } while (0) - -#define BGET_pvcontents(arg) arg = bstate->bs_pv.xpv_pv -#define BGET_strconst(arg) STMT_START { \ - for (arg = PL_tokenbuf; (*arg = BGET_FGETC()); arg++) /* nothing */; \ - arg = PL_tokenbuf; \ - } STMT_END - -#define BGET_NV(arg) STMT_START { \ - char *str; \ - BGET_strconst(str); \ - arg = Atof(str); \ - } STMT_END - -#define BGET_objindex(arg, type) STMT_START { \ - BGET_U32(ix); \ - arg = (type)bstate->bs_obj_list[ix]; \ - } STMT_END -#define BGET_svindex(arg) BGET_objindex(arg, svindex) -#define BGET_opindex(arg) BGET_objindex(arg, opindex) -#define BGET_pvindex(arg) STMT_START { \ - BGET_objindex(arg, pvindex); \ - arg = arg ? savepv(arg) : arg; \ - } STMT_END - -#define BSET_ldspecsv(sv, arg) sv = specialsv_list[arg] -#define BSET_stpv(pv, arg) STMT_START { \ - BSET_OBJ_STORE(pv, arg); \ - SAVEFREEPV(pv); \ - } STMT_END - -#define BSET_sv_refcnt_add(svrefcnt, arg) svrefcnt += arg -#define BSET_gp_refcnt_add(gprefcnt, arg) gprefcnt += arg -#define BSET_gp_share(sv, arg) STMT_START { \ - gp_free((GV*)sv); \ - GvGP(sv) = GvGP(arg); \ - } STMT_END - -#define BSET_gv_fetchpv(sv, arg) sv = (SV*)gv_fetchpv(arg, TRUE, SVt_PV) -#define BSET_gv_stashpv(sv, arg) sv = (SV*)gv_stashpv(arg, TRUE) -#define BSET_sv_magic(sv, arg) sv_magic(sv, Nullsv, arg, 0, 0) -#define BSET_mg_pv(mg, arg) mg->mg_ptr = arg; mg->mg_len = bstate->bs_pv.xpv_cur -#define BSET_sv_upgrade(sv, arg) (void)SvUPGRADE(sv, arg) -#define BSET_xpv(sv) do { \ - SvPV_set(sv, bstate->bs_pv.xpv_pv); \ - SvCUR_set(sv, bstate->bs_pv.xpv_cur); \ - SvLEN_set(sv, bstate->bs_pv.xpv_len); \ - } while (0) -#define BSET_av_extend(sv, arg) av_extend((AV*)sv, arg) - -#define BSET_av_push(sv, arg) av_push((AV*)sv, arg) -#define BSET_hv_store(sv, arg) \ - hv_store((HV*)sv, bstate->bs_pv.xpv_pv, bstate->bs_pv.xpv_cur, arg, 0) -#define BSET_pv_free(pv) Safefree(pv.xpv_pv) -#define BSET_pregcomp(o, arg) \ - ((PMOP*)o)->op_pmregexp = arg ? \ - CALLREGCOMP(aTHX_ arg, arg + bstate->bs_pv.xpv_cur, ((PMOP*)o)) : 0 -#define BSET_newsv(sv, arg) \ - STMT_START { \ - sv = (arg == SVt_PVAV ? (SV*)newAV() : \ - arg == SVt_PVHV ? (SV*)newHV() : \ - NEWSV(666,0)); \ - SvUPGRADE(sv, arg); \ - } STMT_END -#define BSET_newop(o, arg) ((o = (OP*)safemalloc(optype_size[arg])), \ - memzero((char*)o,optype_size[arg])) -#define BSET_newopn(o, arg) STMT_START { \ - OP *oldop = o; \ - BSET_newop(o, arg); \ - oldop->op_next = o; \ - } STMT_END - -#define BSET_ret(foo) STMT_START { \ - Safefree(bstate->bs_obj_list); \ - return; \ - } STMT_END - -/* - * Kludge special-case workaround for OP_MAPSTART - * which needs the ppaddr for OP_GREPSTART. Blech. - */ -#define BSET_op_type(o, arg) STMT_START { \ - o->op_type = arg; \ - if (arg == OP_MAPSTART) \ - arg = OP_GREPSTART; \ - o->op_ppaddr = PL_ppaddr[arg]; \ - } STMT_END -#define BSET_op_ppaddr(o, arg) Perl_croak(aTHX_ "op_ppaddr not yet implemented") -#define BSET_curpad(pad, arg) STMT_START { \ - PL_comppad = (AV *)arg; \ - pad = AvARRAY(arg); \ - } STMT_END -/* this works now that Sarathy's changed the CopFILE_set macro to do the SvREFCNT_inc() - -- BKS 6-2-2000 */ -#define BSET_cop_file(cop, arg) CopFILE_set(cop,arg) -#define BSET_cop_line(cop, arg) CopLINE_set(cop,arg) -#define BSET_cop_stashpv(cop, arg) CopSTASHPV_set(cop,arg) - -/* this is simply stolen from the code in newATTRSUB() */ -#define BSET_push_begin(ary,cv) \ - STMT_START { \ - I32 oldscope = PL_scopestack_ix; \ - ENTER; \ - SAVECOPFILE(&PL_compiling); \ - SAVECOPLINE(&PL_compiling); \ - save_svref(&PL_rs); \ - sv_setsv(PL_rs, PL_nrs); \ - if (!PL_beginav) \ - PL_beginav = newAV(); \ - av_push(PL_beginav, cv); \ - call_list(oldscope, PL_beginav); \ - PL_curcop = &PL_compiling; \ - PL_compiling.op_private = PL_hints; \ - LEAVE; \ - } STMT_END -#define BSET_push_init(ary,cv) \ - STMT_START { \ - av_unshift((PL_initav ? PL_initav : (PL_initav = newAV(), PL_initav)), 1); \ - av_store(PL_initav, 0, cv); \ - } STMT_END -#define BSET_push_end(ary,cv) \ - STMT_START { \ - av_unshift((PL_endav ? PL_endav : (PL_endav = newAV(), PL_endav)), 1); \ - av_store(PL_endav, 0, cv); \ - } STMT_END -#define BSET_OBJ_STORE(obj, ix) \ - (I32)ix > bstate->bs_obj_list_fill ? \ - bset_obj_store(aTHXo_ bstate, obj, (I32)ix) : (bstate->bs_obj_list[ix] = obj) - -/* NOTE: the bytecode header only sanity-checks the bytecode. If a script cares about - * what version of Perl it's being called under, it should do a 'require 5.6.0' or - * equivalent. However, since the header includes checks requiring an exact match in - * ByteLoader versions (we can't guarantee forward compatibility), you don't - * need to specify one: - * use ByteLoader; - * is all you need. - * -- BKS, June 2000 -*/ - -#define HEADER_FAIL(f) \ - Perl_croak(aTHX_ "Invalid bytecode for this architecture: " f) -#define HEADER_FAIL1(f, arg1) \ - Perl_croak(aTHX_ "Invalid bytecode for this architecture: " f, arg1) -#define HEADER_FAIL2(f, arg1, arg2) \ - Perl_croak(aTHX_ "Invalid bytecode for this architecture: " f, arg1, arg2) - -#define BYTECODE_HEADER_CHECK \ - STMT_START { \ - U32 sz = 0; \ - strconst str; \ - \ - BGET_U32(sz); /* Magic: 'PLBC' */ \ - if (sz != 0x43424c50) { \ - HEADER_FAIL1("bad magic (want 0x43424c50, got %#x)", (int)sz); \ - } \ - BGET_strconst(str); /* archname */ \ - if (strNE(str, ARCHNAME)) { \ - HEADER_FAIL2("wrong architecture (want %s, you have %s)",str,ARCHNAME); \ - } \ - BGET_strconst(str); /* ByteLoader version */ \ - if (strNE(str, VERSION)) { \ - HEADER_FAIL2("mismatched ByteLoader versions (want %s, you have %s)", \ - str, VERSION); \ - } \ - BGET_U32(sz); /* ivsize */ \ - if (sz != IVSIZE) { \ - HEADER_FAIL("different IVSIZE"); \ - } \ - BGET_U32(sz); /* ptrsize */ \ - if (sz != PTRSIZE) { \ - HEADER_FAIL("different PTRSIZE"); \ - } \ - BGET_strconst(str); /* byteorder */ \ - if (strNE(str, STRINGIFY(BYTEORDER))) { \ - HEADER_FAIL("different byteorder"); \ - } \ - } STMT_END diff --git a/contrib/perl5/ext/ByteLoader/byterun.c b/contrib/perl5/ext/ByteLoader/byterun.c deleted file mode 100644 index 71cd8aa..0000000 --- a/contrib/perl5/ext/ByteLoader/byterun.c +++ /dev/null @@ -1,916 +0,0 @@ -/* - * Copyright (c) 1996-1999 Malcolm Beattie - * - * You may distribute under the terms of either the GNU General Public - * License or the Artistic License, as specified in the README file. - * - */ -/* - * This file is autogenerated from bytecode.pl. Changes made here will be lost. - */ - -#define PERL_NO_GET_CONTEXT -#include "EXTERN.h" -#include "perl.h" -#define NO_XSLOCKS -#include "XSUB.h" - -#ifdef PERL_OBJECT -#undef CALL_FPTR -#define CALL_FPTR(fptr) (pPerl->*fptr) -#undef PL_ppaddr -#define PL_ppaddr (*get_ppaddr()) -#endif - -#include "byterun.h" -#include "bytecode.h" - - -static const int optype_size[] = { - sizeof(OP), - sizeof(UNOP), - sizeof(BINOP), - sizeof(LOGOP), - sizeof(LISTOP), - sizeof(PMOP), - sizeof(SVOP), - sizeof(PADOP), - sizeof(PVOP), - sizeof(LOOP), - sizeof(COP) -}; - -void * -bset_obj_store(pTHXo_ struct byteloader_state *bstate, void *obj, I32 ix) -{ - if (ix > bstate->bs_obj_list_fill) { - Renew(bstate->bs_obj_list, ix + 32, void*); - bstate->bs_obj_list_fill = ix + 31; - } - bstate->bs_obj_list[ix] = obj; - return obj; -} - -void -byterun(pTHXo_ register struct byteloader_state *bstate) -{ - register int insn; - U32 ix; - SV *specialsv_list[6]; - - BYTECODE_HEADER_CHECK; /* croak if incorrect platform */ - New(666, bstate->bs_obj_list, 32, void*); /* set op objlist */ - bstate->bs_obj_list_fill = 31; - - specialsv_list[0] = Nullsv; - specialsv_list[1] = &PL_sv_undef; - specialsv_list[2] = &PL_sv_yes; - specialsv_list[3] = &PL_sv_no; - specialsv_list[4] = pWARN_ALL; - specialsv_list[5] = pWARN_NONE; - - while ((insn = BGET_FGETC()) != EOF) { - switch (insn) { - case INSN_COMMENT: /* 35 */ - { - comment_t arg; - BGET_comment_t(arg); - arg = arg; - break; - } - case INSN_NOP: /* 10 */ - { - break; - } - case INSN_RET: /* 0 */ - { - BSET_ret(none); - break; - } - case INSN_LDSV: /* 1 */ - { - svindex arg; - BGET_svindex(arg); - bstate->bs_sv = arg; - break; - } - case INSN_LDOP: /* 2 */ - { - opindex arg; - BGET_opindex(arg); - PL_op = arg; - break; - } - case INSN_STSV: /* 3 */ - { - U32 arg; - BGET_U32(arg); - BSET_OBJ_STORE(bstate->bs_sv, arg); - break; - } - case INSN_STOP: /* 4 */ - { - U32 arg; - BGET_U32(arg); - BSET_OBJ_STORE(PL_op, arg); - break; - } - case INSN_STPV: /* 5 */ - { - U32 arg; - BGET_U32(arg); - BSET_stpv(bstate->bs_pv.xpv_pv, arg); - break; - } - case INSN_LDSPECSV: /* 6 */ - { - U8 arg; - BGET_U8(arg); - BSET_ldspecsv(bstate->bs_sv, arg); - break; - } - case INSN_NEWSV: /* 7 */ - { - U8 arg; - BGET_U8(arg); - BSET_newsv(bstate->bs_sv, arg); - break; - } - case INSN_NEWOP: /* 8 */ - { - U8 arg; - BGET_U8(arg); - BSET_newop(PL_op, arg); - break; - } - case INSN_NEWOPN: /* 9 */ - { - U8 arg; - BGET_U8(arg); - BSET_newopn(PL_op, arg); - break; - } - case INSN_NEWPV: /* 11 */ - { - PV arg; - BGET_PV(arg); - break; - } - case INSN_PV_CUR: /* 12 */ - { - STRLEN arg; - BGET_U32(arg); - bstate->bs_pv.xpv_cur = arg; - break; - } - case INSN_PV_FREE: /* 13 */ - { - BSET_pv_free(bstate->bs_pv); - break; - } - case INSN_SV_UPGRADE: /* 14 */ - { - char arg; - BGET_U8(arg); - BSET_sv_upgrade(bstate->bs_sv, arg); - break; - } - case INSN_SV_REFCNT: /* 15 */ - { - U32 arg; - BGET_U32(arg); - SvREFCNT(bstate->bs_sv) = arg; - break; - } - case INSN_SV_REFCNT_ADD: /* 16 */ - { - I32 arg; - BGET_I32(arg); - BSET_sv_refcnt_add(SvREFCNT(bstate->bs_sv), arg); - break; - } - case INSN_SV_FLAGS: /* 17 */ - { - U32 arg; - BGET_U32(arg); - SvFLAGS(bstate->bs_sv) = arg; - break; - } - case INSN_XRV: /* 18 */ - { - svindex arg; - BGET_svindex(arg); - SvRV(bstate->bs_sv) = arg; - break; - } - case INSN_XPV: /* 19 */ - { - BSET_xpv(bstate->bs_sv); - break; - } - case INSN_XIV32: /* 20 */ - { - I32 arg; - BGET_I32(arg); - SvIVX(bstate->bs_sv) = arg; - break; - } - case INSN_XIV64: /* 21 */ - { - IV64 arg; - BGET_IV64(arg); - SvIVX(bstate->bs_sv) = arg; - break; - } - case INSN_XNV: /* 22 */ - { - NV arg; - BGET_NV(arg); - SvNVX(bstate->bs_sv) = arg; - break; - } - case INSN_XLV_TARGOFF: /* 23 */ - { - STRLEN arg; - BGET_U32(arg); - LvTARGOFF(bstate->bs_sv) = arg; - break; - } - case INSN_XLV_TARGLEN: /* 24 */ - { - STRLEN arg; - BGET_U32(arg); - LvTARGLEN(bstate->bs_sv) = arg; - break; - } - case INSN_XLV_TARG: /* 25 */ - { - svindex arg; - BGET_svindex(arg); - LvTARG(bstate->bs_sv) = arg; - break; - } - case INSN_XLV_TYPE: /* 26 */ - { - char arg; - BGET_U8(arg); - LvTYPE(bstate->bs_sv) = arg; - break; - } - case INSN_XBM_USEFUL: /* 27 */ - { - I32 arg; - BGET_I32(arg); - BmUSEFUL(bstate->bs_sv) = arg; - break; - } - case INSN_XBM_PREVIOUS: /* 28 */ - { - U16 arg; - BGET_U16(arg); - BmPREVIOUS(bstate->bs_sv) = arg; - break; - } - case INSN_XBM_RARE: /* 29 */ - { - U8 arg; - BGET_U8(arg); - BmRARE(bstate->bs_sv) = arg; - break; - } - case INSN_XFM_LINES: /* 30 */ - { - I32 arg; - BGET_I32(arg); - FmLINES(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_LINES: /* 31 */ - { - long arg; - BGET_I32(arg); - IoLINES(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_PAGE: /* 32 */ - { - long arg; - BGET_I32(arg); - IoPAGE(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_PAGE_LEN: /* 33 */ - { - long arg; - BGET_I32(arg); - IoPAGE_LEN(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_LINES_LEFT: /* 34 */ - { - long arg; - BGET_I32(arg); - IoLINES_LEFT(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_TOP_NAME: /* 36 */ - { - pvcontents arg; - BGET_pvcontents(arg); - IoTOP_NAME(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_TOP_GV: /* 37 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&IoTOP_GV(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_FMT_NAME: /* 38 */ - { - pvcontents arg; - BGET_pvcontents(arg); - IoFMT_NAME(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_FMT_GV: /* 39 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&IoFMT_GV(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_BOTTOM_NAME: /* 40 */ - { - pvcontents arg; - BGET_pvcontents(arg); - IoBOTTOM_NAME(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_BOTTOM_GV: /* 41 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&IoBOTTOM_GV(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_SUBPROCESS: /* 42 */ - { - short arg; - BGET_U16(arg); - IoSUBPROCESS(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_TYPE: /* 43 */ - { - char arg; - BGET_U8(arg); - IoTYPE(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_FLAGS: /* 44 */ - { - char arg; - BGET_U8(arg); - IoFLAGS(bstate->bs_sv) = arg; - break; - } - case INSN_XCV_STASH: /* 45 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&CvSTASH(bstate->bs_sv) = arg; - break; - } - case INSN_XCV_START: /* 46 */ - { - opindex arg; - BGET_opindex(arg); - CvSTART(bstate->bs_sv) = arg; - break; - } - case INSN_XCV_ROOT: /* 47 */ - { - opindex arg; - BGET_opindex(arg); - CvROOT(bstate->bs_sv) = arg; - break; - } - case INSN_XCV_GV: /* 48 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&CvGV(bstate->bs_sv) = arg; - break; - } - case INSN_XCV_FILE: /* 49 */ - { - pvindex arg; - BGET_pvindex(arg); - CvFILE(bstate->bs_sv) = arg; - break; - } - case INSN_XCV_DEPTH: /* 50 */ - { - long arg; - BGET_I32(arg); - CvDEPTH(bstate->bs_sv) = arg; - break; - } - case INSN_XCV_PADLIST: /* 51 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&CvPADLIST(bstate->bs_sv) = arg; - break; - } - case INSN_XCV_OUTSIDE: /* 52 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&CvOUTSIDE(bstate->bs_sv) = arg; - break; - } - case INSN_XCV_FLAGS: /* 53 */ - { - U16 arg; - BGET_U16(arg); - CvFLAGS(bstate->bs_sv) = arg; - break; - } - case INSN_AV_EXTEND: /* 54 */ - { - SSize_t arg; - BGET_I32(arg); - BSET_av_extend(bstate->bs_sv, arg); - break; - } - case INSN_AV_PUSH: /* 55 */ - { - svindex arg; - BGET_svindex(arg); - BSET_av_push(bstate->bs_sv, arg); - break; - } - case INSN_XAV_FILL: /* 56 */ - { - SSize_t arg; - BGET_I32(arg); - AvFILLp(bstate->bs_sv) = arg; - break; - } - case INSN_XAV_MAX: /* 57 */ - { - SSize_t arg; - BGET_I32(arg); - AvMAX(bstate->bs_sv) = arg; - break; - } - case INSN_XAV_FLAGS: /* 58 */ - { - U8 arg; - BGET_U8(arg); - AvFLAGS(bstate->bs_sv) = arg; - break; - } - case INSN_XHV_RITER: /* 59 */ - { - I32 arg; - BGET_I32(arg); - HvRITER(bstate->bs_sv) = arg; - break; - } - case INSN_XHV_NAME: /* 60 */ - { - pvcontents arg; - BGET_pvcontents(arg); - HvNAME(bstate->bs_sv) = arg; - break; - } - case INSN_HV_STORE: /* 61 */ - { - svindex arg; - BGET_svindex(arg); - BSET_hv_store(bstate->bs_sv, arg); - break; - } - case INSN_SV_MAGIC: /* 62 */ - { - char arg; - BGET_U8(arg); - BSET_sv_magic(bstate->bs_sv, arg); - break; - } - case INSN_MG_OBJ: /* 63 */ - { - svindex arg; - BGET_svindex(arg); - SvMAGIC(bstate->bs_sv)->mg_obj = arg; - break; - } - case INSN_MG_PRIVATE: /* 64 */ - { - U16 arg; - BGET_U16(arg); - SvMAGIC(bstate->bs_sv)->mg_private = arg; - break; - } - case INSN_MG_FLAGS: /* 65 */ - { - U8 arg; - BGET_U8(arg); - SvMAGIC(bstate->bs_sv)->mg_flags = arg; - break; - } - case INSN_MG_PV: /* 66 */ - { - pvcontents arg; - BGET_pvcontents(arg); - BSET_mg_pv(SvMAGIC(bstate->bs_sv), arg); - break; - } - case INSN_XMG_STASH: /* 67 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&SvSTASH(bstate->bs_sv) = arg; - break; - } - case INSN_GV_FETCHPV: /* 68 */ - { - strconst arg; - BGET_strconst(arg); - BSET_gv_fetchpv(bstate->bs_sv, arg); - break; - } - case INSN_GV_STASHPV: /* 69 */ - { - strconst arg; - BGET_strconst(arg); - BSET_gv_stashpv(bstate->bs_sv, arg); - break; - } - case INSN_GP_SV: /* 70 */ - { - svindex arg; - BGET_svindex(arg); - GvSV(bstate->bs_sv) = arg; - break; - } - case INSN_GP_REFCNT: /* 71 */ - { - U32 arg; - BGET_U32(arg); - GvREFCNT(bstate->bs_sv) = arg; - break; - } - case INSN_GP_REFCNT_ADD: /* 72 */ - { - I32 arg; - BGET_I32(arg); - BSET_gp_refcnt_add(GvREFCNT(bstate->bs_sv), arg); - break; - } - case INSN_GP_AV: /* 73 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&GvAV(bstate->bs_sv) = arg; - break; - } - case INSN_GP_HV: /* 74 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&GvHV(bstate->bs_sv) = arg; - break; - } - case INSN_GP_CV: /* 75 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&GvCV(bstate->bs_sv) = arg; - break; - } - case INSN_GP_FILE: /* 76 */ - { - pvindex arg; - BGET_pvindex(arg); - GvFILE(bstate->bs_sv) = arg; - break; - } - case INSN_GP_IO: /* 77 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&GvIOp(bstate->bs_sv) = arg; - break; - } - case INSN_GP_FORM: /* 78 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&GvFORM(bstate->bs_sv) = arg; - break; - } - case INSN_GP_CVGEN: /* 79 */ - { - U32 arg; - BGET_U32(arg); - GvCVGEN(bstate->bs_sv) = arg; - break; - } - case INSN_GP_LINE: /* 80 */ - { - line_t arg; - BGET_U16(arg); - GvLINE(bstate->bs_sv) = arg; - break; - } - case INSN_GP_SHARE: /* 81 */ - { - svindex arg; - BGET_svindex(arg); - BSET_gp_share(bstate->bs_sv, arg); - break; - } - case INSN_XGV_FLAGS: /* 82 */ - { - U8 arg; - BGET_U8(arg); - GvFLAGS(bstate->bs_sv) = arg; - break; - } - case INSN_OP_NEXT: /* 83 */ - { - opindex arg; - BGET_opindex(arg); - PL_op->op_next = arg; - break; - } - case INSN_OP_SIBLING: /* 84 */ - { - opindex arg; - BGET_opindex(arg); - PL_op->op_sibling = arg; - break; - } - case INSN_OP_PPADDR: /* 85 */ - { - strconst arg; - BGET_strconst(arg); - BSET_op_ppaddr(PL_op->op_ppaddr, arg); - break; - } - case INSN_OP_TARG: /* 86 */ - { - PADOFFSET arg; - BGET_U32(arg); - PL_op->op_targ = arg; - break; - } - case INSN_OP_TYPE: /* 87 */ - { - OPCODE arg; - BGET_U16(arg); - BSET_op_type(PL_op, arg); - break; - } - case INSN_OP_SEQ: /* 88 */ - { - U16 arg; - BGET_U16(arg); - PL_op->op_seq = arg; - break; - } - case INSN_OP_FLAGS: /* 89 */ - { - U8 arg; - BGET_U8(arg); - PL_op->op_flags = arg; - break; - } - case INSN_OP_PRIVATE: /* 90 */ - { - U8 arg; - BGET_U8(arg); - PL_op->op_private = arg; - break; - } - case INSN_OP_FIRST: /* 91 */ - { - opindex arg; - BGET_opindex(arg); - cUNOP->op_first = arg; - break; - } - case INSN_OP_LAST: /* 92 */ - { - opindex arg; - BGET_opindex(arg); - cBINOP->op_last = arg; - break; - } - case INSN_OP_OTHER: /* 93 */ - { - opindex arg; - BGET_opindex(arg); - cLOGOP->op_other = arg; - break; - } - case INSN_OP_PMREPLROOT: /* 94 */ - { - opindex arg; - BGET_opindex(arg); - cPMOP->op_pmreplroot = arg; - break; - } - case INSN_OP_PMREPLROOTGV: /* 95 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&cPMOP->op_pmreplroot = arg; - break; - } - case INSN_OP_PMREPLSTART: /* 96 */ - { - opindex arg; - BGET_opindex(arg); - cPMOP->op_pmreplstart = arg; - break; - } - case INSN_OP_PMNEXT: /* 97 */ - { - opindex arg; - BGET_opindex(arg); - *(OP**)&cPMOP->op_pmnext = arg; - break; - } - case INSN_PREGCOMP: /* 98 */ - { - pvcontents arg; - BGET_pvcontents(arg); - BSET_pregcomp(PL_op, arg); - break; - } - case INSN_OP_PMFLAGS: /* 99 */ - { - U16 arg; - BGET_U16(arg); - cPMOP->op_pmflags = arg; - break; - } - case INSN_OP_PMPERMFLAGS: /* 100 */ - { - U16 arg; - BGET_U16(arg); - cPMOP->op_pmpermflags = arg; - break; - } - case INSN_OP_SV: /* 101 */ - { - svindex arg; - BGET_svindex(arg); - cSVOP->op_sv = arg; - break; - } - case INSN_OP_PADIX: /* 102 */ - { - PADOFFSET arg; - BGET_U32(arg); - cPADOP->op_padix = arg; - break; - } - case INSN_OP_PV: /* 103 */ - { - pvcontents arg; - BGET_pvcontents(arg); - cPVOP->op_pv = arg; - break; - } - case INSN_OP_PV_TR: /* 104 */ - { - op_tr_array arg; - BGET_op_tr_array(arg); - cPVOP->op_pv = arg; - break; - } - case INSN_OP_REDOOP: /* 105 */ - { - opindex arg; - BGET_opindex(arg); - cLOOP->op_redoop = arg; - break; - } - case INSN_OP_NEXTOP: /* 106 */ - { - opindex arg; - BGET_opindex(arg); - cLOOP->op_nextop = arg; - break; - } - case INSN_OP_LASTOP: /* 107 */ - { - opindex arg; - BGET_opindex(arg); - cLOOP->op_lastop = arg; - break; - } - case INSN_COP_LABEL: /* 108 */ - { - pvindex arg; - BGET_pvindex(arg); - cCOP->cop_label = arg; - break; - } - case INSN_COP_STASHPV: /* 109 */ - { - pvindex arg; - BGET_pvindex(arg); - BSET_cop_stashpv(cCOP, arg); - break; - } - case INSN_COP_FILE: /* 110 */ - { - pvindex arg; - BGET_pvindex(arg); - BSET_cop_file(cCOP, arg); - break; - } - case INSN_COP_SEQ: /* 111 */ - { - U32 arg; - BGET_U32(arg); - cCOP->cop_seq = arg; - break; - } - case INSN_COP_ARYBASE: /* 112 */ - { - I32 arg; - BGET_I32(arg); - cCOP->cop_arybase = arg; - break; - } - case INSN_COP_LINE: /* 113 */ - { - line_t arg; - BGET_U16(arg); - BSET_cop_line(cCOP, arg); - break; - } - case INSN_COP_WARNINGS: /* 114 */ - { - svindex arg; - BGET_svindex(arg); - cCOP->cop_warnings = arg; - break; - } - case INSN_MAIN_START: /* 115 */ - { - opindex arg; - BGET_opindex(arg); - PL_main_start = arg; - break; - } - case INSN_MAIN_ROOT: /* 116 */ - { - opindex arg; - BGET_opindex(arg); - PL_main_root = arg; - break; - } - case INSN_CURPAD: /* 117 */ - { - svindex arg; - BGET_svindex(arg); - BSET_curpad(PL_curpad, arg); - break; - } - case INSN_PUSH_BEGIN: /* 118 */ - { - svindex arg; - BGET_svindex(arg); - BSET_push_begin(PL_beginav, arg); - break; - } - case INSN_PUSH_INIT: /* 119 */ - { - svindex arg; - BGET_svindex(arg); - BSET_push_init(PL_initav, arg); - break; - } - case INSN_PUSH_END: /* 120 */ - { - svindex arg; - BGET_svindex(arg); - BSET_push_end(PL_endav, arg); - break; - } - default: - Perl_croak(aTHX_ "Illegal bytecode instruction %d\n", insn); - /* NOTREACHED */ - } - } -} diff --git a/contrib/perl5/ext/ByteLoader/byterun.h b/contrib/perl5/ext/ByteLoader/byterun.h deleted file mode 100644 index f074f2d..0000000 --- a/contrib/perl5/ext/ByteLoader/byterun.h +++ /dev/null @@ -1,168 +0,0 @@ -/* - * Copyright (c) 1996-1999 Malcolm Beattie - * - * You may distribute under the terms of either the GNU General Public - * License or the Artistic License, as specified in the README file. - * - */ -/* - * This file is autogenerated from bytecode.pl. Changes made here will be lost. - */ -struct byteloader_fdata { - SV *datasv; - int next_out; - int idx; -}; - -struct byteloader_state { - struct byteloader_fdata *bs_fdata; - SV *bs_sv; - void **bs_obj_list; - int bs_obj_list_fill; - XPV bs_pv; - int bs_iv_overflows; -}; - -int bl_getc(struct byteloader_fdata *); -int bl_read(struct byteloader_fdata *, char *, size_t, size_t); -extern void byterun(pTHXo_ struct byteloader_state *); - -enum { - INSN_RET, /* 0 */ - INSN_LDSV, /* 1 */ - INSN_LDOP, /* 2 */ - INSN_STSV, /* 3 */ - INSN_STOP, /* 4 */ - INSN_STPV, /* 5 */ - INSN_LDSPECSV, /* 6 */ - INSN_NEWSV, /* 7 */ - INSN_NEWOP, /* 8 */ - INSN_NEWOPN, /* 9 */ - INSN_NOP, /* 10 */ - INSN_NEWPV, /* 11 */ - INSN_PV_CUR, /* 12 */ - INSN_PV_FREE, /* 13 */ - INSN_SV_UPGRADE, /* 14 */ - INSN_SV_REFCNT, /* 15 */ - INSN_SV_REFCNT_ADD, /* 16 */ - INSN_SV_FLAGS, /* 17 */ - INSN_XRV, /* 18 */ - INSN_XPV, /* 19 */ - INSN_XIV32, /* 20 */ - INSN_XIV64, /* 21 */ - INSN_XNV, /* 22 */ - INSN_XLV_TARGOFF, /* 23 */ - INSN_XLV_TARGLEN, /* 24 */ - INSN_XLV_TARG, /* 25 */ - INSN_XLV_TYPE, /* 26 */ - INSN_XBM_USEFUL, /* 27 */ - INSN_XBM_PREVIOUS, /* 28 */ - INSN_XBM_RARE, /* 29 */ - INSN_XFM_LINES, /* 30 */ - INSN_XIO_LINES, /* 31 */ - INSN_XIO_PAGE, /* 32 */ - INSN_XIO_PAGE_LEN, /* 33 */ - INSN_XIO_LINES_LEFT, /* 34 */ - INSN_COMMENT, /* 35 */ - INSN_XIO_TOP_NAME, /* 36 */ - INSN_XIO_TOP_GV, /* 37 */ - INSN_XIO_FMT_NAME, /* 38 */ - INSN_XIO_FMT_GV, /* 39 */ - INSN_XIO_BOTTOM_NAME, /* 40 */ - INSN_XIO_BOTTOM_GV, /* 41 */ - INSN_XIO_SUBPROCESS, /* 42 */ - INSN_XIO_TYPE, /* 43 */ - INSN_XIO_FLAGS, /* 44 */ - INSN_XCV_STASH, /* 45 */ - INSN_XCV_START, /* 46 */ - INSN_XCV_ROOT, /* 47 */ - INSN_XCV_GV, /* 48 */ - INSN_XCV_FILE, /* 49 */ - INSN_XCV_DEPTH, /* 50 */ - INSN_XCV_PADLIST, /* 51 */ - INSN_XCV_OUTSIDE, /* 52 */ - INSN_XCV_FLAGS, /* 53 */ - INSN_AV_EXTEND, /* 54 */ - INSN_AV_PUSH, /* 55 */ - INSN_XAV_FILL, /* 56 */ - INSN_XAV_MAX, /* 57 */ - INSN_XAV_FLAGS, /* 58 */ - INSN_XHV_RITER, /* 59 */ - INSN_XHV_NAME, /* 60 */ - INSN_HV_STORE, /* 61 */ - INSN_SV_MAGIC, /* 62 */ - INSN_MG_OBJ, /* 63 */ - INSN_MG_PRIVATE, /* 64 */ - INSN_MG_FLAGS, /* 65 */ - INSN_MG_PV, /* 66 */ - INSN_XMG_STASH, /* 67 */ - INSN_GV_FETCHPV, /* 68 */ - INSN_GV_STASHPV, /* 69 */ - INSN_GP_SV, /* 70 */ - INSN_GP_REFCNT, /* 71 */ - INSN_GP_REFCNT_ADD, /* 72 */ - INSN_GP_AV, /* 73 */ - INSN_GP_HV, /* 74 */ - INSN_GP_CV, /* 75 */ - INSN_GP_FILE, /* 76 */ - INSN_GP_IO, /* 77 */ - INSN_GP_FORM, /* 78 */ - INSN_GP_CVGEN, /* 79 */ - INSN_GP_LINE, /* 80 */ - INSN_GP_SHARE, /* 81 */ - INSN_XGV_FLAGS, /* 82 */ - INSN_OP_NEXT, /* 83 */ - INSN_OP_SIBLING, /* 84 */ - INSN_OP_PPADDR, /* 85 */ - INSN_OP_TARG, /* 86 */ - INSN_OP_TYPE, /* 87 */ - INSN_OP_SEQ, /* 88 */ - INSN_OP_FLAGS, /* 89 */ - INSN_OP_PRIVATE, /* 90 */ - INSN_OP_FIRST, /* 91 */ - INSN_OP_LAST, /* 92 */ - INSN_OP_OTHER, /* 93 */ - INSN_OP_PMREPLROOT, /* 94 */ - INSN_OP_PMREPLROOTGV, /* 95 */ - INSN_OP_PMREPLSTART, /* 96 */ - INSN_OP_PMNEXT, /* 97 */ - INSN_PREGCOMP, /* 98 */ - INSN_OP_PMFLAGS, /* 99 */ - INSN_OP_PMPERMFLAGS, /* 100 */ - INSN_OP_SV, /* 101 */ - INSN_OP_PADIX, /* 102 */ - INSN_OP_PV, /* 103 */ - INSN_OP_PV_TR, /* 104 */ - INSN_OP_REDOOP, /* 105 */ - INSN_OP_NEXTOP, /* 106 */ - INSN_OP_LASTOP, /* 107 */ - INSN_COP_LABEL, /* 108 */ - INSN_COP_STASHPV, /* 109 */ - INSN_COP_FILE, /* 110 */ - INSN_COP_SEQ, /* 111 */ - INSN_COP_ARYBASE, /* 112 */ - INSN_COP_LINE, /* 113 */ - INSN_COP_WARNINGS, /* 114 */ - INSN_MAIN_START, /* 115 */ - INSN_MAIN_ROOT, /* 116 */ - INSN_CURPAD, /* 117 */ - INSN_PUSH_BEGIN, /* 118 */ - INSN_PUSH_INIT, /* 119 */ - INSN_PUSH_END, /* 120 */ - MAX_INSN = 120 -}; - -enum { - OPt_OP, /* 0 */ - OPt_UNOP, /* 1 */ - OPt_BINOP, /* 2 */ - OPt_LOGOP, /* 3 */ - OPt_LISTOP, /* 4 */ - OPt_PMOP, /* 5 */ - OPt_SVOP, /* 6 */ - OPt_PADOP, /* 7 */ - OPt_PVOP, /* 8 */ - OPt_LOOP, /* 9 */ - OPt_COP /* 10 */ -}; - diff --git a/contrib/perl5/ext/ByteLoader/hints/sunos.pl b/contrib/perl5/ext/ByteLoader/hints/sunos.pl deleted file mode 100644 index 3faf498..0000000 --- a/contrib/perl5/ext/ByteLoader/hints/sunos.pl +++ /dev/null @@ -1,2 +0,0 @@ -$self->{CCFLAGS} = $Config{ccflags} . ' -DNEED_FGETC_PROTOTYPE -DNEED_FREAD_PROTOTYPE'; - diff --git a/contrib/perl5/ext/DB_File/Changes b/contrib/perl5/ext/DB_File/Changes deleted file mode 100644 index eda270d..0000000 --- a/contrib/perl5/ext/DB_File/Changes +++ /dev/null @@ -1,336 +0,0 @@ - -0.1 - - First Release. - -0.2 - - When DB_File is opening a database file it no longer terminates the - process if dbopen returned an error. This allows file protection - errors to be caught at run time. Thanks to Judith Grass - <grass@cybercash.com> for spotting the bug. - -0.3 - - Added prototype support for multiple btree compare callbacks. - -1.0 - - DB_File has been in use for over a year. To reflect that, the - version number has been incremented to 1.0. - - Added complete support for multiple concurrent callbacks. - - Using the push method on an empty list didn't work properly. This - has been fixed. - -1.01 - - Fixed a core dump problem with SunOS. - - The return value from TIEHASH wasn't set to NULL when dbopen - returned an error. - -1.02 - - Merged OS/2 specific code into DB_File.xs - - Removed some redundant code in DB_File.xs. - - Documentation update. - - Allow negative subscripts with RECNO interface. - - Changed the default flags from O_RDWR to O_CREAT|O_RDWR. - - The example code which showed how to lock a database needed a call - to sync added. Without it the resultant database file was empty. - - Added get_dup method. - -1.03 - - Documentation update. - - DB_File now imports the constants (O_RDWR, O_CREAT etc.) from Fcntl - automatically. - - The standard hash function exists is now supported. - - Modified the behavior of get_dup. When it returns an associative - array, the value is the count of the number of matching BTREE - values. - -1.04 - - Minor documentation changes. - - Fixed a bug in hash_cb. Patches supplied by Dave Hammen, - <hammen@gothamcity.jsc.nasa.govt>. - - Fixed a bug with the constructors for DB_File::HASHINFO, - DB_File::BTREEINFO and DB_File::RECNOINFO. Also tidied up the - constructors to make them -w clean. - - Reworked part of the test harness to be more locale friendly. - -1.05 - - Made all scripts in the documentation strict and -w clean. - - Added logic to DB_File.xs to allow the module to be built after - Perl is installed. - -1.06 - - Minor namespace cleanup: Localized PrintBtree. - -1.07 - - Fixed bug with RECNO, where bval wasn't defaulting to "\n". - -1.08 - - Documented operation of bval. - -1.09 - - Minor bug fix in DB_File::HASHINFO, DB_File::RECNOINFO and - DB_File::BTREEINFO. - - Changed default mode to 0666. - -1.10 - - Fixed fd method so that it still returns -1 for in-memory files - when db 1.86 is used. - -1.11 - - Documented the untie gotcha. - -1.12 - - Documented the incompatibility with version 2 of Berkeley DB. - -1.13 - - Minor changes to DB_FIle.xs and DB_File.pm - -1.14 - - Made it illegal to tie an associative array to a RECNO database and - an ordinary array to a HASH or BTREE database. - -1.15 - - Patch from Gisle Aas <gisle@aas.no> to suppress "use of undefined - value" warning with db_get and db_seq. - - Patch from Gisle Aas <gisle@aas.no> to make DB_File export only the - O_* constants from Fcntl. - - Removed the DESTROY method from the DB_File::HASHINFO module. - - Previously DB_File hard-wired the class name of any object that it - created to "DB_File". This makes sub-classing difficult. Now - DB_File creats objects in the namespace of the package it has been - inherited into. - - -1.16 - - A harmless looking tab was causing Makefile.PL to fail on AIX 3.2.5 - - Small fix for the AIX strict C compiler XLC which doesn't like - __attribute__ being defined via proto.h and redefined via db.h. Fix - courtesy of Jarkko Hietaniemi. - -1.50 - - DB_File can now build with either DB 1.x or 2.x, but not both at - the same time. - -1.51 - - Fixed the test harness so that it doesn't expect DB_File to have - been installed by the main Perl build. - - - Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent - -1.52 - - Patch from Nick Ing-Simmons now allows DB_File to build on NT. - Merged 1.15 patch. - -1.53 - - Added DB_RENUMBER to flags for recno. - -1.54 - - Fixed a small bug in the test harness when run under win32 - The emulation of fd when useing DB 2.x was busted. - -1.55 - Merged 1.16 changes. - -1.56 - Documented the Solaris 2.5 mutex bug - -1.57 - If Perl has been compiled with Threads support,the symbol op will be - defined. This clashes with a field name in db.h, so it needs to be - #undef'ed before db.h is included. - -1.58 - Tied Array support was enhanced in Perl 5.004_57. DB_File now - supports PUSH,POP,SHIFT,UNSHIFT & STORESIZE. - - Fixed a problem with the use of sv_setpvn. When the size is - specified as 0, it does a strlen on the data. This was ok for DB - 1.x, but isn't for DB 2.x. - -1.59 - Updated the license section. - - Berkeley DB 2.4.10 disallows zero length keys. Tests 32 & 42 in - db-btree.t and test 27 in db-hash.t failed because of this change. - Those tests have been zapped. - - Added dbinfo to the distribution. - -1.60 - Changed the test to check for full tied array support - -1.61 19th November 1998 - - Added a note to README about how to build Berkeley DB 2.x when - using HP-UX. - Minor modifications to get the module to build with DB 2.5.x - Fixed a typo in the definition of O_RDONLY, courtesy of Mark Kettenis. - -1.62 30th November 1998 - - Added hints/dynixptx.pl. - Fixed typemap -- 1.61 used PL_na instead of na - -1.63 19th December 1998 - - * Fix to allow DB 2.6.x to build with DB_File - * Documentation updated to use push,pop etc in the RECNO example & - to include the find_dup & del_dup methods. - -1.64 21st February 1999 - - * Tidied the 1.x to 2.x flag mapping code. - * Added a patch from Mark Kettenis <kettenis@wins.uva.nl> to fix a flag - mapping problem with O_RDONLY on the Hurd - * Updated the message that db-recno.t prints when tests 51, 53 or 55 fail. - -1.65 6th March 1999 - - * Fixed a bug in the recno PUSH logic. - * The BOOT version check now needs 2.3.4 when using Berkeley DB version 2 - -1.66 15th March 1999 - - * Added DBM Filter code - -1.67 6th June 1999 - - * Added DBM Filter documentation to DB_File.pm - - * Fixed DBM Filter code to work with 5.004 - - * A few instances of newSVpvn were used in 1.66. This isn't available in - Perl 5.004_04 or earlier. Replaced with newSVpv. - -1.68 22nd July 1999 - - * Merged changes from 5.005_58 - - * Fixed a bug in R_IBEFORE & R_IAFTER procesing in Berkeley DB - 2 databases. - - * Added some of the examples in the POD into the test harness. - -1.69 3rd August 1999 - - * fixed a bug in push -- DB_APPEND wasn't working properly. - - * Fixed the R_SETCURSOR bug introduced in 1.68 - - * Added a new Perl variable $DB_File::db_ver - -1.70 4th August 1999 - - * Initialise $DB_File::db_ver and $DB_File::db_version with - GV_ADD|GV_ADDMULT -- bug spotted by Nick Ing-Simmons. - - * Added a BOOT check to test for equivalent versions of db.h & - libdb.a/so. - -1.71 7th September 1999 - - * Fixed a bug that prevented 1.70 from compiling under win32 - - * Updated to support Berkeley DB 3.x - - * Updated dbinfo for Berkeley DB 3.x file formats. - -1.72 16th January 2000 - - * Added hints/sco.pl - - * The module will now use XSLoader when it is available. When it - isn't it will use DynaLoader. - - * The locking section in DB_File.pm has been discredited. Many thanks - to David Harris for spotting the underlying problem, contributing - the updates to the documentation and writing DB_File::Lock (available - on CPAN). - -1.73 31st May 2000 - - * Added support in version.c for building with threaded Perl. - - * Berkeley DB 3.1 has reenabled support for null keys. The test - harness has been updated to reflect this. - -1.74 10th December 2000 - - * A "close" call in DB_File.xs needed parenthesised to stop win32 from - thinking it was one of its macros. - - * Updated dbinfo to support Berkeley DB 3.1 file format changes. - - * DB_File.pm & the test hasness now use the warnings pragma (when - available). - - * Included Perl core patch 7703 -- size argument for hash_cb is different - for Berkeley DB 3.x - - * Included Perl core patch 7801 -- Give __getBerkeleyDBInfo the ANSI C - treatment. - - * @a = () produced the warning 'Argument "" isn't numeric in entersub' - This has been fixed. Thanks to Edward Avis for spotting this bug. - - * Added note about building under Linux. Included patches. - - * Included Perl core patch 8068 -- fix for bug 20001013.009 - When run with warnings enabled "$hash{XX} = undef " produced an - "Uninitialized value" warning. This has been fixed. - -1.75 17th December 2000 - - * Fixed perl core patch 7703 - - * Added suppport to allow DB_File to be built with Berkeley DB 3.2 -- - btree_compare, btree_prefix and hash_cb needed to be changed. - - * Updated dbinfo to support Berkeley DB 3.2 file format changes. - - diff --git a/contrib/perl5/ext/DB_File/DB_File.pm b/contrib/perl5/ext/DB_File/DB_File.pm deleted file mode 100644 index c830216..0000000 --- a/contrib/perl5/ext/DB_File/DB_File.pm +++ /dev/null @@ -1,2072 +0,0 @@ -# DB_File.pm -- Perl 5 interface to Berkeley DB -# -# written by Paul Marquess (Paul.Marquess@btinternet.com) -# last modified 17th December 2000 -# version 1.75 -# -# Copyright (c) 1995-2000 Paul Marquess. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - - -package DB_File::HASHINFO ; - -require 5.003 ; - -use warnings; -use strict; -use Carp; -require Tie::Hash; -@DB_File::HASHINFO::ISA = qw(Tie::Hash); - -sub new -{ - my $pkg = shift ; - my %x ; - tie %x, $pkg ; - bless \%x, $pkg ; -} - - -sub TIEHASH -{ - my $pkg = shift ; - - bless { VALID => { map {$_, 1} - qw( bsize ffactor nelem cachesize hash lorder) - }, - GOT => {} - }, $pkg ; -} - - -sub FETCH -{ - my $self = shift ; - my $key = shift ; - - return $self->{GOT}{$key} if exists $self->{VALID}{$key} ; - - my $pkg = ref $self ; - croak "${pkg}::FETCH - Unknown element '$key'" ; -} - - -sub STORE -{ - my $self = shift ; - my $key = shift ; - my $value = shift ; - - if ( exists $self->{VALID}{$key} ) - { - $self->{GOT}{$key} = $value ; - return ; - } - - my $pkg = ref $self ; - croak "${pkg}::STORE - Unknown element '$key'" ; -} - -sub DELETE -{ - my $self = shift ; - my $key = shift ; - - if ( exists $self->{VALID}{$key} ) - { - delete $self->{GOT}{$key} ; - return ; - } - - my $pkg = ref $self ; - croak "DB_File::HASHINFO::DELETE - Unknown element '$key'" ; -} - -sub EXISTS -{ - my $self = shift ; - my $key = shift ; - - exists $self->{VALID}{$key} ; -} - -sub NotHere -{ - my $self = shift ; - my $method = shift ; - - croak ref($self) . " does not define the method ${method}" ; -} - -sub FIRSTKEY { my $self = shift ; $self->NotHere("FIRSTKEY") } -sub NEXTKEY { my $self = shift ; $self->NotHere("NEXTKEY") } -sub CLEAR { my $self = shift ; $self->NotHere("CLEAR") } - -package DB_File::RECNOINFO ; - -use warnings; -use strict ; - -@DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ; - -sub TIEHASH -{ - my $pkg = shift ; - - bless { VALID => { map {$_, 1} - qw( bval cachesize psize flags lorder reclen bfname ) - }, - GOT => {}, - }, $pkg ; -} - -package DB_File::BTREEINFO ; - -use warnings; -use strict ; - -@DB_File::BTREEINFO::ISA = qw(DB_File::HASHINFO) ; - -sub TIEHASH -{ - my $pkg = shift ; - - bless { VALID => { map {$_, 1} - qw( flags cachesize maxkeypage minkeypage psize - compare prefix lorder ) - }, - GOT => {}, - }, $pkg ; -} - - -package DB_File ; - -use warnings; -use strict; -use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO - $db_version $use_XSLoader - ) ; -use Carp; - - -$VERSION = "1.75" ; - -#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; -$DB_BTREE = new DB_File::BTREEINFO ; -$DB_HASH = new DB_File::HASHINFO ; -$DB_RECNO = new DB_File::RECNOINFO ; - -require Tie::Hash; -require Exporter; -use AutoLoader; -BEGIN { - $use_XSLoader = 1 ; - eval { require XSLoader } ; - - if ($@) { - $use_XSLoader = 0 ; - require DynaLoader; - @ISA = qw(DynaLoader); - } -} - -push @ISA, qw(Tie::Hash Exporter); -@EXPORT = qw( - $DB_BTREE $DB_HASH $DB_RECNO - - BTREEMAGIC - BTREEVERSION - DB_LOCK - DB_SHMEM - DB_TXN - HASHMAGIC - HASHVERSION - MAX_PAGE_NUMBER - MAX_PAGE_OFFSET - MAX_REC_NUMBER - RET_ERROR - RET_SPECIAL - RET_SUCCESS - R_CURSOR - R_DUP - R_FIRST - R_FIXEDLEN - R_IAFTER - R_IBEFORE - R_LAST - R_NEXT - R_NOKEY - R_NOOVERWRITE - R_PREV - R_RECNOSYNC - R_SETCURSOR - R_SNAPSHOT - __R_UNUSED - -); - -sub AUTOLOAD { - my($constname); - ($constname = $AUTOLOAD) =~ s/.*:://; - my $val = constant($constname, @_ ? $_[0] : 0); - if ($! != 0) { - if ($! =~ /Invalid/ || $!{EINVAL}) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } - else { - my($pack,$file,$line) = caller; - croak "Your vendor has not defined DB macro $constname, used at $file line $line. -"; - } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - - -eval { - # Make all Fcntl O_XXX constants available for importing - require Fcntl; - my @O = grep /^O_/, @Fcntl::EXPORT; - Fcntl->import(@O); # first we import what we want to export - push(@EXPORT, @O); -}; - -if ($use_XSLoader) - { XSLoader::load("DB_File", $VERSION)} -else - { bootstrap DB_File $VERSION } - -# Preloaded methods go here. Autoload methods go after __END__, and are -# processed by the autosplit program. - -sub tie_hash_or_array -{ - my (@arg) = @_ ; - my $tieHASH = ( (caller(1))[3] =~ /TIEHASH/ ) ; - - $arg[4] = tied %{ $arg[4] } - if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ; - - # make recno in Berkeley DB version 2 work like recno in version 1. - if ($db_version > 1 and defined $arg[4] and $arg[4] =~ /RECNO/ and - $arg[1] and ! -e $arg[1]) { - open(FH, ">$arg[1]") or return undef ; - close FH ; - chmod $arg[3] ? $arg[3] : 0666 , $arg[1] ; - } - - DoTie_($tieHASH, @arg) ; -} - -sub TIEHASH -{ - tie_hash_or_array(@_) ; -} - -sub TIEARRAY -{ - tie_hash_or_array(@_) ; -} - -sub CLEAR -{ - my $self = shift; - my $key = 0 ; - my $value = "" ; - my $status = $self->seq($key, $value, R_FIRST()); - my @keys; - - while ($status == 0) { - push @keys, $key; - $status = $self->seq($key, $value, R_NEXT()); - } - foreach $key (reverse @keys) { - my $s = $self->del($key); - } -} - -sub EXTEND { } - -sub STORESIZE -{ - my $self = shift; - my $length = shift ; - my $current_length = $self->length() ; - - if ($length < $current_length) { - my $key ; - for ($key = $current_length - 1 ; $key >= $length ; -- $key) - { $self->del($key) } - } - elsif ($length > $current_length) { - $self->put($length-1, "") ; - } -} - -sub find_dup -{ - croak "Usage: \$db->find_dup(key,value)\n" - unless @_ == 3 ; - - my $db = shift ; - my ($origkey, $value_wanted) = @_ ; - my ($key, $value) = ($origkey, 0); - my ($status) = 0 ; - - for ($status = $db->seq($key, $value, R_CURSOR() ) ; - $status == 0 ; - $status = $db->seq($key, $value, R_NEXT() ) ) { - - return 0 if $key eq $origkey and $value eq $value_wanted ; - } - - return $status ; -} - -sub del_dup -{ - croak "Usage: \$db->del_dup(key,value)\n" - unless @_ == 3 ; - - my $db = shift ; - my ($key, $value) = @_ ; - my ($status) = $db->find_dup($key, $value) ; - return $status if $status != 0 ; - - $status = $db->del($key, R_CURSOR() ) ; - return $status ; -} - -sub get_dup -{ - croak "Usage: \$db->get_dup(key [,flag])\n" - unless @_ == 2 or @_ == 3 ; - - my $db = shift ; - my $key = shift ; - my $flag = shift ; - my $value = 0 ; - my $origkey = $key ; - my $wantarray = wantarray ; - my %values = () ; - my @values = () ; - my $counter = 0 ; - my $status = 0 ; - - # iterate through the database until either EOF ($status == 0) - # or a different key is encountered ($key ne $origkey). - for ($status = $db->seq($key, $value, R_CURSOR()) ; - $status == 0 and $key eq $origkey ; - $status = $db->seq($key, $value, R_NEXT()) ) { - - # save the value or count number of matches - if ($wantarray) { - if ($flag) - { ++ $values{$value} } - else - { push (@values, $value) } - } - else - { ++ $counter } - - } - - return ($wantarray ? ($flag ? %values : @values) : $counter) ; -} - - -1; -__END__ - -=head1 NAME - -DB_File - Perl5 access to Berkeley DB version 1.x - -=head1 SYNOPSIS - - use DB_File ; - - [$X =] tie %hash, 'DB_File', [$filename, $flags, $mode, $DB_HASH] ; - [$X =] tie %hash, 'DB_File', $filename, $flags, $mode, $DB_BTREE ; - [$X =] tie @array, 'DB_File', $filename, $flags, $mode, $DB_RECNO ; - - $status = $X->del($key [, $flags]) ; - $status = $X->put($key, $value [, $flags]) ; - $status = $X->get($key, $value [, $flags]) ; - $status = $X->seq($key, $value, $flags) ; - $status = $X->sync([$flags]) ; - $status = $X->fd ; - - # BTREE only - $count = $X->get_dup($key) ; - @list = $X->get_dup($key) ; - %list = $X->get_dup($key, 1) ; - $status = $X->find_dup($key, $value) ; - $status = $X->del_dup($key, $value) ; - - # RECNO only - $a = $X->length; - $a = $X->pop ; - $X->push(list); - $a = $X->shift; - $X->unshift(list); - - # DBM Filters - $old_filter = $db->filter_store_key ( sub { ... } ) ; - $old_filter = $db->filter_store_value( sub { ... } ) ; - $old_filter = $db->filter_fetch_key ( sub { ... } ) ; - $old_filter = $db->filter_fetch_value( sub { ... } ) ; - - untie %hash ; - untie @array ; - -=head1 DESCRIPTION - -B<DB_File> is a module which allows Perl programs to make use of the -facilities provided by Berkeley DB version 1.x (if you have a newer -version of DB, see L<Using DB_File with Berkeley DB version 2 or 3>). -It is assumed that you have a copy of the Berkeley DB manual pages at -hand when reading this documentation. The interface defined here -mirrors the Berkeley DB interface closely. - -Berkeley DB is a C library which provides a consistent interface to a -number of database formats. B<DB_File> provides an interface to all -three of the database types currently supported by Berkeley DB. - -The file types are: - -=over 5 - -=item B<DB_HASH> - -This database type allows arbitrary key/value pairs to be stored in data -files. This is equivalent to the functionality provided by other -hashing packages like DBM, NDBM, ODBM, GDBM, and SDBM. Remember though, -the files created using DB_HASH are not compatible with any of the -other packages mentioned. - -A default hashing algorithm, which will be adequate for most -applications, is built into Berkeley DB. If you do need to use your own -hashing algorithm it is possible to write your own in Perl and have -B<DB_File> use it instead. - -=item B<DB_BTREE> - -The btree format allows arbitrary key/value pairs to be stored in a -sorted, balanced binary tree. - -As with the DB_HASH format, it is possible to provide a user defined -Perl routine to perform the comparison of keys. By default, though, the -keys are stored in lexical order. - -=item B<DB_RECNO> - -DB_RECNO allows both fixed-length and variable-length flat text files -to be manipulated using the same key/value pair interface as in DB_HASH -and DB_BTREE. In this case the key will consist of a record (line) -number. - -=back - -=head2 Using DB_File with Berkeley DB version 2 or 3 - -Although B<DB_File> is intended to be used with Berkeley DB version 1, -it can also be used with version 2.or 3 In this case the interface is -limited to the functionality provided by Berkeley DB 1.x. Anywhere the -version 2 or 3 interface differs, B<DB_File> arranges for it to work -like version 1. This feature allows B<DB_File> scripts that were built -with version 1 to be migrated to version 2 or 3 without any changes. - -If you want to make use of the new features available in Berkeley DB -2.x or greater, use the Perl module B<BerkeleyDB> instead. - -B<Note:> The database file format has changed in both Berkeley DB -version 2 and 3. If you cannot recreate your databases, you must dump -any existing databases with the C<db_dump185> utility that comes with -Berkeley DB. -Once you have rebuilt DB_File to use Berkeley DB version 2 or 3, your -databases can be recreated using C<db_load>. Refer to the Berkeley DB -documentation for further details. - -Please read L<"COPYRIGHT"> before using version 2.x or 3.x of Berkeley -DB with DB_File. - -=head2 Interface to Berkeley DB - -B<DB_File> allows access to Berkeley DB files using the tie() mechanism -in Perl 5 (for full details, see L<perlfunc/tie()>). This facility -allows B<DB_File> to access Berkeley DB files using either an -associative array (for DB_HASH & DB_BTREE file types) or an ordinary -array (for the DB_RECNO file type). - -In addition to the tie() interface, it is also possible to access most -of the functions provided in the Berkeley DB API directly. -See L<THE API INTERFACE>. - -=head2 Opening a Berkeley DB Database File - -Berkeley DB uses the function dbopen() to open or create a database. -Here is the C prototype for dbopen(): - - DB* - dbopen (const char * file, int flags, int mode, - DBTYPE type, const void * openinfo) - -The parameter C<type> is an enumeration which specifies which of the 3 -interface methods (DB_HASH, DB_BTREE or DB_RECNO) is to be used. -Depending on which of these is actually chosen, the final parameter, -I<openinfo> points to a data structure which allows tailoring of the -specific interface method. - -This interface is handled slightly differently in B<DB_File>. Here is -an equivalent call using B<DB_File>: - - tie %array, 'DB_File', $filename, $flags, $mode, $DB_HASH ; - -The C<filename>, C<flags> and C<mode> parameters are the direct -equivalent of their dbopen() counterparts. The final parameter $DB_HASH -performs the function of both the C<type> and C<openinfo> parameters in -dbopen(). - -In the example above $DB_HASH is actually a pre-defined reference to a -hash object. B<DB_File> has three of these pre-defined references. -Apart from $DB_HASH, there is also $DB_BTREE and $DB_RECNO. - -The keys allowed in each of these pre-defined references is limited to -the names used in the equivalent C structure. So, for example, the -$DB_HASH reference will only allow keys called C<bsize>, C<cachesize>, -C<ffactor>, C<hash>, C<lorder> and C<nelem>. - -To change one of these elements, just assign to it like this: - - $DB_HASH->{'cachesize'} = 10000 ; - -The three predefined variables $DB_HASH, $DB_BTREE and $DB_RECNO are -usually adequate for most applications. If you do need to create extra -instances of these objects, constructors are available for each file -type. - -Here are examples of the constructors and the valid options available -for DB_HASH, DB_BTREE and DB_RECNO respectively. - - $a = new DB_File::HASHINFO ; - $a->{'bsize'} ; - $a->{'cachesize'} ; - $a->{'ffactor'}; - $a->{'hash'} ; - $a->{'lorder'} ; - $a->{'nelem'} ; - - $b = new DB_File::BTREEINFO ; - $b->{'flags'} ; - $b->{'cachesize'} ; - $b->{'maxkeypage'} ; - $b->{'minkeypage'} ; - $b->{'psize'} ; - $b->{'compare'} ; - $b->{'prefix'} ; - $b->{'lorder'} ; - - $c = new DB_File::RECNOINFO ; - $c->{'bval'} ; - $c->{'cachesize'} ; - $c->{'psize'} ; - $c->{'flags'} ; - $c->{'lorder'} ; - $c->{'reclen'} ; - $c->{'bfname'} ; - -The values stored in the hashes above are mostly the direct equivalent -of their C counterpart. Like their C counterparts, all are set to a -default values - that means you don't have to set I<all> of the -values when you only want to change one. Here is an example: - - $a = new DB_File::HASHINFO ; - $a->{'cachesize'} = 12345 ; - tie %y, 'DB_File', "filename", $flags, 0777, $a ; - -A few of the options need extra discussion here. When used, the C -equivalent of the keys C<hash>, C<compare> and C<prefix> store pointers -to C functions. In B<DB_File> these keys are used to store references -to Perl subs. Below are templates for each of the subs: - - sub hash - { - my ($data) = @_ ; - ... - # return the hash value for $data - return $hash ; - } - - sub compare - { - my ($key, $key2) = @_ ; - ... - # return 0 if $key1 eq $key2 - # -1 if $key1 lt $key2 - # 1 if $key1 gt $key2 - return (-1 , 0 or 1) ; - } - - sub prefix - { - my ($key, $key2) = @_ ; - ... - # return number of bytes of $key2 which are - # necessary to determine that it is greater than $key1 - return $bytes ; - } - -See L<Changing the BTREE sort order> for an example of using the -C<compare> template. - -If you are using the DB_RECNO interface and you intend making use of -C<bval>, you should check out L<The 'bval' Option>. - -=head2 Default Parameters - -It is possible to omit some or all of the final 4 parameters in the -call to C<tie> and let them take default values. As DB_HASH is the most -common file format used, the call: - - tie %A, "DB_File", "filename" ; - -is equivalent to: - - tie %A, "DB_File", "filename", O_CREAT|O_RDWR, 0666, $DB_HASH ; - -It is also possible to omit the filename parameter as well, so the -call: - - tie %A, "DB_File" ; - -is equivalent to: - - tie %A, "DB_File", undef, O_CREAT|O_RDWR, 0666, $DB_HASH ; - -See L<In Memory Databases> for a discussion on the use of C<undef> -in place of a filename. - -=head2 In Memory Databases - -Berkeley DB allows the creation of in-memory databases by using NULL -(that is, a C<(char *)0> in C) in place of the filename. B<DB_File> -uses C<undef> instead of NULL to provide this functionality. - -=head1 DB_HASH - -The DB_HASH file format is probably the most commonly used of the three -file formats that B<DB_File> supports. It is also very straightforward -to use. - -=head2 A Simple Example - -This example shows how to create a database, add key/value pairs to the -database, delete keys/value pairs and finally how to enumerate the -contents of the database. - - use warnings ; - use strict ; - use DB_File ; - use vars qw( %h $k $v ) ; - - unlink "fruit" ; - tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH - or die "Cannot open file 'fruit': $!\n"; - - # Add a few key/value pairs to the file - $h{"apple"} = "red" ; - $h{"orange"} = "orange" ; - $h{"banana"} = "yellow" ; - $h{"tomato"} = "red" ; - - # Check for existence of a key - print "Banana Exists\n\n" if $h{"banana"} ; - - # Delete a key/value pair. - delete $h{"apple"} ; - - # print the contents of the file - while (($k, $v) = each %h) - { print "$k -> $v\n" } - - untie %h ; - -here is the output: - - Banana Exists - - orange -> orange - tomato -> red - banana -> yellow - -Note that the like ordinary associative arrays, the order of the keys -retrieved is in an apparently random order. - -=head1 DB_BTREE - -The DB_BTREE format is useful when you want to store data in a given -order. By default the keys will be stored in lexical order, but as you -will see from the example shown in the next section, it is very easy to -define your own sorting function. - -=head2 Changing the BTREE sort order - -This script shows how to override the default sorting algorithm that -BTREE uses. Instead of using the normal lexical ordering, a case -insensitive compare function will be used. - - use warnings ; - use strict ; - use DB_File ; - - my %h ; - - sub Compare - { - my ($key1, $key2) = @_ ; - "\L$key1" cmp "\L$key2" ; - } - - # specify the Perl sub that will do the comparison - $DB_BTREE->{'compare'} = \&Compare ; - - unlink "tree" ; - tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open file 'tree': $!\n" ; - - # Add a key/value pair to the file - $h{'Wall'} = 'Larry' ; - $h{'Smith'} = 'John' ; - $h{'mouse'} = 'mickey' ; - $h{'duck'} = 'donald' ; - - # Delete - delete $h{"duck"} ; - - # Cycle through the keys printing them in order. - # Note it is not necessary to sort the keys as - # the btree will have kept them in order automatically. - foreach (keys %h) - { print "$_\n" } - - untie %h ; - -Here is the output from the code above. - - mouse - Smith - Wall - -There are a few point to bear in mind if you want to change the -ordering in a BTREE database: - -=over 5 - -=item 1. - -The new compare function must be specified when you create the database. - -=item 2. - -You cannot change the ordering once the database has been created. Thus -you must use the same compare function every time you access the -database. - -=back - -=head2 Handling Duplicate Keys - -The BTREE file type optionally allows a single key to be associated -with an arbitrary number of values. This option is enabled by setting -the flags element of C<$DB_BTREE> to R_DUP when creating the database. - -There are some difficulties in using the tied hash interface if you -want to manipulate a BTREE database with duplicate keys. Consider this -code: - - use warnings ; - use strict ; - use DB_File ; - - use vars qw($filename %h ) ; - - $filename = "tree" ; - unlink $filename ; - - # Enable duplicate records - $DB_BTREE->{'flags'} = R_DUP ; - - tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; - - # Add some key/value pairs to the file - $h{'Wall'} = 'Larry' ; - $h{'Wall'} = 'Brick' ; # Note the duplicate key - $h{'Wall'} = 'Brick' ; # Note the duplicate key and value - $h{'Smith'} = 'John' ; - $h{'mouse'} = 'mickey' ; - - # iterate through the associative array - # and print each key/value pair. - foreach (sort keys %h) - { print "$_ -> $h{$_}\n" } - - untie %h ; - -Here is the output: - - Smith -> John - Wall -> Larry - Wall -> Larry - Wall -> Larry - mouse -> mickey - -As you can see 3 records have been successfully created with key C<Wall> -- the only thing is, when they are retrieved from the database they -I<seem> to have the same value, namely C<Larry>. The problem is caused -by the way that the associative array interface works. Basically, when -the associative array interface is used to fetch the value associated -with a given key, it will only ever retrieve the first value. - -Although it may not be immediately obvious from the code above, the -associative array interface can be used to write values with duplicate -keys, but it cannot be used to read them back from the database. - -The way to get around this problem is to use the Berkeley DB API method -called C<seq>. This method allows sequential access to key/value -pairs. See L<THE API INTERFACE> for details of both the C<seq> method -and the API in general. - -Here is the script above rewritten using the C<seq> API method. - - use warnings ; - use strict ; - use DB_File ; - - use vars qw($filename $x %h $status $key $value) ; - - $filename = "tree" ; - unlink $filename ; - - # Enable duplicate records - $DB_BTREE->{'flags'} = R_DUP ; - - $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; - - # Add some key/value pairs to the file - $h{'Wall'} = 'Larry' ; - $h{'Wall'} = 'Brick' ; # Note the duplicate key - $h{'Wall'} = 'Brick' ; # Note the duplicate key and value - $h{'Smith'} = 'John' ; - $h{'mouse'} = 'mickey' ; - - # iterate through the btree using seq - # and print each key/value pair. - $key = $value = 0 ; - for ($status = $x->seq($key, $value, R_FIRST) ; - $status == 0 ; - $status = $x->seq($key, $value, R_NEXT) ) - { print "$key -> $value\n" } - - undef $x ; - untie %h ; - -that prints: - - Smith -> John - Wall -> Brick - Wall -> Brick - Wall -> Larry - mouse -> mickey - -This time we have got all the key/value pairs, including the multiple -values associated with the key C<Wall>. - -To make life easier when dealing with duplicate keys, B<DB_File> comes with -a few utility methods. - -=head2 The get_dup() Method - -The C<get_dup> method assists in -reading duplicate values from BTREE databases. The method can take the -following forms: - - $count = $x->get_dup($key) ; - @list = $x->get_dup($key) ; - %list = $x->get_dup($key, 1) ; - -In a scalar context the method returns the number of values associated -with the key, C<$key>. - -In list context, it returns all the values which match C<$key>. Note -that the values will be returned in an apparently random order. - -In list context, if the second parameter is present and evaluates -TRUE, the method returns an associative array. The keys of the -associative array correspond to the values that matched in the BTREE -and the values of the array are a count of the number of times that -particular value occurred in the BTREE. - -So assuming the database created above, we can use C<get_dup> like -this: - - use warnings ; - use strict ; - use DB_File ; - - use vars qw($filename $x %h ) ; - - $filename = "tree" ; - - # Enable duplicate records - $DB_BTREE->{'flags'} = R_DUP ; - - $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; - - my $cnt = $x->get_dup("Wall") ; - print "Wall occurred $cnt times\n" ; - - my %hash = $x->get_dup("Wall", 1) ; - print "Larry is there\n" if $hash{'Larry'} ; - print "There are $hash{'Brick'} Brick Walls\n" ; - - my @list = sort $x->get_dup("Wall") ; - print "Wall => [@list]\n" ; - - @list = $x->get_dup("Smith") ; - print "Smith => [@list]\n" ; - - @list = $x->get_dup("Dog") ; - print "Dog => [@list]\n" ; - - -and it will print: - - Wall occurred 3 times - Larry is there - There are 2 Brick Walls - Wall => [Brick Brick Larry] - Smith => [John] - Dog => [] - -=head2 The find_dup() Method - - $status = $X->find_dup($key, $value) ; - -This method checks for the existence of a specific key/value pair. If the -pair exists, the cursor is left pointing to the pair and the method -returns 0. Otherwise the method returns a non-zero value. - -Assuming the database from the previous example: - - use warnings ; - use strict ; - use DB_File ; - - use vars qw($filename $x %h $found) ; - - my $filename = "tree" ; - - # Enable duplicate records - $DB_BTREE->{'flags'} = R_DUP ; - - $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; - - $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; - print "Larry Wall is $found there\n" ; - - $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ; - print "Harry Wall is $found there\n" ; - - undef $x ; - untie %h ; - -prints this - - Larry Wall is there - Harry Wall is not there - - -=head2 The del_dup() Method - - $status = $X->del_dup($key, $value) ; - -This method deletes a specific key/value pair. It returns -0 if they exist and have been deleted successfully. -Otherwise the method returns a non-zero value. - -Again assuming the existence of the C<tree> database - - use warnings ; - use strict ; - use DB_File ; - - use vars qw($filename $x %h $found) ; - - my $filename = "tree" ; - - # Enable duplicate records - $DB_BTREE->{'flags'} = R_DUP ; - - $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; - - $x->del_dup("Wall", "Larry") ; - - $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; - print "Larry Wall is $found there\n" ; - - undef $x ; - untie %h ; - -prints this - - Larry Wall is not there - -=head2 Matching Partial Keys - -The BTREE interface has a feature which allows partial keys to be -matched. This functionality is I<only> available when the C<seq> method -is used along with the R_CURSOR flag. - - $x->seq($key, $value, R_CURSOR) ; - -Here is the relevant quote from the dbopen man page where it defines -the use of the R_CURSOR flag with seq: - - Note, for the DB_BTREE access method, the returned key is not - necessarily an exact match for the specified key. The returned key - is the smallest key greater than or equal to the specified key, - permitting partial key matches and range searches. - -In the example script below, the C<match> sub uses this feature to find -and print the first matching key/value pair given a partial key. - - use warnings ; - use strict ; - use DB_File ; - use Fcntl ; - - use vars qw($filename $x %h $st $key $value) ; - - sub match - { - my $key = shift ; - my $value = 0; - my $orig_key = $key ; - $x->seq($key, $value, R_CURSOR) ; - print "$orig_key\t-> $key\t-> $value\n" ; - } - - $filename = "tree" ; - unlink $filename ; - - $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; - - # Add some key/value pairs to the file - $h{'mouse'} = 'mickey' ; - $h{'Wall'} = 'Larry' ; - $h{'Walls'} = 'Brick' ; - $h{'Smith'} = 'John' ; - - - $key = $value = 0 ; - print "IN ORDER\n" ; - for ($st = $x->seq($key, $value, R_FIRST) ; - $st == 0 ; - $st = $x->seq($key, $value, R_NEXT) ) - - { print "$key -> $value\n" } - - print "\nPARTIAL MATCH\n" ; - - match "Wa" ; - match "A" ; - match "a" ; - - undef $x ; - untie %h ; - -Here is the output: - - IN ORDER - Smith -> John - Wall -> Larry - Walls -> Brick - mouse -> mickey - - PARTIAL MATCH - Wa -> Wall -> Larry - A -> Smith -> John - a -> mouse -> mickey - -=head1 DB_RECNO - -DB_RECNO provides an interface to flat text files. Both variable and -fixed length records are supported. - -In order to make RECNO more compatible with Perl, the array offset for -all RECNO arrays begins at 0 rather than 1 as in Berkeley DB. - -As with normal Perl arrays, a RECNO array can be accessed using -negative indexes. The index -1 refers to the last element of the array, --2 the second last, and so on. Attempting to access an element before -the start of the array will raise a fatal run-time error. - -=head2 The 'bval' Option - -The operation of the bval option warrants some discussion. Here is the -definition of bval from the Berkeley DB 1.85 recno manual page: - - The delimiting byte to be used to mark the end of a - record for variable-length records, and the pad charac- - ter for fixed-length records. If no value is speci- - fied, newlines (``\n'') are used to mark the end of - variable-length records and fixed-length records are - padded with spaces. - -The second sentence is wrong. In actual fact bval will only default to -C<"\n"> when the openinfo parameter in dbopen is NULL. If a non-NULL -openinfo parameter is used at all, the value that happens to be in bval -will be used. That means you always have to specify bval when making -use of any of the options in the openinfo parameter. This documentation -error will be fixed in the next release of Berkeley DB. - -That clarifies the situation with regards Berkeley DB itself. What -about B<DB_File>? Well, the behavior defined in the quote above is -quite useful, so B<DB_File> conforms to it. - -That means that you can specify other options (e.g. cachesize) and -still have bval default to C<"\n"> for variable length records, and -space for fixed length records. - -=head2 A Simple Example - -Here is a simple example that uses RECNO (if you are using a version -of Perl earlier than 5.004_57 this example won't work -- see -L<Extra RECNO Methods> for a workaround). - - use warnings ; - use strict ; - use DB_File ; - - my $filename = "text" ; - unlink $filename ; - - my @h ; - tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO - or die "Cannot open file 'text': $!\n" ; - - # Add a few key/value pairs to the file - $h[0] = "orange" ; - $h[1] = "blue" ; - $h[2] = "yellow" ; - - push @h, "green", "black" ; - - my $elements = scalar @h ; - print "The array contains $elements entries\n" ; - - my $last = pop @h ; - print "popped $last\n" ; - - unshift @h, "white" ; - my $first = shift @h ; - print "shifted $first\n" ; - - # Check for existence of a key - print "Element 1 Exists with value $h[1]\n" if $h[1] ; - - # use a negative index - print "The last element is $h[-1]\n" ; - print "The 2nd last element is $h[-2]\n" ; - - untie @h ; - -Here is the output from the script: - - The array contains 5 entries - popped black - shifted white - Element 1 Exists with value blue - The last element is green - The 2nd last element is yellow - -=head2 Extra RECNO Methods - -If you are using a version of Perl earlier than 5.004_57, the tied -array interface is quite limited. In the example script above -C<push>, C<pop>, C<shift>, C<unshift> -or determining the array length will not work with a tied array. - -To make the interface more useful for older versions of Perl, a number -of methods are supplied with B<DB_File> to simulate the missing array -operations. All these methods are accessed via the object returned from -the tie call. - -Here are the methods: - -=over 5 - -=item B<$X-E<gt>push(list) ;> - -Pushes the elements of C<list> to the end of the array. - -=item B<$value = $X-E<gt>pop ;> - -Removes and returns the last element of the array. - -=item B<$X-E<gt>shift> - -Removes and returns the first element of the array. - -=item B<$X-E<gt>unshift(list) ;> - -Pushes the elements of C<list> to the start of the array. - -=item B<$X-E<gt>length> - -Returns the number of elements in the array. - -=back - -=head2 Another Example - -Here is a more complete example that makes use of some of the methods -described above. It also makes use of the API interface directly (see -L<THE API INTERFACE>). - - use warnings ; - use strict ; - use vars qw(@h $H $file $i) ; - use DB_File ; - use Fcntl ; - - $file = "text" ; - - unlink $file ; - - $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $DB_RECNO - or die "Cannot open file $file: $!\n" ; - - # first create a text file to play with - $h[0] = "zero" ; - $h[1] = "one" ; - $h[2] = "two" ; - $h[3] = "three" ; - $h[4] = "four" ; - - - # Print the records in order. - # - # The length method is needed here because evaluating a tied - # array in a scalar context does not return the number of - # elements in the array. - - print "\nORIGINAL\n" ; - foreach $i (0 .. $H->length - 1) { - print "$i: $h[$i]\n" ; - } - - # use the push & pop methods - $a = $H->pop ; - $H->push("last") ; - print "\nThe last record was [$a]\n" ; - - # and the shift & unshift methods - $a = $H->shift ; - $H->unshift("first") ; - print "The first record was [$a]\n" ; - - # Use the API to add a new record after record 2. - $i = 2 ; - $H->put($i, "Newbie", R_IAFTER) ; - - # and a new record before record 1. - $i = 1 ; - $H->put($i, "New One", R_IBEFORE) ; - - # delete record 3 - $H->del(3) ; - - # now print the records in reverse order - print "\nREVERSE\n" ; - for ($i = $H->length - 1 ; $i >= 0 ; -- $i) - { print "$i: $h[$i]\n" } - - # same again, but use the API functions instead - print "\nREVERSE again\n" ; - my ($s, $k, $v) = (0, 0, 0) ; - for ($s = $H->seq($k, $v, R_LAST) ; - $s == 0 ; - $s = $H->seq($k, $v, R_PREV)) - { print "$k: $v\n" } - - undef $H ; - untie @h ; - -and this is what it outputs: - - ORIGINAL - 0: zero - 1: one - 2: two - 3: three - 4: four - - The last record was [four] - The first record was [zero] - - REVERSE - 5: last - 4: three - 3: Newbie - 2: one - 1: New One - 0: first - - REVERSE again - 5: last - 4: three - 3: Newbie - 2: one - 1: New One - 0: first - -Notes: - -=over 5 - -=item 1. - -Rather than iterating through the array, C<@h> like this: - - foreach $i (@h) - -it is necessary to use either this: - - foreach $i (0 .. $H->length - 1) - -or this: - - for ($a = $H->get($k, $v, R_FIRST) ; - $a == 0 ; - $a = $H->get($k, $v, R_NEXT) ) - -=item 2. - -Notice that both times the C<put> method was used the record index was -specified using a variable, C<$i>, rather than the literal value -itself. This is because C<put> will return the record number of the -inserted line via that parameter. - -=back - -=head1 THE API INTERFACE - -As well as accessing Berkeley DB using a tied hash or array, it is also -possible to make direct use of most of the API functions defined in the -Berkeley DB documentation. - -To do this you need to store a copy of the object returned from the tie. - - $db = tie %hash, "DB_File", "filename" ; - -Once you have done that, you can access the Berkeley DB API functions -as B<DB_File> methods directly like this: - - $db->put($key, $value, R_NOOVERWRITE) ; - -B<Important:> If you have saved a copy of the object returned from -C<tie>, the underlying database file will I<not> be closed until both -the tied variable is untied and all copies of the saved object are -destroyed. - - use DB_File ; - $db = tie %hash, "DB_File", "filename" - or die "Cannot tie filename: $!" ; - ... - undef $db ; - untie %hash ; - -See L<The untie() Gotcha> for more details. - -All the functions defined in L<dbopen> are available except for -close() and dbopen() itself. The B<DB_File> method interface to the -supported functions have been implemented to mirror the way Berkeley DB -works whenever possible. In particular note that: - -=over 5 - -=item * - -The methods return a status value. All return 0 on success. -All return -1 to signify an error and set C<$!> to the exact -error code. The return code 1 generally (but not always) means that the -key specified did not exist in the database. - -Other return codes are defined. See below and in the Berkeley DB -documentation for details. The Berkeley DB documentation should be used -as the definitive source. - -=item * - -Whenever a Berkeley DB function returns data via one of its parameters, -the equivalent B<DB_File> method does exactly the same. - -=item * - -If you are careful, it is possible to mix API calls with the tied -hash/array interface in the same piece of code. Although only a few of -the methods used to implement the tied interface currently make use of -the cursor, you should always assume that the cursor has been changed -any time the tied hash/array interface is used. As an example, this -code will probably not do what you expect: - - $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE - or die "Cannot tie $filename: $!" ; - - # Get the first key/value pair and set the cursor - $X->seq($key, $value, R_FIRST) ; - - # this line will modify the cursor - $count = scalar keys %x ; - - # Get the second key/value pair. - # oops, it didn't, it got the last key/value pair! - $X->seq($key, $value, R_NEXT) ; - -The code above can be rearranged to get around the problem, like this: - - $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE - or die "Cannot tie $filename: $!" ; - - # this line will modify the cursor - $count = scalar keys %x ; - - # Get the first key/value pair and set the cursor - $X->seq($key, $value, R_FIRST) ; - - # Get the second key/value pair. - # worked this time. - $X->seq($key, $value, R_NEXT) ; - -=back - -All the constants defined in L<dbopen> for use in the flags parameters -in the methods defined below are also available. Refer to the Berkeley -DB documentation for the precise meaning of the flags values. - -Below is a list of the methods available. - -=over 5 - -=item B<$status = $X-E<gt>get($key, $value [, $flags]) ;> - -Given a key (C<$key>) this method reads the value associated with it -from the database. The value read from the database is returned in the -C<$value> parameter. - -If the key does not exist the method returns 1. - -No flags are currently defined for this method. - -=item B<$status = $X-E<gt>put($key, $value [, $flags]) ;> - -Stores the key/value pair in the database. - -If you use either the R_IAFTER or R_IBEFORE flags, the C<$key> parameter -will have the record number of the inserted key/value pair set. - -Valid flags are R_CURSOR, R_IAFTER, R_IBEFORE, R_NOOVERWRITE and -R_SETCURSOR. - -=item B<$status = $X-E<gt>del($key [, $flags]) ;> - -Removes all key/value pairs with key C<$key> from the database. - -A return code of 1 means that the requested key was not in the -database. - -R_CURSOR is the only valid flag at present. - -=item B<$status = $X-E<gt>fd ;> - -Returns the file descriptor for the underlying database. - -See L<Locking: The Trouble with fd> for an explanation for why you should -not use C<fd> to lock your database. - -=item B<$status = $X-E<gt>seq($key, $value, $flags) ;> - -This interface allows sequential retrieval from the database. See -L<dbopen> for full details. - -Both the C<$key> and C<$value> parameters will be set to the key/value -pair read from the database. - -The flags parameter is mandatory. The valid flag values are R_CURSOR, -R_FIRST, R_LAST, R_NEXT and R_PREV. - -=item B<$status = $X-E<gt>sync([$flags]) ;> - -Flushes any cached buffers to disk. - -R_RECNOSYNC is the only valid flag at present. - -=back - -=head1 DBM FILTERS - -A DBM Filter is a piece of code that is be used when you I<always> -want to make the same transformation to all keys and/or values in a -DBM database. - -There are four methods associated with DBM Filters. All work identically, -and each is used to install (or uninstall) a single DBM Filter. Each -expects a single parameter, namely a reference to a sub. The only -difference between them is the place that the filter is installed. - -To summarise: - -=over 5 - -=item B<filter_store_key> - -If a filter has been installed with this method, it will be invoked -every time you write a key to a DBM database. - -=item B<filter_store_value> - -If a filter has been installed with this method, it will be invoked -every time you write a value to a DBM database. - - -=item B<filter_fetch_key> - -If a filter has been installed with this method, it will be invoked -every time you read a key from a DBM database. - -=item B<filter_fetch_value> - -If a filter has been installed with this method, it will be invoked -every time you read a value from a DBM database. - -=back - -You can use any combination of the methods, from none, to all four. - -All filter methods return the existing filter, if present, or C<undef> -in not. - -To delete a filter pass C<undef> to it. - -=head2 The Filter - -When each filter is called by Perl, a local copy of C<$_> will contain -the key or value to be filtered. Filtering is achieved by modifying -the contents of C<$_>. The return code from the filter is ignored. - -=head2 An Example -- the NULL termination problem. - -Consider the following scenario. You have a DBM database -that you need to share with a third-party C application. The C application -assumes that I<all> keys and values are NULL terminated. Unfortunately -when Perl writes to DBM databases it doesn't use NULL termination, so -your Perl application will have to manage NULL termination itself. When -you write to the database you will have to use something like this: - - $hash{"$key\0"} = "$value\0" ; - -Similarly the NULL needs to be taken into account when you are considering -the length of existing keys/values. - -It would be much better if you could ignore the NULL terminations issue -in the main application code and have a mechanism that automatically -added the terminating NULL to all keys and values whenever you write to -the database and have them removed when you read from the database. As I'm -sure you have already guessed, this is a problem that DBM Filters can -fix very easily. - - use warnings ; - use strict ; - use DB_File ; - - my %hash ; - my $filename = "/tmp/filt" ; - unlink $filename ; - - my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH - or die "Cannot open $filename: $!\n" ; - - # Install DBM Filters - $db->filter_fetch_key ( sub { s/\0$// } ) ; - $db->filter_store_key ( sub { $_ .= "\0" } ) ; - $db->filter_fetch_value( sub { s/\0$// } ) ; - $db->filter_store_value( sub { $_ .= "\0" } ) ; - - $hash{"abc"} = "def" ; - my $a = $hash{"ABC"} ; - # ... - undef $db ; - untie %hash ; - -Hopefully the contents of each of the filters should be -self-explanatory. Both "fetch" filters remove the terminating NULL, -and both "store" filters add a terminating NULL. - - -=head2 Another Example -- Key is a C int. - -Here is another real-life example. By default, whenever Perl writes to -a DBM database it always writes the key and value as strings. So when -you use this: - - $hash{12345} = "soemthing" ; - -the key 12345 will get stored in the DBM database as the 5 byte string -"12345". If you actually want the key to be stored in the DBM database -as a C int, you will have to use C<pack> when writing, and C<unpack> -when reading. - -Here is a DBM Filter that does it: - - use warnings ; - use strict ; - use DB_File ; - my %hash ; - my $filename = "/tmp/filt" ; - unlink $filename ; - - - my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH - or die "Cannot open $filename: $!\n" ; - - $db->filter_fetch_key ( sub { $_ = unpack("i", $_) } ) ; - $db->filter_store_key ( sub { $_ = pack ("i", $_) } ) ; - $hash{123} = "def" ; - # ... - undef $db ; - untie %hash ; - -This time only two filters have been used -- we only need to manipulate -the contents of the key, so it wasn't necessary to install any value -filters. - -=head1 HINTS AND TIPS - - -=head2 Locking: The Trouble with fd - -Until version 1.72 of this module, the recommended technique for locking -B<DB_File> databases was to flock the filehandle returned from the "fd" -function. Unfortunately this technique has been shown to be fundamentally -flawed (Kudos to David Harris for tracking this down). Use it at your own -peril! - -The locking technique went like this. - - $db = tie(%db, 'DB_File', '/tmp/foo.db', O_CREAT|O_RDWR, 0644) - || die "dbcreat /tmp/foo.db $!"; - $fd = $db->fd; - open(DB_FH, "+<&=$fd") || die "dup $!"; - flock (DB_FH, LOCK_EX) || die "flock: $!"; - ... - $db{"Tom"} = "Jerry" ; - ... - flock(DB_FH, LOCK_UN); - undef $db; - untie %db; - close(DB_FH); - -In simple terms, this is what happens: - -=over 5 - -=item 1. - -Use "tie" to open the database. - -=item 2. - -Lock the database with fd & flock. - -=item 3. - -Read & Write to the database. - -=item 4. - -Unlock and close the database. - -=back - -Here is the crux of the problem. A side-effect of opening the B<DB_File> -database in step 2 is that an initial block from the database will get -read from disk and cached in memory. - -To see why this is a problem, consider what can happen when two processes, -say "A" and "B", both want to update the same B<DB_File> database -using the locking steps outlined above. Assume process "A" has already -opened the database and has a write lock, but it hasn't actually updated -the database yet (it has finished step 2, but not started step 3 yet). Now -process "B" tries to open the same database - step 1 will succeed, -but it will block on step 2 until process "A" releases the lock. The -important thing to notice here is that at this point in time both -processes will have cached identical initial blocks from the database. - -Now process "A" updates the database and happens to change some of the -data held in the initial buffer. Process "A" terminates, flushing -all cached data to disk and releasing the database lock. At this point -the database on disk will correctly reflect the changes made by process -"A". - -With the lock released, process "B" can now continue. It also updates the -database and unfortunately it too modifies the data that was in its -initial buffer. Once that data gets flushed to disk it will overwrite -some/all of the changes process "A" made to the database. - -The result of this scenario is at best a database that doesn't contain -what you expect. At worst the database will corrupt. - -The above won't happen every time competing process update the same -B<DB_File> database, but it does illustrate why the technique should -not be used. - -=head2 Safe ways to lock a database - -Starting with version 2.x, Berkeley DB has internal support for locking. -The companion module to this one, B<BerkeleyDB>, provides an interface -to this locking functionality. If you are serious about locking -Berkeley DB databases, I strongly recommend using B<BerkeleyDB>. - -If using B<BerkeleyDB> isn't an option, there are a number of modules -available on CPAN that can be used to implement locking. Each one -implements locking differently and has different goals in mind. It is -therefore worth knowing the difference, so that you can pick the right -one for your application. Here are the three locking wrappers: - -=over 5 - -=item B<Tie::DB_Lock> - -A B<DB_File> wrapper which creates copies of the database file for -read access, so that you have a kind of a multiversioning concurrent read -system. However, updates are still serial. Use for databases where reads -may be lengthy and consistency problems may occur. - -=item B<Tie::DB_LockFile> - -A B<DB_File> wrapper that has the ability to lock and unlock the database -while it is being used. Avoids the tie-before-flock problem by simply -re-tie-ing the database when you get or drop a lock. Because of the -flexibility in dropping and re-acquiring the lock in the middle of a -session, this can be massaged into a system that will work with long -updates and/or reads if the application follows the hints in the POD -documentation. - -=item B<DB_File::Lock> - -An extremely lightweight B<DB_File> wrapper that simply flocks a lockfile -before tie-ing the database and drops the lock after the untie. Allows -one to use the same lockfile for multiple databases to avoid deadlock -problems, if desired. Use for databases where updates are reads are -quick and simple flock locking semantics are enough. - -=back - -=head2 Sharing Databases With C Applications - -There is no technical reason why a Berkeley DB database cannot be -shared by both a Perl and a C application. - -The vast majority of problems that are reported in this area boil down -to the fact that C strings are NULL terminated, whilst Perl strings are -not. See L<DBM FILTERS> for a generic way to work around this problem. - -Here is a real example. Netscape 2.0 keeps a record of the locations you -visit along with the time you last visited them in a DB_HASH database. -This is usually stored in the file F<~/.netscape/history.db>. The key -field in the database is the location string and the value field is the -time the location was last visited stored as a 4 byte binary value. - -If you haven't already guessed, the location string is stored with a -terminating NULL. This means you need to be careful when accessing the -database. - -Here is a snippet of code that is loosely based on Tom Christiansen's -I<ggh> script (available from your nearest CPAN archive in -F<authors/id/TOMC/scripts/nshist.gz>). - - use warnings ; - use strict ; - use DB_File ; - use Fcntl ; - - use vars qw( $dotdir $HISTORY %hist_db $href $binary_time $date ) ; - $dotdir = $ENV{HOME} || $ENV{LOGNAME}; - - $HISTORY = "$dotdir/.netscape/history.db"; - - tie %hist_db, 'DB_File', $HISTORY - or die "Cannot open $HISTORY: $!\n" ;; - - # Dump the complete database - while ( ($href, $binary_time) = each %hist_db ) { - - # remove the terminating NULL - $href =~ s/\x00$// ; - - # convert the binary time into a user friendly string - $date = localtime unpack("V", $binary_time); - print "$date $href\n" ; - } - - # check for the existence of a specific key - # remember to add the NULL - if ( $binary_time = $hist_db{"http://mox.perl.com/\x00"} ) { - $date = localtime unpack("V", $binary_time) ; - print "Last visited mox.perl.com on $date\n" ; - } - else { - print "Never visited mox.perl.com\n" - } - - untie %hist_db ; - -=head2 The untie() Gotcha - -If you make use of the Berkeley DB API, it is I<very> strongly -recommended that you read L<perltie/The untie Gotcha>. - -Even if you don't currently make use of the API interface, it is still -worth reading it. - -Here is an example which illustrates the problem from a B<DB_File> -perspective: - - use DB_File ; - use Fcntl ; - - my %x ; - my $X ; - - $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_TRUNC - or die "Cannot tie first time: $!" ; - - $x{123} = 456 ; - - untie %x ; - - tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT - or die "Cannot tie second time: $!" ; - - untie %x ; - -When run, the script will produce this error message: - - Cannot tie second time: Invalid argument at bad.file line 14. - -Although the error message above refers to the second tie() statement -in the script, the source of the problem is really with the untie() -statement that precedes it. - -Having read L<perltie> you will probably have already guessed that the -error is caused by the extra copy of the tied object stored in C<$X>. -If you haven't, then the problem boils down to the fact that the -B<DB_File> destructor, DESTROY, will not be called until I<all> -references to the tied object are destroyed. Both the tied variable, -C<%x>, and C<$X> above hold a reference to the object. The call to -untie() will destroy the first, but C<$X> still holds a valid -reference, so the destructor will not get called and the database file -F<tst.fil> will remain open. The fact that Berkeley DB then reports the -attempt to open a database that is already open via the catch-all -"Invalid argument" doesn't help. - -If you run the script with the C<-w> flag the error message becomes: - - untie attempted while 1 inner references still exist at bad.file line 12. - Cannot tie second time: Invalid argument at bad.file line 14. - -which pinpoints the real problem. Finally the script can now be -modified to fix the original problem by destroying the API object -before the untie: - - ... - $x{123} = 456 ; - - undef $X ; - untie %x ; - - $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT - ... - - -=head1 COMMON QUESTIONS - -=head2 Why is there Perl source in my database? - -If you look at the contents of a database file created by DB_File, -there can sometimes be part of a Perl script included in it. - -This happens because Berkeley DB uses dynamic memory to allocate -buffers which will subsequently be written to the database file. Being -dynamic, the memory could have been used for anything before DB -malloced it. As Berkeley DB doesn't clear the memory once it has been -allocated, the unused portions will contain random junk. In the case -where a Perl script gets written to the database, the random junk will -correspond to an area of dynamic memory that happened to be used during -the compilation of the script. - -Unless you don't like the possibility of there being part of your Perl -scripts embedded in a database file, this is nothing to worry about. - -=head2 How do I store complex data structures with DB_File? - -Although B<DB_File> cannot do this directly, there is a module which -can layer transparently over B<DB_File> to accomplish this feat. - -Check out the MLDBM module, available on CPAN in the directory -F<modules/by-module/MLDBM>. - -=head2 What does "Invalid Argument" mean? - -You will get this error message when one of the parameters in the -C<tie> call is wrong. Unfortunately there are quite a few parameters to -get wrong, so it can be difficult to figure out which one it is. - -Here are a couple of possibilities: - -=over 5 - -=item 1. - -Attempting to reopen a database without closing it. - -=item 2. - -Using the O_WRONLY flag. - -=back - -=head2 What does "Bareword 'DB_File' not allowed" mean? - -You will encounter this particular error message when you have the -C<strict 'subs'> pragma (or the full strict pragma) in your script. -Consider this script: - - use warnings ; - use strict ; - use DB_File ; - use vars qw(%x) ; - tie %x, DB_File, "filename" ; - -Running it produces the error in question: - - Bareword "DB_File" not allowed while "strict subs" in use - -To get around the error, place the word C<DB_File> in either single or -double quotes, like this: - - tie %x, "DB_File", "filename" ; - -Although it might seem like a real pain, it is really worth the effort -of having a C<use strict> in all your scripts. - -=head1 REFERENCES - -Articles that are either about B<DB_File> or make use of it. - -=over 5 - -=item 1. - -I<Full-Text Searching in Perl>, Tim Kientzle (tkientzle@ddj.com), -Dr. Dobb's Journal, Issue 295, January 1999, pp 34-41 - -=back - -=head1 HISTORY - -Moved to the Changes file. - -=head1 BUGS - -Some older versions of Berkeley DB had problems with fixed length -records using the RECNO file format. This problem has been fixed since -version 1.85 of Berkeley DB. - -I am sure there are bugs in the code. If you do find any, or can -suggest any enhancements, I would welcome your comments. - -=head1 AVAILABILITY - -B<DB_File> comes with the standard Perl source distribution. Look in -the directory F<ext/DB_File>. Given the amount of time between releases -of Perl the version that ships with Perl is quite likely to be out of -date, so the most recent version can always be found on CPAN (see -L<perlmod/CPAN> for details), in the directory -F<modules/by-module/DB_File>. - -This version of B<DB_File> will work with either version 1.x, 2.x or -3.x of Berkeley DB, but is limited to the functionality provided by -version 1. - -The official web site for Berkeley DB is F<http://www.sleepycat.com>. -All versions of Berkeley DB are available there. - -Alternatively, Berkeley DB version 1 is available at your nearest CPAN -archive in F<src/misc/db.1.85.tar.gz>. - -If you are running IRIX, then get Berkeley DB version 1 from -F<http://reality.sgi.com/ariel>. It has the patches necessary to -compile properly on IRIX 5.3. - -=head1 COPYRIGHT - -Copyright (c) 1995-1999 Paul Marquess. All rights reserved. This program -is free software; you can redistribute it and/or modify it under the -same terms as Perl itself. - -Although B<DB_File> is covered by the Perl license, the library it -makes use of, namely Berkeley DB, is not. Berkeley DB has its own -copyright and its own license. Please take the time to read it. - -Here are are few words taken from the Berkeley DB FAQ (at -F<http://www.sleepycat.com>) regarding the license: - - Do I have to license DB to use it in Perl scripts? - - No. The Berkeley DB license requires that software that uses - Berkeley DB be freely redistributable. In the case of Perl, that - software is Perl, and not your scripts. Any Perl scripts that you - write are your property, including scripts that make use of - Berkeley DB. Neither the Perl license nor the Berkeley DB license - place any restriction on what you may do with them. - -If you are in any doubt about the license situation, contact either the -Berkeley DB authors or the author of DB_File. See L<"AUTHOR"> for details. - - -=head1 SEE ALSO - -L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)>, -L<dbmfilter> - -=head1 AUTHOR - -The DB_File interface was written by Paul Marquess -E<lt>Paul.Marquess@btinternet.comE<gt>. -Questions about the DB system itself may be addressed to -E<lt>db@sleepycat.com<gt>. - -=cut diff --git a/contrib/perl5/ext/DB_File/DB_File.xs b/contrib/perl5/ext/DB_File/DB_File.xs deleted file mode 100644 index fa3bb33..0000000 --- a/contrib/perl5/ext/DB_File/DB_File.xs +++ /dev/null @@ -1,2071 +0,0 @@ -/* - - DB_File.xs -- Perl 5 interface to Berkeley DB - - written by Paul Marquess <Paul.Marquess@btinternet.com> - last modified 17 December 2000 - version 1.75 - - All comments/suggestions/problems are welcome - - Copyright (c) 1995-2000 Paul Marquess. All rights reserved. - This program is free software; you can redistribute it and/or - modify it under the same terms as Perl itself. - - Changes: - 0.1 - Initial Release - 0.2 - No longer bombs out if dbopen returns an error. - 0.3 - Added some support for multiple btree compares - 1.0 - Complete support for multiple callbacks added. - Fixed a problem with pushing a value onto an empty list. - 1.01 - Fixed a SunOS core dump problem. - The return value from TIEHASH wasn't set to NULL when - dbopen returned an error. - 1.02 - Use ALIAS to define TIEARRAY. - Removed some redundant commented code. - Merged OS2 code into the main distribution. - Allow negative subscripts with RECNO interface. - Changed the default flags to O_CREAT|O_RDWR - 1.03 - Added EXISTS - 1.04 - fixed a couple of bugs in hash_cb. Patches supplied by - Dave Hammen, hammen@gothamcity.jsc.nasa.gov - 1.05 - Added logic to allow prefix & hash types to be specified via - Makefile.PL - 1.06 - Minor namespace cleanup: Localized PrintBtree. - 1.07 - Fixed bug with RECNO, where bval wasn't defaulting to "\n". - 1.08 - No change to DB_File.xs - 1.09 - Default mode for dbopen changed to 0666 - 1.10 - Fixed fd method so that it still returns -1 for - in-memory files when db 1.86 is used. - 1.11 - No change to DB_File.xs - 1.12 - No change to DB_File.xs - 1.13 - Tidied up a few casts. - 1.14 - Made it illegal to tie an associative array to a RECNO - database and an ordinary array to a HASH or BTREE database. - 1.50 - Make work with both DB 1.x or DB 2.x - 1.51 - Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent - 1.52 - Patch from Gisle Aas <gisle@aas.no> to suppress "use of - undefined value" warning with db_get and db_seq. - 1.53 - Added DB_RENUMBER to flags for recno. - 1.54 - Fixed bug in the fd method - 1.55 - Fix for AIX from Jarkko Hietaniemi - 1.56 - No change to DB_File.xs - 1.57 - added the #undef op to allow building with Threads support. - 1.58 - Fixed a problem with the use of sv_setpvn. When the - size is specified as 0, it does a strlen on the data. - This was ok for DB 1.x, but isn't for DB 2.x. - 1.59 - No change to DB_File.xs - 1.60 - Some code tidy up - 1.61 - added flagSet macro for DB 2.5.x - fixed typo in O_RDONLY test. - 1.62 - No change to DB_File.xs - 1.63 - Fix to alllow DB 2.6.x to build. - 1.64 - Tidied up the 1.x to 2.x flags mapping code. - Added a patch from Mark Kettenis <kettenis@wins.uva.nl> - to fix a flag mapping problem with O_RDONLY on the Hurd - 1.65 - Fixed a bug in the PUSH logic. - Added BOOT check that using 2.3.4 or greater - 1.66 - Added DBM filter code - 1.67 - Backed off the use of newSVpvn. - Fixed DBM Filter code for Perl 5.004. - Fixed a small memory leak in the filter code. - 1.68 - fixed backward compatability bug with R_IAFTER & R_IBEFORE - merged in the 5.005_58 changes - 1.69 - fixed a bug in push -- DB_APPEND wasn't working properly. - Fixed the R_SETCURSOR bug introduced in 1.68 - Added a new Perl variable $DB_File::db_ver - 1.70 - Initialise $DB_File::db_ver and $DB_File::db_version with - GV_ADD|GV_ADDMULT -- bug spotted by Nick Ing-Simmons. - Added a BOOT check to test for equivalent versions of db.h & - libdb.a/so. - 1.71 - Support for Berkeley DB version 3. - 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 - 1.74 - A call to open needed parenthesised to stop it clashing - with a win32 macro. - Added Perl core patches 7703 & 7801. - 1.75 - Fixed Perl core patch 7703. - Added suppport to allow DB_File to be built with - Berkeley DB 3.2 -- btree_compare, btree_prefix and hash_cb - needed to be changed. - -*/ - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#ifndef PERL_VERSION -# include "patchlevel.h" -# define PERL_REVISION 5 -# define PERL_VERSION PATCHLEVEL -# define PERL_SUBVERSION SUBVERSION -#endif - -#if PERL_REVISION == 5 && (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION <= 75 )) - -# define PL_sv_undef sv_undef -# define PL_na na - -#endif - -/* DEFSV appears first in 5.004_56 */ -#ifndef DEFSV -# define DEFSV GvSV(defgv) -#endif - -/* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be - * shortly #included by the <db.h>) __attribute__ to the possibly - * already defined __attribute__, for example by GNUC or by Perl. */ - -#undef __attribute__ - -/* If Perl has been compiled with Threads support,the symbol op will - be defined here. This clashes with a field name in db.h, so get rid of it. - */ -#ifdef op -# undef op -#endif - -#ifdef COMPAT185 -# include <db_185.h> -#else -# include <db.h> -#endif - -#ifdef CAN_PROTOTYPE -extern void __getBerkeleyDBInfo(void); -#endif - -#ifndef pTHX -# define pTHX -# define pTHX_ -# define aTHX -# define aTHX_ -#endif - -#ifndef newSVpvn -# define newSVpvn(a,b) newSVpv(a,b) -#endif - -#include <fcntl.h> - -/* #define TRACE */ -#define DBM_FILTERING - -#ifdef TRACE -# define Trace(x) printf x -#else -# define Trace(x) -#endif - - -#define DBT_clear(x) Zero(&x, 1, DBT) ; - -#ifdef DB_VERSION_MAJOR - -#if DB_VERSION_MAJOR == 2 -# define BERKELEY_DB_1_OR_2 -#endif - -#if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 2) -# define AT_LEAST_DB_3_2 -#endif - -/* map version 2 features & constants onto their version 1 equivalent */ - -#ifdef DB_Prefix_t -# undef DB_Prefix_t -#endif -#define DB_Prefix_t size_t - -#ifdef DB_Hash_t -# undef DB_Hash_t -#endif -#define DB_Hash_t u_int32_t - -/* DBTYPE stays the same */ -/* HASHINFO, RECNOINFO and BTREEINFO map to DB_INFO */ -#if DB_VERSION_MAJOR == 2 - typedef DB_INFO INFO ; -#else /* DB_VERSION_MAJOR > 2 */ -# define DB_FIXEDLEN (0x8000) -#endif /* DB_VERSION_MAJOR == 2 */ - -/* version 2 has db_recno_t in place of recno_t */ -typedef db_recno_t recno_t; - - -#define R_CURSOR DB_SET_RANGE -#define R_FIRST DB_FIRST -#define R_IAFTER DB_AFTER -#define R_IBEFORE DB_BEFORE -#define R_LAST DB_LAST -#define R_NEXT DB_NEXT -#define R_NOOVERWRITE DB_NOOVERWRITE -#define R_PREV DB_PREV - -#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 -# define R_SETCURSOR 0x800000 -#else -# define R_SETCURSOR (-100) -#endif - -#define R_RECNOSYNC 0 -#define R_FIXEDLEN DB_FIXEDLEN -#define R_DUP DB_DUP - - -#define db_HA_hash h_hash -#define db_HA_ffactor h_ffactor -#define db_HA_nelem h_nelem -#define db_HA_bsize db_pagesize -#define db_HA_cachesize db_cachesize -#define db_HA_lorder db_lorder - -#define db_BT_compare bt_compare -#define db_BT_prefix bt_prefix -#define db_BT_flags flags -#define db_BT_psize db_pagesize -#define db_BT_cachesize db_cachesize -#define db_BT_lorder db_lorder -#define db_BT_maxkeypage -#define db_BT_minkeypage - - -#define db_RE_reclen re_len -#define db_RE_flags flags -#define db_RE_bval re_pad -#define db_RE_bfname re_source -#define db_RE_psize db_pagesize -#define db_RE_cachesize db_cachesize -#define db_RE_lorder db_lorder - -#define TXN NULL, - -#define do_SEQ(db, key, value, flag) (db->cursor->c_get)(db->cursor, &key, &value, flag) - - -#define DBT_flags(x) x.flags = 0 -#define DB_flags(x, v) x |= v - -#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 -# define flagSet(flags, bitmask) ((flags) & (bitmask)) -#else -# define flagSet(flags, bitmask) (((flags) & DB_OPFLAGS_MASK) == (bitmask)) -#endif - -#else /* db version 1.x */ - -#define BERKELEY_DB_1 -#define BERKELEY_DB_1_OR_2 - -typedef union INFO { - HASHINFO hash ; - RECNOINFO recno ; - BTREEINFO btree ; - } INFO ; - - -#ifdef mDB_Prefix_t -# ifdef DB_Prefix_t -# undef DB_Prefix_t -# endif -# define DB_Prefix_t mDB_Prefix_t -#endif - -#ifdef mDB_Hash_t -# ifdef DB_Hash_t -# undef DB_Hash_t -# endif -# define DB_Hash_t mDB_Hash_t -#endif - -#define db_HA_hash hash.hash -#define db_HA_ffactor hash.ffactor -#define db_HA_nelem hash.nelem -#define db_HA_bsize hash.bsize -#define db_HA_cachesize hash.cachesize -#define db_HA_lorder hash.lorder - -#define db_BT_compare btree.compare -#define db_BT_prefix btree.prefix -#define db_BT_flags btree.flags -#define db_BT_psize btree.psize -#define db_BT_cachesize btree.cachesize -#define db_BT_lorder btree.lorder -#define db_BT_maxkeypage btree.maxkeypage -#define db_BT_minkeypage btree.minkeypage - -#define db_RE_reclen recno.reclen -#define db_RE_flags recno.flags -#define db_RE_bval recno.bval -#define db_RE_bfname recno.bfname -#define db_RE_psize recno.psize -#define db_RE_cachesize recno.cachesize -#define db_RE_lorder recno.lorder - -#define TXN - -#define do_SEQ(db, key, value, flag) (db->dbp->seq)(db->dbp, &key, &value, flag) -#define DBT_flags(x) -#define DB_flags(x, v) -#define flagSet(flags, bitmask) ((flags) & (bitmask)) - -#endif /* db version 1 */ - - - -#define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, TXN &key, flags) -#define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, TXN &key, &value, flags) -#define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) - -#define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags) -#define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) - -#ifdef DB_VERSION_MAJOR -#define db_DESTROY(db) ( db->cursor->c_close(db->cursor),\ - (db->dbp->close)(db->dbp, 0) ) -#define db_close(db) ((db->dbp)->close)(db->dbp, 0) -#define db_del(db, key, flags) (flagSet(flags, R_CURSOR) \ - ? ((db->cursor)->c_del)(db->cursor, 0) \ - : ((db->dbp)->del)(db->dbp, NULL, &key, flags) ) - -#else /* ! DB_VERSION_MAJOR */ - -#define db_DESTROY(db) ((db->dbp)->close)(db->dbp) -#define db_close(db) ((db->dbp)->close)(db->dbp) -#define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags) -#define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags) - -#endif /* ! DB_VERSION_MAJOR */ - - -#define db_seq(db, key, value, flags) do_SEQ(db, key, value, flags) - -typedef struct { - DBTYPE type ; - DB * dbp ; - SV * compare ; - SV * prefix ; - SV * hash ; - int in_memory ; -#ifdef BERKELEY_DB_1_OR_2 - INFO info ; -#endif -#ifdef DB_VERSION_MAJOR - DBC * cursor ; -#endif -#ifdef DBM_FILTERING - SV * filter_fetch_key ; - SV * filter_store_key ; - SV * filter_fetch_value ; - SV * filter_store_value ; - int filtering ; -#endif /* DBM_FILTERING */ - - } DB_File_type; - -typedef DB_File_type * DB_File ; -typedef DBT DBTKEY ; - -#ifdef DBM_FILTERING - -#define ckFilter(arg,type,name) \ - if (db->type) { \ - SV * save_defsv ; \ - /* printf("filtering %s\n", name) ;*/ \ - if (db->filtering) \ - croak("recursion detected in %s", name) ; \ - db->filtering = TRUE ; \ - save_defsv = newSVsv(DEFSV) ; \ - sv_setsv(DEFSV, arg) ; \ - PUSHMARK(sp) ; \ - (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); \ - sv_setsv(arg, DEFSV) ; \ - sv_setsv(DEFSV, save_defsv) ; \ - SvREFCNT_dec(save_defsv) ; \ - db->filtering = FALSE ; \ - /*printf("end of filtering %s\n", name) ;*/ \ - } - -#else - -#define ckFilter(arg,type, name) - -#endif /* DBM_FILTERING */ - -#define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (void*)""), s) - -#define OutputValue(arg, name) \ - { if (RETVAL == 0) { \ - my_sv_setpvn(arg, name.data, name.size) ; \ - ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \ - } \ - } - -#define OutputKey(arg, name) \ - { if (RETVAL == 0) \ - { \ - if (db->type != DB_RECNO) { \ - my_sv_setpvn(arg, name.data, name.size); \ - } \ - else \ - sv_setiv(arg, (I32)*(I32*)name.data - 1); \ - ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \ - } \ - } - - -/* Internal Global Data */ -static recno_t Value ; -static recno_t zero = 0 ; -static DB_File CurrentDB ; -static DBTKEY empty ; - -#ifdef DB_VERSION_MAJOR - -static int -#ifdef CAN_PROTOTYPE -db_put(DB_File db, DBTKEY key, DBT value, u_int flags) -#else -db_put(db, key, value, flags) -DB_File db ; -DBTKEY key ; -DBT value ; -u_int flags ; -#endif -{ - int status ; - - if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) { - DBC * temp_cursor ; - DBT l_key, l_value; - -#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6 - if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor) != 0) -#else - if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor, 0) != 0) -#endif - return (-1) ; - - memset(&l_key, 0, sizeof(l_key)); - l_key.data = key.data; - l_key.size = key.size; - memset(&l_value, 0, sizeof(l_value)); - l_value.data = value.data; - l_value.size = value.size; - - if ( temp_cursor->c_get(temp_cursor, &l_key, &l_value, DB_SET) != 0) { - (void)temp_cursor->c_close(temp_cursor); - return (-1); - } - - status = temp_cursor->c_put(temp_cursor, &key, &value, flags); - (void)temp_cursor->c_close(temp_cursor); - - return (status) ; - } - - - if (flagSet(flags, R_CURSOR)) { - return ((db->cursor)->c_put)(db->cursor, &key, &value, DB_CURRENT); - } - - if (flagSet(flags, R_SETCURSOR)) { - if ((db->dbp)->put(db->dbp, NULL, &key, &value, 0) != 0) - return -1 ; - return ((db->cursor)->c_get)(db->cursor, &key, &value, DB_SET_RANGE); - - } - - return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ; - -} - -#endif /* DB_VERSION_MAJOR */ - - -static int -#ifdef AT_LEAST_DB_3_2 - -#ifdef CAN_PROTOTYPE -btree_compare(DB * db, const DBT *key1, const DBT *key2) -#else -btree_compare(db, key1, key2) -DB * db ; -const DBT * key1 ; -const DBT * key2 ; -#endif /* CAN_PROTOTYPE */ - -#else /* Berkeley DB < 3.2 */ - -#ifdef CAN_PROTOTYPE -btree_compare(const DBT *key1, const DBT *key2) -#else -btree_compare(key1, key2) -const DBT * key1 ; -const DBT * key2 ; -#endif - -#endif - -{ -#ifdef dTHX - dTHX; -#endif - dSP ; - void * data1, * data2 ; - int retval ; - int count ; - - data1 = key1->data ; - data2 = key2->data ; - -#ifndef newSVpvn - /* As newSVpv will assume that the data pointer is a null terminated C - string if the size parameter is 0, make sure that data points to an - empty string if the length is 0 - */ - if (key1->size == 0) - data1 = "" ; - if (key2->size == 0) - data2 = "" ; -#endif - - ENTER ; - SAVETMPS; - - PUSHMARK(SP) ; - EXTEND(SP,2) ; - PUSHs(sv_2mortal(newSVpvn(data1,key1->size))); - PUSHs(sv_2mortal(newSVpvn(data2,key2->size))); - PUTBACK ; - - count = perl_call_sv(CurrentDB->compare, G_SCALAR); - - SPAGAIN ; - - if (count != 1) - croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ; - - retval = POPi ; - - PUTBACK ; - FREETMPS ; - LEAVE ; - return (retval) ; - -} - -static DB_Prefix_t -#ifdef AT_LEAST_DB_3_2 - -#ifdef CAN_PROTOTYPE -btree_prefix(DB * db, const DBT *key1, const DBT *key2) -#else -btree_prefix(db, key1, key2) -Db * db ; -const DBT * key1 ; -const DBT * key2 ; -#endif - -#else /* Berkeley DB < 3.2 */ - -#ifdef CAN_PROTOTYPE -btree_prefix(const DBT *key1, const DBT *key2) -#else -btree_prefix(key1, key2) -const DBT * key1 ; -const DBT * key2 ; -#endif - -#endif -{ -#ifdef dTHX - dTHX; -#endif - dSP ; - void * data1, * data2 ; - int retval ; - int count ; - - data1 = key1->data ; - data2 = key2->data ; - -#ifndef newSVpvn - /* As newSVpv will assume that the data pointer is a null terminated C - string if the size parameter is 0, make sure that data points to an - empty string if the length is 0 - */ - if (key1->size == 0) - data1 = "" ; - if (key2->size == 0) - data2 = "" ; -#endif - - ENTER ; - SAVETMPS; - - PUSHMARK(SP) ; - EXTEND(SP,2) ; - PUSHs(sv_2mortal(newSVpvn(data1,key1->size))); - PUSHs(sv_2mortal(newSVpvn(data2,key2->size))); - PUTBACK ; - - count = perl_call_sv(CurrentDB->prefix, G_SCALAR); - - SPAGAIN ; - - if (count != 1) - croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ; - - retval = POPi ; - - PUTBACK ; - FREETMPS ; - LEAVE ; - - return (retval) ; -} - - -#ifdef BERKELEY_DB_1 -# define HASH_CB_SIZE_TYPE size_t -#else -# define HASH_CB_SIZE_TYPE u_int32_t -#endif - -static DB_Hash_t -#ifdef AT_LEAST_DB_3_2 - -#ifdef CAN_PROTOTYPE -hash_cb(DB * db, const void *data, u_int32_t size) -#else -hash_cb(db, data, size) -DB * db ; -const void * data ; -HASH_CB_SIZE_TYPE size ; -#endif - -#else /* Berkeley DB < 3.2 */ - -#ifdef CAN_PROTOTYPE -hash_cb(const void *data, HASH_CB_SIZE_TYPE size) -#else -hash_cb(data, size) -const void * data ; -HASH_CB_SIZE_TYPE size ; -#endif - -#endif -{ -#ifdef dTHX - dTHX; -#endif - dSP ; - int retval ; - int count ; - -#ifndef newSVpvn - if (size == 0) - data = "" ; -#endif - - /* DGH - Next two lines added to fix corrupted stack problem */ - ENTER ; - SAVETMPS; - - PUSHMARK(SP) ; - - XPUSHs(sv_2mortal(newSVpvn((char*)data,size))); - PUTBACK ; - - count = perl_call_sv(CurrentDB->hash, G_SCALAR); - - SPAGAIN ; - - if (count != 1) - croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ; - - retval = POPi ; - - PUTBACK ; - FREETMPS ; - LEAVE ; - - return (retval) ; -} - - -#if defined(TRACE) && defined(BERKELEY_DB_1_OR_2) - -static void -#ifdef CAN_PROTOTYPE -PrintHash(INFO *hash) -#else -PrintHash(hash) -INFO * hash ; -#endif -{ - printf ("HASH Info\n") ; - printf (" hash = %s\n", - (hash->db_HA_hash != NULL ? "redefined" : "default")) ; - printf (" bsize = %d\n", hash->db_HA_bsize) ; - printf (" ffactor = %d\n", hash->db_HA_ffactor) ; - printf (" nelem = %d\n", hash->db_HA_nelem) ; - printf (" cachesize = %d\n", hash->db_HA_cachesize) ; - printf (" lorder = %d\n", hash->db_HA_lorder) ; - -} - -static void -#ifdef CAN_PROTOTYPE -PrintRecno(INFO *recno) -#else -PrintRecno(recno) -INFO * recno ; -#endif -{ - printf ("RECNO Info\n") ; - printf (" flags = %d\n", recno->db_RE_flags) ; - printf (" cachesize = %d\n", recno->db_RE_cachesize) ; - printf (" psize = %d\n", recno->db_RE_psize) ; - printf (" lorder = %d\n", recno->db_RE_lorder) ; - printf (" reclen = %ul\n", (unsigned long)recno->db_RE_reclen) ; - printf (" bval = %d 0x%x\n", recno->db_RE_bval, recno->db_RE_bval) ; - printf (" bfname = %d [%s]\n", recno->db_RE_bfname, recno->db_RE_bfname) ; -} - -static void -#ifdef CAN_PROTOTYPE -PrintBtree(INFO *btree) -#else -PrintBtree(btree) -INFO * btree ; -#endif -{ - printf ("BTREE Info\n") ; - printf (" compare = %s\n", - (btree->db_BT_compare ? "redefined" : "default")) ; - printf (" prefix = %s\n", - (btree->db_BT_prefix ? "redefined" : "default")) ; - printf (" flags = %d\n", btree->db_BT_flags) ; - printf (" cachesize = %d\n", btree->db_BT_cachesize) ; - printf (" psize = %d\n", btree->db_BT_psize) ; -#ifndef DB_VERSION_MAJOR - printf (" maxkeypage = %d\n", btree->db_BT_maxkeypage) ; - printf (" minkeypage = %d\n", btree->db_BT_minkeypage) ; -#endif - printf (" lorder = %d\n", btree->db_BT_lorder) ; -} - -#else - -#define PrintRecno(recno) -#define PrintHash(hash) -#define PrintBtree(btree) - -#endif /* TRACE */ - - -static I32 -#ifdef CAN_PROTOTYPE -GetArrayLength(pTHX_ DB_File db) -#else -GetArrayLength(db) -DB_File db ; -#endif -{ - DBT key ; - DBT value ; - int RETVAL ; - - DBT_clear(key) ; - DBT_clear(value) ; - RETVAL = do_SEQ(db, key, value, R_LAST) ; - if (RETVAL == 0) - RETVAL = *(I32 *)key.data ; - else /* No key means empty file */ - RETVAL = 0 ; - - return ((I32)RETVAL) ; -} - -static recno_t -#ifdef CAN_PROTOTYPE -GetRecnoKey(pTHX_ DB_File db, I32 value) -#else -GetRecnoKey(db, value) -DB_File db ; -I32 value ; -#endif -{ - if (value < 0) { - /* Get the length of the array */ - I32 length = GetArrayLength(aTHX_ db) ; - - /* check for attempt to write before start of array */ - if (length + value + 1 <= 0) - croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ; - - value = length + value + 1 ; - } - else - ++ value ; - - return value ; -} - - -static DB_File -#ifdef CAN_PROTOTYPE -ParseOpenInfo(pTHX_ int isHASH, char *name, int flags, int mode, SV *sv) -#else -ParseOpenInfo(isHASH, name, flags, mode, sv) -int isHASH ; -char * name ; -int flags ; -int mode ; -SV * sv ; -#endif -{ - -#ifdef BERKELEY_DB_1_OR_2 /* Berkeley DB Version 1 or 2 */ - - SV ** svp; - HV * action ; - DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; - void * openinfo = NULL ; - INFO * info = &RETVAL->info ; - STRLEN n_a; - -/* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */ - Zero(RETVAL, 1, DB_File_type) ; - - /* Default to HASH */ -#ifdef DBM_FILTERING - RETVAL->filtering = 0 ; - RETVAL->filter_fetch_key = RETVAL->filter_store_key = - RETVAL->filter_fetch_value = RETVAL->filter_store_value = -#endif /* DBM_FILTERING */ - RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ; - RETVAL->type = DB_HASH ; - - /* DGH - Next line added to avoid SEGV on existing hash DB */ - CurrentDB = RETVAL; - - /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */ - RETVAL->in_memory = (name == NULL) ; - - if (sv) - { - if (! SvROK(sv) ) - croak ("type parameter is not a reference") ; - - svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ; - if (svp && SvOK(*svp)) - action = (HV*) SvRV(*svp) ; - else - croak("internal error") ; - - if (sv_isa(sv, "DB_File::HASHINFO")) - { - - if (!isHASH) - croak("DB_File can only tie an associative array to a DB_HASH database") ; - - RETVAL->type = DB_HASH ; - openinfo = (void*)info ; - - svp = hv_fetch(action, "hash", 4, FALSE); - - if (svp && SvOK(*svp)) - { - info->db_HA_hash = hash_cb ; - RETVAL->hash = newSVsv(*svp) ; - } - else - info->db_HA_hash = NULL ; - - svp = hv_fetch(action, "ffactor", 7, FALSE); - info->db_HA_ffactor = svp ? SvIV(*svp) : 0; - - svp = hv_fetch(action, "nelem", 5, FALSE); - info->db_HA_nelem = svp ? SvIV(*svp) : 0; - - svp = hv_fetch(action, "bsize", 5, FALSE); - info->db_HA_bsize = svp ? SvIV(*svp) : 0; - - svp = hv_fetch(action, "cachesize", 9, FALSE); - info->db_HA_cachesize = svp ? SvIV(*svp) : 0; - - svp = hv_fetch(action, "lorder", 6, FALSE); - info->db_HA_lorder = svp ? SvIV(*svp) : 0; - - PrintHash(info) ; - } - else if (sv_isa(sv, "DB_File::BTREEINFO")) - { - if (!isHASH) - croak("DB_File can only tie an associative array to a DB_BTREE database"); - - RETVAL->type = DB_BTREE ; - openinfo = (void*)info ; - - svp = hv_fetch(action, "compare", 7, FALSE); - if (svp && SvOK(*svp)) - { - info->db_BT_compare = btree_compare ; - RETVAL->compare = newSVsv(*svp) ; - } - else - info->db_BT_compare = NULL ; - - svp = hv_fetch(action, "prefix", 6, FALSE); - if (svp && SvOK(*svp)) - { - info->db_BT_prefix = btree_prefix ; - RETVAL->prefix = newSVsv(*svp) ; - } - else - info->db_BT_prefix = NULL ; - - svp = hv_fetch(action, "flags", 5, FALSE); - info->db_BT_flags = svp ? SvIV(*svp) : 0; - - svp = hv_fetch(action, "cachesize", 9, FALSE); - info->db_BT_cachesize = svp ? SvIV(*svp) : 0; - -#ifndef DB_VERSION_MAJOR - svp = hv_fetch(action, "minkeypage", 10, FALSE); - info->btree.minkeypage = svp ? SvIV(*svp) : 0; - - svp = hv_fetch(action, "maxkeypage", 10, FALSE); - info->btree.maxkeypage = svp ? SvIV(*svp) : 0; -#endif - - svp = hv_fetch(action, "psize", 5, FALSE); - info->db_BT_psize = svp ? SvIV(*svp) : 0; - - svp = hv_fetch(action, "lorder", 6, FALSE); - info->db_BT_lorder = svp ? SvIV(*svp) : 0; - - PrintBtree(info) ; - - } - else if (sv_isa(sv, "DB_File::RECNOINFO")) - { - if (isHASH) - croak("DB_File can only tie an array to a DB_RECNO database"); - - RETVAL->type = DB_RECNO ; - openinfo = (void *)info ; - - info->db_RE_flags = 0 ; - - svp = hv_fetch(action, "flags", 5, FALSE); - info->db_RE_flags = (u_long) (svp ? SvIV(*svp) : 0); - - svp = hv_fetch(action, "reclen", 6, FALSE); - info->db_RE_reclen = (size_t) (svp ? SvIV(*svp) : 0); - - svp = hv_fetch(action, "cachesize", 9, FALSE); - info->db_RE_cachesize = (u_int) (svp ? SvIV(*svp) : 0); - - svp = hv_fetch(action, "psize", 5, FALSE); - info->db_RE_psize = (u_int) (svp ? SvIV(*svp) : 0); - - svp = hv_fetch(action, "lorder", 6, FALSE); - info->db_RE_lorder = (int) (svp ? SvIV(*svp) : 0); - -#ifdef DB_VERSION_MAJOR - info->re_source = name ; - name = NULL ; -#endif - svp = hv_fetch(action, "bfname", 6, FALSE); - if (svp && SvOK(*svp)) { - char * ptr = SvPV(*svp,n_a) ; -#ifdef DB_VERSION_MAJOR - name = (char*) n_a ? ptr : NULL ; -#else - info->db_RE_bfname = (char*) (n_a ? ptr : NULL) ; -#endif - } - else -#ifdef DB_VERSION_MAJOR - name = NULL ; -#else - info->db_RE_bfname = NULL ; -#endif - - svp = hv_fetch(action, "bval", 4, FALSE); -#ifdef DB_VERSION_MAJOR - if (svp && SvOK(*svp)) - { - int value ; - if (SvPOK(*svp)) - value = (int)*SvPV(*svp, n_a) ; - else - value = SvIV(*svp) ; - - if (info->flags & DB_FIXEDLEN) { - info->re_pad = value ; - info->flags |= DB_PAD ; - } - else { - info->re_delim = value ; - info->flags |= DB_DELIMITER ; - } - - } -#else - if (svp && SvOK(*svp)) - { - if (SvPOK(*svp)) - info->db_RE_bval = (u_char)*SvPV(*svp, n_a) ; - else - info->db_RE_bval = (u_char)(unsigned long) SvIV(*svp) ; - DB_flags(info->flags, DB_DELIMITER) ; - - } - else - { - if (info->db_RE_flags & R_FIXEDLEN) - info->db_RE_bval = (u_char) ' ' ; - else - info->db_RE_bval = (u_char) '\n' ; - DB_flags(info->flags, DB_DELIMITER) ; - } -#endif - -#ifdef DB_RENUMBER - info->flags |= DB_RENUMBER ; -#endif - - PrintRecno(info) ; - } - else - croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO"); - } - - - /* OS2 Specific Code */ -#ifdef OS2 -#ifdef __EMX__ - flags |= O_BINARY; -#endif /* __EMX__ */ -#endif /* OS2 */ - -#ifdef DB_VERSION_MAJOR - - { - int Flags = 0 ; - int status ; - - /* Map 1.x flags to 2.x flags */ - if ((flags & O_CREAT) == O_CREAT) - Flags |= DB_CREATE ; - -#if O_RDONLY == 0 - if (flags == O_RDONLY) -#else - if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR) -#endif - Flags |= DB_RDONLY ; - -#ifdef O_TRUNC - if ((flags & O_TRUNC) == O_TRUNC) - Flags |= DB_TRUNCATE ; -#endif - - status = db_open(name, RETVAL->type, Flags, mode, NULL, openinfo, &RETVAL->dbp) ; - if (status == 0) -#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6 - status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor) ; -#else - status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor, - 0) ; -#endif - - if (status) - RETVAL->dbp = NULL ; - - } -#else - -#if defined(DB_LIBRARY_COMPATIBILITY_API) && DB_VERSION_MAJOR > 2 - RETVAL->dbp = __db185_open(name, flags, mode, RETVAL->type, openinfo) ; -#else - RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ; -#endif /* DB_LIBRARY_COMPATIBILITY_API */ - -#endif - - return (RETVAL) ; - -#else /* Berkeley DB Version > 2 */ - - SV ** svp; - HV * action ; - DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; - DB * dbp ; - STRLEN n_a; - int status ; - -/* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */ - Zero(RETVAL, 1, DB_File_type) ; - - /* Default to HASH */ -#ifdef DBM_FILTERING - RETVAL->filtering = 0 ; - RETVAL->filter_fetch_key = RETVAL->filter_store_key = - RETVAL->filter_fetch_value = RETVAL->filter_store_value = -#endif /* DBM_FILTERING */ - RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ; - RETVAL->type = DB_HASH ; - - /* DGH - Next line added to avoid SEGV on existing hash DB */ - CurrentDB = RETVAL; - - /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */ - RETVAL->in_memory = (name == NULL) ; - - status = db_create(&RETVAL->dbp, NULL,0) ; - /* printf("db_create returned %d %s\n", status, db_strerror(status)) ; */ - if (status) { - RETVAL->dbp = NULL ; - return (RETVAL) ; - } - dbp = RETVAL->dbp ; - - if (sv) - { - if (! SvROK(sv) ) - croak ("type parameter is not a reference") ; - - svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ; - if (svp && SvOK(*svp)) - action = (HV*) SvRV(*svp) ; - else - croak("internal error") ; - - if (sv_isa(sv, "DB_File::HASHINFO")) - { - - if (!isHASH) - croak("DB_File can only tie an associative array to a DB_HASH database") ; - - RETVAL->type = DB_HASH ; - - svp = hv_fetch(action, "hash", 4, FALSE); - - if (svp && SvOK(*svp)) - { - (void)dbp->set_h_hash(dbp, hash_cb) ; - RETVAL->hash = newSVsv(*svp) ; - } - - svp = hv_fetch(action, "ffactor", 7, FALSE); - if (svp) - (void)dbp->set_h_ffactor(dbp, SvIV(*svp)) ; - - svp = hv_fetch(action, "nelem", 5, FALSE); - if (svp) - (void)dbp->set_h_nelem(dbp, SvIV(*svp)) ; - - svp = hv_fetch(action, "bsize", 5, FALSE); - if (svp) - (void)dbp->set_pagesize(dbp, SvIV(*svp)); - - svp = hv_fetch(action, "cachesize", 9, FALSE); - if (svp) - (void)dbp->set_cachesize(dbp, 0, SvIV(*svp), 0) ; - - svp = hv_fetch(action, "lorder", 6, FALSE); - if (svp) - (void)dbp->set_lorder(dbp, SvIV(*svp)) ; - - PrintHash(info) ; - } - else if (sv_isa(sv, "DB_File::BTREEINFO")) - { - if (!isHASH) - croak("DB_File can only tie an associative array to a DB_BTREE database"); - - RETVAL->type = DB_BTREE ; - - svp = hv_fetch(action, "compare", 7, FALSE); - if (svp && SvOK(*svp)) - { - (void)dbp->set_bt_compare(dbp, btree_compare) ; - RETVAL->compare = newSVsv(*svp) ; - } - - svp = hv_fetch(action, "prefix", 6, FALSE); - if (svp && SvOK(*svp)) - { - (void)dbp->set_bt_prefix(dbp, btree_prefix) ; - RETVAL->prefix = newSVsv(*svp) ; - } - - svp = hv_fetch(action, "flags", 5, FALSE); - if (svp) - (void)dbp->set_flags(dbp, SvIV(*svp)) ; - - svp = hv_fetch(action, "cachesize", 9, FALSE); - if (svp) - (void)dbp->set_cachesize(dbp, 0, SvIV(*svp), 0) ; - - svp = hv_fetch(action, "psize", 5, FALSE); - if (svp) - (void)dbp->set_pagesize(dbp, SvIV(*svp)) ; - - svp = hv_fetch(action, "lorder", 6, FALSE); - if (svp) - (void)dbp->set_lorder(dbp, SvIV(*svp)) ; - - PrintBtree(info) ; - - } - else if (sv_isa(sv, "DB_File::RECNOINFO")) - { - int fixed = FALSE ; - - if (isHASH) - croak("DB_File can only tie an array to a DB_RECNO database"); - - RETVAL->type = DB_RECNO ; - - svp = hv_fetch(action, "flags", 5, FALSE); - if (svp) { - int flags = SvIV(*svp) ; - /* remove FIXDLEN, if present */ - if (flags & DB_FIXEDLEN) { - fixed = TRUE ; - flags &= ~DB_FIXEDLEN ; - } - } - - svp = hv_fetch(action, "cachesize", 9, FALSE); - if (svp) { - status = dbp->set_cachesize(dbp, 0, SvIV(*svp), 0) ; - } - - svp = hv_fetch(action, "psize", 5, FALSE); - if (svp) { - status = dbp->set_pagesize(dbp, SvIV(*svp)) ; - } - - svp = hv_fetch(action, "lorder", 6, FALSE); - if (svp) { - status = dbp->set_lorder(dbp, SvIV(*svp)) ; - } - - svp = hv_fetch(action, "bval", 4, FALSE); - if (svp && SvOK(*svp)) - { - int value ; - if (SvPOK(*svp)) - value = (int)*SvPV(*svp, n_a) ; - else - value = SvIV(*svp) ; - - if (fixed) { - status = dbp->set_re_pad(dbp, value) ; - } - else { - status = dbp->set_re_delim(dbp, value) ; - } - - } - - if (fixed) { - svp = hv_fetch(action, "reclen", 6, FALSE); - if (svp) { - u_int32_t len = (u_int32_t)SvIV(*svp) ; - status = dbp->set_re_len(dbp, len) ; - } - } - - if (name != NULL) { - status = dbp->set_re_source(dbp, name) ; - name = NULL ; - } - - svp = hv_fetch(action, "bfname", 6, FALSE); - if (svp && SvOK(*svp)) { - char * ptr = SvPV(*svp,n_a) ; - name = (char*) n_a ? ptr : NULL ; - } - else - name = NULL ; - - - status = dbp->set_flags(dbp, DB_RENUMBER) ; - - if (flags){ - (void)dbp->set_flags(dbp, flags) ; - } - PrintRecno(info) ; - } - else - croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO"); - } - - { - int Flags = 0 ; - int status ; - - /* Map 1.x flags to 3.x flags */ - if ((flags & O_CREAT) == O_CREAT) - Flags |= DB_CREATE ; - -#if O_RDONLY == 0 - if (flags == O_RDONLY) -#else - if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR) -#endif - Flags |= DB_RDONLY ; - -#ifdef O_TRUNC - if ((flags & O_TRUNC) == O_TRUNC) - Flags |= DB_TRUNCATE ; -#endif - - status = (RETVAL->dbp->open)(RETVAL->dbp, name, NULL, RETVAL->type, - Flags, mode) ; - /* printf("open returned %d %s\n", status, db_strerror(status)) ; */ - - if (status == 0) - status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor, - 0) ; - /* printf("cursor returned %d %s\n", status, db_strerror(status)) ; */ - - if (status) - RETVAL->dbp = NULL ; - - } - - return (RETVAL) ; - -#endif /* Berkeley DB Version > 2 */ - -} /* ParseOpenInfo */ - - -static double -#ifdef CAN_PROTOTYPE -constant(char *name, int arg) -#else -constant(name, arg) -char *name; -int arg; -#endif -{ - errno = 0; - switch (*name) { - case 'A': - break; - case 'B': - if (strEQ(name, "BTREEMAGIC")) -#ifdef BTREEMAGIC - return BTREEMAGIC; -#else - goto not_there; -#endif - if (strEQ(name, "BTREEVERSION")) -#ifdef BTREEVERSION - return BTREEVERSION; -#else - goto not_there; -#endif - break; - case 'C': - break; - case 'D': - if (strEQ(name, "DB_LOCK")) -#ifdef DB_LOCK - return DB_LOCK; -#else - goto not_there; -#endif - if (strEQ(name, "DB_SHMEM")) -#ifdef DB_SHMEM - return DB_SHMEM; -#else - goto not_there; -#endif - if (strEQ(name, "DB_TXN")) -#ifdef DB_TXN - return (U32)DB_TXN; -#else - goto not_there; -#endif - break; - case 'E': - break; - case 'F': - break; - case 'G': - break; - case 'H': - if (strEQ(name, "HASHMAGIC")) -#ifdef HASHMAGIC - return HASHMAGIC; -#else - goto not_there; -#endif - if (strEQ(name, "HASHVERSION")) -#ifdef HASHVERSION - return HASHVERSION; -#else - goto not_there; -#endif - break; - case 'I': - break; - case 'J': - break; - case 'K': - break; - case 'L': - break; - case 'M': - if (strEQ(name, "MAX_PAGE_NUMBER")) -#ifdef MAX_PAGE_NUMBER - return (U32)MAX_PAGE_NUMBER; -#else - goto not_there; -#endif - if (strEQ(name, "MAX_PAGE_OFFSET")) -#ifdef MAX_PAGE_OFFSET - return MAX_PAGE_OFFSET; -#else - goto not_there; -#endif - if (strEQ(name, "MAX_REC_NUMBER")) -#ifdef MAX_REC_NUMBER - return (U32)MAX_REC_NUMBER; -#else - goto not_there; -#endif - break; - case 'N': - break; - case 'O': - break; - case 'P': - break; - case 'Q': - break; - case 'R': - if (strEQ(name, "RET_ERROR")) -#ifdef RET_ERROR - return RET_ERROR; -#else - goto not_there; -#endif - if (strEQ(name, "RET_SPECIAL")) -#ifdef RET_SPECIAL - return RET_SPECIAL; -#else - goto not_there; -#endif - if (strEQ(name, "RET_SUCCESS")) -#ifdef RET_SUCCESS - return RET_SUCCESS; -#else - goto not_there; -#endif - if (strEQ(name, "R_CURSOR")) -#ifdef R_CURSOR - return R_CURSOR; -#else - goto not_there; -#endif - if (strEQ(name, "R_DUP")) -#ifdef R_DUP - return R_DUP; -#else - goto not_there; -#endif - if (strEQ(name, "R_FIRST")) -#ifdef R_FIRST - return R_FIRST; -#else - goto not_there; -#endif - if (strEQ(name, "R_FIXEDLEN")) -#ifdef R_FIXEDLEN - return R_FIXEDLEN; -#else - goto not_there; -#endif - if (strEQ(name, "R_IAFTER")) -#ifdef R_IAFTER - return R_IAFTER; -#else - goto not_there; -#endif - if (strEQ(name, "R_IBEFORE")) -#ifdef R_IBEFORE - return R_IBEFORE; -#else - goto not_there; -#endif - if (strEQ(name, "R_LAST")) -#ifdef R_LAST - return R_LAST; -#else - goto not_there; -#endif - if (strEQ(name, "R_NEXT")) -#ifdef R_NEXT - return R_NEXT; -#else - goto not_there; -#endif - if (strEQ(name, "R_NOKEY")) -#ifdef R_NOKEY - return R_NOKEY; -#else - goto not_there; -#endif - if (strEQ(name, "R_NOOVERWRITE")) -#ifdef R_NOOVERWRITE - return R_NOOVERWRITE; -#else - goto not_there; -#endif - if (strEQ(name, "R_PREV")) -#ifdef R_PREV - return R_PREV; -#else - goto not_there; -#endif - if (strEQ(name, "R_RECNOSYNC")) -#ifdef R_RECNOSYNC - return R_RECNOSYNC; -#else - goto not_there; -#endif - if (strEQ(name, "R_SETCURSOR")) -#ifdef R_SETCURSOR - return R_SETCURSOR; -#else - goto not_there; -#endif - if (strEQ(name, "R_SNAPSHOT")) -#ifdef R_SNAPSHOT - return R_SNAPSHOT; -#else - goto not_there; -#endif - break; - case 'S': - break; - case 'T': - break; - case 'U': - break; - case 'V': - break; - case 'W': - break; - case 'X': - break; - case 'Y': - break; - case 'Z': - break; - case '_': - break; - } - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - -MODULE = DB_File PACKAGE = DB_File PREFIX = db_ - -BOOT: - { - __getBerkeleyDBInfo() ; - - DBT_clear(empty) ; - empty.data = &zero ; - empty.size = sizeof(recno_t) ; - } - -double -constant(name,arg) - char * name - int arg - - -DB_File -db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH) - int isHASH - char * dbtype - int flags - int mode - CODE: - { - char * name = (char *) NULL ; - SV * sv = (SV *) NULL ; - STRLEN n_a; - - if (items >= 3 && SvOK(ST(2))) - name = (char*) SvPV(ST(2), n_a) ; - - if (items == 6) - sv = ST(5) ; - - RETVAL = ParseOpenInfo(aTHX_ isHASH, name, flags, mode, sv) ; - if (RETVAL->dbp == NULL) - RETVAL = NULL ; - } - OUTPUT: - RETVAL - -int -db_DESTROY(db) - DB_File db - INIT: - CurrentDB = db ; - CLEANUP: - if (db->hash) - SvREFCNT_dec(db->hash) ; - if (db->compare) - SvREFCNT_dec(db->compare) ; - if (db->prefix) - SvREFCNT_dec(db->prefix) ; -#ifdef DBM_FILTERING - if (db->filter_fetch_key) - SvREFCNT_dec(db->filter_fetch_key) ; - if (db->filter_store_key) - SvREFCNT_dec(db->filter_store_key) ; - if (db->filter_fetch_value) - SvREFCNT_dec(db->filter_fetch_value) ; - if (db->filter_store_value) - SvREFCNT_dec(db->filter_store_value) ; -#endif /* DBM_FILTERING */ - safefree(db) ; -#ifdef DB_VERSION_MAJOR - if (RETVAL > 0) - RETVAL = -1 ; -#endif - - -int -db_DELETE(db, key, flags=0) - DB_File db - DBTKEY key - u_int flags - INIT: - CurrentDB = db ; - - -int -db_EXISTS(db, key) - DB_File db - DBTKEY key - CODE: - { - DBT value ; - - DBT_clear(value) ; - CurrentDB = db ; - RETVAL = (((db->dbp)->get)(db->dbp, TXN &key, &value, 0) == 0) ; - } - OUTPUT: - RETVAL - -int -db_FETCH(db, key, flags=0) - DB_File db - DBTKEY key - u_int flags - CODE: - { - DBT value ; - - DBT_clear(value) ; - CurrentDB = db ; - /* RETVAL = ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) ; */ - RETVAL = db_get(db, key, value, flags) ; - ST(0) = sv_newmortal(); - OutputValue(ST(0), value) - } - -int -db_STORE(db, key, value, flags=0) - DB_File db - DBTKEY key - DBT value - u_int flags - INIT: - CurrentDB = db ; - - -int -db_FIRSTKEY(db) - DB_File db - CODE: - { - DBTKEY key ; - DBT value ; - - DBT_clear(key) ; - DBT_clear(value) ; - CurrentDB = db ; - RETVAL = do_SEQ(db, key, value, R_FIRST) ; - ST(0) = sv_newmortal(); - OutputKey(ST(0), key) ; - } - -int -db_NEXTKEY(db, key) - DB_File db - DBTKEY key - CODE: - { - DBT value ; - - DBT_clear(value) ; - CurrentDB = db ; - RETVAL = do_SEQ(db, key, value, R_NEXT) ; - ST(0) = sv_newmortal(); - OutputKey(ST(0), key) ; - } - -# -# These would be nice for RECNO -# - -int -unshift(db, ...) - DB_File db - ALIAS: UNSHIFT = 1 - CODE: - { - DBTKEY key ; - DBT value ; - int i ; - int One ; - DB * Db = db->dbp ; - STRLEN n_a; - - DBT_clear(key) ; - DBT_clear(value) ; - CurrentDB = db ; -#ifdef DB_VERSION_MAJOR - /* get the first value */ - RETVAL = do_SEQ(db, key, value, DB_FIRST) ; - RETVAL = 0 ; -#else - RETVAL = -1 ; -#endif - for (i = items-1 ; i > 0 ; --i) - { - value.data = SvPV(ST(i), n_a) ; - value.size = n_a ; - One = 1 ; - key.data = &One ; - key.size = sizeof(int) ; -#ifdef DB_VERSION_MAJOR - RETVAL = (db->cursor->c_put)(db->cursor, &key, &value, DB_BEFORE) ; -#else - RETVAL = (Db->put)(Db, &key, &value, R_IBEFORE) ; -#endif - if (RETVAL != 0) - break; - } - } - OUTPUT: - RETVAL - -I32 -pop(db) - DB_File db - ALIAS: POP = 1 - CODE: - { - DBTKEY key ; - DBT value ; - - DBT_clear(key) ; - DBT_clear(value) ; - CurrentDB = db ; - - /* First get the final value */ - RETVAL = do_SEQ(db, key, value, R_LAST) ; - ST(0) = sv_newmortal(); - /* Now delete it */ - if (RETVAL == 0) - { - /* the call to del will trash value, so take a copy now */ - OutputValue(ST(0), value) ; - RETVAL = db_del(db, key, R_CURSOR) ; - if (RETVAL != 0) - sv_setsv(ST(0), &PL_sv_undef); - } - } - -I32 -shift(db) - DB_File db - ALIAS: SHIFT = 1 - CODE: - { - DBT value ; - DBTKEY key ; - - DBT_clear(key) ; - DBT_clear(value) ; - CurrentDB = db ; - /* get the first value */ - RETVAL = do_SEQ(db, key, value, R_FIRST) ; - ST(0) = sv_newmortal(); - /* Now delete it */ - if (RETVAL == 0) - { - /* the call to del will trash value, so take a copy now */ - OutputValue(ST(0), value) ; - RETVAL = db_del(db, key, R_CURSOR) ; - if (RETVAL != 0) - sv_setsv (ST(0), &PL_sv_undef) ; - } - } - - -I32 -push(db, ...) - DB_File db - ALIAS: PUSH = 1 - CODE: - { - DBTKEY key ; - DBT value ; - DB * Db = db->dbp ; - int i ; - STRLEN n_a; - int keyval ; - - DBT_flags(key) ; - DBT_flags(value) ; - CurrentDB = db ; - /* Set the Cursor to the Last element */ - RETVAL = do_SEQ(db, key, value, R_LAST) ; -#ifndef DB_VERSION_MAJOR - if (RETVAL >= 0) -#endif - { - if (RETVAL == 0) - keyval = *(int*)key.data ; - else - keyval = 0 ; - for (i = 1 ; i < items ; ++i) - { - value.data = SvPV(ST(i), n_a) ; - value.size = n_a ; - ++ keyval ; - key.data = &keyval ; - key.size = sizeof(int) ; - RETVAL = (Db->put)(Db, TXN &key, &value, 0) ; - if (RETVAL != 0) - break; - } - } - } - OUTPUT: - RETVAL - -I32 -length(db) - DB_File db - ALIAS: FETCHSIZE = 1 - CODE: - CurrentDB = db ; - RETVAL = GetArrayLength(aTHX_ db) ; - OUTPUT: - RETVAL - - -# -# Now provide an interface to the rest of the DB functionality -# - -int -db_del(db, key, flags=0) - DB_File db - DBTKEY key - u_int flags - CODE: - CurrentDB = db ; - RETVAL = db_del(db, key, flags) ; -#ifdef DB_VERSION_MAJOR - if (RETVAL > 0) - RETVAL = -1 ; - else if (RETVAL == DB_NOTFOUND) - RETVAL = 1 ; -#endif - OUTPUT: - RETVAL - - -int -db_get(db, key, value, flags=0) - DB_File db - DBTKEY key - DBT value = NO_INIT - u_int flags - CODE: - CurrentDB = db ; - DBT_clear(value) ; - RETVAL = db_get(db, key, value, flags) ; -#ifdef DB_VERSION_MAJOR - if (RETVAL > 0) - RETVAL = -1 ; - else if (RETVAL == DB_NOTFOUND) - RETVAL = 1 ; -#endif - OUTPUT: - RETVAL - value - -int -db_put(db, key, value, flags=0) - DB_File db - DBTKEY key - DBT value - u_int flags - CODE: - CurrentDB = db ; - RETVAL = db_put(db, key, value, flags) ; -#ifdef DB_VERSION_MAJOR - if (RETVAL > 0) - RETVAL = -1 ; - else if (RETVAL == DB_KEYEXIST) - RETVAL = 1 ; -#endif - OUTPUT: - RETVAL - key if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) OutputKey(ST(1), key); - -int -db_fd(db) - DB_File db - int status = 0 ; - CODE: - CurrentDB = db ; -#ifdef DB_VERSION_MAJOR - RETVAL = -1 ; - status = (db->in_memory - ? -1 - : ((db->dbp)->fd)(db->dbp, &RETVAL) ) ; - if (status != 0) - RETVAL = -1 ; -#else - RETVAL = (db->in_memory - ? -1 - : ((db->dbp)->fd)(db->dbp) ) ; -#endif - OUTPUT: - RETVAL - -int -db_sync(db, flags=0) - DB_File db - u_int flags - CODE: - CurrentDB = db ; - RETVAL = db_sync(db, flags) ; -#ifdef DB_VERSION_MAJOR - if (RETVAL > 0) - RETVAL = -1 ; -#endif - OUTPUT: - RETVAL - - -int -db_seq(db, key, value, flags) - DB_File db - DBTKEY key - DBT value = NO_INIT - u_int flags - CODE: - CurrentDB = db ; - DBT_clear(value) ; - RETVAL = db_seq(db, key, value, flags); -#ifdef DB_VERSION_MAJOR - if (RETVAL > 0) - RETVAL = -1 ; - else if (RETVAL == DB_NOTFOUND) - RETVAL = 1 ; -#endif - OUTPUT: - RETVAL - key - value - -#ifdef DBM_FILTERING - -#define setFilter(type) \ - { \ - if (db->type) \ - RETVAL = sv_mortalcopy(db->type) ; \ - ST(0) = RETVAL ; \ - if (db->type && (code == &PL_sv_undef)) { \ - SvREFCNT_dec(db->type) ; \ - db->type = NULL ; \ - } \ - else if (code) { \ - if (db->type) \ - sv_setsv(db->type, code) ; \ - else \ - db->type = newSVsv(code) ; \ - } \ - } - - -SV * -filter_fetch_key(db, code) - DB_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_fetch_key) ; - -SV * -filter_store_key(db, code) - DB_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_store_key) ; - -SV * -filter_fetch_value(db, code) - DB_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_fetch_value) ; - -SV * -filter_store_value(db, code) - DB_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_store_value) ; - -#endif /* DBM_FILTERING */ diff --git a/contrib/perl5/ext/DB_File/DB_File_BS b/contrib/perl5/ext/DB_File/DB_File_BS deleted file mode 100644 index 9282c49..0000000 --- a/contrib/perl5/ext/DB_File/DB_File_BS +++ /dev/null @@ -1,6 +0,0 @@ -# NeXT needs /usr/lib/libposix.a to load along with DB_File.so -if ( $dlsrc eq "dl_next.xs" ) { - @DynaLoader::dl_resolve_using = ( '/usr/lib/libposix.a' ); -} - -1; diff --git a/contrib/perl5/ext/DB_File/Makefile.PL b/contrib/perl5/ext/DB_File/Makefile.PL deleted file mode 100644 index 0414160..0000000 --- a/contrib/perl5/ext/DB_File/Makefile.PL +++ /dev/null @@ -1,29 +0,0 @@ -use ExtUtils::MakeMaker 5.16 ; -use Config ; - -# OS2 is a special case, so check for it now. -my $OS2 = "-DOS2" if $Config{'osname'} eq 'os2' ; - -my $LIB = "-ldb" ; -# so is win32 -$LIB = "-llibdb" if $^O eq 'MSWin32' ; - -WriteMakefile( - NAME => 'DB_File', - LIBS => ["-L/usr/local/lib $LIB"], - MAN3PODS => {}, # Pods will be built by installman. - #INC => '-I/usr/local/include', - VERSION_FROM => 'DB_File.pm', - OBJECT => 'version$(OBJ_EXT) DB_File$(OBJ_EXT)', - XSPROTOARG => '-noprototypes', - DEFINE => $OS2 || "", - INC => ($^O eq "MacOS" ? "-i ::::db:include" : "") - ); - -sub MY::postamble { - ' -version$(OBJ_EXT): version.c - -' ; -} - diff --git a/contrib/perl5/ext/DB_File/dbinfo b/contrib/perl5/ext/DB_File/dbinfo deleted file mode 100644 index 5a4df15..0000000 --- a/contrib/perl5/ext/DB_File/dbinfo +++ /dev/null @@ -1,109 +0,0 @@ -#!/usr/local/bin/perl - -# Name: dbinfo -- identify berkeley DB version used to create -# a database file -# -# Author: Paul Marquess <Paul.Marquess@btinternet.com> -# Version: 1.03 -# Date 17th September 2000 -# -# Copyright (c) 1998-2000 Paul Marquess. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -# Todo: Print more stats on a db file, e.g. no of records -# add log/txn/lock files - -use strict ; - -my %Data = - ( - 0x053162 => { - Type => "Btree", - Versions => - { - 1 => "Unknown (older than 1.71)", - 2 => "Unknown (older than 1.71)", - 3 => "1.71 -> 1.85, 1.86", - 4 => "Unknown", - 5 => "2.0.0 -> 2.3.0", - 6 => "2.3.1 -> 2.7.7", - 7 => "3.0.x", - 8 => "3.1.x or greater", - } - }, - 0x061561 => { - Type => "Hash", - Versions => - { - 1 => "Unknown (older than 1.71)", - 2 => "1.71 -> 1.85", - 3 => "1.86", - 4 => "2.0.0 -> 2.1.0", - 5 => "2.2.6 -> 2.7.7", - 6 => "3.0.x", - 7 => "3.1.x or greater", - } - }, - 0x042253 => { - Type => "Queue", - Versions => - { - 1 => "3.0.x", - 2 => "3.1.x", - 3 => "3.2.x or greater", - } - }, - ) ; - -die "Usage: dbinfo file\n" unless @ARGV == 1 ; - -print "testing file $ARGV[0]...\n\n" ; -open (F, "<$ARGV[0]") or die "Cannot open file $ARGV[0]: $!\n" ; - -my $buff ; -read F, $buff, 20 ; - -my (@info) = unpack("NNNNN", $buff) ; -my (@info1) = unpack("VVVVV", $buff) ; -my ($magic, $version, $endian) ; - -if ($Data{$info[0]}) # first try DB 1.x format -{ - $magic = $info[0] ; - $version = $info[1] ; - $endian = "Unknown" ; -} -elsif ($Data{$info[3]}) # next DB 2.x big endian -{ - $magic = $info[3] ; - $version = $info[4] ; - $endian = "Big Endian" ; -} -elsif ($Data{$info1[3]}) # next DB 2.x little endian -{ - $magic = $info1[3] ; - $version = $info1[4] ; - $endian = "Little Endian" ; -} -else - { die "not a Berkeley DB database file.\n" } - -my $type = $Data{$magic} ; -$magic = sprintf "%06X", $magic ; - -my $ver_string = "Unknown" ; -$ver_string = $type->{Versions}{$version} - if defined $type->{Versions}{$version} ; - -print <<EOM ; -File Type: Berkeley DB $type->{Type} file. -File Version ID: $version -Built with Berkeley DB: $ver_string -Byte Order: $endian -Magic: $magic -EOM - -close F ; - -exit ; diff --git a/contrib/perl5/ext/DB_File/hints/dynixptx.pl b/contrib/perl5/ext/DB_File/hints/dynixptx.pl deleted file mode 100644 index bb5ffa5..0000000 --- a/contrib/perl5/ext/DB_File/hints/dynixptx.pl +++ /dev/null @@ -1,3 +0,0 @@ -# Need to add an extra '-lc' to the end to work around a DYNIX/ptx bug - -$self->{LIBS} = ['-lm -lc']; diff --git a/contrib/perl5/ext/DB_File/hints/sco.pl b/contrib/perl5/ext/DB_File/hints/sco.pl deleted file mode 100644 index ff60440..0000000 --- a/contrib/perl5/ext/DB_File/hints/sco.pl +++ /dev/null @@ -1,2 +0,0 @@ -# osr5 needs to explicitly link against libc to pull in some static symbols -$self->{LIBS} = ['-ldb -lc'] if $Config{'osvers'} =~ '3\.2v5\.0\..' ; diff --git a/contrib/perl5/ext/DB_File/typemap b/contrib/perl5/ext/DB_File/typemap deleted file mode 100644 index 55439ee..0000000 --- a/contrib/perl5/ext/DB_File/typemap +++ /dev/null @@ -1,44 +0,0 @@ -# typemap for Perl 5 interface to Berkeley -# -# written by Paul Marquess <Paul.Marquess@btinternet.com> -# last modified 10th December 2000 -# version 1.74 -# -#################################### DB SECTION -# -# - -u_int T_U_INT -DB_File T_PTROBJ -DBT T_dbtdatum -DBTKEY T_dbtkeydatum - -INPUT -T_dbtkeydatum - ckFilter($arg, filter_store_key, \"filter_store_key\"); - DBT_clear($var) ; - if (db->type != DB_RECNO) { - $var.data = SvPV($arg, PL_na); - $var.size = (int)PL_na; - } - else { - Value = GetRecnoKey(aTHX_ db, SvIV($arg)) ; - $var.data = & Value; - $var.size = (int)sizeof(recno_t); - } -T_dbtdatum - ckFilter($arg, filter_store_value, \"filter_store_value\"); - DBT_clear($var) ; - if (SvOK($arg)) { - $var.data = SvPV($arg, PL_na); - $var.size = (int)PL_na; - } - -OUTPUT - -T_dbtkeydatum - OutputKey($arg, $var) -T_dbtdatum - OutputValue($arg, $var) -T_PTROBJ - sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/contrib/perl5/ext/DB_File/version.c b/contrib/perl5/ext/DB_File/version.c deleted file mode 100644 index 6e55b2e..0000000 --- a/contrib/perl5/ext/DB_File/version.c +++ /dev/null @@ -1,81 +0,0 @@ -/* - - version.c -- Perl 5 interface to Berkeley DB - - written by Paul Marquess <Paul.Marquess@btinternet.com> - last modified 16th January 2000 - version 1.73 - - All comments/suggestions/problems are welcome - - Copyright (c) 1995-2000 Paul Marquess. All rights reserved. - This program is free software; you can redistribute it and/or - modify it under the same terms as Perl itself. - - Changes: - 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 - 1.74 - Added Perl core patch 7801. - - -*/ - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#include <db.h> - -void -#ifdef CAN_PROTOTYPE -__getBerkeleyDBInfo(void) -#else -__getBerkeleyDBInfo() -#endif -{ -#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) ; - -#ifdef DB_VERSION_MAJOR - int Major, Minor, Patch ; - - (void)db_version(&Major, &Minor, &Patch) ; - - /* Check that the versions of db.h and libdb.a are the same */ - if (Major != DB_VERSION_MAJOR || Minor != DB_VERSION_MINOR - || Patch != DB_VERSION_PATCH) - croak("\nDB_File needs compatible versions of libdb & db.h\n\tyou have db.h version %d.%d.%d and libdb version %d.%d.%d\n", - DB_VERSION_MAJOR, DB_VERSION_MINOR, DB_VERSION_PATCH, - Major, Minor, Patch) ; - - /* check that libdb is recent enough -- we need 2.3.4 or greater */ - if (Major == 2 && (Minor < 3 || (Minor == 3 && Patch < 4))) - croak("DB_File needs Berkeley DB 2.3.4 or greater, you have %d.%d.%d\n", - Major, Minor, Patch) ; - - { - char buffer[40] ; - sprintf(buffer, "%d.%d", Major, Minor) ; - sv_setpv(version_sv, buffer) ; - sprintf(buffer, "%d.%03d%03d", Major, Minor, Patch) ; - sv_setpv(ver_sv, buffer) ; - } - -#else /* ! DB_VERSION_MAJOR */ - sv_setiv(version_sv, 1) ; - sv_setiv(ver_sv, 1) ; -#endif /* ! DB_VERSION_MAJOR */ - -#ifdef COMPAT185 - sv_setiv(compat_sv, 1) ; -#else /* ! COMPAT185 */ - sv_setiv(compat_sv, 0) ; -#endif /* ! COMPAT185 */ - -} diff --git a/contrib/perl5/ext/Data/Dumper/Changes b/contrib/perl5/ext/Data/Dumper/Changes deleted file mode 100644 index 161aba9..0000000 --- a/contrib/perl5/ext/Data/Dumper/Changes +++ /dev/null @@ -1,193 +0,0 @@ -=head1 NAME - -HISTORY - public release history for Data::Dumper - -=head1 DESCRIPTION - -=over 8 - -=item 2.11 (unreleased) - -C<0> is now dumped as such, not as C<'0'>. - -qr// objects are now dumped correctly (provided a post-5.005_58) -overload.pm exists). - -Implemented $Data::Dumper::Maxdepth, which was on the Todo list. -Thanks to John Nolan <jpnolan@Op.Net>. - -=item 2.101 (30 Apr 1999) - -Minor release to sync with version in 5.005_03. Fixes dump of -dummy coderefs. - -=item 2.10 (31 Oct 1998) - -Bugfixes for dumping related undef values, globs, and better double -quoting: three patches suggested by Gisle Aas <gisle@aas.no>. - -Escaping of single quotes in the XS version could get tripped up -by the presence of nulls in the string. Fix suggested by -Slaven Rezic <eserte@cs.tu-berlin.de>. - -Rather large scale reworking of the logic in how seen values -are stashed. Anonymous scalars that may be encountered while -traversing the structure are properly tracked, in case they become -used in data dumped in a later pass. There used to be a problem -with the previous logic that prevented such structures from being -dumped correctly. - -Various additions to the testsuite. - -=item 2.09 (9 July 1998) - -Implement $Data::Dumper::Bless, suggested by Mark Daku <daku@nortel.ca>. - -=item 2.081 (15 January 1998) - -Minor release to fix Makefile.PL not accepting MakeMaker args. - -=item 2.08 (7 December 1997) - -Glob dumps don't output superflous 'undef' anymore. - -Fixes from Gisle Aas <gisle@aas.no> to make Dumper() work with -overloaded strings in recent perls, and his new testsuite. - -require 5.004. - -A separate flag to always quote hash keys (on by default). - -Recreating known CODE refs is now better supported. - -Changed flawed constant SCALAR bless workaround. - -=item 2.07 (7 December 1996) - -Dumpxs output is now exactly the same as Dump. It still doesn't -honor C<Useqq> though. - -Regression tests test for identical output and C<eval>-ability. - -Bug in *GLOB{THING} output fixed. - -Other small enhancements. - -=item 2.06 (2 December 1996) - -Bugfix that was serious enough for new release--the bug cripples -MLDBM. Problem was "Attempt to modify readonly value..." failures -that stemmed for a misguided SvPV_force() instead of a SvPV().) - -=item 2.05 (2 December 1996) - -Fixed the type mismatch that was causing Dumpxs test to fail -on 64-bit platforms. - -GLOB elements are dumped now when C<Purity> is set (using the -*GLOB{THING} syntax). - -The C<Freezer> option can be set to a method name to call -before probing objects for dumping. Some applications: objects with -external data, can re-bless themselves into a transitional package; -Objects the maintain ephemeral state (like open files) can put -additional information in the object to facilitate persistence. - -The corresponding C<Toaster> option, if set, specifies -the method call that will revive the frozen object. - -The C<Deepcopy> flag has been added to do just that. - -Dumper does more aggressive cataloging of SCALARs encountered -within ARRAY/HASH structures. Thanks to Norman Gaywood -<norm@godel.une.edu.au> for reporting the problem. - -Objects that C<overload> the '""' operator are now handled -properly by the C<Dump> method. - -Significant additions to the testsuite. - -More documentation. - -=item 2.04beta (28 August 1996) - -Made dump of glob names respect C<Useqq> setting. - -[@$%] are now escaped now when in double quotes. - -=item 2.03beta (26 August 1996) - -Fixed Dumpxs. It was appending trailing nulls to globnames. -(reported by Randal Schwartz <merlyn@teleport.com>). - -Calling the C<Indent()> method on a dumper object now correctly -resets the internal separator (reported by Curt Tilmes -<curt@ltpmail.gsfc.nasa.gov>). - -New C<Terse> option to suppress the 'C<VARI<n> = >' prefix -introduced. If the option is set, they are output only when -absolutely essential. - -The C<Useqq> flag is supported (but not by the XSUB version -yet). - -Embedded nulls in keys are now handled properly by Dumpxs. - -Dumper.xs now use various integer types in perl.h (should -make it compile without noises on 64 bit platforms, although -I haven't been able to test this). - -All the dump methods now return a list of strings in a list -context. - - -=item 2.02beta (13 April 1996) - -Non portable sprintf usage in XS code fixed (thanks to -Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de>). - - -=item 2.01beta (10 April 1996) - -Minor bugfix (single digit numbers were always getting quoted). - - -=item 2.00beta (9 April 1996) - -C<Dumpxs> is now the exact XSUB equivalent of C<Dump>. The XS version -is 4-5 times faster. - -C<require 5.002>. - -MLDBM example removed (as its own module, it has a separate CPAN -reality now). - -Fixed bugs in handling keys with wierd characters. Perl can be -tripped up in its implicit quoting of the word before '=>'. The -fix: C<Data::Dumper::Purity>, when set, always triggers quotes -around hash keys. - -Andreas Koenig <k@anna.in-berlin.de> pointed out that handling octals -is busted. His patch added. - -Dead code removed, other minor documentation fixes. - - -=item 1.23 (3 Dec 1995) - -MLDBM example added. - -Several folks pointed out that quoting of ticks and backslashes -in strings is missing. Added. - -Ian Phillips <ian@pipex.net> pointed out that numerics may lose -precision without quotes. Fixed. - - -=item 1.21 (20 Nov 1995) - -Last stable version I can remember. - -=back - -=cut diff --git a/contrib/perl5/ext/Data/Dumper/Dumper.pm b/contrib/perl5/ext/Data/Dumper/Dumper.pm deleted file mode 100644 index a8e59ab..0000000 --- a/contrib/perl5/ext/Data/Dumper/Dumper.pm +++ /dev/null @@ -1,1048 +0,0 @@ -# -# Data/Dumper.pm -# -# convert perl data structures into perl syntax suitable for both printing -# and eval -# -# Documentation at the __END__ -# - -package Data::Dumper; - -$VERSION = '2.102'; - -#$| = 1; - -require 5.005_64; -require Exporter; -use XSLoader (); -require overload; - -use Carp; - -@ISA = qw(Exporter); -@EXPORT = qw(Dumper); -@EXPORT_OK = qw(DumperX); - -XSLoader::load 'Data::Dumper'; - -# module vars and their defaults -$Indent = 2 unless defined $Indent; -$Purity = 0 unless defined $Purity; -$Pad = "" unless defined $Pad; -$Varname = "VAR" unless defined $Varname; -$Useqq = 0 unless defined $Useqq; -$Terse = 0 unless defined $Terse; -$Freezer = "" unless defined $Freezer; -$Toaster = "" unless defined $Toaster; -$Deepcopy = 0 unless defined $Deepcopy; -$Quotekeys = 1 unless defined $Quotekeys; -$Bless = "bless" unless defined $Bless; -#$Expdepth = 0 unless defined $Expdepth; -$Maxdepth = 0 unless defined $Maxdepth; - -# -# expects an arrayref of values to be dumped. -# can optionally pass an arrayref of names for the values. -# names must have leading $ sign stripped. begin the name with * -# to cause output of arrays and hashes rather than refs. -# -sub new { - my($c, $v, $n) = @_; - - croak "Usage: PACKAGE->new(ARRAYREF, [ARRAYREF])" - unless (defined($v) && (ref($v) eq 'ARRAY')); - $n = [] unless (defined($n) && (ref($v) eq 'ARRAY')); - - my($s) = { - level => 0, # current recursive depth - indent => $Indent, # various styles of indenting - pad => $Pad, # all lines prefixed by this string - xpad => "", # padding-per-level - apad => "", # added padding for hash keys n such - sep => "", # list separator - seen => {}, # local (nested) refs (id => [name, val]) - todump => $v, # values to dump [] - names => $n, # optional names for values [] - varname => $Varname, # prefix to use for tagging nameless ones - purity => $Purity, # degree to which output is evalable - useqq => $Useqq, # use "" for strings (backslashitis ensues) - terse => $Terse, # avoid name output (where feasible) - freezer => $Freezer, # name of Freezer method for objects - toaster => $Toaster, # name of method to revive objects - deepcopy => $Deepcopy, # dont cross-ref, except to stop recursion - quotekeys => $Quotekeys, # quote hash keys - 'bless' => $Bless, # keyword to use for "bless" -# expdepth => $Expdepth, # cutoff depth for explicit dumping - maxdepth => $Maxdepth, # depth beyond which we give up - }; - - if ($Indent > 0) { - $s->{xpad} = " "; - $s->{sep} = "\n"; - } - return bless($s, $c); -} - -# -# add-to or query the table of already seen references -# -sub Seen { - my($s, $g) = @_; - if (defined($g) && (ref($g) eq 'HASH')) { - my($k, $v, $id); - while (($k, $v) = each %$g) { - if (defined $v and ref $v) { - ($id) = (overload::StrVal($v) =~ /\((.*)\)$/); - if ($k =~ /^[*](.*)$/) { - $k = (ref $v eq 'ARRAY') ? ( "\\\@" . $1 ) : - (ref $v eq 'HASH') ? ( "\\\%" . $1 ) : - (ref $v eq 'CODE') ? ( "\\\&" . $1 ) : - ( "\$" . $1 ) ; - } - elsif ($k !~ /^\$/) { - $k = "\$" . $k; - } - $s->{seen}{$id} = [$k, $v]; - } - else { - carp "Only refs supported, ignoring non-ref item \$$k"; - } - } - return $s; - } - else { - return map { @$_ } values %{$s->{seen}}; - } -} - -# -# set or query the values to be dumped -# -sub Values { - my($s, $v) = @_; - if (defined($v) && (ref($v) eq 'ARRAY')) { - $s->{todump} = [@$v]; # make a copy - return $s; - } - else { - return @{$s->{todump}}; - } -} - -# -# set or query the names of the values to be dumped -# -sub Names { - my($s, $n) = @_; - if (defined($n) && (ref($n) eq 'ARRAY')) { - $s->{names} = [@$n]; # make a copy - return $s; - } - else { - return @{$s->{names}}; - } -} - -sub DESTROY {} - -sub Dump { - return &Dumpxs - unless $Data::Dumper::Useqq || (ref($_[0]) && $_[0]->{useqq}); - return &Dumpperl; -} - -# -# dump the refs in the current dumper object. -# expects same args as new() if called via package name. -# -sub Dumpperl { - my($s) = shift; - my(@out, $val, $name); - my($i) = 0; - local(@post); - - $s = $s->new(@_) unless ref $s; - - for $val (@{$s->{todump}}) { - my $out = ""; - @post = (); - $name = $s->{names}[$i++]; - if (defined $name) { - if ($name =~ /^[*](.*)$/) { - if (defined $val) { - $name = (ref $val eq 'ARRAY') ? ( "\@" . $1 ) : - (ref $val eq 'HASH') ? ( "\%" . $1 ) : - (ref $val eq 'CODE') ? ( "\*" . $1 ) : - ( "\$" . $1 ) ; - } - else { - $name = "\$" . $1; - } - } - elsif ($name !~ /^\$/) { - $name = "\$" . $name; - } - } - else { - $name = "\$" . $s->{varname} . $i; - } - - my $valstr; - { - local($s->{apad}) = $s->{apad}; - $s->{apad} .= ' ' x (length($name) + 3) if $s->{indent} >= 2; - $valstr = $s->_dump($val, $name); - } - - $valstr = "$name = " . $valstr . ';' if @post or !$s->{terse}; - $out .= $s->{pad} . $valstr . $s->{sep}; - $out .= $s->{pad} . join(';' . $s->{sep} . $s->{pad}, @post) - . ';' . $s->{sep} if @post; - - push @out, $out; - } - return wantarray ? @out : join('', @out); -} - -# -# twist, toil and turn; -# and recurse, of course. -# -sub _dump { - my($s, $val, $name) = @_; - my($sname); - my($out, $realpack, $realtype, $type, $ipad, $id, $blesspad); - - $type = ref $val; - $out = ""; - - if ($type) { - - # prep it, if it looks like an object - if (my $freezer = $s->{freezer}) { - $val->$freezer() if UNIVERSAL::can($val, $freezer); - } - - ($realpack, $realtype, $id) = - (overload::StrVal($val) =~ /^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$/); - - # if it has a name, we need to either look it up, or keep a tab - # on it so we know when we hit it later - if (defined($name) and length($name)) { - # keep a tab on it so that we dont fall into recursive pit - if (exists $s->{seen}{$id}) { -# if ($s->{expdepth} < $s->{level}) { - if ($s->{purity} and $s->{level} > 0) { - $out = ($realtype eq 'HASH') ? '{}' : - ($realtype eq 'ARRAY') ? '[]' : - 'do{my $o}' ; - push @post, $name . " = " . $s->{seen}{$id}[0]; - } - else { - $out = $s->{seen}{$id}[0]; - if ($name =~ /^([\@\%])/) { - my $start = $1; - if ($out =~ /^\\$start/) { - $out = substr($out, 1); - } - else { - $out = $start . '{' . $out . '}'; - } - } - } - return $out; -# } - } - else { - # store our name - $s->{seen}{$id} = [ (($name =~ /^[@%]/) ? ('\\' . $name ) : - ($realtype eq 'CODE' and - $name =~ /^[*](.*)$/) ? ('\\&' . $1 ) : - $name ), - $val ]; - } - } - - if ($realpack and $realpack eq 'Regexp') { - $out = "$val"; - $out =~ s,/,\\/,g; - return "qr/$out/"; - } - - # If purity is not set and maxdepth is set, then check depth: - # if we have reached maximum depth, return the string - # representation of the thing we are currently examining - # at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)'). - if (!$s->{purity} - and $s->{maxdepth} > 0 - and $s->{level} >= $s->{maxdepth}) - { - return qq['$val']; - } - - # we have a blessed ref - if ($realpack) { - $out = $s->{'bless'} . '( '; - $blesspad = $s->{apad}; - $s->{apad} .= ' ' if ($s->{indent} >= 2); - } - - $s->{level}++; - $ipad = $s->{xpad} x $s->{level}; - - if ($realtype eq 'SCALAR' || $realtype eq 'REF') { - if ($realpack) { - $out .= 'do{\\(my $o = ' . $s->_dump($$val, "\${$name}") . ')}'; - } - else { - $out .= '\\' . $s->_dump($$val, "\${$name}"); - } - } - elsif ($realtype eq 'GLOB') { - $out .= '\\' . $s->_dump($$val, "*{$name}"); - } - elsif ($realtype eq 'ARRAY') { - my($v, $pad, $mname); - my($i) = 0; - $out .= ($name =~ /^\@/) ? '(' : '['; - $pad = $s->{sep} . $s->{pad} . $s->{apad}; - ($name =~ /^\@(.*)$/) ? ($mname = "\$" . $1) : - # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar} - ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) : - ($mname = $name . '->'); - $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/; - for $v (@$val) { - $sname = $mname . '[' . $i . ']'; - $out .= $pad . $ipad . '#' . $i if $s->{indent} >= 3; - $out .= $pad . $ipad . $s->_dump($v, $sname); - $out .= "," if $i++ < $#$val; - } - $out .= $pad . ($s->{xpad} x ($s->{level} - 1)) if $i; - $out .= ($name =~ /^\@/) ? ')' : ']'; - } - elsif ($realtype eq 'HASH') { - my($k, $v, $pad, $lpad, $mname); - $out .= ($name =~ /^\%/) ? '(' : '{'; - $pad = $s->{sep} . $s->{pad} . $s->{apad}; - $lpad = $s->{apad}; - ($name =~ /^\%(.*)$/) ? ($mname = "\$" . $1) : - # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar} - ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) : - ($mname = $name . '->'); - $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/; - while (($k, $v) = each %$val) { - my $nk = $s->_dump($k, ""); - $nk = $1 if !$s->{quotekeys} and $nk =~ /^[\"\']([A-Za-z_]\w*)[\"\']$/; - $sname = $mname . '{' . $nk . '}'; - $out .= $pad . $ipad . $nk . " => "; - - # temporarily alter apad - $s->{apad} .= (" " x (length($nk) + 4)) if $s->{indent} >= 2; - $out .= $s->_dump($val->{$k}, $sname) . ","; - $s->{apad} = $lpad if $s->{indent} >= 2; - } - if (substr($out, -1) eq ',') { - chop $out; - $out .= $pad . ($s->{xpad} x ($s->{level} - 1)); - } - $out .= ($name =~ /^\%/) ? ')' : '}'; - } - elsif ($realtype eq 'CODE') { - $out .= 'sub { "DUMMY" }'; - carp "Encountered CODE ref, using dummy placeholder" if $s->{purity}; - } - else { - croak "Can\'t handle $realtype type."; - } - - if ($realpack) { # we have a blessed ref - $out .= ', \'' . $realpack . '\'' . ' )'; - $out .= '->' . $s->{toaster} . '()' if $s->{toaster} ne ''; - $s->{apad} = $blesspad; - } - $s->{level}--; - - } - else { # simple scalar - - my $ref = \$_[1]; - # first, catalog the scalar - if ($name ne '') { - ($id) = ("$ref" =~ /\(([^\(]*)\)$/); - if (exists $s->{seen}{$id}) { - if ($s->{seen}{$id}[2]) { - $out = $s->{seen}{$id}[0]; - #warn "[<$out]\n"; - return "\${$out}"; - } - } - else { - #warn "[>\\$name]\n"; - $s->{seen}{$id} = ["\\$name", $ref]; - } - } - if (ref($ref) eq 'GLOB' or "$ref" =~ /=GLOB\([^()]+\)$/) { # glob - my $name = substr($val, 1); - if ($name =~ /^[A-Za-z_][\w:]*$/) { - $name =~ s/^main::/::/; - $sname = $name; - } - else { - $sname = $s->_dump($name, ""); - $sname = '{' . $sname . '}'; - } - if ($s->{purity}) { - my $k; - local ($s->{level}) = 0; - for $k (qw(SCALAR ARRAY HASH)) { - my $gval = *$val{$k}; - next unless defined $gval; - next if $k eq "SCALAR" && ! defined $$gval; # always there - - # _dump can push into @post, so we hold our place using $postlen - my $postlen = scalar @post; - $post[$postlen] = "\*$sname = "; - local ($s->{apad}) = " " x length($post[$postlen]) if $s->{indent} >= 2; - $post[$postlen] .= $s->_dump($gval, "\*$sname\{$k\}"); - } - } - $out .= '*' . $sname; - } - elsif (!defined($val)) { - $out .= "undef"; - } - elsif ($val =~ /^(?:0|-?[1-9]\d{0,8})$/) { # safe decimal number - $out .= $val; - } - else { # string - if ($s->{useqq}) { - $out .= qquote($val, $s->{useqq}); - } - else { - $val =~ s/([\\\'])/\\$1/g; - $out .= '\'' . $val . '\''; - } - } - } - if ($id) { - # if we made it this far, $id was added to seen list at current - # level, so remove it to get deep copies - if ($s->{deepcopy}) { - delete($s->{seen}{$id}); - } - elsif ($name) { - $s->{seen}{$id}[2] = 1; - } - } - return $out; -} - -# -# non-OO style of earlier version -# -sub Dumper { - return Data::Dumper->Dump([@_]); -} - -# compat stub -sub DumperX { - return Data::Dumper->Dumpxs([@_], []); -} - -sub Dumpf { return Data::Dumper->Dump(@_) } - -sub Dumpp { print Data::Dumper->Dump(@_) } - -# -# reset the "seen" cache -# -sub Reset { - my($s) = shift; - $s->{seen} = {}; - return $s; -} - -sub Indent { - my($s, $v) = @_; - if (defined($v)) { - if ($v == 0) { - $s->{xpad} = ""; - $s->{sep} = ""; - } - else { - $s->{xpad} = " "; - $s->{sep} = "\n"; - } - $s->{indent} = $v; - return $s; - } - else { - return $s->{indent}; - } -} - -sub Pad { - my($s, $v) = @_; - defined($v) ? (($s->{pad} = $v), return $s) : $s->{pad}; -} - -sub Varname { - my($s, $v) = @_; - defined($v) ? (($s->{varname} = $v), return $s) : $s->{varname}; -} - -sub Purity { - my($s, $v) = @_; - defined($v) ? (($s->{purity} = $v), return $s) : $s->{purity}; -} - -sub Useqq { - my($s, $v) = @_; - defined($v) ? (($s->{useqq} = $v), return $s) : $s->{useqq}; -} - -sub Terse { - my($s, $v) = @_; - defined($v) ? (($s->{terse} = $v), return $s) : $s->{terse}; -} - -sub Freezer { - my($s, $v) = @_; - defined($v) ? (($s->{freezer} = $v), return $s) : $s->{freezer}; -} - -sub Toaster { - my($s, $v) = @_; - defined($v) ? (($s->{toaster} = $v), return $s) : $s->{toaster}; -} - -sub Deepcopy { - my($s, $v) = @_; - defined($v) ? (($s->{deepcopy} = $v), return $s) : $s->{deepcopy}; -} - -sub Quotekeys { - my($s, $v) = @_; - defined($v) ? (($s->{quotekeys} = $v), return $s) : $s->{quotekeys}; -} - -sub Bless { - my($s, $v) = @_; - defined($v) ? (($s->{'bless'} = $v), return $s) : $s->{'bless'}; -} - -sub Maxdepth { - my($s, $v) = @_; - defined($v) ? (($s->{'maxdepth'} = $v), return $s) : $s->{'maxdepth'}; -} - - -# used by qquote below -my %esc = ( - "\a" => "\\a", - "\b" => "\\b", - "\t" => "\\t", - "\n" => "\\n", - "\f" => "\\f", - "\r" => "\\r", - "\e" => "\\e", -); - -# put a string value in double quotes -sub qquote { - local($_) = shift; - s/([\\\"\@\$])/\\$1/g; - return qq("$_") unless - /[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~]/; # fast exit - - my $high = shift || ""; - s/([\a\b\t\n\f\r\e])/$esc{$1}/g; - - if (ord('^')==94) { # ascii - # no need for 3 digits in escape for these - s/([\0-\037])(?!\d)/'\\'.sprintf('%o',ord($1))/eg; - s/([\0-\037\177])/'\\'.sprintf('%03o',ord($1))/eg; - # all but last branch below not supported --BEHAVIOR SUBJECT TO CHANGE-- - if ($high eq "iso8859") { - s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg; - } elsif ($high eq "utf8") { -# use utf8; -# $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge; - } elsif ($high eq "8bit") { - # leave it as it is - } else { - s/([\200-\377])/'\\'.sprintf('%03o',ord($1))/eg; - } - } - else { # ebcdic - s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])(?!\d)} - {my $v = ord($1); '\\'.sprintf(($v <= 037 ? '%o' : '%03o'), $v)}eg; - s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])} - {'\\'.sprintf('%03o',ord($1))}eg; - } - - return qq("$_"); -} - -1; -__END__ - -=head1 NAME - -Data::Dumper - stringified perl data structures, suitable for both printing and C<eval> - - -=head1 SYNOPSIS - - use Data::Dumper; - - # simple procedural interface - print Dumper($foo, $bar); - - # extended usage with names - print Data::Dumper->Dump([$foo, $bar], [qw(foo *ary)]); - - # configuration variables - { - local $Data::Dump::Purity = 1; - eval Data::Dumper->Dump([$foo, $bar], [qw(foo *ary)]); - } - - # OO usage - $d = Data::Dumper->new([$foo, $bar], [qw(foo *ary)]); - ... - print $d->Dump; - ... - $d->Purity(1)->Terse(1)->Deepcopy(1); - eval $d->Dump; - - -=head1 DESCRIPTION - -Given a list of scalars or reference variables, writes out their contents in -perl syntax. The references can also be objects. The contents of each -variable is output in a single Perl statement. Handles self-referential -structures correctly. - -The return value can be C<eval>ed to get back an identical copy of the -original reference structure. - -Any references that are the same as one of those passed in will be named -C<$VAR>I<n> (where I<n> is a numeric suffix), and other duplicate references -to substructures within C<$VAR>I<n> will be appropriately labeled using arrow -notation. You can specify names for individual values to be dumped if you -use the C<Dump()> method, or you can change the default C<$VAR> prefix to -something else. See C<$Data::Dumper::Varname> and C<$Data::Dumper::Terse> -below. - -The default output of self-referential structures can be C<eval>ed, but the -nested references to C<$VAR>I<n> will be undefined, since a recursive -structure cannot be constructed using one Perl statement. You should set the -C<Purity> flag to 1 to get additional statements that will correctly fill in -these references. - -In the extended usage form, the references to be dumped can be given -user-specified names. If a name begins with a C<*>, the output will -describe the dereferenced type of the supplied reference for hashes and -arrays, and coderefs. Output of names will be avoided where possible if -the C<Terse> flag is set. - -In many cases, methods that are used to set the internal state of the -object will return the object itself, so method calls can be conveniently -chained together. - -Several styles of output are possible, all controlled by setting -the C<Indent> flag. See L<Configuration Variables or Methods> below -for details. - - -=head2 Methods - -=over 4 - -=item I<PACKAGE>->new(I<ARRAYREF [>, I<ARRAYREF]>) - -Returns a newly created C<Data::Dumper> object. The first argument is an -anonymous array of values to be dumped. The optional second argument is an -anonymous array of names for the values. The names need not have a leading -C<$> sign, and must be comprised of alphanumeric characters. You can begin -a name with a C<*> to specify that the dereferenced type must be dumped -instead of the reference itself, for ARRAY and HASH references. - -The prefix specified by C<$Data::Dumper::Varname> will be used with a -numeric suffix if the name for a value is undefined. - -Data::Dumper will catalog all references encountered while dumping the -values. Cross-references (in the form of names of substructures in perl -syntax) will be inserted at all possible points, preserving any structural -interdependencies in the original set of values. Structure traversal is -depth-first, and proceeds in order from the first supplied value to -the last. - -=item I<$OBJ>->Dump I<or> I<PACKAGE>->Dump(I<ARRAYREF [>, I<ARRAYREF]>) - -Returns the stringified form of the values stored in the object (preserving -the order in which they were supplied to C<new>), subject to the -configuration options below. In a list context, it returns a list -of strings corresponding to the supplied values. - -The second form, for convenience, simply calls the C<new> method on its -arguments before dumping the object immediately. - -=item I<$OBJ>->Seen(I<[HASHREF]>) - -Queries or adds to the internal table of already encountered references. -You must use C<Reset> to explicitly clear the table if needed. Such -references are not dumped; instead, their names are inserted wherever they -are encountered subsequently. This is useful especially for properly -dumping subroutine references. - -Expects a anonymous hash of name => value pairs. Same rules apply for names -as in C<new>. If no argument is supplied, will return the "seen" list of -name => value pairs, in a list context. Otherwise, returns the object -itself. - -=item I<$OBJ>->Values(I<[ARRAYREF]>) - -Queries or replaces the internal array of values that will be dumped. -When called without arguments, returns the values. Otherwise, returns the -object itself. - -=item I<$OBJ>->Names(I<[ARRAYREF]>) - -Queries or replaces the internal array of user supplied names for the values -that will be dumped. When called without arguments, returns the names. -Otherwise, returns the object itself. - -=item I<$OBJ>->Reset - -Clears the internal table of "seen" references and returns the object -itself. - -=back - -=head2 Functions - -=over 4 - -=item Dumper(I<LIST>) - -Returns the stringified form of the values in the list, subject to the -configuration options below. The values will be named C<$VAR>I<n> in the -output, where I<n> is a numeric suffix. Will return a list of strings -in a list context. - -=back - -=head2 Configuration Variables or Methods - -Several configuration variables can be used to control the kind of output -generated when using the procedural interface. These variables are usually -C<local>ized in a block so that other parts of the code are not affected by -the change. - -These variables determine the default state of the object created by calling -the C<new> method, but cannot be used to alter the state of the object -thereafter. The equivalent method names should be used instead to query -or set the internal state of the object. - -The method forms return the object itself when called with arguments, -so that they can be chained together nicely. - -=over 4 - -=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 -items. It is the most compact format possible that can still be called -valid perl. Style 1 outputs a readable form with newlines but no fancy -indentation (each level in the structure is simply indented by a fixed -amount of whitespace). Style 2 (the default) outputs a very readable form -which takes into account the length of hash keys (so the hash value lines -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]>) - -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]>) - -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]>) - -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]>) - -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" -characters will be backslashed, and unprintable characters will be output as -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]>) - -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]>) - -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 -stringify it. This method can alter the contents of the object (if, for -instance, it contains data allocated from C), and even rebless it in a -different package. The client is responsible for making sure the specified -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]>) - -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 -using the syntax C<bless(DATA, CLASS)->METHOD()>. Note that this means that -the method specified will have to perform any modifications required on the -object (like creating new state within it, and/or reblessing it in a -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]>) - -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]>) - -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]>) - -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]>) - -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 -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. - -=back - -=head2 Exports - -=over 4 - -=item Dumper - -=back - -=head1 EXAMPLES - -Run these code snippets to get a quick feel for the behavior of this -module. When you are through with these examples, you may want to -add or change the various configuration variables described above, -to see their behavior. (See the testsuite in the Data::Dumper -distribution for more examples.) - - - use Data::Dumper; - - package Foo; - sub new {bless {'a' => 1, 'b' => sub { return "foo" }}, $_[0]}; - - package Fuz; # a weird REF-REF-SCALAR object - sub new {bless \($_ = \ 'fu\'z'), $_[0]}; - - package main; - $foo = Foo->new; - $fuz = Fuz->new; - $boo = [ 1, [], "abcd", \*foo, - {1 => 'a', 023 => 'b', 0x45 => 'c'}, - \\"p\q\'r", $foo, $fuz]; - - ######## - # simple usage - ######## - - $bar = eval(Dumper($boo)); - print($@) if $@; - print Dumper($boo), Dumper($bar); # pretty print (no array indices) - - $Data::Dumper::Terse = 1; # don't output names where feasible - $Data::Dumper::Indent = 0; # turn off all pretty print - print Dumper($boo), "\n"; - - $Data::Dumper::Indent = 1; # mild pretty print - print Dumper($boo); - - $Data::Dumper::Indent = 3; # pretty print with array indices - print Dumper($boo); - - $Data::Dumper::Useqq = 1; # print strings in double quotes - print Dumper($boo); - - - ######## - # recursive structures - ######## - - @c = ('c'); - $c = \@c; - $b = {}; - $a = [1, $b, $c]; - $b->{a} = $a; - $b->{b} = $a->[1]; - $b->{c} = $a->[2]; - print Data::Dumper->Dump([$a,$b,$c], [qw(a b c)]); - - - $Data::Dumper::Purity = 1; # fill in the holes for eval - print Data::Dumper->Dump([$a, $b], [qw(*a b)]); # print as @a - print Data::Dumper->Dump([$b, $a], [qw(*b a)]); # print as %b - - - $Data::Dumper::Deepcopy = 1; # avoid cross-refs - print Data::Dumper->Dump([$b, $a], [qw(*b a)]); - - - $Data::Dumper::Purity = 0; # avoid cross-refs - print Data::Dumper->Dump([$b, $a], [qw(*b a)]); - - ######## - # deep structures - ######## - - $a = "pearl"; - $b = [ $a ]; - $c = { 'b' => $b }; - $d = [ $c ]; - $e = { 'd' => $d }; - $f = { 'e' => $e }; - print Data::Dumper->Dump([$f], [qw(f)]); - - $Data::Dumper::Maxdepth = 3; # no deeper than 3 refs down - print Data::Dumper->Dump([$f], [qw(f)]); - - - ######## - # object-oriented usage - ######## - - $d = Data::Dumper->new([$a,$b], [qw(a b)]); - $d->Seen({'*c' => $c}); # stash a ref without printing it - $d->Indent(3); - print $d->Dump; - $d->Reset->Purity(0); # empty the seen cache - print join "----\n", $d->Dump; - - - ######## - # persistence - ######## - - package Foo; - sub new { bless { state => 'awake' }, shift } - sub Freeze { - my $s = shift; - print STDERR "preparing to sleep\n"; - $s->{state} = 'asleep'; - return bless $s, 'Foo::ZZZ'; - } - - package Foo::ZZZ; - sub Thaw { - my $s = shift; - print STDERR "waking up\n"; - $s->{state} = 'awake'; - return bless $s, 'Foo'; - } - - package Foo; - use Data::Dumper; - $a = Foo->new; - $b = Data::Dumper->new([$a], ['c']); - $b->Freezer('Freeze'); - $b->Toaster('Thaw'); - $c = $b->Dump; - print $c; - $d = eval $c; - print Data::Dumper->Dump([$d], ['d']); - - - ######## - # symbol substitution (useful for recreating CODE refs) - ######## - - sub foo { print "foo speaking\n" } - *other = \&foo; - $bar = [ \&other ]; - $d = Data::Dumper->new([\&other,$bar],['*other','bar']); - $d->Seen({ '*foo' => \&foo }); - print $d->Dump; - - -=head1 BUGS - -Due to limitations of Perl subroutine call semantics, you cannot pass an -array or hash. Prepend it with a C<\> to pass its reference instead. This -will be remedied in time, with the arrival of prototypes in later versions -of Perl. For now, you need to use the extended usage form, and prepend the -name with a C<*> to output it as a hash or array. - -C<Data::Dumper> cheats with CODE references. If a code reference is -encountered in the structure being processed, an anonymous subroutine that -contains the string '"DUMMY"' will be inserted in its place, and a warning -will be printed if C<Purity> is set. You can C<eval> the result, but bear -in mind that the anonymous sub that gets created is just a placeholder. -Someday, perl will have a switch to cache-on-demand the string -representation of a compiled piece of code, I hope. If you have prior -knowledge of all the code refs that your data structures are likely -to have, you can use the C<Seen> method to pre-seed the internal reference -table and make the dumped output point to them, instead. See L<EXAMPLES> -above. - -The C<Useqq> flag makes Dump() run slower, since the XSUB implementation -does not support it. - -SCALAR objects have the weirdest looking C<bless> workaround. - - -=head1 AUTHOR - -Gurusamy Sarathy gsar@activestate.com - -Copyright (c) 1996-98 Gurusamy Sarathy. All rights reserved. -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - - -=head1 VERSION - -Version 2.11 (unreleased) - -=head1 SEE ALSO - -perl(1) - -=cut diff --git a/contrib/perl5/ext/Data/Dumper/Dumper.xs b/contrib/perl5/ext/Data/Dumper/Dumper.xs deleted file mode 100644 index 25e72b1..0000000 --- a/contrib/perl5/ext/Data/Dumper/Dumper.xs +++ /dev/null @@ -1,901 +0,0 @@ -#define PERL_NO_GET_CONTEXT -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#ifndef PERL_VERSION -#include "patchlevel.h" -#define PERL_VERSION PATCHLEVEL -#endif - -#if PERL_VERSION < 5 -# ifndef PL_sv_undef -# define PL_sv_undef sv_undef -# endif -# ifndef ERRSV -# define ERRSV GvSV(errgv) -# endif -# ifndef newSVpvn -# define newSVpvn newSVpv -# endif -#endif - -static I32 num_q (char *s, STRLEN slen); -static I32 esc_q (char *dest, char *src, STRLEN slen); -static SV *sv_x (pTHX_ SV *sv, char *str, STRLEN len, I32 n); -static I32 DD_dump (pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, - HV *seenhv, AV *postav, I32 *levelp, I32 indent, - SV *pad, SV *xpad, SV *apad, SV *sep, - SV *freezer, SV *toaster, - I32 purity, I32 deepcopy, I32 quotekeys, SV *bless, - I32 maxdepth); - -/* does a string need to be protected? */ -static I32 -needs_quote(register char *s) -{ -TOP: - if (s[0] == ':') { - if (*++s) { - if (*s++ != ':') - return 1; - } - else - return 1; - } - if (isIDFIRST(*s)) { - while (*++s) - if (!isALNUM(*s)) { - if (*s == ':') - goto TOP; - else - return 1; - } - } - else - return 1; - return 0; -} - -/* count the number of "'"s and "\"s in string */ -static I32 -num_q(register char *s, register STRLEN slen) -{ - register I32 ret = 0; - - while (slen > 0) { - if (*s == '\'' || *s == '\\') - ++ret; - ++s; - --slen; - } - return ret; -} - - -/* returns number of chars added to escape "'"s and "\"s in s */ -/* slen number of characters in s will be escaped */ -/* destination must be long enough for additional chars */ -static I32 -esc_q(register char *d, register char *s, register STRLEN slen) -{ - register I32 ret = 0; - - while (slen > 0) { - switch (*s) { - case '\'': - case '\\': - *d = '\\'; - ++d; ++ret; - default: - *d = *s; - ++d; ++s; --slen; - break; - } - } - return ret; -} - -/* append a repeated string to an SV */ -static SV * -sv_x(pTHX_ SV *sv, register char *str, STRLEN len, I32 n) -{ - if (sv == Nullsv) - sv = newSVpvn("", 0); - else - assert(SvTYPE(sv) >= SVt_PV); - - if (n > 0) { - SvGROW(sv, len*n + SvCUR(sv) + 1); - if (len == 1) { - char *start = SvPVX(sv) + SvCUR(sv); - SvCUR(sv) += n; - start[n] = '\0'; - while (n > 0) - start[--n] = str[0]; - } - else - while (n > 0) { - sv_catpvn(sv, str, len); - --n; - } - } - return sv; -} - -/* - * This ought to be split into smaller functions. (it is one long function since - * it exactly parallels the perl version, which was one long thing for - * efficiency raisins.) Ugggh! - */ -static I32 -DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, - AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad, - SV *apad, SV *sep, SV *freezer, SV *toaster, I32 purity, - I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth) -{ - char tmpbuf[128]; - U32 i; - char *c, *r, *realpack, id[128]; - SV **svp; - SV *sv, *ipad, *ival; - SV *blesspad = Nullsv; - AV *seenentry = Nullav; - char *iname; - STRLEN inamelen, idlen = 0; - U32 flags; - U32 realtype; - - if (!val) - return 0; - - flags = SvFLAGS(val); - realtype = SvTYPE(val); - - if (SvGMAGICAL(val)) - mg_get(val); - if (SvROK(val)) { - - if (SvOBJECT(SvRV(val)) && freezer && - SvPOK(freezer) && SvCUR(freezer)) - { - dSP; ENTER; SAVETMPS; PUSHMARK(sp); - XPUSHs(val); PUTBACK; - i = perl_call_method(SvPVX(freezer), G_EVAL|G_SCALAR); - SPAGAIN; - if (SvTRUE(ERRSV)) - warn("WARNING(Freezer method call failed): %s", - SvPVX(ERRSV)); - else if (i) - val = newSVsv(POPs); - PUTBACK; FREETMPS; LEAVE; - if (i) - (void)sv_2mortal(val); - } - - ival = SvRV(val); - flags = SvFLAGS(ival); - realtype = SvTYPE(ival); - (void) sprintf(id, "0x%lx", (unsigned long)ival); - idlen = strlen(id); - if (SvOBJECT(ival)) - realpack = HvNAME(SvSTASH(ival)); - else - realpack = Nullch; - - /* if it has a name, we need to either look it up, or keep a tab - * on it so we know when we hit it later - */ - if (namelen) { - if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) - && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv))) - { - SV *othername; - if ((svp = av_fetch(seenentry, 0, FALSE)) - && (othername = *svp)) - { - if (purity && *levelp > 0) { - SV *postentry; - - if (realtype == SVt_PVHV) - sv_catpvn(retval, "{}", 2); - else if (realtype == SVt_PVAV) - sv_catpvn(retval, "[]", 2); - else - sv_catpvn(retval, "do{my $o}", 9); - postentry = newSVpvn(name, namelen); - sv_catpvn(postentry, " = ", 3); - sv_catsv(postentry, othername); - av_push(postav, postentry); - } - else { - if (name[0] == '@' || name[0] == '%') { - if ((SvPVX(othername))[0] == '\\' && - (SvPVX(othername))[1] == name[0]) { - sv_catpvn(retval, SvPVX(othername)+1, - SvCUR(othername)-1); - } - else { - sv_catpvn(retval, name, 1); - sv_catpvn(retval, "{", 1); - sv_catsv(retval, othername); - sv_catpvn(retval, "}", 1); - } - } - else - sv_catsv(retval, othername); - } - return 1; - } - else { - warn("ref name not found for %s", id); - return 0; - } - } - else { /* store our name and continue */ - SV *namesv; - if (name[0] == '@' || name[0] == '%') { - namesv = newSVpvn("\\", 1); - sv_catpvn(namesv, name, namelen); - } - else if (realtype == SVt_PVCV && name[0] == '*') { - namesv = newSVpvn("\\", 2); - sv_catpvn(namesv, name, namelen); - (SvPVX(namesv))[1] = '&'; - } - else - namesv = newSVpvn(name, namelen); - seenentry = newAV(); - av_push(seenentry, namesv); - (void)SvREFCNT_inc(val); - av_push(seenentry, val); - (void)hv_store(seenhv, id, strlen(id), - newRV((SV*)seenentry), 0); - SvREFCNT_dec(seenentry); - } - } - - if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) { - STRLEN rlen; - char *rval = SvPV(val, rlen); - char *slash = strchr(rval, '/'); - sv_catpvn(retval, "qr/", 3); - while (slash) { - sv_catpvn(retval, rval, slash-rval); - sv_catpvn(retval, "\\/", 2); - rlen -= slash-rval+1; - rval = slash+1; - slash = strchr(rval, '/'); - } - sv_catpvn(retval, rval, rlen); - sv_catpvn(retval, "/", 1); - return 1; - } - - /* If purity is not set and maxdepth is set, then check depth: - * if we have reached maximum depth, return the string - * representation of the thing we are currently examining - * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)'). - */ - if (!purity && maxdepth > 0 && *levelp >= maxdepth) { - STRLEN vallen; - char *valstr = SvPV(val,vallen); - sv_catpvn(retval, "'", 1); - sv_catpvn(retval, valstr, vallen); - sv_catpvn(retval, "'", 1); - return 1; - } - - if (realpack) { /* we have a blessed ref */ - STRLEN blesslen; - char *blessstr = SvPV(bless, blesslen); - sv_catpvn(retval, blessstr, blesslen); - sv_catpvn(retval, "( ", 2); - if (indent >= 2) { - blesspad = apad; - apad = newSVsv(apad); - sv_x(aTHX_ apad, " ", 1, blesslen+2); - } - } - - (*levelp)++; - ipad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp); - - if (realtype <= SVt_PVBM) { /* scalar ref */ - SV *namesv = newSVpvn("${", 2); - sv_catpvn(namesv, name, namelen); - sv_catpvn(namesv, "}", 1); - if (realpack) { /* blessed */ - sv_catpvn(retval, "do{\\(my $o = ", 13); - DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv, - postav, levelp, indent, pad, xpad, apad, sep, - freezer, toaster, purity, deepcopy, quotekeys, bless, - maxdepth); - sv_catpvn(retval, ")}", 2); - } /* plain */ - else { - sv_catpvn(retval, "\\", 1); - DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv, - postav, levelp, indent, pad, xpad, apad, sep, - freezer, toaster, purity, deepcopy, quotekeys, bless, - maxdepth); - } - SvREFCNT_dec(namesv); - } - else if (realtype == SVt_PVGV) { /* glob ref */ - SV *namesv = newSVpvn("*{", 2); - sv_catpvn(namesv, name, namelen); - sv_catpvn(namesv, "}", 1); - sv_catpvn(retval, "\\", 1); - DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv, - postav, levelp, indent, pad, xpad, apad, sep, - freezer, toaster, purity, deepcopy, quotekeys, bless, - maxdepth); - SvREFCNT_dec(namesv); - } - else if (realtype == SVt_PVAV) { - SV *totpad; - I32 ix = 0; - I32 ixmax = av_len((AV *)ival); - - SV *ixsv = newSViv(0); - /* allowing for a 24 char wide array index */ - New(0, iname, namelen+28, char); - (void)strcpy(iname, name); - inamelen = namelen; - if (name[0] == '@') { - sv_catpvn(retval, "(", 1); - iname[0] = '$'; - } - else { - sv_catpvn(retval, "[", 1); - /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */ - /*if (namelen > 0 - && name[namelen-1] != ']' && name[namelen-1] != '}' - && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/ - if ((namelen > 0 - && name[namelen-1] != ']' && name[namelen-1] != '}') - || (namelen > 4 - && (name[1] == '{' - || (name[0] == '\\' && name[2] == '{')))) - { - iname[inamelen++] = '-'; iname[inamelen++] = '>'; - iname[inamelen] = '\0'; - } - } - if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 && - (instr(iname+inamelen-8, "{SCALAR}") || - instr(iname+inamelen-7, "{ARRAY}") || - instr(iname+inamelen-6, "{HASH}"))) { - iname[inamelen++] = '-'; iname[inamelen++] = '>'; - } - iname[inamelen++] = '['; iname[inamelen] = '\0'; - totpad = newSVsv(sep); - sv_catsv(totpad, pad); - sv_catsv(totpad, apad); - - for (ix = 0; ix <= ixmax; ++ix) { - STRLEN ilen; - SV *elem; - svp = av_fetch((AV*)ival, ix, FALSE); - if (svp) - elem = *svp; - else - elem = &PL_sv_undef; - - ilen = inamelen; - sv_setiv(ixsv, ix); - (void) sprintf(iname+ilen, "%"IVdf, (IV)ix); - ilen = strlen(iname); - iname[ilen++] = ']'; iname[ilen] = '\0'; - if (indent >= 3) { - sv_catsv(retval, totpad); - sv_catsv(retval, ipad); - sv_catpvn(retval, "#", 1); - sv_catsv(retval, ixsv); - } - sv_catsv(retval, totpad); - sv_catsv(retval, ipad); - DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav, - levelp, indent, pad, xpad, apad, sep, - freezer, toaster, purity, deepcopy, quotekeys, bless, - maxdepth); - if (ix < ixmax) - sv_catpvn(retval, ",", 1); - } - if (ixmax >= 0) { - SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), (*levelp)-1); - sv_catsv(retval, totpad); - sv_catsv(retval, opad); - SvREFCNT_dec(opad); - } - if (name[0] == '@') - sv_catpvn(retval, ")", 1); - else - sv_catpvn(retval, "]", 1); - SvREFCNT_dec(ixsv); - SvREFCNT_dec(totpad); - Safefree(iname); - } - else if (realtype == SVt_PVHV) { - SV *totpad, *newapad; - SV *iname, *sname; - HE *entry; - char *key; - I32 klen; - SV *hval; - - iname = newSVpvn(name, namelen); - if (name[0] == '%') { - sv_catpvn(retval, "(", 1); - (SvPVX(iname))[0] = '$'; - } - else { - sv_catpvn(retval, "{", 1); - /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */ - if ((namelen > 0 - && name[namelen-1] != ']' && name[namelen-1] != '}') - || (namelen > 4 - && (name[1] == '{' - || (name[0] == '\\' && name[2] == '{')))) - { - sv_catpvn(iname, "->", 2); - } - } - if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 && - (instr(name+namelen-8, "{SCALAR}") || - instr(name+namelen-7, "{ARRAY}") || - instr(name+namelen-6, "{HASH}"))) { - sv_catpvn(iname, "->", 2); - } - sv_catpvn(iname, "{", 1); - totpad = newSVsv(sep); - sv_catsv(totpad, pad); - sv_catsv(totpad, apad); - - (void)hv_iterinit((HV*)ival); - i = 0; - while ((entry = hv_iternext((HV*)ival))) { - char *nkey; - I32 nticks = 0; - - if (i) - sv_catpvn(retval, ",", 1); - i++; - key = hv_iterkey(entry, &klen); - hval = hv_iterval((HV*)ival, entry); - - if (quotekeys || needs_quote(key)) { - nticks = num_q(key, klen); - New(0, nkey, klen+nticks+3, char); - nkey[0] = '\''; - if (nticks) - klen += esc_q(nkey+1, key, klen); - else - (void)Copy(key, nkey+1, klen, char); - nkey[++klen] = '\''; - nkey[++klen] = '\0'; - } - else { - New(0, nkey, klen, char); - (void)Copy(key, nkey, klen, char); - } - - sname = newSVsv(iname); - sv_catpvn(sname, nkey, klen); - sv_catpvn(sname, "}", 1); - - sv_catsv(retval, totpad); - sv_catsv(retval, ipad); - sv_catpvn(retval, nkey, klen); - sv_catpvn(retval, " => ", 4); - if (indent >= 2) { - char *extra; - I32 elen = 0; - newapad = newSVsv(apad); - New(0, extra, klen+4+1, char); - while (elen < (klen+4)) - extra[elen++] = ' '; - extra[elen] = '\0'; - sv_catpvn(newapad, extra, elen); - Safefree(extra); - } - else - newapad = apad; - - DD_dump(aTHX_ hval, SvPVX(sname), SvCUR(sname), retval, seenhv, - postav, levelp, indent, pad, xpad, newapad, sep, - freezer, toaster, purity, deepcopy, quotekeys, bless, - maxdepth); - SvREFCNT_dec(sname); - Safefree(nkey); - if (indent >= 2) - SvREFCNT_dec(newapad); - } - if (i) { - SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp-1); - sv_catsv(retval, totpad); - sv_catsv(retval, opad); - SvREFCNT_dec(opad); - } - if (name[0] == '%') - sv_catpvn(retval, ")", 1); - else - sv_catpvn(retval, "}", 1); - SvREFCNT_dec(iname); - SvREFCNT_dec(totpad); - } - else if (realtype == SVt_PVCV) { - sv_catpvn(retval, "sub { \"DUMMY\" }", 15); - if (purity) - warn("Encountered CODE ref, using dummy placeholder"); - } - else { - warn("cannot handle ref type %ld", realtype); - } - - if (realpack) { /* free blessed allocs */ - if (indent >= 2) { - SvREFCNT_dec(apad); - apad = blesspad; - } - sv_catpvn(retval, ", '", 3); - sv_catpvn(retval, realpack, strlen(realpack)); - sv_catpvn(retval, "' )", 3); - if (toaster && SvPOK(toaster) && SvCUR(toaster)) { - sv_catpvn(retval, "->", 2); - sv_catsv(retval, toaster); - sv_catpvn(retval, "()", 2); - } - } - SvREFCNT_dec(ipad); - (*levelp)--; - } - else { - STRLEN i; - - if (namelen) { - (void) sprintf(id, "0x%lx", (unsigned long)val); - if ((svp = hv_fetch(seenhv, id, (idlen = strlen(id)), FALSE)) && - (sv = *svp) && SvROK(sv) && - (seenentry = (AV*)SvRV(sv))) - { - SV *othername; - if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp) - && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0) - { - sv_catpvn(retval, "${", 2); - sv_catsv(retval, othername); - sv_catpvn(retval, "}", 1); - return 1; - } - } - else { - SV *namesv; - namesv = newSVpvn("\\", 1); - sv_catpvn(namesv, name, namelen); - seenentry = newAV(); - av_push(seenentry, namesv); - av_push(seenentry, newRV(val)); - (void)hv_store(seenhv, id, strlen(id), newRV((SV*)seenentry), 0); - SvREFCNT_dec(seenentry); - } - } - - if (SvIOK(val)) { - STRLEN len; - if (SvIsUV(val)) - (void) sprintf(tmpbuf, "%"UVuf, SvUV(val)); - else - (void) sprintf(tmpbuf, "%"IVdf, SvIV(val)); - len = strlen(tmpbuf); - sv_catpvn(retval, tmpbuf, len); - } - else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */ - c = SvPV(val, i); - ++c; --i; /* just get the name */ - if (i >= 6 && strncmp(c, "main::", 6) == 0) { - c += 4; - i -= 4; - } - if (needs_quote(c)) { - sv_grow(retval, SvCUR(retval)+6+2*i); - r = SvPVX(retval)+SvCUR(retval); - r[0] = '*'; r[1] = '{'; r[2] = '\''; - i += esc_q(r+3, c, i); - i += 3; - r[i++] = '\''; r[i++] = '}'; - r[i] = '\0'; - } - else { - sv_grow(retval, SvCUR(retval)+i+2); - r = SvPVX(retval)+SvCUR(retval); - r[0] = '*'; strcpy(r+1, c); - i++; - } - SvCUR_set(retval, SvCUR(retval)+i); - - if (purity) { - static char *entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" }; - static STRLEN sizes[] = { 8, 7, 6 }; - SV *e; - SV *nname = newSVpvn("", 0); - SV *newapad = newSVpvn("", 0); - GV *gv = (GV*)val; - I32 j; - - for (j=0; j<3; j++) { - e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv)); - if (!e) - continue; - if (j == 0 && !SvOK(e)) - continue; - - { - I32 nlevel = 0; - SV *postentry = newSVpvn(r,i); - - sv_setsv(nname, postentry); - sv_catpvn(nname, entries[j], sizes[j]); - sv_catpvn(postentry, " = ", 3); - av_push(postav, postentry); - e = newRV(e); - - SvCUR(newapad) = 0; - if (indent >= 2) - (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry)); - - DD_dump(aTHX_ e, SvPVX(nname), SvCUR(nname), postentry, - seenhv, postav, &nlevel, indent, pad, xpad, - newapad, sep, freezer, toaster, purity, - deepcopy, quotekeys, bless, maxdepth); - SvREFCNT_dec(e); - } - } - - SvREFCNT_dec(newapad); - SvREFCNT_dec(nname); - } - } - else if (val == &PL_sv_undef || !SvOK(val)) { - sv_catpvn(retval, "undef", 5); - } - else { - c = SvPV(val, i); - sv_grow(retval, SvCUR(retval)+3+2*i); - r = SvPVX(retval)+SvCUR(retval); - r[0] = '\''; - i += esc_q(r+1, c, i); - ++i; - r[i++] = '\''; - r[i] = '\0'; - SvCUR_set(retval, SvCUR(retval)+i); - } - } - - if (idlen) { - if (deepcopy) - (void)hv_delete(seenhv, id, idlen, G_DISCARD); - else if (namelen && seenentry) { - SV *mark = *av_fetch(seenentry, 2, TRUE); - sv_setiv(mark,1); - } - } - return 1; -} - - -MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_ - -# -# This is the exact equivalent of Dump. Well, almost. The things that are -# different as of now (due to Laziness): -# * doesnt do double-quotes yet. -# - -void -Data_Dumper_Dumpxs(href, ...) - SV *href; - PROTOTYPE: $;$$ - PPCODE: - { - HV *hv; - SV *retval, *valstr; - HV *seenhv = Nullhv; - AV *postav, *todumpav, *namesav; - I32 level = 0; - I32 indent, terse, useqq, i, imax, postlen; - SV **svp; - SV *val, *name, *pad, *xpad, *apad, *sep, *tmp, *varname; - SV *freezer, *toaster, *bless; - I32 purity, deepcopy, quotekeys, maxdepth = 0; - char tmpbuf[1024]; - I32 gimme = GIMME; - - if (!SvROK(href)) { /* call new to get an object first */ - if (items < 2) - croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])"); - - ENTER; - SAVETMPS; - - PUSHMARK(sp); - XPUSHs(href); - XPUSHs(sv_2mortal(newSVsv(ST(1)))); - if (items >= 3) - XPUSHs(sv_2mortal(newSVsv(ST(2)))); - PUTBACK; - i = perl_call_method("new", G_SCALAR); - SPAGAIN; - if (i) - href = newSVsv(POPs); - - PUTBACK; - FREETMPS; - LEAVE; - if (i) - (void)sv_2mortal(href); - } - - todumpav = namesav = Nullav; - seenhv = Nullhv; - val = pad = xpad = apad = sep = tmp = varname - = freezer = toaster = bless = &PL_sv_undef; - name = sv_newmortal(); - indent = 2; - terse = useqq = purity = deepcopy = 0; - quotekeys = 1; - - retval = newSVpvn("", 0); - if (SvROK(href) - && (hv = (HV*)SvRV((SV*)href)) - && SvTYPE(hv) == SVt_PVHV) { - - if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp)) - seenhv = (HV*)SvRV(*svp); - if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp)) - todumpav = (AV*)SvRV(*svp); - if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp)) - namesav = (AV*)SvRV(*svp); - if ((svp = hv_fetch(hv, "indent", 6, FALSE))) - indent = SvIV(*svp); - if ((svp = hv_fetch(hv, "purity", 6, FALSE))) - purity = SvIV(*svp); - if ((svp = hv_fetch(hv, "terse", 5, FALSE))) - terse = SvTRUE(*svp); - if ((svp = hv_fetch(hv, "useqq", 5, FALSE))) - useqq = SvTRUE(*svp); - if ((svp = hv_fetch(hv, "pad", 3, FALSE))) - pad = *svp; - if ((svp = hv_fetch(hv, "xpad", 4, FALSE))) - xpad = *svp; - if ((svp = hv_fetch(hv, "apad", 4, FALSE))) - apad = *svp; - if ((svp = hv_fetch(hv, "sep", 3, FALSE))) - sep = *svp; - if ((svp = hv_fetch(hv, "varname", 7, FALSE))) - varname = *svp; - if ((svp = hv_fetch(hv, "freezer", 7, FALSE))) - freezer = *svp; - if ((svp = hv_fetch(hv, "toaster", 7, FALSE))) - toaster = *svp; - if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE))) - deepcopy = SvTRUE(*svp); - if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE))) - quotekeys = SvTRUE(*svp); - if ((svp = hv_fetch(hv, "bless", 5, FALSE))) - bless = *svp; - if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE))) - maxdepth = SvIV(*svp); - postav = newAV(); - - if (todumpav) - imax = av_len(todumpav); - else - imax = -1; - valstr = newSVpvn("",0); - for (i = 0; i <= imax; ++i) { - SV *newapad; - - av_clear(postav); - if ((svp = av_fetch(todumpav, i, FALSE))) - val = *svp; - else - val = &PL_sv_undef; - if ((svp = av_fetch(namesav, i, TRUE))) - sv_setsv(name, *svp); - else - (void)SvOK_off(name); - - if (SvOK(name)) { - if ((SvPVX(name))[0] == '*') { - if (SvROK(val)) { - switch (SvTYPE(SvRV(val))) { - case SVt_PVAV: - (SvPVX(name))[0] = '@'; - break; - case SVt_PVHV: - (SvPVX(name))[0] = '%'; - break; - case SVt_PVCV: - (SvPVX(name))[0] = '*'; - break; - default: - (SvPVX(name))[0] = '$'; - break; - } - } - else - (SvPVX(name))[0] = '$'; - } - else if ((SvPVX(name))[0] != '$') - sv_insert(name, 0, 0, "$", 1); - } - else { - STRLEN nchars = 0; - sv_setpvn(name, "$", 1); - sv_catsv(name, varname); - (void) sprintf(tmpbuf, "%"IVdf, (IV)(i+1)); - nchars = strlen(tmpbuf); - sv_catpvn(name, tmpbuf, nchars); - } - - if (indent >= 2) { - SV *tmpsv = sv_x(aTHX_ Nullsv, " ", 1, SvCUR(name)+3); - newapad = newSVsv(apad); - sv_catsv(newapad, tmpsv); - SvREFCNT_dec(tmpsv); - } - else - newapad = apad; - - DD_dump(aTHX_ val, SvPVX(name), SvCUR(name), valstr, seenhv, - postav, &level, indent, pad, xpad, newapad, sep, - freezer, toaster, purity, deepcopy, quotekeys, - bless, maxdepth); - - if (indent >= 2) - SvREFCNT_dec(newapad); - - postlen = av_len(postav); - if (postlen >= 0 || !terse) { - sv_insert(valstr, 0, 0, " = ", 3); - sv_insert(valstr, 0, 0, SvPVX(name), SvCUR(name)); - sv_catpvn(valstr, ";", 1); - } - sv_catsv(retval, pad); - sv_catsv(retval, valstr); - sv_catsv(retval, sep); - if (postlen >= 0) { - I32 i; - sv_catsv(retval, pad); - for (i = 0; i <= postlen; ++i) { - SV *elem; - svp = av_fetch(postav, i, FALSE); - if (svp && (elem = *svp)) { - sv_catsv(retval, elem); - if (i < postlen) { - sv_catpvn(retval, ";", 1); - sv_catsv(retval, sep); - sv_catsv(retval, pad); - } - } - } - sv_catpvn(retval, ";", 1); - sv_catsv(retval, sep); - } - sv_setpvn(valstr, "", 0); - if (gimme == G_ARRAY) { - XPUSHs(sv_2mortal(retval)); - if (i < imax) /* not the last time thro ? */ - retval = newSVpvn("",0); - } - } - SvREFCNT_dec(postav); - SvREFCNT_dec(valstr); - } - else - croak("Call to new() method failed to return HASH ref"); - if (gimme == G_SCALAR) - XPUSHs(sv_2mortal(retval)); - } diff --git a/contrib/perl5/ext/Data/Dumper/Makefile.PL b/contrib/perl5/ext/Data/Dumper/Makefile.PL deleted file mode 100644 index 12930c5..0000000 --- a/contrib/perl5/ext/Data/Dumper/Makefile.PL +++ /dev/null @@ -1,11 +0,0 @@ -use ExtUtils::MakeMaker; -WriteMakefile( - NAME => "Data::Dumper", - VERSION_FROM => 'Dumper.pm', - 'dist' => { - COMPRESS => 'gzip -9f', - SUFFIX => 'gz', - DIST_DEFAULT => 'all tardist', - }, - MAN3PODS => {}, -); diff --git a/contrib/perl5/ext/Data/Dumper/Todo b/contrib/perl5/ext/Data/Dumper/Todo deleted file mode 100644 index bd76e65..0000000 --- a/contrib/perl5/ext/Data/Dumper/Todo +++ /dev/null @@ -1,28 +0,0 @@ -=head1 NAME - -TODO - seeds germane, yet not germinated - -=head1 DESCRIPTION - -The following functionality will be supported in the next few releases. - -=over 4 - -=item $Data::Dumper::Expdepth I<or> $I<OBJ>->Expdepth(I<NEWVAL>) - -Dump contents explicitly up to a certain depth and then use names for -cross-referencing identical references. (useful in debugger, in situations -where we don't care so much for cross-references). - -=item Make C<Dumpxs()> honor C<$Useqq> - -=item Fix formatting when Terse is set and Indent >= 2 - -=item Output space after '\' (ref constructor) for high enough Indent - -=item Implement redesign that allows various backends (Perl, Lisp, -some-binary-data-format, graph-description-languages, etc.) - -=item Dump traversal in breadth-first order - -=back diff --git a/contrib/perl5/ext/Devel/DProf/Changes b/contrib/perl5/ext/Devel/DProf/Changes deleted file mode 100644 index 216498b..0000000 --- a/contrib/perl5/ext/Devel/DProf/Changes +++ /dev/null @@ -1,176 +0,0 @@ -1999 Jan 8 - - Ilya Zakharevich: - Newer perls: Add PERL_POLLUTE and dTHR. - -1998 Nov 10 -This version of DProf should work with older Perls too, but to get -full benefits some patches to 5.004_55 are needed. Patches take effect -after new version of Perl is installed, and DProf recompiled. - -Without these patches the overhead of DProf is too big, thus the statistic -may be very skewed. - -Oct 98: - Ilya Zakharevich: - DProf.xs - - correct defstash to PL_defstash - - nonlocal exits work - dprofpp - - nonlocal exits work - DProf.pm - - documentation updated - t/test6.* - - added - -Nov-Dec 97: - Jason E. Holt and Ilya Zakharevich: - DProf.xs - - will not wait until completion to write the output, size of buffer - regulated by PERL_DPROF_BUFFER, default 2**14 words; - - Ilya Zakharevich: - dprofpp - - smarter in fixing garbled profiles; - - subtracts DProf output overhead, and suggested profiler overhead; - - new options -A, -R, -g subroutine, -S; - - handles 'goto' too; - DProf.xs - - 7x denser output (time separated from name, ids for subs); - - outputs report-write overhead; - - optional higher-resolution (currently OS/2 only, cannot grok VMS code); - - outputs suggested profiler overhead; - - handles 'goto' too; - - handles PERL_DPROF_TICKS (on OS/2, VMS may be easily modified too) - -Jun 14, 97 andreas koenig adds the compatibility notes to the README -and lets the Makefile.PL die on $] < 5.004. - -Jun 06, 97 andreas koenig applies a patch by gurusamy sarathy because -Dean is not available for comments at that time. The patch is available -from CPAN in the authors/id/GSAR directory for inspection. - -Sep 30, 96 dmr - DProf.xs - - added Ilya's patches to fix "&bar as &bar(@_)" bug. This also fixes - the coredumps people have seen when using this with 5.003+. - DProf.pm - - updated manpage - t/bug.t - - moved to test5 - Makefile.PL - - remove special case for bug.t - -Jun 26, 96 dmr - dprofpp.PL - - smarter r.e. to find VERSION in Makefile (for MM5.27). - DProf.pm - - updated manpage - DProf.xs - - keep pid of profiled process, if process forks then only the - parent is profiled. Added test4 for this. - -Mar 2, 96 dmr - README - - updated - dprofpp - - updated manpage, point to DProf for raw profile description. - DProf.pm - - update manpage, update raw profile description with XS_VERSION. - - update manpage for AUTOLOAD changes. - DProf.xs - - smart handling of &AUTOLOAD--looks in $AUTOLOAD for the sub name. - this fixes one problem with corrupt profiles. - -Feb 5, 96 dmr - dprofpp - - updated manpage - - added -E/-I for exclusive/inclusive times - - added DPROFPP_OPTS -- lazily - - added -p/-Q for profile-then-analyze - - added version check - dprofpp.PL - - pull dprofpp's version id from the makefile - DProf.pm - - added version to bootstrap - - updated doc - - updated doc, DProf and -w are now friendly to each other - DProf.xs - - using savepv - - added Tim's patch to check for DBsub, avoids -MDevel::DProf coredump - - turn off warnings during newXS("DB::sub") - tests - - added Tim's patch to ignore Loader::import in results - - added Tim's patch to aid readability of test?.v output - - --- from those days when I kept a unique changelog for each module -- - -# Devel::DProf - a Perl code profiler -# 31oct95 -# -# changes/bugs fixed since 5apr95 version -dmr: -# -added VMS patches from CharlesB. -# -now open ./tmon.out in BOOT. -# changes/bugs fixed since 2apr95 version -dmr: -# -now mallocing an extra byte for the \0 :) -# changes/bugs fixed since 01mar95 version -dmr: -# -stringified code ref is used for name of anonymous sub. -# -include stash name with stringified code ref. -# -use perl.c's DBsingle and DBsub. -# -now using croak() and warn(). -# -print "timer is on" before turning timer on. -# -use safefree() instead of free(). -# -rely on PM to provide full path name to tmon.out. -# -print errno if unable to write tmon.out. -# changes/bugs fixed since 03feb95 version -dmr: -# -comments -# changes/bugs fixed since 31dec94 version -dmr: -# -added patches from AndyD. -# - -# Devel::DProf - a Perl code profiler -# 31oct95 -# -# changes/bugs fixed since 05apr95 version -dmr: -# - VMS-related prob; now let tmon.out name be handled in XS. -# changes/bugs fixed since 01mar95 version -dmr: -# - record $pwd and build pathname for tmon.out -# changes/bugs fixed since 03feb95 version -dmr: -# - fixed some doc bugs -# - added require 5.000 -# - added -w note to bugs section of pod -# changes/bugs fixed since 31dec94 version -dmr: -# - podified -# - - -# dprofpp - display perl profile data -# 31oct95 -# -# changes/bugs fixed since 7oct95 version -dmr: -# - PL'd -# changes/bugs fixed since 5apr95 version -dmr: -# - touch up handling of exit timestamps. -# - suggests -F when exit timestamps are missing. -# - added compressed execution tree patches from AchimB, put under -t. -# now -z is the default action; user+system time. -# - doc changes. -# changes/bugs fixed since 10feb95 version -dmr: -# - summary info is printed by default, opt_c is gone. -# - fixed some doc bugs -# - changed name to dprofpp -# changes/bugs fixed since 03feb95 version -dmr: -# - fixed division by zero. -# - replace many local()s with my(). -# - now prints user+system times by default -# now -u prints user time, -U prints unsorted. -# - fixed documentation -# - fixed output, to clarify that times are given in seconds. -# - can now fake exit timestamps if the profile is garbled. -# changes/bugs fixed since 17jun94 version -dmr: -# - podified. -# - correct old documentation flaws. -# - added AndyD's patches. -# - diff --git a/contrib/perl5/ext/Devel/DProf/DProf.pm b/contrib/perl5/ext/Devel/DProf/DProf.pm deleted file mode 100644 index 38082fc..0000000 --- a/contrib/perl5/ext/Devel/DProf/DProf.pm +++ /dev/null @@ -1,196 +0,0 @@ -require 5.005_64; - -=head1 NAME - -Devel::DProf - a Perl code profiler - -=head1 SYNOPSIS - - perl5 -d:DProf test.pl - -=head1 DESCRIPTION - -The Devel::DProf package is a Perl code profiler. This will collect -information on the execution time of a Perl script and of the subs in that -script. This information can be used to determine which subroutines are -using the most time and which subroutines are being called most often. This -information can also be used to create an execution graph of the script, -showing subroutine relationships. - -To profile a Perl script run the perl interpreter with the B<-d> debugging -switch. The profiler uses the debugging hooks. So to profile script -F<test.pl> the following command should be used: - - perl5 -d:DProf test.pl - -When the script terminates (or when the output buffer is filled) the -profiler will dump the profile information to a file called -F<tmon.out>. A tool like I<dprofpp> can be used to interpret the -information which is in that profile. The following command will -print the top 15 subroutines which used the most time: - - dprofpp - -To print an execution graph of the subroutines in the script use the -following command: - - dprofpp -T - -Consult L<dprofpp> for other options. - -=head1 PROFILE FORMAT - -The old profile is a text file which looks like this: - - #fOrTyTwO - $hz=100; - $XS_VERSION='DProf 19970606'; - # All values are given in HZ - $rrun_utime=2; $rrun_stime=0; $rrun_rtime=7 - PART2 - + 26 28 566822884 DynaLoader::import - - 26 28 566822884 DynaLoader::import - + 27 28 566822885 main::bar - - 27 28 566822886 main::bar - + 27 28 566822886 main::baz - + 27 28 566822887 main::bar - - 27 28 566822888 main::bar - [....] - -The first line is the magic number. The second line is the hertz value, or -clock ticks, of the machine where the profile was collected. The third line -is the name and version identifier of the tool which created the profile. -The fourth line is a comment. The fifth line contains three variables -holding the user time, system time, and realtime of the process while it was -being profiled. The sixth line indicates the beginning of the sub -entry/exit profile section. - -The columns in B<PART2> are: - - sub entry(+)/exit(-) mark - app's user time at sub entry/exit mark, in ticks - app's system time at sub entry/exit mark, in ticks - app's realtime at sub entry/exit mark, in ticks - fully-qualified sub name, when possible - -With newer perls another format is used, which may look like this: - - #fOrTyTwO - $hz=10000; - $XS_VERSION='DProf 19971213'; - # All values are given in HZ - $over_utime=5917; $over_stime=0; $over_rtime=5917; - $over_tests=10000; - $rrun_utime=1284; $rrun_stime=0; $rrun_rtime=1284; - $total_marks=6; - - PART2 - @ 406 0 406 - & 2 main bar - + 2 - @ 456 0 456 - - 2 - @ 1 0 1 - & 3 main baz - + 3 - @ 141 0 141 - + 2 - @ 141 0 141 - - 2 - @ 1 0 1 - & 4 main foo - + 4 - @ 142 0 142 - + & Devel::DProf::write - @ 5 0 5 - - & Devel::DProf::write - -(with high value of $ENV{PERL_DPROF_TICKS}). - -New C<$over_*> values show the measured overhead of making $over_tests -calls to the profiler These values are used by the profiler to -subtract the overhead from the runtimes. - -The lines starting with C<@> mark time passed from the previous C<@> -line. The lines starting with C<&> introduce new subroutine I<id> and -show the package and the subroutine name of this id. Lines starting -with C<+>, C<-> and C<*> mark entering and exit of subroutines by -I<id>s, and C<goto &subr>. - -The I<old-style> C<+>- and C<->-lines are used to mark the overhead -related to writing to profiler-output file. - -=head1 AUTOLOAD - -When Devel::DProf finds a call to an C<&AUTOLOAD> subroutine it looks at the -C<$AUTOLOAD> variable to find the real name of the sub being called. See -L<perlsub/"Autoloading">. - -=head1 ENVIRONMENT - -C<PERL_DPROF_BUFFER> sets size of output buffer in words. Defaults to 2**14. - -C<PERL_DPROF_TICKS> sets number of ticks per second on some systems where -a replacement for times() is used. Defaults to the value of C<HZ> macro. - -C<PERL_DPROF_OUT_FILE_NAME> sets the name of the output file. If not set, -defaults to tmon.out. - -=head1 BUGS - -Builtin functions cannot be measured by Devel::DProf. - -With a newer Perl DProf relies on the fact that the numeric slot of -$DB::sub contains an address of a subroutine. Excessive manipulation -of this variable may overwrite this slot, as in - - $DB::sub = 'current_sub'; - ... - $addr = $DB::sub + 0; - -will set this numeric slot to numeric value of the string -C<current_sub>, i.e., to C<0>. This will cause a segfault on the exit -from this subroutine. Note that the first assignment above does not -change the numeric slot (it will I<mark> it as invalid, but will not -write over it). - -Mail bug reports and feature requests to the perl5-porters mailing list at -F<E<lt>perl5-porters@perl.orgE<gt>>. - -=head1 SEE ALSO - -L<perl>, L<dprofpp>, times(2) - -=cut - -# This sub is needed for calibration. -package Devel::DProf; - -sub NONESUCH_noxs { - return $Devel::DProf::VERSION; -} - -package DB; - -# -# As of perl5.003_20, &DB::sub stub is not needed (some versions -# even had problems if stub was redefined with XS version). -# - -# disable DB single-stepping -BEGIN { $single = 0; } - -# This sub is needed during startup. -sub DB { -# print "nonXS DBDB\n"; -} - -use XSLoader (); - -# Underscore to allow older Perls to access older version from CPAN -$Devel::DProf::VERSION = '20000000.00_00'; # this version not authorized by - # Dean Roehrich. See "Changes" file. - -XSLoader::load 'Devel::DProf', $Devel::DProf::VERSION; - -1; diff --git a/contrib/perl5/ext/Devel/DProf/DProf.xs b/contrib/perl5/ext/Devel/DProf/DProf.xs deleted file mode 100644 index aba6de9..0000000 --- a/contrib/perl5/ext/Devel/DProf/DProf.xs +++ /dev/null @@ -1,679 +0,0 @@ -#define PERL_NO_GET_CONTEXT -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -/*#define DBG_SUB 1 */ -/*#define DBG_TIMER 1 */ - -#ifdef DBG_SUB -# define DBG_SUB_NOTIFY(A,B) warn(A, B) -#else -# define DBG_SUB_NOTIFY(A,B) /* nothing */ -#endif - -#ifdef DBG_TIMER -# define DBG_TIMER_NOTIFY(A) warn(A) -#else -# define DBG_TIMER_NOTIFY(A) /* nothing */ -#endif - -/* HZ == clock ticks per second */ -#ifdef VMS -# define HZ ((I32)CLK_TCK) -# define DPROF_HZ HZ -# include <starlet.h> /* prototype for sys$gettim() */ -# include <lib$routines.h> -# define Times(ptr) (dprof_times(aTHX_ ptr)) -#else -# ifndef HZ -# ifdef CLK_TCK -# define HZ ((I32)CLK_TCK) -# else -# define HZ 60 -# endif -# endif -# ifdef OS2 /* times() has significant overhead */ -# define Times(ptr) (dprof_times(aTHX_ ptr)) -# define INCL_DOSPROFILE -# define INCL_DOSERRORS -# include <os2.h> -# define toLongLong(arg) (*(long long*)&(arg)) -# define DPROF_HZ g_dprof_ticks -# else -# define Times(ptr) (times(ptr)) -# define DPROF_HZ HZ -# endif -#endif - -XS(XS_Devel__DProf_END); /* used by prof_mark() */ - -/* Everything is built on times(2). See its manpage for a description - * of the timings. - */ - -union prof_any { - clock_t tms_utime; /* cpu time spent in user space */ - clock_t tms_stime; /* cpu time spent in system */ - clock_t realtime; /* elapsed real time, in ticks */ - char *name; - U32 id; - opcode ptype; -}; - -typedef union prof_any PROFANY; - -typedef struct { - U32 dprof_ticks; - char* out_file_name; /* output file (defaults to tmon.out) */ - PerlIO* fp; /* pointer to tmon.out file */ - long TIMES_LOCATION; /* Where in the file to store the time totals */ - int SAVE_STACK; /* How much data to buffer until end of run */ - int prof_pid; /* pid of profiled process */ - struct tms prof_start; - struct tms prof_end; - clock_t rprof_start; /* elapsed real time ticks */ - clock_t rprof_end; - clock_t wprof_u; - clock_t wprof_s; - clock_t wprof_r; - clock_t otms_utime; - clock_t otms_stime; - clock_t orealtime; - PROFANY* profstack; - int profstack_max; - int profstack_ix; - HV* cv_hash; - U32 total; - U32 lastid; - U32 default_perldb; - U32 depth; -#ifdef OS2 - ULONG frequ; - long long start_cnt; -#endif -#ifdef PERL_IMPLICIT_CONTEXT -# define register - pTHX; -# undef register -#endif -} prof_state_t; - -prof_state_t g_prof_state; - -#define g_dprof_ticks g_prof_state.dprof_ticks -#define g_out_file_name g_prof_state.out_file_name -#define g_fp g_prof_state.fp -#define g_TIMES_LOCATION g_prof_state.TIMES_LOCATION -#define g_SAVE_STACK g_prof_state.SAVE_STACK -#define g_prof_pid g_prof_state.prof_pid -#define g_prof_start g_prof_state.prof_start -#define g_prof_end g_prof_state.prof_end -#define g_rprof_start g_prof_state.rprof_start -#define g_rprof_end g_prof_state.rprof_end -#define g_wprof_u g_prof_state.wprof_u -#define g_wprof_s g_prof_state.wprof_s -#define g_wprof_r g_prof_state.wprof_r -#define g_otms_utime g_prof_state.otms_utime -#define g_otms_stime g_prof_state.otms_stime -#define g_orealtime g_prof_state.orealtime -#define g_profstack g_prof_state.profstack -#define g_profstack_max g_prof_state.profstack_max -#define g_profstack_ix g_prof_state.profstack_ix -#define g_cv_hash g_prof_state.cv_hash -#define g_total g_prof_state.total -#define g_lastid g_prof_state.lastid -#define g_default_perldb g_prof_state.default_perldb -#define g_depth g_prof_state.depth -#ifdef PERL_IMPLICIT_CONTEXT -# define g_THX g_prof_state.aTHX -#endif -#ifdef OS2 -# define g_frequ g_prof_state.frequ -# define g_start_cnt g_prof_state.start_cnt -#endif - -clock_t -dprof_times(pTHX_ struct tms *t) -{ -#ifdef OS2 - ULONG rc; - QWORD cnt; - STRLEN n_a; - - if (!g_frequ) { - if (CheckOSError(DosTmrQueryFreq(&g_frequ))) - croak("DosTmrQueryFreq: %s", SvPV(perl_get_sv("!",TRUE),n_a)); - else - g_frequ = g_frequ/DPROF_HZ; /* count per tick */ - if (CheckOSError(DosTmrQueryTime(&cnt))) - croak("DosTmrQueryTime: %s", - SvPV(perl_get_sv("!",TRUE), n_a)); - g_start_cnt = toLongLong(cnt); - } - - if (CheckOSError(DosTmrQueryTime(&cnt))) - croak("DosTmrQueryTime: %s", SvPV(perl_get_sv("!",TRUE), n_a)); - t->tms_stime = 0; - return (t->tms_utime = (toLongLong(cnt) - g_start_cnt)/g_frequ); -#else /* !OS2 */ -# ifdef VMS - clock_t retval; - /* Get wall time and convert to 10 ms intervals to - * produce the return value dprof expects */ -# if defined(__DECC) && defined (__ALPHA) -# include <ints.h> - uint64 vmstime; - _ckvmssts(sys$gettim(&vmstime)); - vmstime /= 100000; - retval = vmstime & 0x7fffffff; -# else - /* (Older hw or ccs don't have an atomic 64-bit type, so we - * juggle 32-bit ints (and a float) to produce a time_t result - * with minimal loss of information.) */ - long int vmstime[2],remainder,divisor = 100000; - _ckvmssts(sys$gettim((unsigned long int *)vmstime)); - vmstime[1] &= 0x7fff; /* prevent overflow in EDIV */ - _ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder)); -# endif - /* Fill in the struct tms using the CRTL routine . . .*/ - times((tbuffer_t *)t); - return (clock_t) retval; -# else /* !VMS && !OS2 */ - return times(t); -# endif -#endif -} - -static void -prof_dumpa(pTHX_ opcode ptype, U32 id) -{ - if (ptype == OP_LEAVESUB) { - PerlIO_printf(g_fp,"- %"UVxf"\n", (UV)id); - } - else if(ptype == OP_ENTERSUB) { - PerlIO_printf(g_fp,"+ %"UVxf"\n", (UV)id); - } - else if(ptype == OP_GOTO) { - PerlIO_printf(g_fp,"* %"UVxf"\n", (UV)id); - } - else if(ptype == OP_DIE) { - PerlIO_printf(g_fp,"/ %"UVxf"\n", (UV)id); - } - else { - PerlIO_printf(g_fp,"Profiler unknown prof code %d\n", ptype); - } -} - -static void -prof_dumps(pTHX_ U32 id, char *pname, char *gname) -{ - PerlIO_printf(g_fp,"& %"UVxf" %s %s\n", (UV)id, pname, gname); -} - -static void -prof_dumpt(pTHX_ long tms_utime, long tms_stime, long realtime) -{ - PerlIO_printf(g_fp,"@ %ld %ld %ld\n", tms_utime, tms_stime, realtime); -} - -static void -prof_dump_until(pTHX_ long ix) -{ - long base = 0; - struct tms t1, t2; - clock_t realtime1, realtime2; - - realtime1 = Times(&t1); - - while (base < ix) { - opcode ptype = g_profstack[base++].ptype; - if (ptype == OP_TIME) { - long tms_utime = g_profstack[base++].tms_utime; - long tms_stime = g_profstack[base++].tms_stime; - long realtime = g_profstack[base++].realtime; - - prof_dumpt(aTHX_ tms_utime, tms_stime, realtime); - } - else if (ptype == OP_GV) { - U32 id = g_profstack[base++].id; - char *pname = g_profstack[base++].name; - char *gname = g_profstack[base++].name; - - prof_dumps(aTHX_ id, pname, gname); - } - else { - U32 id = g_profstack[base++].id; - prof_dumpa(aTHX_ ptype, id); - } - } - PerlIO_flush(g_fp); - realtime2 = Times(&t2); - if (realtime2 != realtime1 || t1.tms_utime != t2.tms_utime - || t1.tms_stime != t2.tms_stime) { - g_wprof_r += realtime2 - realtime1; - g_wprof_u += t2.tms_utime - t1.tms_utime; - g_wprof_s += t2.tms_stime - t1.tms_stime; - - PerlIO_printf(g_fp,"+ & Devel::DProf::write\n"); - PerlIO_printf(g_fp,"@ %"IVdf" %"IVdf" %"IVdf"\n", - /* The (IV) casts are one possibility: - * the Painfully Correct Way would be to - * have Clock_t_f. */ - (IV)(t2.tms_utime - t1.tms_utime), - (IV)(t2.tms_stime - t1.tms_stime), - (IV)(realtime2 - realtime1)); - PerlIO_printf(g_fp,"- & Devel::DProf::write\n"); - g_otms_utime = t2.tms_utime; - g_otms_stime = t2.tms_stime; - g_orealtime = realtime2; - PerlIO_flush(g_fp); - } -} - -static void -prof_mark(pTHX_ opcode ptype) -{ - struct tms t; - clock_t realtime, rdelta, udelta, sdelta; - U32 id; - SV *Sub = GvSV(PL_DBsub); /* name of current sub */ - - if (g_SAVE_STACK) { - if (g_profstack_ix + 5 > g_profstack_max) { - g_profstack_max = g_profstack_max * 3 / 2; - Renew(g_profstack, g_profstack_max, PROFANY); - } - } - - realtime = Times(&t); - rdelta = realtime - g_orealtime; - udelta = t.tms_utime - g_otms_utime; - sdelta = t.tms_stime - g_otms_stime; - if (rdelta || udelta || sdelta) { - if (g_SAVE_STACK) { - g_profstack[g_profstack_ix++].ptype = OP_TIME; - g_profstack[g_profstack_ix++].tms_utime = udelta; - g_profstack[g_profstack_ix++].tms_stime = sdelta; - g_profstack[g_profstack_ix++].realtime = rdelta; - } - else { /* Write it to disk now so's not to eat up core */ - if (g_prof_pid == (int)getpid()) { - prof_dumpt(aTHX_ udelta, sdelta, rdelta); - PerlIO_flush(g_fp); - } - } - g_orealtime = realtime; - g_otms_stime = t.tms_stime; - g_otms_utime = t.tms_utime; - } - - { - SV **svp; - char *gname, *pname; - CV *cv; - - cv = INT2PTR(CV*,SvIVX(Sub)); - svp = hv_fetch(g_cv_hash, (char*)&cv, sizeof(CV*), TRUE); - if (!SvOK(*svp)) { - GV *gv = CvGV(cv); - - sv_setiv(*svp, id = ++g_lastid); - pname = ((GvSTASH(gv) && HvNAME(GvSTASH(gv))) - ? HvNAME(GvSTASH(gv)) - : "(null)"); - gname = GvNAME(gv); - if (CvXSUB(cv) == XS_Devel__DProf_END) - return; - if (g_SAVE_STACK) { /* Store it for later recording -JH */ - g_profstack[g_profstack_ix++].ptype = OP_GV; - g_profstack[g_profstack_ix++].id = id; - g_profstack[g_profstack_ix++].name = pname; - g_profstack[g_profstack_ix++].name = gname; - } - else { /* Write it to disk now so's not to eat up core */ - /* Only record the parent's info */ - if (g_prof_pid == (int)getpid()) { - prof_dumps(aTHX_ id, pname, gname); - PerlIO_flush(g_fp); - } - else - PL_perldb = 0; /* Do not debug the kid. */ - } - } - else { - id = SvIV(*svp); - } - } - - g_total++; - if (g_SAVE_STACK) { /* Store it for later recording -JH */ - g_profstack[g_profstack_ix++].ptype = ptype; - g_profstack[g_profstack_ix++].id = id; - - /* Only record the parent's info */ - if (g_SAVE_STACK < g_profstack_ix) { - if (g_prof_pid == (int)getpid()) - prof_dump_until(aTHX_ g_profstack_ix); - else - PL_perldb = 0; /* Do not debug the kid. */ - g_profstack_ix = 0; - } - } - else { /* Write it to disk now so's not to eat up core */ - - /* Only record the parent's info */ - if (g_prof_pid == (int)getpid()) { - prof_dumpa(aTHX_ ptype, id); - PerlIO_flush(g_fp); - } - else - PL_perldb = 0; /* Do not debug the kid. */ - } -} - -#ifdef PL_NEEDED -# define defstash PL_defstash -#endif - -/* Counts overhead of prof_mark and extra XS call. */ -static void -test_time(pTHX_ clock_t *r, clock_t *u, clock_t *s) -{ - CV *cv = perl_get_cv("Devel::DProf::NONESUCH_noxs", FALSE); - int i, j, k = 0; - HV *oldstash = PL_curstash; - struct tms t1, t2; - clock_t realtime1, realtime2; - U32 ototal = g_total; - U32 ostack = g_SAVE_STACK; - U32 operldb = PL_perldb; - - g_SAVE_STACK = 1000000; - realtime1 = Times(&t1); - - while (k < 2) { - i = 0; - /* Disable debugging of perl_call_sv on second pass: */ - PL_curstash = (k == 0 ? PL_defstash : PL_debstash); - PL_perldb = g_default_perldb; - while (++i <= 100) { - j = 0; - g_profstack_ix = 0; /* Do not let the stack grow */ - while (++j <= 100) { -/* prof_mark(aTHX_ OP_ENTERSUB); */ - - PUSHMARK(PL_stack_sp); - perl_call_sv((SV*)cv, G_SCALAR); - PL_stack_sp--; -/* prof_mark(aTHX_ OP_LEAVESUB); */ - } - } - PL_curstash = oldstash; - if (k == 0) { /* Put time with debugging */ - realtime2 = Times(&t2); - *r = realtime2 - realtime1; - *u = t2.tms_utime - t1.tms_utime; - *s = t2.tms_stime - t1.tms_stime; - } - else { /* Subtract time without debug */ - realtime1 = Times(&t1); - *r -= realtime1 - realtime2; - *u -= t1.tms_utime - t2.tms_utime; - *s -= t1.tms_stime - t2.tms_stime; - } - k++; - } - g_total = ototal; - g_SAVE_STACK = ostack; - PL_perldb = operldb; -} - -static void -prof_recordheader(pTHX) -{ - clock_t r, u, s; - - /* g_fp is opened in the BOOT section */ - PerlIO_printf(g_fp, "#fOrTyTwO\n"); - PerlIO_printf(g_fp, "$hz=%"IVdf";\n", (IV)DPROF_HZ); - PerlIO_printf(g_fp, "$XS_VERSION='DProf %s';\n", XS_VERSION); - PerlIO_printf(g_fp, "# All values are given in HZ\n"); - test_time(aTHX_ &r, &u, &s); - PerlIO_printf(g_fp, - "$over_utime=%"IVdf"; $over_stime=%"IVdf"; $over_rtime=%"IVdf";\n", - /* The (IV) casts are one possibility: - * the Painfully Correct Way would be to - * have Clock_t_f. */ - (IV)u, (IV)s, (IV)r); - PerlIO_printf(g_fp, "$over_tests=10000;\n"); - - g_TIMES_LOCATION = PerlIO_tell(g_fp); - - /* Pad with whitespace. */ - /* This should be enough even for very large numbers. */ - PerlIO_printf(g_fp, "%*s\n", 240 , ""); - - PerlIO_printf(g_fp, "\n"); - PerlIO_printf(g_fp, "PART2\n"); - - PerlIO_flush(g_fp); -} - -static void -prof_record(pTHX) -{ - /* g_fp is opened in the BOOT section */ - - /* Now that we know the runtimes, fill them in at the recorded - location -JH */ - - if (g_SAVE_STACK) { - prof_dump_until(aTHX_ g_profstack_ix); - } - PerlIO_seek(g_fp, g_TIMES_LOCATION, SEEK_SET); - /* Write into reserved 240 bytes: */ - PerlIO_printf(g_fp, - "$rrun_utime=%"IVdf"; $rrun_stime=%"IVdf"; $rrun_rtime=%"IVdf";", - /* The (IV) casts are one possibility: - * the Painfully Correct Way would be to - * have Clock_t_f. */ - (IV)(g_prof_end.tms_utime-g_prof_start.tms_utime-g_wprof_u), - (IV)(g_prof_end.tms_stime-g_prof_start.tms_stime-g_wprof_s), - (IV)(g_rprof_end-g_rprof_start-g_wprof_r)); - PerlIO_printf(g_fp, "\n$total_marks=%"IVdf, (IV)g_total); - - PerlIO_close(g_fp); -} - -#define NONESUCH() - -static void -check_depth(pTHX_ void *foo) -{ - U32 need_depth = PTR2UV(foo); - if (need_depth != g_depth) { - if (need_depth > g_depth) { - warn("garbled call depth when profiling"); - } - else { - I32 marks = g_depth - need_depth; - -/* warn("Check_depth: got %d, expected %d\n", g_depth, need_depth); */ - while (marks--) { - prof_mark(aTHX_ OP_DIE); - } - g_depth = need_depth; - } - } -} - -#define for_real -#ifdef for_real - -XS(XS_DB_sub) -{ - dXSARGS; - dORIGMARK; - SV *Sub = GvSV(PL_DBsub); /* name of current sub */ - -#ifdef PERL_IMPLICIT_CONTEXT - /* profile only the interpreter that loaded us */ - if (g_THX != aTHX) { - PUSHMARK(ORIGMARK); - perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME | G_NODEBUG); - } - else -#endif - { - HV *oldstash = PL_curstash; - - DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub)); - - SAVEDESTRUCTOR_X(check_depth, (void*)g_depth); - g_depth++; - - prof_mark(aTHX_ OP_ENTERSUB); - PUSHMARK(ORIGMARK); - perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME | G_NODEBUG); - PL_curstash = oldstash; - prof_mark(aTHX_ OP_LEAVESUB); - g_depth--; - } - return; -} - -XS(XS_DB_goto) -{ -#ifdef PERL_IMPLICIT_CONTEXT - if (g_THX == aTHX) -#endif - { - prof_mark(aTHX_ OP_GOTO); - return; - } -} - -#endif /* for_real */ - -#ifdef testing - - MODULE = Devel::DProf PACKAGE = DB - - void - sub(...) - PPCODE: - { - dORIGMARK; - HV *oldstash = PL_curstash; - SV *Sub = GvSV(PL_DBsub); /* name of current sub */ - /* SP -= items; added by xsubpp */ - DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub)); - - sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */ - - prof_mark(aTHX_ OP_ENTERSUB); - PUSHMARK(ORIGMARK); - - PL_curstash = PL_debstash; /* To disable debugging of perl_call_sv */ - perl_call_sv(Sub, GIMME); - PL_curstash = oldstash; - - prof_mark(aTHX_ OP_LEAVESUB); - SPAGAIN; - /* PUTBACK; added by xsubpp */ - } - -#endif /* testing */ - -MODULE = Devel::DProf PACKAGE = Devel::DProf - -void -END() -PPCODE: - { - if (PL_DBsub) { - /* maybe the process forked--we want only - * the parent's profile. - */ - if ( -#ifdef PERL_IMPLICIT_CONTEXT - g_THX == aTHX && -#endif - g_prof_pid == (int)getpid()) - { - g_rprof_end = Times(&g_prof_end); - DBG_TIMER_NOTIFY("Profiler timer is off.\n"); - prof_record(aTHX); - } - } - } - -void -NONESUCH() - -BOOT: - { - g_TIMES_LOCATION = 42; - g_SAVE_STACK = 1<<14; - g_profstack_max = 128; -#ifdef PERL_IMPLICIT_CONTEXT - g_THX = aTHX; -#endif - - /* Before we go anywhere make sure we were invoked - * properly, else we'll dump core. - */ - if (!PL_DBsub) - croak("DProf: run perl with -d to use DProf.\n"); - - /* When we hook up the XS DB::sub we'll be redefining - * the DB::sub from the PM file. Turn off warnings - * while we do this. - */ - { - I32 warn_tmp = PL_dowarn; - PL_dowarn = 0; - newXS("DB::sub", XS_DB_sub, file); - newXS("DB::goto", XS_DB_goto, file); - PL_dowarn = warn_tmp; - } - - sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */ - - { - char *buffer = getenv("PERL_DPROF_BUFFER"); - - if (buffer) { - g_SAVE_STACK = atoi(buffer); - } - - buffer = getenv("PERL_DPROF_TICKS"); - - if (buffer) { - g_dprof_ticks = atoi(buffer); /* Used under OS/2 only */ - } - else { - g_dprof_ticks = HZ; - } - - buffer = getenv("PERL_DPROF_OUT_FILE_NAME"); - g_out_file_name = savepv(buffer ? buffer : "tmon.out"); - } - - if ((g_fp = PerlIO_open(g_out_file_name, "w")) == NULL) - croak("DProf: unable to write '%s', errno = %d\n", - g_out_file_name, errno); - - g_default_perldb = PERLDBf_NONAME | PERLDBf_SUB | PERLDBf_GOTO; - g_cv_hash = newHV(); - g_prof_pid = (int)getpid(); - - New(0, g_profstack, g_profstack_max, PROFANY); - prof_recordheader(aTHX); - DBG_TIMER_NOTIFY("Profiler timer is on.\n"); - g_orealtime = g_rprof_start = Times(&g_prof_start); - g_otms_utime = g_prof_start.tms_utime; - g_otms_stime = g_prof_start.tms_stime; - PL_perldb = g_default_perldb; - } diff --git a/contrib/perl5/ext/Devel/DProf/Makefile.PL b/contrib/perl5/ext/Devel/DProf/Makefile.PL deleted file mode 100644 index 667cc52..0000000 --- a/contrib/perl5/ext/Devel/DProf/Makefile.PL +++ /dev/null @@ -1,17 +0,0 @@ -use ExtUtils::MakeMaker; - -WriteMakefile( - NAME => 'Devel::DProf', - DISTNAME => 'DProf', - VERSION_FROM => 'DProf.pm', - clean => { 'FILES' => 'tmon.out t/tmon.out t/err'}, - XSPROTOARG => '-noprototypes', - DEFINE => '-DPERLDBf_NONAME=0x40 -DPERLDBf_GOTO=0x80 ' - .'-DG_NODEBUG=32 -DPL_NEEDED', - dist => { - COMPRESS => 'gzip -9f', - SUFFIX => 'gz', - DIST_DEFAULT => 'all tardist', - }, - MAN3PODS => {}, -); diff --git a/contrib/perl5/ext/Devel/DProf/Todo b/contrib/perl5/ext/Devel/DProf/Todo deleted file mode 100644 index 0e00347..0000000 --- a/contrib/perl5/ext/Devel/DProf/Todo +++ /dev/null @@ -1,13 +0,0 @@ -- work on test suite. -- localize the depth to guard against non-local exits. -Current overhead (with PERLDBf_NONAME) wrt non-debugging run (estimates): - 8% extra call frame on DB::sub - 7% output of subroutine data - 70% output of timing data (on OS/2, 35% with custom dprof_times()) -(Additional 17% are spent to write the output, but they are counted - and subtracted.) - -With compensation for DProf overhead all but some odd 12% are subtracted ?! - -- Calculate overhead/count for XS calls and Perl calls separately. -- goto &XSUB in pp_ctl.c; diff --git a/contrib/perl5/ext/Devel/Peek/Changes b/contrib/perl5/ext/Devel/Peek/Changes deleted file mode 100644 index e143f87..0000000 --- a/contrib/perl5/ext/Devel/Peek/Changes +++ /dev/null @@ -1,64 +0,0 @@ -0.3: Some functions return SV * now. -0.4: Hashes dumped recursively. - Additional fields for CV added. -0.5: Prototypes for functions supported. - Strings are consostently in quotes now. - Name changed to Devel::Peek (former ExtUtils::Peek). -0.7: - New function mstat added. - Docs added (thanks to Dean Roehrich). - -0.8: - Exports Dump and mstat. - Docs list more details. - Arrays print addresses of SV. - CV: STASH renamed to COMP_STASH. The package of GV is printed now. - Updated for newer overloading implementation (but will not report - packages with overloading). -0.81: - Implements and exports DeadCode(). - Buglet in the definition of mstat for malloc-less perl corrected. -0.82: - New style PADless CV allowed. -0.83: - DumpArray added. - Compatible with PerlIO. - When calculating junk inside subs, divide by refcount. -0.84: - Indented output. -0.85: - By Gisle Aas: format SvPVX, print magic (but not unrefcounted mg_obj); - A lot of new fields stolen from sv_dump(); -0.86: - By Gisle Aas: - - Updated the documentation. - - Move string printer to it's own function: fprintpv() - - Use it to print PVs, HV keys, MG_PTR - - Don't print IV for hashes as KEY is the same field - - Tag GvSTASH as "GvSTASH" in order to not confuse it with - the other STASH field, e.g. Dump(bless \*foo, "bar") -0.87: - Extra indentation of SvRV. - AMAGIC removed. - Head of OOK data printed too. -0.88: - PADLIST and OUTSIDE of CVs itemized. - Prints the value of the hash of HV keys. - Changes by Gisle: do not print both if AvARRAY == AvALLOC; - print hash fill statistics. -0.89: - Changes by Gisle: optree dump. -0.90: - DumpWithOP, DumpProg exported. - Better indent for AV, HV elts. - Address of SV printed. - Corrected Zero code which was causing segfaults. -0.91: - Compiles, runs test under 5.005beta2. - Update DEBUGGING_MSTATS-less MSTATS. -0.92: - Should compile without MYMALLOC too. -0.94: - Had problems with HEf_SVKEY magic. -0.95: - Added "hash quality" output to estimate Perl's hash functions. diff --git a/contrib/perl5/ext/Devel/Peek/Makefile.PL b/contrib/perl5/ext/Devel/Peek/Makefile.PL deleted file mode 100644 index f6d0cc9..0000000 --- a/contrib/perl5/ext/Devel/Peek/Makefile.PL +++ /dev/null @@ -1,12 +0,0 @@ -use ExtUtils::MakeMaker; -WriteMakefile( - NAME => "Devel::Peek", - VERSION_FROM => 'Peek.pm', - XSPROTOARG => '-noprototypes', - 'dist' => { - COMPRESS => 'gzip -9f', - SUFFIX => 'gz', - DIST_DEFAULT => 'all tardist', - }, - MAN3PODS => {}, -); diff --git a/contrib/perl5/ext/Devel/Peek/Peek.pm b/contrib/perl5/ext/Devel/Peek/Peek.pm deleted file mode 100644 index 0850172..0000000 --- a/contrib/perl5/ext/Devel/Peek/Peek.pm +++ /dev/null @@ -1,494 +0,0 @@ -# Devel::Peek - A data debugging tool for the XS programmer -# The documentation is after the __END__ - -package Devel::Peek; - -# Underscore to allow older Perls to access older version from CPAN -$VERSION = '1.00_01'; - -require Exporter; -use XSLoader (); - -@ISA = qw(Exporter); -@EXPORT = qw(Dump mstat DeadCode DumpArray DumpWithOP DumpProg - fill_mstats mstats_fillhash mstats2hash); -@EXPORT_OK = qw(SvREFCNT SvREFCNT_inc SvREFCNT_dec CvGV); -%EXPORT_TAGS = ('ALL' => [@EXPORT, @EXPORT_OK]); - -XSLoader::load 'Devel::Peek'; - -sub DumpWithOP ($;$) { - local($Devel::Peek::dump_ops)=1; - my $depth = @_ > 1 ? $_[1] : 4 ; - Dump($_[0],$depth); -} - -1; -__END__ - -=head1 NAME - -Devel::Peek - A data debugging tool for the XS programmer - -=head1 SYNOPSIS - - use Devel::Peek; - Dump( $a ); - Dump( $a, 5 ); - DumpArray( 5, $a, $b, ... ); - mstat "Point 5"; - -=head1 DESCRIPTION - -Devel::Peek contains functions which allows raw Perl datatypes to be -manipulated from a Perl script. This is used by those who do XS programming -to check that the data they are sending from C to Perl looks as they think -it should look. The trick, then, is to know what the raw datatype is -supposed to look like when it gets to Perl. This document offers some tips -and hints to describe good and bad raw data. - -It is very possible that this document will fall far short of being useful -to the casual reader. The reader is expected to understand the material in -the first few sections of L<perlguts>. - -Devel::Peek supplies a C<Dump()> function which can dump a raw Perl -datatype, and C<mstat("marker")> function to report on memory usage -(if perl is compiled with corresponding option). The function -DeadCode() provides statistics on the data "frozen" into inactive -C<CV>. Devel::Peek also supplies C<SvREFCNT()>, C<SvREFCNT_inc()>, and -C<SvREFCNT_dec()> which can query, increment, and decrement reference -counts on SVs. This document will take a passive, and safe, approach -to data debugging and for that it will describe only the C<Dump()> -function. - -Function C<DumpArray()> allows dumping of multiple values (useful when you -need to analyze returns of functions). - -The global variable $Devel::Peek::pv_limit can be set to limit the -number of character printed in various string values. Setting it to 0 -means no limit. - -=head2 Memory footprint debugging - -When perl is compiled with support for memory footprint debugging -(default with Perl's malloc()), Devel::Peek provides an access to this API. - -Use mstat() function to emit a memory state statistic to the terminal. -For more information on the format of output of mstat() see -L<perldebug/Using C<$ENV{PERL_DEBUG_MSTATS}>>. - -Three additional functions allow access to this statistic from Perl. -First, use C<mstats_fillhash(%hash)> to get the information contained -in the output of mstat() into %hash. The field of this hash are - - minbucket nbuckets sbrk_good sbrk_slack sbrked_remains sbrks start_slack - topbucket topbucket_ev topbucket_odd total total_chain total_sbrk totfree - -Two additional fields C<free>, C<used> contain array references which -provide per-bucket count of free and used chunks. Two other fields -C<mem_size>, C<available_size> contain array references which provide -the information about the allocated size and usable size of chunks in -each bucket. Again, see L<perldebug/Using C<$ENV{PERL_DEBUG_MSTATS}>> -for details. - -Keep in mind that only the first several "odd-numbered" buckets are -used, so the information on size of the "odd-numbered" buckets which are -not used is probably meaningless. - -The information in - - mem_size available_size minbucket nbuckets - -is the property of a particular build of perl, and does not depend on -the current process. If you do not provide the optional argument to -the functions mstats_fillhash(), fill_mstats(), mstats2hash(), then -the information in fields C<mem_size>, C<available_size> is not -updated. - -C<fill_mstats($buf)> is a much cheaper call (both speedwise and -memory-wise) which collects the statistic into $buf in -machine-readable form. At a later moment you may need to call -C<mstats2hash($buf, %hash)> to use this information to fill %hash. - -All three APIs C<fill_mstats($buf)>, C<mstats_fillhash(%hash)>, and -C<mstats2hash($buf, %hash)> are designed to allocate no memory if used -I<the second time> on the same $buf and/or %hash. - -So, if you want to collect memory info in a cycle, you may call - - $#buf = 999; - fill_mstats($_) for @buf; - mstats_fillhash(%report, 1); # Static info too - - foreach (@buf) { - # Do something... - fill_mstats $_; # Collect statistic - } - foreach (@buf) { - mstats2hash($_, %report); # Preserve static info - # Do something with %report - } - -=head1 EXAMPLES - -The following examples don't attempt to show everything as that would be a -monumental task, and, frankly, we don't want this manpage to be an internals -document for Perl. The examples do demonstrate some basics of the raw Perl -datatypes, and should suffice to get most determined people on their way. -There are no guidewires or safety nets, nor blazed trails, so be prepared to -travel alone from this point and on and, if at all possible, don't fall into -the quicksand (it's bad for business). - -Oh, one final bit of advice: take L<perlguts> with you. When you return we -expect to see it well-thumbed. - -=head2 A simple scalar string - -Let's begin by looking a simple scalar which is holding a string. - - use Devel::Peek; - $a = "hello"; - Dump $a; - -The output: - - SV = PVIV(0xbc288) - REFCNT = 1 - FLAGS = (POK,pPOK) - IV = 0 - PV = 0xb2048 "hello"\0 - CUR = 5 - LEN = 6 - -This says C<$a> is an SV, a scalar. The scalar is a PVIV, a string. -Its reference count is 1. It has the C<POK> flag set, meaning its -current PV field is valid. Because POK is set we look at the PV item -to see what is in the scalar. The \0 at the end indicate that this -PV is properly NUL-terminated. -If the FLAGS had been IOK we would look -at the IV item. CUR indicates the number of characters in the PV. -LEN indicates the number of bytes requested for the PV (one more than -CUR, in this case, because LEN includes an extra byte for the -end-of-string marker). - -=head2 A simple scalar number - -If the scalar contains a number the raw SV will be leaner. - - use Devel::Peek; - $a = 42; - Dump $a; - -The output: - - SV = IV(0xbc818) - REFCNT = 1 - FLAGS = (IOK,pIOK) - IV = 42 - -This says C<$a> is an SV, a scalar. The scalar is an IV, a number. Its -reference count is 1. It has the C<IOK> flag set, meaning it is currently -being evaluated as a number. Because IOK is set we look at the IV item to -see what is in the scalar. - -=head2 A simple scalar with an extra reference - -If the scalar from the previous example had an extra reference: - - use Devel::Peek; - $a = 42; - $b = \$a; - Dump $a; - -The output: - - SV = IV(0xbe860) - REFCNT = 2 - FLAGS = (IOK,pIOK) - IV = 42 - -Notice that this example differs from the previous example only in its -reference count. Compare this to the next example, where we dump C<$b> -instead of C<$a>. - -=head2 A reference to a simple scalar - -This shows what a reference looks like when it references a simple scalar. - - use Devel::Peek; - $a = 42; - $b = \$a; - Dump $b; - -The output: - - SV = RV(0xf041c) - REFCNT = 1 - FLAGS = (ROK) - RV = 0xbab08 - SV = IV(0xbe860) - REFCNT = 2 - FLAGS = (IOK,pIOK) - IV = 42 - -Starting from the top, this says C<$b> is an SV. The scalar is an RV, a -reference. It has the C<ROK> flag set, meaning it is a reference. Because -ROK is set we have an RV item rather than an IV or PV. Notice that Dump -follows the reference and shows us what C<$b> was referencing. We see the -same C<$a> that we found in the previous example. - -Note that the value of C<RV> coincides with the numbers we see when we -stringify $b. The addresses inside RV() and IV() are addresses of -C<X***> structure which holds the current state of an C<SV>. This -address may change during lifetime of an SV. - -=head2 A reference to an array - -This shows what a reference to an array looks like. - - use Devel::Peek; - $a = [42]; - Dump $a; - -The output: - - SV = RV(0xf041c) - REFCNT = 1 - FLAGS = (ROK) - RV = 0xb2850 - SV = PVAV(0xbd448) - REFCNT = 1 - FLAGS = () - IV = 0 - NV = 0 - ARRAY = 0xb2048 - ALLOC = 0xb2048 - FILL = 0 - MAX = 0 - ARYLEN = 0x0 - FLAGS = (REAL) - Elt No. 0 0xb5658 - SV = IV(0xbe860) - REFCNT = 1 - FLAGS = (IOK,pIOK) - IV = 42 - -This says C<$a> is an SV and that it is an RV. That RV points to -another SV which is a PVAV, an array. The array has one element, -element zero, which is another SV. The field C<FILL> above indicates -the last element in the array, similar to C<$#$a>. - -If C<$a> pointed to an array of two elements then we would see the -following. - - use Devel::Peek 'Dump'; - $a = [42,24]; - Dump $a; - -The output: - - SV = RV(0xf041c) - REFCNT = 1 - FLAGS = (ROK) - RV = 0xb2850 - SV = PVAV(0xbd448) - REFCNT = 1 - FLAGS = () - IV = 0 - NV = 0 - ARRAY = 0xb2048 - ALLOC = 0xb2048 - FILL = 0 - MAX = 0 - ARYLEN = 0x0 - FLAGS = (REAL) - Elt No. 0 0xb5658 - SV = IV(0xbe860) - REFCNT = 1 - FLAGS = (IOK,pIOK) - IV = 42 - Elt No. 1 0xb5680 - SV = IV(0xbe818) - REFCNT = 1 - FLAGS = (IOK,pIOK) - IV = 24 - -Note that C<Dump> will not report I<all> the elements in the array, -only several first (depending on how deep it already went into the -report tree). - -=head2 A reference to a hash - -The following shows the raw form of a reference to a hash. - - use Devel::Peek; - $a = {hello=>42}; - Dump $a; - -The output: - - SV = RV(0xf041c) - REFCNT = 1 - FLAGS = (ROK) - RV = 0xb2850 - SV = PVHV(0xbd448) - REFCNT = 1 - FLAGS = () - NV = 0 - ARRAY = 0xbd748 - KEYS = 1 - FILL = 1 - MAX = 7 - RITER = -1 - EITER = 0x0 - Elt "hello" => 0xbaaf0 - SV = IV(0xbe860) - REFCNT = 1 - FLAGS = (IOK,pIOK) - IV = 42 - -This shows C<$a> is a reference pointing to an SV. That SV is a PVHV, a -hash. Fields RITER and EITER are used by C<L<each>>. - -=head2 Dumping a large array or hash - -The C<Dump()> function, by default, dumps up to 4 elements from a -toplevel array or hash. This number can be increased by supplying a -second argument to the function. - - use Devel::Peek; - $a = [10,11,12,13,14]; - Dump $a; - -Notice that C<Dump()> prints only elements 10 through 13 in the above code. -The following code will print all of the elements. - - use Devel::Peek 'Dump'; - $a = [10,11,12,13,14]; - Dump $a, 5; - -=head2 A reference to an SV which holds a C pointer - -This is what you really need to know as an XS programmer, of course. When -an XSUB returns a pointer to a C structure that pointer is stored in an SV -and a reference to that SV is placed on the XSUB stack. So the output from -an XSUB which uses something like the T_PTROBJ map might look something like -this: - - SV = RV(0xf381c) - REFCNT = 1 - FLAGS = (ROK) - RV = 0xb8ad8 - SV = PVMG(0xbb3c8) - REFCNT = 1 - FLAGS = (OBJECT,IOK,pIOK) - IV = 729160 - NV = 0 - PV = 0 - STASH = 0xc1d10 "CookBookB::Opaque" - -This shows that we have an SV which is an RV. That RV points at another -SV. In this case that second SV is a PVMG, a blessed scalar. Because it is -blessed it has the C<OBJECT> flag set. Note that an SV which holds a C -pointer also has the C<IOK> flag set. The C<STASH> is set to the package -name which this SV was blessed into. - -The output from an XSUB which uses something like the T_PTRREF map, which -doesn't bless the object, might look something like this: - - SV = RV(0xf381c) - REFCNT = 1 - FLAGS = (ROK) - RV = 0xb8ad8 - SV = PVMG(0xbb3c8) - REFCNT = 1 - FLAGS = (IOK,pIOK) - IV = 729160 - NV = 0 - PV = 0 - -=head2 A reference to a subroutine - -Looks like this: - - SV = RV(0x798ec) - REFCNT = 1 - FLAGS = (TEMP,ROK) - RV = 0x1d453c - SV = PVCV(0x1c768c) - REFCNT = 2 - FLAGS = () - IV = 0 - NV = 0 - COMP_STASH = 0x31068 "main" - START = 0xb20e0 - ROOT = 0xbece0 - XSUB = 0x0 - XSUBANY = 0 - GVGV::GV = 0x1d44e8 "MY" :: "top_targets" - FILE = "(eval 5)" - DEPTH = 0 - PADLIST = 0x1c9338 - -This shows that - -=over - -=item * - -the subroutine is not an XSUB (since C<START> and C<ROOT> are -non-zero, and C<XSUB> is zero); - -=item * - -that it was compiled in the package C<main>; - -=item * - -under the name C<MY::top_targets>; - -=item * - -inside a 5th eval in the program; - -=item * - -it is not currently executed (see C<DEPTH>); - -=item * - -it has no prototype (C<PROTOTYPE> field is missing). - -=back - -=head1 EXPORTS - -C<Dump>, C<mstat>, C<DeadCode>, C<DumpArray>, C<DumpWithOP> and -C<DumpProg>, C<fill_mstats>, C<mstats_fillhash>, C<mstats2hash> by -default. Additionally available C<SvREFCNT>, C<SvREFCNT_inc> and -C<SvREFCNT_dec>. - -=head1 BUGS - -Readers have been known to skip important parts of L<perlguts>, causing much -frustration for all. - -=head1 AUTHOR - -Ilya Zakharevich ilya@math.ohio-state.edu - -Copyright (c) 1995-98 Ilya Zakharevich. All rights reserved. -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -Author of this software makes no claim whatsoever about suitability, -reliability, edability, editability or usability of this product, and -should not be kept liable for any damage resulting from the use of -it. If you can use it, you are in luck, if not, I should not be kept -responsible. Keep a handy copy of your backup tape at hand. - -=head1 SEE ALSO - -L<perlguts>, and L<perlguts>, again. - -=cut diff --git a/contrib/perl5/ext/Devel/Peek/Peek.xs b/contrib/perl5/ext/Devel/Peek/Peek.xs deleted file mode 100644 index 1e48149..0000000 --- a/contrib/perl5/ext/Devel/Peek/Peek.xs +++ /dev/null @@ -1,404 +0,0 @@ -#define PERL_NO_GET_CONTEXT -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -SV * -DeadCode(pTHX) -{ -#ifdef PURIFY - return Nullsv; -#else - SV* sva; - SV* sv, *dbg; - SV* ret = newRV_noinc((SV*)newAV()); - register SV* svend; - int tm = 0, tref = 0, ts = 0, ta = 0, tas = 0; - - for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { - svend = &sva[SvREFCNT(sva)]; - for (sv = sva + 1; sv < svend; ++sv) { - if (SvTYPE(sv) == SVt_PVCV) { - CV *cv = (CV*)sv; - AV* padlist = CvPADLIST(cv), *argav; - SV** svp; - SV** pad; - int i = 0, j, levelm, totm = 0, levelref, totref = 0; - int levels, tots = 0, levela, tota = 0, levelas, totas = 0; - int dumpit = 0; - - if (CvXSUB(sv)) { - continue; /* XSUB */ - } - if (!CvGV(sv)) { - continue; /* file-level scope. */ - } - if (!CvROOT(cv)) { - /* PerlIO_printf(Perl_debug_log, " no root?!\n"); */ - continue; /* autoloading stub. */ - } - do_gvgv_dump(0, Perl_debug_log, "GVGV::GV", CvGV(sv)); - if (CvDEPTH(cv)) { - PerlIO_printf(Perl_debug_log, " busy\n"); - continue; - } - svp = AvARRAY(padlist); - while (++i <= AvFILL(padlist)) { /* Depth. */ - SV **args; - - pad = AvARRAY((AV*)svp[i]); - argav = (AV*)pad[0]; - if (!argav || (SV*)argav == &PL_sv_undef) { - PerlIO_printf(Perl_debug_log, " closure-template\n"); - continue; - } - args = AvARRAY(argav); - levelm = levels = levelref = levelas = 0; - levela = sizeof(SV*) * (AvMAX(argav) + 1); - if (AvREAL(argav)) { - for (j = 0; j < AvFILL(argav); j++) { - if (SvROK(args[j])) { - PerlIO_printf(Perl_debug_log, " ref in args!\n"); - levelref++; - } - /* else if (SvPOK(args[j]) && SvPVX(args[j])) { */ - else if (SvTYPE(args[j]) >= SVt_PV && SvLEN(args[j])) { - levelas += SvLEN(args[j])/SvREFCNT(args[j]); - } - } - } - for (j = 1; j < AvFILL((AV*)svp[1]); j++) { /* Vars. */ - if (SvROK(pad[j])) { - levelref++; - do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0); - dumpit = 1; - } - /* else if (SvPOK(pad[j]) && SvPVX(pad[j])) { */ - else if (SvTYPE(pad[j]) >= SVt_PVAV) { - if (!SvPADMY(pad[j])) { - levelref++; - do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0); - dumpit = 1; - } - } - else if (SvTYPE(pad[j]) >= SVt_PV && SvLEN(pad[j])) { - levels++; - levelm += SvLEN(pad[j])/SvREFCNT(pad[j]); - /* Dump(pad[j],4); */ - } - } - PerlIO_printf(Perl_debug_log, " level %i: refs: %i, strings: %i in %i,\targsarray: %i, argsstrings: %i\n", - i, levelref, levelm, levels, levela, levelas); - totm += levelm; - tota += levela; - totas += levelas; - tots += levels; - totref += levelref; - if (dumpit) - do_sv_dump(0, Perl_debug_log, (SV*)cv, 0, 2, 0, 0); - } - if (AvFILL(padlist) > 1) { - PerlIO_printf(Perl_debug_log, " total: refs: %i, strings: %i in %i,\targsarrays: %i, argsstrings: %i\n", - totref, totm, tots, tota, totas); - } - tref += totref; - tm += totm; - ts += tots; - ta += tota; - tas += totas; - } - } - } - PerlIO_printf(Perl_debug_log, "total: refs: %i, strings: %i in %i\targsarray: %i, argsstrings: %i\n", tref, tm, ts, ta, tas); - - return ret; -#endif /* !PURIFY */ -} - -#if defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS) \ - || (defined(MYMALLOC) && !defined(PLAIN_MALLOC)) -# define mstat(str) dump_mstats(str) -#else -# define mstat(str) \ - PerlIO_printf(Perl_debug_log, "%s: perl not compiled with DEBUGGING_MSTATS\n",str); -#endif - -#if defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS) \ - || (defined(MYMALLOC) && !defined(PLAIN_MALLOC)) - -/* Very coarse overestimate, 2-per-power-of-2, one more to determine NBUCKETS. */ -# define _NBUCKETS (2*8*IVSIZE+1) - -struct mstats_buffer -{ - perl_mstats_t buffer; - UV buf[_NBUCKETS*4]; -}; - -void -_fill_mstats(struct mstats_buffer *b, int level) -{ - dTHX; - b->buffer.nfree = b->buf; - b->buffer.ntotal = b->buf + _NBUCKETS; - b->buffer.bucket_mem_size = b->buf + 2*_NBUCKETS; - b->buffer.bucket_available_size = b->buf + 3*_NBUCKETS; - Zero(b->buf, (level ? 4*_NBUCKETS: 2*_NBUCKETS), unsigned long); - get_mstats(&(b->buffer), _NBUCKETS, level); -} - -void -fill_mstats(SV *sv, int level) -{ - dTHX; - int nbuckets; - struct mstats_buffer buf; - - if (SvREADONLY(sv)) - croak("Cannot modify a readonly value"); - SvGROW(sv, sizeof(struct mstats_buffer)+1); - _fill_mstats((struct mstats_buffer*)SvPVX(sv),level); - SvCUR_set(sv, sizeof(struct mstats_buffer)); - *SvEND(sv) = '\0'; - SvPOK_only(sv); -} - -void -_mstats_to_hv(HV *hv, struct mstats_buffer *b, int level) -{ - dTHX; - SV **svp; - int type; - - svp = hv_fetch(hv, "topbucket", 9, 1); - sv_setiv(*svp, b->buffer.topbucket); - - svp = hv_fetch(hv, "topbucket_ev", 12, 1); - sv_setiv(*svp, b->buffer.topbucket_ev); - - svp = hv_fetch(hv, "topbucket_odd", 13, 1); - sv_setiv(*svp, b->buffer.topbucket_odd); - - svp = hv_fetch(hv, "totfree", 7, 1); - sv_setiv(*svp, b->buffer.totfree); - - svp = hv_fetch(hv, "total", 5, 1); - sv_setiv(*svp, b->buffer.total); - - svp = hv_fetch(hv, "total_chain", 11, 1); - sv_setiv(*svp, b->buffer.total_chain); - - svp = hv_fetch(hv, "total_sbrk", 10, 1); - sv_setiv(*svp, b->buffer.total_sbrk); - - svp = hv_fetch(hv, "sbrks", 5, 1); - sv_setiv(*svp, b->buffer.sbrks); - - svp = hv_fetch(hv, "sbrk_good", 9, 1); - sv_setiv(*svp, b->buffer.sbrk_good); - - svp = hv_fetch(hv, "sbrk_slack", 10, 1); - sv_setiv(*svp, b->buffer.sbrk_slack); - - svp = hv_fetch(hv, "start_slack", 11, 1); - sv_setiv(*svp, b->buffer.start_slack); - - svp = hv_fetch(hv, "sbrked_remains", 14, 1); - sv_setiv(*svp, b->buffer.sbrked_remains); - - svp = hv_fetch(hv, "minbucket", 9, 1); - sv_setiv(*svp, b->buffer.minbucket); - - svp = hv_fetch(hv, "nbuckets", 8, 1); - sv_setiv(*svp, b->buffer.nbuckets); - - if (_NBUCKETS < b->buffer.nbuckets) - warn("FIXME: internal mstats buffer too short"); - - for (type = 0; type < (level ? 4 : 2); type++) { - UV *p, *p1; - AV *av; - int i; - static const char *types[4] = { - "free", "used", "mem_size", "available_size" - }; - - svp = hv_fetch(hv, types[type], strlen(types[type]), 1); - - if (SvOK(*svp) && !(SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV)) - croak("Unexpected value for the key '%s' in the mstats hash", types[type]); - if (!SvOK(*svp)) { - av = newAV(); - SvUPGRADE(*svp, SVt_RV); - SvRV(*svp) = (SV*)av; - SvROK_on(*svp); - } else - av = (AV*)SvRV(*svp); - - av_extend(av, b->buffer.nbuckets - 1); - /* XXXX What is the official way to reduce the size of the array? */ - switch (type) { - case 0: - p = b->buffer.nfree; - break; - case 1: - p = b->buffer.ntotal; - p1 = b->buffer.nfree; - break; - case 2: - p = b->buffer.bucket_mem_size; - break; - case 3: - p = b->buffer.bucket_available_size; - break; - } - for (i = 0; i < b->buffer.nbuckets; i++) { - svp = av_fetch(av, i, 1); - if (type == 1) - sv_setiv(*svp, p[i]-p1[i]); - else - sv_setuv(*svp, p[i]); - } - } -} -void -mstats_fillhash(SV *sv, int level) -{ - struct mstats_buffer buf; - - if (!(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV)) - croak("Not a hash reference"); - _fill_mstats(&buf, level); - _mstats_to_hv((HV *)SvRV(sv), &buf, level); -} -void -mstats2hash(SV *sv, SV *rv, int level) -{ - if (!(SvROK(rv) && SvTYPE(SvRV(rv)) == SVt_PVHV)) - croak("Not a hash reference"); - if (!SvPOK(sv)) - croak("Undefined value when expecting mstats buffer"); - if (SvCUR(sv) != sizeof(struct mstats_buffer)) - croak("Wrong size for a value with a mstats buffer"); - _mstats_to_hv((HV *)SvRV(rv), (struct mstats_buffer*)SvPVX(sv), level); -} -#else /* !( defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS) \ ) */ -void -fill_mstats(SV *sv, int level) -{ - croak("Cannot report mstats without Perl malloc"); -} -void -mstats_fillhash(SV *sv, int level) -{ - croak("Cannot report mstats without Perl malloc"); -} -void -mstats2hash(SV *sv, SV *rv, int level) -{ - croak("Cannot report mstats without Perl malloc"); -} -#endif /* defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS)... */ - -#define _CvGV(cv) \ - (SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV) \ - ? SvREFCNT_inc(CvGV((CV*)SvRV(cv))) : &PL_sv_undef) - -MODULE = Devel::Peek PACKAGE = Devel::Peek - -void -mstat(str="Devel::Peek::mstat: ") -char *str - -void -fill_mstats(SV *sv, int level = 0) - -void -mstats_fillhash(SV *sv, int level = 0) - PROTOTYPE: \%;$ - -void -mstats2hash(SV *sv, SV *rv, int level = 0) - PROTOTYPE: $\%;$ - -void -Dump(sv,lim=4) -SV * sv -I32 lim -PPCODE: -{ - SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", FALSE); - STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0; - SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", FALSE); - I32 save_dumpindent = PL_dumpindent; - PL_dumpindent = 2; - do_sv_dump(0, Perl_debug_log, sv, 0, lim, dumpop && SvTRUE(dumpop), pv_lim); - PL_dumpindent = save_dumpindent; -} - -void -DumpArray(lim,...) -I32 lim -PPCODE: -{ - long i; - SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", FALSE); - STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0; - SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", FALSE); - I32 save_dumpindent = PL_dumpindent; - PL_dumpindent = 2; - - for (i=1; i<items; i++) { - PerlIO_printf(Perl_debug_log, "Elt No. %ld 0x%"UVxf"\n", i - 1, PTR2UV(ST(i))); - do_sv_dump(0, Perl_debug_log, ST(i), 0, lim, dumpop && SvTRUE(dumpop), pv_lim); - } - PL_dumpindent = save_dumpindent; -} - -void -DumpProg() -PPCODE: -{ - warn("dumpindent is %d", (int)PL_dumpindent); - if (PL_main_root) - op_dump(PL_main_root); -} - -I32 -SvREFCNT(sv) -SV * sv - -# PPCODE needed since otherwise sv_2mortal is inserted that will kill the value. - -SV * -SvREFCNT_inc(sv) -SV * sv -PPCODE: -{ - RETVAL = SvREFCNT_inc(sv); - PUSHs(RETVAL); -} - -# PPCODE needed since by default it is void - -void -SvREFCNT_dec(sv) -SV * sv -PPCODE: -{ - SvREFCNT_dec(sv); - PUSHs(sv); -} - -SV * -DeadCode() -CODE: - RETVAL = DeadCode(aTHX); -OUTPUT: - RETVAL - -MODULE = Devel::Peek PACKAGE = Devel::Peek PREFIX = _ - -SV * -_CvGV(cv) - SV *cv diff --git a/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL b/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL deleted file mode 100644 index 266c9d0..0000000 --- a/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL +++ /dev/null @@ -1,894 +0,0 @@ -use Config; - -sub to_string { - my ($value) = @_; - $value =~ s/\\/\\\\/g; - $value =~ s/'/\\'/g; - return "'$value'"; -} - -unlink "DynaLoader.pm" if -f "DynaLoader.pm"; -open OUT, ">DynaLoader.pm" or die $!; -print OUT <<'EOT'; - -# Generated from DynaLoader.pm.PL - -package DynaLoader; - -# And Gandalf said: 'Many folk like to know beforehand what is to -# be set on the table; but those who have laboured to prepare the -# feast like to keep their secret; for wonder makes the words of -# praise louder.' - -# (Quote from Tolkien suggested by Anno Siegel.) -# -# See pod text at end of file for documentation. -# See also ext/DynaLoader/README in source tree for other information. -# -# Tim.Bunce@ig.co.uk, August 1994 - -use vars qw($VERSION *AUTOLOAD); - -$VERSION = 1.04; # avoid typo warning - -require AutoLoader; -*AUTOLOAD = \&AutoLoader::AUTOLOAD; - -use Config; - -# The following require can't be removed during maintenance -# releases, sadly, because of the risk of buggy code that does -# require Carp; Carp::croak "..."; without brackets dying -# if Carp hasn't been loaded in earlier compile time. :-( -# We'll let those bugs get found on the development track. -require Carp if $] < 5.00450; - -# enable debug/trace messages from DynaLoader perl code -$dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; - -# -# Flags to alter dl_load_file behaviour. Assigned bits: -# 0x01 make symbols available for linking later dl_load_file's. -# (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL)) -# (ignored under VMS; effect is built-in to image linking) -# -# This is called as a class method $module->dl_load_flags. The -# definition here will be inherited and result on "default" loading -# behaviour unless a sub-class of DynaLoader defines its own version. -# - -sub dl_load_flags { 0x00 } - -# ($dl_dlext, $dlsrc) -# = @Config::Config{'dlext', 'dlsrc'}; -EOT - -print OUT " (\$dl_dlext, \$dlsrc) = (", - to_string($Config::Config{'dlext'}), ",", - to_string($Config::Config{'dlsrc'}), ")\n;" ; - -print OUT <<'EOT'; - -# Some systems need special handling to expand file specifications -# (VMS support by Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>) -# See dl_expandspec() for more details. Should be harmless but -# inefficient to define on systems that don't need it. -$Is_VMS = $^O eq 'VMS'; -$do_expand = $Is_VMS; -$Is_MacOS = $^O eq 'MacOS'; - -@dl_require_symbols = (); # names of symbols we need -@dl_resolve_using = (); # names of files to link with -@dl_library_path = (); # path to look for files -@dl_librefs = (); # things we have loaded -@dl_modules = (); # Modules we have loaded - -# This is a fix to support DLD's unfortunate desire to relink -lc -@dl_resolve_using = dl_findfile('-lc') if $dlsrc eq "dl_dld.xs"; - -EOT - -my $cfg_dl_library_path = <<'EOT'; -push(@dl_library_path, split(' ', $Config::Config{libpth})); -EOT - -sub dquoted_comma_list { - join(", ", map {qq("$_")} @_); -} - -if ($ENV{PERL_BUILD_EXPAND_CONFIG_VARS}) { - eval $cfg_dl_library_path; - if (!$ENV{PERL_BUILD_EXPAND_ENV_VARS}) { - my $dl_library_path = dquoted_comma_list(@dl_library_path); - print OUT <<EOT; -# The below \@dl_library_path has been expanded (%Config) in Perl build time. - -\@dl_library_path = ($dl_library_path); - -EOT - } -} -else { - print OUT <<EOT; -# Initialise \@dl_library_path with the 'standard' library path -# for this platform as determined by Configure. - -$cfg_dl_library_path - -EOT -} - -my $ldlibpthname; -my $ldlibpthname_defined; -my $pthsep; - -if ($ENV{PERL_BUILD_EXPAND_CONFIG_VARS}) { - $ldlibpthname = $Config::Config{ldlibpthname}; - $ldlibpthname_defined = defined $Config::Config{ldlibpthname} ? 1 : 0; - $pthsep = $Config::Config{path_sep}; -} -else { - $ldlibpthname = q($Config::Config{ldlibpthname}); - $ldlibpthname_defined = q(defined $Config::Config{ldlibpthname}); - $pthsep = q($Config::Config{path_sep}); - print OUT <<EOT; -my \$ldlibpthname = $ldlibpthname; -my \$ldlibpthname_defined = $ldlibpthname_defined; -my \$pthsep = $pthsep; - -EOT -} - -my $env_dl_library_path = <<'EOT'; -if ($ldlibpthname_defined && - exists $ENV{$ldlibpthname}) { - push(@dl_library_path, split(/$pthsep/, $ENV{$ldlibpthname})); -} - -# E.g. HP-UX supports both its native SHLIB_PATH *and* LD_LIBRARY_PATH. - -if ($ldlibpthname_defined && - $ldlibpthname ne 'LD_LIBRARY_PATH' && - exists $ENV{LD_LIBRARY_PATH}) { - push(@dl_library_path, split(/$pthsep/, $ENV{LD_LIBRARY_PATH})); -} -EOT - -if ($ENV{PERL_BUILD_EXPAND_CONFIG_VARS} && $ENV{PERL_BUILD_EXPAND_ENV_VARS}) { - eval $env_dl_library_path; -} -else { - print OUT <<EOT; -# Add to \@dl_library_path any extra directories we can gather from environment -# during runtime. - -$env_dl_library_path - -EOT -} - -if ($ENV{PERL_BUILD_EXPAND_CONFIG_VARS} && $ENV{PERL_BUILD_EXPAND_ENV_VARS}) { - my $dl_library_path = dquoted_comma_list(@dl_library_path); - print OUT <<EOT; -# The below \@dl_library_path has been expanded (%Config, %ENV) -# in Perl build time. - -\@dl_library_path = ($dl_library_path); - -EOT -} - -print OUT <<'EOT'; -# 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_error); - -if ($dl_debug) { - print STDERR "DynaLoader.pm loaded (@INC, @dl_library_path)\n"; - print STDERR "DynaLoader not linked into this perl\n" - unless defined(&boot_DynaLoader); -} - -1; # End of main code - - -sub croak { require Carp; Carp::croak(@_) } - -sub bootstrap_inherit { - my $module = $_[0]; - local *isa = *{"$module\::ISA"}; - local @isa = (@isa, 'DynaLoader'); - # Cannot goto due to delocalization. Will report errors on a wrong line? - bootstrap(@_); -} - -# The bootstrap function cannot be autoloaded (without complications) -# so we define it here: - -sub bootstrap { - # use local vars to enable $module.bs script to edit values - local(@args) = @_; - local($module) = $args[0]; - local(@dirs, $file); - - unless ($module) { - require Carp; - Carp::confess("Usage: DynaLoader::bootstrap(module)"); - } - - # A common error on platforms which don't support dynamic loading. - # Since it's fatal and potentially confusing we give a detailed message. - croak("Can't load module $module, dynamic loading not available in this perl.\n". - " (You may need to build a new perl executable which either supports\n". - " dynamic loading or has the $module module statically linked into it.)\n") - unless defined(&dl_load_file); - - my @modparts = split(/::/,$module); - my $modfname = $modparts[-1]; - - # Some systems have restrictions on files names for DLL's etc. - # mod2fname returns appropriate file base name (typically truncated) - # It may also edit @modparts if required. - $modfname = &mod2fname(\@modparts) if defined &mod2fname; - - my $modpname = join(($Is_MacOS ? ':' : '/'),@modparts); - - print STDERR "DynaLoader::bootstrap for $module ", - ($Is_MacOS - ? "(:auto:$modpname:$modfname.$dl_dlext)\n" : - "(auto/$modpname/$modfname.$dl_dlext)\n") - if $dl_debug; - - foreach (@INC) { - chop($_ = VMS::Filespec::unixpath($_)) if $Is_VMS; - my $dir; - if ($Is_MacOS) { - chop $_ if /:$/; - $dir = "$_:auto:$modpname"; - } else { - $dir = "$_/auto/$modpname"; - } - next unless -d $dir; # skip over uninteresting directories - - # check for common cases to avoid autoload of dl_findfile - my $try = $Is_MacOS ? "$dir:$modfname.$dl_dlext" : "$dir/$modfname.$dl_dlext"; - last if $file = ($do_expand) ? dl_expandspec($try) : (-f $try && $try); - - # no luck here, save dir for possible later dl_findfile search - push @dirs, $dir; - } - # last resort, let dl_findfile have a go in all known locations - $file = dl_findfile(map("-L$_",@dirs,@INC), $modfname) unless $file; - - croak("Can't locate loadable object for module $module in \@INC (\@INC contains: @INC)") - unless $file; # wording similar to error from 'require' - - $file = uc($file) if $Is_VMS && $Config::Config{d_vms_case_sensitive_symbols}; - my $bootname = "boot_$module"; - $bootname =~ s/\W/_/g; - @dl_require_symbols = ($bootname); - - # Execute optional '.bootstrap' perl script for this module. - # The .bs file can be used to configure @dl_resolve_using etc to - # match the needs of the individual module on this architecture. - my $bs = $file; - $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library - if (-s $bs) { # only read file if it's not empty - print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug; - eval { do $bs; }; - warn "$bs: $@\n" if $@; - } - - # Many dynamic extension loading problems will appear to come from - # this section of code: XYZ failed at line 123 of DynaLoader.pm. - # Often these errors are actually occurring in the initialisation - # C code of the extension XS file. Perl reports the error as being - # in this perl code simply because this was the last perl code - # it executed. - - my $libref = dl_load_file($file, $module->dl_load_flags) or - croak("Can't load '$file' for module $module: ".dl_error()); - - push(@dl_librefs,$libref); # record loaded object - - my @unresolved = dl_undef_symbols(); - if (@unresolved) { - require Carp; - Carp::carp("Undefined symbols present after loading $file: @unresolved\n"); - } - - my $boot_symbol_ref = dl_find_symbol($libref, $bootname) or - croak("Can't find '$bootname' symbol in $file\n"); - - my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file); - - push(@dl_modules, $module); # record loaded module - - # See comment block above - &$xs(@args); -} - - -#sub _check_file { # private utility to handle dl_expandspec vs -f tests -# my($file) = @_; -# return $file if (!$do_expand && -f $file); # the common case -# return $file if ( $do_expand && ($file=dl_expandspec($file))); -# return undef; -#} - - -# Let autosplit and the autoloader deal with these functions: -__END__ - - -sub dl_findfile { - # Read ext/DynaLoader/DynaLoader.doc for detailed information. - # This function does not automatically consider the architecture - # or the perl library auto directories. - my (@args) = @_; - my (@dirs, $dir); # which directories to search - my (@found); # full paths to real files we have found -EOT - -print OUT ' my $dl_ext= ' . to_string($Config::Config{'dlext'}) . - "; # \$Config::Config{'dlext'} suffix for perl extensions\n"; -print OUT ' my $dl_so = ' . to_string($Config::Config{'so'}) . - "; # \$Config::Config{'so'} suffix for shared libraries\n"; - -print OUT <<'EOT'; - - print STDERR "dl_findfile(@args)\n" if $dl_debug; - - # accumulate directories but process files as they appear - arg: foreach(@args) { - # Special fast case: full filepath requires no search - if ($Is_VMS && m%[:>/\]]% && -f $_) { - push(@found,dl_expandspec(VMS::Filespec::vmsify($_))); - last arg unless wantarray; - next; - } - elsif ($Is_MacOS) { - if (m/:/ && -f $_) { - push(@found,$_); - last arg unless wantarray; - } - } - elsif (m:/: && -f $_ && !$do_expand) { - push(@found,$_); - last arg unless wantarray; - next; - } - - # Deal with directories first: - # Using a -L prefix is the preferred option (faster and more robust) - if (m:^-L:) { s/^-L//; push(@dirs, $_); next; } - - if ($Is_MacOS) { - # Otherwise we try to try to spot directories by a heuristic - # (this is a more complicated issue than it first appears) - if (m/:/ && -d $_) { push(@dirs, $_); next; } - # Only files should get this far... - my(@names, $name); # what filenames to look for - s/^-l//; - push(@names, $_); - foreach $dir (@dirs, @dl_library_path) { - next unless -d $dir; - $dir =~ s/^([^:]+)$/:$1/; - $dir =~ s/:$//; - foreach $name (@names) { - my($file) = "$dir:$name"; - print STDERR " checking in $dir for $name\n" if $dl_debug; - if (-f $file) { - push(@found, $file); - next arg; # no need to look any further - } - } - } - next; - } - - # Otherwise we try to try to spot directories by a heuristic - # (this is a more complicated issue than it first appears) - if (m:/: && -d $_) { push(@dirs, $_); next; } - - # VMS: we may be using native VMS directory syntax instead of - # Unix emulation, so check this as well - if ($Is_VMS && /[:>\]]/ && -d $_) { push(@dirs, $_); next; } - - # Only files should get this far... - my(@names, $name); # what filenames to look for - if (m:-l: ) { # convert -lname to appropriate library name - s/-l//; - push(@names,"lib$_.$dl_so"); - push(@names,"lib$_.a"); - } else { # Umm, a bare name. Try various alternatives: - # these should be ordered with the most likely first - push(@names,"$_.$dl_ext") unless m/\.$dl_ext$/o; - push(@names,"$_.$dl_so") unless m/\.$dl_so$/o; - push(@names,"lib$_.$dl_so") unless m:/:; - push(@names,"$_.a") if !m/\.a$/ and $dlsrc eq "dl_dld.xs"; - push(@names, $_); - } - foreach $dir (@dirs, @dl_library_path) { - next unless -d $dir; - chop($dir = VMS::Filespec::unixpath($dir)) if $Is_VMS; - foreach $name (@names) { - my($file) = "$dir/$name"; - print STDERR " checking in $dir for $name\n" if $dl_debug; - $file = ($do_expand) ? dl_expandspec($file) : (-f $file && $file); - #$file = _check_file($file); - if ($file) { - push(@found, $file); - next arg; # no need to look any further - } - } - } - } - if ($dl_debug) { - foreach(@dirs) { - print STDERR " dl_findfile ignored non-existent directory: $_\n" unless -d $_; - } - print STDERR "dl_findfile found: @found\n"; - } - return $found[0] unless wantarray; - @found; -} - - -sub dl_expandspec { - my($spec) = @_; - # Optional function invoked if DynaLoader.pm sets $do_expand. - # Most systems do not require or use this function. - # Some systems may implement it in the dl_*.xs file in which case - # this autoload version will not be called but is harmless. - - # This function is designed to deal with systems which treat some - # 'filenames' in a special way. For example VMS 'Logical Names' - # (something like unix environment variables - but different). - # This function should recognise such names and expand them into - # full file paths. - # Must return undef if $spec is invalid or file does not exist. - - my $file = $spec; # default output to input - - if ($Is_VMS) { # dl_expandspec should be defined in dl_vms.xs - require Carp; - Carp::croak("dl_expandspec: should be defined in XS file!\n"); - } else { - return undef unless -f $file; - } - print STDERR "dl_expandspec($spec) => $file\n" if $dl_debug; - $file; -} - -sub dl_find_symbol_anywhere -{ - my $sym = shift; - my $libref; - foreach $libref (@dl_librefs) { - my $symref = dl_find_symbol($libref,$sym); - return $symref if $symref; - } - return undef; -} - -=head1 NAME - -DynaLoader - Dynamically load C libraries into Perl code - -dl_error(), dl_findfile(), dl_expandspec(), dl_load_file(), dl_unload_file(), dl_find_symbol(), dl_find_symbol_anywhere(), dl_undef_symbols(), dl_install_xsub(), dl_load_flags(), bootstrap() - routines used by DynaLoader modules - -=head1 SYNOPSIS - - package YourPackage; - require DynaLoader; - @ISA = qw(... DynaLoader ...); - bootstrap YourPackage; - - # optional method for 'global' loading - sub dl_load_flags { 0x01 } - - -=head1 DESCRIPTION - -This document defines a standard generic interface to the dynamic -linking mechanisms available on many platforms. Its primary purpose is -to implement automatic dynamic loading of Perl modules. - -This document serves as both a specification for anyone wishing to -implement the DynaLoader for a new platform and as a guide for -anyone wishing to use the DynaLoader directly in an application. - -The DynaLoader is designed to be a very simple high-level -interface that is sufficiently general to cover the requirements -of SunOS, HP-UX, NeXT, Linux, VMS and other platforms. - -It is also hoped that the interface will cover the needs of OS/2, NT -etc and also allow pseudo-dynamic linking (using C<ld -A> at runtime). - -It must be stressed that the DynaLoader, by itself, is practically -useless for accessing non-Perl libraries because it provides almost no -Perl-to-C 'glue'. There is, for example, no mechanism for calling a C -library function or supplying arguments. A C::DynaLib module -is available from CPAN sites which performs that function for some -common system types. - -DynaLoader Interface Summary - - @dl_library_path - @dl_resolve_using - @dl_require_symbols - $dl_debug - @dl_librefs - @dl_modules - Implemented in: - bootstrap($modulename) Perl - @filepaths = dl_findfile(@names) Perl - $flags = $modulename->dl_load_flags Perl - $symref = dl_find_symbol_anywhere($symbol) Perl - - $libref = dl_load_file($filename, $flags) C - $status = dl_unload_file($libref) C - $symref = dl_find_symbol($libref, $symbol) C - @symbols = dl_undef_symbols() C - dl_install_xsub($name, $symref [, $filename]) C - $message = dl_error C - -=over 4 - -=item @dl_library_path - -The standard/default list of directories in which dl_findfile() will -search for libraries etc. Directories are searched in order: -$dl_library_path[0], [1], ... etc - -@dl_library_path is initialised to hold the list of 'normal' directories -(F</usr/lib>, etc) determined by B<Configure> (C<$Config{'libpth'}>). This should -ensure portability across a wide range of platforms. - -@dl_library_path should also be initialised with any other directories -that can be determined from the environment at runtime (such as -LD_LIBRARY_PATH for SunOS). - -After initialisation @dl_library_path can be manipulated by an -application using push and unshift before calling dl_findfile(). -Unshift can be used to add directories to the front of the search order -either to save search time or to override libraries with the same name -in the 'normal' directories. - -The load function that dl_load_file() calls may require an absolute -pathname. The dl_findfile() function and @dl_library_path can be -used to search for and return the absolute pathname for the -library/object that you wish to load. - -=item @dl_resolve_using - -A list of additional libraries or other shared objects which can be -used to resolve any undefined symbols that might be generated by a -later call to load_file(). - -This is only required on some platforms which do not handle dependent -libraries automatically. For example the Socket Perl extension -library (F<auto/Socket/Socket.so>) contains references to many socket -functions which need to be resolved when it's loaded. Most platforms -will automatically know where to find the 'dependent' library (e.g., -F</usr/lib/libsocket.so>). A few platforms need to be told the -location of the dependent library explicitly. Use @dl_resolve_using -for this. - -Example usage: - - @dl_resolve_using = dl_findfile('-lsocket'); - -=item @dl_require_symbols - -A list of one or more symbol names that are in the library/object file -to be dynamically loaded. This is only required on some platforms. - -=item @dl_librefs - -An array of the handles returned by successful calls to dl_load_file(), -made by bootstrap, in the order in which they were loaded. -Can be used with dl_find_symbol() to look for a symbol in any of -the loaded files. - -=item @dl_modules - -An array of module (package) names that have been bootstrap'ed. - -=item dl_error() - -Syntax: - - $message = dl_error(); - -Error message text from the last failed DynaLoader function. Note -that, similar to errno in unix, a successful function call does not -reset this message. - -Implementations should detect the error as soon as it occurs in any of -the other functions and save the corresponding message for later -retrieval. This will avoid problems on some platforms (such as SunOS) -where the error message is very temporary (e.g., dlerror()). - -=item $dl_debug - -Internal debugging messages are enabled when $dl_debug is set true. -Currently setting $dl_debug only affects the Perl side of the -DynaLoader. These messages should help an application developer to -resolve any DynaLoader usage problems. - -$dl_debug is set to C<$ENV{'PERL_DL_DEBUG'}> if defined. - -For the DynaLoader developer/porter there is a similar debugging -variable added to the C code (see dlutils.c) and enabled if Perl was -built with the B<-DDEBUGGING> flag. This can also be set via the -PERL_DL_DEBUG environment variable. Set to 1 for minimal information or -higher for more. - -=item dl_findfile() - -Syntax: - - @filepaths = dl_findfile(@names) - -Determine the full paths (including file suffix) of one or more -loadable files given their generic names and optionally one or more -directories. Searches directories in @dl_library_path by default and -returns an empty list if no files were found. - -Names can be specified in a variety of platform independent forms. Any -names in the form B<-lname> are converted into F<libname.*>, where F<.*> is -an appropriate suffix for the platform. - -If a name does not already have a suitable prefix and/or suffix then -the corresponding file will be searched for by trying combinations of -prefix and suffix appropriate to the platform: "$name.o", "lib$name.*" -and "$name". - -If any directories are included in @names they are searched before -@dl_library_path. Directories may be specified as B<-Ldir>. Any other -names are treated as filenames to be searched for. - -Using arguments of the form C<-Ldir> and C<-lname> is recommended. - -Example: - - @dl_resolve_using = dl_findfile(qw(-L/usr/5lib -lposix)); - - -=item dl_expandspec() - -Syntax: - - $filepath = dl_expandspec($spec) - -Some unusual systems, such as VMS, require special filename handling in -order to deal with symbolic names for files (i.e., VMS's Logical Names). - -To support these systems a dl_expandspec() function can be implemented -either in the F<dl_*.xs> file or code can be added to the autoloadable -dl_expandspec() function in F<DynaLoader.pm>. See F<DynaLoader.pm> for -more information. - -=item dl_load_file() - -Syntax: - - $libref = dl_load_file($filename, $flags) - -Dynamically load $filename, which must be the path to a shared object -or library. An opaque 'library reference' is returned as a handle for -the loaded object. Returns undef on error. - -The $flags argument to alters dl_load_file behaviour. -Assigned bits: - - 0x01 make symbols available for linking later dl_load_file's. - (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL)) - (ignored under VMS; this is a normal part of image linking) - -(On systems that provide a handle for the loaded object such as SunOS -and HPUX, $libref will be that handle. On other systems $libref will -typically be $filename or a pointer to a buffer containing $filename. -The application should not examine or alter $libref in any way.) - -This is the function that does the real work. It should use the -current values of @dl_require_symbols and @dl_resolve_using if required. - - SunOS: dlopen($filename) - HP-UX: shl_load($filename) - Linux: dld_create_reference(@dl_require_symbols); dld_link($filename) - NeXT: rld_load($filename, @dl_resolve_using) - VMS: lib$find_image_symbol($filename,$dl_require_symbols[0]) - -(The dlopen() function is also used by Solaris and some versions of -Linux, and is a common choice when providing a "wrapper" on other -mechanisms as is done in the OS/2 port.) - -=item dl_unload_file() - -Syntax: - - $status = dl_unload_file($libref) - -Dynamically unload $libref, which must be an opaque 'library reference' as -returned from dl_load_file. Returns one on success and zero on failure. - -This function is optional and may not necessarily be provided on all platforms. -If it is defined, it is called automatically when the interpreter exits for -every shared object or library loaded by DynaLoader::bootstrap. All such -library references are stored in @dl_librefs by DynaLoader::Bootstrap as it -loads the libraries. The files are unloaded in last-in, first-out order. - -This unloading is usually necessary when embedding a shared-object perl (e.g. -one configured with -Duseshrplib) within a larger application, and the perl -interpreter is created and destroyed several times within the lifetime of the -application. In this case it is possible that the system dynamic linker will -unload and then subsequently reload the shared libperl without relocating any -references to it from any files DynaLoaded by the previous incarnation of the -interpreter. As a result, any shared objects opened by DynaLoader may point to -a now invalid 'ghost' of the libperl shared object, causing apparently random -memory corruption and crashes. This behaviour is most commonly seen when using -Apache and mod_perl built with the APXS mechanism. - - SunOS: dlclose($libref) - HP-UX: ??? - Linux: ??? - NeXT: ??? - VMS: ??? - -(The dlclose() function is also used by Solaris and some versions of -Linux, and is a common choice when providing a "wrapper" on other -mechanisms as is done in the OS/2 port.) - -=item dl_loadflags() - -Syntax: - - $flags = dl_loadflags $modulename; - -Designed to be a method call, and to be overridden by a derived class -(i.e. a class which has DynaLoader in its @ISA). The definition in -DynaLoader itself returns 0, which produces standard behavior from -dl_load_file(). - -=item dl_find_symbol() - -Syntax: - - $symref = dl_find_symbol($libref, $symbol) - -Return the address of the symbol $symbol or C<undef> if not found. If the -target system has separate functions to search for symbols of different -types then dl_find_symbol() should search for function symbols first and -then other types. - -The exact manner in which the address is returned in $symref is not -currently defined. The only initial requirement is that $symref can -be passed to, and understood by, dl_install_xsub(). - - SunOS: dlsym($libref, $symbol) - HP-UX: shl_findsym($libref, $symbol) - Linux: dld_get_func($symbol) and/or dld_get_symbol($symbol) - NeXT: rld_lookup("_$symbol") - VMS: lib$find_image_symbol($libref,$symbol) - - -=item dl_find_symbol_anywhere() - -Syntax: - - $symref = dl_find_symbol_anywhere($symbol) - -Applies dl_find_symbol() to the members of @dl_librefs and returns -the first match found. - -=item dl_undef_symbols() - -Example - - @symbols = dl_undef_symbols() - -Return a list of symbol names which remain undefined after load_file(). -Returns C<()> if not known. Don't worry if your platform does not provide -a mechanism for this. Most do not need it and hence do not provide it, -they just return an empty list. - - -=item dl_install_xsub() - -Syntax: - - dl_install_xsub($perl_name, $symref [, $filename]) - -Create a new Perl external subroutine named $perl_name using $symref as -a pointer to the function which implements the routine. This is simply -a direct call to newXSUB(). Returns a reference to the installed -function. - -The $filename parameter is used by Perl to identify the source file for -the function if required by die(), caller() or the debugger. If -$filename is not defined then "DynaLoader" will be used. - - -=item bootstrap() - -Syntax: - -bootstrap($module) - -This is the normal entry point for automatic dynamic loading in Perl. - -It performs the following actions: - -=over 8 - -=item * - -locates an auto/$module directory by searching @INC - -=item * - -uses dl_findfile() to determine the filename to load - -=item * - -sets @dl_require_symbols to C<("boot_$module")> - -=item * - -executes an F<auto/$module/$module.bs> file if it exists -(typically used to add to @dl_resolve_using any files which -are required to load the module on the current platform) - -=item * - -calls dl_load_flags() to determine how to load the file. - -=item * - -calls dl_load_file() to load the file - -=item * - -calls dl_undef_symbols() and warns if any symbols are undefined - -=item * - -calls dl_find_symbol() for "boot_$module" - -=item * - -calls dl_install_xsub() to install it as "${module}::bootstrap" - -=item * - -calls &{"${module}::bootstrap"} to bootstrap the module (actually -it uses the function reference returned by dl_install_xsub for speed) - -=back - -=back - - -=head1 AUTHOR - -Tim Bunce, 11 August 1994. - -This interface is based on the work and comments of (in no particular -order): Larry Wall, Robert Sanders, Dean Roehrich, Jeff Okamoto, Anno -Siegel, Thomas Neumann, Paul Marquess, Charles Bailey, myself and others. - -Larry Wall designed the elegant inherited bootstrap mechanism and -implemented the first Perl 5 dynamic loader using it. - -Solaris global loading added by Nick Ing-Simmons with design/coding -assistance from Tim Bunce, January 1996. - -=cut -EOT - -close OUT or die $!; - diff --git a/contrib/perl5/ext/DynaLoader/Makefile.PL b/contrib/perl5/ext/DynaLoader/Makefile.PL deleted file mode 100644 index 83cbd77..0000000 --- a/contrib/perl5/ext/DynaLoader/Makefile.PL +++ /dev/null @@ -1,34 +0,0 @@ -use ExtUtils::MakeMaker; - -WriteMakefile( - NAME => 'DynaLoader', - LINKTYPE => 'static', - DEFINE => '-DPERL_CORE -DLIBC="$(LIBC)"', - MAN3PODS => {}, # Pods will be built by installman. - SKIP => [qw(dynamic dynamic_lib dynamic_bs)], - XSPROTOARG => '-noprototypes', # XXX remove later? - VERSION_FROM => 'DynaLoader_pm.PL', - PL_FILES => {'DynaLoader_pm.PL'=>'DynaLoader.pm', - 'XSLoader_pm.PL'=>'XSLoader.pm'}, - PM => {'DynaLoader.pm' => '$(INST_LIBDIR)/DynaLoader.pm', - 'XSLoader.pm' => '$(INST_LIBDIR)/XSLoader.pm'}, - depend => {'DynaLoader.o' => 'dlutils.c'}, - clean => {FILES => 'DynaLoader.c DynaLoader.xs DynaLoader.pm ' . - 'XSLoader.pm'}, -); - -sub MY::postamble { - ' -DynaLoader.xs: $(DLSRC) - $(RM_F) $@ - $(CP) $? $@ - -# Perform very simple tests just to check for major gaffs. -# We can\'t do much more for platforms we are not executing on. -test-xs: - for i in dl_*xs; \ - do $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSUBPPARGS) $$i > /dev/null; \ - done -'; -} - diff --git a/contrib/perl5/ext/DynaLoader/README b/contrib/perl5/ext/DynaLoader/README deleted file mode 100644 index 0551cf3..0000000 --- a/contrib/perl5/ext/DynaLoader/README +++ /dev/null @@ -1,53 +0,0 @@ -Perl 5 DynaLoader - -See DynaLoader.pm for detailed specification. - -This module is very similar to the other Perl 5 modules except that -Configure selects which dl_*.xs file to use. - -After Configure has been run the Makefile.PL will generate a Makefile -which will run xsubpp on a specific dl_*.xs file and write the output -to DynaLoader.c - -After that the processing is the same as any other module. - -Note that, to be effective, the DynaLoader module must be _statically_ -linked into perl! Configure should arrange this. - -This interface is based on the work and comments of (in no particular -order): Larry Wall, Robert Sanders, Dean Roehrich, Jeff Okamoto, Anno -Siegel, Thomas Neumann, Paul Marquess, Charles Bailey and others. - -The dl_*.xs files should either be named after the dynamic linking -operating system interface used if that interface is available on more -than one type of system, e.g.: - dlopen for dlopen()/dlsym() type functions (SunOS, BSD) - dld for the GNU dld library functions (linux, ?) -or else the osname, e.g., hpux, next, vms etc. - -Both are determined by Configure and so only those specific names that -Configure knows/uses will work. - -If porting the DynaLoader to a platform that has a core dynamic linking -interface similar to an existing generic type, e.g., dlopen or dld, -please try to port the corresponding dl_*.xs file (using #ifdef's if -required). - -Otherwise, or if that proves too messy, create a new dl_*.xs file named -after your osname. Configure will give preference to a dl_$osname.xs -file if one exists. - -The file dl_dlopen.xs is a reference implementation by Paul Marquess -which is a good place to start if porting from scratch. For more complex -platforms take a look at dl_dld.xs. The dlutils.c file holds some -common definitions that are #included into the dl_*.xs files. - -After the initial implementation of a new DynaLoader dl_*.xs file you -may need to edit or create ext/MODULE/MODULE.bs files (library bootstrap -files) to reflect the needs of your platform and linking software. - -Refer to DynaLoader.pm, lib/ExtUtils/MakeMaker.pm and any existing -ext/MODULE/MODULE.bs files for more information. - -Tim Bunce. -August 1994 diff --git a/contrib/perl5/ext/DynaLoader/XSLoader_pm.PL b/contrib/perl5/ext/DynaLoader/XSLoader_pm.PL deleted file mode 100644 index 7657410..0000000 --- a/contrib/perl5/ext/DynaLoader/XSLoader_pm.PL +++ /dev/null @@ -1,160 +0,0 @@ -use Config; - -sub to_string { - my ($value) = @_; - $value =~ s/\\/\\\\/g; - $value =~ s/'/\\'/g; - return "'$value'"; -} - -unlink "XSLoader.pm" if -f "XSLoader.pm"; -open OUT, ">XSLoader.pm" or die $!; -print OUT <<'EOT'; -# Generated from XSLoader.pm.PL (resolved %Config::Config value) - -package XSLoader; - -# And Gandalf said: 'Many folk like to know beforehand what is to -# be set on the table; but those who have laboured to prepare the -# feast like to keep their secret; for wonder makes the words of -# praise louder.' - -# (Quote from Tolkien sugested by Anno Siegel.) -# -# See pod text at end of file for documentation. -# See also ext/DynaLoader/README in source tree for other information. -# -# Tim.Bunce@ig.co.uk, August 1994 - -$VERSION = "0.01"; # avoid typo warning - -# enable debug/trace messages from DynaLoader perl code -# $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; - -EOT - -print OUT ' my $dl_dlext = ', to_string($Config::Config{'dlext'}), ";\n" ; - -print OUT <<'EOT'; - -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_error); -package XSLoader; - -1; # End of main code - -# The bootstrap function cannot be autoloaded (without complications) -# so we define it here: - -sub load { - package DynaLoader; - - my($module) = $_[0]; - - # work with static linking too - my $b = "$module\::bootstrap"; - goto &$b if defined &$b; - - goto retry unless $module and defined &dl_load_file; - - my @modparts = split(/::/,$module); - my $modfname = $modparts[-1]; - -EOT - -print OUT <<'EOT' if defined &DynaLoader::mod2fname; - # Some systems have restrictions on files names for DLL's etc. - # mod2fname returns appropriate file base name (typically truncated) - # It may also edit @modparts if required. - $modfname = &mod2fname(\@modparts) if defined &mod2fname; - -EOT - -print OUT <<'EOT'; - my $modpname = join('/',@modparts); - my $modlibname = (caller())[1]; - my $c = @modparts; - $modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename - my $file = "$modlibname/auto/$modpname/$modfname.$dl_dlext"; - -# print STDERR "XSLoader::load for $module ($file)\n" if $dl_debug; - - my $bs = $file; - $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library - - goto retry if not -f $file or -s $bs; - - my $bootname = "boot_$module"; - $bootname =~ s/\W/_/g; - @dl_require_symbols = ($bootname); - - # Many dynamic extension loading problems will appear to come from - # this section of code: XYZ failed at line 123 of DynaLoader.pm. - # Often these errors are actually occurring in the initialisation - # C code of the extension XS file. Perl reports the error as being - # in this perl code simply because this was the last perl code - # it executed. - - my $libref = dl_load_file($file, 0) or do { - require Carp; - Carp::croak("Can't load '$file' for module $module: " . dl_error()); - }; - push(@dl_librefs,$libref); # record loaded object - - my @unresolved = dl_undef_symbols(); - if (@unresolved) { - require Carp; - Carp::carp("Undefined symbols present after loading $file: @unresolved\n"); - } - - my $boot_symbol_ref = dl_find_symbol($libref, $bootname) or do { - require Carp; - Carp::croak("Can't find '$bootname' symbol in $file\n"); - }; - - my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file); - - push(@dl_modules, $module); # record loaded module - - # See comment block above - return &$xs(@_); - - retry: - require DynaLoader; - goto &DynaLoader::bootstrap_inherit; -} - -__END__ - -=head1 NAME - -XSLoader - Dynamically load C libraries into Perl code - -=head1 SYNOPSIS - - package YourPackage; - use XSLoader; - - XSLoader::load 'YourPackage', @args; - -=head1 DESCRIPTION - -This module defines a standard I<simplified> interface to the dynamic -linking mechanisms available on many platforms. Its primary purpose is -to implement cheap automatic dynamic loading of Perl modules. - -For more complicated interface see L<DynaLoader>. - -=head1 AUTHOR - -Ilya Zakharevich: extraction from DynaLoader. - -=cut -EOT - -close OUT or die $!; - diff --git a/contrib/perl5/ext/DynaLoader/dl_aix.xs b/contrib/perl5/ext/DynaLoader/dl_aix.xs deleted file mode 100644 index e29c0f8..0000000 --- a/contrib/perl5/ext/DynaLoader/dl_aix.xs +++ /dev/null @@ -1,744 +0,0 @@ -/* dl_aix.xs - * - * Written: 8/31/94 by Wayne Scott (wscott@ichips.intel.com) - * - * All I did was take Jens-Uwe Mager's libdl emulation library for - * AIX and merged it with the dl_dlopen.xs file to create a dynamic library - * package that works for AIX. - * - * I did change all malloc's, free's, strdup's, calloc's to use the perl - * equilvant. I also removed some stuff we will not need. Call fini() - * on statup... It can probably be trimmed more. - */ - -#define PERLIO_NOT_STDIO 0 - -/* - * @(#)dlfcn.c 1.5 revision of 93/02/14 20:14:17 - * This is an unpublished work copyright (c) 1992 Helios Software GmbH - * 3000 Hannover 1, Germany - */ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -/* When building as a 64-bit binary on AIX, define this to get the - * correct structure definitions. Also determines the field-name - * macros and gates some logic in readEntries(). -- Steven N. Hirsch - * <hirschs@btv.ibm.com> */ -#ifdef USE_64_BIT_ALL -# define __XCOFF64__ -# define __XCOFF32__ -#endif - -#include <stdio.h> -#include <errno.h> -#include <string.h> -#include <stdlib.h> -#include <sys/types.h> -#include <sys/ldr.h> -#include <a.out.h> -#undef FREAD -#undef FWRITE -#include <ldfcn.h> - -#ifdef USE_64_BIT_ALL -# define AIX_SCNHDR SCNHDR_64 -# define AIX_LDHDR LDHDR_64 -# define AIX_LDSYM LDSYM_64 -# define AIX_LDHDRSZ LDHDRSZ_64 -#else -# define AIX_SCNHDR SCNHDR -# define AIX_LDHDR LDHDR -# define AIX_LDSYM LDSYM -# define AIX_LDHDRSZ LDHDRSZ -#endif - -/* When using Perl extensions written in C++ the longer versions - * of load() and unload() from libC and libC_r need to be used, - * otherwise statics in the extensions won't get initialized right. - * -- Stephanie Beals <bealzy@us.ibm.com> */ - -/* Older AIX C compilers cannot deal with C++ double-slash comments in - the ibmcxx and/or xlC includes. Since we only need a single file, - be more fine-grained about what's included <hirschs@btv.ibm.com> */ - -#ifdef USE_libC /* The define comes, when it comes, from hints/aix.pl. */ -# define LOAD loadAndInit -# define UNLOAD terminateAndUnload -# if defined(USE_vacpp_load_h) -# include "/usr/vacpp/include/load.h" -# elif defined(USE_ibmcxx_load_h) -# include "/usr/ibmcxx/include/load.h" -# elif defined(USE_xlC_load_h) -# include "/usr/lpp/xlC/include/load.h" -# elif defined(USE_load_h) -# include "/usr/include/load.h" -# endif -#else -# define LOAD load -# define UNLOAD unload -#endif - -/* - * AIX 4.3 does remove some useful definitions from ldfcn.h. Define - * these here to compensate for that lossage. - */ -#ifndef BEGINNING -# define BEGINNING SEEK_SET -#endif -#ifndef FSEEK -# define FSEEK(ldptr,o,p) fseek(IOPTR(ldptr),(p==BEGINNING)?(OFFSET(ldptr) +o):o,p) -#endif -#ifndef FREAD -# define FREAD(p,s,n,ldptr) fread(p,s,n,IOPTR(ldptr)) -#endif - -/* - * We simulate dlopen() et al. through a call to load. Because AIX has - * no call to find an exported symbol we read the loader section of the - * loaded module and build a list of exported symbols and their virtual - * address. - */ - -typedef struct { - char *name; /* the symbols's name */ - void *addr; /* its relocated virtual address */ -} Export, *ExportPtr; - -/* - * The void * handle returned from dlopen is actually a ModulePtr. - */ -typedef struct Module { - struct Module *next; - char *name; /* module name for refcounting */ - int refCnt; /* the number of references */ - void *entry; /* entry point from load */ - int nExports; /* the number of exports found */ - ExportPtr exports; /* the array of exports */ -} Module, *ModulePtr; - -/* - * We keep a list of all loaded modules to be able to reference count - * duplicate dlopen's. - */ -static ModulePtr modList; /* XXX threaded */ - -/* - * The last error from one of the dl* routines is kept in static - * variables here. Each error is returned only once to the caller. - */ -static char errbuf[BUFSIZ]; /* XXX threaded */ -static int errvalid; /* XXX threaded */ - -static void caterr(char *); -static int readExports(ModulePtr); -static void *findMain(void); - -static char *strerror_failed = "(strerror failed)"; -static char *strerror_r_failed = "(strerror_r failed)"; - -char *strerrorcat(char *str, int err) { - int strsiz = strlen(str); - int msgsiz; - char *msg; - -#ifdef USE_THREADS - char *buf = malloc(BUFSIZ); - - if (buf == 0) - return 0; - if (strerror_r(err, buf, BUFSIZ) == 0) - msg = buf; - else - msg = strerror_r_failed; - msgsiz = strlen(msg); - if (strsiz + msgsiz < BUFSIZ) - strcat(str, msg); - free(buf); -#else - if ((msg = strerror(err)) == 0) - msg = strerror_failed; - msgsiz = strlen(msg); /* Note msg = buf and free() above. */ - if (strsiz + msgsiz < BUFSIZ) /* Do not move this after #endif. */ - strcat(str, msg); -#endif - - return str; -} - -char *strerrorcpy(char *str, int err) { - int msgsiz; - char *msg; - -#ifdef USE_THREADS - char *buf = malloc(BUFSIZ); - - if (buf == 0) - return 0; - if (strerror_r(err, buf, BUFSIZ) == 0) - msg = buf; - else - msg = strerror_r_failed; - msgsiz = strlen(msg); - if (msgsiz < BUFSIZ) - strcpy(str, msg); - free(buf); -#else - if ((msg = strerror(err)) == 0) - msg = strerror_failed; - msgsiz = strlen(msg); /* Note msg = buf and free() above. */ - if (msgsiz < BUFSIZ) /* Do not move this after #endif. */ - strcpy(str, msg); -#endif - - return str; -} - -/* ARGSUSED */ -void *dlopen(char *path, int mode) -{ - dTHX; - register ModulePtr mp; - static void *mainModule; /* XXX threaded */ - - /* - * Upon the first call register a terminate handler that will - * close all libraries. - */ - if (mainModule == NULL) { - if ((mainModule = findMain()) == NULL) - return NULL; - } - /* - * Scan the list of modules if have the module already loaded. - */ - for (mp = modList; mp; mp = mp->next) - if (strcmp(mp->name, path) == 0) { - mp->refCnt++; - return mp; - } - Newz(1000,mp,1,Module); - if (mp == NULL) { - errvalid++; - strcpy(errbuf, "Newz: "); - strerrorcat(errbuf, errno); - return NULL; - } - - if ((mp->name = savepv(path)) == NULL) { - errvalid++; - strcpy(errbuf, "savepv: "); - strerrorcat(errbuf, errno); - safefree(mp); - return NULL; - } - - /* - * load should be declared load(const char *...). Thus we - * cast the path to a normal char *. Ugly. - */ - if ((mp->entry = (void *)LOAD((char *)path, -#ifdef L_LIBPATH_EXEC - L_LIBPATH_EXEC | -#endif - L_NOAUTODEFER, - NULL)) == NULL) { - int saverrno = errno; - - safefree(mp->name); - safefree(mp); - errvalid++; - strcpy(errbuf, "dlopen: "); - strcat(errbuf, path); - strcat(errbuf, ": "); - /* - * If AIX says the file is not executable, the error - * can be further described by querying the loader about - * the last error. - */ - if (saverrno == ENOEXEC) { - char *moreinfo[BUFSIZ/sizeof(char *)]; - if (loadquery(L_GETMESSAGES, moreinfo, sizeof(moreinfo)) == -1) - strerrorcpy(errbuf, saverrno); - else { - char **p; - for (p = moreinfo; *p; p++) - caterr(*p); - } - } else - strerrorcat(errbuf, saverrno); - return NULL; - } - mp->refCnt = 1; - mp->next = modList; - modList = mp; - /* - * 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. 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 || - loadbind(0, mainModule, mp->entry)) { - int saverrno = errno; - - dlclose(mp); - errvalid++; - strcpy(errbuf, "loadbind: "); - strerrorcat(errbuf, saverrno); - return NULL; - } - if (readExports(mp) == -1) { - dlclose(mp); - return NULL; - } - return mp; -} - -/* - * Attempt to decipher an AIX loader error message and append it - * to our static error message buffer. - */ -static void caterr(char *s) -{ - register char *p = s; - - while (*p >= '0' && *p <= '9') - p++; - switch(atoi(s)) { - case L_ERROR_TOOMANY: - strcat(errbuf, "too many errors"); - break; - case L_ERROR_NOLIB: - strcat(errbuf, "can't load library"); - strcat(errbuf, p); - break; - case L_ERROR_UNDEF: - strcat(errbuf, "can't find symbol"); - strcat(errbuf, p); - break; - case L_ERROR_RLDBAD: - strcat(errbuf, "bad RLD"); - strcat(errbuf, p); - break; - case L_ERROR_FORMAT: - strcat(errbuf, "bad exec format in"); - strcat(errbuf, p); - break; - case L_ERROR_ERRNO: - strerrorcat(errbuf, atoi(++p)); - break; - default: - strcat(errbuf, s); - break; - } -} - -void *dlsym(void *handle, const char *symbol) -{ - register ModulePtr mp = (ModulePtr)handle; - register ExportPtr ep; - register int i; - - /* - * Could speed up search, but I assume that one assigns - * the result to function pointers anyways. - */ - for (ep = mp->exports, i = mp->nExports; i; i--, ep++) - if (strcmp(ep->name, symbol) == 0) - return ep->addr; - errvalid++; - strcpy(errbuf, "dlsym: undefined symbol "); - strcat(errbuf, symbol); - return NULL; -} - -char *dlerror(void) -{ - if (errvalid) { - errvalid = 0; - return errbuf; - } - return NULL; -} - -int dlclose(void *handle) -{ - register ModulePtr mp = (ModulePtr)handle; - int result; - register ModulePtr mp1; - - if (--mp->refCnt > 0) - return 0; - result = UNLOAD(mp->entry); - if (result == -1) { - errvalid++; - strerrorcpy(errbuf, errno); - } - if (mp->exports) { - register ExportPtr ep; - register int i; - for (ep = mp->exports, i = mp->nExports; i; i--, ep++) - if (ep->name) - safefree(ep->name); - safefree(mp->exports); - } - if (mp == modList) - modList = mp->next; - else { - for (mp1 = modList; mp1; mp1 = mp1->next) - if (mp1->next == mp) { - mp1->next = mp->next; - break; - } - } - safefree(mp->name); - safefree(mp); - return result; -} - -/* 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. - * Without this we get this system calloc and perl's free, resulting - * in a "Bad free" message. This way we always use perl's malloc. - */ -void *calloc(size_t ne, size_t sz) -{ - void *out; - - out = (void *) safemalloc(ne*sz); - memzero(out, ne*sz); - return(out); -} - -/* - * Build the export table from the XCOFF .loader section. - */ -static int readExports(ModulePtr mp) -{ - dTHX; - LDFILE *ldp = NULL; - AIX_SCNHDR sh; - AIX_LDHDR *lhp; - char *ldbuf; - AIX_LDSYM *ls; - int i; - ExportPtr ep; - - if ((ldp = ldopen(mp->name, ldp)) == NULL) { - struct ld_info *lp; - char *buf; - int size = 4*1024; - if (errno != ENOENT) { - errvalid++; - strcpy(errbuf, "readExports: "); - strerrorcat(errbuf, errno); - return -1; - } - /* - * The module might be loaded due to the LIBPATH - * environment variable. Search for the loaded - * module using L_GETINFO. - */ - if ((buf = safemalloc(size)) == NULL) { - errvalid++; - strcpy(errbuf, "readExports: "); - strerrorcat(errbuf, errno); - return -1; - } - while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { - safefree(buf); - size += 4*1024; - if ((buf = safemalloc(size)) == NULL) { - errvalid++; - strcpy(errbuf, "readExports: "); - strerrorcat(errbuf, errno); - return -1; - } - } - if (i == -1) { - errvalid++; - strcpy(errbuf, "readExports: "); - strerrorcat(errbuf, errno); - safefree(buf); - return -1; - } - /* - * Traverse the list of loaded modules. The entry point - * returned by LOAD() does actually point to the data - * segment origin. - */ - lp = (struct ld_info *)buf; - while (lp) { - if (lp->ldinfo_dataorg == mp->entry) { - ldp = ldopen(lp->ldinfo_filename, ldp); - break; - } - if (lp->ldinfo_next == 0) - lp = NULL; - else - lp = (struct ld_info *)((char *)lp + lp->ldinfo_next); - } - safefree(buf); - if (!ldp) { - errvalid++; - strcpy(errbuf, "readExports: "); - strerrorcat(errbuf, errno); - return -1; - } - } -#ifdef USE_64_BIT_ALL - if (TYPE(ldp) != U803XTOCMAGIC) { -#else - if (TYPE(ldp) != U802TOCMAGIC) { -#endif - errvalid++; - strcpy(errbuf, "readExports: bad magic"); - while(ldclose(ldp) == FAILURE) - ; - return -1; - } - if (ldnshread(ldp, _LOADER, &sh) != SUCCESS) { - errvalid++; - strcpy(errbuf, "readExports: cannot read loader section header"); - while(ldclose(ldp) == FAILURE) - ; - return -1; - } - /* - * We read the complete loader section in one chunk, this makes - * finding long symbol names residing in the string table easier. - */ - if ((ldbuf = (char *)safemalloc(sh.s_size)) == NULL) { - errvalid++; - strcpy(errbuf, "readExports: "); - strerrorcat(errbuf, errno); - while(ldclose(ldp) == FAILURE) - ; - return -1; - } - if (FSEEK(ldp, sh.s_scnptr, BEGINNING) != OKFSEEK) { - errvalid++; - strcpy(errbuf, "readExports: cannot seek to loader section"); - safefree(ldbuf); - while(ldclose(ldp) == FAILURE) - ; - return -1; - } -/* This first case is a hack, since it assumes that the 3rd parameter to - FREAD is 1. See the redefinition of FREAD above to see how this works. */ - if (FREAD(ldbuf, sh.s_size, 1, ldp) != 1) { - errvalid++; - strcpy(errbuf, "readExports: cannot read loader section"); - safefree(ldbuf); - while(ldclose(ldp) == FAILURE) - ; - return -1; - } - lhp = (AIX_LDHDR *)ldbuf; - ls = (AIX_LDSYM *)(ldbuf+AIX_LDHDRSZ); - /* - * Count the number of exports to include in our export table. - */ - for (i = lhp->l_nsyms; i; i--, ls++) { - if (!LDR_EXPORT(*ls)) - continue; - mp->nExports++; - } - Newz(1001, mp->exports, mp->nExports, Export); - if (mp->exports == NULL) { - errvalid++; - strcpy(errbuf, "readExports: "); - strerrorcat(errbuf, errno); - safefree(ldbuf); - while(ldclose(ldp) == FAILURE) - ; - return -1; - } - /* - * Fill in the export table. All entries are relative to - * the entry point we got from load. - */ - ep = mp->exports; - ls = (AIX_LDSYM *)(ldbuf+AIX_LDHDRSZ); - for (i = lhp->l_nsyms; i; i--, ls++) { - char *symname; - if (!LDR_EXPORT(*ls)) - continue; -#ifndef USE_64_BIT_ALL - if (ls->l_zeroes == 0) -#endif - symname = ls->l_offset+lhp->l_stoff+ldbuf; -#ifndef USE_64_BIT_ALL - else - symname = ls->l_name; -#endif - ep->name = savepv(symname); - ep->addr = (void *)((unsigned long)mp->entry + ls->l_value); - ep++; - } - safefree(ldbuf); - while(ldclose(ldp) == FAILURE) - ; - 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. - * Author: Paul Marquess (Paul.Marquess@btinternet.com) - * Created: 10th July 1994 - * - * Modified: - * 15th July 1994 - Added code to explicitly save any error messages. - * 3rd August 1994 - Upgraded to v3 spec. - * 9th August 1994 - Changed to use IV - * 10th August 1994 - Tim Bunce: Added RTLD_LAZY, switchable debugging, - * basic FreeBSD support, removed ClearError - * - */ - -/* Porting notes: - - see dl_dlopen.xs - -*/ - -#include "dlutils.c" /* SaveError() etc */ - - -static void -dl_private_init(pTHX) -{ - (void)dl_generic_private_init(aTHX); -} - -MODULE = DynaLoader PACKAGE = DynaLoader - -BOOT: - (void)dl_private_init(aTHX); - - -void * -dl_load_file(filename, flags=0) - char * filename - int flags - CODE: - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); - if (flags & 0x01) - Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename); - RETVAL = dlopen(filename, 1) ; - DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL)); - ST(0) = sv_newmortal() ; - if (RETVAL == NULL) - SaveError(aTHX_ "%s",dlerror()) ; - 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) - void * libhandle - char * symbolname - CODE: - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%x, symbol=%s)\n", - libhandle, symbolname)); - RETVAL = dlsym(libhandle, symbolname); - DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref = %x\n", RETVAL)); - ST(0) = sv_newmortal() ; - if (RETVAL == NULL) - SaveError(aTHX_ "%s",dlerror()) ; - else - sv_setiv( ST(0), PTR2IV(RETVAL)); - - -void -dl_undef_symbols() - PPCODE: - - - -# These functions should not need changing on any platform: - -void -dl_install_xsub(perl_name, symref, filename="$Package") - char * perl_name - void * symref - char * filename - CODE: - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n", - perl_name, symref)); - ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, - (void(*)(pTHX_ CV *))symref, - filename))); - - -char * -dl_error() - CODE: - RETVAL = LastError ; - OUTPUT: - RETVAL - -# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_beos.xs b/contrib/perl5/ext/DynaLoader/dl_beos.xs deleted file mode 100644 index 705c8bc..0000000 --- a/contrib/perl5/ext/DynaLoader/dl_beos.xs +++ /dev/null @@ -1,117 +0,0 @@ -/* - * dl_beos.xs, by Tom Spindler - * based on dl_dlopen.xs, by Paul Marquess - * $Id:$ - */ - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#include <be/kernel/image.h> -#include <OS.h> -#include <stdlib.h> -#include <limits.h> - -#define dlerror() strerror(errno) - -#include "dlutils.c" /* SaveError() etc */ - -static void -dl_private_init(pTHX) -{ - (void)dl_generic_private_init(aTHX); -} - -MODULE = DynaLoader PACKAGE = DynaLoader - -BOOT: - (void)dl_private_init(aTHX); - - -void * -dl_load_file(filename, flags=0) - char * filename - int flags - CODE: -{ image_id bogo; - char *path; - path = malloc(PATH_MAX); - if (*filename != '/') { - getcwd(path, PATH_MAX); - strcat(path, "/"); - strcat(path, filename); - } else { - strcpy(path, filename); - } - - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", path, flags)); - bogo = load_add_on(path); - DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%lx\n", (unsigned long) RETVAL)); - ST(0) = sv_newmortal() ; - if (bogo < 0) { - SaveError(aTHX_ "%s", strerror(bogo)); - PerlIO_printf(Perl_debug_log, "load_add_on(%s) : %d (%s)\n", path, bogo, strerror(bogo)); - } else { - RETVAL = (void *) bogo; - sv_setiv( ST(0), PTR2IV(RETVAL) ); - } - free(path); -} - -void * -dl_find_symbol(libhandle, symbolname) - void * libhandle - char * symbolname - CODE: - status_t retcode; - void *adr = 0; -#ifdef DLSYM_NEEDS_UNDERSCORE - symbolname = Perl_form_nocontext("_%s", symbolname); -#endif - RETVAL = NULL; - DLDEBUG(2, PerlIO_printf(Perl_debug_log, - "dl_find_symbol(handle=%lx, symbol=%s)\n", - (unsigned long) libhandle, symbolname)); - retcode = get_image_symbol((image_id) libhandle, symbolname, - B_SYMBOL_TYPE_TEXT, (void **) &adr); - RETVAL = adr; - DLDEBUG(2, PerlIO_printf(Perl_debug_log, - " symbolref = %lx\n", (unsigned long) RETVAL)); - ST(0) = sv_newmortal() ; - if (RETVAL == NULL) { - SaveError(aTHX_ "%s", strerror(retcode)) ; - PerlIO_printf(Perl_debug_log, "retcode = %p (%s)\n", retcode, strerror(retcode)); - } else - sv_setiv( ST(0), PTR2IV(RETVAL)); - - -void -dl_undef_symbols() - PPCODE: - - - -# These functions should not need changing on any platform: - -void -dl_install_xsub(perl_name, symref, filename="$Package") - char * perl_name - void * symref - char * filename - CODE: - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%lx)\n", - perl_name, (unsigned long) symref)); - ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, - (void(*)(pTHX_ CV *))symref, - filename))); - - -char * -dl_error() - CODE: - RETVAL = LastError ; - OUTPUT: - RETVAL - -# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_dld.xs b/contrib/perl5/ext/DynaLoader/dl_dld.xs deleted file mode 100644 index d8fad2a..0000000 --- a/contrib/perl5/ext/DynaLoader/dl_dld.xs +++ /dev/null @@ -1,177 +0,0 @@ -/* - * Written 3/1/94, Robert Sanders <Robert.Sanders@linux.org> - * - * based upon the file "dl.c", which is - * Copyright (c) 1994, Larry Wall - * - * You may distribute under the terms of either the GNU General Public - * License or the Artistic License, as specified in the README file. - * - * $Date: 1994/03/07 00:21:43 $ - * $Source: /home/rsanders/src/perl5alpha6/RCS/dld_dl.c,v $ - * $Revision: 1.4 $ - * $State: Exp $ - * - * $Log: dld_dl.c,v $ - * Removed implicit link against libc. 1994/09/14 William Setzer. - * - * Integrated other DynaLoader changes. 1994/06/08 Tim Bunce. - * - * rewrote dl_load_file, misc updates. 1994/09/03 William Setzer. - * - * Revision 1.4 1994/03/07 00:21:43 rsanders - * added min symbol count for load_libs and switched order so system libs - * are loaded after app-specified libs. - * - * Revision 1.3 1994/03/05 01:17:26 rsanders - * added path searching. - * - * Revision 1.2 1994/03/05 00:52:39 rsanders - * added package-specified libraries. - * - * Revision 1.1 1994/03/05 00:33:40 rsanders - * Initial revision - * - * - */ - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#include <dld.h> /* GNU DLD header file */ -#include <unistd.h> - -#include "dlutils.c" /* for SaveError() etc */ - -static AV *dl_resolve_using = Nullav; -static AV *dl_require_symbols = Nullav; - -static void -dl_private_init(pTHX) -{ - int dlderr; - dl_generic_private_init(aTHX); - dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); - dl_require_symbols = get_av("DynaLoader::dl_require_symbols", GV_ADDMULTI); -#ifdef __linux__ - dlderr = dld_init("/proc/self/exe"); - if (dlderr) { -#endif - dlderr = dld_init(dld_find_executable(PL_origargv[0])); - if (dlderr) { - char *msg = dld_strerror(dlderr); - SaveError(aTHX_ "dld_init(%s) failed: %s", PL_origargv[0], msg); - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "%s", LastError)); - } -#ifdef __linux__ - } -#endif -} - - -MODULE = DynaLoader PACKAGE = DynaLoader - -BOOT: - (void)dl_private_init(); - - -char * -dl_load_file(filename, flags=0) - char * filename - int flags - PREINIT: - int dlderr,x,max; - GV *gv; - CODE: - RETVAL = filename; - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); - if (flags & 0x01) - Perl_croak(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename); - max = AvFILL(dl_require_symbols); - for (x = 0; x <= max; x++) { - char *sym = SvPVX(*av_fetch(dl_require_symbols, x, 0)); - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_create_ref(%s)\n", sym)); - if (dlderr = dld_create_reference(sym)) { - SaveError(aTHX_ "dld_create_reference(%s): %s", sym, - dld_strerror(dlderr)); - goto haverror; - } - } - - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_link(%s)\n", filename)); - if (dlderr = dld_link(filename)) { - SaveError(aTHX_ "dld_link(%s): %s", filename, dld_strerror(dlderr)); - goto haverror; - } - - max = AvFILL(dl_resolve_using); - for (x = 0; x <= max; x++) { - char *sym = SvPVX(*av_fetch(dl_resolve_using, x, 0)); - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_link(%s)\n", sym)); - if (dlderr = dld_link(sym)) { - SaveError(aTHX_ "dld_link(%s): %s", sym, dld_strerror(dlderr)); - goto haverror; - } - } - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "libref=%s\n", RETVAL)); -haverror: - ST(0) = sv_newmortal() ; - if (dlderr == 0) - sv_setiv(ST(0), PTR2IV(RETVAL)); - - -void * -dl_find_symbol(libhandle, symbolname) - void * libhandle - char * symbolname - CODE: - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%x, symbol=%s)\n", - libhandle, symbolname)); - RETVAL = (void *)dld_get_func(symbolname); - /* if RETVAL==NULL we should try looking for a non-function symbol */ - DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref = %x\n", RETVAL)); - ST(0) = sv_newmortal() ; - if (RETVAL == NULL) - SaveError(aTHX_ "dl_find_symbol: Unable to find '%s' symbol", symbolname) ; - else - sv_setiv(ST(0), PTR2IV(RETVAL)); - - -void -dl_undef_symbols() - PPCODE: - if (dld_undefined_sym_count) { - int x; - char **undef_syms = dld_list_undefined_sym(); - EXTEND(SP, dld_undefined_sym_count); - for (x=0; x < dld_undefined_sym_count; x++) - PUSHs(sv_2mortal(newSVpv(undef_syms[x]+1, 0))); - free(undef_syms); - } - - - -# These functions should not need changing on any platform: - -void -dl_install_xsub(perl_name, symref, filename="$Package") - char * perl_name - void * symref - char * filename - CODE: - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n", - perl_name, symref)); - ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, - (void(*)(pTHX_ CV *))symref, - filename))); - - -char * -dl_error() - CODE: - RETVAL = LastError ; - OUTPUT: - RETVAL - -# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_dllload.xs b/contrib/perl5/ext/DynaLoader/dl_dllload.xs deleted file mode 100644 index fe6957a..0000000 --- a/contrib/perl5/ext/DynaLoader/dl_dllload.xs +++ /dev/null @@ -1,189 +0,0 @@ -/* dl_dllload.xs - * - * Platform: OS/390, possibly others that use dllload(),dllfree() (VM/ESA?). - * Authors: John Goodyear && Peter Prymmer - * Created: 28 October 2000 - * Modified: - * 16 January 2001 - based loosely on dl_dlopen.xs. - */ - -/* Porting notes: - - OS/390 Dynamic Loading functions: - - dllload - ------- - dllhandle * dllload(const char *dllName) - - This function takes the name of a dynamic object file and returns - a descriptor which can be used by dlllqueryfn() and/or dllqueryvar() - later. If dllName contains a slash, it is used to locate the dll. - If not then the LIBPATH environment variable is used to - search for the requested dll (at least within the HFS). - It returns NULL on error and sets errno. - - dllfree - ------- - int dllfree(dllhandle *handle); - - dllfree() decrements the load count for the dll and frees - it if the count is 0. It returns zero on success, and - non-zero on failure. - - dllqueryfn && dllqueryvar - ------------------------- - void (* dllqueryfn(dllhandle *handle, const char *function))(); - void * dllqueryvar(dllhandle *handle, const char *symbol); - - dllqueryfn() takes the handle returned from dllload() and the name - of a function to get the address of. If the function was found - a pointer is returned, otherwise NULL is returned. - - dllqueryvar() takes the handle returned from dllload() and the name - of a symbol to get the address of. If the variable was found a - pointer is returned, otherwise NULL is returned. - - The XS dl_find_symbol() first calls dllqueryfn(). If it fails - dlqueryvar() is then called. - - strerror - -------- - char * strerror(int errno) - - Returns a null-terminated string which describes the last error - that occurred with other functions (not necessarily unique to - dll loading). - - Return Types - ============ - In this implementation the two functions, dl_load_file() && - dl_find_symbol(), return (void *). This is primarily because the - dlopen() && dlsym() style dynamic linker calls return (void *). - We suspect that casting to (void *) may be easier than teaching XS - typemaps about the (dllhandle *) type. - - Dealing with Error Messages - =========================== - In order to make the handling of dynamic linking errors as generic as - possible you should store any error messages associated with your - implementation with the StoreError function. - - In the case of OS/390 the function strerror(errno) returns the error - message associated with the last dynamic link error. As the S/390 - dynamic linker functions dllload() && dllqueryvar() both return NULL - on error every call to an S/390 dynamic link routine is coded - like this: - - RETVAL = dllload(filename) ; - if (RETVAL == NULL) - SaveError("%s",strerror(errno)) ; - - Note that SaveError() takes a printf format string. Use a "%s" as - the first parameter if the error may contain any % characters. - - Other comments within the dl_dlopen.xs file may be helpful as well. -*/ - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#include <dll.h> /* the dynamic linker include file for S/390 */ -#include <errno.h> /* strerror() and friends */ - -#include "dlutils.c" /* SaveError() etc */ - -static void -dl_private_init(pTHX) -{ - (void)dl_generic_private_init(aTHX); -} - -MODULE = DynaLoader PACKAGE = DynaLoader - -BOOT: - (void)dl_private_init(aTHX); - - -void * -dl_load_file(filename, flags=0) - char * filename - int flags - PREINIT: - int mode = 0; - CODE: -{ - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); - /* add a (void *) dllload(filename) ; cast if needed */ - RETVAL = dllload(filename) ; - DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%lx\n", (unsigned long) RETVAL)); - ST(0) = sv_newmortal() ; - if (RETVAL == NULL) - SaveError(aTHX_ "%s",strerror(errno)) ; - 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", PTR2ul(libref))); - /* RETVAL = (dllfree((dllhandle *)libref) == 0 ? 1 : 0); */ - RETVAL = (dllfree(libref) == 0 ? 1 : 0); - if (!RETVAL) - SaveError(aTHX_ "%s", strerror(errno)) ; - DLDEBUG(2,PerlIO_printf(Perl_debug_log, " retval = %d\n", RETVAL)); - OUTPUT: - RETVAL - - -void * -dl_find_symbol(libhandle, symbolname) - void * libhandle - char * symbolname - CODE: - DLDEBUG(2, PerlIO_printf(Perl_debug_log, - "dl_find_symbol(handle=%lx, symbol=%s)\n", - (unsigned long) libhandle, symbolname)); - if((RETVAL = (void*)dllqueryfn(libhandle, symbolname)) == NULL) - RETVAL = dllqueryvar(libhandle, symbolname); - DLDEBUG(2, PerlIO_printf(Perl_debug_log, - " symbolref = %lx\n", (unsigned long) RETVAL)); - ST(0) = sv_newmortal() ; - if (RETVAL == NULL) - SaveError(aTHX_ "%s",strerror(errno)) ; - else - sv_setiv( ST(0), PTR2IV(RETVAL)); - - -void -dl_undef_symbols() - PPCODE: - - - -# These functions should not need changing on any platform: - -void -dl_install_xsub(perl_name, symref, filename="$Package") - char * perl_name - void * symref - char * filename - CODE: - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%lx)\n", - perl_name, (unsigned long) symref)); - ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, - (void(*)(pTHX_ CV *))symref, - filename))); - - -char * -dl_error() - CODE: - RETVAL = LastError ; - OUTPUT: - RETVAL - -# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_dlopen.xs b/contrib/perl5/ext/DynaLoader/dl_dlopen.xs deleted file mode 100644 index e1b2a82..0000000 --- a/contrib/perl5/ext/DynaLoader/dl_dlopen.xs +++ /dev/null @@ -1,259 +0,0 @@ -/* dl_dlopen.xs - * - * Platform: SunOS/Solaris, possibly others which use dlopen. - * Author: Paul Marquess (Paul.Marquess@btinternet.com) - * Created: 10th July 1994 - * - * Modified: - * 15th July 1994 - Added code to explicitly save any error messages. - * 3rd August 1994 - Upgraded to v3 spec. - * 9th August 1994 - Changed to use IV - * 10th August 1994 - Tim Bunce: Added RTLD_LAZY, switchable debugging, - * basic FreeBSD support, removed ClearError - * 29th Feburary 2000 - Alan Burlison: Added functionality to close dlopen'd - * files when the interpreter exits - * - */ - -/* Porting notes: - - - Definition of Sunos dynamic Linking functions - ============================================= - In order to make this implementation easier to understand here is a - quick definition of the SunOS Dynamic Linking functions which are - used here. - - dlopen - ------ - void * - dlopen(path, mode) - char * path; - int mode; - - This function takes the name of a dynamic object file and returns - a descriptor which can be used by dlsym later. It returns NULL on - error. - - The mode parameter must be set to 1 for Solaris 1 and to - RTLD_LAZY (==2) on Solaris 2. - - - dlclose - ------- - int - dlclose(handle) - void * handle; - - This function takes the handle returned by a previous invocation of - dlopen and closes the associated dynamic object file. It returns zero - on success, and non-zero on failure. - - - dlsym - ------ - void * - dlsym(handle, symbol) - void * handle; - char * symbol; - - Takes the handle returned from dlopen and the name of a symbol to - get the address of. If the symbol was found a pointer is - returned. It returns NULL on error. If DL_PREPEND_UNDERSCORE is - defined an underscore will be added to the start of symbol. This - is required on some platforms (freebsd). - - dlerror - ------ - char * dlerror() - - Returns a null-terminated string which describes the last error - that occurred with either dlopen or dlsym. After each call to - dlerror the error message will be reset to a null pointer. The - SaveError function is used to save the error as soon as it happens. - - - Return Types - ============ - In this implementation the two functions, dl_load_file & - dl_find_symbol, return void *. This is because the underlying SunOS - dynamic linker calls also return void *. This is not necessarily - the case for all architectures. For example, some implementation - will want to return a char * for dl_load_file. - - If void * is not appropriate for your architecture, you will have to - change the void * to whatever you require. If you are not certain of - how Perl handles C data types, I suggest you start by consulting - Dean Roerich's Perl 5 API document. Also, have a look in the typemap - file (in the ext directory) for a fairly comprehensive list of types - that are already supported. If you are completely stuck, I suggest you - post a message to perl5-porters, comp.lang.perl.misc or if you are really - desperate to me. - - Remember when you are making any changes that the return value from - dl_load_file is used as a parameter in the dl_find_symbol - function. Also the return value from find_symbol is used as a parameter - to install_xsub. - - - Dealing with Error Messages - ============================ - In order to make the handling of dynamic linking errors as generic as - possible you should store any error messages associated with your - implementation with the StoreError function. - - In the case of SunOS the function dlerror returns the error message - associated with the last dynamic link error. As the SunOS dynamic - linker functions dlopen & dlsym both return NULL on error every call - to a SunOS dynamic link routine is coded like this - - RETVAL = dlopen(filename, 1) ; - if (RETVAL == NULL) - SaveError("%s",dlerror()) ; - - Note that SaveError() takes a printf format string. Use a "%s" as - the first parameter if the error may contain any % characters. - -*/ - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#ifdef I_DLFCN -#include <dlfcn.h> /* the dynamic linker include file for Sunos/Solaris */ -#else -#include <nlist.h> -#include <link.h> -#endif - -#ifndef RTLD_LAZY -# define RTLD_LAZY 1 /* Solaris 1 */ -#endif - -#ifndef HAS_DLERROR -# ifdef __NetBSD__ -# define dlerror() strerror(errno) -# else -# define dlerror() "Unknown error - dlerror() not implemented" -# endif -#endif - - -#include "dlutils.c" /* SaveError() etc */ - - -static void -dl_private_init(pTHX) -{ - (void)dl_generic_private_init(aTHX); -} - -MODULE = DynaLoader PACKAGE = DynaLoader - -BOOT: - (void)dl_private_init(aTHX); - - -void * -dl_load_file(filename, flags=0) - char * filename - int flags - PREINIT: - int mode = RTLD_LAZY; - CODE: -{ -#if defined(DLOPEN_WONT_DO_RELATIVE_PATHS) - char pathbuf[PATH_MAX + 2]; - if (*filename != '/' && strchr(filename, '/')) { - if (getcwd(pathbuf, PATH_MAX - strlen(filename))) { - strcat(pathbuf, "/"); - strcat(pathbuf, filename); - filename = pathbuf; - } - } -#endif -#ifdef RTLD_NOW - if (dl_nonlazy) - mode = RTLD_NOW; -#endif - if (flags & 0x01) -#ifdef RTLD_GLOBAL - mode |= RTLD_GLOBAL; -#else - Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename); -#endif - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); - RETVAL = dlopen(filename, mode) ; - DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%lx\n", (unsigned long) RETVAL)); - ST(0) = sv_newmortal() ; - if (RETVAL == NULL) - SaveError(aTHX_ "%s",dlerror()) ; - 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", PTR2ul(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) - void * libhandle - char * symbolname - CODE: -#ifdef DLSYM_NEEDS_UNDERSCORE - symbolname = Perl_form_nocontext("_%s", symbolname); -#endif - DLDEBUG(2, PerlIO_printf(Perl_debug_log, - "dl_find_symbol(handle=%lx, symbol=%s)\n", - (unsigned long) libhandle, symbolname)); - RETVAL = dlsym(libhandle, symbolname); - DLDEBUG(2, PerlIO_printf(Perl_debug_log, - " symbolref = %lx\n", (unsigned long) RETVAL)); - ST(0) = sv_newmortal() ; - if (RETVAL == NULL) - SaveError(aTHX_ "%s",dlerror()) ; - else - sv_setiv( ST(0), PTR2IV(RETVAL)); - - -void -dl_undef_symbols() - PPCODE: - - - -# These functions should not need changing on any platform: - -void -dl_install_xsub(perl_name, symref, filename="$Package") - char * perl_name - void * symref - char * filename - CODE: - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%lx)\n", - perl_name, (unsigned long) symref)); - ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, - (void(*)(pTHX_ CV *))symref, - filename))); - - -char * -dl_error() - CODE: - RETVAL = LastError ; - OUTPUT: - RETVAL - -# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_dyld.xs b/contrib/perl5/ext/DynaLoader/dl_dyld.xs deleted file mode 100644 index 688e474..0000000 --- a/contrib/perl5/ext/DynaLoader/dl_dyld.xs +++ /dev/null @@ -1,226 +0,0 @@ -/* dl_dyld.xs - * - * Platform: Darwin (Mac OS) - * Author: Wilfredo Sanchez <wsanchez@apple.com> - * Based on: dl_next.xs by Paul Marquess - * Based on: dl_dlopen.xs by Anno Siegel - * Created: Aug 15th, 1994 - * - */ - -/* - And Gandalf said: 'Many folk like to know beforehand what is to - be set on the table; but those who have laboured to prepare the - feast like to keep their secret; for wonder makes the words of - praise louder.' -*/ - -/* Porting notes: - -dl_dyld.xs is based on dl_next.xs by Anno Siegel. - -dl_next.xs is in turn a port from dl_dlopen.xs by Paul Marquess. It -should not be used as a base for further ports though it may be used -as an example for how dl_dlopen.xs can be ported to other platforms. - -The method used here is just to supply the sun style dlopen etc. -functions in terms of NeXT's/Apple's dyld. The xs code proper is -unchanged from Paul's original. - -The port could use some streamlining. For one, error handling could -be simplified. - -This should be useable as a replacement for dl_next.xs, but it has not -been tested on NeXT platforms. - - Wilfredo Sanchez - -*/ - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#define DL_LOADONCEONLY - -#include "dlutils.c" /* SaveError() etc */ - -#undef environ -#undef bool -#import <mach-o/dyld.h> - -static char * dl_last_error = (char *) 0; -static AV *dl_resolve_using = Nullav; - -static char *dlerror() -{ - return dl_last_error; -} - -int dlclose(handle) /* stub only */ -void *handle; -{ - return 0; -} - -enum dyldErrorSource -{ - OFImage, -}; - -static void TranslateError - (const char *path, enum dyldErrorSource type, int number) -{ - dTHX; - char *error; - unsigned int index; - static char *OFIErrorStrings[] = - { - "%s(%d): Object Image Load Failure\n", - "%s(%d): Object Image Load Success\n", - "%s(%d): Not an recognisable object file\n", - "%s(%d): No valid architecture\n", - "%s(%d): Object image has an invalid format\n", - "%s(%d): Invalid access (permissions?)\n", - "%s(%d): Unknown error code from NSCreateObjectFileImageFromFile\n", - }; -#define NUM_OFI_ERRORS (sizeof(OFIErrorStrings) / sizeof(OFIErrorStrings[0])) - - switch (type) - { - case OFImage: - index = number; - if (index > NUM_OFI_ERRORS - 1) - index = NUM_OFI_ERRORS - 1; - error = Perl_form_nocontext(OFIErrorStrings[index], path, number); - break; - - default: - error = Perl_form_nocontext("%s(%d): Totally unknown error type %d\n", - path, number, type); - break; - } - safefree(dl_last_error); - dl_last_error = savepv(error); -} - -static char *dlopen(char *path, int mode /* mode is ignored */) -{ - int dyld_result; - NSObjectFileImage ofile; - NSModule handle = NULL; - - dyld_result = NSCreateObjectFileImageFromFile(path, &ofile); - if (dyld_result != NSObjectFileImageSuccess) - TranslateError(path, OFImage, dyld_result); - else - { - // NSLinkModule will cause the run to abort on any link error's - // not very friendly but the error recovery functionality is limited. - handle = NSLinkModule(ofile, path, TRUE); - } - - return handle; -} - -void * -dlsym(handle, symbol) -void *handle; -char *symbol; -{ - void *addr; - - if (NSIsSymbolNameDefined(symbol)) - addr = NSAddressOfSymbol(NSLookupAndBindSymbol(symbol)); - else - addr = NULL; - - return addr; -} - - - -/* ----- code from dl_dlopen.xs below here ----- */ - - -static void -dl_private_init(pTHX) -{ - (void)dl_generic_private_init(aTHX); - dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); -} - -MODULE = DynaLoader PACKAGE = DynaLoader - -BOOT: - (void)dl_private_init(aTHX); - - - -void * -dl_load_file(filename, flags=0) - char * filename - int flags - PREINIT: - int mode = 1; - CODE: - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); - if (flags & 0x01) - Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename); - RETVAL = dlopen(filename, mode) ; - DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL)); - ST(0) = sv_newmortal() ; - if (RETVAL == NULL) - SaveError(aTHX_ "%s",dlerror()) ; - else - sv_setiv( ST(0), PTR2IV(RETVAL) ); - - -void * -dl_find_symbol(libhandle, symbolname) - void * libhandle - char * symbolname - CODE: - symbolname = Perl_form_nocontext("_%s", symbolname); - DLDEBUG(2, PerlIO_printf(Perl_debug_log, - "dl_find_symbol(handle=%lx, symbol=%s)\n", - (unsigned long) libhandle, symbolname)); - RETVAL = dlsym(libhandle, symbolname); - DLDEBUG(2, PerlIO_printf(Perl_debug_log, - " symbolref = %lx\n", (unsigned long) RETVAL)); - ST(0) = sv_newmortal() ; - if (RETVAL == NULL) - SaveError(aTHX_ "%s",dlerror()) ; - else - sv_setiv( ST(0), PTR2IV(RETVAL) ); - - -void -dl_undef_symbols() - PPCODE: - - - -# These functions should not need changing on any platform: - -void -dl_install_xsub(perl_name, symref, filename="$Package") - char * perl_name - void * symref - char * filename - CODE: - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n", - perl_name, symref)); - ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, - (void(*)(pTHX_ CV *))symref, - filename))); - - -char * -dl_error() - CODE: - RETVAL = LastError ; - OUTPUT: - RETVAL - -# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_hpux.xs b/contrib/perl5/ext/DynaLoader/dl_hpux.xs deleted file mode 100644 index 582c047..0000000 --- a/contrib/perl5/ext/DynaLoader/dl_hpux.xs +++ /dev/null @@ -1,159 +0,0 @@ -/* - * Author: Jeff Okamoto (okamoto@corp.hp.com) - * Version: 2.1, 1995/1/25 - */ - -/* o Added BIND_VERBOSE to dl_nonlazy condition to add names of missing - * symbols to stderr message on fatal error. - * - * o Added BIND_NONFATAL comment to default condition. - * - * Chuck Phillips (cdp@fc.hp.com) - * Version: 2.2, 1997/5/4 */ - -#ifdef __hp9000s300 -#define magic hpux_magic -#define MAGIC HPUX_MAGIC -#endif - -#include <dl.h> -#ifdef __hp9000s300 -#undef magic -#undef MAGIC -#endif - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - - -#include "dlutils.c" /* for SaveError() etc */ - -static AV *dl_resolve_using = Nullav; - - -static void -dl_private_init(pTHX) -{ - (void)dl_generic_private_init(aTHX); - dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); -} - -MODULE = DynaLoader PACKAGE = DynaLoader - -BOOT: - (void)dl_private_init(aTHX); - - -void * -dl_load_file(filename, flags=0) - char * filename - int flags - PREINIT: - shl_t obj = NULL; - int i, max, bind_type; - CODE: - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); - if (flags & 0x01) - Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename); - if (dl_nonlazy) { - bind_type = BIND_IMMEDIATE|BIND_VERBOSE; - } else { - bind_type = BIND_DEFERRED; - /* For certain libraries, like DCE, deferred binding often causes run - * time problems. Adding BIND_NONFATAL to BIND_IMMEDIATE still allows - * unresolved references in situations like this. */ - /* bind_type = BIND_IMMEDIATE|BIND_NONFATAL; */ - } - /* BIND_NOSTART removed from bind_type because it causes the shared library's */ - /* initialisers not to be run. This causes problems with all of the static objects */ - /* in the library. */ -#ifdef DEBUGGING - if (dl_debug) - bind_type |= BIND_VERBOSE; -#endif /* DEBUGGING */ - - max = AvFILL(dl_resolve_using); - for (i = 0; i <= max; i++) { - char *sym = SvPVX(*av_fetch(dl_resolve_using, i, 0)); - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s) (dependent)\n", sym)); - obj = shl_load(sym, bind_type, 0L); - if (obj == NULL) { - goto end; - } - } - - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s): ", filename)); - obj = shl_load(filename, bind_type, 0L); - - DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", obj)); -end: - ST(0) = sv_newmortal() ; - if (obj == NULL) - SaveError(aTHX_ "%s",Strerror(errno)); - else - sv_setiv( ST(0), PTR2IV(obj) ); - - -void * -dl_find_symbol(libhandle, symbolname) - void * libhandle - char * symbolname - CODE: - shl_t obj = (shl_t) libhandle; - void *symaddr = NULL; - int status; -#ifdef __hp9000s300 - symbolname = Perl_form_nocontext("_%s", symbolname); -#endif - DLDEBUG(2, PerlIO_printf(Perl_debug_log, - "dl_find_symbol(handle=%lx, symbol=%s)\n", - (unsigned long) libhandle, symbolname)); - - ST(0) = sv_newmortal() ; - errno = 0; - - status = shl_findsym(&obj, symbolname, TYPE_PROCEDURE, &symaddr); - DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref(PROCEDURE) = %x\n", symaddr)); - - if (status == -1 && errno == 0) { /* try TYPE_DATA instead */ - status = shl_findsym(&obj, symbolname, TYPE_DATA, &symaddr); - DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref(DATA) = %x\n", symaddr)); - } - - if (status == -1) { - SaveError(aTHX_ "%s",(errno) ? Strerror(errno) : "Symbol not found") ; - } else { - sv_setiv( ST(0), PTR2IV(symaddr) ); - } - - -void -dl_undef_symbols() - PPCODE: - - - -# These functions should not need changing on any platform: - -void -dl_install_xsub(perl_name, symref, filename="$Package") - char * perl_name - void * symref - char * filename - CODE: - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n", - perl_name, symref)); - ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, - (void(*)(pTHX_ CV *))symref, - filename))); - - -char * -dl_error() - CODE: - RETVAL = LastError ; - OUTPUT: - RETVAL - -# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_mac.xs b/contrib/perl5/ext/DynaLoader/dl_mac.xs deleted file mode 100644 index 5f48139..0000000 --- a/contrib/perl5/ext/DynaLoader/dl_mac.xs +++ /dev/null @@ -1,137 +0,0 @@ -/* dl_mac.xs - * - * Platform: Macintosh CFM - * Author: Matthias Neeracher <neeri@iis.ee.ethz.ch> - * Adapted from dl_dlopen.xs reference implementation by - * Paul Marquess (pmarquess@bfsec.bt.co.uk) - * $Log: dl_mac.xs,v $ - * Revision 1.3 1998/04/07 01:47:24 neeri - * MacPerl 5.2.0r4b1 - * - * Revision 1.2 1997/08/08 16:39:18 neeri - * MacPerl 5.1.4b1 + time() fix - * - * Revision 1.1 1997/04/07 20:48:23 neeri - * Synchronized with MacPerl 5.1.4a1 - * - */ - -#define MAC_CONTEXT -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#include <CodeFragments.h> - - -#include "dlutils.c" /* SaveError() etc */ - -typedef CFragConnectionID ConnectionID; - -static ConnectionID ** connections; - -static void terminate(void) -{ - int size = GetHandleSize((Handle) connections) / sizeof(ConnectionID); - HLock((Handle) connections); - while (size) - CloseConnection(*connections + --size); - DisposeHandle((Handle) connections); - connections = nil; -} - -static void -dl_private_init(pTHX) -{ - (void)dl_generic_private_init(aTHX); -} - -MODULE = DynaLoader PACKAGE = DynaLoader - -BOOT: - (void)dl_private_init(aTHX); - - -ConnectionID -dl_load_file(filename, flags=0) - char * filename - int flags - PREINIT: - OSErr err; - FSSpec spec; - ConnectionID connID; - Ptr mainAddr; - Str255 errName; - CODE: - DLDEBUG(1,PerlIO_printf(Perl_debug_log,"dl_load_file(%s):\n", filename)); - err = GUSIPath2FSp(filename, &spec); - if (!err) - err = - GetDiskFragment( - &spec, 0, 0, spec.name, kLoadCFrag, &connID, &mainAddr, errName); - if (!err) { - if (!connections) { - connections = (ConnectionID **)NewHandle(0); - atexit(terminate); - } - PtrAndHand((Ptr) &connID, (Handle) connections, sizeof(ConnectionID)); - RETVAL = connID; - } else - RETVAL = (ConnectionID) 0; - DLDEBUG(2,PerlIO_printf(Perl_debug_log," libref=%d\n", RETVAL)); - ST(0) = sv_newmortal() ; - if (err) - SaveError(aTHX_ "DynaLoader error [%d, %#s]", err, errName) ; - else - sv_setiv( ST(0), (IV)RETVAL); - -void * -dl_find_symbol(connID, symbol) - ConnectionID connID - Str255 symbol - CODE: - { - OSErr err; - Ptr symAddr; - CFragSymbolClass symClass; - DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_find_symbol(handle=%x, symbol=%#s)\n", - connID, symbol)); - err = FindSymbol(connID, symbol, &symAddr, &symClass); - if (err) - symAddr = (Ptr) 0; - RETVAL = (void *) symAddr; - DLDEBUG(2,PerlIO_printf(Perl_debug_log," symbolref = %x\n", RETVAL)); - ST(0) = sv_newmortal() ; - if (err) - SaveError(aTHX_ "DynaLoader error [%d]!", err) ; - else - sv_setiv( ST(0), (IV)RETVAL); - } - -void -dl_undef_symbols() - PPCODE: - - - -# These functions should not need changing on any platform: - -void -dl_install_xsub(perl_name, symref, filename="$Package") - char * perl_name - void * symref - char * filename - CODE: - DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_install_xsub(name=%s, symref=%x)\n", - perl_name, symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); - - -char * -dl_error() - CODE: - RETVAL = LastError ; - OUTPUT: - RETVAL - -# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_mpeix.xs b/contrib/perl5/ext/DynaLoader/dl_mpeix.xs deleted file mode 100644 index 7d27901..0000000 --- a/contrib/perl5/ext/DynaLoader/dl_mpeix.xs +++ /dev/null @@ -1,131 +0,0 @@ -/* - * Author: Mark Klein (mklein@dis.com) - * Version: 2.1, 1996/07/25 - * Version: 2.2, 1997/09/25 Mark Bixby (markb@cccd.edu) - * Version: 2.3, 1998/11/19 Mark Bixby (markb@cccd.edu) - */ - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#ifdef __GNUC__ -extern void HPGETPROCPLABEL( int parms, - char * procname, - int * plabel, - int * status, - char * firstfile, - int casesensitive, - int symboltype, - int * datasize, - int position, - int searchpath, - int binding); -#else -#pragma intrinsic HPGETPROCPLABEL -#endif -#include "dlutils.c" /* for SaveError() etc */ - -typedef struct { - char filename[PATH_MAX + 3]; - } t_mpe_dld, *p_mpe_dld; - -static AV *dl_resolve_using = Nullav; - -static void -dl_private_init(pTHX) -{ - (void)dl_generic_private_init(aTHX); - dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); -} - -MODULE = DynaLoader PACKAGE = DynaLoader - -BOOT: - (void)dl_private_init(aTHX); - -void * -dl_load_file(filename, flags=0) - char * filename - int flags - PREINIT: - char buf[PATH_MAX + 3]; - p_mpe_dld obj = NULL; - int i; - CODE: - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename, -flags)); - if (flags & 0x01) - Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s -",filename); - obj = (p_mpe_dld) safemalloc(sizeof(t_mpe_dld)); - memzero(obj, sizeof(t_mpe_dld)); - if (filename[0] != '/') - { - getcwd(buf,sizeof(buf)); - sprintf(obj->filename," %s/%s ",buf,filename); - } - else - sprintf(obj->filename," %s ",filename); - - DLDEBUG(2,PerlIO_printf(Perl_debug_log," libref=%x\n", obj)); - - ST(0) = sv_newmortal() ; - if (obj == NULL) - SaveError(aTHX_"%s",Strerror(errno)); - else - sv_setiv( ST(0), PTR2IV(obj) ); - -void * -dl_find_symbol(libhandle, symbolname) - void * libhandle - char * symbolname - CODE: - int datalen; - p_mpe_dld obj = (p_mpe_dld) libhandle; - char symname[PATH_MAX + 3]; - void * symaddr = NULL; - int status; - DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_find_symbol(handle=%x, symbol=%s)\n", - libhandle, symbolname)); - ST(0) = sv_newmortal() ; - errno = 0; - - sprintf(symname, " %s ", symbolname); - HPGETPROCPLABEL(8, symname, &symaddr, &status, obj->filename, 1, - 0, &datalen, 1, 0, 0); - - DLDEBUG(2,PerlIO_printf(Perl_debug_log," symbolref(PROCEDURE) = %x, status=%x\n", symaddr, status)); - - if (status != 0) { - SaveError(aTHX_"%s",(errno) ? Strerror(errno) : "Symbol not found") ; - } else { - sv_setiv( ST(0), PTR2IV(symaddr) ); - } - -void -dl_undef_symbols() - PPCODE: - -# These functions should not need changing on any platform: - -void -dl_install_xsub(perl_name, symref, filename="$Package") - char * perl_name - void * symref - char * filename - CODE: - DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_install_xsub(name=%s, symref=%x)\n", - perl_name, symref)); - ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, - (void(*)(pTHX_ CV *))symref, - filename))); - -char * -dl_error() - CODE: - RETVAL = LastError ; - OUTPUT: - RETVAL - -# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_next.xs b/contrib/perl5/ext/DynaLoader/dl_next.xs deleted file mode 100644 index b8c19f2..0000000 --- a/contrib/perl5/ext/DynaLoader/dl_next.xs +++ /dev/null @@ -1,307 +0,0 @@ -/* dl_next.xs - * - * Platform: NeXT NS 3.2 - * Author: Anno Siegel (siegel@zrz.TU-Berlin.DE) - * Based on: dl_dlopen.xs by Paul Marquess - * Created: Aug 15th, 1994 - * - */ - -/* - And Gandalf said: 'Many folk like to know beforehand what is to - be set on the table; but those who have laboured to prepare the - feast like to keep their secret; for wonder makes the words of - praise louder.' -*/ - -/* Porting notes: - -dl_next.xs is itself a port from dl_dlopen.xs by Paul Marquess. It -should not be used as a base for further ports though it may be used -as an example for how dl_dlopen.xs can be ported to other platforms. - -The method used here is just to supply the sun style dlopen etc. -functions in terms of NeXTs rld_*. The xs code proper is unchanged -from Paul's original. - -The port could use some streamlining. For one, error handling could -be simplified. - -Anno Siegel - -*/ - -#if NS_TARGET_MAJOR >= 4 -#else -/* include these before perl headers */ -#include <mach-o/rld.h> -#include <streams/streams.h> -#endif - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#define DL_LOADONCEONLY - -#include "dlutils.c" /* SaveError() etc */ - - -static char * dl_last_error = (char *) 0; -static AV *dl_resolve_using = Nullav; - -static char *dlerror() -{ - return dl_last_error; -} - -int dlclose(handle) /* stub only */ -void *handle; -{ - return 0; -} - -#if NS_TARGET_MAJOR >= 4 -#import <mach-o/dyld.h> - -enum dyldErrorSource -{ - OFImage, -}; - -static void TranslateError - (const char *path, enum dyldErrorSource type, int number) -{ - dTHX; - char *error; - unsigned int index; - static char *OFIErrorStrings[] = - { - "%s(%d): Object Image Load Failure\n", - "%s(%d): Object Image Load Success\n", - "%s(%d): Not an recognisable object file\n", - "%s(%d): No valid architecture\n", - "%s(%d): Object image has an invalid format\n", - "%s(%d): Invalid access (permissions?)\n", - "%s(%d): Unknown error code from NSCreateObjectFileImageFromFile\n", - }; -#define NUM_OFI_ERRORS (sizeof(OFIErrorStrings) / sizeof(OFIErrorStrings[0])) - - switch (type) - { - case OFImage: - index = number; - if (index > NUM_OFI_ERRORS - 1) - index = NUM_OFI_ERRORS - 1; - error = Perl_form_nocontext(OFIErrorStrings[index], path, number); - break; - - default: - error = Perl_form_nocontext("%s(%d): Totally unknown error type %d\n", - path, number, type); - break; - } - Safefree(dl_last_error); - dl_last_error = savepv(error); -} - -static char *dlopen(char *path, int mode /* mode is ignored */) -{ - int dyld_result; - NSObjectFileImage ofile; - NSModule handle = NULL; - - dyld_result = NSCreateObjectFileImageFromFile(path, &ofile); - if (dyld_result != NSObjectFileImageSuccess) - TranslateError(path, OFImage, dyld_result); - else - { - // NSLinkModule will cause the run to abort on any link error's - // not very friendly but the error recovery functionality is limited. - handle = NSLinkModule(ofile, path, TRUE); - } - - return handle; -} - -void * -dlsym(handle, symbol) -void *handle; -char *symbol; -{ - void *addr; - - if (NSIsSymbolNameDefined(symbol)) - addr = NSAddressOfSymbol(NSLookupAndBindSymbol(symbol)); - else - addr = NULL; - - return addr; -} - -#else /* NS_TARGET_MAJOR <= 3 */ - -static NXStream *OpenError(void) -{ - return NXOpenMemory( (char *) 0, 0, NX_WRITEONLY); -} - -static void TransferError(NXStream *s) -{ - char *buffer; - int len, maxlen; - - if ( dl_last_error ) { - Safefree(dl_last_error); - } - NXGetMemoryBuffer(s, &buffer, &len, &maxlen); - New(1097, dl_last_error, len, char); - strcpy(dl_last_error, buffer); -} - -static void CloseError(NXStream *s) -{ - if ( s ) { - NXCloseMemory( s, NX_FREEBUFFER); - } -} - -static char *dlopen(char *path, int mode /* mode is ignored */) -{ - int rld_success; - NXStream *nxerr; - I32 i, psize; - char *result; - char **p; - STRLEN n_a; - - /* Do not load what is already loaded into this process */ - if (hv_fetch(dl_loaded_files, path, strlen(path), 0)) - return path; - - nxerr = OpenError(); - psize = AvFILL(dl_resolve_using) + 3; - p = (char **) safemalloc(psize * sizeof(char*)); - p[0] = path; - for(i=1; i<psize-1; i++) { - p[i] = SvPVx(*av_fetch(dl_resolve_using, i-1, TRUE), n_a); - } - p[psize-1] = 0; - rld_success = rld_load(nxerr, (struct mach_header **)0, p, - (const char *) 0); - safefree((char*) p); - if (rld_success) { - result = path; - /* prevent multiple loads of same file into same process */ - hv_store(dl_loaded_files, path, strlen(path), &PL_sv_yes, 0); - } else { - TransferError(nxerr); - result = (char*) 0; - } - CloseError(nxerr); - return result; -} - -void * -dlsym(handle, symbol) -void *handle; -char *symbol; -{ - NXStream *nxerr = OpenError(); - unsigned long symref = 0; - - if (!rld_lookup(nxerr, Perl_form_nocontext("_%s", symbol), &symref)) - TransferError(nxerr); - CloseError(nxerr); - return (void*) symref; -} - -#endif /* NS_TARGET_MAJOR >= 4 */ - - -/* ----- code from dl_dlopen.xs below here ----- */ - - -static void -dl_private_init(pTHX) -{ - (void)dl_generic_private_init(aTHX); - dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); -} - -MODULE = DynaLoader PACKAGE = DynaLoader - -BOOT: - (void)dl_private_init(aTHX); - - - -void * -dl_load_file(filename, flags=0) - char * filename - int flags - PREINIT: - int mode = 1; - CODE: - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); - if (flags & 0x01) - Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename); - RETVAL = dlopen(filename, mode) ; - DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL)); - ST(0) = sv_newmortal() ; - if (RETVAL == NULL) - SaveError(aTHX_ "%s",dlerror()) ; - else - sv_setiv( ST(0), PTR2IV(RETVAL) ); - - -void * -dl_find_symbol(libhandle, symbolname) - void * libhandle - char * symbolname - CODE: -#if NS_TARGET_MAJOR >= 4 - symbolname = Perl_form_nocontext("_%s", symbolname); -#endif - DLDEBUG(2, PerlIO_printf(Perl_debug_log, - "dl_find_symbol(handle=%lx, symbol=%s)\n", - (unsigned long) libhandle, symbolname)); - RETVAL = dlsym(libhandle, symbolname); - DLDEBUG(2, PerlIO_printf(Perl_debug_log, - " symbolref = %lx\n", (unsigned long) RETVAL)); - ST(0) = sv_newmortal() ; - if (RETVAL == NULL) - SaveError(aTHX_ "%s",dlerror()) ; - else - sv_setiv( ST(0), PTR2IV(RETVAL) ); - - -void -dl_undef_symbols() - PPCODE: - - - -# These functions should not need changing on any platform: - -void -dl_install_xsub(perl_name, symref, filename="$Package") - char * perl_name - void * symref - char * filename - CODE: - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n", - perl_name, symref)); - ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, - (void(*)(pTHX_ CV *))symref, - filename))); - - -char * -dl_error() - CODE: - RETVAL = LastError ; - OUTPUT: - RETVAL - -# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_none.xs b/contrib/perl5/ext/DynaLoader/dl_none.xs deleted file mode 100644 index 5a193e4..0000000 --- a/contrib/perl5/ext/DynaLoader/dl_none.xs +++ /dev/null @@ -1,19 +0,0 @@ -/* dl_none.xs - * - * Stubs for platforms that do not support dynamic linking - */ - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -MODULE = DynaLoader PACKAGE = DynaLoader - -char * -dl_error() - CODE: - RETVAL = "Not implemented"; - OUTPUT: - RETVAL - -# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_vmesa.xs b/contrib/perl5/ext/DynaLoader/dl_vmesa.xs deleted file mode 100644 index 8595e44..0000000 --- a/contrib/perl5/ext/DynaLoader/dl_vmesa.xs +++ /dev/null @@ -1,175 +0,0 @@ -/* dl_vmesa.xs - * - * Platform: VM/ESA, possibly others which use dllload etc. - * Author: Neale Ferguson (neale@mailbox.tabnsw.com.au) - * Created: 23rd Septemer, 1998 - * - * - */ - -/* Porting notes: - - - Definition of VM/ESA dynamic Linking functions - ============================================== - In order to make this implementation easier to understand here is a - quick definition of the VM/ESA Dynamic Linking functions which are - used here. - - dlopen - ------ - void * - dlopen(const char *path) - - This function takes the name of a dynamic object file and returns - a descriptor which can be used by dlsym later. It returns NULL on - error. - - - dllsym - ------ - void * - dlsym(void *handle, char *symbol) - - Takes the handle returned from dlopen and the name of a symbol to - get the address of. If the symbol was found a pointer is - returned. It returns NULL on error. - - dlerror - ------- - char * dlerror() - - Returns a null-terminated string which describes the last error - that occurred with the other dll functions. After each call to - dlerror the error message will be reset to a null pointer. The - SaveError function is used to save the error as soo as it happens. - - - Return Types - ============ - In this implementation the two functions, dl_load_file & - dl_find_symbol, return void *. This is because the underlying SunOS - dynamic linker calls also return void *. This is not necessarily - the case for all architectures. For example, some implementation - will want to return a char * for dl_load_file. - - If void * is not appropriate for your architecture, you will have to - change the void * to whatever you require. If you are not certain of - how Perl handles C data types, I suggest you start by consulting - Dean Roerich's Perl 5 API document. Also, have a look in the typemap - file (in the ext directory) for a fairly comprehensive list of types - that are already supported. If you are completely stuck, I suggest you - post a message to perl5-porters, comp.lang.perl.misc or if you are really - desperate to me. - - Remember when you are making any changes that the return value from - dl_load_file is used as a parameter in the dl_find_symbol - function. Also the return value from find_symbol is used as a parameter - to install_xsub. - - - Dealing with Error Messages - ============================ - In order to make the handling of dynamic linking errors as generic as - possible you should store any error messages associated with your - implementation with the StoreError function. - - In the case of VM/ESA the function dlerror returns the error message - associated with the last dynamic link error. As the VM/ESA dynamic - linker functions return NULL on error every call to a VM/ESA dynamic - dynamic link routine is coded like this - - RETVAL = dlopen(filename) ; - if (RETVAL == NULL) - SaveError(aTHX_ "%s",dlerror()) ; - - Note that SaveError() takes a printf format string. Use a "%s" as - the first parameter if the error may contain and % characters. - -*/ - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" -#include <dll.h> - - -#include "dlutils.c" /* SaveError() etc */ - - -static void -dl_private_init(pTHX) -{ - (void)dl_generic_private_init(aTHX); -} - -MODULE = DynaLoader PACKAGE = DynaLoader - -BOOT: - (void)dl_private_init(aTHX); - - -void * -dl_load_file(filename, flags=0) - char * filename - int flags - CODE: - if (flags & 0x01) - Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename); - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); - RETVAL = dlopen(filename) ; - DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%lx\n", (unsigned long) RETVAL)); - ST(0) = sv_newmortal() ; - if (RETVAL == NULL) - SaveError(aTHX_ "%s",dlerror()) ; - else - sv_setiv( ST(0), PTR2IV(RETVAL) ); - - -void * -dl_find_symbol(libhandle, symbolname) - void * libhandle - char * symbolname - CODE: - DLDEBUG(2, PerlIO_printf(Perl_debug_log, - "dl_find_symbol(handle=%lx, symbol=%s)\n", - (unsigned long) libhandle, symbolname)); - RETVAL = dlsym(libhandle, symbolname); - DLDEBUG(2, PerlIO_printf(Perl_debug_log, - " symbolref = %lx\n", (unsigned long) RETVAL)); - ST(0) = sv_newmortal() ; - if (RETVAL == NULL) - SaveError(aTHX_ "%s",dlerror()) ; - else - sv_setiv( ST(0), PTR2IV(RETVAL) ); - - -void -dl_undef_symbols() - PPCODE: - - - -# These functions should not need changing on any platform: - -void -dl_install_xsub(perl_name, symref, filename="$Package") - char * perl_name - void * symref - char * filename - CODE: - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%lx)\n", - perl_name, (unsigned long) symref)); - ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, - (void(*)(pTHX_ CV *))symref, - filename))); - - -char * -dl_error() - CODE: - RETVAL = LastError ; - OUTPUT: - RETVAL - -# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_vms.xs b/contrib/perl5/ext/DynaLoader/dl_vms.xs deleted file mode 100644 index d7a1f86..0000000 --- a/contrib/perl5/ext/DynaLoader/dl_vms.xs +++ /dev/null @@ -1,367 +0,0 @@ -/* dl_vms.xs - * - * Platform: OpenVMS, VAX or AXP - * Author: Charles Bailey bailey@newman.upenn.edu - * Revised: 12-Dec-1994 - * - * Implementation Note - * This section is added as an aid to users and DynaLoader developers, in - * order to clarify the process of dynamic linking under VMS. - * dl_vms.xs uses the supported VMS dynamic linking call, which allows - * a running program to map an arbitrary file of executable code and call - * routines within that file. This is done via the VMS RTL routine - * lib$find_image_symbol, whose calling sequence is as follows: - * status = lib$find_image_symbol(imgname,symname,symval,defspec); - * where - * status = a standard VMS status value (unsigned long int) - * imgname = a fixed-length string descriptor, passed by - * reference, containing the NAME ONLY of the image - * file to be mapped. An attempt will be made to - * translate this string as a logical name, so it may - * not contain any characters which are not allowed in - * logical names. If no translation is found, imgname - * is used directly as the name of the image file. - * symname = a fixed-length string descriptor, passed by - * reference, containing the name of the routine - * to be located. - * symval = an unsigned long int, passed by reference, into - * which is written the entry point address of the - * routine whose name is specified in symname. - * defspec = a fixed-length string descriptor, passed by - * reference, containing a default file specification - * whichis used to fill in any missing parts of the - * image file specification after the imgname argument - * is processed. - * In order to accommodate the handling of the imgname argument, the routine - * dl_expandspec() is provided for use by perl code (e.g. dl_findfile) - * which wants to see what image file lib$find_image_symbol would use if - * it were passed a given file specification. The file specification passed - * to dl_expandspec() and dl_load_file() can be partial or complete, and can - * use VMS or Unix syntax; these routines perform the necessary conversions. - * In general, writers of perl extensions need only conform to the - * procedures set out in the DynaLoader documentation, and let the details - * be taken care of by the routines here and in DynaLoader.pm. If anyone - * comes across any incompatibilities, please let me know. Thanks. - * - */ - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#include "dlutils.c" /* dl_debug, LastError; SaveError not used */ - -static AV *dl_require_symbols = Nullav; - -/* N.B.: - * dl_debug and LastError are static vars; you'll need to deal - * with them appropriately if you need context independence - */ - -#include <descrip.h> -#include <fscndef.h> -#include <lib$routines.h> -#include <rms.h> -#include <ssdef.h> -#include <starlet.h> - -#if defined(VMS_WE_ARE_CASE_SENSITIVE) -#define DL_CASE_SENSITIVE 1<<4 -#else -#define DL_CASE_SENSITIVE 0 -#endif - -typedef unsigned long int vmssts; - -struct libref { - struct dsc$descriptor_s name; - struct dsc$descriptor_s defspec; -}; - -/* Static data for dl_expand_filespec() - This is static to save - * initialization on each call; if you need context-independence, - * just make these auto variables in dl_expandspec() and dl_load_file() - */ -static char dlesa[NAM$C_MAXRSS], dlrsa[NAM$C_MAXRSS]; -static struct FAB dlfab; -static struct NAM dlnam; - -/* $PutMsg action routine - records error message in LastError */ -static vmssts -copy_errmsg(msg,unused) - struct dsc$descriptor_s * msg; - vmssts unused; -{ - if (*(msg->dsc$a_pointer) == '%') { /* first line */ - if (LastError) - strncpy((LastError = saferealloc(LastError,msg->dsc$w_length+1)), - msg->dsc$a_pointer, msg->dsc$w_length); - else - strncpy((LastError = safemalloc(msg->dsc$w_length+1)), - msg->dsc$a_pointer, msg->dsc$w_length); - LastError[msg->dsc$w_length] = '\0'; - } - else { /* continuation line */ - int errlen = strlen(LastError); - LastError = saferealloc(LastError, errlen + msg->dsc$w_length + 2); - LastError[errlen] = '\n'; LastError[errlen+1] = '\0'; - strncat(LastError, msg->dsc$a_pointer, msg->dsc$w_length); - LastError[errlen+msg->dsc$w_length+1] = '\0'; - } - return 0; -} - -/* Use $PutMsg to retrieve error message for failure status code */ -static void -dl_set_error(sts,stv) - vmssts sts; - vmssts stv; -{ - vmssts vec[3]; - dTHX; - - vec[0] = stv ? 2 : 1; - vec[1] = sts; vec[2] = stv; - _ckvmssts(sys$putmsg(vec,copy_errmsg,0,0)); -} - -static unsigned int -findsym_handler(void *sig, void *mech) -{ - dTHX; - unsigned long int myvec[8],args, *usig = (unsigned long int *) sig; - /* Be paranoid and assume signal vector passed in might be readonly */ - myvec[0] = args = usig[0] > 10 ? 9 : usig[0] - 1; - while (--args) myvec[args] = usig[args]; - _ckvmssts(sys$putmsg(myvec,copy_errmsg,0,0)); - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "findsym_handler: received\n\t%s\n",LastError)); - return SS$_CONTINUE; -} - -/* wrapper for lib$find_image_symbol, so signalled errors can be saved - * for dl_error and then returned */ -static unsigned long int -my_find_image_symbol(struct dsc$descriptor_s *imgname, - struct dsc$descriptor_s *symname, - void (**entry)(), - struct dsc$descriptor_s *defspec) -{ - unsigned long int retsts; - VAXC$ESTABLISH(findsym_handler); - retsts = lib$find_image_symbol(imgname,symname,entry,defspec,DL_CASE_SENSITIVE); - return retsts; -} - - -static void -dl_private_init(pTHX) -{ - dl_generic_private_init(aTHX); - dl_require_symbols = get_av("DynaLoader::dl_require_symbols", 0x4); - /* Set up the static control blocks for dl_expand_filespec() */ - dlfab = cc$rms_fab; - dlnam = cc$rms_nam; - dlfab.fab$l_nam = &dlnam; - dlnam.nam$l_esa = dlesa; - dlnam.nam$b_ess = sizeof dlesa; - dlnam.nam$l_rsa = dlrsa; - dlnam.nam$b_rss = sizeof dlrsa; -} -MODULE = DynaLoader PACKAGE = DynaLoader - -BOOT: - (void)dl_private_init(aTHX); - -void -dl_expandspec(filespec) - char * filespec - CODE: - char vmsspec[NAM$C_MAXRSS], defspec[NAM$C_MAXRSS]; - size_t deflen; - vmssts sts; - - tovmsspec(filespec,vmsspec); - dlfab.fab$l_fna = vmsspec; - dlfab.fab$b_fns = strlen(vmsspec); - dlfab.fab$l_dna = 0; - dlfab.fab$b_dns = 0; - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_expand_filespec(%s):\n",vmsspec)); - /* On the first pass, just parse the specification string */ - dlnam.nam$b_nop = NAM$M_SYNCHK; - sts = sys$parse(&dlfab); - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tSYNCHK sys$parse = %d\n",sts)); - if (!(sts & 1)) { - dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); - ST(0) = &PL_sv_undef; - } - else { - /* Now set up a default spec - everything but the name */ - deflen = dlnam.nam$l_name - dlesa; - memcpy(defspec,dlesa,deflen); - memcpy(defspec+deflen,dlnam.nam$l_type, - dlnam.nam$b_type + dlnam.nam$b_ver); - deflen += dlnam.nam$b_type + dlnam.nam$b_ver; - memcpy(vmsspec,dlnam.nam$l_name,dlnam.nam$b_name); - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tsplit filespec: name = %.*s, default = %.*s\n", - dlnam.nam$b_name,vmsspec,deflen,defspec)); - /* . . . and go back to expand it */ - dlnam.nam$b_nop = 0; - dlfab.fab$l_dna = defspec; - dlfab.fab$b_dns = deflen; - dlfab.fab$b_fns = dlnam.nam$b_name; - sts = sys$parse(&dlfab); - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tname/default sys$parse = %d\n",sts)); - if (!(sts & 1)) { - dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); - ST(0) = &PL_sv_undef; - } - else { - /* Now find the actual file */ - sts = sys$search(&dlfab); - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tsys$search = %d\n",sts)); - if (!(sts & 1)) { - dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); - ST(0) = &PL_sv_undef; - } - else { - ST(0) = sv_2mortal(newSVpvn(dlnam.nam$l_rsa,dlnam.nam$b_rsl)); - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "\tresult = \\%.*s\\\n", - dlnam.nam$b_rsl,dlnam.nam$l_rsa)); - } - } - } - -void -dl_load_file(filespec, flags) - char * filespec - int flags - PREINIT: - dTHX; - char vmsspec[NAM$C_MAXRSS]; - SV *reqSV, **reqSVhndl; - STRLEN deflen; - struct dsc$descriptor_s - specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}, - symdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; - struct fscnlst { - unsigned short int len; - unsigned short int code; - char *string; - } namlst[2] = {{0,FSCN$_NAME,0},{0,0,0}}; - struct libref *dlptr; - vmssts sts, failed = 0; - void (*entry)(); - CODE: - - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filespec,flags)); - specdsc.dsc$a_pointer = tovmsspec(filespec,vmsspec); - specdsc.dsc$w_length = strlen(specdsc.dsc$a_pointer); - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tVMS-ified filespec is %s\n", - specdsc.dsc$a_pointer)); - New(1399,dlptr,1,struct libref); - dlptr->name.dsc$b_dtype = dlptr->defspec.dsc$b_dtype = DSC$K_DTYPE_T; - dlptr->name.dsc$b_class = dlptr->defspec.dsc$b_class = DSC$K_CLASS_S; - sts = sys$filescan(&specdsc,namlst,0); - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tsys$filescan: returns %d, name is %.*s\n", - sts,namlst[0].len,namlst[0].string)); - if (!(sts & 1)) { - failed = 1; - dl_set_error(sts,0); - } - else { - dlptr->name.dsc$w_length = namlst[0].len; - dlptr->name.dsc$a_pointer = savepvn(namlst[0].string,namlst[0].len); - dlptr->defspec.dsc$w_length = specdsc.dsc$w_length - namlst[0].len; - New(1097, dlptr->defspec.dsc$a_pointer, dlptr->defspec.dsc$w_length + 1, char); - deflen = namlst[0].string - specdsc.dsc$a_pointer; - memcpy(dlptr->defspec.dsc$a_pointer,specdsc.dsc$a_pointer,deflen); - memcpy(dlptr->defspec.dsc$a_pointer + deflen, - namlst[0].string + namlst[0].len, - dlptr->defspec.dsc$w_length - deflen); - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tlibref = name: %s, defspec: %.*s\n", - dlptr->name.dsc$a_pointer, - dlptr->defspec.dsc$w_length, - dlptr->defspec.dsc$a_pointer)); - if (!(reqSVhndl = av_fetch(dl_require_symbols,0,FALSE)) || !(reqSV = *reqSVhndl)) { - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\t@dl_require_symbols empty, returning untested libref\n")); - } - else { - symdsc.dsc$w_length = SvCUR(reqSV); - symdsc.dsc$a_pointer = SvPVX(reqSV); - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\t$dl_require_symbols[0] = %.*s\n", - symdsc.dsc$w_length, symdsc.dsc$a_pointer)); - sts = my_find_image_symbol(&(dlptr->name),&symdsc, - &entry,&(dlptr->defspec)); - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tlib$find_image_symbol returns %d\n",sts)); - if (!(sts&1)) { - failed = 1; - dl_set_error(sts,0); - } - } - } - - if (failed) { - Safefree(dlptr->name.dsc$a_pointer); - Safefree(dlptr->defspec.dsc$a_pointer); - Safefree(dlptr); - ST(0) = &PL_sv_undef; - } - else { - ST(0) = sv_2mortal(newSViv(PTR2IV(dlptr))); - } - - -void -dl_find_symbol(librefptr,symname) - void * librefptr - SV * symname - CODE: - struct libref thislib = *((struct libref *)librefptr); - struct dsc$descriptor_s - symdsc = {SvCUR(symname),DSC$K_DTYPE_T,DSC$K_CLASS_S,SvPVX(symname)}; - void (*entry)(); - vmssts sts; - - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_find_dymbol(%.*s,%.*s):\n", - thislib.name.dsc$w_length, thislib.name.dsc$a_pointer, - symdsc.dsc$w_length,symdsc.dsc$a_pointer)); - sts = my_find_image_symbol(&(thislib.name),&symdsc, - &entry,&(thislib.defspec)); - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tlib$find_image_symbol returns %d\n",sts)); - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tentry point is %d\n", - (unsigned long int) entry)); - if (!(sts & 1)) { - /* error message already saved by findsym_handler */ - ST(0) = &PL_sv_undef; - } - else ST(0) = sv_2mortal(newSViv(PTR2IV(entry))); - - -void -dl_undef_symbols() - PPCODE: - - -# These functions should not need changing on any platform: - -void -dl_install_xsub(perl_name, symref, filename="$Package") - char * perl_name - void * symref - char * filename - CODE: - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n", - perl_name, symref)); - ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, - (void(*)(pTHX_ CV *))symref, - filename))); - - -char * -dl_error() - CODE: - RETVAL = LastError ; - OUTPUT: - RETVAL - -# end. diff --git a/contrib/perl5/ext/DynaLoader/dlutils.c b/contrib/perl5/ext/DynaLoader/dlutils.c deleted file mode 100644 index 9d88f5f..0000000 --- a/contrib/perl5/ext/DynaLoader/dlutils.c +++ /dev/null @@ -1,106 +0,0 @@ -/* dlutils.c - handy functions and definitions for dl_*.xs files - * - * Currently this file is simply #included into dl_*.xs/.c files. - * It should really be split into a dlutils.h and dlutils.c - * - * Modified: - * 29th Feburary 2000 - Alan Burlison: Added functionality to close dlopen'd - * files when the interpreter exits - */ - - -/* pointer to allocated memory for last error message */ -static char *LastError = (char*)NULL; - -/* flag for immediate rather than lazy linking (spots unresolved symbol) */ -static int dl_nonlazy = 0; - -#ifdef DL_LOADONCEONLY -static HV *dl_loaded_files = Nullhv; /* only needed on a few systems */ -#endif - - -#ifdef DEBUGGING -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) -#endif - - -/* Close all dlopen'd files */ -static void -dl_unload_all_files(pTHXo_ void *unused) -{ - CV *sub; - AV *dl_librefs; - SV *dl_libref; - - if ((sub = get_cv("DynaLoader::dl_unload_file", FALSE)) != NULL) { - dl_librefs = get_av("DynaLoader::dl_librefs", FALSE); - while ((dl_libref = av_pop(dl_librefs)) != &PL_sv_undef) { - dSP; - ENTER; - SAVETMPS; - PUSHMARK(SP); - XPUSHs(sv_2mortal(dl_libref)); - PUTBACK; - call_sv((SV*)sub, G_DISCARD | G_NODEBUG); - FREETMPS; - LEAVE; - } - } -} - - -static void -dl_generic_private_init(pTHXo) /* called by dl_*.xs dl_private_init() */ -{ - char *perl_dl_nonlazy; -#ifdef DEBUGGING - SV *sv = get_sv("DynaLoader::dl_debug", 0); - dl_debug = sv ? SvIV(sv) : 0; -#endif - if ( (perl_dl_nonlazy = getenv("PERL_DL_NONLAZY")) != NULL ) - dl_nonlazy = atoi(perl_dl_nonlazy); - if (dl_nonlazy) - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "DynaLoader bind mode is 'non-lazy'\n")); -#ifdef DL_LOADONCEONLY - 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 -} - - -/* SaveError() takes printf style args and saves the result in LastError */ -static void -SaveError(pTHXo_ char* pat, ...) -{ - va_list args; - SV *msv; - char *message; - STRLEN len; - - /* This code is based on croak/warn, see mess() in util.c */ - - va_start(args, pat); - msv = vmess(pat, &args); - va_end(args); - - message = SvPV(msv,len); - len++; /* include terminating null char */ - - /* Allocate some memory for the error message */ - if (LastError) - LastError = (char*)saferealloc(LastError, len) ; - else - LastError = (char *) safemalloc(len) ; - - /* Copy message into LastError (including terminating null char) */ - strncpy(LastError, message, len) ; - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "DynaLoader: stored error msg '%s'\n",LastError)); -} - diff --git a/contrib/perl5/ext/DynaLoader/hints/aix.pl b/contrib/perl5/ext/DynaLoader/hints/aix.pl deleted file mode 100644 index d4231cc..0000000 --- a/contrib/perl5/ext/DynaLoader/hints/aix.pl +++ /dev/null @@ -1,14 +0,0 @@ -# See dl_aix.xs for details. -use Config; -if ($Config{libs} =~ /-lC/ && -f '/lib/libC.a') { - $self->{CCFLAGS} = $Config{ccflags} . ' -DUSE_libC'; - if (-f '/usr/vacpp/include/load.h') { - $self->{CCFLAGS} .= ' -DUSE_vacpp_load_h'; - } elsif (-f '/usr/ibmcxx/include/load.h') { - $self->{CCFLAGS} .= ' -DUSE_ibmcxx_load_h'; - } elsif (-f '/usr/lpp/xlC/include/load.h') { - $self->{CCFLAGS} .= ' -DUSE_xlC_load_h'; - } elsif (-f '/usr/include/load.h') { - $self->{CCFLAGS} .= ' -DUSE_load_h'; - } -} diff --git a/contrib/perl5/ext/DynaLoader/hints/linux.pl b/contrib/perl5/ext/DynaLoader/hints/linux.pl deleted file mode 100644 index 06f4f4c..0000000 --- a/contrib/perl5/ext/DynaLoader/hints/linux.pl +++ /dev/null @@ -1,4 +0,0 @@ -# XXX Configure test needed. -# Some Linux releases like to hide their <nlist.h> -$self->{CCFLAGS} = $Config{ccflags} . ' -I/usr/include/libelf' - if -f "/usr/include/libelf/nlist.h"; diff --git a/contrib/perl5/ext/DynaLoader/hints/netbsd.pl b/contrib/perl5/ext/DynaLoader/hints/netbsd.pl deleted file mode 100644 index a0fbaf7..0000000 --- a/contrib/perl5/ext/DynaLoader/hints/netbsd.pl +++ /dev/null @@ -1,3 +0,0 @@ -# XXX Configure test needed? -# Some NetBSDs seem to have a dlopen() that won't accept relative paths -$self->{CCFLAGS} = $Config{ccflags} . ' -DDLOPEN_WONT_DO_RELATIVE_PATHS'; diff --git a/contrib/perl5/ext/DynaLoader/hints/openbsd.pl b/contrib/perl5/ext/DynaLoader/hints/openbsd.pl deleted file mode 100644 index aeaa92c..0000000 --- a/contrib/perl5/ext/DynaLoader/hints/openbsd.pl +++ /dev/null @@ -1,3 +0,0 @@ -# XXX Configure test needed? -# Some OpenBSDs seem to have a dlopen() that won't accept relative paths -$self->{CCFLAGS} = $Config{ccflags} . ' -DDLOPEN_WONT_DO_RELATIVE_PATHS'; diff --git a/contrib/perl5/ext/Errno/ChangeLog b/contrib/perl5/ext/Errno/ChangeLog deleted file mode 100644 index dd94b37..0000000 --- a/contrib/perl5/ext/Errno/ChangeLog +++ /dev/null @@ -1,55 +0,0 @@ -Change 171 on 2000-09-12 by <calle@lysator.liu.se> (Calle Dybedahl) - - - Fixed filename-extracting regexp to allow whitespace between - "#" and "line", which the cpp on Unicos 9 produces. - -Change 170 on 1998/07/05 by <gbarr@pobox.com> (Graham Barr) - - Fixed three problems reported by Hans Mulder for NeXT - - - Errno_pm.PL does not recognize #define lines because they have - whitespace before the '#'. ANSI does not allow that in portable - code; that didn't stop the author of NeXT's <errno.h>. - - - Cpp output lines look like this: #1 "errno.c" - Errno_pm.PL does not recognize that format; it wants whitespace - before the line number. - - - Cpp does a syntax check on files with names ending in ".c"; it - reports fatal errors on input lines like: "ENOSYS" [[ENOSYS]] - Workaround: use $Config{cppstdin}, like Errno 1.04 did. - -Change 160 on 1998/06/27 by <gbarr@pobox.com> (Graham Barr) - - - Added patch from Sarathy to support Win32 - - Changed use of $Config{cpp} to $Config{cpprun} as suggested by - Tom Horsley - -Change 159 on 1998/06/27 by <gbarr@pobox.com> (Graham Barr) - - - Changed to use cpp to locate required files - - Moved dummy Errno.pm file into d/ - - Added support for VMS - -Change 158 on 1998/06/27 by <gbarr@pobox.com> (Graham Barr) - - Rename errno.pl to Errno_pm.PL - -Change 146 on 1998/05/31 by <gbarr@pobox.com> (Graham Barr) - - Added ChangeLog to MANIFEST - -Change 140 on 1998/05/23 by <gbarr@pobox.com> (Graham Barr) - - Fix type in errno.pl - -Change 139 on 1998/05/23 by <gbarr@pobox.com> (Graham Barr) - - Moved code to generate Errno.pm into errno.pl - -Change 136 on 1998/05/19 by <gbarr@pobox.com> (Graham Barr) - - Changed to use cpp to locate constants - - Added t/errno.t - diff --git a/contrib/perl5/ext/Errno/Errno_pm.PL b/contrib/perl5/ext/Errno/Errno_pm.PL deleted file mode 100644 index 3f2f3e0..0000000 --- a/contrib/perl5/ext/Errno/Errno_pm.PL +++ /dev/null @@ -1,361 +0,0 @@ -use ExtUtils::MakeMaker; -use Config; -use strict; - -use vars qw($VERSION); - -$VERSION = "1.111"; - -my %err = (); - -unlink "Errno.pm" if -f "Errno.pm"; -open OUT, ">Errno.pm" or die "Cannot open Errno.pm: $!"; -select OUT; -my $file; -foreach $file (get_files()) { - process_file($file); -} -write_errno_pm(); -unlink "errno.c" if -f "errno.c"; - -sub process_file { - my($file) = @_; - - return unless defined $file and -f $file; - - local *FH; - if (($^O eq 'VMS') && ($Config{vms_cc_type} ne 'gnuc')) { - unless(open(FH," LIBRARY/EXTRACT=ERRNO/OUTPUT=SYS\$OUTPUT $file |")) { - warn "Cannot open '$file'"; - return; - } - } elsif ($Config{gccversion} ne '') { - # With the -dM option, gcc outputs every #define it finds - my $ccopts = "-E -dM "; - $ccopts .= "-traditional-cpp " if $^O eq 'darwin'; - unless(open(FH,"$Config{cc} $ccopts $file |")) { - warn "Cannot open '$file'"; - return; - } - } else { - unless(open(FH,"< $file")) { - # This file could be a temporary file created by cppstdin - # so only warn under -w, and return - warn "Cannot open '$file'" if $^W; - return; - } - } - - if ($^O eq 'MacOS') { - while(<FH>) { - $err{$1} = $2 - if /^\s*#\s*define\s+(E\w+)\s+(\d+)/; - } - } else { - while(<FH>) { - $err{$1} = 1 - if /^\s*#\s*define\s+(E\w+)\s+/; - } - } - close(FH); -} - -my $cppstdin; - -sub default_cpp { - unless (defined $cppstdin) { - use File::Spec; - $cppstdin = $Config{cppstdin}; - my $upup_cppstdin = File::Spec->catfile(File::Spec->updir, - File::Spec->updir, - "cppstdin"); - my $cppstdin_is_wrapper = - ($cppstdin eq 'cppstdin' - and -f $upup_cppstdin - and -x $upup_cppstdin); - $cppstdin = $upup_cppstdin if $cppstdin_is_wrapper; - } - return "$cppstdin $Config{cppflags} $Config{cppminus}"; -} - -sub get_files { - my %file = (); - # VMS keeps its include files in system libraries (well, except for Gcc) - if ($^O eq 'VMS') { - if ($Config{vms_cc_type} eq 'decc') { - $file{'Sys$Library:DECC$RTLDEF.TLB'} = 1; - } elsif ($Config{vms_cc_type} eq 'vaxc') { - $file{'Sys$Library:vaxcdef.tlb'} = 1; - } elsif ($Config{vms_cc_type} eq 'gcc') { - $file{'gnu_cc_include:[000000]errno.h'} = 1; - } - } elsif ($^O eq 'os390') { - # OS/390 C compiler doesn't generate #file or #line directives - $file{'/usr/include/errno.h'} = 1; - } elsif ($^O eq 'vmesa') { - # OS/390 C compiler doesn't generate #file or #line directives - $file{'../../vmesa/errno.h'} = 1; - } elsif ($Config{archname} eq 'epoc') { - # Watch out for cross compiling for EPOC (usually done on linux) - $file{'/usr/local/epoc/include/libc/sys/errno.h'} = 1; - } elsif ($^O eq 'linux') { - # Some Linuxes have weird errno.hs which generate - # no #file or #line directives - $file{'/usr/include/errno.h'} = 1; - } elsif ($^O eq 'MacOS') { - # note that we are only getting the GUSI errno's here ... - # we might miss out on compiler-specific ones - $file{"$ENV{GUSI}include:sys:errno.h"} = 1; - - } else { - open(CPPI,"> errno.c") or - die "Cannot open errno.c"; - - print CPPI "#include <errno.h>\n"; - - close(CPPI); - - # invoke CPP and read the output - if ($^O eq 'MSWin32') { - open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or - die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'"; - } else { - my $cpp = default_cpp(); - open(CPPO,"$cpp < errno.c |") or - die "Cannot exec $cpp"; - } - - my $pat; - if ($^O eq 'MSWin32' and $Config{cc} =~ /^bcc/i) { - $pat = '^/\*\s+(.+)\s+\d+\s*:\s+\*/'; - } - else { - $pat = '^#\s*(?:line)?\s*\d+\s+"([^"]+)"'; - } - while(<CPPO>) { - if ($^O eq 'os2' or $^O eq 'MSWin32') { - if (/$pat/o) { - my $f = $1; - $f =~ s,\\\\,/,g; - $file{$f} = 1; - } - } - else { - $file{$1} = 1 if /$pat/o; - } - } - close(CPPO); - } - return keys %file; -} - -sub write_errno_pm { - my $err; - - # quick sanity check - - die "No error definitions found" unless keys %err; - - # create the CPP input - - open(CPPI,"> errno.c") or - die "Cannot open errno.c"; - - print CPPI "#include <errno.h>\n"; - - foreach $err (keys %err) { - print CPPI '"',$err,'" [[',$err,']]',"\n"; - } - - close(CPPI); - - unless ($^O eq 'MacOS') { # trust what we have - # invoke CPP and read the output - - if ($^O eq 'VMS') { - my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}"; - $cpp =~ s/sys\$input//i; - open(CPPO,"$cpp errno.c |") or - die "Cannot exec $Config{cppstdin}"; - } elsif ($^O eq 'MSWin32') { - open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or - die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'"; - } else { - my $cpp = default_cpp(); - open(CPPO,"$cpp < errno.c |") - or die "Cannot exec $cpp"; - } - - %err = (); - - while(<CPPO>) { - my($name,$expr); - next unless ($name, $expr) = /"(.*?)"\s*\[\s*\[\s*(.*?)\s*\]\s*\]/; - next if $name eq $expr; - $err{$name} = eval $expr; - } - close(CPPO); - } - - # Write Errno.pm - - print <<"EDQ"; -# -# This file is auto-generated. ***ANY*** changes here will be lost -# - -package Errno; -use vars qw(\@EXPORT_OK \%EXPORT_TAGS \@ISA \$VERSION \%errno \$AUTOLOAD); -use Exporter (); -use Config; -use strict; - -"\$Config{'archname'}-\$Config{'osvers'}" eq -"$Config{'archname'}-$Config{'osvers'}" or - die "Errno architecture ($Config{'archname'}-$Config{'osvers'}) does not match executable architecture (\$Config{'archname'}-\$Config{'osvers'})"; - -\$VERSION = "$VERSION"; -\@ISA = qw(Exporter); - -EDQ - - my $len = 0; - my @err = sort { $err{$a} <=> $err{$b} } keys %err; - map { $len = length if length > $len } @err; - - my $j = "\@EXPORT_OK = qw(" . join(" ",keys %err) . ");\n"; - $j =~ s/(.{50,70})\s/$1\n\t/g; - print $j,"\n"; - -print <<'ESQ'; -%EXPORT_TAGS = ( - POSIX => [qw( -ESQ - - my $k = join(" ", grep { exists $err{$_} } - qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT - EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED - ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT - EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS - EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK - EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH - ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM - ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR - ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM - EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE - ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT - ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY - EUSERS EWOULDBLOCK EXDEV)); - - $k =~ s/(.{50,70})\s/$1\n\t/g; - print "\t",$k,"\n )]\n);\n\n"; - - foreach $err (@err) { - printf "sub %s () { %d }\n",,$err,$err{$err}; - } - - print <<'ESQ'; - -sub TIEHASH { bless [] } - -sub FETCH { - my ($self, $errname) = @_; - my $proto = prototype("Errno::$errname"); - my $errno = ""; - if (defined($proto) && $proto eq "") { - no strict 'refs'; - $errno = &$errname; - $errno = 0 unless $! == $errno; - } - return $errno; -} - -sub STORE { - require Carp; - Carp::confess("ERRNO hash is read only!"); -} - -*CLEAR = \&STORE; -*DELETE = \&STORE; - -sub NEXTKEY { - my($k,$v); - while(($k,$v) = each %Errno::) { - my $proto = prototype("Errno::$k"); - last if (defined($proto) && $proto eq ""); - } - $k -} - -sub FIRSTKEY { - my $s = scalar keys %Errno::; # initialize iterator - goto &NEXTKEY; -} - -sub EXISTS { - my ($self, $errname) = @_; - my $proto = prototype($errname); - defined($proto) && $proto eq ""; -} - -tie %!, __PACKAGE__; - -1; -__END__ - -=head1 NAME - -Errno - System errno constants - -=head1 SYNOPSIS - - use Errno qw(EINTR EIO :POSIX); - -=head1 DESCRIPTION - -C<Errno> defines and conditionally exports all the error constants -defined in your system C<errno.h> include file. It has a single export -tag, C<:POSIX>, which will export all POSIX defined error numbers. - -C<Errno> also makes C<%!> magic such that each element of C<%!> has a -non-zero value only if C<$!> is set to that value. For example: - - use Errno; - - unless (open(FH, "/fangorn/spouse")) { - if ($!{ENOENT}) { - warn "Get a wife!\n"; - } else { - warn "This path is barred: $!"; - } - } - -If a specified constant C<EFOO> does not exist on the system, C<$!{EFOO}> -returns C<"">. You may use C<exists $!{EFOO}> to check whether the -constant is available on the system. - -=head1 CAVEATS - -Importing a particular constant may not be very portable, because the -import will fail on platforms that do not have that constant. A more -portable way to set C<$!> to a valid value is to use: - - if (exists &Errno::EFOO) { - $! = &Errno::EFOO; - } - -=head1 AUTHOR - -Graham Barr <gbarr@pobox.com> - -=head1 COPYRIGHT - -Copyright (c) 1997-8 Graham Barr. All rights reserved. -This program is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -=cut - -ESQ - -} diff --git a/contrib/perl5/ext/Errno/Makefile.PL b/contrib/perl5/ext/Errno/Makefile.PL deleted file mode 100644 index 604d4fb..0000000 --- a/contrib/perl5/ext/Errno/Makefile.PL +++ /dev/null @@ -1,30 +0,0 @@ -use ExtUtils::MakeMaker; - -@VMS = ($^O eq 'VMS') ? (MAN3PODS => {}) : (); - -WriteMakefile( - NAME => 'Errno', - VERSION_FROM => 'Errno_pm.PL', - MAN3PODS => {}, # Pods will be built by installman. - PL_FILES => {'Errno_pm.PL'=>'Errno.pm'}, - PM => {'Errno.pm' => '$(INST_LIBDIR)/Errno.pm'}, - 'clean' => {FILES => 'Errno.pm'}, - 'dist' => { - COMPRESS => 'gzip -9f', - SUFFIX => '.gz', - DIST_DEFAULT => 'd/Errno.pm tardist', - }, - @VMS, -); - -sub MY::postamble { - my $TARG = MM->catfile('d','Errno.pm'); -qq!$TARG : Makefile - echo '#This is a dummy file so CPAN will find a VERSION' > $TARG - echo 'package Errno;' >> $TARG - echo '\$\$VERSION = "\$(VERSION)";' >>$TARG - echo '#This is to make sure require will return an error' >>$TARG - echo '0;' >>$TARG - -! -} diff --git a/contrib/perl5/ext/Fcntl/Fcntl.pm b/contrib/perl5/ext/Fcntl/Fcntl.pm deleted file mode 100644 index 92103a1..0000000 --- a/contrib/perl5/ext/Fcntl/Fcntl.pm +++ /dev/null @@ -1,222 +0,0 @@ -package Fcntl; - -=head1 NAME - -Fcntl - load the C Fcntl.h defines - -=head1 SYNOPSIS - - use Fcntl; - use Fcntl qw(:DEFAULT :flock); - -=head1 DESCRIPTION - -This module is just a translation of the C F<fnctl.h> file. -Unlike the old mechanism of requiring a translated F<fnctl.ph> -file, this uses the B<h2xs> program (see the Perl source distribution) -and your native C compiler. This means that it has a -far more likely chance of getting the numbers right. - -=head1 NOTE - -Only C<#define> symbols get translated; you must still correctly -pack up your own arguments to pass as args for locking functions, etc. - -=head1 EXPORTED SYMBOLS - -By default your system's F_* and O_* constants (eg, F_DUPFD and -O_CREAT) and the FD_CLOEXEC constant are exported into your namespace. - -You can request that the flock() constants (LOCK_SH, LOCK_EX, LOCK_NB -and LOCK_UN) be provided by using the tag C<:flock>. See L<Exporter>. - -You can request that the old constants (FAPPEND, FASYNC, FCREAT, -FDEFER, FEXCL, FNDELAY, FNONBLOCK, FSYNC, FTRUNC) be provided for -compatibility reasons by using the tag C<:Fcompat>. For new -applications the newer versions of these constants are suggested -(O_APPEND, O_ASYNC, O_CREAT, O_DEFER, O_EXCL, O_NDELAY, O_NONBLOCK, -O_SYNC, O_TRUNC). - -For ease of use also the SEEK_* constants (for seek() and sysseek(), -e.g. SEEK_END) and the S_I* constants (for chmod() and stat()) are -available for import. They can be imported either separately or using -the tags C<:seek> and C<:mode>. - -Please refer to your native fcntl(2), open(2), fseek(3), lseek(2) -(equal to Perl's seek() and sysseek(), respectively), and chmod(2) -documentation to see what constants are implemented in your system. - -See L<perlopentut> to learn about the uses of the O_* constants -with sysopen(). - -See L<perlfunc/seek> and L<perlfunc/sysseek> about the SEEK_* constants. - -See L<perlfunc/stat> about the S_I* constants. - -=cut - -our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $AUTOLOAD); - -require Exporter; -use XSLoader (); -@ISA = qw(Exporter); -$VERSION = "1.03"; -# Items to export into callers namespace by default -# (move infrequently used names to @EXPORT_OK below) -@EXPORT = - qw( - FD_CLOEXEC - F_ALLOCSP - F_ALLOCSP64 - F_COMPAT - F_DUP2FD - F_DUPFD - F_EXLCK - F_FREESP - F_FREESP64 - F_FSYNC - F_FSYNC64 - F_GETFD - F_GETFL - F_GETLK - F_GETLK64 - F_GETOWN - F_NODNY - F_POSIX - F_RDACC - F_RDDNY - F_RDLCK - F_RWACC - F_RWDNY - F_SETFD - F_SETFL - F_SETLK - F_SETLK64 - F_SETLKW - F_SETLKW64 - F_SETOWN - F_SHARE - F_SHLCK - F_UNLCK - F_UNSHARE - F_WRACC - F_WRDNY - F_WRLCK - O_ACCMODE - O_ALIAS - O_APPEND - O_ASYNC - O_BINARY - O_CREAT - O_DEFER - O_DIRECT - O_DIRECTORY - O_DSYNC - O_EXCL - O_EXLOCK - O_LARGEFILE - 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 - O_TEXT - O_TRUNC - O_WRONLY - ); - -# Other items we are prepared to export if requested -@EXPORT_OK = qw( - FAPPEND - FASYNC - FCREAT - FDEFER - FDSYNC - FEXCL - FLARGEFILE - FNDELAY - FNONBLOCK - FRSYNC - FSYNC - FTRUNC - LOCK_EX - LOCK_NB - LOCK_SH - LOCK_UN - S_ISUID S_ISGID S_ISVTX S_ISTXT - _S_IFMT S_IFREG S_IFDIR S_IFLNK - S_IFSOCK S_IFBLK S_IFCHR S_IFIFO S_IFWHT S_ENFMT - S_IRUSR S_IWUSR S_IXUSR S_IRWXU - S_IRGRP S_IWGRP S_IXGRP S_IRWXG - S_IROTH S_IWOTH S_IXOTH S_IRWXO - S_IREAD S_IWRITE S_IEXEC - &S_ISREG &S_ISDIR &S_ISLNK &S_ISSOCK &S_ISBLK &S_ISCHR &S_ISFIFO - &S_ISWHT &S_ISENFMT &S_IFMT &S_IMODE - SEEK_SET - SEEK_CUR - SEEK_END -); -# Named groups of exports -%EXPORT_TAGS = ( - 'flock' => [qw(LOCK_SH LOCK_EX LOCK_NB LOCK_UN)], - 'Fcompat' => [qw(FAPPEND FASYNC FCREAT FDEFER FDSYNC FEXCL FLARGEFILE - FNDELAY FNONBLOCK FRSYNC FSYNC FTRUNC)], - 'seek' => [qw(SEEK_SET SEEK_CUR SEEK_END)], - 'mode' => [qw(S_ISUID S_ISGID S_ISVTX S_ISTXT - _S_IFMT S_IFREG S_IFDIR S_IFLNK - S_IFSOCK S_IFBLK S_IFCHR S_IFIFO S_IFWHT S_ENFMT - S_IRUSR S_IWUSR S_IXUSR S_IRWXU - S_IRGRP S_IWGRP S_IXGRP S_IRWXG - S_IROTH S_IWOTH S_IXOTH S_IRWXO - S_IREAD S_IWRITE S_IEXEC - S_ISREG S_ISDIR S_ISLNK S_ISSOCK - S_ISBLK S_ISCHR S_ISFIFO - S_ISWHT S_ISENFMT - S_IFMT S_IMODE - )], -); - -sub S_IFMT { @_ ? ( $_[0] & _S_IFMT() ) : _S_IFMT() } -sub S_IMODE { $_[0] & 07777 } - -sub S_ISREG { ( $_[0] & _S_IFMT() ) == S_IFREG() } -sub S_ISDIR { ( $_[0] & _S_IFMT() ) == S_IFDIR() } -sub S_ISLNK { ( $_[0] & _S_IFMT() ) == S_IFLNK() } -sub S_ISSOCK { ( $_[0] & _S_IFMT() ) == S_IFSOCK() } -sub S_ISBLK { ( $_[0] & _S_IFMT() ) == S_IFBLK() } -sub S_ISCHR { ( $_[0] & _S_IFMT() ) == S_IFCHR() } -sub S_ISFIFO { ( $_[0] & _S_IFMT() ) == S_IFIFO() } -sub S_ISWHT { ( $_[0] & _S_IFMT() ) == S_IFWHT() } -sub S_ISENFMT { ( $_[0] & _S_IFMT() ) == S_IFENFMT() } - -sub AUTOLOAD { - (my $constname = $AUTOLOAD) =~ s/.*:://; - my $val = constant($constname, 0); - if ($! != 0) { - if ($! =~ /Invalid/ || $!{EINVAL}) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } - else { - my ($pack,$file,$line) = caller; - die "Your vendor has not defined Fcntl macro $constname, used at $file line $line. -"; - } - } - *$AUTOLOAD = sub { $val }; - goto &$AUTOLOAD; -} - -XSLoader::load 'Fcntl', $VERSION; - -1; diff --git a/contrib/perl5/ext/Fcntl/Fcntl.xs b/contrib/perl5/ext/Fcntl/Fcntl.xs deleted file mode 100644 index 51851bb..0000000 --- a/contrib/perl5/ext/Fcntl/Fcntl.xs +++ /dev/null @@ -1,780 +0,0 @@ -#define PERL_NO_GET_CONTEXT -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#ifdef VMS -# include <file.h> -#else -#if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32) -#define _NO_OLDNAMES -#endif -# include <fcntl.h> -#if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32) -#undef _NO_OLDNAMES -#endif -#endif - -#ifdef I_UNISTD -#include <unistd.h> -#endif - -/* This comment is a kludge to get metaconfig to see the symbols - VAL_O_NONBLOCK - VAL_EAGAIN - RD_NODATA - EOF_NONBLOCK - and include the appropriate metaconfig unit - so that Configure will test how to turn on non-blocking I/O - for a file descriptor. See config.h for how to use these - in your extension. - - While I'm at it, I'll have metaconfig look for HAS_POLL too. - --AD October 16, 1995 -*/ - -static double -constant(char *name, int arg) -{ - errno = 0; - switch (*name) { - case '_': - if (strEQ(name, "_S_IFMT")) /* Yes, on name _S_IFMT return S_IFMT. */ -#ifdef S_IFMT - return S_IFMT; -#else - goto not_there; -#endif - break; - case 'F': - if (strnEQ(name, "F_", 2)) { - if (strEQ(name, "F_ALLOCSP")) -#ifdef F_ALLOCSP - return F_ALLOCSP; -#else - goto not_there; -#endif - if (strEQ(name, "F_ALLOCSP64")) -#ifdef F_ALLOCSP64 - return F_ALLOCSP64; -#else - goto not_there; -#endif - if (strEQ(name, "F_COMPAT")) -#ifdef F_COMPAT - return F_COMPAT; -#else - goto not_there; -#endif - if (strEQ(name, "F_DUP2FD")) -#ifdef F_DUP2FD - return F_DUP2FD; -#else - goto not_there; -#endif - if (strEQ(name, "F_DUPFD")) -#ifdef F_DUPFD - return F_DUPFD; -#else - goto not_there; -#endif - if (strEQ(name, "F_EXLCK")) -#ifdef F_EXLCK - return F_EXLCK; -#else - goto not_there; -#endif - if (strEQ(name, "F_FREESP")) -#ifdef F_FREESP - return F_FREESP; -#else - goto not_there; -#endif - if (strEQ(name, "F_FREESP64")) -#ifdef F_FREESP64 - return F_FREESP64; -#else - goto not_there; -#endif - if (strEQ(name, "F_FSYNC")) -#ifdef F_FSYNC - return F_FSYNC; -#else - goto not_there; -#endif - if (strEQ(name, "F_FSYNC64")) -#ifdef F_FSYNC64 - return F_FSYNC64; -#else - goto not_there; -#endif - if (strEQ(name, "F_GETFD")) -#ifdef F_GETFD - return F_GETFD; -#else - goto not_there; -#endif - if (strEQ(name, "F_GETFL")) -#ifdef F_GETFL - return F_GETFL; -#else - goto not_there; -#endif - if (strEQ(name, "F_GETLK")) -#ifdef F_GETLK - return F_GETLK; -#else - goto not_there; -#endif - if (strEQ(name, "F_GETLK64")) -#ifdef F_GETLK64 - return F_GETLK64; -#else - goto not_there; -#endif - if (strEQ(name, "F_GETOWN")) -#ifdef F_GETOWN - return F_GETOWN; -#else - goto not_there; -#endif - if (strEQ(name, "F_NODNY")) -#ifdef F_NODNY - return F_NODNY; -#else - goto not_there; -#endif - if (strEQ(name, "F_POSIX")) -#ifdef F_POSIX - return F_POSIX; -#else - goto not_there; -#endif - if (strEQ(name, "F_RDACC")) -#ifdef F_RDACC - return F_RDACC; -#else - goto not_there; -#endif - if (strEQ(name, "F_RDDNY")) -#ifdef F_RDDNY - return F_RDDNY; -#else - goto not_there; -#endif - if (strEQ(name, "F_RDLCK")) -#ifdef F_RDLCK - return F_RDLCK; -#else - goto not_there; -#endif - if (strEQ(name, "F_RWACC")) -#ifdef F_RWACC - return F_RWACC; -#else - goto not_there; -#endif - if (strEQ(name, "F_RWDNY")) -#ifdef F_RWDNY - return F_RWDNY; -#else - goto not_there; -#endif - if (strEQ(name, "F_SETFD")) -#ifdef F_SETFD - return F_SETFD; -#else - goto not_there; -#endif - if (strEQ(name, "F_SETFL")) -#ifdef F_SETFL - return F_SETFL; -#else - goto not_there; -#endif - if (strEQ(name, "F_SETLK")) -#ifdef F_SETLK - return F_SETLK; -#else - goto not_there; -#endif - if (strEQ(name, "F_SETLK64")) -#ifdef F_SETLK64 - return F_SETLK64; -#else - goto not_there; -#endif - if (strEQ(name, "F_SETLKW")) -#ifdef F_SETLKW - return F_SETLKW; -#else - goto not_there; -#endif - if (strEQ(name, "F_SETLKW64")) -#ifdef F_SETLKW64 - return F_SETLKW64; -#else - goto not_there; -#endif - if (strEQ(name, "F_SETOWN")) -#ifdef F_SETOWN - return F_SETOWN; -#else - goto not_there; -#endif - if (strEQ(name, "F_SHARE")) -#ifdef F_SHARE - return F_SHARE; -#else - goto not_there; -#endif - if (strEQ(name, "F_SHLCK")) -#ifdef F_SHLCK - return F_SHLCK; -#else - goto not_there; -#endif - if (strEQ(name, "F_UNLCK")) -#ifdef F_UNLCK - return F_UNLCK; -#else - goto not_there; -#endif - if (strEQ(name, "F_UNSHARE")) -#ifdef F_UNSHARE - return F_UNSHARE; -#else - goto not_there; -#endif - if (strEQ(name, "F_WRACC")) -#ifdef F_WRACC - return F_WRACC; -#else - goto not_there; -#endif - if (strEQ(name, "F_WRDNY")) -#ifdef F_WRDNY - return F_WRDNY; -#else - goto not_there; -#endif - if (strEQ(name, "F_WRLCK")) -#ifdef F_WRLCK - return F_WRLCK; -#else - goto not_there; -#endif - errno = EINVAL; - return 0; - } - if (strEQ(name, "FAPPEND")) -#ifdef FAPPEND - return FAPPEND; -#else - goto not_there; -#endif - if (strEQ(name, "FASYNC")) -#ifdef FASYNC - return FASYNC; -#else - goto not_there; -#endif - if (strEQ(name, "FCREAT")) -#ifdef FCREAT - return FCREAT; -#else - goto not_there; -#endif - if (strEQ(name, "FD_CLOEXEC")) -#ifdef FD_CLOEXEC - return FD_CLOEXEC; -#else - goto not_there; -#endif - if (strEQ(name, "FDEFER")) -#ifdef FDEFER - return FDEFER; -#else - goto not_there; -#endif - if (strEQ(name, "FDSYNC")) -#ifdef FDSYNC - return FDSYNC; -#else - goto not_there; -#endif - if (strEQ(name, "FEXCL")) -#ifdef FEXCL - return FEXCL; -#else - goto not_there; -#endif - if (strEQ(name, "FLARGEFILE")) -#ifdef FLARGEFILE - return FLARGEFILE; -#else - goto not_there; -#endif - if (strEQ(name, "FNDELAY")) -#ifdef FNDELAY - return FNDELAY; -#else - goto not_there; -#endif - if (strEQ(name, "FNONBLOCK")) -#ifdef FNONBLOCK - return FNONBLOCK; -#else - goto not_there; -#endif - if (strEQ(name, "FRSYNC")) -#ifdef FRSYNC - return FRSYNC; -#else - goto not_there; -#endif - if (strEQ(name, "FSYNC")) -#ifdef FSYNC - return FSYNC; -#else - goto not_there; -#endif - if (strEQ(name, "FTRUNC")) -#ifdef FTRUNC - return FTRUNC; -#else - goto not_there; -#endif - break; - case 'L': - if (strnEQ(name, "LOCK_", 5)) { - /* We support flock() on systems which don't have it, so - always supply the constants. */ - if (strEQ(name, "LOCK_SH")) -#ifdef LOCK_SH - return LOCK_SH; -#else - return 1; -#endif - if (strEQ(name, "LOCK_EX")) -#ifdef LOCK_EX - return LOCK_EX; -#else - return 2; -#endif - if (strEQ(name, "LOCK_NB")) -#ifdef LOCK_NB - return LOCK_NB; -#else - return 4; -#endif - if (strEQ(name, "LOCK_UN")) -#ifdef LOCK_UN - return LOCK_UN; -#else - return 8; -#endif - } else - goto not_there; - break; - case 'O': - if (strnEQ(name, "O_", 2)) { - if (strEQ(name, "O_ACCMODE")) -#ifdef O_ACCMODE - return O_ACCMODE; -#else - goto not_there; -#endif - if (strEQ(name, "O_APPEND")) -#ifdef O_APPEND - return O_APPEND; -#else - goto not_there; -#endif - if (strEQ(name, "O_ASYNC")) -#ifdef O_ASYNC - return O_ASYNC; -#else - goto not_there; -#endif - if (strEQ(name, "O_BINARY")) -#ifdef O_BINARY - return O_BINARY; -#else - goto not_there; -#endif - if (strEQ(name, "O_CREAT")) -#ifdef O_CREAT - return O_CREAT; -#else - goto not_there; -#endif - if (strEQ(name, "O_DEFER")) -#ifdef O_DEFER - return O_DEFER; -#else - goto not_there; -#endif - if (strEQ(name, "O_DIRECT")) -#ifdef O_DIRECT - return O_DIRECT; -#else - goto not_there; -#endif - if (strEQ(name, "O_DIRECTORY")) -#ifdef O_DIRECTORY - return O_DIRECTORY; -#else - goto not_there; -#endif - if (strEQ(name, "O_DSYNC")) -#ifdef O_DSYNC - return O_DSYNC; -#else - goto not_there; -#endif - if (strEQ(name, "O_EXCL")) -#ifdef O_EXCL - return O_EXCL; -#else - goto not_there; -#endif - if (strEQ(name, "O_EXLOCK")) -#ifdef O_EXLOCK - return O_EXLOCK; -#else - goto not_there; -#endif - if (strEQ(name, "O_LARGEFILE")) -#ifdef O_LARGEFILE - return O_LARGEFILE; -#else - goto not_there; -#endif - if (strEQ(name, "O_NDELAY")) -#ifdef O_NDELAY - return O_NDELAY; -#else - goto not_there; -#endif - if (strEQ(name, "O_NOCTTY")) -#ifdef O_NOCTTY - return O_NOCTTY; -#else - goto not_there; -#endif - if (strEQ(name, "O_NOFOLLOW")) -#ifdef O_NOFOLLOW - return O_NOFOLLOW; -#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; -#else - goto not_there; -#endif - if (strEQ(name, "O_RDWR")) -#ifdef O_RDWR - return O_RDWR; -#else - goto not_there; -#endif - if (strEQ(name, "O_RSYNC")) -#ifdef O_RSYNC - return O_RSYNC; -#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; -#else - goto not_there; -#endif - if (strEQ(name, "O_SYNC")) -#ifdef O_SYNC - return O_SYNC; -#else - goto not_there; -#endif - if (strEQ(name, "O_TEMPORARY")) -#ifdef O_TEMPORARY - return O_TEMPORARY; -#else - goto not_there; -#endif - if (strEQ(name, "O_TEXT")) -#ifdef O_TEXT - return O_TEXT; -#else - goto not_there; -#endif - if (strEQ(name, "O_TRUNC")) -#ifdef O_TRUNC - return O_TRUNC; -#else - goto not_there; -#endif - if (strEQ(name, "O_WRONLY")) -#ifdef O_WRONLY - return O_WRONLY; -#else - goto not_there; -#endif - if (strEQ(name, "O_ALIAS")) -#ifdef O_ALIAS - return O_ALIAS; -#else - goto not_there; -#endif - if (strEQ(name, "O_RSRC")) -#ifdef O_RSRC - return O_RSRC; -#else - goto not_there; -#endif - } else - goto not_there; - break; - case 'S': - switch (name[1]) { - case '_': - if (strEQ(name, "S_ISUID")) -#ifdef S_ISUID - return S_ISUID; -#else - goto not_there; -#endif - if (strEQ(name, "S_ISGID")) -#ifdef S_ISGID - return S_ISGID; -#else - goto not_there; -#endif - if (strEQ(name, "S_ISVTX")) -#ifdef S_ISVTX - return S_ISVTX; -#else - goto not_there; -#endif - if (strEQ(name, "S_ISTXT")) -#ifdef S_ISTXT - return S_ISTXT; -#else - goto not_there; -#endif - if (strEQ(name, "S_IFREG")) -#ifdef S_IFREG - return S_IFREG; -#else - goto not_there; -#endif - if (strEQ(name, "S_IFDIR")) -#ifdef S_IFDIR - return S_IFDIR; -#else - goto not_there; -#endif - if (strEQ(name, "S_IFLNK")) -#ifdef S_IFLNK - return S_IFLNK; -#else - goto not_there; -#endif - if (strEQ(name, "S_IFSOCK")) -#ifdef S_IFSOCK - return S_IFSOCK; -#else - goto not_there; -#endif - if (strEQ(name, "S_IFBLK")) -#ifdef S_IFBLK - return S_IFBLK; -#else - goto not_there; -#endif - if (strEQ(name, "S_IFCHR")) -#ifdef S_IFCHR - return S_IFCHR; -#else - goto not_there; -#endif - if (strEQ(name, "S_IFIFO")) -#ifdef S_IFIFO - return S_IFIFO; -#else - goto not_there; -#endif - if (strEQ(name, "S_IFWHT")) -#ifdef S_IFWHT - return S_IFWHT; -#else - goto not_there; -#endif - if (strEQ(name, "S_ENFMT")) -#ifdef S_ENFMT - return S_ENFMT; -#else - goto not_there; -#endif - if (strEQ(name, "S_IRUSR")) -#ifdef S_IRUSR - return S_IRUSR; -#else - goto not_there; -#endif - if (strEQ(name, "S_IWUSR")) -#ifdef S_IWUSR - return S_IWUSR; -#else - goto not_there; -#endif - if (strEQ(name, "S_IXUSR")) -#ifdef S_IXUSR - return S_IXUSR; -#else - goto not_there; -#endif - if (strEQ(name, "S_IRWXU")) -#ifdef S_IRWXU - return S_IRWXU; -#else - goto not_there; -#endif - if (strEQ(name, "S_IRGRP")) -#ifdef S_IRGRP - return S_IRGRP; -#else - goto not_there; -#endif - if (strEQ(name, "S_IWGRP")) -#ifdef S_IWGRP - return S_IWGRP; -#else - goto not_there; -#endif - if (strEQ(name, "S_IXGRP")) -#ifdef S_IXGRP - return S_IXGRP; -#else - goto not_there; -#endif - if (strEQ(name, "S_IRWXG")) -#ifdef S_IRWXG - return S_IRWXG; -#else - goto not_there; -#endif - if (strEQ(name, "S_IROTH")) -#ifdef S_IROTH - return S_IROTH; -#else - goto not_there; -#endif - if (strEQ(name, "S_IWOTH")) -#ifdef S_IWOTH - return S_IWOTH; -#else - goto not_there; -#endif - if (strEQ(name, "S_IXOTH")) -#ifdef S_IXOTH - return S_IXOTH; -#else - goto not_there; -#endif - if (strEQ(name, "S_IRWXO")) -#ifdef S_IRWXO - return S_IRWXO; -#else - goto not_there; -#endif - if (strEQ(name, "S_IREAD")) -#ifdef S_IREAD - return S_IREAD; -#else - goto not_there; -#endif - if (strEQ(name, "S_IWRITE")) -#ifdef S_IWRITE - return S_IWRITE; -#else - goto not_there; -#endif - if (strEQ(name, "S_IEXEC")) -#ifdef S_IEXEC - return S_IEXEC; -#else - goto not_there; -#endif - break; - case 'E': - if (strEQ(name, "SEEK_CUR")) -#ifdef SEEK_CUR - return SEEK_CUR; -#else - return 1; -#endif - if (strEQ(name, "SEEK_END")) -#ifdef SEEK_END - return SEEK_END; -#else - return 2; -#endif - if (strEQ(name, "SEEK_SET")) -#ifdef SEEK_SET - return SEEK_SET; -#else - return 0; -#endif - break; - } - } - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - - -MODULE = Fcntl PACKAGE = Fcntl - -double -constant(name,arg) - char * name - int arg - diff --git a/contrib/perl5/ext/Fcntl/Makefile.PL b/contrib/perl5/ext/Fcntl/Makefile.PL deleted file mode 100644 index 0346373..0000000 --- a/contrib/perl5/ext/Fcntl/Makefile.PL +++ /dev/null @@ -1,8 +0,0 @@ -use ExtUtils::MakeMaker; -WriteMakefile( - NAME => 'Fcntl', - MAN3PODS => {}, # Pods will be built by installman. - XSPROTOARG => '-noprototypes', # XXX remove later? - VERSION_FROM => 'Fcntl.pm', -); - diff --git a/contrib/perl5/ext/File/Glob/Changes b/contrib/perl5/ext/File/Glob/Changes deleted file mode 100644 index f46ec70..0000000 --- a/contrib/perl5/ext/File/Glob/Changes +++ /dev/null @@ -1,49 +0,0 @@ -Revision history for Perl extension File::Glob - -0.00 Tue Dec 17 10:51:33 1996 - - original version; created by h2xs 1.16 - -0.90 Tue Dec 17 13:58:32 MST 1996 - - implemented first pass access to glob(3), - but it's clumsy and it looks like it leaks - memory. - -0.91 Thu Sep 4 08:43:55 CDT 1997 - - included CORE/config.h portability macros - - s/glob/bsd_glob/ to avoid calling and including the - system's glob stuff - - added GLOB_DEBUG for (surprise!) glob debugging - - tainted all filenames returned from &Glob::BSD::glob - -0.92 Tue Sep 30 08:31:57 CDT 1997 - - only use lstat if HAS_LSTAT is defined - - renamed the glob flags to GLOB_* - - added GLOB_CSH convenience macro for csh(1) globbing - These changes thanks to Hans Mulder <hansm@icgned.nl> - - fixed an incompatibility with csh(1) globbing where a - pattern like {A*,b,c} wouldn't expand properly - - various compatibility changes - - fixed and added tests - -0.93 Wed Jul 1 10:39:47 CDT 1998 - - renamed module to File::BSDGlob - - enabled 'globally' import directive to override the core - glob - - added Sarathy's tests for File::DosGlob -0.99 Tue Oct 12 06:42:02 PDT 1999 - - renamed module to File::Glob for incorporation into the - Perl source distribution - - ansified prototypes - - s/struct stat/Stat_t/ - - split on spaces to make <*.c *.h> work (for compatibility) -0.991 Tue Oct 26 09:48:00 BST 1999 - - Add case-insensitive matching (GLOB_NOCASE) - - Make glob_csh case insensitive by default on Win32, VMS, - OS/2, DOS, RISC OS, and Mac OS - - Add support for :case and :nocase tags - - Hack to make patterns like C:* work on DOSISH systems - - Add support for either \ or / as separators on DOSISH systems - - Limit effect of \ as a quoting operator on DOSISH systems to - when it precedes one of []{}-~\ (to minimise backslashitis). -0.992 Tue Mar 20 09:25:48 2001 - - Add alphabetic sorting for csh compatibility (GLOB_ALPHASORT) diff --git a/contrib/perl5/ext/File/Glob/Glob.pm b/contrib/perl5/ext/File/Glob/Glob.pm deleted file mode 100644 index 20b26f9..0000000 --- a/contrib/perl5/ext/File/Glob/Glob.pm +++ /dev/null @@ -1,438 +0,0 @@ -package File::Glob; - -use strict; -use Carp; -our($VERSION, @ISA, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS, - $AUTOLOAD, $DEFAULT_FLAGS); - -require Exporter; -use XSLoader (); -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_ALPHASORT - GLOB_ALTDIRFUNC - GLOB_BRACE - GLOB_CSH - GLOB_ERR - GLOB_ERROR - GLOB_MARK - GLOB_NOCASE - GLOB_NOCHECK - GLOB_NOMAGIC - GLOB_NOSORT - GLOB_NOSPACE - GLOB_QUOTE - GLOB_TILDE -); - -%EXPORT_TAGS = ( - 'glob' => [ qw( - GLOB_ABEND - GLOB_ALPHASORT - GLOB_ALTDIRFUNC - GLOB_BRACE - GLOB_CSH - GLOB_ERR - GLOB_ERROR - GLOB_MARK - GLOB_NOCASE - GLOB_NOCHECK - GLOB_NOMAGIC - GLOB_NOSORT - GLOB_NOSPACE - GLOB_QUOTE - GLOB_TILDE - glob - bsd_glob - ) ], -); - -$VERSION = '0.991'; - -sub import { - my $i = 1; - while ($i < @_) { - if ($_[$i] =~ /^:(case|nocase|globally)$/) { - splice(@_, $i, 1); - $DEFAULT_FLAGS &= ~GLOB_NOCASE() if $1 eq 'case'; - $DEFAULT_FLAGS |= GLOB_NOCASE() if $1 eq 'nocase'; - if ($1 eq 'globally') { - no warnings; - *CORE::GLOBAL::glob = \&File::Glob::csh_glob; - } - next; - } - ++$i; - } - goto &Exporter::import; -} - -sub AUTOLOAD { - # This AUTOLOAD is used to 'autoload' constants from the constant() - # XS function. If a constant is not found then control is passed - # to the AUTOLOAD in AutoLoader. - - my $constname; - ($constname = $AUTOLOAD) =~ s/.*:://; - my $val = constant($constname, @_ ? $_[0] : 0); - if ($! != 0) { - if ($! =~ /Invalid/) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } - else { - croak "Your vendor has not defined File::Glob macro $constname"; - } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - -XSLoader::load 'File::Glob', $VERSION; - -# Preloaded methods go here. - -sub GLOB_ERROR { - return constant('GLOB_ERROR', 0); -} - -sub GLOB_CSH () { - GLOB_BRACE() - | GLOB_NOMAGIC() - | GLOB_QUOTE() - | GLOB_TILDE() - | GLOB_ALPHASORT() -} - -$DEFAULT_FLAGS = GLOB_CSH(); -if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos|MacOS)$/) { - $DEFAULT_FLAGS |= GLOB_NOCASE(); -} - -# Autoload methods go after =cut, and are processed by the autosplit program. - -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; - -sub csh_glob { - my $pat = shift; - my $cxix = shift; - my @pat; - - # glob without args defaults to $_ - $pat = $_ unless defined $pat; - - # extract patterns - $pat =~ s/^\s+//; # Protect against empty elements in - $pat =~ s/\s+$//; # things like < *.c> and <*.c >. - # These alone shouldn't trigger ParseWords. - if ($pat =~ /\s/) { - # XXX this is needed for compatibility with the csh - # implementation in Perl. Need to support a flag - # to disable this behavior. - require Text::ParseWords; - @pat = Text::ParseWords::parse_line('\s+',0,$pat); - } - - # assume global context if not provided one - $cxix = '_G_' unless defined $cxix; - $iter{$cxix} = 0 unless exists $iter{$cxix}; - - # if we're just beginning, do it all first - if ($iter{$cxix} == 0) { - if (@pat) { - $entries{$cxix} = [ map { doglob($_, $DEFAULT_FLAGS) } @pat ]; - } - else { - $entries{$cxix} = [ doglob($pat, $DEFAULT_FLAGS) ]; - } - } - - # chuck it all out, quick or slow - if (wantarray) { - delete $iter{$cxix}; - return @{delete $entries{$cxix}}; - } - else { - if ($iter{$cxix} = scalar @{$entries{$cxix}}) { - return shift @{$entries{$cxix}}; - } - else { - # return undef for EOL - delete $iter{$cxix}; - delete $entries{$cxix}; - return undef; - } - } -} - -1; -__END__ - -=head1 NAME - -File::Glob - Perl extension for BSD glob routine - -=head1 SYNOPSIS - - use File::Glob ':glob'; - @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 - ## by default anyway, since v5.6.0) - use File::Glob ':globally'; - my @sources = <*.{c,h,y}> - - ## override the core glob, forcing case sensitivity - use File::Glob qw(:globally :case); - my @sources = <*.{c,h,y}> - - ## override the core glob forcing case insensitivity - use File::Glob qw(:globally :nocase); - my @sources = <*.{c,h,y}> - -=head1 DESCRIPTION - -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. - -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 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> - -Each pathname that is a directory that matches the pattern has a slash -appended. - -=item C<GLOB_NOCASE> - -By default, file names are assumed to be case sensitive; this flag -makes bsd_glob() treat case differences as not significant. - -=item C<GLOB_NOCHECK> - -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 bsd_glob()). - -=back - -The FreeBSD extensions to the POSIX standard are the following flags: - -=over 4 - -=item C<GLOB_BRACE> - -Pre-process the string to expand C<{pat,pat,...}> strings like csh(1). -The pattern '{}' is left unexpanded for historical reasons (and csh(1) -does the same thing to ease typing of find(1) patterns). - -=item C<GLOB_NOMAGIC> - -Same as C<GLOB_NOCHECK> but it only returns the pattern if it does not -contain any of the special characters "*", "?" or "[". C<NOMAGIC> is -provided to simplify implementing the historic csh(1) globbing -behaviour and should probably not be used anywhere else. - -=item C<GLOB_QUOTE> - -Use the backslash ('\') character for quoting: every occurrence of a -backslash followed by a character in the pattern is replaced by that -character, avoiding any special interpretation of the character. -(But see below for exceptions on DOSISH systems). - -=item C<GLOB_TILDE> - -Expand patterns that start with '~' to user name home directories. - -=item C<GLOB_CSH> - -For convenience, C<GLOB_CSH> is a synonym for -C<GLOB_BRACE | GLOB_NOMAGIC | GLOB_QUOTE | GLOB_TILDE | GLOB_ALPHASORT>. - -=back - -The POSIX provided C<GLOB_APPEND>, C<GLOB_DOOFFS>, and the FreeBSD -extensions C<GLOB_ALTDIRFUNC>, and C<GLOB_MAGCHAR> flags have not been -implemented in the Perl version because they involve more complex -interaction with the underlying C structures. - -The following flag has been added in the Perl implementation for -compatibility with common flavors of csh: - -=over 4 - -=item C<GLOB_ALPHASORT> - -If C<GLOB_NOSORT> is not in effect, sort filenames is alphabetical -order (case does not matter) rather than in ASCII order. - -=back - -=head1 DIAGNOSTICS - -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: - -=over 4 - -=item C<GLOB_NOSPACE> - -An attempt to allocate memory failed. - -=item C<GLOB_ABEND> - -The glob was stopped because an error was encountered. - -=back - -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 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. - -Be aware that all filenames returned from File::Glob are tainted. - -=head1 NOTES - -=over 4 - -=item * - -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 * - -On DOSISH systems, backslash is a valid directory separator character. -In this case, use of backslash as a quoting character (via GLOB_QUOTE) -interferes with the use of backslash as a directory separator. The -best (simplest, most portable) solution is to use forward slashes for -directory separators, and backslashes for quoting. However, this does -not match "normal practice" on these systems. As a concession to user -expectation, therefore, backslashes (under GLOB_QUOTE) only quote the -glob metacharacters '[', ']', '{', '}', '-', '~', and backslash itself. -All other backslashes are passed through unchanged. - -=item * - -Win32 users should use the real slash. If you really want to use -backslashes, consider using Sarathy's File::DosGlob, which comes with -the standard Perl distribution. - -=item * - -Mac OS (Classic) users should note a few differences. Since -Mac OS is not Unix, when the glob code encounters a tilde glob (e.g. -~user/foo) and the C<GLOB_TILDE> flag is used, it simply returns that -pattern without doing any expansion. - -Glob on Mac OS is case-insensitive by default (if you don't use any -flags). If you specify any flags at all and still want glob -to be case-insensitive, you must include C<GLOB_NOCASE> in the flags. - -The path separator is ':' (aka colon), not '/' (aka slash). Mac OS users -should be careful about specifying relative pathnames. While a full path -always begins with a volume name, a relative pathname should always -begin with a ':'. If specifying a volume name only, a trailing ':' is -required. - -=back - -=head1 AUTHOR - -The Perl interface was written by Nathan Torkington E<lt>gnat@frii.comE<gt>, -and is released under the artistic license. Further modifications were -made by Greg Bacon E<lt>gbacon@cs.uah.eduE<gt>, Gurusamy Sarathy -E<lt>gsar@activestate.comE<gt>, and Thomas Wegner -E<lt>wegner_thomas@yahoo.comE<gt>. The C glob code has the -following copyright: - - Copyright (c) 1989, 1993 The Regents of the University of California. - All rights reserved. - - This code is derived from software contributed to Berkeley by - Guido van Rossum. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the University nor the names of its contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. - -=cut diff --git a/contrib/perl5/ext/File/Glob/Glob.xs b/contrib/perl5/ext/File/Glob/Glob.xs deleted file mode 100644 index ee8c0c9..0000000 --- a/contrib/perl5/ext/File/Glob/Glob.xs +++ /dev/null @@ -1,208 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#include "bsd_glob.h" - -/* XXX: need some thread awareness */ -static int GLOB_ERROR = 0; - -static double -constant(char *name, int arg) -{ - errno = 0; - if (strlen(name) <= 5) - goto not_there; - switch (*(name+5)) { - case 'A': - if (strEQ(name, "GLOB_ABEND")) -#ifdef GLOB_ABEND - return GLOB_ABEND; -#else - goto not_there; -#endif - if (strEQ(name, "GLOB_ALPHASORT")) -#ifdef GLOB_ALPHASORT - return GLOB_ALPHASORT; -#else - goto not_there; -#endif - if (strEQ(name, "GLOB_ALTDIRFUNC")) -#ifdef GLOB_ALTDIRFUNC - return GLOB_ALTDIRFUNC; -#else - goto not_there; -#endif - break; - case 'B': - if (strEQ(name, "GLOB_BRACE")) -#ifdef GLOB_BRACE - return GLOB_BRACE; -#else - goto not_there; -#endif - break; - case 'C': - break; - case 'D': - break; - case 'E': - if (strEQ(name, "GLOB_ERR")) -#ifdef GLOB_ERR - return GLOB_ERR; -#else - goto not_there; -#endif - if (strEQ(name, "GLOB_ERROR")) - return GLOB_ERROR; - break; - case 'F': - break; - case 'G': - break; - case 'H': - break; - case 'I': - break; - case 'J': - break; - case 'K': - break; - case 'L': - break; - case 'M': - if (strEQ(name, "GLOB_MARK")) -#ifdef GLOB_MARK - return GLOB_MARK; -#else - goto not_there; -#endif - break; - case 'N': - if (strEQ(name, "GLOB_NOCASE")) -#ifdef GLOB_NOCASE - return GLOB_NOCASE; -#else - goto not_there; -#endif - if (strEQ(name, "GLOB_NOCHECK")) -#ifdef GLOB_NOCHECK - return GLOB_NOCHECK; -#else - goto not_there; -#endif - if (strEQ(name, "GLOB_NOMAGIC")) -#ifdef GLOB_NOMAGIC - return GLOB_NOMAGIC; -#else - goto not_there; -#endif - if (strEQ(name, "GLOB_NOSORT")) -#ifdef GLOB_NOSORT - return GLOB_NOSORT; -#else - goto not_there; -#endif - if (strEQ(name, "GLOB_NOSPACE")) -#ifdef GLOB_NOSPACE - return GLOB_NOSPACE; -#else - goto not_there; -#endif - break; - case 'O': - break; - case 'P': - break; - case 'Q': - if (strEQ(name, "GLOB_QUOTE")) -#ifdef GLOB_QUOTE - return GLOB_QUOTE; -#else - goto not_there; -#endif - break; - case 'R': - break; - case 'S': - break; - case 'T': - if (strEQ(name, "GLOB_TILDE")) -#ifdef GLOB_TILDE - return GLOB_TILDE; -#else - goto not_there; -#endif - break; - case 'U': - break; - case 'V': - break; - case 'W': - break; - case 'X': - break; - case 'Y': - break; - case 'Z': - break; - } - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - -#ifdef WIN32 -#define errfunc NULL -#else -int -errfunc(const char *foo, int bar) { - return !(bar == ENOENT || bar == ENOTDIR); -} -#endif - -MODULE = File::Glob PACKAGE = File::Glob - -void -doglob(pattern,...) - char *pattern -PROTOTYPE: $;$ -PREINIT: - glob_t pglob; - int i; - int retval; - int flags = 0; - SV *tmp; -PPCODE: - { - /* allow for optional flags argument */ - if (items > 1) { - flags = (int) SvIV(ST(1)); - } - - /* call glob */ - retval = bsd_glob(pattern, flags, errfunc, &pglob); - GLOB_ERROR = retval; - - /* return any matches found */ - EXTEND(sp, pglob.gl_pathc); - for (i = 0; i < pglob.gl_pathc; i++) { - /* printf("# bsd_glob: %s\n", pglob.gl_pathv[i]); */ - tmp = sv_2mortal(newSVpvn(pglob.gl_pathv[i], - strlen(pglob.gl_pathv[i]))); - TAINT; - SvTAINT(tmp); - PUSHs(tmp); - } - - bsd_globfree(&pglob); - } - -double -constant(name,arg) - char *name - int arg -PROTOTYPE: $$ diff --git a/contrib/perl5/ext/File/Glob/Makefile.PL b/contrib/perl5/ext/File/Glob/Makefile.PL deleted file mode 100644 index 98781c9..0000000 --- a/contrib/perl5/ext/File/Glob/Makefile.PL +++ /dev/null @@ -1,21 +0,0 @@ -use ExtUtils::MakeMaker; -WriteMakefile( - NAME => 'File::Glob', - VERSION_FROM => 'Glob.pm', - MAN3PODS => {}, # Pods will be built by installman. - OBJECT => 'bsd_glob$(OBJ_EXT) Glob$(OBJ_EXT)', - -## uncomment for glob debugging (will cause make test to fail) -# DEFINE => '-DGLOB_DEBUG', -# OPTIMIZE => '-g', -); -use Config; -sub MY::cflags { - package MY; - my $inherited = shift->SUPER::cflags(@_); - if ($Config::Config{archname} =~ /^aix/ and - $Config::Config{use64bitall} eq 'define') { - $inherited =~ s/\s-O\d?//m; - } - $inherited; -} diff --git a/contrib/perl5/ext/File/Glob/TODO b/contrib/perl5/ext/File/Glob/TODO deleted file mode 100644 index ef2547f..0000000 --- a/contrib/perl5/ext/File/Glob/TODO +++ /dev/null @@ -1,21 +0,0 @@ -Some issues left to take care of: - - o sane ~ handling on non-Unix platforms - - Currently on non-Unix, when the glob code encounters a tilde glob - (.e.g ~user/foo or ~/.cshrc), it simply returns that pattern - without doing any expansion (meaning perl will weed it out since a - file of that name isn't likely to exist). - - Please, if you have strong feelings about how tilde expansion - should be done on your favorite non-Unix platform(s), submit a - patch. - - o path separator handling - - Guido's code contains the assumption that the path separator is one - character (byte, probably) in length. Win32 doesn't object to the - true slash as a separator. I imagine MacPerl could change the SEP - cpp #define to ":". I have no idea what it is for VMS. Again, if - you have ideas and especially patches, please feel free to share - them. diff --git a/contrib/perl5/ext/File/Glob/bsd_glob.c b/contrib/perl5/ext/File/Glob/bsd_glob.c deleted file mode 100644 index 15ee659..0000000 --- a/contrib/perl5/ext/File/Glob/bsd_glob.c +++ /dev/null @@ -1,971 +0,0 @@ -/* - * Copyright (c) 1989, 1993 - * The Regents of the University of California. All rights reserved. - * - * This code is derived from software contributed to Berkeley by - * Guido van Rossum. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions - * are met: - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * 3. Neither the name of the University nor the names of its contributors - * may be used to endorse or promote products derived from this software - * without specific prior written permission. - * - * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - * SUCH DAMAGE. - */ - -#if defined(LIBC_SCCS) && !defined(lint) -static char sccsid[] = "@(#)glob.c 8.3 (Berkeley) 10/13/93"; -#endif /* LIBC_SCCS and not lint */ - -/* - * glob(3) -- a superset of the one defined in POSIX 1003.2. - * - * The [!...] convention to negate a range is supported (SysV, Posix, ksh). - * - * Optional extra services, controlled by flags not defined by POSIX: - * - * GLOB_QUOTE: - * Escaping convention: \ inhibits any special meaning the following - * character might have (except \ at end of string is retained). - * GLOB_MAGCHAR: - * Set in gl_flags if pattern contained a globbing character. - * GLOB_NOMAGIC: - * Same as GLOB_NOCHECK, but it will only append pattern if it did - * not contain any magic characters. [Used in csh style globbing] - * GLOB_ALTDIRFUNC: - * Use alternately specified directory access functions. - * GLOB_TILDE: - * expand ~user/foo to the /home/dir/of/user/foo - * GLOB_BRACE: - * expand {1,2}{a,b} to 1a 1b 2a 2b - * gl_matchc: - * Number of matches in the current invocation of glob. - * GLOB_ALPHASORT: - * sort alphabetically like csh (case doesn't matter) instead of in ASCII - * order - */ - -#include <EXTERN.h> -#include <perl.h> -#include <XSUB.h> - -#include "bsd_glob.h" -#ifdef I_PWD -# include <pwd.h> -#else -#ifdef HAS_PASSWD - struct passwd *getpwnam(char *); - struct passwd *getpwuid(Uid_t); -#endif -#endif - -#ifndef MAXPATHLEN -# ifdef PATH_MAX -# define MAXPATHLEN PATH_MAX -# ifdef MACOS_TRADITIONAL -# define MAXPATHLEN 255 -# else -# define MAXPATHLEN 1024 -# endif -# endif -#endif - -#define BG_DOLLAR '$' -#define BG_DOT '.' -#define BG_EOS '\0' -#define BG_LBRACKET '[' -#define BG_NOT '!' -#define BG_QUESTION '?' -#define BG_QUOTE '\\' -#define BG_RANGE '-' -#define BG_RBRACKET ']' -#ifdef MACOS_TRADITIONAL -# define BG_SEP ':' -#else -# define BG_SEP '/' -#endif -#ifdef DOSISH -#define BG_SEP2 '\\' -#endif -#define BG_STAR '*' -#define BG_TILDE '~' -#define BG_UNDERSCORE '_' -#define BG_LBRACE '{' -#define BG_RBRACE '}' -#define BG_SLASH '/' -#define BG_COMMA ',' - -#ifndef GLOB_DEBUG - -#define M_QUOTE 0x8000 -#define M_PROTECT 0x4000 -#define M_MASK 0xffff -#define M_ASCII 0x00ff - -typedef U16 Char; - -#else - -#define M_QUOTE 0x80 -#define M_PROTECT 0x40 -#define M_MASK 0xff -#define M_ASCII 0x7f - -typedef U8 Char; - -#endif /* !GLOB_DEBUG */ - - -#define CHAR(c) ((Char)((c)&M_ASCII)) -#define META(c) ((Char)((c)|M_QUOTE)) -#define M_ALL META('*') -#define M_END META(']') -#define M_NOT META('!') -#define M_ONE META('?') -#define M_RNG META('-') -#define M_SET META('[') -#define ismeta(c) (((c)&M_QUOTE) != 0) - - -static int compare(const void *, const void *); -static int ci_compare(const void *, const void *); -static void g_Ctoc(const Char *, char *); -static int g_lstat(Char *, Stat_t *, glob_t *); -static DIR *g_opendir(Char *, glob_t *); -static Char *g_strchr(Char *, int); -#ifdef notdef -static Char *g_strcat(Char *, const Char *); -#endif -static int g_stat(Char *, Stat_t *, glob_t *); -static int glob0(const Char *, glob_t *); -static int glob1(Char *, glob_t *); -static int glob2(Char *, Char *, Char *, glob_t *); -static int glob3(Char *, Char *, Char *, Char *, glob_t *); -static int globextend(const Char *, glob_t *); -static const Char * globtilde(const Char *, Char *, glob_t *); -static int globexp1(const Char *, glob_t *); -static int globexp2(const Char *, const Char *, glob_t *, int *); -static int match(Char *, Char *, Char *, int); -#ifdef GLOB_DEBUG -static void qprintf(const char *, Char *); -#endif /* GLOB_DEBUG */ - -#ifdef PERL_IMPLICIT_CONTEXT -static Direntry_t * my_readdir(DIR*); - -static Direntry_t * -my_readdir(DIR *d) -{ - return PerlDir_read(d); -} -#else -#define my_readdir readdir -#endif - -int -bsd_glob(const char *pattern, int flags, - int (*errfunc)(const char *, int), glob_t *pglob) -{ - const U8 *patnext; - int c; - Char *bufnext, *bufend, patbuf[MAXPATHLEN+1]; - - patnext = (U8 *) pattern; - if (!(flags & GLOB_APPEND)) { - pglob->gl_pathc = 0; - pglob->gl_pathv = NULL; - if (!(flags & GLOB_DOOFFS)) - pglob->gl_offs = 0; - } - pglob->gl_flags = flags & ~GLOB_MAGCHAR; - pglob->gl_errfunc = errfunc; - pglob->gl_matchc = 0; - - bufnext = patbuf; - bufend = bufnext + MAXPATHLEN; -#ifdef DOSISH - /* Nasty hack to treat patterns like "C:*" correctly. In this - * case, the * should match any file in the current directory - * on the C: drive. However, the glob code does not treat the - * colon specially, so it looks for files beginning "C:" in - * the current directory. To fix this, change the pattern to - * add an explicit "./" at the start (just after the drive - * letter and colon - ie change to "C:./*"). - */ - if (isalpha(pattern[0]) && pattern[1] == ':' && - pattern[2] != BG_SEP && pattern[2] != BG_SEP2 && - bufend - bufnext > 4) { - *bufnext++ = pattern[0]; - *bufnext++ = ':'; - *bufnext++ = '.'; - *bufnext++ = BG_SEP; - patnext += 2; - } -#endif - if (flags & GLOB_QUOTE) { - /* Protect the quoted characters. */ - while (bufnext < bufend && (c = *patnext++) != BG_EOS) - if (c == BG_QUOTE) { -#ifdef DOSISH - /* To avoid backslashitis on Win32, - * we only treat \ as a quoting character - * if it precedes one of the - * metacharacters []-{}~\ - */ - if ((c = *patnext++) != '[' && c != ']' && - c != '-' && c != '{' && c != '}' && - c != '~' && c != '\\') { -#else - if ((c = *patnext++) == BG_EOS) { -#endif - c = BG_QUOTE; - --patnext; - } - *bufnext++ = c | M_PROTECT; - } - else - *bufnext++ = c; - } - else - while (bufnext < bufend && (c = *patnext++) != BG_EOS) - *bufnext++ = c; - *bufnext = BG_EOS; - - if (flags & GLOB_BRACE) - return globexp1(patbuf, pglob); - else - return glob0(patbuf, pglob); -} - -/* - * Expand recursively a glob {} pattern. When there is no more expansion - * invoke the standard globbing routine to glob the rest of the magic - * characters - */ -static int globexp1(const Char *pattern, glob_t *pglob) -{ - const Char* ptr = pattern; - int rv; - - /* Protect a single {}, for find(1), like csh */ - if (pattern[0] == BG_LBRACE && pattern[1] == BG_RBRACE && pattern[2] == BG_EOS) - return glob0(pattern, pglob); - - while ((ptr = (const Char *) g_strchr((Char *) ptr, BG_LBRACE)) != NULL) - if (!globexp2(ptr, pattern, pglob, &rv)) - return rv; - - return glob0(pattern, pglob); -} - - -/* - * Recursive brace globbing helper. Tries to expand a single brace. - * If it succeeds then it invokes globexp1 with the new pattern. - * If it fails then it tries to glob the rest of the pattern and returns. - */ -static int globexp2(const Char *ptr, const Char *pattern, - glob_t *pglob, int *rv) -{ - int i; - Char *lm, *ls; - const Char *pe, *pm, *pl; - Char patbuf[MAXPATHLEN + 1]; - - /* copy part up to the brace */ - for (lm = patbuf, pm = pattern; pm != ptr; *lm++ = *pm++) - continue; - ls = lm; - - /* Find the balanced brace */ - for (i = 0, pe = ++ptr; *pe; pe++) - if (*pe == BG_LBRACKET) { - /* Ignore everything between [] */ - for (pm = pe++; *pe != BG_RBRACKET && *pe != BG_EOS; pe++) - continue; - if (*pe == BG_EOS) { - /* - * We could not find a matching BG_RBRACKET. - * Ignore and just look for BG_RBRACE - */ - pe = pm; - } - } - else if (*pe == BG_LBRACE) - i++; - else if (*pe == BG_RBRACE) { - if (i == 0) - break; - i--; - } - - /* Non matching braces; just glob the pattern */ - if (i != 0 || *pe == BG_EOS) { - *rv = glob0(patbuf, pglob); - return 0; - } - - for (i = 0, pl = pm = ptr; pm <= pe; pm++) - switch (*pm) { - case BG_LBRACKET: - /* Ignore everything between [] */ - for (pl = pm++; *pm != BG_RBRACKET && *pm != BG_EOS; pm++) - continue; - if (*pm == BG_EOS) { - /* - * We could not find a matching BG_RBRACKET. - * Ignore and just look for BG_RBRACE - */ - pm = pl; - } - break; - - case BG_LBRACE: - i++; - break; - - case BG_RBRACE: - if (i) { - i--; - break; - } - /* FALLTHROUGH */ - case BG_COMMA: - if (i && *pm == BG_COMMA) - break; - else { - /* Append the current string */ - for (lm = ls; (pl < pm); *lm++ = *pl++) - continue; - /* - * Append the rest of the pattern after the - * closing brace - */ - for (pl = pe + 1; (*lm++ = *pl++) != BG_EOS;) - continue; - - /* Expand the current pattern */ -#ifdef GLOB_DEBUG - qprintf("globexp2:", patbuf); -#endif /* GLOB_DEBUG */ - *rv = globexp1(patbuf, pglob); - - /* move after the comma, to the next string */ - pl = pm + 1; - } - break; - - default: - break; - } - *rv = 0; - return 0; -} - - - -/* - * expand tilde from the passwd file. - */ -static const Char * -globtilde(const Char *pattern, Char *patbuf, glob_t *pglob) -{ - struct passwd *pwd; - char *h; - const Char *p; - Char *b; - - if (*pattern != BG_TILDE || !(pglob->gl_flags & GLOB_TILDE)) - return pattern; - - /* Copy up to the end of the string or / */ - for (p = pattern + 1, h = (char *) patbuf; *p && *p != BG_SLASH; - *h++ = *p++) - continue; - - *h = BG_EOS; - - if (((char *) patbuf)[0] == BG_EOS) { - /* - * handle a plain ~ or ~/ by expanding $HOME - * first and then trying the password file - */ - if ((h = getenv("HOME")) == NULL) { -#ifdef HAS_PASSWD - if ((pwd = getpwuid(getuid())) == NULL) - return pattern; - else - h = pwd->pw_dir; -#else - return pattern; -#endif - } - } - else { - /* - * Expand a ~user - */ -#ifdef HAS_PASSWD - if ((pwd = getpwnam((char*) patbuf)) == NULL) - return pattern; - else - h = pwd->pw_dir; -#else - return pattern; -#endif - } - - /* Copy the home directory */ - for (b = patbuf; *h; *b++ = *h++) - continue; - - /* Append the rest of the pattern */ - while ((*b++ = *p++) != BG_EOS) - continue; - - return patbuf; -} - - -/* - * The main glob() routine: compiles the pattern (optionally processing - * quotes), calls glob1() to do the real pattern matching, and finally - * sorts the list (unless unsorted operation is requested). Returns 0 - * if things went well, nonzero if errors occurred. It is not an error - * to find no matches. - */ -static int -glob0(const Char *pattern, glob_t *pglob) -{ - const Char *qpat, *qpatnext; - int c, err, oldflags, oldpathc; - Char *bufnext, patbuf[MAXPATHLEN+1]; - -#ifdef MACOS_TRADITIONAL - if ( (*pattern == BG_TILDE) && (pglob->gl_flags & GLOB_TILDE) ) { - return(globextend(pattern, pglob)); - } -#endif - - qpat = globtilde(pattern, patbuf, pglob); - qpatnext = qpat; - oldflags = pglob->gl_flags; - oldpathc = pglob->gl_pathc; - bufnext = patbuf; - - /* We don't need to check for buffer overflow any more. */ - while ((c = *qpatnext++) != BG_EOS) { - switch (c) { - case BG_LBRACKET: - c = *qpatnext; - if (c == BG_NOT) - ++qpatnext; - if (*qpatnext == BG_EOS || - g_strchr((Char *) qpatnext+1, BG_RBRACKET) == NULL) { - *bufnext++ = BG_LBRACKET; - if (c == BG_NOT) - --qpatnext; - break; - } - *bufnext++ = M_SET; - if (c == BG_NOT) - *bufnext++ = M_NOT; - c = *qpatnext++; - do { - *bufnext++ = CHAR(c); - if (*qpatnext == BG_RANGE && - (c = qpatnext[1]) != BG_RBRACKET) { - *bufnext++ = M_RNG; - *bufnext++ = CHAR(c); - qpatnext += 2; - } - } while ((c = *qpatnext++) != BG_RBRACKET); - pglob->gl_flags |= GLOB_MAGCHAR; - *bufnext++ = M_END; - break; - case BG_QUESTION: - pglob->gl_flags |= GLOB_MAGCHAR; - *bufnext++ = M_ONE; - break; - case BG_STAR: - pglob->gl_flags |= GLOB_MAGCHAR; - /* collapse adjacent stars to one, - * to avoid exponential behavior - */ - if (bufnext == patbuf || bufnext[-1] != M_ALL) - *bufnext++ = M_ALL; - break; - default: - *bufnext++ = CHAR(c); - break; - } - } - *bufnext = BG_EOS; -#ifdef GLOB_DEBUG - qprintf("glob0:", patbuf); -#endif /* GLOB_DEBUG */ - - if ((err = glob1(patbuf, pglob)) != 0) { - pglob->gl_flags = oldflags; - return(err); - } - - /* - * If there was no match we are going to append the pattern - * if GLOB_NOCHECK was specified or if GLOB_NOMAGIC was specified - * and the pattern did not contain any magic characters - * GLOB_NOMAGIC is there just for compatibility with csh. - */ - if (pglob->gl_pathc == oldpathc && - ((pglob->gl_flags & GLOB_NOCHECK) || - ((pglob->gl_flags & GLOB_NOMAGIC) && - !(pglob->gl_flags & GLOB_MAGCHAR)))) - { -#ifdef GLOB_DEBUG - printf("calling globextend from glob0\n"); -#endif /* GLOB_DEBUG */ - pglob->gl_flags = oldflags; - return(globextend(qpat, pglob)); - } - else if (!(pglob->gl_flags & GLOB_NOSORT)) - qsort(pglob->gl_pathv + pglob->gl_offs + oldpathc, - pglob->gl_pathc - oldpathc, sizeof(char *), - (pglob->gl_flags & (GLOB_ALPHASORT|GLOB_NOCASE)) - ? ci_compare : compare); - pglob->gl_flags = oldflags; - return(0); -} - -static int -ci_compare(const void *p, const void *q) -{ - const char *pp = *(const char **)p; - const char *qq = *(const char **)q; - int ci; - while (*pp && *qq) { - if (tolower(*pp) != tolower(*qq)) - break; - ++pp; - ++qq; - } - ci = tolower(*pp) - tolower(*qq); - if (ci == 0) - return compare(p, q); - return ci; -} - -static int -compare(const void *p, const void *q) -{ - return(strcmp(*(char **)p, *(char **)q)); -} - -static int -glob1(Char *pattern, glob_t *pglob) -{ - Char pathbuf[MAXPATHLEN+1]; - - /* A null pathname is invalid -- POSIX 1003.1 sect. 2.4. */ - if (*pattern == BG_EOS) - return(0); - return(glob2(pathbuf, pathbuf, pattern, pglob)); -} - -/* - * The functions glob2 and glob3 are mutually recursive; there is one level - * of recursion for each segment in the pattern that contains one or more - * meta characters. - */ -static int -glob2(Char *pathbuf, Char *pathend, Char *pattern, glob_t *pglob) -{ - Stat_t sb; - Char *p, *q; - int anymeta; - - /* - * Loop over pattern segments until end of pattern or until - * segment with meta character found. - */ - for (anymeta = 0;;) { - if (*pattern == BG_EOS) { /* End of pattern? */ - *pathend = BG_EOS; - - if (g_lstat(pathbuf, &sb, pglob)) - return(0); - - if (((pglob->gl_flags & GLOB_MARK) && - pathend[-1] != BG_SEP -#ifdef DOSISH - && pathend[-1] != BG_SEP2 -#endif - ) && (S_ISDIR(sb.st_mode) - || (S_ISLNK(sb.st_mode) && - (g_stat(pathbuf, &sb, pglob) == 0) && - S_ISDIR(sb.st_mode)))) { - *pathend++ = BG_SEP; - *pathend = BG_EOS; - } - ++pglob->gl_matchc; -#ifdef GLOB_DEBUG - printf("calling globextend from glob2\n"); -#endif /* GLOB_DEBUG */ - return(globextend(pathbuf, pglob)); - } - - /* Find end of next segment, copy tentatively to pathend. */ - q = pathend; - p = pattern; - while (*p != BG_EOS && *p != BG_SEP -#ifdef DOSISH - && *p != BG_SEP2 -#endif - ) { - if (ismeta(*p)) - anymeta = 1; - *q++ = *p++; - } - - if (!anymeta) { /* No expansion, do next segment. */ - pathend = q; - pattern = p; - while (*pattern == BG_SEP -#ifdef DOSISH - || *pattern == BG_SEP2 -#endif - ) - *pathend++ = *pattern++; - } else /* Need expansion, recurse. */ - return(glob3(pathbuf, pathend, pattern, p, pglob)); - } - /* NOTREACHED */ -} - -static int -glob3(Char *pathbuf, Char *pathend, Char *pattern, - Char *restpattern, glob_t *pglob) -{ - register Direntry_t *dp; - DIR *dirp; - int err; - int nocase; - char buf[MAXPATHLEN]; - - /* - * The readdirfunc declaration can't be prototyped, because it is - * assigned, below, to two functions which are prototyped in glob.h - * and dirent.h as taking pointers to differently typed opaque - * structures. - */ - Direntry_t *(*readdirfunc)(DIR*); - - *pathend = BG_EOS; - errno = 0; - -#ifdef VMS - { - Char *q = pathend; - if (q - pathbuf > 5) { - q -= 5; - if (q[0] == '.' && tolower(q[1]) == 'd' && tolower(q[2]) == 'i' - && tolower(q[3]) == 'r' && q[4] == '/') - { - q[0] = '/'; - q[1] = BG_EOS; - pathend = q+1; - } - } - } -#endif - if ((dirp = g_opendir(pathbuf, pglob)) == NULL) { - /* TODO: don't call for ENOENT or ENOTDIR? */ - if (pglob->gl_errfunc) { - g_Ctoc(pathbuf, buf); - if (pglob->gl_errfunc(buf, errno) || - (pglob->gl_flags & GLOB_ERR)) - return (GLOB_ABEND); - } - return(0); - } - - err = 0; - nocase = ((pglob->gl_flags & GLOB_NOCASE) != 0); - - /* Search directory for matching names. */ - if (pglob->gl_flags & GLOB_ALTDIRFUNC) - readdirfunc = (Direntry_t *(*)(DIR *))pglob->gl_readdir; - else - readdirfunc = my_readdir; - while ((dp = (*readdirfunc)(dirp))) { - register U8 *sc; - register Char *dc; - - /* Initial BG_DOT must be matched literally. */ - if (dp->d_name[0] == BG_DOT && *pattern != BG_DOT) - continue; - for (sc = (U8 *) dp->d_name, dc = pathend; - (*dc++ = *sc++) != BG_EOS;) - continue; - if (!match(pathend, pattern, restpattern, nocase)) { - *pathend = BG_EOS; - continue; - } - err = glob2(pathbuf, --dc, restpattern, pglob); - if (err) - break; - } - - if (pglob->gl_flags & GLOB_ALTDIRFUNC) - (*pglob->gl_closedir)(dirp); - else - PerlDir_close(dirp); - return(err); -} - - -/* - * Extend the gl_pathv member of a glob_t structure to accomodate a new item, - * add the new item, and update gl_pathc. - * - * This assumes the BSD realloc, which only copies the block when its size - * crosses a power-of-two boundary; for v7 realloc, this would cause quadratic - * behavior. - * - * Return 0 if new item added, error code if memory couldn't be allocated. - * - * Invariant of the glob_t structure: - * Either gl_pathc is zero and gl_pathv is NULL; or gl_pathc > 0 and - * gl_pathv points to (gl_offs + gl_pathc + 1) items. - */ -static int -globextend(const Char *path, glob_t *pglob) -{ - register char **pathv; - register int i; - char *copy; - const Char *p; - -#ifdef GLOB_DEBUG - printf("Adding "); - for (p = path; *p; p++) - (void)printf("%c", CHAR(*p)); - printf("\n"); -#endif /* GLOB_DEBUG */ - - if (pglob->gl_pathv) - pathv = Renew(pglob->gl_pathv, - (2 + pglob->gl_pathc + pglob->gl_offs),char*); - else - New(0,pathv,(2 + pglob->gl_pathc + pglob->gl_offs),char*); - if (pathv == NULL) - return(GLOB_NOSPACE); - - if (pglob->gl_pathv == NULL && pglob->gl_offs > 0) { - /* first time around -- clear initial gl_offs items */ - pathv += pglob->gl_offs; - for (i = pglob->gl_offs; --i >= 0; ) - *--pathv = NULL; - } - pglob->gl_pathv = pathv; - - for (p = path; *p++;) - continue; - New(0, copy, p-path, char); - if (copy != NULL) { - g_Ctoc(path, copy); - pathv[pglob->gl_offs + pglob->gl_pathc++] = copy; - } - pathv[pglob->gl_offs + pglob->gl_pathc] = NULL; - return(copy == NULL ? GLOB_NOSPACE : 0); -} - - -/* - * pattern matching function for filenames. Each occurrence of the * - * pattern causes a recursion level. - */ -static int -match(register Char *name, register Char *pat, register Char *patend, int nocase) -{ - int ok, negate_range; - Char c, k; - - while (pat < patend) { - c = *pat++; - switch (c & M_MASK) { - case M_ALL: - if (pat == patend) - return(1); - do - if (match(name, pat, patend, nocase)) - return(1); - while (*name++ != BG_EOS); - return(0); - case M_ONE: - if (*name++ == BG_EOS) - return(0); - break; - case M_SET: - ok = 0; - if ((k = *name++) == BG_EOS) - return(0); - if ((negate_range = ((*pat & M_MASK) == M_NOT)) != BG_EOS) - ++pat; - while (((c = *pat++) & M_MASK) != M_END) - if ((*pat & M_MASK) == M_RNG) { - if (nocase) { - if (tolower(c) <= tolower(k) && tolower(k) <= tolower(pat[1])) - ok = 1; - } else { - if (c <= k && k <= pat[1]) - ok = 1; - } - pat += 2; - } else if (nocase ? (tolower(c) == tolower(k)) : (c == k)) - ok = 1; - if (ok == negate_range) - return(0); - break; - default: - k = *name++; - if (nocase ? (tolower(k) != tolower(c)) : (k != c)) - return(0); - break; - } - } - return(*name == BG_EOS); -} - -/* Free allocated data belonging to a glob_t structure. */ -void -bsd_globfree(glob_t *pglob) -{ - register int i; - register char **pp; - - if (pglob->gl_pathv != NULL) { - pp = pglob->gl_pathv + pglob->gl_offs; - for (i = pglob->gl_pathc; i--; ++pp) - if (*pp) - Safefree(*pp); - Safefree(pglob->gl_pathv); - } -} - -static DIR * -g_opendir(register Char *str, glob_t *pglob) -{ - char buf[MAXPATHLEN]; - - if (!*str) { -#ifdef MACOS_TRADITIONAL - strcpy(buf, ":"); -#else - strcpy(buf, "."); -#endif - } else { - g_Ctoc(str, buf); - } - - if (pglob->gl_flags & GLOB_ALTDIRFUNC) - return((*pglob->gl_opendir)(buf)); - else - return(PerlDir_open(buf)); -} - -static int -g_lstat(register Char *fn, Stat_t *sb, glob_t *pglob) -{ - char buf[MAXPATHLEN]; - - g_Ctoc(fn, buf); - if (pglob->gl_flags & GLOB_ALTDIRFUNC) - return((*pglob->gl_lstat)(buf, sb)); -#ifdef HAS_LSTAT - return(PerlLIO_lstat(buf, sb)); -#else - return(PerlLIO_stat(buf, sb)); -#endif /* HAS_LSTAT */ -} - -static int -g_stat(register Char *fn, Stat_t *sb, glob_t *pglob) -{ - char buf[MAXPATHLEN]; - - g_Ctoc(fn, buf); - if (pglob->gl_flags & GLOB_ALTDIRFUNC) - return((*pglob->gl_stat)(buf, sb)); - return(PerlLIO_stat(buf, sb)); -} - -static Char * -g_strchr(Char *str, int ch) -{ - do { - if (*str == ch) - return (str); - } while (*str++); - return (NULL); -} - -#ifdef notdef -static Char * -g_strcat(Char *dst, const Char *src) -{ - Char *sdst = dst; - - while (*dst++) - continue; - --dst; - while((*dst++ = *src++) != BG_EOS) - continue; - - return (sdst); -} -#endif - -static void -g_Ctoc(register const Char *str, char *buf) -{ - register char *dc; - - for (dc = buf; (*dc++ = *str++) != BG_EOS;) - continue; -} - -#ifdef GLOB_DEBUG -static void -qprintf(const char *str, register Char *s) -{ - register Char *p; - - (void)printf("%s:\n", str); - for (p = s; *p; p++) - (void)printf("%c", CHAR(*p)); - (void)printf("\n"); - for (p = s; *p; p++) - (void)printf("%c", *p & M_PROTECT ? '"' : ' '); - (void)printf("\n"); - for (p = s; *p; p++) - (void)printf("%c", ismeta(*p) ? '_' : ' '); - (void)printf("\n"); -} -#endif /* GLOB_DEBUG */ diff --git a/contrib/perl5/ext/File/Glob/bsd_glob.h b/contrib/perl5/ext/File/Glob/bsd_glob.h deleted file mode 100644 index 5d04fff..0000000 --- a/contrib/perl5/ext/File/Glob/bsd_glob.h +++ /dev/null @@ -1,83 +0,0 @@ -/* - * Copyright (c) 1989, 1993 - * The Regents of the University of California. All rights reserved. - * - * This code is derived from software contributed to Berkeley by - * Guido van Rossum. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions - * are met: - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * 3. Neither the name of the University nor the names of its contributors - * may be used to endorse or promote products derived from this software - * without specific prior written permission. - * - * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - * SUCH DAMAGE. - * - * @(#)glob.h 8.1 (Berkeley) 6/2/93 - */ - -#ifndef _BSD_GLOB_H_ -#define _BSD_GLOB_H_ - -/* #include <sys/cdefs.h> */ - -typedef struct { - int gl_pathc; /* Count of total paths so far. */ - int gl_matchc; /* Count of paths matching pattern. */ - int gl_offs; /* Reserved at beginning of gl_pathv. */ - int gl_flags; /* Copy of flags parameter to glob. */ - char **gl_pathv; /* List of paths matching pattern. */ - /* Copy of errfunc parameter to glob. */ - int (*gl_errfunc)(const char *, int); - - /* - * Alternate filesystem access methods for glob; replacement - * versions of closedir(3), readdir(3), opendir(3), stat(2) - * and lstat(2). - */ - void (*gl_closedir)(void *); - Direntry_t *(*gl_readdir)(void *); - void *(*gl_opendir)(const char *); - int (*gl_lstat)(const char *, Stat_t *); - int (*gl_stat)(const char *, Stat_t *); -} glob_t; - -#define GLOB_APPEND 0x0001 /* Append to output from previous call. */ -#define GLOB_DOOFFS 0x0002 /* Use gl_offs. */ -#define GLOB_ERR 0x0004 /* Return on error. */ -#define GLOB_MARK 0x0008 /* Append / to matching directories. */ -#define GLOB_NOCHECK 0x0010 /* Return pattern itself if nothing matches. */ -#define GLOB_NOSORT 0x0020 /* Don't sort. */ - -#define GLOB_ALTDIRFUNC 0x0040 /* Use alternately specified directory funcs. */ -#define GLOB_BRACE 0x0080 /* Expand braces ala csh. */ -#define GLOB_MAGCHAR 0x0100 /* Pattern had globbing characters. */ -#define GLOB_NOMAGIC 0x0200 /* GLOB_NOCHECK without magic chars (csh). */ -#define GLOB_QUOTE 0x0400 /* Quote special chars with \. */ -#define GLOB_TILDE 0x0800 /* Expand tilde names from the passwd file. */ -#define GLOB_NOCASE 0x1000 /* Treat filenames without regard for case. */ -#define GLOB_ALPHASORT 0x2000 /* Alphabetic, not ASCII sort, like csh. */ - -#define GLOB_NOSPACE (-1) /* Malloc call failed. */ -#define GLOB_ABEND (-2) /* Unignored error. */ - -int bsd_glob(const char *, int, int (*)(const char *, int), glob_t *); -void bsd_globfree(glob_t *); - -#endif /* !_BSD_GLOB_H_ */ diff --git a/contrib/perl5/ext/GDBM_File/GDBM_File.pm b/contrib/perl5/ext/GDBM_File/GDBM_File.pm deleted file mode 100644 index 310243c..0000000 --- a/contrib/perl5/ext/GDBM_File/GDBM_File.pm +++ /dev/null @@ -1,89 +0,0 @@ -# GDBM_File.pm -- Perl 5 interface to GNU gdbm library. - -=head1 NAME - -GDBM_File - Perl5 access to the gdbm library. - -=head1 SYNOPSIS - - use GDBM_File ; - tie %hash, 'GDBM_File', $filename, &GDBM_WRCREAT, 0640; - # Use the %hash array. - untie %hash ; - -=head1 DESCRIPTION - -B<GDBM_File> is a module which allows Perl programs to make use of the -facilities provided by the GNU gdbm library. If you intend to use this -module you should really have a copy of the gdbm manualpage at hand. - -Most of the libgdbm.a functions are available through the GDBM_File -interface. - -=head1 AVAILABILITY - -Gdbm is available from any GNU archive. The master site is -C<prep.ai.mit.edu>, but your are strongly urged to use one of the many -mirrors. You can obtain a list of mirror sites by issuing the -command C<finger fsf@prep.ai.mit.edu>. - -=head1 BUGS - -The available functions and the gdbm/perl interface need to be documented. - -=head1 SEE ALSO - -L<perl(1)>, L<DB_File(3)>, L<perldbmfilter>. - -=cut - -package GDBM_File; - -use strict; -use warnings; -our($VERSION, @ISA, @EXPORT, $AUTOLOAD); - -require Carp; -require Tie::Hash; -require Exporter; -use AutoLoader; -use XSLoader (); -@ISA = qw(Tie::Hash Exporter); -@EXPORT = qw( - GDBM_CACHESIZE - GDBM_FAST - GDBM_INSERT - GDBM_NEWDB - GDBM_NOLOCK - GDBM_READER - GDBM_REPLACE - GDBM_WRCREAT - GDBM_WRITER -); - -$VERSION = "1.05"; - -sub AUTOLOAD { - my($constname); - ($constname = $AUTOLOAD) =~ s/.*:://; - my $val = constant($constname, @_ ? $_[0] : 0); - if ($! != 0) { - if ($! =~ /Invalid/ || $!{EINVAL}) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } - else { - Carp::croak("Your vendor has not defined GDBM_File macro $constname, used"); - } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - -XSLoader::load 'GDBM_File', $VERSION; - -# Preloaded methods go here. Autoload methods go after __END__, and are -# processed by the autosplit program. - -1; -__END__ diff --git a/contrib/perl5/ext/GDBM_File/GDBM_File.xs b/contrib/perl5/ext/GDBM_File/GDBM_File.xs deleted file mode 100644 index 5e426f9..0000000 --- a/contrib/perl5/ext/GDBM_File/GDBM_File.xs +++ /dev/null @@ -1,363 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#include <gdbm.h> -#include <fcntl.h> - -typedef struct { - GDBM_FILE dbp ; - SV * filter_fetch_key ; - SV * filter_store_key ; - SV * filter_fetch_value ; - SV * filter_store_value ; - int filtering ; - } GDBM_File_type; - -typedef GDBM_File_type * GDBM_File ; -typedef datum datum_key ; -typedef datum datum_value ; - -#define ckFilter(arg,type,name) \ - if (db->type) { \ - SV * save_defsv ; \ - /* printf("filtering %s\n", name) ;*/ \ - if (db->filtering) \ - croak("recursion detected in %s", name) ; \ - db->filtering = TRUE ; \ - save_defsv = newSVsv(DEFSV) ; \ - sv_setsv(DEFSV, arg) ; \ - PUSHMARK(sp) ; \ - (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); \ - sv_setsv(arg, DEFSV) ; \ - sv_setsv(DEFSV, save_defsv) ; \ - SvREFCNT_dec(save_defsv) ; \ - db->filtering = FALSE ; \ - /*printf("end of filtering %s\n", name) ;*/ \ - } - - - -#define GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */ - -typedef void (*FATALFUNC)(); - -#ifndef GDBM_FAST -static int -not_here(char *s) -{ - croak("GDBM_File::%s not implemented on this architecture", s); - return -1; -} -#endif - -/* GDBM allocates the datum with system malloc() and expects the user - * to free() it. So we either have to free() it immediately, or have - * perl free() it when it deallocates the SV, depending on whether - * perl uses malloc()/free() or not. */ -static void -output_datum(pTHX_ SV *arg, char *str, int size) -{ -#if !defined(MYMALLOC) || (defined(MYMALLOC) && defined(PERL_POLLUTE_MALLOC) && !defined(LEAKTEST)) - sv_usepvn(arg, str, size); -#else - sv_setpvn(arg, str, size); - safesysfree(str); -#endif -} - -/* Versions of gdbm prior to 1.7x might not have the gdbm_sync, - gdbm_exists, and gdbm_setopt functions. Apparently Slackware - (Linux) 2.1 contains gdbm-1.5 (which dates back to 1991). -*/ -#ifndef GDBM_FAST -#define gdbm_exists(db,key) not_here("gdbm_exists") -#define gdbm_sync(db) (void) not_here("gdbm_sync") -#define gdbm_setopt(db,optflag,optval,optlen) not_here("gdbm_setopt") -#endif - -static double -constant(char *name, int arg) -{ - errno = 0; - switch (*name) { - case 'A': - break; - case 'B': - break; - case 'C': - break; - case 'D': - break; - case 'E': - break; - case 'F': - break; - case 'G': - if (strEQ(name, "GDBM_CACHESIZE")) -#ifdef GDBM_CACHESIZE - return GDBM_CACHESIZE; -#else - goto not_there; -#endif - if (strEQ(name, "GDBM_FAST")) -#ifdef GDBM_FAST - return GDBM_FAST; -#else - goto not_there; -#endif - if (strEQ(name, "GDBM_FASTMODE")) -#ifdef GDBM_FASTMODE - return GDBM_FASTMODE; -#else - goto not_there; -#endif - if (strEQ(name, "GDBM_INSERT")) -#ifdef GDBM_INSERT - return GDBM_INSERT; -#else - goto not_there; -#endif - if (strEQ(name, "GDBM_NEWDB")) -#ifdef GDBM_NEWDB - return GDBM_NEWDB; -#else - goto not_there; -#endif - if (strEQ(name, "GDBM_NOLOCK")) -#ifdef GDBM_NOLOCK - return GDBM_NOLOCK; -#else - goto not_there; -#endif - if (strEQ(name, "GDBM_READER")) -#ifdef GDBM_READER - return GDBM_READER; -#else - goto not_there; -#endif - if (strEQ(name, "GDBM_REPLACE")) -#ifdef GDBM_REPLACE - return GDBM_REPLACE; -#else - goto not_there; -#endif - if (strEQ(name, "GDBM_WRCREAT")) -#ifdef GDBM_WRCREAT - return GDBM_WRCREAT; -#else - goto not_there; -#endif - if (strEQ(name, "GDBM_WRITER")) -#ifdef GDBM_WRITER - return GDBM_WRITER; -#else - goto not_there; -#endif - break; - case 'H': - break; - case 'I': - break; - case 'J': - break; - case 'K': - break; - case 'L': - break; - case 'M': - break; - case 'N': - break; - case 'O': - break; - case 'P': - break; - case 'Q': - break; - case 'R': - break; - case 'S': - break; - case 'T': - break; - case 'U': - break; - case 'V': - break; - case 'W': - break; - case 'X': - break; - case 'Y': - break; - case 'Z': - break; - } - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - -MODULE = GDBM_File PACKAGE = GDBM_File PREFIX = gdbm_ - -double -constant(name,arg) - char * name - int arg - - -GDBM_File -gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func = (FATALFUNC)croak) - char * dbtype - char * name - int read_write - int mode - FATALFUNC fatal_func - CODE: - { - GDBM_FILE dbp ; - - RETVAL = NULL ; - if ((dbp = gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode, fatal_func))) { - RETVAL = (GDBM_File)safemalloc(sizeof(GDBM_File_type)) ; - Zero(RETVAL, 1, GDBM_File_type) ; - RETVAL->dbp = dbp ; - } - - } - OUTPUT: - RETVAL - - -#define gdbm_close(db) gdbm_close(db->dbp) -void -gdbm_close(db) - GDBM_File db - CLEANUP: - -void -gdbm_DESTROY(db) - GDBM_File db - CODE: - gdbm_close(db); - safefree(db); - -#define gdbm_FETCH(db,key) gdbm_fetch(db->dbp,key) -datum_value -gdbm_FETCH(db, key) - GDBM_File db - datum_key key - -#define gdbm_STORE(db,key,value,flags) gdbm_store(db->dbp,key,value,flags) -int -gdbm_STORE(db, key, value, flags = GDBM_REPLACE) - GDBM_File db - datum_key key - datum_value value - int flags - CLEANUP: - if (RETVAL) { - if (RETVAL < 0 && errno == EPERM) - croak("No write permission to gdbm file"); - croak("gdbm store returned %d, errno %d, key \"%.*s\"", - RETVAL,errno,key.dsize,key.dptr); - } - -#define gdbm_DELETE(db,key) gdbm_delete(db->dbp,key) -int -gdbm_DELETE(db, key) - GDBM_File db - datum_key key - -#define gdbm_FIRSTKEY(db) gdbm_firstkey(db->dbp) -datum_key -gdbm_FIRSTKEY(db) - GDBM_File db - -#define gdbm_NEXTKEY(db,key) gdbm_nextkey(db->dbp,key) -datum_key -gdbm_NEXTKEY(db, key) - GDBM_File db - datum_key key - -#define gdbm_reorganize(db) gdbm_reorganize(db->dbp) -int -gdbm_reorganize(db) - GDBM_File db - - -#define gdbm_sync(db) gdbm_sync(db->dbp) -void -gdbm_sync(db) - GDBM_File db - -#define gdbm_EXISTS(db,key) gdbm_exists(db->dbp,key) -int -gdbm_EXISTS(db, key) - GDBM_File db - datum_key key - -#define gdbm_setopt(db,optflag, optval, optlen) gdbm_setopt(db->dbp,optflag, optval, optlen) -int -gdbm_setopt (db, optflag, optval, optlen) - GDBM_File db - int optflag - int &optval - int optlen - - -#define setFilter(type) \ - { \ - if (db->type) \ - RETVAL = sv_mortalcopy(db->type) ; \ - ST(0) = RETVAL ; \ - if (db->type && (code == &PL_sv_undef)) { \ - SvREFCNT_dec(db->type) ; \ - db->type = NULL ; \ - } \ - else if (code) { \ - if (db->type) \ - sv_setsv(db->type, code) ; \ - else \ - db->type = newSVsv(code) ; \ - } \ - } - - - -SV * -filter_fetch_key(db, code) - GDBM_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_fetch_key) ; - -SV * -filter_store_key(db, code) - GDBM_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_store_key) ; - -SV * -filter_fetch_value(db, code) - GDBM_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_fetch_value) ; - -SV * -filter_store_value(db, code) - GDBM_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_store_value) ; - diff --git a/contrib/perl5/ext/GDBM_File/Makefile.PL b/contrib/perl5/ext/GDBM_File/Makefile.PL deleted file mode 100644 index 2a7256f..0000000 --- a/contrib/perl5/ext/GDBM_File/Makefile.PL +++ /dev/null @@ -1,8 +0,0 @@ -use ExtUtils::MakeMaker; -WriteMakefile( - NAME => 'GDBM_File', - LIBS => ["-L/usr/local/lib -lgdbm", "-ldbm"], - MAN3PODS => {}, # Pods will be built by installman. - XSPROTOARG => '-noprototypes', # XXX remove later? - VERSION_FROM => 'GDBM_File.pm', -); diff --git a/contrib/perl5/ext/GDBM_File/hints/sco.pl b/contrib/perl5/ext/GDBM_File/hints/sco.pl deleted file mode 100644 index 5c74a77..0000000 --- a/contrib/perl5/ext/GDBM_File/hints/sco.pl +++ /dev/null @@ -1,2 +0,0 @@ -# SCO OSR5 needs to link with libc.so again to have C<fsync> defined -$self->{LIBS} = ['-lgdbm -lc']; diff --git a/contrib/perl5/ext/GDBM_File/typemap b/contrib/perl5/ext/GDBM_File/typemap deleted file mode 100644 index 1dd0630..0000000 --- a/contrib/perl5/ext/GDBM_File/typemap +++ /dev/null @@ -1,38 +0,0 @@ -# -#################################### DBM SECTION -# - -datum_key T_DATUM_K -datum_value T_DATUM_V -NDBM_File T_PTROBJ -GDBM_File T_PTROBJ -SDBM_File T_PTROBJ -ODBM_File T_PTROBJ -DB_File T_PTROBJ -DBZ_File T_PTROBJ -FATALFUNC T_OPAQUEPTR - -INPUT -T_DATUM_K - ckFilter($arg, filter_store_key, \"filter_store_key\"); - $var.dptr = SvPV($arg, PL_na); - $var.dsize = (int)PL_na; -T_DATUM_V - ckFilter($arg, filter_store_value, \"filter_store_value\"); - if (SvOK($arg)) { - $var.dptr = SvPV($arg, PL_na); - $var.dsize = (int)PL_na; - } - else { - $var.dptr = \"\"; - $var.dsize = 0; - } -OUTPUT -T_DATUM_K - output_datum(aTHX_ $arg, $var.dptr, $var.dsize); - ckFilter($arg, filter_fetch_key,\"filter_fetch_key\"); -T_DATUM_V - output_datum(aTHX_ $arg, $var.dptr, $var.dsize); - ckFilter($arg, filter_fetch_value,\"filter_fetch_value\"); -T_PTROBJ - sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/contrib/perl5/ext/IO/ChangeLog b/contrib/perl5/ext/IO/ChangeLog deleted file mode 100644 index c45e785..0000000 --- a/contrib/perl5/ext/IO/ChangeLog +++ /dev/null @@ -1,318 +0,0 @@ -For more recent changes, see the Perl Changes* file(s). - -Change 173 on 1998/07/14 by <gbarr@pobox.com> (Graham Barr) - - IO::Socket - - Added method connected - - IO.xs - - Added check that file * is not null - - t/io_udp.t - - Added check for connected - - Made change to catch recv not returning the address, and added a fix to - ensure test does not hang - - t/io_sock.t - - Added check for connected. - -Change 137 on 1998/05/21 by <gbarr@pobox.com> (Graham Barr) - - IO::Socket::INET - - Added checks to all peer* and host* methods for undef - -Change 134 on 1998/05/09 by <gbarr@pobox.com> (Graham Barr) - - t/io_sock.t - - fix race condition on Solaris & SunOS - - IO::Handle - - Applied patch from Gisle Aas <gisle@aas.no> for - documentation update - - Applied patch from Kuma <tgy@chocobo.org> - changed input_line_number to be on a per-handle basis. - - IO::File - - Applied patch from Gisle Aas <gisle@aas.no> for - documentation update - - IO::Seekable - - Applied patch from Gisle Aas <gisle@aas.no> for - documentation update - added sysseek - - IO, IO::Socket::INET - - documentation update - - IO.xs - - Applied patch from Gisle Aas <gisle@aas.no> for - blocking - -Change 133 on 1998/05/09 by <gbarr@pobox.com> (Graham Barr) - - t/io_sock.t - - Added checks for blocking() - -Sun Apr 12 1998 <gbarr@pobox.com> (Graham Barr) - - IO.xs - - enclosed newCONSTSUB in #ifdef as _64 now defines it. - -Thu Mar 19 1998 <gbarr@pobox.com> (Graham Barr) - - All - - Changed copyright/distribution policy back to be the same as perl - -Sun Feb 15 1998 <gbarr@pobox.com> (Graham Barr) - - IO::Socket - - Fix to ->accept, accept() returns false on error not undef. - -*** Release 1.19 - -Thu Feb 5 1998 <gbarr@pobox.com> (Graham Barr) - - All - - change copyright notice - - IO::Socket::INET - - changed configure to accept PeerHost and LocalHost as well as the - PeerAddr and LocalAddr arguments. - -Mon Feb 2 1998 <gbarr@pobox.com> (Graham Barr) - - IO::Handle - - Added printflush so that flush.pl can be depreciated - - IO::Socket - - Remove C<use Config> statement as it was not needed - -Tue Jan 27 1998 <gbarr@pobox.com> (Graham Barr) - - IO::Socket::INET - - removed carp if $^W - -*** Patch 1.1804 - -Sat Jan 17 1998 <gbarr@pobox.com> (Graham Barr) - - t/io_sock.t - - Replaced C<Listen => 0> with C<LocalAddr => 'localhost'> - - IO/Socket/INET.pm - - Modified the MultiHomed code. Now each address for a given host has - a timeout of C<Timeout>. - - added _get_addr method for doing hostname lookups. Now Net::DNS can be - use by sub-classing IO::Socket::INET, Thanks Gisle Aas - - t/io_multihomed.t - - new test added. Thanks Gisle Aas. - -*** Patch 1.1803 - -Mon Nov 17 1997 <gbarr@pobox.com> (Graham Barr) - - poll.c - - Added #ifdef I_* tests - - IO::Socket - - Changed initialization of @domain2pkg to fix problem of Domain option - not working - - Added patch for multi-homed hosts, Thanks to Gisle Aas <gisle@aas.no> - - IO::Socket::INET - - Change default proto to getprotobyname instead of 'tcp' constant string - - Added patch for multi-homed hosts, Thanks to Gisle Aas <gisle@aas.no> - - t/io_sock.t - - Change to test fix for Domain problem fixed in IO::Socket and be - more comprehensive, Thanks to Gisle Aas <gisle@aas.no> - - t/io_unix.t - - New test, Thanks to Gisle Aas <gisle@aas.no> - -*** Patch 1.1802 - -Wed Nov 12 1997 <gbarr@pobox.com> (Graham Barr) - - t/io_poll.t - - test 4 made an assumption that was not portable, fixed. - -*** Patch 1.1801 - -Wed Oct 22 1997 <gbarr@pobox.com> (Graham Barr) - - IO.xs - - change #ifdef's to allow compilation with 5.002 - - IO::Socket - - Fix to ensure that socket is not returned as non-blocking - unless the user asks for it - - t/io_udp.t - - Fix to stop endless loop - -*** Release 1.18 - -Mon Oct 13 1997 <gbarr@pobox.com> (Graham Barr) - - IO.xs, IO::Handle - - 1.17 broke compatability with 5.003, small tweaks to restore - compatability - - t/io_const.t - - Added new test to ensure backwards compatability with constants - is not broken - -Wed Oct 8 1997 <gbarr@pobox.com> (Graham Barr) - - IO.xs - - Added #define's to cope with argument changes to start_subparse - from 5.003_22, _23 and _24 - - IO::Select - - Renamed has_error to be has_exception which is more correct, - has_error is a wrapper around has_exception with a warning if - $^W is set. - - Makefile.PL - - Remove 'linkext' option to WriteMakefile so that static linking - should work properly, cannot remember why I added it. - -Sun Oct 5 1997 <gbarr@pobox.com> (Graham Barr) - - IO::Pipe - - GLOB assignment does not copy the fileno while under -T - added checks for undefined fileno, and added fdopen - - reader and write can now be called as static methods - - Makefile.PL - - Attempt to locate <poll.h> and define I_POLL if found - -*** Release 1.17 - -Fri Sep 26 1997 <gbarr@pobox.com> (Graham Barr) - - IO.xs - - Fix bug in _poll for ANSI C compilers - - IO::Socket - - Split IO::Socket::INET and IO::Socket::UNIX into separate files - - IO::File - - Patch to open() for when file is in current directory. - -*** Release 1.16 - -Mon 15 Sep 1997 <gbarr@pobox.com> Graham Barr - - o New modules - - IO::Dir - - IO::Poll - - o IO::Socket - - Changed new to call autoflush on the new socket - - IO::Socket::INET->new now accepts a single argument - - IO::Socket::INET default to protocol 'tcp' - - o IO::File - - Added doc for new_tmpfile - - o IO::Handle - - Removed use of AutoLoader for constants, constants are - now defined as constant XS subs - - Added fsync, but will not be avaliable for use - unless HAS_FSYNC is defined, perls configure does not define - this yet. - - Moved bootstrap of IO.xs to IO.pm. IO::Handle no longer - contains an AUTOLOAD sub in it's ISA hier - - o IO::Seekable - - Remove clearerr, as it is defined in IO.xs - - o IO.xs - - Patched IO.xs with patch from Chip for setvbuf warning - - Added XS sub "constant" for backwards compatability - - o Misc - - Fixed IO::Socket::configure, it was not passing $arg to domain - specific package - - Changed all $fh variables in IO::Handle to $io and all $fh - variables in IO::Socket to $sock as Chip suggested - - Fixed usage messages to be consistant - -*** Release 1.15 - -Sun 19 Jan 1997 <bodg@tiuk.ti.com> Graham Barr - - o Updated PODs for IO::Handle and IO::File - o Modified IO.xs so that DESTROY gets called on IO::File - objects that were created with IO::File->new_tmpfile - o Modified the domain2pkg code in IO::Socket so that it - does not use blessd refs - o Created a new package IO::Pipe::End so that pipe specific - stuff can be moved out of IO::Handle. - o Added Ilya's OS/2 changes to Pipe.pm and io_pipe.t - - o These changes happened somtime before the release of 1.15 - - added shutdown to IO::Socket - - modified connect to not use alarm - - modified accept and connect to use IO::Select - -*** Release 1.14 - -Tue 24 Dec 1996 <bodg@tiuk.ti.com> Graham Barr - - o Updated to patches in perl core dist. - o Added C<use strict> to all modules - o Modified t/io_sock.t, hopefully the race condition has gone - o Added close statements to reader/writer in IO::Pipe - o IO::Handle::syswrite was calling sysread, fixed :-) - -*** Release 1.12 - -Thu 19 Sep 1996 <bodg@tiuk.ti.com> Graham Barr - - o Modified IO.xs so that it will compile with pre perlio version - of perl (ie pre perl5.003_02) - o Modified IO::Socket::send so not to pass 4 arguments to send - if the socket is connected - -*** Release 1.10 - -Mon 11 Sep 1996 <bodg@tiuk.ti.com> Graham Barr - - o Fixed a bug in IO::Socket which caused DESTROY to be called - on a partly initialised connection - o Changed IO.xs to use Perlio - o Modified usage message to report correct package - o Added IO::File::new changes from Chip, to allow PERM to be passed - o Added sysread and syswrite methods to IO::Handle - o Updated documentation - o Fixed a bug in IO::Select that caused a hang if the last handle - was removed. - o Added count method to IO::Select - o Renamed and modified tests so that they can be copied into the - perl distribution - o Added fcntl and ioctl methods to IO::Handle - -Thu 25 Jul 1996 <bodg@tiuk.ti.com> Graham Barr - - o It is now not necessary to call the domain sub-classes of - IO::Socket. when connect is called it notes the domain. - Domain specific methods, which are normally non-critical, are - called via this note-ing. - o Added methods to IO::Socket to retrieve the domain, type and - protocol of a given socket - -Tue 23 Jul 1996 <bodg@tiuk.ti.com> Graham Barr - - o IO::Socket::connect changed how we do timeouts, as it did not work - - o IO::Handle::new_from_fd removed method call to _ref_fd, which was - a leftover from FileHandle - -Fri 28 Jun 1996 <bodg@tiuk.ti.com> Graham Barr - - o Modified IO::Socket::UNIX::configure to default to using a socket - type of SOCK_STREAM if no type is specified. diff --git a/contrib/perl5/ext/IO/IO.pm b/contrib/perl5/ext/IO/IO.pm deleted file mode 100644 index 0087530..0000000 --- a/contrib/perl5/ext/IO/IO.pm +++ /dev/null @@ -1,47 +0,0 @@ -# - -package IO; - -use XSLoader (); -use Carp; - -$VERSION = "1.20"; -XSLoader::load 'IO', $VERSION; - -sub import { - shift; - my @l = @_ ? @_ : qw(Handle Seekable File Pipe Socket Dir); - - eval join("", map { "require IO::" . (/(\w+)/)[0] . ";\n" } @l) - or croak $@; -} - -1; - -__END__ - -=head1 NAME - -IO - load various IO modules - -=head1 SYNOPSIS - - use IO; - -=head1 DESCRIPTION - -C<IO> provides a simple mechanism to load some of the IO modules at one go. -Currently this includes: - - IO::Handle - IO::Seekable - IO::File - IO::Pipe - IO::Socket - IO::Dir - -For more information on any of these modules, please see its respective -documentation. - -=cut - diff --git a/contrib/perl5/ext/IO/IO.xs b/contrib/perl5/ext/IO/IO.xs deleted file mode 100644 index 38acf41..0000000 --- a/contrib/perl5/ext/IO/IO.xs +++ /dev/null @@ -1,466 +0,0 @@ -/* - * Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. - * This program is free software; you can redistribute it and/or - * modify it under the same terms as Perl itself. - */ - -#define PERL_NO_GET_CONTEXT -#include "EXTERN.h" -#define PERLIO_NOT_STDIO 1 -#include "perl.h" -#include "XSUB.h" -#include "poll.h" -#ifdef I_UNISTD -# include <unistd.h> -#endif -#if defined(I_FCNTL) || defined(HAS_FCNTL) -# include <fcntl.h> -#endif - -#ifdef PerlIO -typedef int SysRet; -typedef PerlIO * InputStream; -typedef PerlIO * OutputStream; -#else -#define PERLIO_IS_STDIO 1 -typedef int SysRet; -typedef FILE * InputStream; -typedef FILE * OutputStream; -#endif - -#define MY_start_subparse(fmt,flags) start_subparse(fmt,flags) - -#ifndef gv_stashpvn -#define gv_stashpvn(str,len,flags) gv_stashpv(str,flags) -#endif - -static int -not_here(char *s) -{ - croak("%s not implemented on this architecture", s); - return -1; -} - - -#ifndef PerlIO -#define PerlIO_fileno(f) fileno(f) -#endif - -static int -io_blocking(InputStream f, int block) -{ - int RETVAL; - if(!f) { - errno = EBADF; - return -1; - } -#if defined(HAS_FCNTL) - RETVAL = fcntl(PerlIO_fileno(f), F_GETFL, 0); - if (RETVAL >= 0) { - int mode = RETVAL; -#ifdef O_NONBLOCK - /* POSIX style */ -#if defined(O_NDELAY) && O_NDELAY != O_NONBLOCK - /* Ooops has O_NDELAY too - make sure we don't - * get SysV behaviour by mistake. */ - - /* E.g. In UNICOS and UNICOS/mk a F_GETFL returns an O_NDELAY - * after a successful F_SETFL of an O_NONBLOCK. */ - RETVAL = RETVAL & (O_NONBLOCK | O_NDELAY) ? 0 : 1; - - if (block >= 0) { - if ((mode & O_NDELAY) || ((block == 0) && !(mode & O_NONBLOCK))) { - int ret; - mode = (mode & ~O_NDELAY) | O_NONBLOCK; - ret = fcntl(PerlIO_fileno(f),F_SETFL,mode); - if(ret < 0) - RETVAL = ret; - } - else - if ((mode & O_NDELAY) || ((block > 0) && (mode & O_NONBLOCK))) { - int ret; - mode &= ~(O_NONBLOCK | O_NDELAY); - ret = fcntl(PerlIO_fileno(f),F_SETFL,mode); - if(ret < 0) - RETVAL = ret; - } - } -#else - /* Standard POSIX */ - RETVAL = RETVAL & O_NONBLOCK ? 0 : 1; - - if ((block == 0) && !(mode & O_NONBLOCK)) { - int ret; - mode |= O_NONBLOCK; - ret = fcntl(PerlIO_fileno(f),F_SETFL,mode); - if(ret < 0) - RETVAL = ret; - } - else if ((block > 0) && (mode & O_NONBLOCK)) { - int ret; - mode &= ~O_NONBLOCK; - ret = fcntl(PerlIO_fileno(f),F_SETFL,mode); - if(ret < 0) - RETVAL = ret; - } -#endif -#else - /* Not POSIX - better have O_NDELAY or we can't cope. - * for BSD-ish machines this is an acceptable alternative - * for SysV we can't tell "would block" from EOF but that is - * the way SysV is... - */ - RETVAL = RETVAL & O_NDELAY ? 0 : 1; - - if ((block == 0) && !(mode & O_NDELAY)) { - int ret; - mode |= O_NDELAY; - ret = fcntl(PerlIO_fileno(f),F_SETFL,mode); - if(ret < 0) - RETVAL = ret; - } - else if ((block > 0) && (mode & O_NDELAY)) { - int ret; - mode &= ~O_NDELAY; - ret = fcntl(PerlIO_fileno(f),F_SETFL,mode); - if(ret < 0) - RETVAL = ret; - } -#endif - } - return RETVAL; -#else - return -1; -#endif -} - -MODULE = IO PACKAGE = IO::Seekable PREFIX = f - -void -fgetpos(handle) - InputStream handle - CODE: - if (handle) { - Fpos_t pos; - if ( -#ifdef PerlIO - PerlIO_getpos(handle, &pos) -#else - fgetpos(handle, &pos) -#endif - ) { - ST(0) = &PL_sv_undef; - } else { - ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t))); - } - } - else { - ST(0) = &PL_sv_undef; - errno = EINVAL; - } - -SysRet -fsetpos(handle, pos) - InputStream handle - SV * pos - CODE: - char *p; - STRLEN len; - if (handle && (p = SvPV(pos,len)) && len == sizeof(Fpos_t)) -#ifdef PerlIO - RETVAL = PerlIO_setpos(handle, (Fpos_t*)p); -#else - RETVAL = fsetpos(handle, (Fpos_t*)p); -#endif - else { - RETVAL = -1; - errno = EINVAL; - } - OUTPUT: - RETVAL - -MODULE = IO PACKAGE = IO::File PREFIX = f - -void -new_tmpfile(packname = "IO::File") - char * packname - PREINIT: - OutputStream fp; - GV *gv; - CODE: -#ifdef PerlIO - fp = PerlIO_tmpfile(); -#else - fp = tmpfile(); -#endif - gv = (GV*)SvREFCNT_inc(newGVgen(packname)); - hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD); - if (do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) { - ST(0) = sv_2mortal(newRV((SV*)gv)); - sv_bless(ST(0), gv_stashpv(packname, TRUE)); - SvREFCNT_dec(gv); /* undo increment in newRV() */ - } - else { - ST(0) = &PL_sv_undef; - SvREFCNT_dec(gv); - } - -MODULE = IO PACKAGE = IO::Poll - -void -_poll(timeout,...) - int timeout; -PPCODE: -{ -#ifdef HAS_POLL - int nfd = (items - 1) / 2; - SV *tmpsv = NEWSV(999,nfd * sizeof(struct pollfd)); - struct pollfd *fds = (struct pollfd *)SvPVX(tmpsv); - int i,j,ret; - for(i=1, j=0 ; j < nfd ; j++) { - fds[j].fd = SvIV(ST(i)); - i++; - fds[j].events = SvIV(ST(i)); - i++; - fds[j].revents = 0; - } - if((ret = poll(fds,nfd,timeout)) >= 0) { - for(i=1, j=0 ; j < nfd ; j++) { - sv_setiv(ST(i), fds[j].fd); i++; - sv_setiv(ST(i), fds[j].revents); i++; - } - } - SvREFCNT_dec(tmpsv); - XSRETURN_IV(ret); -#else - not_here("IO::Poll::poll"); -#endif -} - -MODULE = IO PACKAGE = IO::Handle PREFIX = io_ - -void -io_blocking(handle,blk=-1) - InputStream handle - int blk -PROTOTYPE: $;$ -CODE: -{ - int ret = io_blocking(handle, items == 1 ? -1 : blk ? 1 : 0); - if(ret >= 0) - XSRETURN_IV(ret); - else - XSRETURN_UNDEF; -} - -MODULE = IO PACKAGE = IO::Handle PREFIX = f - - -int -ungetc(handle, c) - InputStream handle - int c - CODE: - if (handle) -#ifdef PerlIO - RETVAL = PerlIO_ungetc(handle, c); -#else - RETVAL = ungetc(c, handle); -#endif - else { - RETVAL = -1; - errno = EINVAL; - } - OUTPUT: - RETVAL - -int -ferror(handle) - InputStream handle - CODE: - if (handle) -#ifdef PerlIO - RETVAL = PerlIO_error(handle); -#else - RETVAL = ferror(handle); -#endif - else { - RETVAL = -1; - errno = EINVAL; - } - OUTPUT: - RETVAL - -int -clearerr(handle) - InputStream handle - CODE: - if (handle) { -#ifdef PerlIO - PerlIO_clearerr(handle); -#else - clearerr(handle); -#endif - RETVAL = 0; - } - else { - RETVAL = -1; - errno = EINVAL; - } - OUTPUT: - RETVAL - -int -untaint(handle) - SV * handle - CODE: -#ifdef IOf_UNTAINT - IO * io; - io = sv_2io(handle); - if (io) { - IoFLAGS(io) |= IOf_UNTAINT; - RETVAL = 0; - } - else { -#endif - RETVAL = -1; - errno = EINVAL; -#ifdef IOf_UNTAINT - } -#endif - OUTPUT: - RETVAL - -SysRet -fflush(handle) - OutputStream handle - CODE: - if (handle) -#ifdef PerlIO - RETVAL = PerlIO_flush(handle); -#else - RETVAL = Fflush(handle); -#endif - else { - RETVAL = -1; - errno = EINVAL; - } - OUTPUT: - RETVAL - -void -setbuf(handle, buf) - OutputStream handle - char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0; - CODE: - if (handle) -#ifdef PERLIO_IS_STDIO - setbuf(handle, buf); -#else - not_here("IO::Handle::setbuf"); -#endif - -SysRet -setvbuf(handle, buf, type, size) - OutputStream handle - char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0; - int type - int size - CODE: -#if defined(PERLIO_IS_STDIO) && defined(_IOFBF) && defined(HAS_SETVBUF) - if (!handle) /* Try input stream. */ - handle = IoIFP(sv_2io(ST(0))); - if (handle) - RETVAL = setvbuf(handle, buf, type, size); - else { - RETVAL = -1; - errno = EINVAL; - } -#else - RETVAL = (SysRet) not_here("IO::Handle::setvbuf"); -#endif - OUTPUT: - RETVAL - - -SysRet -fsync(handle) - OutputStream handle - CODE: -#ifdef HAS_FSYNC - if(handle) - RETVAL = fsync(PerlIO_fileno(handle)); - else { - RETVAL = -1; - errno = EINVAL; - } -#else - RETVAL = (SysRet) not_here("IO::Handle::sync"); -#endif - OUTPUT: - RETVAL - - -BOOT: -{ - HV *stash; - /* - * constant subs for IO::Poll - */ - stash = gv_stashpvn("IO::Poll", 8, TRUE); -#ifdef POLLIN - newCONSTSUB(stash,"POLLIN",newSViv(POLLIN)); -#endif -#ifdef POLLPRI - newCONSTSUB(stash,"POLLPRI", newSViv(POLLPRI)); -#endif -#ifdef POLLOUT - newCONSTSUB(stash,"POLLOUT", newSViv(POLLOUT)); -#endif -#ifdef POLLRDNORM - newCONSTSUB(stash,"POLLRDNORM", newSViv(POLLRDNORM)); -#endif -#ifdef POLLWRNORM - newCONSTSUB(stash,"POLLWRNORM", newSViv(POLLWRNORM)); -#endif -#ifdef POLLRDBAND - newCONSTSUB(stash,"POLLRDBAND", newSViv(POLLRDBAND)); -#endif -#ifdef POLLWRBAND - newCONSTSUB(stash,"POLLWRBAND", newSViv(POLLWRBAND)); -#endif -#ifdef POLLNORM - newCONSTSUB(stash,"POLLNORM", newSViv(POLLNORM)); -#endif -#ifdef POLLERR - newCONSTSUB(stash,"POLLERR", newSViv(POLLERR)); -#endif -#ifdef POLLHUP - newCONSTSUB(stash,"POLLHUP", newSViv(POLLHUP)); -#endif -#ifdef POLLNVAL - newCONSTSUB(stash,"POLLNVAL", newSViv(POLLNVAL)); -#endif - /* - * constant subs for IO::Handle - */ - stash = gv_stashpvn("IO::Handle", 10, TRUE); -#ifdef _IOFBF - newCONSTSUB(stash,"_IOFBF", newSViv(_IOFBF)); -#endif -#ifdef _IOLBF - newCONSTSUB(stash,"_IOLBF", newSViv(_IOLBF)); -#endif -#ifdef _IONBF - newCONSTSUB(stash,"_IONBF", newSViv(_IONBF)); -#endif -#ifdef SEEK_SET - newCONSTSUB(stash,"SEEK_SET", newSViv(SEEK_SET)); -#endif -#ifdef SEEK_CUR - newCONSTSUB(stash,"SEEK_CUR", newSViv(SEEK_CUR)); -#endif -#ifdef SEEK_END - newCONSTSUB(stash,"SEEK_END", newSViv(SEEK_END)); -#endif -} diff --git a/contrib/perl5/ext/IO/Makefile.PL b/contrib/perl5/ext/IO/Makefile.PL deleted file mode 100644 index 095d7c2..0000000 --- a/contrib/perl5/ext/IO/Makefile.PL +++ /dev/null @@ -1,9 +0,0 @@ -use ExtUtils::MakeMaker; -use Config qw(%Config); - -WriteMakefile( - VERSION_FROM => "IO.pm", - NAME => "IO", - OBJECT => '$(O_FILES)', - MAN3PODS => {}, # Pods will be built by installman. -); diff --git a/contrib/perl5/ext/IO/README b/contrib/perl5/ext/IO/README deleted file mode 100644 index 191d550..0000000 --- a/contrib/perl5/ext/IO/README +++ /dev/null @@ -1,5 +0,0 @@ -This directory contains files from the IO distribution created by -Graham Barr. It is currently maintained by the Perl Porters as part -of the Perl source distribution. If you find that you have to modify -any files in this directory then please forward them a patch at -<perl5-porters@perl.org>. diff --git a/contrib/perl5/ext/IO/lib/IO/Dir.pm b/contrib/perl5/ext/IO/lib/IO/Dir.pm deleted file mode 100644 index 1fa07ed..0000000 --- a/contrib/perl5/ext/IO/lib/IO/Dir.pm +++ /dev/null @@ -1,239 +0,0 @@ -# IO::Dir.pm -# -# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package IO::Dir; - -use 5.003_26; - -use strict; -use Carp; -use Symbol; -use Exporter; -use IO::File; -our(@ISA, $VERSION, @EXPORT_OK); -use Tie::Hash; -use File::stat; - -@ISA = qw(Tie::Hash Exporter); -$VERSION = "1.03"; -@EXPORT_OK = qw(DIR_UNLINK); - -sub DIR_UNLINK () { 1 } - -sub new { - @_ >= 1 && @_ <= 2 or croak 'usage: new IO::Dir [DIRNAME]'; - my $class = shift; - my $dh = gensym; - if (@_) { - IO::Dir::open($dh, $_[0]) - or return undef; - } - bless $dh, $class; -} - -sub DESTROY { - my ($dh) = @_; - closedir($dh); -} - -sub open { - @_ == 2 or croak 'usage: $dh->open(DIRNAME)'; - my ($dh, $dirname) = @_; - return undef - unless opendir($dh, $dirname); - ${*$dh}{io_dir_path} = $dirname; - 1; -} - -sub close { - @_ == 1 or croak 'usage: $dh->close()'; - my ($dh) = @_; - closedir($dh); -} - -sub read { - @_ == 1 or croak 'usage: $dh->read()'; - my ($dh) = @_; - readdir($dh); -} - -sub seek { - @_ == 2 or croak 'usage: $dh->seek(POS)'; - my ($dh,$pos) = @_; - seekdir($dh,$pos); -} - -sub tell { - @_ == 1 or croak 'usage: $dh->tell()'; - my ($dh) = @_; - telldir($dh); -} - -sub rewind { - @_ == 1 or croak 'usage: $dh->rewind()'; - my ($dh) = @_; - rewinddir($dh); -} - -sub TIEHASH { - my($class,$dir,$options) = @_; - - my $dh = $class->new($dir) - or return undef; - - $options ||= 0; - - ${*$dh}{io_dir_unlink} = $options & DIR_UNLINK; - $dh; -} - -sub FIRSTKEY { - my($dh) = @_; - $dh->rewind; - scalar $dh->read; -} - -sub NEXTKEY { - my($dh) = @_; - scalar $dh->read; -} - -sub EXISTS { - my($dh,$key) = @_; - -e ${*$dh}{io_dir_path} . "/" . $key; -} - -sub FETCH { - my($dh,$key) = @_; - &lstat(${*$dh}{io_dir_path} . "/" . $key); -} - -sub STORE { - my($dh,$key,$data) = @_; - my($atime,$mtime) = ref($data) ? @$data : ($data,$data); - my $file = ${*$dh}{io_dir_path} . "/" . $key; - unless(-e $file) { - my $io = IO::File->new($file,O_CREAT | O_RDWR); - $io->close if $io; - } - utime($atime,$mtime, $file); -} - -sub DELETE { - my($dh,$key) = @_; - # Only unlink if unlink-ing is enabled - my $file = ${*$dh}{io_dir_path} . "/" . $key; - - return 0 - unless ${*$dh}{io_dir_unlink}; - - -d $file - ? rmdir($file) - : unlink($file); -} - -1; - -__END__ - -=head1 NAME - -IO::Dir - supply object methods for directory handles - -=head1 SYNOPSIS - - use IO::Dir; - $d = new IO::Dir "."; - if (defined $d) { - while (defined($_ = $d->read)) { something($_); } - $d->rewind; - while (defined($_ = $d->read)) { something_else($_); } - undef $d; - } - - tie %dir, IO::Dir, "."; - foreach (keys %dir) { - print $_, " " , $dir{$_}->size,"\n"; - } - -=head1 DESCRIPTION - -The C<IO::Dir> package provides two interfaces to perl's directory reading -routines. - -The first interface is an object approach. C<IO::Dir> provides an object -constructor and methods, which are just wrappers around perl's built in -directory reading routines. - -=over 4 - -=item new ( [ DIRNAME ] ) - -C<new> is the constuctor for C<IO::Dir> objects. It accepts one optional -argument which, if given, C<new> will pass to C<open> - -=back - -The following methods are wrappers for the directory related functions built -into perl (the trailing `dir' has been removed from the names). See L<perlfunc> -for details of these functions. - -=over 4 - -=item open ( DIRNAME ) - -=item read () - -=item seek ( POS ) - -=item tell () - -=item rewind () - -=item close () - -=back - -C<IO::Dir> also provides a interface to reading directories via a tied -HASH. The tied HASH extends the interface beyond just the directory -reading routines by the use of C<lstat>, from the C<File::stat> package, -C<unlink>, C<rmdir> and C<utime>. - -=over 4 - -=item tie %hash, IO::Dir, DIRNAME [, OPTIONS ] - -=back - -The keys of the HASH will be the names of the entries in the directory. -Reading a value from the hash will be the result of calling -C<File::stat::lstat>. Deleting an element from the hash will call C<unlink> -providing that C<DIR_UNLINK> is passed in the C<OPTIONS>. - -Assigning to an entry in the HASH will cause the time stamps of the file -to be modified. If the file does not exist then it will be created. Assigning -a single integer to a HASH element will cause both the access and -modification times to be changed to that value. Alternatively a reference to -an array of two values can be passed. The first array element will be used to -set the access time and the second element will be used to set the modification -time. - -=head1 SEE ALSO - -L<File::stat> - -=head1 AUTHOR - -Graham Barr. Currently maintained by the Perl Porters. Please report all -bugs to <perl5-porters@perl.org>. - -=head1 COPYRIGHT - -Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut diff --git a/contrib/perl5/ext/IO/lib/IO/File.pm b/contrib/perl5/ext/IO/lib/IO/File.pm deleted file mode 100644 index 569c280..0000000 --- a/contrib/perl5/ext/IO/lib/IO/File.pm +++ /dev/null @@ -1,169 +0,0 @@ -# - -package IO::File; - -=head1 NAME - -IO::File - supply object methods for filehandles - -=head1 SYNOPSIS - - use IO::File; - - $fh = new IO::File; - if ($fh->open("< file")) { - print <$fh>; - $fh->close; - } - - $fh = new IO::File "> file"; - if (defined $fh) { - print $fh "bar\n"; - $fh->close; - } - - $fh = new IO::File "file", "r"; - if (defined $fh) { - print <$fh>; - undef $fh; # automatically closes the file - } - - $fh = new IO::File "file", O_WRONLY|O_APPEND; - if (defined $fh) { - print $fh "corge\n"; - - $pos = $fh->getpos; - $fh->setpos($pos); - - undef $fh; # automatically closes the file - } - - autoflush STDOUT 1; - -=head1 DESCRIPTION - -C<IO::File> inherits from C<IO::Handle> and C<IO::Seekable>. It extends -these classes with methods that are specific to file handles. - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( FILENAME [,MODE [,PERMS]] ) - -Creates a C<IO::File>. If it receives any parameters, they are passed to -the method C<open>; if the open fails, the object is destroyed. Otherwise, -it is returned to the caller. - -=item new_tmpfile - -Creates an C<IO::File> opened for read/write on a newly created temporary -file. On systems where this is possible, the temporary file is anonymous -(i.e. it is unlinked after creation, but held open). If the temporary -file cannot be created or opened, the C<IO::File> object is destroyed. -Otherwise, it is returned to the caller. - -=back - -=head1 METHODS - -=over 4 - -=item open( FILENAME [,MODE [,PERMS]] ) - -C<open> accepts one, two or three parameters. With one parameter, -it is just a front end for the built-in C<open> function. With two or three -parameters, the first parameter is a filename that may include -whitespace or other special characters, and the second parameter is -the open mode, optionally followed by a file permission value. - -If C<IO::File::open> receives a Perl mode string ("E<gt>", "+E<lt>", etc.) -or a ANSI C fopen() mode string ("w", "r+", etc.), it uses the basic -Perl C<open> operator (but protects any special characters). - -If C<IO::File::open> is given a numeric mode, it passes that mode -and the optional permissions value to the Perl C<sysopen> operator. -The permissions default to 0666. - -For convenience, C<IO::File> exports the O_XXX constants from the -Fcntl module, if this module is available. - -=back - -=head1 SEE ALSO - -L<perlfunc>, -L<perlop/"I/O Operators">, -L<IO::Handle> -L<IO::Seekable> - -=head1 HISTORY - -Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>. - -=cut - -require 5.005_64; -use strict; -our($VERSION, @EXPORT, @EXPORT_OK, @ISA); -use Carp; -use Symbol; -use SelectSaver; -use IO::Seekable; -use File::Spec; - -require Exporter; - -@ISA = qw(IO::Handle IO::Seekable Exporter); - -$VERSION = "1.08"; - -@EXPORT = @IO::Seekable::EXPORT; - -eval { - # Make all Fcntl O_XXX constants available for importing - require Fcntl; - my @O = grep /^O_/, @Fcntl::EXPORT; - Fcntl->import(@O); # first we import what we want to export - push(@EXPORT, @O); -}; - -################################################ -## Constructor -## - -sub new { - my $type = shift; - my $class = ref($type) || $type || "IO::File"; - @_ >= 0 && @_ <= 3 - or croak "usage: new $class [FILENAME [,MODE [,PERMS]]]"; - my $fh = $class->SUPER::new(); - if (@_) { - $fh->open(@_) - or return undef; - } - $fh; -} - -################################################ -## Open -## - -sub open { - @_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])'; - my ($fh, $file) = @_; - if (@_ > 2) { - my ($mode, $perms) = @_[2, 3]; - if ($mode =~ /^\d+$/) { - defined $perms or $perms = 0666; - return sysopen($fh, $file, $mode, $perms); - } - if (! File::Spec->file_name_is_absolute($file)) { - $file = File::Spec->catfile(File::Spec->curdir(),$file); - } - $file = IO::Handle::_open_mode_string($mode) . " $file\0"; - } - open($fh, $file); -} - -1; diff --git a/contrib/perl5/ext/IO/lib/IO/Handle.pm b/contrib/perl5/ext/IO/lib/IO/Handle.pm deleted file mode 100644 index fb754a6..0000000 --- a/contrib/perl5/ext/IO/lib/IO/Handle.pm +++ /dev/null @@ -1,612 +0,0 @@ - -package IO::Handle; - -=head1 NAME - -IO::Handle - supply object methods for I/O handles - -=head1 SYNOPSIS - - use IO::Handle; - - $io = new IO::Handle; - if ($io->fdopen(fileno(STDIN),"r")) { - print $io->getline; - $io->close; - } - - $io = new IO::Handle; - if ($io->fdopen(fileno(STDOUT),"w")) { - $io->print("Some text\n"); - } - - use IO::Handle '_IOLBF'; - $io->setvbuf($buffer_var, _IOLBF, 1024); - - undef $io; # automatically closes the file if it's open - - autoflush STDOUT 1; - -=head1 DESCRIPTION - -C<IO::Handle> is the base class for all other IO handle classes. It is -not intended that objects of C<IO::Handle> would be created directly, -but instead C<IO::Handle> is inherited from by several other classes -in the IO hierarchy. - -If you are reading this documentation, looking for a replacement for -the C<FileHandle> package, then I suggest you read the documentation -for C<IO::File> too. - -=head1 CONSTRUCTOR - -=over 4 - -=item new () - -Creates a new C<IO::Handle> object. - -=item new_from_fd ( FD, MODE ) - -Creates a C<IO::Handle> like C<new> does. -It requires two parameters, which are passed to the method C<fdopen>; -if the fdopen fails, the object is destroyed. Otherwise, it is returned -to the caller. - -=back - -=head1 METHODS - -See L<perlfunc> for complete descriptions of each of the following -supported C<IO::Handle> methods, which are just front ends for the -corresponding built-in functions: - - $io->close - $io->eof - $io->fileno - $io->format_write( [FORMAT_NAME] ) - $io->getc - $io->read ( BUF, LEN, [OFFSET] ) - $io->print ( ARGS ) - $io->printf ( FMT, [ARGS] ) - $io->stat - $io->sysread ( BUF, LEN, [OFFSET] ) - $io->syswrite ( BUF, [LEN, [OFFSET]] ) - $io->truncate ( LEN ) - -See L<perlvar> for complete descriptions of each of the following -supported C<IO::Handle> methods. All of them return the previous -value of the attribute and takes an optional single argument that when -given will set the value. If no argument is given the previous value -is unchanged (except for $io->autoflush will actually turn ON -autoflush by default). - - $io->autoflush ( [BOOL] ) $| - $io->format_page_number( [NUM] ) $% - $io->format_lines_per_page( [NUM] ) $= - $io->format_lines_left( [NUM] ) $- - $io->format_name( [STR] ) $~ - $io->format_top_name( [STR] ) $^ - $io->input_line_number( [NUM]) $. - -The following methods are not supported on a per-filehandle basis. - - IO::Handle->format_line_break_characters( [STR] ) $: - IO::Handle->format_formfeed( [STR]) $^L - IO::Handle->output_field_separator( [STR] ) $, - IO::Handle->output_record_separator( [STR] ) $\ - - IO::Handle->input_record_separator( [STR] ) $/ - -Furthermore, for doing normal I/O you might need these: - -=over - -=item $io->fdopen ( FD, MODE ) - -C<fdopen> is like an ordinary C<open> except that its first parameter -is not a filename but rather a file handle name, a IO::Handle object, -or a file descriptor number. - -=item $io->opened - -Returns true if the object is currently a valid file descriptor, false -otherwise. - -=item $io->getline - -This works like <$io> described in L<perlop/"I/O Operators"> -except that it's more readable and can be safely called in a -list context but still returns just one line. - -=item $io->getlines - -This works like <$io> when called in a list context to read all -the remaining lines in a file, except that it's more readable. -It will also croak() if accidentally called in a scalar context. - -=item $io->ungetc ( ORD ) - -Pushes a character with the given ordinal value back onto the given -handle's input stream. Only one character of pushback per handle is -guaranteed. - -=item $io->write ( BUF, LEN [, OFFSET ] ) - -This C<write> is like C<write> found in C, that is it is the -opposite of read. The wrapper for the perl C<write> function is -called C<format_write>. - -=item $io->error - -Returns a true value if the given handle has experienced any errors -since it was opened or since the last call to C<clearerr>, or if the -handle is invalid. It only returns false for a valid handle with no -outstanding errors. - -=item $io->clearerr - -Clear the given handle's error indicator. Returns -1 if the handle is -invalid, 0 otherwise. - -=item $io->sync - -C<sync> synchronizes a file's in-memory state with that on the -physical medium. C<sync> does not operate at the perlio api level, but -operates on the file descriptor (similar to sysread, sysseek and -systell). This means that any data held at the perlio api level will not -be synchronized. To synchronize data that is buffered at the perlio api -level you must use the flush method. C<sync> is not implemented on all -platforms. Returns "0 but true" on success, C<undef> on error, C<undef> -for an invalid handle. See L<fsync(3c)>. - -=item $io->flush - -C<flush> causes perl to flush any buffered data at the perlio api level. -Any unread data in the buffer will be discarded, and any unwritten data -will be written to the underlying file descriptor. Returns "0 but true" -on success, C<undef> on error. - -=item $io->printflush ( ARGS ) - -Turns on autoflush, print ARGS and then restores the autoflush status of the -C<IO::Handle> object. Returns the return value from print. - -=item $io->blocking ( [ BOOL ] ) - -If called with an argument C<blocking> will turn on non-blocking IO if -C<BOOL> is false, and turn it off if C<BOOL> is true. - -C<blocking> will return the value of the previous setting, or the -current setting if C<BOOL> is not given. - -If an error occurs C<blocking> will return undef and C<$!> will be set. - -=back - - -If the C functions setbuf() and/or setvbuf() are available, then -C<IO::Handle::setbuf> and C<IO::Handle::setvbuf> set the buffering -policy for an IO::Handle. The calling sequences for the Perl functions -are the same as their C counterparts--including the constants C<_IOFBF>, -C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter -specifies a scalar variable to use as a buffer. You should only -change the buffer before any I/O, or immediately after calling flush. - -WARNING: A variable used as a buffer by C<setbuf> or C<setvbuf> B<must not -be modified> in any way until the IO::Handle is closed or C<setbuf> or -C<setvbuf> is called again, or memory corruption may result! Remember that -the order of global destruction is undefined, so even if your buffer -variable remains in scope until program termination, it may be undefined -before the file IO::Handle is closed. Note that you need to import the -constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. Like C, setbuf -returns nothing. setvbuf returns "0 but true", on success, C<undef> on -failure. - -Lastly, there is a special method for working under B<-T> and setuid/gid -scripts: - -=over - -=item $io->untaint - -Marks the object as taint-clean, and as such data read from it will also -be considered taint-clean. Note that this is a very trusting action to -take, and appropriate consideration for the data source and potential -vulnerability should be kept in mind. Returns 0 on success, -1 if setting -the taint-clean flag failed. (eg invalid handle) - -=back - -=head1 NOTE - -A C<IO::Handle> object is a reference to a symbol/GLOB reference (see -the C<Symbol> package). Some modules that -inherit from C<IO::Handle> may want to keep object related variables -in the hash table part of the GLOB. In an attempt to prevent modules -trampling on each other I propose the that any such module should prefix -its variables with its own name separated by _'s. For example the IO::Socket -module keeps a C<timeout> variable in 'io_socket_timeout'. - -=head1 SEE ALSO - -L<perlfunc>, -L<perlop/"I/O Operators">, -L<IO::File> - -=head1 BUGS - -Due to backwards compatibility, all filehandles resemble objects -of class C<IO::Handle>, or actually classes derived from that class. -They actually aren't. Which means you can't derive your own -class from C<IO::Handle> and inherit those methods. - -=head1 HISTORY - -Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt> - -=cut - -require 5.005_64; -use strict; -our($VERSION, @EXPORT_OK, @ISA); -use Carp; -use Symbol; -use SelectSaver; -use IO (); # Load the XS module - -require Exporter; -@ISA = qw(Exporter); - -$VERSION = "1.21"; - -@EXPORT_OK = qw( - autoflush - output_field_separator - output_record_separator - input_record_separator - input_line_number - format_page_number - format_lines_per_page - format_lines_left - format_name - format_top_name - format_line_break_characters - format_formfeed - format_write - - print - printf - getline - getlines - - printflush - flush - - SEEK_SET - SEEK_CUR - SEEK_END - _IOFBF - _IOLBF - _IONBF -); - -################################################ -## Constructors, destructors. -## - -sub new { - my $class = ref($_[0]) || $_[0] || "IO::Handle"; - @_ == 1 or croak "usage: new $class"; - my $io = gensym; - bless $io, $class; -} - -sub new_from_fd { - my $class = ref($_[0]) || $_[0] || "IO::Handle"; - @_ == 3 or croak "usage: new_from_fd $class FD, MODE"; - my $io = gensym; - shift; - IO::Handle::fdopen($io, @_) - or return undef; - bless $io, $class; -} - -# -# There is no need for DESTROY to do anything, because when the -# last reference to an IO object is gone, Perl automatically -# closes its associated files (if any). However, to avoid any -# attempts to autoload DESTROY, we here define it to do nothing. -# -sub DESTROY {} - - -################################################ -## Open and close. -## - -sub _open_mode_string { - my ($mode) = @_; - $mode =~ /^\+?(<|>>?)$/ - or $mode =~ s/^r(\+?)$/$1</ - or $mode =~ s/^w(\+?)$/$1>/ - or $mode =~ s/^a(\+?)$/$1>>/ - or croak "IO::Handle: bad open mode: $mode"; - $mode; -} - -sub fdopen { - @_ == 3 or croak 'usage: $io->fdopen(FD, MODE)'; - my ($io, $fd, $mode) = @_; - local(*GLOB); - - if (ref($fd) && "".$fd =~ /GLOB\(/o) { - # It's a glob reference; Alias it as we cannot get name of anon GLOBs - my $n = qualify(*GLOB); - *GLOB = *{*$fd}; - $fd = $n; - } elsif ($fd =~ m#^\d+$#) { - # It's an FD number; prefix with "=". - $fd = "=$fd"; - } - - open($io, _open_mode_string($mode) . '&' . $fd) - ? $io : undef; -} - -sub close { - @_ == 1 or croak 'usage: $io->close()'; - my($io) = @_; - - close($io); -} - -################################################ -## Normal I/O functions. -## - -# flock -# select - -sub opened { - @_ == 1 or croak 'usage: $io->opened()'; - defined fileno($_[0]); -} - -sub fileno { - @_ == 1 or croak 'usage: $io->fileno()'; - fileno($_[0]); -} - -sub getc { - @_ == 1 or croak 'usage: $io->getc()'; - getc($_[0]); -} - -sub eof { - @_ == 1 or croak 'usage: $io->eof()'; - eof($_[0]); -} - -sub print { - @_ or croak 'usage: $io->print(ARGS)'; - my $this = shift; - print $this @_; -} - -sub printf { - @_ >= 2 or croak 'usage: $io->printf(FMT,[ARGS])'; - my $this = shift; - printf $this @_; -} - -sub getline { - @_ == 1 or croak 'usage: $io->getline()'; - my $this = shift; - return scalar <$this>; -} - -*gets = \&getline; # deprecated - -sub getlines { - @_ == 1 or croak 'usage: $io->getlines()'; - wantarray or - croak 'Can\'t call $io->getlines in a scalar context, use $io->getline'; - my $this = shift; - return <$this>; -} - -sub truncate { - @_ == 2 or croak 'usage: $io->truncate(LEN)'; - truncate($_[0], $_[1]); -} - -sub read { - @_ == 3 || @_ == 4 or croak 'usage: $io->read(BUF, LEN [, OFFSET])'; - read($_[0], $_[1], $_[2], $_[3] || 0); -} - -sub sysread { - @_ == 3 || @_ == 4 or croak 'usage: $io->sysread(BUF, LEN [, OFFSET])'; - sysread($_[0], $_[1], $_[2], $_[3] || 0); -} - -sub write { - @_ >= 2 && @_ <= 4 or croak 'usage: $io->write(BUF [, LEN [, OFFSET]])'; - local($\) = ""; - $_[2] = length($_[1]) unless defined $_[2]; - print { $_[0] } substr($_[1], $_[3] || 0, $_[2]); -} - -sub syswrite { - @_ >= 2 && @_ <= 4 or croak 'usage: $io->syswrite(BUF [, LEN [, OFFSET]])'; - if (defined($_[2])) { - syswrite($_[0], $_[1], $_[2], $_[3] || 0); - } else { - syswrite($_[0], $_[1]); - } -} - -sub stat { - @_ == 1 or croak 'usage: $io->stat()'; - stat($_[0]); -} - -################################################ -## State modification functions. -## - -sub autoflush { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $|; - $| = @_ > 1 ? $_[1] : 1; - $prev; -} - -sub output_field_separator { - carp "output_field_separator is not supported on a per-handle basis" - if ref($_[0]); - my $prev = $,; - $, = $_[1] if @_ > 1; - $prev; -} - -sub output_record_separator { - carp "output_record_separator is not supported on a per-handle basis" - if ref($_[0]); - my $prev = $\; - $\ = $_[1] if @_ > 1; - $prev; -} - -sub input_record_separator { - carp "input_record_separator is not supported on a per-handle basis" - if ref($_[0]); - my $prev = $/; - $/ = $_[1] if @_ > 1; - $prev; -} - -sub input_line_number { - local $.; - my $tell = tell qualify($_[0], caller) if ref($_[0]); - my $prev = $.; - $. = $_[1] if @_ > 1; - $prev; -} - -sub format_page_number { - my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); - my $prev = $%; - $% = $_[1] if @_ > 1; - $prev; -} - -sub format_lines_per_page { - my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); - my $prev = $=; - $= = $_[1] if @_ > 1; - $prev; -} - -sub format_lines_left { - my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); - my $prev = $-; - $- = $_[1] if @_ > 1; - $prev; -} - -sub format_name { - my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); - my $prev = $~; - $~ = qualify($_[1], caller) if @_ > 1; - $prev; -} - -sub format_top_name { - my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); - my $prev = $^; - $^ = qualify($_[1], caller) if @_ > 1; - $prev; -} - -sub format_line_break_characters { - carp "format_line_break_characters is not supported on a per-handle basis" - if ref($_[0]); - my $prev = $:; - $: = $_[1] if @_ > 1; - $prev; -} - -sub format_formfeed { - carp "format_formfeed is not supported on a per-handle basis" - if ref($_[0]); - my $prev = $^L; - $^L = $_[1] if @_ > 1; - $prev; -} - -sub formline { - my $io = shift; - my $picture = shift; - local($^A) = $^A; - local($\) = ""; - formline($picture, @_); - print $io $^A; -} - -sub format_write { - @_ < 3 || croak 'usage: $io->write( [FORMAT_NAME] )'; - if (@_ == 2) { - my ($io, $fmt) = @_; - my $oldfmt = $io->format_name($fmt); - CORE::write($io); - $io->format_name($oldfmt); - } else { - CORE::write($_[0]); - } -} - -# XXX undocumented -sub fcntl { - @_ == 3 || croak 'usage: $io->fcntl( OP, VALUE );'; - my ($io, $op) = @_; - return fcntl($io, $op, $_[2]); -} - -# XXX undocumented -sub ioctl { - @_ == 3 || croak 'usage: $io->ioctl( OP, VALUE );'; - my ($io, $op) = @_; - return ioctl($io, $op, $_[2]); -} - -# this sub is for compatability with older releases of IO that used -# a sub called constant to detemine if a constant existed -- GMB -# -# The SEEK_* and _IO?BF constants were the only constants at that time -# any new code should just chech defined(&CONSTANT_NAME) - -sub constant { - no strict 'refs'; - my $name = shift; - (($name =~ /^(SEEK_(SET|CUR|END)|_IO[FLN]BF)$/) && defined &{$name}) - ? &{$name}() : undef; -} - - -# so that flush.pl can be depriciated - -sub printflush { - my $io = shift; - my $old = new SelectSaver qualify($io, caller) if ref($io); - local $| = 1; - if(ref($io)) { - print $io @_; - } - else { - print @_; - } -} - -1; diff --git a/contrib/perl5/ext/IO/lib/IO/Pipe.pm b/contrib/perl5/ext/IO/lib/IO/Pipe.pm deleted file mode 100644 index 27b5ad0..0000000 --- a/contrib/perl5/ext/IO/lib/IO/Pipe.pm +++ /dev/null @@ -1,252 +0,0 @@ -# IO::Pipe.pm -# -# Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package IO::Pipe; - -require 5.005_64; - -use IO::Handle; -use strict; -our($VERSION); -use Carp; -use Symbol; - -$VERSION = "1.121"; - -sub new { - my $type = shift; - my $class = ref($type) || $type || "IO::Pipe"; - @_ == 0 || @_ == 2 or croak "usage: new $class [READFH, WRITEFH]"; - - my $me = bless gensym(), $class; - - my($readfh,$writefh) = @_ ? @_ : $me->handles; - - pipe($readfh, $writefh) - or return undef; - - @{*$me} = ($readfh, $writefh); - - $me; -} - -sub handles { - @_ == 1 or croak 'usage: $pipe->handles()'; - (IO::Pipe::End->new(), IO::Pipe::End->new()); -} - -my $do_spawn = $^O eq 'os2'; - -sub _doit { - my $me = shift; - my $rw = shift; - - my $pid = $do_spawn ? 0 : fork(); - - if($pid) { # Parent - return $pid; - } - elsif(defined $pid) { # Child or spawn - my $fh; - my $io = $rw ? \*STDIN : \*STDOUT; - my ($mode, $save) = $rw ? "r" : "w"; - if ($do_spawn) { - require Fcntl; - $save = IO::Handle->new_from_fd($io, $mode); - # Close in child: - fcntl(shift, Fcntl::F_SETFD(), 1) or croak "fcntl: $!"; - $fh = $rw ? ${*$me}[0] : ${*$me}[1]; - } else { - shift; - $fh = $rw ? $me->reader() : $me->writer(); # close the other end - } - bless $io, "IO::Handle"; - $io->fdopen($fh, $mode); - $fh->close; - - if ($do_spawn) { - $pid = eval { system 1, @_ }; # 1 == P_NOWAIT - my $err = $!; - - $io->fdopen($save, $mode); - $save->close or croak "Cannot close $!"; - croak "IO::Pipe: Cannot spawn-NOWAIT: $err" if not $pid or $pid < 0; - return $pid; - } else { - exec @_ or - croak "IO::Pipe: Cannot exec: $!"; - } - } - else { - croak "IO::Pipe: Cannot fork: $!"; - } - - # NOT Reached -} - -sub reader { - @_ >= 1 or croak 'usage: $pipe->reader( [SUB_COMMAND_ARGS] )'; - my $me = shift; - - return undef - unless(ref($me) || ref($me = $me->new)); - - my $fh = ${*$me}[0]; - my $pid = $me->_doit(0, $fh, @_) - if(@_); - - close ${*$me}[1]; - bless $me, ref($fh); - *$me = *$fh; # Alias self to handle - $me->fdopen($fh->fileno,"r") - unless defined($me->fileno); - bless $fh; # Really wan't un-bless here - ${*$me}{'io_pipe_pid'} = $pid - if defined $pid; - - $me; -} - -sub writer { - @_ >= 1 or croak 'usage: $pipe->writer( [SUB_COMMAND_ARGS] )'; - my $me = shift; - - return undef - unless(ref($me) || ref($me = $me->new)); - - my $fh = ${*$me}[1]; - my $pid = $me->_doit(1, $fh, @_) - if(@_); - - close ${*$me}[0]; - bless $me, ref($fh); - *$me = *$fh; # Alias self to handle - $me->fdopen($fh->fileno,"w") - unless defined($me->fileno); - bless $fh; # Really wan't un-bless here - ${*$me}{'io_pipe_pid'} = $pid - if defined $pid; - - $me; -} - -package IO::Pipe::End; - -our(@ISA); - -@ISA = qw(IO::Handle); - -sub close { - my $fh = shift; - my $r = $fh->SUPER::close(@_); - - waitpid(${*$fh}{'io_pipe_pid'},0) - if(defined ${*$fh}{'io_pipe_pid'}); - - $r; -} - -1; - -__END__ - -=head1 NAME - -IO::Pipe - supply object methods for pipes - -=head1 SYNOPSIS - - use IO::Pipe; - - $pipe = new IO::Pipe; - - if($pid = fork()) { # Parent - $pipe->reader(); - - while(<$pipe> { - .... - } - - } - elsif(defined $pid) { # Child - $pipe->writer(); - - print $pipe .... - } - - or - - $pipe = new IO::Pipe; - - $pipe->reader(qw(ls -l)); - - while(<$pipe>) { - .... - } - -=head1 DESCRIPTION - -C<IO::Pipe> provides an interface to creating pipes between -processes. - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( [READER, WRITER] ) - -Creates a C<IO::Pipe>, which is a reference to a newly created symbol -(see the C<Symbol> package). C<IO::Pipe::new> optionally takes two -arguments, which should be objects blessed into C<IO::Handle>, or a -subclass thereof. These two objects will be used for the system call -to C<pipe>. If no arguments are given then method C<handles> is called -on the new C<IO::Pipe> object. - -These two handles are held in the array part of the GLOB until either -C<reader> or C<writer> is called. - -=back - -=head1 METHODS - -=over 4 - -=item reader ([ARGS]) - -The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a -handle at the reading end of the pipe. If C<ARGS> are given then C<fork> -is called and C<ARGS> are passed to exec. - -=item writer ([ARGS]) - -The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a -handle at the writing end of the pipe. If C<ARGS> are given then C<fork> -is called and C<ARGS> are passed to exec. - -=item handles () - -This method is called during construction by C<IO::Pipe::new> -on the newly created C<IO::Pipe> object. It returns an array of two objects -blessed into C<IO::Pipe::End>, or a subclass thereof. - -=back - -=head1 SEE ALSO - -L<IO::Handle> - -=head1 AUTHOR - -Graham Barr. Currently maintained by the Perl Porters. Please report all -bugs to <perl5-porters@perl.org>. - -=head1 COPYRIGHT - -Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut diff --git a/contrib/perl5/ext/IO/lib/IO/Poll.pm b/contrib/perl5/ext/IO/lib/IO/Poll.pm deleted file mode 100644 index 70a3469..0000000 --- a/contrib/perl5/ext/IO/lib/IO/Poll.pm +++ /dev/null @@ -1,204 +0,0 @@ - -# IO::Poll.pm -# -# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package IO::Poll; - -use strict; -use IO::Handle; -use Exporter (); -our(@ISA, @EXPORT_OK, @EXPORT, $VERSION); - -@ISA = qw(Exporter); -$VERSION = "0.05"; - -@EXPORT = qw( POLLIN - POLLOUT - POLLERR - POLLHUP - POLLNVAL - ); - -@EXPORT_OK = qw( - POLLPRI - POLLRDNORM - POLLWRNORM - POLLRDBAND - POLLWRBAND - POLLNORM - ); - -# [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; - - $self; -} - -sub mask { - my $self = shift; - my $io = shift; - my $fd = fileno($io); - if (@_) { - my $mask = shift; - if($mask) { - $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}; - } - } - - return unless exists $self->[0]{$fd} and exists $self->[0]{$fd}{$io}; - return $self->[0]{$fd}{$io}; -} - - -sub poll { - my($self,$timeout) = @_; - - $self->[1] = {}; - - my($fd,$mask,$iom); - my @poll = (); - - 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; - - return $ret - unless $ret > 0; - - while(@poll) { - my($fd,$got) = splice(@poll,0,2); - $self->[1]{$fd} = $got if $got; - } - - return $ret; -} - -sub events { - my $self = shift; - my $io = shift; - my $fd = fileno($io); - exists $self->[1]{$fd} and exists $self->[0]{$fd}{$io} - ? $self->[1]{$fd} & ($self->[0]{$fd}{$io}|POLLHUP|POLLERR|POLLNVAL) - : 0; -} - -sub remove { - my $self = shift; - my $io = shift; - $self->mask($io,0); -} - -sub handles { - my $self = shift; - return values %{$self->[2]} unless @_; - - my $events = shift || 0; - my($fd,$ev,$io,$mask); - my @handles = (); - - while(($fd,$ev) = each %{$self->[1]}) { - 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; -} - -1; - -__END__ - -=head1 NAME - -IO::Poll - Object interface to system poll call - -=head1 SYNOPSIS - - use IO::Poll qw(POLLRDNORM POLLWRNORM POLLIN POLLHUP); - - $poll = new IO::Poll; - - $poll->mask($input_handle => POLLIN); - $poll->mask($output_handle => POLLOUT); - - $poll->poll($timeout); - - $ev = $poll->events($input); - -=head1 DESCRIPTION - -C<IO::Poll> is a simple interface to the system level poll routine. - -=head1 METHODS - -=over 4 - -=item mask ( IO [, EVENT_MASK ] ) - -If EVENT_MASK is given, then, if EVENT_MASK is non-zero, IO is added to the -list of file descriptors and the next call to poll will check for -any event specified in EVENT_MASK. If EVENT_MASK is zero then IO will be -removed from the list of file descriptors. - -If EVENT_MASK is not given then the return value will be the current -event mask value for IO. - -=item poll ( [ TIMEOUT ] ) - -Call the system level poll routine. If TIMEOUT is not specified then the -call will block. Returns the number of handles which had events -happen, or -1 on error. - -=item events ( IO ) - -Returns the event mask which represents the events that happend on IO -during the last call to C<poll>. - -=item remove ( IO ) - -Remove IO from the list of file descriptors for the next poll. - -=item handles( [ EVENT_MASK ] ) - -Returns a list of handles. If EVENT_MASK is not given then a list of all -handles known will be returned. If EVENT_MASK is given then a list -of handles will be returned which had one of the events specified by -EVENT_MASK happen during the last call ti C<poll> - -=back - -=head1 SEE ALSO - -L<poll(2)>, L<IO::Handle>, L<IO::Select> - -=head1 AUTHOR - -Graham Barr. Currently maintained by the Perl Porters. Please report all -bugs to <perl5-porters@perl.org>. - -=head1 COPYRIGHT - -Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut diff --git a/contrib/perl5/ext/IO/lib/IO/Seekable.pm b/contrib/perl5/ext/IO/lib/IO/Seekable.pm deleted file mode 100644 index 243a971..0000000 --- a/contrib/perl5/ext/IO/lib/IO/Seekable.pm +++ /dev/null @@ -1,127 +0,0 @@ -# - -package IO::Seekable; - -=head1 NAME - -IO::Seekable - supply seek based methods for I/O objects - -=head1 SYNOPSIS - - use IO::Seekable; - package IO::Something; - @ISA = qw(IO::Seekable); - -=head1 DESCRIPTION - -C<IO::Seekable> does not have a constructor of its own as it is intended to -be inherited by other C<IO::Handle> based objects. It provides methods -which allow seeking of the file descriptors. - -=over 4 - -=item $io->getpos - -Returns an opaque value that represents the current position of the -IO::File, or C<undef> if this is not possible (eg an unseekable stream such -as a terminal, pipe or socket). If the fgetpos() function is available in -your C library it is used to implements getpos, else perl emulates getpos -using C's ftell() function. - -=item $io->setpos - -Uses the value of a previous getpos call to return to a previously visited -position. Returns "0 but true" on success, C<undef> on failure. - -=back - -See L<perlfunc> for complete descriptions of each of the following -supported C<IO::Seekable> methods, which are just front ends for the -corresponding built-in functions: - -=over 4 - -=item $io->setpos ( POS, WHENCE ) - -Seek the IO::File to position POS, relative to WHENCE: - -=over 8 - -=item WHENCE=0 (SEEK_SET) - -POS is absolute position. (Seek relative to the start of the file) - -=item WHENCE=1 (SEEK_CUR) - -POS is an offset from the current position. (Seek relative to current) - -=item WHENCE=1 (SEEK_END) - -POS is an offset from the end of the file. (Seek relative to end) - -=back - -The SEEK_* constants can be imported from the C<Fcntl> module if you -don't wish to use the numbers C<0> C<1> or C<2> in your code. - -Returns C<1> upon success, C<0> otherwise. - -=item $io->sysseek( POS, WHENCE ) - -Similar to $io->seek, but sets the IO::File's position using the system -call lseek(2) directly, so will confuse most perl IO operators except -sysread and syswrite (see L<perlfunc> for full details) - -Returns the new position, or C<undef> on failure. A position -of zero is returned as the string C<"0 but true"> - -=item $io->tell - -Returns the IO::File's current position, or -1 on error. - -=back - -=head1 SEE ALSO - -L<perlfunc>, -L<perlop/"I/O Operators">, -L<IO::Handle> -L<IO::File> - -=head1 HISTORY - -Derived from FileHandle.pm by Graham Barr E<lt>gbarr@pobox.comE<gt> - -=cut - -require 5.005_64; -use Carp; -use strict; -our($VERSION, @EXPORT, @ISA); -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); -@ISA = qw(Exporter); - -$VERSION = "1.08"; - -sub seek { - @_ == 3 or croak 'usage: $io->seek(POS, WHENCE)'; - seek($_[0], $_[1], $_[2]); -} - -sub sysseek { - @_ == 3 or croak 'usage: $io->sysseek(POS, WHENCE)'; - sysseek($_[0], $_[1], $_[2]); -} - -sub tell { - @_ == 1 or croak 'usage: $io->tell()'; - tell($_[0]); -} - -1; diff --git a/contrib/perl5/ext/IO/lib/IO/Select.pm b/contrib/perl5/ext/IO/lib/IO/Select.pm deleted file mode 100644 index 1a3a26f..0000000 --- a/contrib/perl5/ext/IO/lib/IO/Select.pm +++ /dev/null @@ -1,381 +0,0 @@ -# IO::Select.pm -# -# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package IO::Select; - -use strict; -use warnings::register; -use vars qw($VERSION @ISA); -require Exporter; - -$VERSION = "1.14"; - -@ISA = qw(Exporter); # This is only so we can do version checking - -sub VEC_BITS () {0} -sub FD_COUNT () {1} -sub FIRST_FD () {2} - -sub new -{ - my $self = shift; - my $type = ref($self) || $self; - - my $vec = bless [undef,0], $type; - - $vec->add(@_) - if @_; - - $vec; -} - -sub add -{ - shift->_update('add', @_); -} - - -sub remove -{ - shift->_update('remove', @_); -} - - -sub exists -{ - my $vec = shift; - my $fno = $vec->_fileno(shift); - return undef unless defined $fno; - $vec->[$fno + FIRST_FD]; -} - - -sub _fileno -{ - my($self, $f) = @_; - return unless defined $f; - $f = $f->[0] if ref($f) eq 'ARRAY'; - ($f =~ /^\d+$/) ? $f : fileno($f); -} - -sub _update -{ - my $vec = shift; - my $add = shift eq 'add'; - - my $bits = $vec->[VEC_BITS]; - $bits = '' unless defined $bits; - - my $count = 0; - my $f; - foreach $f (@_) - { - my $fn = $vec->_fileno($f); - next unless defined $fn; - my $i = $fn + FIRST_FD; - if ($add) { - if (defined $vec->[$i]) { - $vec->[$i] = $f; # if array rest might be different, so we update - next; - } - $vec->[FD_COUNT]++; - vec($bits, $fn, 1) = 1; - $vec->[$i] = $f; - } else { # remove - next unless defined $vec->[$i]; - $vec->[FD_COUNT]--; - vec($bits, $fn, 1) = 0; - $vec->[$i] = undef; - } - $count++; - } - $vec->[VEC_BITS] = $vec->[FD_COUNT] ? $bits : undef; - $count; -} - -sub can_read -{ - my $vec = shift; - my $timeout = shift; - my $r = $vec->[VEC_BITS]; - - defined($r) && (select($r,undef,undef,$timeout) > 0) - ? handles($vec, $r) - : (); -} - -sub can_write -{ - my $vec = shift; - my $timeout = shift; - my $w = $vec->[VEC_BITS]; - - defined($w) && (select(undef,$w,undef,$timeout) > 0) - ? handles($vec, $w) - : (); -} - -sub has_exception -{ - my $vec = shift; - my $timeout = shift; - my $e = $vec->[VEC_BITS]; - - defined($e) && (select(undef,undef,$e,$timeout) > 0) - ? handles($vec, $e) - : (); -} - -sub has_error -{ - warnings::warn("Call to depreciated method 'has_error', use 'has_exception'") - if warnings::enabled(); - goto &has_exception; -} - -sub count -{ - my $vec = shift; - $vec->[FD_COUNT]; -} - -sub bits -{ - my $vec = shift; - $vec->[VEC_BITS]; -} - -sub as_string # for debugging -{ - my $vec = shift; - my $str = ref($vec) . ": "; - my $bits = $vec->bits; - my $count = $vec->count; - $str .= defined($bits) ? unpack("b*", $bits) : "undef"; - $str .= " $count"; - my @handles = @$vec; - splice(@handles, 0, FIRST_FD); - for (@handles) { - $str .= " " . (defined($_) ? "$_" : "-"); - } - $str; -} - -sub _max -{ - my($a,$b,$c) = @_; - $a > $b - ? $a > $c - ? $a - : $c - : $b > $c - ? $b - : $c; -} - -sub select -{ - shift - if defined $_[0] && !ref($_[0]); - - my($r,$w,$e,$t) = @_; - my @result = (); - - my $rb = defined $r ? $r->[VEC_BITS] : undef; - my $wb = defined $w ? $w->[VEC_BITS] : undef; - my $eb = defined $e ? $e->[VEC_BITS] : undef; - - if(select($rb,$wb,$eb,$t) > 0) - { - my @r = (); - my @w = (); - my @e = (); - my $i = _max(defined $r ? scalar(@$r)-1 : 0, - defined $w ? scalar(@$w)-1 : 0, - defined $e ? scalar(@$e)-1 : 0); - - for( ; $i >= FIRST_FD ; $i--) - { - my $j = $i - FIRST_FD; - push(@r, $r->[$i]) - if defined $rb && defined $r->[$i] && vec($rb, $j, 1); - push(@w, $w->[$i]) - if defined $wb && defined $w->[$i] && vec($wb, $j, 1); - push(@e, $e->[$i]) - if defined $eb && defined $e->[$i] && vec($eb, $j, 1); - } - - @result = (\@r, \@w, \@e); - } - @result; -} - - -sub handles -{ - my $vec = shift; - my $bits = shift; - my @h = (); - my $i; - my $max = scalar(@$vec) - 1; - - for ($i = FIRST_FD; $i <= $max; $i++) - { - next unless defined $vec->[$i]; - push(@h, $vec->[$i]) - if !defined($bits) || vec($bits, $i - FIRST_FD, 1); - } - - @h; -} - -1; -__END__ - -=head1 NAME - -IO::Select - OO interface to the select system call - -=head1 SYNOPSIS - - use IO::Select; - - $s = IO::Select->new(); - - $s->add(\*STDIN); - $s->add($some_handle); - - @ready = $s->can_read($timeout); - - @ready = IO::Select->new(@handles)->read(0); - -=head1 DESCRIPTION - -The C<IO::Select> package implements an object approach to the system C<select> -function call. It allows the user to see what IO handles, see L<IO::Handle>, -are ready for reading, writing or have an error condition pending. - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( [ HANDLES ] ) - -The constructor creates a new object and optionally initialises it with a set -of handles. - -=back - -=head1 METHODS - -=over 4 - -=item add ( HANDLES ) - -Add the list of handles to the C<IO::Select> object. It is these values that -will be returned when an event occurs. C<IO::Select> keeps these values in a -cache which is indexed by the C<fileno> of the handle, so if more than one -handle with the same C<fileno> is specified then only the last one is cached. - -Each handle can be an C<IO::Handle> object, an integer or an array -reference where the first element is a C<IO::Handle> or an integer. - -=item remove ( HANDLES ) - -Remove all the given handles from the object. This method also works -by the C<fileno> of the handles. So the exact handles that were added -need not be passed, just handles that have an equivalent C<fileno> - -=item exists ( HANDLE ) - -Returns a true value (actually the handle itself) if it is present. -Returns undef otherwise. - -=item handles - -Return an array of all registered handles. - -=item can_read ( [ TIMEOUT ] ) - -Return an array of handles that are ready for reading. C<TIMEOUT> is -the maximum amount of time to wait before returning an empty list, in -seconds, possibly fractional. If C<TIMEOUT> is not given and any -handles are registered then the call will block. - -=item can_write ( [ TIMEOUT ] ) - -Same as C<can_read> except check for handles that can be written to. - -=item has_exception ( [ TIMEOUT ] ) - -Same as C<can_read> except check for handles that have an exception -condition, for example pending out-of-band data. - -=item count () - -Returns the number of handles that the object will check for when -one of the C<can_> methods is called or the object is passed to -the C<select> static method. - -=item bits() - -Return the bit string suitable as argument to the core select() call. - -=item select ( READ, WRITE, ERROR [, TIMEOUT ] ) - -C<select> is a static method, that is you call it with the package -name like C<new>. C<READ>, C<WRITE> and C<ERROR> are either C<undef> -or C<IO::Select> objects. C<TIMEOUT> is optional and has the same -effect as for the core select call. - -The result will be an array of 3 elements, each a reference to an array -which will hold the handles that are ready for reading, writing and have -error conditions respectively. Upon error an empty array is returned. - -=back - -=head1 EXAMPLE - -Here is a short example which shows how C<IO::Select> could be used -to write a server which communicates with several sockets while also -listening for more connections on a listen socket - - use IO::Select; - use IO::Socket; - - $lsn = new IO::Socket::INET(Listen => 1, LocalPort => 8080); - $sel = new IO::Select( $lsn ); - - while(@ready = $sel->can_read) { - foreach $fh (@ready) { - if($fh == $lsn) { - # Create a new socket - $new = $lsn->accept; - $sel->add($new); - } - else { - # Process socket - - # Maybe we have finished with the socket - $sel->remove($fh); - $fh->close; - } - } - } - -=head1 AUTHOR - -Graham Barr. Currently maintained by the Perl Porters. Please report all -bugs to <perl5-porters@perl.org>. - -=head1 COPYRIGHT - -Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut - diff --git a/contrib/perl5/ext/IO/lib/IO/Socket.pm b/contrib/perl5/ext/IO/lib/IO/Socket.pm deleted file mode 100644 index b8da092..0000000 --- a/contrib/perl5/ext/IO/lib/IO/Socket.pm +++ /dev/null @@ -1,428 +0,0 @@ -# IO::Socket.pm -# -# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package IO::Socket; - -require 5.005_64; - -use IO::Handle; -use Socket 1.3; -use Carp; -use strict; -our(@ISA, $VERSION); -use Exporter; -use Errno; - -# legacy - -require IO::Socket::INET; -require IO::Socket::UNIX if ($^O ne 'epoc'); - -@ISA = qw(IO::Handle); - -$VERSION = "1.26"; - -sub import { - my $pkg = shift; - my $callpkg = caller; - Exporter::export 'Socket', $callpkg, @_; -} - -sub new { - my($class,%arg) = @_; - my $sock = $class->SUPER::new(); - - $sock->autoflush(1); - - ${*$sock}{'io_socket_timeout'} = delete $arg{Timeout}; - - return scalar(%arg) ? $sock->configure(\%arg) - : $sock; -} - -my @domain2pkg; - -sub register_domain { - my($p,$d) = @_; - $domain2pkg[$d] = $p; -} - -sub configure { - my($sock,$arg) = @_; - my $domain = delete $arg->{Domain}; - - croak 'IO::Socket: Cannot configure a generic socket' - unless defined $domain; - - croak "IO::Socket: Unsupported socket domain" - unless defined $domain2pkg[$domain]; - - croak "IO::Socket: Cannot configure socket in domain '$domain'" - unless ref($sock) eq "IO::Socket"; - - bless($sock, $domain2pkg[$domain]); - $sock->configure($arg); -} - -sub socket { - @_ == 4 or croak 'usage: $sock->socket(DOMAIN, TYPE, PROTOCOL)'; - my($sock,$domain,$type,$protocol) = @_; - - socket($sock,$domain,$type,$protocol) or - return undef; - - ${*$sock}{'io_socket_domain'} = $domain; - ${*$sock}{'io_socket_type'} = $type; - ${*$sock}{'io_socket_proto'} = $protocol; - - $sock; -} - -sub socketpair { - @_ == 4 || croak 'usage: IO::Socket->socketpair(DOMAIN, TYPE, PROTOCOL)'; - my($class,$domain,$type,$protocol) = @_; - my $sock1 = $class->new(); - my $sock2 = $class->new(); - - socketpair($sock1,$sock2,$domain,$type,$protocol) or - return (); - - ${*$sock1}{'io_socket_type'} = ${*$sock2}{'io_socket_type'} = $type; - ${*$sock1}{'io_socket_proto'} = ${*$sock2}{'io_socket_proto'} = $protocol; - - ($sock1,$sock2); -} - -sub connect { - @_ == 2 or croak 'usage: $sock->connect(NAME)'; - my $sock = shift; - my $addr = shift; - my $timeout = ${*$sock}{'io_socket_timeout'}; - my $err; - my $blocking; - $blocking = $sock->blocking(0) if $timeout; - - if (!connect($sock, $addr)) { - if ($timeout && $!{EINPROGRESS}) { - require IO::Select; - - my $sel = new IO::Select $sock; - - if (!$sel->can_write($timeout)) { - $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1); - $@ = "connect: timeout"; - } - elsif(!connect($sock,$addr) && not $!{EISCONN}) { - # Some systems refuse to re-connect() to - # an already open socket and set errno to EISCONN. - $err = $!; - $@ = "connect: $!"; - } - } - else { - $err = $!; - $@ = "connect: $!"; - } - } - - $sock->blocking(1) if $blocking; - - $! = $err if $err; - - $err ? undef : $sock; -} - -sub bind { - @_ == 2 or croak 'usage: $sock->bind(NAME)'; - my $sock = shift; - my $addr = shift; - - return bind($sock, $addr) ? $sock - : undef; -} - -sub listen { - @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])'; - my($sock,$queue) = @_; - $queue = 5 - unless $queue && $queue > 0; - - return listen($sock, $queue) ? $sock - : undef; -} - -sub accept { - @_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])'; - my $sock = shift; - my $pkg = shift || $sock; - my $timeout = ${*$sock}{'io_socket_timeout'}; - my $new = $pkg->new(Timeout => $timeout); - my $peer = undef; - - if($timeout) { - require IO::Select; - - my $sel = new IO::Select $sock; - - unless ($sel->can_read($timeout)) { - $@ = 'accept: timeout'; - $! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1); - return; - } - } - - $peer = accept($new,$sock) - or return; - - return wantarray ? ($new, $peer) - : $new; -} - -sub sockname { - @_ == 1 or croak 'usage: $sock->sockname()'; - getsockname($_[0]); -} - -sub peername { - @_ == 1 or croak 'usage: $sock->peername()'; - my($sock) = @_; - getpeername($sock) - || ${*$sock}{'io_socket_peername'} - || undef; -} - -sub connected { - @_ == 1 or croak 'usage: $sock->connected()'; - my($sock) = @_; - getpeername($sock); -} - -sub send { - @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])'; - my $sock = $_[0]; - my $flags = $_[2] || 0; - my $peer = $_[3] || $sock->peername; - - croak 'send: Cannot determine peer address' - unless($peer); - - my $r = defined(getpeername($sock)) - ? send($sock, $_[1], $flags) - : send($sock, $_[1], $flags, $peer); - - # remember who we send to, if it was sucessful - ${*$sock}{'io_socket_peername'} = $peer - if(@_ == 4 && defined $r); - - $r; -} - -sub recv { - @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])'; - my $sock = $_[0]; - my $len = $_[2]; - my $flags = $_[3] || 0; - - # remember who we recv'd from - ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags); -} - -sub shutdown { - @_ == 2 or croak 'usage: $sock->shutdown(HOW)'; - my($sock, $how) = @_; - shutdown($sock, $how); -} - -sub setsockopt { - @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME)'; - setsockopt($_[0],$_[1],$_[2],$_[3]); -} - -my $intsize = length(pack("i",0)); - -sub getsockopt { - @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)'; - my $r = getsockopt($_[0],$_[1],$_[2]); - # Just a guess - $r = unpack("i", $r) - if(defined $r && length($r) == $intsize); - $r; -} - -sub sockopt { - my $sock = shift; - @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_) - : $sock->setsockopt(SOL_SOCKET,@_); -} - -sub timeout { - @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])'; - my($sock,$val) = @_; - my $r = ${*$sock}{'io_socket_timeout'} || undef; - - ${*$sock}{'io_socket_timeout'} = 0 + $val - if(@_ == 2); - - $r; -} - -sub sockdomain { - @_ == 1 or croak 'usage: $sock->sockdomain()'; - my $sock = shift; - ${*$sock}{'io_socket_domain'}; -} - -sub socktype { - @_ == 1 or croak 'usage: $sock->socktype()'; - my $sock = shift; - ${*$sock}{'io_socket_type'} -} - -sub protocol { - @_ == 1 or croak 'usage: $sock->protocol()'; - my($sock) = @_; - ${*$sock}{'io_socket_proto'}; -} - -1; - -__END__ - -=head1 NAME - -IO::Socket - Object interface to socket communications - -=head1 SYNOPSIS - - use IO::Socket; - -=head1 DESCRIPTION - -C<IO::Socket> provides an object interface to creating and using sockets. It -is built upon the L<IO::Handle> interface and inherits all the methods defined -by L<IO::Handle>. - -C<IO::Socket> only defines methods for those operations which are common to all -types of socket. Operations which are specified to a socket in a particular -domain have methods defined in sub classes of C<IO::Socket> - -C<IO::Socket> will export all functions (and constants) defined by L<Socket>. - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( [ARGS] ) - -Creates an C<IO::Socket>, which is a reference to a -newly created symbol (see the C<Symbol> package). C<new> -optionally takes arguments, these arguments are in key-value pairs. -C<new> only looks for one key C<Domain> which tells new which domain -the socket will be in. All other arguments will be passed to the -configuration method of the package for that domain, See below. - - NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE - -As of VERSION 1.18 all IO::Socket objects have autoflush turned on -by default. This was not the case with earlier releases. - - NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE - -=back - -=head1 METHODS - -See L<perlfunc> for complete descriptions of each of the following -supported C<IO::Socket> methods, which are just front ends for the -corresponding built-in functions: - - socket - socketpair - bind - listen - accept - send - recv - peername (getpeername) - sockname (getsockname) - shutdown - -Some methods take slightly different arguments to those defined in L<perlfunc> -in attempt to make the interface more flexible. These are - -=over 4 - -=item accept([PKG]) - -perform the system call C<accept> on the socket and return a new object. The -new object will be created in the same class as the listen socket, unless -C<PKG> is specified. This object can be used to communicate with the client -that was trying to connect. In a scalar context the new socket is returned, -or undef upon failure. In a list context a two-element array is returned -containing the new socket and the peer address; the list will -be empty upon failure. - -=item socketpair(DOMAIN, TYPE, PROTOCOL) - -Call C<socketpair> and return a list of two sockets created, or an -empty list on failure. - -=back - -Additional methods that are provided are: - -=over 4 - -=item timeout([VAL]) - -Set or get the timeout value associated with this socket. If called without -any arguments then the current setting is returned. If called with an argument -the current setting is changed and the previous value returned. - -=item sockopt(OPT [, VAL]) - -Unified method to both set and get options in the SOL_SOCKET level. If called -with one argument then getsockopt is called, otherwise setsockopt is called. - -=item sockdomain - -Returns the numerical number for the socket domain type. For example, for -a AF_INET socket the value of &AF_INET will be returned. - -=item socktype - -Returns the numerical number for the socket type. For example, for -a SOCK_STREAM socket the value of &SOCK_STREAM will be returned. - -=item protocol - -Returns the numerical number for the protocol being used on the socket, if -known. If the protocol is unknown, as with an AF_UNIX socket, zero -is returned. - -=item connected - -If the socket is in a connected state the the peer address is returned. -If the socket is not in a connected state then undef will be returned. - -=back - -=head1 SEE ALSO - -L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX> - -=head1 AUTHOR - -Graham Barr. Currently maintained by the Perl Porters. Please report all -bugs to <perl5-porters@perl.org>. - -=head1 COPYRIGHT - -Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut diff --git a/contrib/perl5/ext/IO/lib/IO/Socket/INET.pm b/contrib/perl5/ext/IO/lib/IO/Socket/INET.pm deleted file mode 100644 index d2cc488..0000000 --- a/contrib/perl5/ext/IO/lib/IO/Socket/INET.pm +++ /dev/null @@ -1,414 +0,0 @@ -# IO::Socket::INET.pm -# -# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package IO::Socket::INET; - -use strict; -our(@ISA, $VERSION); -use IO::Socket; -use Socket; -use Carp; -use Exporter; -use Errno; - -@ISA = qw(IO::Socket); -$VERSION = "1.25"; - -my $EINVAL = exists(&Errno::EINVAL) ? Errno::EINVAL() : 1; - -IO::Socket::INET->register_domain( AF_INET ); - -my %socket_type = ( tcp => SOCK_STREAM, - udp => SOCK_DGRAM, - icmp => SOCK_RAW - ); - -sub new { - my $class = shift; - unshift(@_, "PeerAddr") if @_ == 1; - return $class->SUPER::new(@_); -} - -sub _sock_info { - my($addr,$port,$proto) = @_; - my $origport = $port; - my @proto = (); - my @serv = (); - - $port = $1 - if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,); - - if(defined $proto) { - if (@proto = ( $proto =~ m,\D, - ? getprotobyname($proto) - : getprotobynumber($proto)) - ) { - $proto = $proto[2] || undef; - } - else { - $@ = "Bad protocol '$proto'"; - return; - } - } - - if(defined $port) { - $port =~ s,\((\d+)\)$,,; - - my $defport = $1 || undef; - my $pnum = ($port =~ m,^(\d+)$,)[0]; - - @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; - } - - return ($addr || undef, - $port || undef, - $proto || undef - ); -} - -sub _error { - my $sock = shift; - my $err = shift; - { - local($!); - $@ = join("",ref($sock),": ",@_); - close($sock) - if(defined fileno($sock)); - } - $! = $err; - return undef; -} - -sub _get_addr { - my($sock,$addr_str, $multi) = @_; - my @addr; - if ($multi && $addr_str !~ /^\d+(?:\.\d+){3}$/) { - (undef, undef, undef, undef, @addr) = gethostbyname($addr_str); - } else { - my $h = inet_aton($addr_str); - push(@addr, $h) if defined $h; - } - @addr; -} - -sub configure { - my($sock,$arg) = @_; - my($lport,$rport,$laddr,$raddr,$proto,$type); - - - $arg->{LocalAddr} = $arg->{LocalHost} - if exists $arg->{LocalHost} && !exists $arg->{LocalAddr}; - - ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr}, - $arg->{LocalPort}, - $arg->{Proto}) - or return _error($sock, $!, $@); - - $laddr = defined $laddr ? inet_aton($laddr) - : INADDR_ANY; - - return _error($sock, $EINVAL, "Bad hostname '",$arg->{LocalAddr},"'") - unless(defined $laddr); - - $arg->{PeerAddr} = $arg->{PeerHost} - if exists $arg->{PeerHost} && !exists $arg->{PeerAddr}; - - unless(exists $arg->{Listen}) { - ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr}, - $arg->{PeerPort}, - $proto) - or return _error($sock, $!, $@); - } - - $proto ||= (getprotobyname('tcp'))[2]; - - my $pname = (getprotobynumber($proto))[0]; - $type = $arg->{Type} || $socket_type{$pname}; - - my @raddr = (); - - if(defined $raddr) { - @raddr = $sock->_get_addr($raddr, $arg->{MultiHomed}); - return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'") - unless @raddr; - } - - while(1) { - - $sock->socket(AF_INET, $type, $proto) or - return _error($sock, $!, "$!"); - - if ($arg->{Reuse} || $arg->{ReuseAddr}) { - $sock->sockopt(SO_REUSEADDR,1) or - return _error($sock, $!, "$!"); - } - - if ($arg->{ReusePort}) { - $sock->sockopt(SO_REUSEPORT,1) or - return _error($sock, $!, "$!"); - } - - if($lport || ($laddr ne INADDR_ANY) || exists $arg->{Listen}) { - $sock->bind($lport || 0, $laddr) or - return _error($sock, $!, "$!"); - } - - if(exists $arg->{Listen}) { - $sock->listen($arg->{Listen} || 5) or - return _error($sock, $!, "$!"); - last; - } - - # don't try to connect unless we're given a PeerAddr - last unless exists($arg->{PeerAddr}); - - $raddr = shift @raddr; - - return _error($sock, $EINVAL, 'Cannot determine remote port') - unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW); - - last - unless($type == SOCK_STREAM || defined $raddr); - - return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'") - unless defined $raddr; - -# my $timeout = ${*$sock}{'io_socket_timeout'}; -# my $before = time() if $timeout; - - if ($sock->connect(pack_sockaddr_in($rport, $raddr))) { -# ${*$sock}{'io_socket_timeout'} = $timeout; - return $sock; - } - - return _error($sock, $!, "Timeout") - unless @raddr; - -# if ($timeout) { -# my $new_timeout = $timeout - (time() - $before); -# return _error($sock, -# (exists(&Errno::ETIMEDOUT) ? Errno::ETIMEDOUT() : $EINVAL), -# "Timeout") if $new_timeout <= 0; -# ${*$sock}{'io_socket_timeout'} = $new_timeout; -# } - - } - - $sock; -} - -sub connect { - @_ == 2 || @_ == 3 or - croak 'usage: $sock->connect(NAME) or $sock->connect(PORT, ADDR)'; - my $sock = shift; - return $sock->SUPER::connect(@_ == 1 ? shift : pack_sockaddr_in(@_)); -} - -sub bind { - @_ == 2 || @_ == 3 or - croak 'usage: $sock->bind(NAME) or $sock->bind(PORT, ADDR)'; - my $sock = shift; - return $sock->SUPER::bind(@_ == 1 ? shift : pack_sockaddr_in(@_)) -} - -sub sockaddr { - @_ == 1 or croak 'usage: $sock->sockaddr()'; - my($sock) = @_; - my $name = $sock->sockname; - $name ? (sockaddr_in($name))[1] : undef; -} - -sub sockport { - @_ == 1 or croak 'usage: $sock->sockport()'; - my($sock) = @_; - my $name = $sock->sockname; - $name ? (sockaddr_in($name))[0] : undef; -} - -sub sockhost { - @_ == 1 or croak 'usage: $sock->sockhost()'; - my($sock) = @_; - my $addr = $sock->sockaddr; - $addr ? inet_ntoa($addr) : undef; -} - -sub peeraddr { - @_ == 1 or croak 'usage: $sock->peeraddr()'; - my($sock) = @_; - my $name = $sock->peername; - $name ? (sockaddr_in($name))[1] : undef; -} - -sub peerport { - @_ == 1 or croak 'usage: $sock->peerport()'; - my($sock) = @_; - my $name = $sock->peername; - $name ? (sockaddr_in($name))[0] : undef; -} - -sub peerhost { - @_ == 1 or croak 'usage: $sock->peerhost()'; - my($sock) = @_; - my $addr = $sock->peeraddr; - $addr ? inet_ntoa($addr) : undef; -} - -1; - -__END__ - -=head1 NAME - -IO::Socket::INET - Object interface for AF_INET domain sockets - -=head1 SYNOPSIS - - use IO::Socket::INET; - -=head1 DESCRIPTION - -C<IO::Socket::INET> provides an object interface to creating and using sockets -in the AF_INET domain. It is built upon the L<IO::Socket> interface and -inherits all the methods defined by L<IO::Socket>. - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( [ARGS] ) - -Creates an C<IO::Socket::INET> object, which is a reference to a -newly created symbol (see the C<Symbol> package). C<new> -optionally takes arguments, these arguments are in key-value pairs. - -In addition to the key-value pairs accepted by L<IO::Socket>, -C<IO::Socket::INET> provides. - - - PeerAddr Remote host address <hostname>[:<port>] - PeerHost Synonym for PeerAddr - PeerPort Remote port or service <service>[(<no>)] | <no> - LocalAddr Local host bind address hostname[:port] - LocalHost Synonym for LocalAddr - LocalPort Local host bind port <service>[(<no>)] | <no> - Proto Protocol name (or number) "tcp" | "udp" | ... - Type Socket type SOCK_STREAM | SOCK_DGRAM | ... - Listen Queue size for listen - ReuseAddr Set SO_REUSEADDR before binding - Reuse Set SO_REUSEADDR before binding (deprecated, prefer ReuseAddr) - ReusePort Set SO_REUSEPORT before binding - Timeout Timeout value for various operations - MultiHomed Try all adresses for multi-homed hosts - - -If C<Listen> is defined then a listen socket is created, else if the -socket type, which is derived from the protocol, is SOCK_STREAM then -connect() is called. - -Although it is not illegal, the use of C<MultiHomed> on a socket -which is in non-blocking mode is of little use. This is because the -first connect will never fail with a timeout as the connaect call -will not block. - -The C<PeerAddr> can be a hostname or the IP-address on the -"xx.xx.xx.xx" form. The C<PeerPort> can be a number or a symbolic -service name. The service name might be followed by a number in -parenthesis which is used if the service is not known by the system. -The C<PeerPort> specification can also be embedded in the C<PeerAddr> -by preceding it with a ":". - -If C<Proto> is not given and you specify a symbolic C<PeerPort> port, -then the constructor will try to derive C<Proto> from the service -name. As a last resort C<Proto> "tcp" is assumed. The C<Type> -parameter will be deduced from C<Proto> if not specified. - -If the constructor is only passed a single argument, it is assumed to -be a C<PeerAddr> specification. - -Examples: - - $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org', - PeerPort => 'http(80)', - Proto => 'tcp'); - - $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)'); - - $sock = IO::Socket::INET->new(Listen => 5, - LocalAddr => 'localhost', - LocalPort => 9000, - Proto => 'tcp'); - - $sock = IO::Socket::INET->new('127.0.0.1:25'); - - - NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE - -As of VERSION 1.18 all IO::Socket objects have autoflush turned on -by default. This was not the case with earlier releases. - - NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE - -=back - -=head2 METHODS - -=over 4 - -=item sockaddr () - -Return the address part of the sockaddr structure for the socket - -=item sockport () - -Return the port number that the socket is using on the local host - -=item sockhost () - -Return the address part of the sockaddr structure for the socket in a -text form xx.xx.xx.xx - -=item peeraddr () - -Return the address part of the sockaddr structure for the socket on -the peer host - -=item peerport () - -Return the port number for the socket on the peer host. - -=item peerhost () - -Return the address part of the sockaddr structure for the socket on the -peer host in a text form xx.xx.xx.xx - -=back - -=head1 SEE ALSO - -L<Socket>, L<IO::Socket> - -=head1 AUTHOR - -Graham Barr. Currently maintained by the Perl Porters. Please report all -bugs to <perl5-porters@perl.org>. - -=head1 COPYRIGHT - -Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut diff --git a/contrib/perl5/ext/IO/lib/IO/Socket/UNIX.pm b/contrib/perl5/ext/IO/lib/IO/Socket/UNIX.pm deleted file mode 100644 index 2a11752..0000000 --- a/contrib/perl5/ext/IO/lib/IO/Socket/UNIX.pm +++ /dev/null @@ -1,143 +0,0 @@ -# IO::Socket::UNIX.pm -# -# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package IO::Socket::UNIX; - -use strict; -our(@ISA, $VERSION); -use IO::Socket; -use Socket; -use Carp; - -@ISA = qw(IO::Socket); -$VERSION = "1.20"; - -IO::Socket::UNIX->register_domain( AF_UNIX ); - -sub new { - my $class = shift; - unshift(@_, "Peer") if @_ == 1; - return $class->SUPER::new(@_); -} - -sub configure { - my($sock,$arg) = @_; - my($bport,$cport); - - my $type = $arg->{Type} || SOCK_STREAM; - - $sock->socket(AF_UNIX, $type, 0) or - return undef; - - if(exists $arg->{Local}) { - my $addr = sockaddr_un($arg->{Local}); - $sock->bind($addr) or - return undef; - } - if(exists $arg->{Listen} && $type != SOCK_DGRAM) { - $sock->listen($arg->{Listen} || 5) or - return undef; - } - elsif(exists $arg->{Peer}) { - my $addr = sockaddr_un($arg->{Peer}); - $sock->connect($addr) or - return undef; - } - - $sock; -} - -sub hostpath { - @_ == 1 or croak 'usage: $sock->hostpath()'; - my $n = $_[0]->sockname || return undef; - (sockaddr_un($n))[0]; -} - -sub peerpath { - @_ == 1 or croak 'usage: $sock->peerpath()'; - my $n = $_[0]->peername || return undef; - (sockaddr_un($n))[0]; -} - -1; # Keep require happy - -__END__ - -=head1 NAME - -IO::Socket::UNIX - Object interface for AF_UNIX domain sockets - -=head1 SYNOPSIS - - use IO::Socket::UNIX; - -=head1 DESCRIPTION - -C<IO::Socket::UNIX> provides an object interface to creating and using sockets -in the AF_UNIX domain. It is built upon the L<IO::Socket> interface and -inherits all the methods defined by L<IO::Socket>. - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( [ARGS] ) - -Creates an C<IO::Socket::UNIX> object, which is a reference to a -newly created symbol (see the C<Symbol> package). C<new> -optionally takes arguments, these arguments are in key-value pairs. - -In addition to the key-value pairs accepted by L<IO::Socket>, -C<IO::Socket::UNIX> provides. - - Type Type of socket (eg SOCK_STREAM or SOCK_DGRAM) - Local Path to local fifo - Peer Path to peer fifo - Listen Create a listen socket - -If the constructor is only passed a single argument, it is assumed to -be a C<Peer> specification. - - - NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE - -As of VERSION 1.18 all IO::Socket objects have autoflush turned on -by default. This was not the case with earlier releases. - - NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE - -=back - -=head1 METHODS - -=over 4 - -=item hostpath() - -Returns the pathname to the fifo at the local end - -=item peerpath() - -Returns the pathanme to the fifo at the peer end - -=back - -=head1 SEE ALSO - -L<Socket>, L<IO::Socket> - -=head1 AUTHOR - -Graham Barr. Currently maintained by the Perl Porters. Please report all -bugs to <perl5-porters@perl.org>. - -=head1 COPYRIGHT - -Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut diff --git a/contrib/perl5/ext/IO/poll.c b/contrib/perl5/ext/IO/poll.c deleted file mode 100644 index 024c52f..0000000 --- a/contrib/perl5/ext/IO/poll.c +++ /dev/null @@ -1,135 +0,0 @@ -/* - * poll.c - * - * Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. - * 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 - * kernels < v2.1.23) try to emulate it as closely as possible using select() - * - */ - -#include "EXTERN.h" -#include "perl.h" -#include "poll.h" -#ifdef I_SYS_TIME -# include <sys/time.h> -#endif -#ifdef I_TIME -# include <time.h> -#endif -#include <sys/types.h> -#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */ -# include <sys/socket.h> -#endif -#include <sys/stat.h> -#include <errno.h> - -#ifdef HAS_SELECT -#ifdef I_SYS_SELECT -#include <sys/select.h> -#endif -#endif - -#ifdef EMULATE_POLL_WITH_SELECT - -# define POLL_CAN_READ (POLLIN | POLLRDNORM ) -# define POLL_CAN_WRITE (POLLOUT | POLLWRNORM | POLLWRBAND ) -# define POLL_HAS_EXCP (POLLRDBAND | POLLPRI ) - -# define POLL_EVENTS_MASK (POLL_CAN_READ | POLL_CAN_WRITE | POLL_HAS_EXCP) - -int -poll(struct pollfd *fds, unsigned long nfds, int timeout) -{ - int i,err; - fd_set rfd,wfd,efd,ifd; - struct timeval timebuf; - struct timeval *tbuf = (struct timeval *)0; - int n = 0; - int count; - - FD_ZERO(&ifd); - -again: - - FD_ZERO(&rfd); - FD_ZERO(&wfd); - FD_ZERO(&efd); - - for(i = 0 ; i < nfds ; i++) { - int events = fds[i].events; - int fd = fds[i].fd; - - fds[i].revents = 0; - - if(fd < 0 || FD_ISSET(fd, &ifd)) - continue; - - if(fd > n) - n = fd; - - if(events & POLL_CAN_READ) - FD_SET(fd, &rfd); - - if(events & POLL_CAN_WRITE) - FD_SET(fd, &wfd); - - if(events & POLL_HAS_EXCP) - FD_SET(fd, &efd); - } - - if(timeout >= 0) { - timebuf.tv_sec = timeout / 1000; - timebuf.tv_usec = (timeout % 1000) * 1000; - tbuf = &timebuf; - } - - err = select(n+1,&rfd,&wfd,&efd,tbuf); - - if(err < 0) { -#ifdef HAS_FSTAT - if(errno == EBADF) { - for(i = 0 ; i < nfds ; i++) { - struct stat buf; - if((fstat(fds[i].fd,&buf) < 0) && (errno == EBADF)) { - FD_SET(fds[i].fd, &ifd); - goto again; - } - } - } -#endif /* HAS_FSTAT */ - return err; - } - - count = 0; - - for(i = 0 ; i < nfds ; i++) { - int revents = (fds[i].events & POLL_EVENTS_MASK); - int fd = fds[i].fd; - - if(fd < 0) - continue; - - if(FD_ISSET(fd, &ifd)) - revents = POLLNVAL; - else { - if(!FD_ISSET(fd, &rfd)) - revents &= ~POLL_CAN_READ; - - if(!FD_ISSET(fd, &wfd)) - revents &= ~POLL_CAN_WRITE; - - if(!FD_ISSET(fd, &efd)) - revents &= ~POLL_HAS_EXCP; - } - - if((fds[i].revents = revents) != 0) - count++; - } - - return count; -} - -#endif /* EMULATE_POLL_WITH_SELECT */ diff --git a/contrib/perl5/ext/IO/poll.h b/contrib/perl5/ext/IO/poll.h deleted file mode 100644 index 4055b49..0000000 --- a/contrib/perl5/ext/IO/poll.h +++ /dev/null @@ -1,55 +0,0 @@ -/* - * poll.h - * - * Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. - * This program is free software; you can redistribute it and/or - * modify it under the same terms as Perl itself. - * - */ - -#ifndef POLL_H -# define POLL_H - -#if (defined(HAS_POLL) && defined(I_POLL)) || defined(POLLWRBAND) -# include <poll.h> -#else -#ifdef HAS_SELECT - - -/* We shall emulate poll using select */ - -#define EMULATE_POLL_WITH_SELECT - -typedef struct pollfd { - int fd; - short events; - short revents; -} pollfd_t; - -#define POLLIN 0x0001 -#define POLLPRI 0x0002 -#define POLLOUT 0x0004 -#define POLLRDNORM 0x0040 -#define POLLWRNORM POLLOUT -#define POLLRDBAND 0x0080 -#define POLLWRBAND 0x0100 -#define POLLNORM POLLRDNORM - -/* Return ONLY events (NON testable) */ - -#define POLLERR 0x0008 -#define POLLHUP 0x0010 -#define POLLNVAL 0x0020 - -int poll (struct pollfd *, unsigned long, int); - -#ifndef HAS_POLL -# define HAS_POLL -#endif - -#endif /* HAS_SELECT */ - -#endif /* I_POLL */ - -#endif /* POLL_H */ - diff --git a/contrib/perl5/ext/IPC/SysV/ChangeLog b/contrib/perl5/ext/IPC/SysV/ChangeLog deleted file mode 100644 index fff95be..0000000 --- a/contrib/perl5/ext/IPC/SysV/ChangeLog +++ /dev/null @@ -1,28 +0,0 @@ -Fri Jul 3 15:06:40 1998 Jarkko Hietaniemi <jhi@iki.fi> - - - Integrated IPC::SysV 1.03 to Perl 5.004_69. - -Change 142 on 1998/05/31 by <gbarr@pobox.com> (Graham Barr) - - - Changed SHMLBA from a constSUB to an XS sub as on some systems it is not - a constant - - Added a missing MODULE line to SysV.xs so ftok is defined in IPC::SysV - -Change 138 on 1998/05/23 by <gbarr@pobox.com> (Graham Barr) - - Applied patch from Jarkko Hietaniemi to add constats for UNICOS - - Reduced size of XS object by changing constant sub definition - into a loop - - Updated POD to include ftok() - -Change 135 on 1998/05/18 by <gbarr@pobox.com> (Graham Barr) - - applied changes from Jarkko Hietaniemi <jhi@iki.fi> to add - new constants and ftok - - fixed to compile with >5.004_50 - - surrounded newCONSTSUB with #ifndef as perl now defines this itself - diff --git a/contrib/perl5/ext/IPC/SysV/MANIFEST b/contrib/perl5/ext/IPC/SysV/MANIFEST deleted file mode 100644 index 4b2aa00..0000000 --- a/contrib/perl5/ext/IPC/SysV/MANIFEST +++ /dev/null @@ -1,10 +0,0 @@ -MANIFEST -Makefile.PL -Msg.pm -README -Semaphore.pm -SysV.pm -SysV.xs -t/msg.t -t/sem.t -ChangeLog diff --git a/contrib/perl5/ext/IPC/SysV/Makefile.PL b/contrib/perl5/ext/IPC/SysV/Makefile.PL deleted file mode 100644 index 6831176..0000000 --- a/contrib/perl5/ext/IPC/SysV/Makefile.PL +++ /dev/null @@ -1,38 +0,0 @@ -# This -*- perl -*- script makes the Makefile -# $Id: Makefile.PL,v 1.3 1997/03/04 09:21:12 gbarr Exp $ -# $FreeBSD$ - -require 5.002; -use ExtUtils::MakeMaker; - -#--- MY package - -sub MY::libscan -{ - my($self,$path) = @_; - - return '' - if($path =~ m:/(RCS|CVS|SCCS)/: || - $path =~ m:[~%]$: || - $path =~ m:\.(orig|rej)$: - ); - - $path; -} - -WriteMakefile( - VERSION_FROM => "SysV.pm", - NAME => "IPC::SysV", - MAN3PODS => {}, # Pods will be built by installman. - - 'dist' => {COMPRESS => 'gzip -9f', - SUFFIX => 'gz', - DIST_DEFAULT => 'all tardist', - }, - - 'clean' => {FILES => join(" ", - map { "$_ */$_ */*/$_" } - qw(*% *.html *.b[ac]k *.old)) - }, - 'macro' => { INSTALLDIRS => 'perl' }, -); diff --git a/contrib/perl5/ext/IPC/SysV/Msg.pm b/contrib/perl5/ext/IPC/SysV/Msg.pm deleted file mode 100644 index 120a5b2..0000000 --- a/contrib/perl5/ext/IPC/SysV/Msg.pm +++ /dev/null @@ -1,223 +0,0 @@ -# IPC::Msg.pm -# -# Copyright (c) 1997 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package IPC::Msg; - -use IPC::SysV qw(IPC_STAT IPC_SET IPC_RMID); -use strict; -use vars qw($VERSION); -use Carp; - -$VERSION = "1.00"; - -{ - package IPC::Msg::stat; - - use Class::Struct qw(struct); - - struct 'IPC::Msg::stat' => [ - uid => '$', - gid => '$', - cuid => '$', - cgid => '$', - mode => '$', - qnum => '$', - qbytes => '$', - lspid => '$', - lrpid => '$', - stime => '$', - rtime => '$', - ctime => '$', - ]; -} - -sub new { - @_ == 3 || croak 'new IPC::Msg ( KEY , FLAGS )'; - my $class = shift; - - my $id = msgget($_[0],$_[1]); - - defined($id) - ? bless \$id, $class - : undef; -} - -sub id { - my $self = shift; - $$self; -} - -sub stat { - my $self = shift; - my $data = ""; - msgctl($$self,IPC_STAT,$data) or - return undef; - IPC::Msg::stat->new->unpack($data); -} - -sub set { - my $self = shift; - my $ds; - - if(@_ == 1) { - $ds = shift; - } - else { - croak 'Bad arg count' if @_ % 2; - my %arg = @_; - my $ds = $self->stat - or return undef; - my($key,$val); - $ds->$key($val) - while(($key,$val) = each %arg); - } - - msgctl($$self,IPC_SET,$ds->pack); -} - -sub remove { - my $self = shift; - (msgctl($$self,IPC_RMID,0), undef $$self)[0]; -} - -sub rcv { - @_ <= 5 && @_ >= 3 or croak '$msg->rcv( BUF, LEN, TYPE, FLAGS )'; - my $self = shift; - my $buf = ""; - msgrcv($$self,$buf,$_[1],$_[2] || 0, $_[3] || 0) or - return; - my $type; - ($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); -} - - -1; - -__END__ - -=head1 NAME - -IPC::Msg - SysV Msg IPC object class - -=head1 SYNOPSIS - - use IPC::SysV qw(IPC_PRIVATE S_IRWXU); - use IPC::Msg; - - $msg = new IPC::Msg(IPC_PRIVATE, S_IRWXU); - - $msg->snd(pack("l! a*",$msgtype,$msg)); - - $msg->rcv($buf,256); - - $ds = $msg->stat; - - $msg->remove; - -=head1 DESCRIPTION - -=head1 METHODS - -=over 4 - -=item new ( KEY , FLAGS ) - -Creates a new message queue associated with C<KEY>. A new queue is -created if - -=over 4 - -=item * - -C<KEY> is equal to C<IPC_PRIVATE> - -=item * - -C<KEY> does not already have a message queue -associated with it, and C<I<FLAGS> & IPC_CREAT> is true. - -=back - -On creation of a new message queue C<FLAGS> is used to set the -permissions. - -=item id - -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>. The BUF becomes tainted. - -=item remove - -Remove and destroy the message queue from the system. - -=item set ( STAT ) - -=item set ( NAME => VALUE [, NAME => VALUE ...] ) - -C<set> will set the following values of the C<stat> structure associated -with the message queue. - - uid - gid - mode (oly the permission bits) - qbytes - -C<set> accepts either a stat object, as returned by the C<stat> method, -or a list of I<name>-I<value> pairs. - -=item snd ( TYPE, MSG [, FLAGS ] ) - -Place a message on the queue with the data from C<MSG> and with type C<TYPE>. -See L<msgsnd>. - -=item stat - -Returns an object of type C<IPC::Msg::stat> which is a sub-class of -C<Class::Struct>. It provides the following fields. For a description -of these fields see you system documentation. - - uid - gid - cuid - cgid - mode - qnum - qbytes - lspid - lrpid - stime - rtime - ctime - -=back - -=head1 SEE ALSO - -L<IPC::SysV> L<Class::Struct> - -=head1 AUTHOR - -Graham Barr <gbarr@pobox.com> - -=head1 COPYRIGHT - -Copyright (c) 1997 Graham Barr. All rights reserved. -This program is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -=cut - diff --git a/contrib/perl5/ext/IPC/SysV/README b/contrib/perl5/ext/IPC/SysV/README deleted file mode 100644 index d412c4c..0000000 --- a/contrib/perl5/ext/IPC/SysV/README +++ /dev/null @@ -1,20 +0,0 @@ -Copyright (c) 1997 Graham Barr <gbarr@pobox.com>. All rights reserved. -This package is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -The SysV-IPC contains three packages - - IPC::Semaphore - - Provides an object interface to using SysV IPC semaphores - - IPC::Msg - - Provides an object interface to using SysV IPC messages - - IPC::SysV - - Provides the constants required to use the system SysV IPC calls. - -Currently there is not object support for SysV shared memory, but -SysV::SharedMem is a project for the future. - -Share and enjoy! - diff --git a/contrib/perl5/ext/IPC/SysV/Semaphore.pm b/contrib/perl5/ext/IPC/SysV/Semaphore.pm deleted file mode 100644 index faf7411..0000000 --- a/contrib/perl5/ext/IPC/SysV/Semaphore.pm +++ /dev/null @@ -1,297 +0,0 @@ -# IPC::Semaphore -# -# Copyright (c) 1997 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package IPC::Semaphore; - -use IPC::SysV qw(GETNCNT GETZCNT GETVAL SETVAL GETPID GETALL SETALL - IPC_STAT IPC_SET IPC_RMID); -use strict; -use vars qw($VERSION); -use Carp; - -$VERSION = "1.00"; - -{ - package IPC::Semaphore::stat; - - use Class::Struct qw(struct); - - struct 'IPC::Semaphore::stat' => [ - uid => '$', - gid => '$', - cuid => '$', - cgid => '$', - mode => '$', - ctime => '$', - otime => '$', - nsems => '$', - ]; -} - -sub new { - @_ == 4 || croak 'new ' . __PACKAGE__ . '( KEY, NSEMS, FLAGS )'; - my $class = shift; - - my $id = semget($_[0],$_[1],$_[2]); - - defined($id) - ? bless \$id, $class - : undef; -} - -sub id { - my $self = shift; - $$self; -} - -sub remove { - my $self = shift; - (semctl($$self,0,IPC_RMID,0), undef $$self)[0]; -} - -sub getncnt { - @_ == 2 || croak '$sem->getncnt( SEM )'; - my $self = shift; - my $sem = shift; - my $v = semctl($$self,$sem,GETNCNT,0); - $v ? 0 + $v : undef; -} - -sub getzcnt { - @_ == 2 || croak '$sem->getzcnt( SEM )'; - my $self = shift; - my $sem = shift; - my $v = semctl($$self,$sem,GETZCNT,0); - $v ? 0 + $v : undef; -} - -sub getval { - @_ == 2 || croak '$sem->getval( SEM )'; - my $self = shift; - my $sem = shift; - my $v = semctl($$self,$sem,GETVAL,0); - $v ? 0 + $v : undef; -} - -sub getpid { - @_ == 2 || croak '$sem->getpid( SEM )'; - my $self = shift; - my $sem = shift; - my $v = semctl($$self,$sem,GETPID,0); - $v ? 0 + $v : undef; -} - -sub op { - @_ >= 4 || croak '$sem->op( OPLIST )'; - my $self = shift; - croak 'Bad arg count' if @_ % 3; - my $data = pack("s*",@_); - semop($$self,$data); -} - -sub stat { - my $self = shift; - my $data = ""; - semctl($$self,0,IPC_STAT,$data) - or return undef; - IPC::Semaphore::stat->new->unpack($data); -} - -sub set { - my $self = shift; - my $ds; - - if(@_ == 1) { - $ds = shift; - } - else { - croak 'Bad arg count' if @_ % 2; - my %arg = @_; - my $ds = $self->stat - or return undef; - my($key,$val); - $ds->$key($val) - while(($key,$val) = each %arg); - } - - my $v = semctl($$self,0,IPC_SET,$ds->pack); - $v ? 0 + $v : undef; -} - -sub getall { - my $self = shift; - my $data = ""; - semctl($$self,0,GETALL,$data) - or return (); - (unpack("s*",$data)); -} - -sub setall { - my $self = shift; - my $data = pack("s*",@_); - semctl($$self,0,SETALL,$data); -} - -sub setval { - @_ == 3 || croak '$sem->setval( SEM, VAL )'; - my $self = shift; - my $sem = shift; - my $val = shift; - semctl($$self,$sem,SETVAL,$val); -} - -1; - -__END__ - -=head1 NAME - -IPC::Semaphore - SysV Semaphore IPC object class - -=head1 SYNOPSIS - - use IPC::SysV qw(IPC_PRIVATE S_IRWXU IPC_CREAT); - use IPC::Semaphore; - - $sem = new IPC::Semaphore(IPC_PRIVATE, 10, S_IRWXU | IPC_CREAT); - - $sem->setall( (0) x 10); - - @sem = $sem->getall; - - $ncnt = $sem->getncnt; - - $zcnt = $sem->getzcnt; - - $ds = $sem->stat; - - $sem->remove; - -=head1 DESCRIPTION - -=head1 METHODS - -=over 4 - -=item new ( KEY , NSEMS , FLAGS ) - -Create a new semaphore set associated with C<KEY>. C<NSEMS> is the number -of semaphores in the set. A new set is created if - -=over 4 - -=item * - -C<KEY> is equal to C<IPC_PRIVATE> - -=item * - -C<KEY> does not already have a semaphore identifier -associated with it, and C<I<FLAGS> & IPC_CREAT> is true. - -=back - -On creation of a new semaphore set C<FLAGS> is used to set the -permissions. - -=item getall - -Returns the values of the semaphore set as an array. - -=item getncnt ( SEM ) - -Returns the number of processed waiting for the semaphore C<SEM> to -become greater than it's current value - -=item getpid ( SEM ) - -Returns the process id of the last process that performed an operation -on the semaphore C<SEM>. - -=item getval ( SEM ) - -Returns the current value of the semaphore C<SEM>. - -=item getzcnt ( SEM ) - -Returns the number of processed waiting for the semaphore C<SEM> to -become zero. - -=item id - -Returns the system identifier for the semaphore set. - -=item op ( OPLIST ) - -C<OPLIST> is a list of operations to pass to C<semop>. C<OPLIST> is -a concatenation of smaller lists, each which has three values. The -first is the semaphore number, the second is the operation and the last -is a flags value. See L<semop> for more details. For example - - $sem->op( - 0, -1, IPC_NOWAIT, - 1, 1, IPC_NOWAIT - ); - -=item remove - -Remove and destroy the semaphore set from the system. - -=item set ( STAT ) - -=item set ( NAME => VALUE [, NAME => VALUE ...] ) - -C<set> will set the following values of the C<stat> structure associated -with the semaphore set. - - uid - gid - mode (oly the permission bits) - -C<set> accepts either a stat object, as returned by the C<stat> method, -or a list of I<name>-I<value> pairs. - -=item setall ( VALUES ) - -Sets all values in the semaphore set to those given on the C<VALUES> list. -C<VALUES> must contain the correct number of values. - -=item setval ( N , VALUE ) - -Set the C<N>th value in the semaphore set to C<VALUE> - -=item stat - -Returns an object of type C<IPC::Semaphore::stat> which is a sub-class of -C<Class::Struct>. It provides the following fields. For a description -of these fields see you system documentation. - - uid - gid - cuid - cgid - mode - ctime - otime - nsems - -=back - -=head1 SEE ALSO - -L<IPC::SysV> L<Class::Struct> L<semget> L<semctl> L<semop> - -=head1 AUTHOR - -Graham Barr <gbarr@pobox.com> - -=head1 COPYRIGHT - -Copyright (c) 1997 Graham Barr. All rights reserved. -This program is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -=cut diff --git a/contrib/perl5/ext/IPC/SysV/SysV.pm b/contrib/perl5/ext/IPC/SysV/SysV.pm deleted file mode 100644 index bebb8fd..0000000 --- a/contrib/perl5/ext/IPC/SysV/SysV.pm +++ /dev/null @@ -1,102 +0,0 @@ -# IPC::SysV.pm -# -# Copyright (c) 1997 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package IPC::SysV; - -use strict; -use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); -use Carp; -use Config; - -require Exporter; -@ISA = qw(Exporter); - -$VERSION = "1.03"; - -@EXPORT_OK = qw( - GETALL GETNCNT GETPID GETVAL GETZCNT - - IPC_ALLOC IPC_CREAT IPC_EXCL IPC_GETACL IPC_LOCKED IPC_M - IPC_NOERROR IPC_NOWAIT IPC_PRIVATE IPC_R IPC_RMID IPC_SET - IPC_SETACL IPC_SETLABEL IPC_STAT IPC_W IPC_WANTED - - MSG_FWAIT MSG_LOCKED MSG_MWAIT MSG_NOERROR MSG_QWAIT - MSG_R MSG_RWAIT MSG_STAT MSG_W MSG_WWAIT - - SEM_A SEM_ALLOC SEM_DEST SEM_ERR SEM_ORDER SEM_R SEM_UNDO - - SETALL SETVAL - - SHMLBA - - SHM_A SHM_CLEAR SHM_COPY SHM_DCACHE SHM_DEST SHM_ECACHE - SHM_FMAP SHM_ICACHE SHM_INIT SHM_LOCK SHM_LOCKED SHM_MAP - SHM_NOSWAP SHM_R SHM_RDONLY SHM_REMOVED SHM_RND SHM_SHARE_MMU - SHM_SHATTR SHM_SIZE SHM_UNLOCK SHM_W - - S_IRUSR S_IWUSR S_IRWXU - S_IRGRP S_IWGRP S_IRWXG - S_IROTH S_IWOTH S_IRWXO - - ftok -); - -BOOT_XS: { - # If I inherit DynaLoader then I inherit AutoLoader and I DON'T WANT TO - require DynaLoader; - - # DynaLoader calls dl_load_flags as a static method. - *dl_load_flags = DynaLoader->can('dl_load_flags'); - - do { - __PACKAGE__->can('bootstrap') || \&DynaLoader::bootstrap - }->(__PACKAGE__, $VERSION); -} - -1; - -__END__ - -=head1 NAME - -IPC::SysV - SysV IPC constants - -=head1 SYNOPSIS - - use IPC::SysV qw(IPC_STAT IPC_PRIVATE); - -=head1 DESCRIPTION - -C<IPC::SysV> defines and conditionally exports all the constants -defined in your system include files which are needed by the SysV -IPC calls. - -=over - -=item ftok( PATH, ID ) - -Return a key based on PATH and ID, which can be used as a key for -C<msgget>, C<semget> and C<shmget>. See L<ftok> - -=back - -=head1 SEE ALSO - -L<IPC::Msg>, L<IPC::Semaphore>, L<ftok> - -=head1 AUTHORS - -Graham Barr <gbarr@pobox.com> -Jarkko Hietaniemi <jhi@iki.fi> - -=head1 COPYRIGHT - -Copyright (c) 1997 Graham Barr. All rights reserved. -This program is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -=cut - diff --git a/contrib/perl5/ext/IPC/SysV/SysV.xs b/contrib/perl5/ext/IPC/SysV/SysV.xs deleted file mode 100644 index c7985f9..0000000 --- a/contrib/perl5/ext/IPC/SysV/SysV.xs +++ /dev/null @@ -1,443 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#include <sys/types.h> -#ifdef __linux__ -# include <asm/page.h> -#endif -#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) -#ifndef HAS_SEM -# include <sys/ipc.h> -#endif -# ifdef HAS_MSG -# include <sys/msg.h> -# endif -# ifdef HAS_SHM -# if defined(PERL_SCO) || defined(PERL_ISC) -# include <sys/sysmacros.h> /* SHMLBA */ -# endif -# include <sys/shm.h> -# ifndef HAS_SHMAT_PROTOTYPE - extern Shmat_t shmat (int, char *, int); -# endif -# if defined(__sparc__) && (defined(__NetBSD__) || defined(__OpenBSD__)) -# undef SHMLBA /* not static: determined at boot time */ -# define SHMLBA getpagesize() -# endif -# endif -#endif - -/* Required to get 'struct pte' for SHMLBA on ULTRIX. */ -#if defined(__ultrix) || defined(__ultrix__) || defined(ultrix) -#include <machine/pte.h> -#endif - -/* Required in BSDI to get PAGE_SIZE definition for SHMLBA. - * Ugly. More beautiful solutions welcome. - * Shouting at BSDI sounds quite beautiful. */ -#ifdef __bsdi__ -# include <vm/vm_param.h> /* move upwards under HAS_SHM? */ -#endif - -#ifndef S_IRWXU -# ifdef S_IRUSR -# define S_IRWXU (S_IRUSR|S_IWUSR|S_IWUSR) -# define S_IRWXG (S_IRGRP|S_IWGRP|S_IWGRP) -# define S_IRWXO (S_IROTH|S_IWOTH|S_IWOTH) -# else -# define S_IRWXU 0700 -# define S_IRWXG 0070 -# define S_IRWXO 0007 -# endif -#endif - -MODULE=IPC::SysV PACKAGE=IPC::Msg::stat - -PROTOTYPES: ENABLE - -void -pack(obj) - SV * obj -PPCODE: -{ -#ifdef HAS_MSG - SV *sv; - struct msqid_ds ds; - AV *list = (AV*)SvRV(obj); - sv = *av_fetch(list,0,TRUE); ds.msg_perm.uid = SvIV(sv); - sv = *av_fetch(list,1,TRUE); ds.msg_perm.gid = SvIV(sv); - sv = *av_fetch(list,4,TRUE); ds.msg_perm.mode = SvIV(sv); - sv = *av_fetch(list,6,TRUE); ds.msg_qbytes = SvIV(sv); - ST(0) = sv_2mortal(newSVpvn((char *)&ds,sizeof(ds))); - XSRETURN(1); -#else - croak("System V msgxxx is not implemented on this machine"); -#endif -} - -void -unpack(obj,buf) - SV * obj - SV * buf -PPCODE: -{ -#ifdef HAS_MSG - STRLEN len; - SV **sv_ptr; - struct msqid_ds *ds = (struct msqid_ds *)SvPV(buf,len); - AV *list = (AV*)SvRV(obj); - if (len != sizeof(*ds)) { - croak("Bad arg length for %s, length is %d, should be %d", - "IPC::Msg::stat", - len, sizeof(*ds)); - } - sv_ptr = av_fetch(list,0,TRUE); - sv_setiv(*sv_ptr, ds->msg_perm.uid); - sv_ptr = av_fetch(list,1,TRUE); - sv_setiv(*sv_ptr, ds->msg_perm.gid); - sv_ptr = av_fetch(list,2,TRUE); - sv_setiv(*sv_ptr, ds->msg_perm.cuid); - sv_ptr = av_fetch(list,3,TRUE); - sv_setiv(*sv_ptr, ds->msg_perm.cgid); - sv_ptr = av_fetch(list,4,TRUE); - sv_setiv(*sv_ptr, ds->msg_perm.mode); - sv_ptr = av_fetch(list,5,TRUE); - sv_setiv(*sv_ptr, ds->msg_qnum); - sv_ptr = av_fetch(list,6,TRUE); - sv_setiv(*sv_ptr, ds->msg_qbytes); - sv_ptr = av_fetch(list,7,TRUE); - sv_setiv(*sv_ptr, ds->msg_lspid); - sv_ptr = av_fetch(list,8,TRUE); - sv_setiv(*sv_ptr, ds->msg_lrpid); - sv_ptr = av_fetch(list,9,TRUE); - sv_setiv(*sv_ptr, ds->msg_stime); - sv_ptr = av_fetch(list,10,TRUE); - sv_setiv(*sv_ptr, ds->msg_rtime); - sv_ptr = av_fetch(list,11,TRUE); - sv_setiv(*sv_ptr, ds->msg_ctime); - XSRETURN(1); -#else - croak("System V msgxxx is not implemented on this machine"); -#endif -} - -MODULE=IPC::SysV PACKAGE=IPC::Semaphore::stat - -void -unpack(obj,ds) - SV * obj - SV * ds -PPCODE: -{ -#ifdef HAS_SEM - STRLEN len; - AV *list = (AV*)SvRV(obj); - struct semid_ds *data = (struct semid_ds *)SvPV(ds,len); - if(!sv_isa(obj, "IPC::Semaphore::stat")) - croak("method %s not called a %s object", - "unpack","IPC::Semaphore::stat"); - if (len != sizeof(*data)) { - croak("Bad arg length for %s, length is %d, should be %d", - "IPC::Semaphore::stat", - len, sizeof(*data)); - } - sv_setiv(*av_fetch(list,0,TRUE), data[0].sem_perm.uid); - sv_setiv(*av_fetch(list,1,TRUE), data[0].sem_perm.gid); - sv_setiv(*av_fetch(list,2,TRUE), data[0].sem_perm.cuid); - sv_setiv(*av_fetch(list,3,TRUE), data[0].sem_perm.cgid); - sv_setiv(*av_fetch(list,4,TRUE), data[0].sem_perm.mode); - sv_setiv(*av_fetch(list,5,TRUE), data[0].sem_ctime); - sv_setiv(*av_fetch(list,6,TRUE), data[0].sem_otime); - sv_setiv(*av_fetch(list,7,TRUE), data[0].sem_nsems); - XSRETURN(1); -#else - croak("System V semxxx is not implemented on this machine"); -#endif -} - -void -pack(obj) - SV * obj -PPCODE: -{ -#ifdef HAS_SEM - SV **sv_ptr; - SV *sv; - struct semid_ds ds; - AV *list = (AV*)SvRV(obj); - if(!sv_isa(obj, "IPC::Semaphore::stat")) - croak("method %s not called a %s object", - "pack","IPC::Semaphore::stat"); - if((sv_ptr = av_fetch(list,0,TRUE)) && (sv = *sv_ptr)) - ds.sem_perm.uid = SvIV(*sv_ptr); - if((sv_ptr = av_fetch(list,1,TRUE)) && (sv = *sv_ptr)) - ds.sem_perm.gid = SvIV(*sv_ptr); - if((sv_ptr = av_fetch(list,2,TRUE)) && (sv = *sv_ptr)) - ds.sem_perm.cuid = SvIV(*sv_ptr); - if((sv_ptr = av_fetch(list,3,TRUE)) && (sv = *sv_ptr)) - ds.sem_perm.cgid = SvIV(*sv_ptr); - if((sv_ptr = av_fetch(list,4,TRUE)) && (sv = *sv_ptr)) - ds.sem_perm.mode = SvIV(*sv_ptr); - if((sv_ptr = av_fetch(list,5,TRUE)) && (sv = *sv_ptr)) - ds.sem_ctime = SvIV(*sv_ptr); - if((sv_ptr = av_fetch(list,6,TRUE)) && (sv = *sv_ptr)) - ds.sem_otime = SvIV(*sv_ptr); - if((sv_ptr = av_fetch(list,7,TRUE)) && (sv = *sv_ptr)) - ds.sem_nsems = SvIV(*sv_ptr); - ST(0) = sv_2mortal(newSVpvn((char *)&ds,sizeof(ds))); - XSRETURN(1); -#else - croak("System V semxxx is not implemented on this machine"); -#endif -} - -MODULE=IPC::SysV PACKAGE=IPC::SysV - -void -ftok(path, id) - char * path - int id - CODE: -#if defined(HAS_SEM) || defined(HAS_SHM) - key_t k = ftok(path, id); - ST(0) = k == (key_t) -1 ? &PL_sv_undef : sv_2mortal(newSViv(k)); -#else - DIE(aTHX_ PL_no_func, "ftok"); -#endif - -void -SHMLBA() - CODE: -#ifdef SHMLBA - ST(0) = sv_2mortal(newSViv(SHMLBA)); -#else - croak("SHMLBA is not defined on this architecture"); -#endif - -BOOT: -{ - HV *stash = gv_stashpvn("IPC::SysV", 9, TRUE); - /* - * constant subs for IPC::SysV - */ - struct { char *n; I32 v; } IPC__SysV__const[] = { -#ifdef GETVAL - {"GETVAL", GETVAL}, -#endif -#ifdef GETPID - {"GETPID", GETPID}, -#endif -#ifdef GETNCNT - {"GETNCNT", GETNCNT}, -#endif -#ifdef GETZCNT - {"GETZCNT", GETZCNT}, -#endif -#ifdef GETALL - {"GETALL", GETALL}, -#endif -#ifdef IPC_ALLOC - {"IPC_ALLOC", IPC_ALLOC}, -#endif -#ifdef IPC_CREAT - {"IPC_CREAT", IPC_CREAT}, -#endif -#ifdef IPC_EXCL - {"IPC_EXCL", IPC_EXCL}, -#endif -#ifdef IPC_GETACL - {"IPC_GETACL", IPC_EXCL}, -#endif -#ifdef IPC_LOCKED - {"IPC_LOCKED", IPC_LOCKED}, -#endif -#ifdef IPC_M - {"IPC_M", IPC_M}, -#endif -#ifdef IPC_NOERROR - {"IPC_NOERROR", IPC_NOERROR}, -#endif -#ifdef IPC_NOWAIT - {"IPC_NOWAIT", IPC_NOWAIT}, -#endif -#ifdef IPC_PRIVATE - {"IPC_PRIVATE", IPC_PRIVATE}, -#endif -#ifdef IPC_R - {"IPC_R", IPC_R}, -#endif -#ifdef IPC_RMID - {"IPC_RMID", IPC_RMID}, -#endif -#ifdef IPC_SET - {"IPC_SET", IPC_SET}, -#endif -#ifdef IPC_SETACL - {"IPC_SETACL", IPC_SETACL}, -#endif -#ifdef IPC_SETLABEL - {"IPC_SETLABEL", IPC_SETLABEL}, -#endif -#ifdef IPC_STAT - {"IPC_STAT", IPC_STAT}, -#endif -#ifdef IPC_W - {"IPC_W", IPC_W}, -#endif -#ifdef IPC_WANTED - {"IPC_WANTED", IPC_WANTED}, -#endif -#ifdef MSG_NOERROR - {"MSG_NOERROR", MSG_NOERROR}, -#endif -#ifdef MSG_FWAIT - {"MSG_FWAIT", MSG_FWAIT}, -#endif -#ifdef MSG_LOCKED - {"MSG_LOCKED", MSG_LOCKED}, -#endif -#ifdef MSG_MWAIT - {"MSG_MWAIT", MSG_MWAIT}, -#endif -#ifdef MSG_WAIT - {"MSG_WAIT", MSG_WAIT}, -#endif -#ifdef MSG_R - {"MSG_R", MSG_R}, -#endif -#ifdef MSG_RWAIT - {"MSG_RWAIT", MSG_RWAIT}, -#endif -#ifdef MSG_STAT - {"MSG_STAT", MSG_STAT}, -#endif -#ifdef MSG_W - {"MSG_W", MSG_W}, -#endif -#ifdef MSG_WWAIT - {"MSG_WWAIT", MSG_WWAIT}, -#endif -#ifdef SEM_A - {"SEM_A", SEM_A}, -#endif -#ifdef SEM_ALLOC - {"SEM_ALLOC", SEM_ALLOC}, -#endif -#ifdef SEM_DEST - {"SEM_DEST", SEM_DEST}, -#endif -#ifdef SEM_ERR - {"SEM_ERR", SEM_ERR}, -#endif -#ifdef SEM_R - {"SEM_R", SEM_R}, -#endif -#ifdef SEM_ORDER - {"SEM_ORDER", SEM_ORDER}, -#endif -#ifdef SEM_UNDO - {"SEM_UNDO", SEM_UNDO}, -#endif -#ifdef SETVAL - {"SETVAL", SETVAL}, -#endif -#ifdef SETALL - {"SETALL", SETALL}, -#endif -#ifdef SHM_CLEAR - {"SHM_CLEAR", SHM_CLEAR}, -#endif -#ifdef SHM_COPY - {"SHM_COPY", SHM_COPY}, -#endif -#ifdef SHM_DCACHE - {"SHM_DCACHE", SHM_DCACHE}, -#endif -#ifdef SHM_DEST - {"SHM_DEST", SHM_DEST}, -#endif -#ifdef SHM_ECACHE - {"SHM_ECACHE", SHM_ECACHE}, -#endif -#ifdef SHM_FMAP - {"SHM_FMAP", SHM_FMAP}, -#endif -#ifdef SHM_ICACHE - {"SHM_ICACHE", SHM_ICACHE}, -#endif -#ifdef SHM_INIT - {"SHM_INIT", SHM_INIT}, -#endif -#ifdef SHM_LOCK - {"SHM_LOCK", SHM_LOCK}, -#endif -#ifdef SHM_LOCKED - {"SHM_LOCKED", SHM_LOCKED}, -#endif -#ifdef SHM_MAP - {"SHM_MAP", SHM_MAP}, -#endif -#ifdef SHM_NOSWAP - {"SHM_NOSWAP", SHM_NOSWAP}, -#endif -#ifdef SHM_RDONLY - {"SHM_RDONLY", SHM_RDONLY}, -#endif -#ifdef SHM_REMOVED - {"SHM_REMOVED", SHM_REMOVED}, -#endif -#ifdef SHM_RND - {"SHM_RND", SHM_RND}, -#endif -#ifdef SHM_SHARE_MMU - {"SHM_SHARE_MMU", SHM_SHARE_MMU}, -#endif -#ifdef SHM_SHATTR - {"SHM_SHATTR", SHM_SHATTR}, -#endif -#ifdef SHM_SIZE - {"SHM_SIZE", SHM_SIZE}, -#endif -#ifdef SHM_UNLOCK - {"SHM_UNLOCK", SHM_UNLOCK}, -#endif -#ifdef SHM_W - {"SHM_W", SHM_W}, -#endif -#ifdef S_IRUSR - {"S_IRUSR", S_IRUSR}, -#endif -#ifdef S_IWUSR - {"S_IWUSR", S_IWUSR}, -#endif -#ifdef S_IRWXU - {"S_IRWXU", S_IRWXU}, -#endif -#ifdef S_IRGRP - {"S_IRGRP", S_IRGRP}, -#endif -#ifdef S_IWGRP - {"S_IWGRP", S_IWGRP}, -#endif -#ifdef S_IRWXG - {"S_IRWXG", S_IRWXG}, -#endif -#ifdef S_IROTH - {"S_IROTH", S_IROTH}, -#endif -#ifdef S_IWOTH - {"S_IWOTH", S_IWOTH}, -#endif -#ifdef S_IRWXO - {"S_IRWXO", S_IRWXO}, -#endif - {Nullch,0}}; - char *name; - int i; - - for(i = 0 ; (name = IPC__SysV__const[i].n) ; i++) { - newCONSTSUB(stash,name, newSViv(IPC__SysV__const[i].v)); - } -} - diff --git a/contrib/perl5/ext/IPC/SysV/hints/cygwin.pl b/contrib/perl5/ext/IPC/SysV/hints/cygwin.pl deleted file mode 100644 index e1a1dea..0000000 --- a/contrib/perl5/ext/IPC/SysV/hints/cygwin.pl +++ /dev/null @@ -1,2 +0,0 @@ -# SysV IPC is an optional Cygwin package -$self->{LIBS} = ['-lcygipc'] diff --git a/contrib/perl5/ext/IPC/SysV/hints/next_3.pl b/contrib/perl5/ext/IPC/SysV/hints/next_3.pl deleted file mode 100644 index 2290ac7..0000000 --- a/contrib/perl5/ext/IPC/SysV/hints/next_3.pl +++ /dev/null @@ -1 +0,0 @@ -$self->{CCFLAGS} = $Config{ccflags} . ' -D_POSIX_SOURCE' ; diff --git a/contrib/perl5/ext/IPC/SysV/t/msg.t b/contrib/perl5/ext/IPC/SysV/t/msg.t deleted file mode 100755 index 2a982f0..0000000 --- a/contrib/perl5/ext/IPC/SysV/t/msg.t +++ /dev/null @@ -1,41 +0,0 @@ -use IPC::SysV qw(IPC_PRIVATE IPC_RMID IPC_NOWAIT IPC_STAT S_IRWXU S_IRWXG S_IRWXO); - -use IPC::Msg; -#Creating a message queue - -print "1..9\n"; - -$msq = new IPC::Msg(IPC_PRIVATE, S_IRWXU | S_IRWXG | S_IRWXO) - || die "msgget: ",$!+0," $!\n"; - -print "ok 1\n"; - -#Putting a message on the queue -$msgtype = 1; -$msg = "hello"; -$msq->snd($msgtype,$msg,0) || print "not "; -print "ok 2\n"; - -#Check if there are messages on the queue -$ds = $msq->stat() or print "not "; -print "ok 3\n"; - -print "not " unless $ds && $ds->qnum() == 1; -print "ok 4\n"; - -#Retreiving a message from the queue -$rmsgtype = 0; # Give me any type -$rmsgtype = $msq->rcv($rmsg,256,$rmsgtype,IPC_NOWAIT) || print "not "; -print "ok 5\n"; - -print "not " unless $rmsgtype == $msgtype && $rmsg eq $msg; -print "ok 6\n"; - -$ds = $msq->stat() or print "not "; -print "ok 7\n"; - -print "not " unless $ds && $ds->qnum() == 0; -print "ok 8\n"; - -$msq->remove || print "not "; -print "ok 9\n"; diff --git a/contrib/perl5/ext/IPC/SysV/t/sem.t b/contrib/perl5/ext/IPC/SysV/t/sem.t deleted file mode 100755 index 9d6fff6..0000000 --- a/contrib/perl5/ext/IPC/SysV/t/sem.t +++ /dev/null @@ -1,51 +0,0 @@ - -use IPC::SysV qw( - SETALL - IPC_PRIVATE - IPC_CREAT - IPC_RMID - IPC_NOWAIT - IPC_STAT - S_IRWXU - S_IRWXG - S_IRWXO -); -use IPC::Semaphore; - -print "1..10\n"; - -$sem = new IPC::Semaphore(IPC_PRIVATE, 10, S_IRWXU | S_IRWXG | S_IRWXO | IPC_CREAT) - || die "semget: ",$!+0," $!\n"; - -print "ok 1\n"; - -my $st = $sem->stat || print "not "; -print "ok 2\n"; - -$sem->setall( (0) x 10) || print "not "; -print "ok 3\n"; - -my @sem = $sem->getall; -print "not " unless join("",@sem) eq "0000000000"; -print "ok 4\n"; - -$sem[2] = 1; -$sem->setall( @sem ) || print "not "; -print "ok 5\n"; - -@sem = $sem->getall; -print "not " unless join("",@sem) eq "0010000000"; -print "ok 6\n"; - -my $ncnt = $sem->getncnt(0); -print "not " if $sem->getncnt(0) || !defined($ncnt); -print "ok 7\n"; - -$sem->op(2,-1,IPC_NOWAIT) || print "not "; -print "ok 8\n"; - -print "not " if $sem->getncnt(0); -print "ok 9\n"; - -$sem->remove || print "not "; -print "ok 10\n"; diff --git a/contrib/perl5/ext/NDBM_File/Makefile.PL b/contrib/perl5/ext/NDBM_File/Makefile.PL deleted file mode 100644 index 7b58601..0000000 --- a/contrib/perl5/ext/NDBM_File/Makefile.PL +++ /dev/null @@ -1,9 +0,0 @@ -use ExtUtils::MakeMaker; -WriteMakefile( - NAME => 'NDBM_File', - LIBS => ["-L/usr/local/lib -lndbm", "-ldbm -lucb"], - MAN3PODS => {}, # Pods will be built by installman. - XSPROTOARG => '-noprototypes', # XXX remove later? - VERSION_FROM => 'NDBM_File.pm', - INC => ($^O eq "MacOS" ? "-i ::::db:include" : "") -); diff --git a/contrib/perl5/ext/NDBM_File/NDBM_File.pm b/contrib/perl5/ext/NDBM_File/NDBM_File.pm deleted file mode 100644 index b280459..0000000 --- a/contrib/perl5/ext/NDBM_File/NDBM_File.pm +++ /dev/null @@ -1,113 +0,0 @@ -package NDBM_File; - -use strict; -use warnings; - -require Tie::Hash; -use XSLoader (); - -our @ISA = qw(Tie::Hash); -our $VERSION = "1.04"; - -XSLoader::load 'NDBM_File', $VERSION; - -1; - -__END__ - -=head1 NAME - -NDBM_File - Tied access to ndbm files - -=head1 SYNOPSIS - - use Fcntl; # For O_RDWR, O_CREAT, etc. - use NDBM_File; - - # Now read and change the hash - $h{newkey} = newvalue; - print $h{oldkey}; - ... - - untie %h; - -=head1 DESCRIPTION - -C<NDBM_File> establishes a connection between a Perl hash variable and -a file in NDBM_File format;. You can manipulate the data in the file -just as if it were in a Perl hash, but when your program exits, the -data will remain in the file, to be used the next time your program -runs. - -Use C<NDBM_File> with the Perl built-in C<tie> function to establish -the connection between the variable and the file. The arguments to -C<tie> should be: - -=over 4 - -=item 1. - -The hash variable you want to tie. - -=item 2. - -The string C<"NDBM_File">. (Ths tells Perl to use the C<NDBM_File> -package to perform the functions of the hash.) - -=item 3. - -The name of the file you want to tie to the hash. - -=item 4. - -Flags. Use one of: - -=over 2 - -=item C<O_RDONLY> - -Read-only access to the data in the file. - -=item C<O_WRONLY> - -Write-only access to the data in the file. - -=item C<O_RDWR> - -Both read and write access. - -=back - -If you want to create the file if it does not exist, add C<O_CREAT> to -any of these, as in the example. If you omit C<O_CREAT> and the file -does not already exist, the C<tie> call will fail. - -=item 5. - -The default permissions to use if a new file is created. The actual -permissions will be modified by the user's umask, so you should -probably use 0666 here. (See L<perlfunc/umask>.) - -=back - -=head1 DIAGNOSTICS - -On failure, the C<tie> call returns an undefined value and probably -sets C<$!> to contain the reason the file could not be tied. - -=head2 C<ndbm store returned -1, errno 22, key "..." at ...> - -This warning is emmitted when you try to store a key or a value that -is too long. It means that the change was not recorded in the -database. See BUGS AND WARNINGS below. - -=head1 BUGS AND WARNINGS - -There are a number of limits on the size of the data that you can -store in the NDBM file. The most important is that the length of a -key, plus the length of its associated value, may not exceed 1008 -bytes. - -See L<perlfunc/tie>, L<perldbmfilter>, L<Fcntl> - -=cut diff --git a/contrib/perl5/ext/NDBM_File/NDBM_File.xs b/contrib/perl5/ext/NDBM_File/NDBM_File.xs deleted file mode 100644 index c417eb6..0000000 --- a/contrib/perl5/ext/NDBM_File/NDBM_File.xs +++ /dev/null @@ -1,173 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" -/* If using the DB3 emulation, ENTER is defined both - * by DB3 and Perl. We drop the Perl definition now. - * See also INSTALL section on DB3. - * -- Stanislav Brabec <utx@penguin.cz> */ -#undef ENTER -#include <ndbm.h> - -typedef struct { - DBM * dbp ; - SV * filter_fetch_key ; - SV * filter_store_key ; - SV * filter_fetch_value ; - SV * filter_store_value ; - int filtering ; - } NDBM_File_type; - -typedef NDBM_File_type * NDBM_File ; -typedef datum datum_key ; -typedef datum datum_value ; - -#define ckFilter(arg,type,name) \ - if (db->type) { \ - SV * save_defsv ; \ - /* printf("filtering %s\n", name) ;*/ \ - if (db->filtering) \ - croak("recursion detected in %s", name) ; \ - db->filtering = TRUE ; \ - save_defsv = newSVsv(DEFSV) ; \ - sv_setsv(DEFSV, arg) ; \ - PUSHMARK(sp) ; \ - (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); \ - sv_setsv(arg, DEFSV) ; \ - sv_setsv(DEFSV, save_defsv) ; \ - SvREFCNT_dec(save_defsv) ; \ - db->filtering = FALSE ; \ - /*printf("end of filtering %s\n", name) ;*/ \ - } - - -MODULE = NDBM_File PACKAGE = NDBM_File PREFIX = ndbm_ - -NDBM_File -ndbm_TIEHASH(dbtype, filename, flags, mode) - char * dbtype - char * filename - int flags - int mode - CODE: - { - DBM * dbp ; - - RETVAL = NULL ; - if (dbp = dbm_open(filename, flags, mode)) { - RETVAL = (NDBM_File)safemalloc(sizeof(NDBM_File_type)) ; - Zero(RETVAL, 1, NDBM_File_type) ; - RETVAL->dbp = dbp ; - } - - } - OUTPUT: - RETVAL - -void -ndbm_DESTROY(db) - NDBM_File db - CODE: - dbm_close(db->dbp); - safefree(db); - -#define ndbm_FETCH(db,key) dbm_fetch(db->dbp,key) -datum_value -ndbm_FETCH(db, key) - NDBM_File db - datum_key key - -#define ndbm_STORE(db,key,value,flags) dbm_store(db->dbp,key,value,flags) -int -ndbm_STORE(db, key, value, flags = DBM_REPLACE) - NDBM_File db - datum_key key - datum_value value - int flags - CLEANUP: - if (RETVAL) { - if (RETVAL < 0 && errno == EPERM) - croak("No write permission to ndbm file"); - croak("ndbm store returned %d, errno %d, key \"%s\"", - RETVAL,errno,key.dptr); - dbm_clearerr(db->dbp); - } - -#define ndbm_DELETE(db,key) dbm_delete(db->dbp,key) -int -ndbm_DELETE(db, key) - NDBM_File db - datum_key key - -#define ndbm_FIRSTKEY(db) dbm_firstkey(db->dbp) -datum_key -ndbm_FIRSTKEY(db) - NDBM_File db - -#define ndbm_NEXTKEY(db,key) dbm_nextkey(db->dbp) -datum_key -ndbm_NEXTKEY(db, key) - NDBM_File db - datum_key key - -#define ndbm_error(db) dbm_error(db->dbp) -int -ndbm_error(db) - NDBM_File db - -#define ndbm_clearerr(db) dbm_clearerr(db->dbp) -void -ndbm_clearerr(db) - NDBM_File db - - -#define setFilter(type) \ - { \ - if (db->type) \ - RETVAL = sv_mortalcopy(db->type) ; \ - ST(0) = RETVAL ; \ - if (db->type && (code == &PL_sv_undef)) { \ - SvREFCNT_dec(db->type) ; \ - db->type = NULL ; \ - } \ - else if (code) { \ - if (db->type) \ - sv_setsv(db->type, code) ; \ - else \ - db->type = newSVsv(code) ; \ - } \ - } - - - -SV * -filter_fetch_key(db, code) - NDBM_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_fetch_key) ; - -SV * -filter_store_key(db, code) - NDBM_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_store_key) ; - -SV * -filter_fetch_value(db, code) - NDBM_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_fetch_value) ; - -SV * -filter_store_value(db, code) - NDBM_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_store_value) ; - diff --git a/contrib/perl5/ext/NDBM_File/hints/cygwin.pl b/contrib/perl5/ext/NDBM_File/hints/cygwin.pl deleted file mode 100644 index 0a4b762..0000000 --- a/contrib/perl5/ext/NDBM_File/hints/cygwin.pl +++ /dev/null @@ -1,2 +0,0 @@ -# uses GDBM ndbm compatibility feature -$self->{LIBS} = ['-lgdbm']; diff --git a/contrib/perl5/ext/NDBM_File/hints/dec_osf.pl b/contrib/perl5/ext/NDBM_File/hints/dec_osf.pl deleted file mode 100644 index e96d907..0000000 --- a/contrib/perl5/ext/NDBM_File/hints/dec_osf.pl +++ /dev/null @@ -1,2 +0,0 @@ -# Spider Boardman <spider@Orb.Nashua.NH.US> -$self->{LIBS} = ['']; diff --git a/contrib/perl5/ext/NDBM_File/hints/dynixptx.pl b/contrib/perl5/ext/NDBM_File/hints/dynixptx.pl deleted file mode 100644 index d402c17..0000000 --- a/contrib/perl5/ext/NDBM_File/hints/dynixptx.pl +++ /dev/null @@ -1,3 +0,0 @@ -# On DYNIX/ptx 4.0 (v4.1.3), ndbm is actually contained in the -# libc library, and must be explicitly linked against -lc when compiling. -$self->{LIBS} = ['-lc']; diff --git a/contrib/perl5/ext/NDBM_File/hints/sco.pl b/contrib/perl5/ext/NDBM_File/hints/sco.pl deleted file mode 100644 index f551578..0000000 --- a/contrib/perl5/ext/NDBM_File/hints/sco.pl +++ /dev/null @@ -1,4 +0,0 @@ -# SCO ODT 3.2v4.2 has a -ldbm library that is missing dbmclose. -# This system should have a complete library installed as -ldbm.nfs which -# should be used instead (Probably need the networking product add-on) -$self->{LIBS} = ['-lndbm',-e "/usr/lib/libdbm.nfs.a"?'-ldbm.nfs':'-ldbm']; diff --git a/contrib/perl5/ext/NDBM_File/hints/solaris.pl b/contrib/perl5/ext/NDBM_File/hints/solaris.pl deleted file mode 100644 index 11310a9..0000000 --- a/contrib/perl5/ext/NDBM_File/hints/solaris.pl +++ /dev/null @@ -1,3 +0,0 @@ -# -lucb has been reported to be fatal for perl5 on Solaris. -# Thus we deliberately don't include it here. -$self->{LIBS} = ["-lndbm", "-ldbm"]; diff --git a/contrib/perl5/ext/NDBM_File/hints/svr4.pl b/contrib/perl5/ext/NDBM_File/hints/svr4.pl deleted file mode 100644 index 3285d9a..0000000 --- a/contrib/perl5/ext/NDBM_File/hints/svr4.pl +++ /dev/null @@ -1,4 +0,0 @@ -# Some SVR4 systems may need to link against routines in -lucb for -# odbm. Some may also need to link against -lc to pick up things like -# ecvt. -$self->{LIBS} = ['-ldbm -lucb -lc']; diff --git a/contrib/perl5/ext/NDBM_File/typemap b/contrib/perl5/ext/NDBM_File/typemap deleted file mode 100644 index 40b95f2..0000000 --- a/contrib/perl5/ext/NDBM_File/typemap +++ /dev/null @@ -1,43 +0,0 @@ -# -#################################### DBM SECTION -# - -datum_key T_DATUM_K -datum_value T_DATUM_V -gdatum T_GDATUM -NDBM_File T_PTROBJ -GDBM_File T_PTROBJ -SDBM_File T_PTROBJ -ODBM_File T_PTROBJ -DB_File T_PTROBJ -DBZ_File T_PTROBJ -FATALFUNC T_OPAQUEPTR - -INPUT -T_DATUM_K - ckFilter($arg, filter_store_key, \"filter_store_key\"); - $var.dptr = SvPV($arg, PL_na); - $var.dsize = (int)PL_na; -T_DATUM_V - ckFilter($arg, filter_store_value, \"filter_store_value\"); - if (SvOK($arg)) { - $var.dptr = SvPV($arg, PL_na); - $var.dsize = (int)PL_na; - } - else { - $var.dptr = \"\"; - $var.dsize = 0; - } -T_GDATUM - UNIMPLEMENTED -OUTPUT -T_DATUM_K - sv_setpvn($arg, $var.dptr, $var.dsize); - ckFilter($arg, filter_fetch_key,\"filter_fetch_key\"); -T_DATUM_V - sv_setpvn($arg, $var.dptr, $var.dsize); - ckFilter($arg, filter_fetch_value,\"filter_fetch_value\"); -T_GDATUM - sv_usepvn($arg, $var.dptr, $var.dsize); -T_PTROBJ - sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/contrib/perl5/ext/ODBM_File/Makefile.PL b/contrib/perl5/ext/ODBM_File/Makefile.PL deleted file mode 100644 index 2732a32..0000000 --- a/contrib/perl5/ext/ODBM_File/Makefile.PL +++ /dev/null @@ -1,8 +0,0 @@ -use ExtUtils::MakeMaker; -WriteMakefile( - NAME => 'ODBM_File', - LIBS => ["-ldbm -lucb"], - MAN3PODS => {}, # Pods will be built by installman. - XSPROTOARG => '-noprototypes', # XXX remove later? - VERSION_FROM => 'ODBM_File.pm', -); diff --git a/contrib/perl5/ext/ODBM_File/ODBM_File.pm b/contrib/perl5/ext/ODBM_File/ODBM_File.pm deleted file mode 100644 index 9e8e008..0000000 --- a/contrib/perl5/ext/ODBM_File/ODBM_File.pm +++ /dev/null @@ -1,113 +0,0 @@ -package ODBM_File; - -use strict; -use warnings; - -require Tie::Hash; -use XSLoader (); - -our @ISA = qw(Tie::Hash); -our $VERSION = "1.03"; - -XSLoader::load 'ODBM_File', $VERSION; - -1; - -__END__ - -=head1 NAME - -ODBM_File - Tied access to odbm files - -=head1 SYNOPSIS - - use Fcntl; # For O_RDWR, O_CREAT, etc. - use ODBM_File; - - # Now read and change the hash - $h{newkey} = newvalue; - print $h{oldkey}; - ... - - untie %h; - -=head1 DESCRIPTION - -C<ODBM_File> establishes a connection between a Perl hash variable and -a file in ODBM_File format;. You can manipulate the data in the file -just as if it were in a Perl hash, but when your program exits, the -data will remain in the file, to be used the next time your program -runs. - -Use C<ODBM_File> with the Perl built-in C<tie> function to establish -the connection between the variable and the file. The arguments to -C<tie> should be: - -=over 4 - -=item 1. - -The hash variable you want to tie. - -=item 2. - -The string C<"ODBM_File">. (Ths tells Perl to use the C<ODBM_File> -package to perform the functions of the hash.) - -=item 3. - -The name of the file you want to tie to the hash. - -=item 4. - -Flags. Use one of: - -=over 2 - -=item C<O_RDONLY> - -Read-only access to the data in the file. - -=item C<O_WRONLY> - -Write-only access to the data in the file. - -=item C<O_RDWR> - -Both read and write access. - -=back - -If you want to create the file if it does not exist, add C<O_CREAT> to -any of these, as in the example. If you omit C<O_CREAT> and the file -does not already exist, the C<tie> call will fail. - -=item 5. - -The default permissions to use if a new file is created. The actual -permissions will be modified by the user's umask, so you should -probably use 0666 here. (See L<perlfunc/umask>.) - -=back - -=head1 DIAGNOSTICS - -On failure, the C<tie> call returns an undefined value and probably -sets C<$!> to contain the reason the file could not be tied. - -=head2 C<odbm store returned -1, errno 22, key "..." at ...> - -This warning is emmitted when you try to store a key or a value that -is too long. It means that the change was not recorded in the -database. See BUGS AND WARNINGS below. - -=head1 BUGS AND WARNINGS - -There are a number of limits on the size of the data that you can -store in the ODBM file. The most important is that the length of a -key, plus the length of its associated value, may not exceed 1008 -bytes. - -See L<perlfunc/tie>, L<perldbmfilter>, L<Fcntl> - -=cut diff --git a/contrib/perl5/ext/ODBM_File/ODBM_File.xs b/contrib/perl5/ext/ODBM_File/ODBM_File.xs deleted file mode 100644 index 27174ef..0000000 --- a/contrib/perl5/ext/ODBM_File/ODBM_File.xs +++ /dev/null @@ -1,207 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#ifdef I_DBM -/* If using the DB3 emulation, ENTER is defined both - * by DB3 and Perl. We drop the Perl definition now. - * See also INSTALL section on DB3. - * -- Stanislav Brabec <utx@penguin.cz> */ -# undef ENTER -# include <dbm.h> -#else -# ifdef I_RPCSVC_DBM -# include <rpcsvc/dbm.h> -# endif -#endif - -#ifdef DBM_BUG_DUPLICATE_FREE -/* - * DBM on at least Ultrix and HPUX call dbmclose() from dbminit(), - * resulting in duplicate free() because dbmclose() does *not* - * check if it has already been called for this DBM. - * If some malloc/free calls have been done between dbmclose() and - * the next dbminit(), the memory might be used for something else when - * it is freed. - * Verified to work on ultrix4.3. Probably will work on HP/UX. - * Set DBM_BUG_DUPLICATE_FREE in the extension hint file. - */ -/* Close the previous dbm, and fail to open a new dbm */ -#define dbmclose() ((void) dbminit("/tmp/x/y/z/z/y")) -#endif - -#include <fcntl.h> - -typedef struct { - void * dbp ; - SV * filter_fetch_key ; - SV * filter_store_key ; - SV * filter_fetch_value ; - SV * filter_store_value ; - int filtering ; - } ODBM_File_type; - -typedef ODBM_File_type * ODBM_File ; -typedef datum datum_key ; -typedef datum datum_value ; - -#define ckFilter(arg,type,name) \ - if (db->type) { \ - SV * save_defsv ; \ - /* printf("filtering %s\n", name) ;*/ \ - if (db->filtering) \ - croak("recursion detected in %s", name) ; \ - db->filtering = TRUE ; \ - save_defsv = newSVsv(DEFSV) ; \ - sv_setsv(DEFSV, arg) ; \ - PUSHMARK(sp) ; \ - (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); \ - sv_setsv(arg, DEFSV) ; \ - sv_setsv(DEFSV, save_defsv) ; \ - SvREFCNT_dec(save_defsv) ; \ - db->filtering = FALSE ; \ - /*printf("end of filtering %s\n", name) ;*/ \ - } - - -#define odbm_FETCH(db,key) fetch(key) -#define odbm_STORE(db,key,value,flags) store(key,value) -#define odbm_DELETE(db,key) delete(key) -#define odbm_FIRSTKEY(db) firstkey() -#define odbm_NEXTKEY(db,key) nextkey(key) - -static int dbmrefcnt; - -#ifndef DBM_REPLACE -#define DBM_REPLACE 0 -#endif - -MODULE = ODBM_File PACKAGE = ODBM_File PREFIX = odbm_ - -ODBM_File -odbm_TIEHASH(dbtype, filename, flags, mode) - char * dbtype - char * filename - int flags - int mode - CODE: - { - char *tmpbuf; - void * dbp ; - if (dbmrefcnt++) - croak("Old dbm can only open one database"); - New(0, tmpbuf, strlen(filename) + 5, char); - SAVEFREEPV(tmpbuf); - sprintf(tmpbuf,"%s.dir",filename); - if (stat(tmpbuf, &PL_statbuf) < 0) { - if (flags & O_CREAT) { - if (mode < 0 || close(creat(tmpbuf,mode)) < 0) - croak("ODBM_File: Can't create %s", filename); - sprintf(tmpbuf,"%s.pag",filename); - if (close(creat(tmpbuf,mode)) < 0) - croak("ODBM_File: Can't create %s", filename); - } - else - croak("ODBM_FILE: Can't open %s", filename); - } - dbp = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0); - RETVAL = (ODBM_File)safemalloc(sizeof(ODBM_File_type)) ; - Zero(RETVAL, 1, ODBM_File_type) ; - RETVAL->dbp = dbp ; - ST(0) = sv_mortalcopy(&PL_sv_undef); - sv_setptrobj(ST(0), RETVAL, dbtype); - } - -void -DESTROY(db) - ODBM_File db - CODE: - dbmrefcnt--; - dbmclose(); - safefree(db); - -datum_value -odbm_FETCH(db, key) - ODBM_File db - datum_key key - -int -odbm_STORE(db, key, value, flags = DBM_REPLACE) - ODBM_File db - datum_key key - datum_value value - int flags - CLEANUP: - if (RETVAL) { - if (RETVAL < 0 && errno == EPERM) - croak("No write permission to odbm file"); - croak("odbm store returned %d, errno %d, key \"%s\"", - RETVAL,errno,key.dptr); - } - -int -odbm_DELETE(db, key) - ODBM_File db - datum_key key - -datum_key -odbm_FIRSTKEY(db) - ODBM_File db - -datum_key -odbm_NEXTKEY(db, key) - ODBM_File db - datum_key key - - -#define setFilter(type) \ - { \ - if (db->type) \ - RETVAL = sv_mortalcopy(db->type) ; \ - ST(0) = RETVAL ; \ - if (db->type && (code == &PL_sv_undef)) { \ - SvREFCNT_dec(db->type) ; \ - db->type = Nullsv ; \ - } \ - else if (code) { \ - if (db->type) \ - sv_setsv(db->type, code) ; \ - else \ - db->type = newSVsv(code) ; \ - } \ - } - - - -SV * -filter_fetch_key(db, code) - ODBM_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_fetch_key) ; - -SV * -filter_store_key(db, code) - ODBM_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_store_key) ; - -SV * -filter_fetch_value(db, code) - ODBM_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_fetch_value) ; - -SV * -filter_store_value(db, code) - ODBM_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_store_value) ; - diff --git a/contrib/perl5/ext/ODBM_File/hints/cygwin.pl b/contrib/perl5/ext/ODBM_File/hints/cygwin.pl deleted file mode 100644 index a0d33c8..0000000 --- a/contrib/perl5/ext/ODBM_File/hints/cygwin.pl +++ /dev/null @@ -1,2 +0,0 @@ -# uses GDBM dbm compatibility feature -$self->{LIBS} = ['-lgdbm']; diff --git a/contrib/perl5/ext/ODBM_File/hints/dec_osf.pl b/contrib/perl5/ext/ODBM_File/hints/dec_osf.pl deleted file mode 100644 index febb7cd..0000000 --- a/contrib/perl5/ext/ODBM_File/hints/dec_osf.pl +++ /dev/null @@ -1,9 +0,0 @@ -# The -hidden option causes compilation to fail on Digital Unix. -# Andy Dougherty <doughera@lafcol.lafayette.edu> -# Sat Jan 13 16:29:52 EST 1996 -$self->{LDDLFLAGS} = $Config{lddlflags}; -$self->{LDDLFLAGS} =~ s/-hidden//; -# As long as we're hinting, note the known location of the dbm routines. -# Spider Boardman <spider@Orb.Nashua.NH.US> -# Fri Feb 21 14:50:31 EST 1997 -$self->{LIBS} = ['-ldbm']; diff --git a/contrib/perl5/ext/ODBM_File/hints/hpux.pl b/contrib/perl5/ext/ODBM_File/hints/hpux.pl deleted file mode 100644 index 31f9d24..0000000 --- a/contrib/perl5/ext/ODBM_File/hints/hpux.pl +++ /dev/null @@ -1,4 +0,0 @@ -# Try to work around "bad free" messages. See note in ODBM_File.xs. -# Andy Dougherty <doughera@lafcol.lafayette.edu> -# Sun Sep 8 12:57:52 EDT 1996 -$self->{CCFLAGS} = $Config{ccflags} . ' -DDBM_BUG_DUPLICATE_FREE' ; diff --git a/contrib/perl5/ext/ODBM_File/hints/sco.pl b/contrib/perl5/ext/ODBM_File/hints/sco.pl deleted file mode 100644 index f551578..0000000 --- a/contrib/perl5/ext/ODBM_File/hints/sco.pl +++ /dev/null @@ -1,4 +0,0 @@ -# SCO ODT 3.2v4.2 has a -ldbm library that is missing dbmclose. -# This system should have a complete library installed as -ldbm.nfs which -# should be used instead (Probably need the networking product add-on) -$self->{LIBS} = ['-lndbm',-e "/usr/lib/libdbm.nfs.a"?'-ldbm.nfs':'-ldbm']; diff --git a/contrib/perl5/ext/ODBM_File/hints/solaris.pl b/contrib/perl5/ext/ODBM_File/hints/solaris.pl deleted file mode 100644 index ac57393..0000000 --- a/contrib/perl5/ext/ODBM_File/hints/solaris.pl +++ /dev/null @@ -1,3 +0,0 @@ -# -lucb has been reported to be fatal for perl5 on Solaris. -# Thus we deliberately don't include it here. -$self->{LIBS} = ['-ldbm']; diff --git a/contrib/perl5/ext/ODBM_File/hints/svr4.pl b/contrib/perl5/ext/ODBM_File/hints/svr4.pl deleted file mode 100644 index 3285d9a..0000000 --- a/contrib/perl5/ext/ODBM_File/hints/svr4.pl +++ /dev/null @@ -1,4 +0,0 @@ -# Some SVR4 systems may need to link against routines in -lucb for -# odbm. Some may also need to link against -lc to pick up things like -# ecvt. -$self->{LIBS} = ['-ldbm -lucb -lc']; diff --git a/contrib/perl5/ext/ODBM_File/hints/ultrix.pl b/contrib/perl5/ext/ODBM_File/hints/ultrix.pl deleted file mode 100644 index 31f9d24..0000000 --- a/contrib/perl5/ext/ODBM_File/hints/ultrix.pl +++ /dev/null @@ -1,4 +0,0 @@ -# Try to work around "bad free" messages. See note in ODBM_File.xs. -# Andy Dougherty <doughera@lafcol.lafayette.edu> -# Sun Sep 8 12:57:52 EDT 1996 -$self->{CCFLAGS} = $Config{ccflags} . ' -DDBM_BUG_DUPLICATE_FREE' ; diff --git a/contrib/perl5/ext/ODBM_File/typemap b/contrib/perl5/ext/ODBM_File/typemap deleted file mode 100644 index 096427e..0000000 --- a/contrib/perl5/ext/ODBM_File/typemap +++ /dev/null @@ -1,41 +0,0 @@ -# -#################################### DBM SECTION -# - -datum_key T_DATUM_K -datum_value T_DATUM_V -gdatum T_GDATUM -NDBM_File T_PTROBJ -GDBM_File T_PTROBJ -SDBM_File T_PTROBJ -ODBM_File T_PTROBJ -DB_File T_PTROBJ -DBZ_File T_PTROBJ -FATALFUNC T_OPAQUEPTR - -INPUT -T_DATUM_K - ckFilter($arg, filter_store_key, \"filter_store_key\"); - $var.dptr = SvPV($arg, PL_na); - $var.dsize = (int)PL_na; -T_DATUM_V - ckFilter($arg, filter_store_value, \"filter_store_value\"); - if (SvOK($arg)) { - $var.dptr = SvPV($arg, PL_na); - $var.dsize = (int)PL_na; - } - else { - $var.dptr = \"\"; - $var.dsize = 0; - } -T_GDATUM - UNIMPLEMENTED -OUTPUT -T_DATUM_K - sv_setpvn($arg, $var.dptr, $var.dsize); - ckFilter($arg, filter_fetch_key,\"filter_fetch_key\"); -T_DATUM_V - sv_setpvn($arg, $var.dptr, $var.dsize); - ckFilter($arg, filter_fetch_value,\"filter_fetch_value\"); -T_GDATUM - sv_usepvn($arg, $var.dptr, $var.dsize); diff --git a/contrib/perl5/ext/Opcode/Makefile.PL b/contrib/perl5/ext/Opcode/Makefile.PL deleted file mode 100644 index d7e781f..0000000 --- a/contrib/perl5/ext/Opcode/Makefile.PL +++ /dev/null @@ -1,7 +0,0 @@ -use ExtUtils::MakeMaker; -WriteMakefile( - NAME => 'Opcode', - MAN3PODS => {}, - VERSION_FROM => 'Opcode.pm', - XS_VERSION => '1.03' -); diff --git a/contrib/perl5/ext/Opcode/Opcode.pm b/contrib/perl5/ext/Opcode/Opcode.pm deleted file mode 100644 index 841120c..0000000 --- a/contrib/perl5/ext/Opcode/Opcode.pm +++ /dev/null @@ -1,575 +0,0 @@ -package Opcode; - -require 5.005_64; - -our($VERSION, $XS_VERSION, @ISA, @EXPORT_OK); - -$VERSION = "1.04"; -$XS_VERSION = "1.03"; - -use strict; -use Carp; -use Exporter (); -use XSLoader (); -@ISA = qw(Exporter); - -BEGIN { - @EXPORT_OK = qw( - opset ops_to_opset - opset_to_ops opset_to_hex invert_opset - empty_opset full_opset - opdesc opcodes opmask define_optag - opmask_add verify_opset opdump - ); -} - -sub opset (;@); -sub opset_to_hex ($); -sub opdump (;$); -use subs @EXPORT_OK; - -XSLoader::load 'Opcode', $XS_VERSION; - -_init_optags(); - -sub ops_to_opset { opset @_ } # alias for old name - -sub opset_to_hex ($) { - return "(invalid opset)" unless verify_opset($_[0]); - unpack("h*",$_[0]); -} - -sub opdump (;$) { - my $pat = shift; - # handy utility: perl -MOpcode=opdump -e 'opdump File' - foreach(opset_to_ops(full_opset)) { - my $op = sprintf " %12s %s\n", $_, opdesc($_); - next if defined $pat and $op !~ m/$pat/i; - print $op; - } -} - - - -sub _init_optags { - my(%all, %seen); - @all{opset_to_ops(full_opset)} = (); # keys only - - local($_); - local($/) = "\n=cut"; # skip to optags definition section - <DATA>; - $/ = "\n="; # now read in 'pod section' chunks - while(<DATA>) { - next unless m/^item\s+(:\w+)/; - my $tag = $1; - - # Split into lines, keep only indented lines - my @lines = grep { m/^\s/ } split(/\n/); - foreach (@lines) { s/--.*// } # delete comments - my @ops = map { split ' ' } @lines; # get op words - - foreach(@ops) { - warn "$tag - $_ already tagged in $seen{$_}\n" if $seen{$_}; - $seen{$_} = $tag; - delete $all{$_}; - } - # opset will croak on invalid names - define_optag($tag, opset(@ops)); - } - close(DATA); - warn "Untagged opnames: ".join(' ',keys %all)."\n" if %all; -} - - -1; - -__DATA__ - -=head1 NAME - -Opcode - Disable named opcodes when compiling perl code - -=head1 SYNOPSIS - - use Opcode; - - -=head1 DESCRIPTION - -Perl code is always compiled into an internal format before execution. - -Evaluating perl code (e.g. via "eval" or "do 'file'") causes -the code to be compiled into an internal format and then, -provided there was no error in the compilation, executed. -The internal format is based on many distinct I<opcodes>. - -By default no opmask is in effect and any code can be compiled. - -The Opcode module allow you to define an I<operator mask> to be in -effect when perl I<next> compiles any code. Attempting to compile code -which contains a masked opcode will cause the compilation to fail -with an error. The code will not be executed. - -=head1 NOTE - -The Opcode module is not usually used directly. See the ops pragma and -Safe modules for more typical uses. - -=head1 WARNING - -The authors make B<no warranty>, implied or otherwise, about the -suitability of this software for safety or security purposes. - -The authors shall not in any case be liable for special, incidental, -consequential, indirect or other similar damages arising from the use -of this software. - -Your mileage will vary. If in any doubt B<do not use it>. - - -=head1 Operator Names and Operator Lists - -The canonical list of operator names is the contents of the array -PL_op_name defined and initialised in file F<opcode.h> of the Perl -source distribution (and installed into the perl library). - -Each operator has both a terse name (its opname) and a more verbose or -recognisable descriptive name. The opdesc function can be used to -return a list of descriptions for a list of operators. - -Many of the functions and methods listed below take a list of -operators as parameters. Most operator lists can be made up of several -types of element. Each element can be one of - -=over 8 - -=item an operator name (opname) - -Operator names are typically small lowercase words like enterloop, -leaveloop, last, next, redo etc. Sometimes they are rather cryptic -like gv2cv, i_ncmp and ftsvtx. - -=item an operator tag name (optag) - -Operator tags can be used to refer to groups (or sets) of operators. -Tag names always begin with a colon. The Opcode module defines several -optags and the user can define others using the define_optag function. - -=item a negated opname or optag - -An opname or optag can be prefixed with an exclamation mark, e.g., !mkdir. -Negating an opname or optag means remove the corresponding ops from the -accumulated set of ops at that point. - -=item an operator set (opset) - -An I<opset> as a binary string of approximately 44 bytes which holds a -set or zero or more operators. - -The opset and opset_to_ops functions can be used to convert from -a list of operators to an opset and I<vice versa>. - -Wherever a list of operators can be given you can use one or more opsets. -See also Manipulating Opsets below. - -=back - - -=head1 Opcode Functions - -The Opcode package contains functions for manipulating operator names -tags and sets. All are available for export by the package. - -=over 8 - -=item opcodes - -In a scalar context opcodes returns the number of opcodes in this -version of perl (around 350 for perl-5.7.0). - -In a list context it returns a list of all the operator names. -(Not yet implemented, use @names = opset_to_ops(full_opset).) - -=item opset (OP, ...) - -Returns an opset containing the listed operators. - -=item opset_to_ops (OPSET) - -Returns a list of operator names corresponding to those operators in -the set. - -=item opset_to_hex (OPSET) - -Returns a string representation of an opset. Can be handy for debugging. - -=item full_opset - -Returns an opset which includes all operators. - -=item empty_opset - -Returns an opset which contains no operators. - -=item invert_opset (OPSET) - -Returns an opset which is the inverse set of the one supplied. - -=item verify_opset (OPSET, ...) - -Returns true if the supplied opset looks like a valid opset (is the -right length etc) otherwise it returns false. If an optional second -parameter is true then verify_opset will croak on an invalid opset -instead of returning false. - -Most of the other Opcode functions call verify_opset automatically -and will croak if given an invalid opset. - -=item define_optag (OPTAG, OPSET) - -Define OPTAG as a symbolic name for OPSET. Optag names always start -with a colon C<:>. - -The optag name used must not be defined already (define_optag will -croak if it is already defined). Optag names are global to the perl -process and optag definitions cannot be altered or deleted once -defined. - -It is strongly recommended that applications using Opcode should use a -leading capital letter on their tag names since lowercase names are -reserved for use by the Opcode module. If using Opcode within a module -you should prefix your tags names with the name of your module to -ensure uniqueness and thus avoid clashes with other modules. - -=item opmask_add (OPSET) - -Adds the supplied opset to the current opmask. Note that there is -currently I<no> mechanism for unmasking ops once they have been masked. -This is intentional. - -=item opmask - -Returns an opset corresponding to the current opmask. - -=item opdesc (OP, ...) - -This takes a list of operator names and returns the corresponding list -of operator descriptions. - -=item opdump (PAT) - -Dumps to STDOUT a two column list of op names and op descriptions. -If an optional pattern is given then only lines which match the -(case insensitive) pattern will be output. - -It's designed to be used as a handy command line utility: - - perl -MOpcode=opdump -e opdump - perl -MOpcode=opdump -e 'opdump Eval' - -=back - -=head1 Manipulating Opsets - -Opsets may be manipulated using the perl bit vector operators & (and), | (or), -^ (xor) and ~ (negate/invert). - -However you should never rely on the numerical position of any opcode -within the opset. In other words both sides of a bit vector operator -should be opsets returned from Opcode functions. - -Also, since the number of opcodes in your current version of perl might -not be an exact multiple of eight, there may be unused bits in the last -byte of an upset. This should not cause any problems (Opcode functions -ignore those extra bits) but it does mean that using the ~ operator -will typically not produce the same 'physical' opset 'string' as the -invert_opset function. - - -=head1 TO DO (maybe) - - $bool = opset_eq($opset1, $opset2) true if opsets are logically eqiv - - $yes = opset_can($opset, @ops) true if $opset has all @ops set - - @diff = opset_diff($opset1, $opset2) => ('foo', '!bar', ...) - -=cut - -# the =cut above is used by _init_optags() to get here quickly - -=head1 Predefined Opcode Tags - -=over 5 - -=item :base_core - - null stub scalar pushmark wantarray const defined undef - - rv2sv sassign - - rv2av aassign aelem aelemfast aslice av2arylen - - rv2hv helem hslice each values keys exists delete - - preinc i_preinc predec i_predec postinc i_postinc postdec i_postdec - int hex oct abs pow multiply i_multiply divide i_divide - modulo i_modulo add i_add subtract i_subtract - - left_shift right_shift bit_and bit_xor bit_or negate i_negate - not complement - - lt i_lt gt i_gt le i_le ge i_ge eq i_eq ne i_ne ncmp i_ncmp - slt sgt sle sge seq sne scmp - - substr vec stringify study pos length index rindex ord chr - - ucfirst lcfirst uc lc quotemeta trans chop schop chomp schomp - - match split qr - - list lslice splice push pop shift unshift reverse - - cond_expr flip flop andassign orassign and or xor - - warn die lineseq nextstate scope enter leave setstate - - rv2cv anoncode prototype - - entersub leavesub leavesublv return method method_named -- XXX loops via recursion? - - leaveeval -- needed for Safe to operate, is safe without entereval - -=item :base_mem - -These memory related ops are not included in :base_core because they -can easily be used to implement a resource attack (e.g., consume all -available memory). - - concat repeat join range - - anonlist anonhash - -Note that despite the existance of this optag a memory resource attack -may still be possible using only :base_core ops. - -Disabling these ops is a I<very> heavy handed way to attempt to prevent -a memory resource attack. It's probable that a specific memory limit -mechanism will be added to perl in the near future. - -=item :base_loop - -These loop ops are not included in :base_core because they can easily be -used to implement a resource attack (e.g., consume all available CPU time). - - grepstart grepwhile - mapstart mapwhile - enteriter iter - enterloop leaveloop unstack - last next redo - goto - -=item :base_io - -These ops enable I<filehandle> (rather than filename) based input and -output. These are safe on the assumption that only pre-existing -filehandles are available for use. To create new filehandles other ops -such as open would need to be enabled. - - readline rcatline getc read - - formline enterwrite leavewrite - - print sysread syswrite send recv - - eof tell seek sysseek - - readdir telldir seekdir rewinddir - -=item :base_orig - -These are a hotchpotch of opcodes still waiting to be considered - - gvsv gv gelem - - padsv padav padhv padany - - rv2gv refgen srefgen ref - - bless -- could be used to change ownership of objects (reblessing) - - pushre regcmaybe regcreset regcomp subst substcont - - sprintf prtf -- can core dump - - crypt - - tie untie - - dbmopen dbmclose - sselect select - pipe_op sockpair - - getppid getpgrp setpgrp getpriority setpriority localtime gmtime - - entertry leavetry -- can be used to 'hide' fatal errors - -=item :base_math - -These ops are not included in :base_core because of the risk of them being -used to generate floating point exceptions (which would have to be caught -using a $SIG{FPE} handler). - - atan2 sin cos exp log sqrt - -These ops are not included in :base_core because they have an effect -beyond the scope of the compartment. - - rand srand - -=item :base_thread - -These ops are related to multi-threading. - - lock threadsv - -=item :default - -A handy tag name for a I<reasonable> default set of ops. (The current ops -allowed are unstable while development continues. It will change.) - - :base_core :base_mem :base_loop :base_io :base_orig :base_thread - -If safety matters to you (and why else would you be using the Opcode module?) -then you should not rely on the definition of this, or indeed any other, optag! - - -=item :filesys_read - - stat lstat readlink - - ftatime ftblk ftchr ftctime ftdir fteexec fteowned fteread - ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned - ftrread ftsgid ftsize ftsock ftsuid fttty ftzero ftrwrite ftsvtx - - fttext ftbinary - - fileno - -=item :sys_db - - ghbyname ghbyaddr ghostent shostent ehostent -- hosts - gnbyname gnbyaddr gnetent snetent enetent -- networks - gpbyname gpbynumber gprotoent sprotoent eprotoent -- protocols - gsbyname gsbyport gservent sservent eservent -- services - - gpwnam gpwuid gpwent spwent epwent getlogin -- users - ggrnam ggrgid ggrent sgrent egrent -- groups - -=item :browse - -A handy tag name for a I<reasonable> default set of ops beyond the -:default optag. Like :default (and indeed all the other optags) its -current definition is unstable while development continues. It will change. - -The :browse tag represents the next step beyond :default. It it a -superset of the :default ops and adds :filesys_read the :sys_db. -The intent being that scripts can access more (possibly sensitive) -information about your system but not be able to change it. - - :default :filesys_read :sys_db - -=item :filesys_open - - sysopen open close - umask binmode - - open_dir closedir -- other dir ops are in :base_io - -=item :filesys_write - - link unlink rename symlink truncate - - mkdir rmdir - - utime chmod chown - - fcntl -- not strictly filesys related, but possibly as dangerous? - -=item :subprocess - - backtick system - - fork - - wait waitpid - - glob -- access to Cshell via <`rm *`> - -=item :ownprocess - - exec exit kill - - time tms -- could be used for timing attacks (paranoid?) - -=item :others - -This tag holds groups of assorted specialist opcodes that don't warrant -having optags defined for them. - -SystemV Interprocess Communications: - - msgctl msgget msgrcv msgsnd - - semctl semget semop - - shmctl shmget shmread shmwrite - -=item :still_to_be_decided - - chdir - flock ioctl - - socket getpeername ssockopt - bind connect listen accept shutdown gsockopt getsockname - - sleep alarm -- changes global timer state and signal handling - sort -- assorted problems including core dumps - tied -- can be used to access object implementing a tie - pack unpack -- can be used to create/use memory pointers - - entereval -- can be used to hide code from initial compile - require dofile - - caller -- get info about calling environment and args - - reset - - dbstate -- perl -d version of nextstate(ment) opcode - -=item :dangerous - -This tag is simply a bucket for opcodes that are unlikely to be used via -a tag name but need to be tagged for completness and documentation. - - syscall dump chroot - - -=back - -=head1 SEE ALSO - -ops(3) -- perl pragma interface to Opcode module. - -Safe(3) -- Opcode and namespace limited execution compartments - -=head1 AUTHORS - -Originally designed and implemented by Malcolm Beattie, -mbeattie@sable.ox.ac.uk as part of Safe version 1. - -Split out from Safe module version 1, named opcode tags and other -changes added by Tim Bunce. - -=cut - diff --git a/contrib/perl5/ext/Opcode/Opcode.xs b/contrib/perl5/ext/Opcode/Opcode.xs deleted file mode 100644 index cc4e1f4..0000000 --- a/contrib/perl5/ext/Opcode/Opcode.xs +++ /dev/null @@ -1,482 +0,0 @@ -#define PERL_NO_GET_CONTEXT -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -/* PL_maxo shouldn't differ from MAXO but leave room anyway (see BOOT:) */ -#define OP_MASK_BUF_SIZE (MAXO + 100) - -/* XXX op_named_bits and opset_all are never freed */ -static HV *op_named_bits; /* cache shared for whole process */ -static SV *opset_all; /* mask with all bits set */ -static IV opset_len; /* length of opmasks in bytes */ -static int opcode_debug = 0; - -static SV *new_opset (pTHX_ SV *old_opset); -static int verify_opset (pTHX_ SV *opset, int fatal); -static void set_opset_bits (pTHX_ char *bitmap, SV *bitspec, int on, char *opname); -static void put_op_bitspec (pTHX_ char *optag, STRLEN len, SV *opset); -static SV *get_op_bitspec (pTHX_ char *opname, STRLEN len, int fatal); - - -/* Initialise our private op_named_bits HV. - * It is first loaded with the name and number of each perl operator. - * Then the builtin tags :none and :all are added. - * Opcode.pm loads the standard optags from __DATA__ - * XXX leak-alert: data allocated here is never freed, call this - * at most once - */ - -static void -op_names_init(pTHX) -{ - int i; - STRLEN len; - char **op_names; - char *bitmap; - - op_named_bits = newHV(); - op_names = get_op_names(); - for(i=0; i < PL_maxo; ++i) { - SV *sv; - sv = newSViv(i); - SvREADONLY_on(sv); - hv_store(op_named_bits, op_names[i], strlen(op_names[i]), sv, 0); - } - - put_op_bitspec(aTHX_ ":none",0, sv_2mortal(new_opset(aTHX_ Nullsv))); - - opset_all = new_opset(aTHX_ Nullsv); - bitmap = SvPV(opset_all, len); - i = len-1; /* deal with last byte specially, see below */ - while(i-- > 0) - bitmap[i] = 0xFF; - /* Take care to set the right number of bits in the last byte */ - bitmap[len-1] = (PL_maxo & 0x07) ? ~(0xFF << (PL_maxo & 0x07)) : 0xFF; - put_op_bitspec(aTHX_ ":all",0, opset_all); /* don't mortalise */ -} - - -/* Store a new tag definition. Always a mask. - * The tag must not already be defined. - * SV *mask is copied not referenced. - */ - -static void -put_op_bitspec(pTHX_ char *optag, STRLEN len, SV *mask) -{ - SV **svp; - verify_opset(aTHX_ mask,1); - if (!len) - len = strlen(optag); - svp = hv_fetch(op_named_bits, optag, len, 1); - if (SvOK(*svp)) - croak("Opcode tag \"%s\" already defined", optag); - sv_setsv(*svp, mask); - SvREADONLY_on(*svp); -} - - - -/* Fetch a 'bits' entry for an opname or optag (IV/PV). - * Note that we return the actual entry for speed. - * Always sv_mortalcopy() if returing it to user code. - */ - -static SV * -get_op_bitspec(pTHX_ char *opname, STRLEN len, int fatal) -{ - SV **svp; - if (!len) - len = strlen(opname); - svp = hv_fetch(op_named_bits, opname, len, 0); - if (!svp || !SvOK(*svp)) { - if (!fatal) - return Nullsv; - if (*opname == ':') - croak("Unknown operator tag \"%s\"", opname); - if (*opname == '!') /* XXX here later, or elsewhere? */ - croak("Can't negate operators here (\"%s\")", opname); - if (isALPHA(*opname)) - croak("Unknown operator name \"%s\"", opname); - croak("Unknown operator prefix \"%s\"", opname); - } - return *svp; -} - - - -static SV * -new_opset(pTHX_ SV *old_opset) -{ - SV *opset; - if (old_opset) { - verify_opset(aTHX_ old_opset,1); - opset = newSVsv(old_opset); - } - else { - opset = NEWSV(1156, opset_len); - Zero(SvPVX(opset), opset_len + 1, char); - SvCUR_set(opset, opset_len); - (void)SvPOK_only(opset); - } - /* not mortalised here */ - return opset; -} - - -static int -verify_opset(pTHX_ SV *opset, int fatal) -{ - char *err = Nullch; - if (!SvOK(opset)) err = "undefined"; - else if (!SvPOK(opset)) err = "wrong type"; - else if (SvCUR(opset) != opset_len) err = "wrong size"; - if (err && fatal) { - croak("Invalid opset: %s", err); - } - return !err; -} - - -static void -set_opset_bits(pTHX_ char *bitmap, SV *bitspec, int on, char *opname) -{ - if (SvIOK(bitspec)) { - int myopcode = SvIV(bitspec); - int offset = myopcode >> 3; - int bit = myopcode & 0x07; - if (myopcode >= PL_maxo || myopcode < 0) - croak("panic: opcode \"%s\" value %d is invalid", opname, myopcode); - if (opcode_debug >= 2) - warn("set_opset_bits bit %2d (off=%d, bit=%d) %s %s\n", - myopcode, offset, bit, opname, (on)?"on":"off"); - if (on) - bitmap[offset] |= 1 << bit; - else - bitmap[offset] &= ~(1 << bit); - } - else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) { - - STRLEN len; - char *specbits = SvPV(bitspec, len); - if (opcode_debug >= 2) - warn("set_opset_bits opset %s %s\n", opname, (on)?"on":"off"); - if (on) - while(len-- > 0) bitmap[len] |= specbits[len]; - else - while(len-- > 0) bitmap[len] &= ~specbits[len]; - } - else - croak("panic: invalid bitspec for \"%s\" (type %u)", - opname, (unsigned)SvTYPE(bitspec)); -} - - -static void -opmask_add(pTHX_ SV *opset) /* THE ONLY FUNCTION TO EDIT PL_op_mask ITSELF */ -{ - int i,j; - char *bitmask; - STRLEN len; - int myopcode = 0; - - verify_opset(aTHX_ opset,1); /* croaks on bad opset */ - - if (!PL_op_mask) /* caller must ensure PL_op_mask exists */ - croak("Can't add to uninitialised PL_op_mask"); - - /* OPCODES ALREADY MASKED ARE NEVER UNMASKED. See opmask_addlocal() */ - - bitmask = SvPV(opset, len); - for (i=0; i < opset_len; i++) { - U16 bits = bitmask[i]; - if (!bits) { /* optimise for sparse masks */ - myopcode += 8; - continue; - } - for (j=0; j < 8 && myopcode < PL_maxo; ) - PL_op_mask[myopcode++] |= bits & (1 << j++); - } -} - -static void -opmask_addlocal(pTHX_ SV *opset, char *op_mask_buf) /* Localise PL_op_mask then opmask_add() */ -{ - char *orig_op_mask = PL_op_mask; - SAVEVPTR(PL_op_mask); -#if !defined(PERL_OBJECT) - /* XXX casting to an ordinary function ptr from a member function ptr - * is disallowed by Borland - */ - if (opcode_debug >= 2) - SAVEDESTRUCTOR((void(*)(void*))Perl_warn,"PL_op_mask restored"); -#endif - PL_op_mask = &op_mask_buf[0]; - if (orig_op_mask) - Copy(orig_op_mask, PL_op_mask, PL_maxo, char); - else - Zero(PL_op_mask, PL_maxo, char); - opmask_add(aTHX_ opset); -} - - - -MODULE = Opcode PACKAGE = Opcode - -PROTOTYPES: ENABLE - -BOOT: - assert(PL_maxo < OP_MASK_BUF_SIZE); - opset_len = (PL_maxo + 7) / 8; - if (opcode_debug >= 1) - warn("opset_len %ld\n", (long)opset_len); - op_names_init(aTHX); - - -void -_safe_call_sv(Package, mask, codesv) - char * Package - SV * mask - SV * codesv -PPCODE: - char op_mask_buf[OP_MASK_BUF_SIZE]; - GV *gv; - - ENTER; - - opmask_addlocal(aTHX_ mask, op_mask_buf); - - save_aptr(&PL_endav); - PL_endav = (AV*)sv_2mortal((SV*)newAV()); /* ignore END blocks for now */ - - save_hptr(&PL_defstash); /* save current default stash */ - /* the assignment to global defstash changes our sense of 'main' */ - PL_defstash = gv_stashpv(Package, GV_ADDWARN); /* should exist already */ - save_hptr(&PL_curstash); - PL_curstash = PL_defstash; - - /* defstash must itself contain a main:: so we'll add that now */ - /* take care with the ref counts (was cause of long standing bug) */ - /* XXX I'm still not sure if this is right, GV_ADDWARN should warn! */ - gv = gv_fetchpv("main::", GV_ADDWARN, SVt_PVHV); - sv_free((SV*)GvHV(gv)); - GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash); - - /* %INC must be clean for use/require in compartment */ - save_hash(PL_incgv); - sv_free((SV*)GvHV(PL_incgv)); /* get rid of what save_hash gave us*/ - GvHV(PL_incgv) = (HV*)SvREFCNT_inc(GvHV(gv_HVadd(gv_fetchpv("INC",TRUE,SVt_PVHV)))); - - PUSHMARK(SP); - perl_call_sv(codesv, GIMME|G_EVAL|G_KEEPERR); /* use callers context */ - SPAGAIN; /* for the PUTBACK added by xsubpp */ - LEAVE; - - -int -verify_opset(opset, fatal = 0) - SV *opset - int fatal -CODE: - RETVAL = verify_opset(aTHX_ opset,fatal); -OUTPUT: - RETVAL - -void -invert_opset(opset) - SV *opset -CODE: - { - char *bitmap; - STRLEN len = opset_len; - opset = sv_2mortal(new_opset(aTHX_ opset)); /* verify and clone opset */ - bitmap = SvPVX(opset); - while(len-- > 0) - bitmap[len] = ~bitmap[len]; - /* take care of extra bits beyond PL_maxo in last byte */ - if (PL_maxo & 07) - bitmap[opset_len-1] &= ~(0xFF << (PL_maxo & 0x07)); - } - ST(0) = opset; - - -void -opset_to_ops(opset, desc = 0) - SV *opset - int desc -PPCODE: - { - STRLEN len; - int i, j, myopcode; - char *bitmap = SvPV(opset, len); - char **names = (desc) ? get_op_descs() : get_op_names(); - verify_opset(aTHX_ opset,1); - for (myopcode=0, i=0; i < opset_len; i++) { - U16 bits = bitmap[i]; - for (j=0; j < 8 && myopcode < PL_maxo; j++, myopcode++) { - if ( bits & (1 << j) ) - XPUSHs(sv_2mortal(newSVpv(names[myopcode], 0))); - } - } - } - - -void -opset(...) -CODE: - int i; - SV *bitspec, *opset; - char *bitmap; - STRLEN len, on; - opset = sv_2mortal(new_opset(aTHX_ Nullsv)); - bitmap = SvPVX(opset); - for (i = 0; i < items; i++) { - char *opname; - on = 1; - if (verify_opset(aTHX_ ST(i),0)) { - opname = "(opset)"; - bitspec = ST(i); - } - else { - opname = SvPV(ST(i), len); - if (*opname == '!') { on=0; ++opname;--len; } - bitspec = get_op_bitspec(aTHX_ opname, len, 1); - } - set_opset_bits(aTHX_ bitmap, bitspec, on, opname); - } - ST(0) = opset; - - -#define PERMITING (ix == 0 || ix == 1) -#define ONLY_THESE (ix == 0 || ix == 2) - -void -permit_only(safe, ...) - SV *safe -ALIAS: - permit = 1 - deny_only = 2 - deny = 3 -CODE: - int i, on; - SV *bitspec, *mask; - char *bitmap, *opname; - STRLEN len; - - if (!SvROK(safe) || !SvOBJECT(SvRV(safe)) || SvTYPE(SvRV(safe))!=SVt_PVHV) - croak("Not a Safe object"); - mask = *hv_fetch((HV*)SvRV(safe), "Mask",4, 1); - if (ONLY_THESE) /* *_only = new mask, else edit current */ - sv_setsv(mask, sv_2mortal(new_opset(aTHX_ PERMITING ? opset_all : Nullsv))); - else - verify_opset(aTHX_ mask,1); /* croaks */ - bitmap = SvPVX(mask); - for (i = 1; i < items; i++) { - on = PERMITING ? 0 : 1; /* deny = mask bit on */ - if (verify_opset(aTHX_ ST(i),0)) { /* it's a valid mask */ - opname = "(opset)"; - bitspec = ST(i); - } - else { /* it's an opname/optag */ - opname = SvPV(ST(i), len); - /* invert if op has ! prefix (only one allowed) */ - if (*opname == '!') { on = !on; ++opname; --len; } - bitspec = get_op_bitspec(aTHX_ opname, len, 1); /* croaks */ - } - set_opset_bits(aTHX_ bitmap, bitspec, on, opname); - } - ST(0) = &PL_sv_yes; - - - -void -opdesc(...) -PPCODE: - int i, myopcode; - STRLEN len; - SV **args; - char **op_desc = get_op_descs(); - /* copy args to a scratch area since we may push output values onto */ - /* the stack faster than we read values off it if masks are used. */ - args = (SV**)SvPVX(sv_2mortal(newSVpvn((char*)&ST(0), items*sizeof(SV*)))); - for (i = 0; i < items; i++) { - char *opname = SvPV(args[i], len); - SV *bitspec = get_op_bitspec(aTHX_ opname, len, 1); - if (SvIOK(bitspec)) { - myopcode = SvIV(bitspec); - if (myopcode < 0 || myopcode >= PL_maxo) - croak("panic: opcode %d (%s) out of range",myopcode,opname); - XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0))); - } - else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) { - int b, j; - STRLEN n_a; - char *bitmap = SvPV(bitspec,n_a); - myopcode = 0; - for (b=0; b < opset_len; b++) { - U16 bits = bitmap[b]; - for (j=0; j < 8 && myopcode < PL_maxo; j++, myopcode++) - if (bits & (1 << j)) - XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0))); - } - } - else - croak("panic: invalid bitspec for \"%s\" (type %u)", - opname, (unsigned)SvTYPE(bitspec)); - } - - -void -define_optag(optagsv, mask) - SV *optagsv - SV *mask -CODE: - STRLEN len; - char *optag = SvPV(optagsv, len); - put_op_bitspec(aTHX_ optag, len, mask); /* croaks */ - ST(0) = &PL_sv_yes; - - -void -empty_opset() -CODE: - ST(0) = sv_2mortal(new_opset(aTHX_ Nullsv)); - -void -full_opset() -CODE: - ST(0) = sv_2mortal(new_opset(aTHX_ opset_all)); - -void -opmask_add(opset) - SV *opset -PREINIT: - if (!PL_op_mask) - Newz(0, PL_op_mask, PL_maxo, char); -CODE: - opmask_add(aTHX_ opset); - -void -opcodes() -PPCODE: - if (GIMME == G_ARRAY) { - croak("opcodes in list context not yet implemented"); /* XXX */ - } - else { - XPUSHs(sv_2mortal(newSViv(PL_maxo))); - } - -void -opmask() -CODE: - ST(0) = sv_2mortal(new_opset(aTHX_ Nullsv)); - if (PL_op_mask) { - char *bitmap = SvPVX(ST(0)); - int myopcode; - for(myopcode=0; myopcode < PL_maxo; ++myopcode) { - if (PL_op_mask[myopcode]) - bitmap[myopcode >> 3] |= 1 << (myopcode & 0x07); - } - } - diff --git a/contrib/perl5/ext/Opcode/Safe.pm b/contrib/perl5/ext/Opcode/Safe.pm deleted file mode 100644 index 7e1d6a3..0000000 --- a/contrib/perl5/ext/Opcode/Safe.pm +++ /dev/null @@ -1,558 +0,0 @@ -package Safe; - -use 5.003_11; -use strict; - -our $VERSION = "2.06"; - -use Carp; - -use Opcode 1.01, qw( - opset opset_to_ops opmask_add - empty_opset full_opset invert_opset verify_opset - opdesc opcodes opmask define_optag opset_to_hex -); - -*ops_to_opset = \&opset; # Temporary alias for old Penguins - - -my $default_root = 0; -my $default_share = ['*_']; #, '*main::']; - -sub new { - my($class, $root, $mask) = @_; - my $obj = {}; - bless $obj, $class; - - if (defined($root)) { - croak "Can't use \"$root\" as root name" - if $root =~ /^main\b/ or $root !~ /^\w[:\w]*$/; - $obj->{Root} = $root; - $obj->{Erase} = 0; - } - else { - $obj->{Root} = "Safe::Root".$default_root++; - $obj->{Erase} = 1; - } - - # use permit/deny methods instead till interface issues resolved - # XXX perhaps new Safe 'Root', mask => $mask, foo => bar, ...; - croak "Mask parameter to new no longer supported" if defined $mask; - $obj->permit_only(':default'); - - # We must share $_ and @_ with the compartment or else ops such - # as split, length and so on won't default to $_ properly, nor - # will passing argument to subroutines work (via @_). In fact, - # for reasons I don't completely understand, we need to share - # the whole glob *_ rather than $_ and @_ separately, otherwise - # @_ in non default packages within the compartment don't work. - $obj->share_from('main', $default_share); - return $obj; -} - -sub DESTROY { - my $obj = shift; - $obj->erase('DESTROY') if $obj->{Erase}; -} - -sub erase { - my ($obj, $action) = @_; - my $pkg = $obj->root(); - my ($stem, $leaf); - - no strict 'refs'; - $pkg = "main::$pkg\::"; # expand to full symbol table name - ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; - - # The 'my $foo' is needed! Without it you get an - # 'Attempt to free unreferenced scalar' warning! - my $stem_symtab = *{$stem}{HASH}; - - #warn "erase($pkg) stem=$stem, leaf=$leaf"; - #warn " stem_symtab hash ".scalar(%$stem_symtab)."\n"; - # ", join(', ', %$stem_symtab),"\n"; - -# delete $stem_symtab->{$leaf}; - - my $leaf_glob = $stem_symtab->{$leaf}; - my $leaf_symtab = *{$leaf_glob}{HASH}; -# warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n"; - %$leaf_symtab = (); - #delete $leaf_symtab->{'__ANON__'}; - #delete $leaf_symtab->{'foo'}; - #delete $leaf_symtab->{'main::'}; -# my $foo = undef ${"$stem\::"}{"$leaf\::"}; - - if ($action and $action eq 'DESTROY') { - delete $stem_symtab->{$leaf}; - } else { - $obj->share_from('main', $default_share); - } - 1; -} - - -sub reinit { - my $obj= shift; - $obj->erase; - $obj->share_redo; -} - -sub root { - my $obj = shift; - croak("Safe root method now read-only") if @_; - return $obj->{Root}; -} - - -sub mask { - my $obj = shift; - return $obj->{Mask} unless @_; - $obj->deny_only(@_); -} - -# v1 compatibility methods -sub trap { shift->deny(@_) } -sub untrap { shift->permit(@_) } - -sub deny { - my $obj = shift; - $obj->{Mask} |= opset(@_); -} -sub deny_only { - my $obj = shift; - $obj->{Mask} = opset(@_); -} - -sub permit { - my $obj = shift; - # XXX needs testing - $obj->{Mask} &= invert_opset opset(@_); -} -sub permit_only { - my $obj = shift; - $obj->{Mask} = invert_opset opset(@_); -} - - -sub dump_mask { - my $obj = shift; - print opset_to_hex($obj->{Mask}),"\n"; -} - - - -sub share { - my($obj, @vars) = @_; - $obj->share_from(scalar(caller), \@vars); -} - -sub share_from { - my $obj = shift; - my $pkg = shift; - my $vars = shift; - my $no_record = shift || 0; - my $root = $obj->root(); - croak("vars not an array ref") unless ref $vars eq 'ARRAY'; - no strict 'refs'; - # Check that 'from' package actually exists - croak("Package \"$pkg\" does not exist") - unless keys %{"$pkg\::"}; - my $arg; - foreach $arg (@$vars) { - # catch some $safe->share($var) errors: - croak("'$arg' not a valid symbol table name") - unless $arg =~ /^[\$\@%*&]?\w[\w:]*$/ - or $arg =~ /^\$\W$/; - my ($var, $type); - $type = $1 if ($var = $arg) =~ s/^(\W)//; - # warn "share_from $pkg $type $var"; - *{$root."::$var"} = (!$type) ? \&{$pkg."::$var"} - : ($type eq '&') ? \&{$pkg."::$var"} - : ($type eq '$') ? \${$pkg."::$var"} - : ($type eq '@') ? \@{$pkg."::$var"} - : ($type eq '%') ? \%{$pkg."::$var"} - : ($type eq '*') ? *{$pkg."::$var"} - : croak(qq(Can't share "$type$var" of unknown type)); - } - $obj->share_record($pkg, $vars) unless $no_record or !$vars; -} - -sub share_record { - my $obj = shift; - my $pkg = shift; - my $vars = shift; - my $shares = \%{$obj->{Shares} ||= {}}; - # Record shares using keys of $obj->{Shares}. See reinit. - @{$shares}{@$vars} = ($pkg) x @$vars if @$vars; -} -sub share_redo { - my $obj = shift; - my $shares = \%{$obj->{Shares} ||= {}}; - my($var, $pkg); - while(($var, $pkg) = each %$shares) { - # warn "share_redo $pkg\:: $var"; - $obj->share_from($pkg, [ $var ], 1); - } -} -sub share_forget { - delete shift->{Shares}; -} - -sub varglob { - my ($obj, $var) = @_; - no strict 'refs'; - return *{$obj->root()."::$var"}; -} - - -sub reval { - my ($obj, $expr, $strict) = @_; - my $root = $obj->{Root}; - - # Create anon sub ref in root of compartment. - # Uses a closure (on $expr) to pass in the code to be executed. - # (eval on one line to keep line numbers as expected by caller) - my $evalcode = sprintf('package %s; sub { eval $expr; }', $root); - my $evalsub; - - if ($strict) { use strict; $evalsub = eval $evalcode; } - else { no strict; $evalsub = eval $evalcode; } - - return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub); -} - -sub rdo { - my ($obj, $file) = @_; - my $root = $obj->{Root}; - - my $evalsub = eval - sprintf('package %s; sub { do $file }', $root); - return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub); -} - - -1; - -__END__ - -=head1 NAME - -Safe - Compile and execute code in restricted compartments - -=head1 SYNOPSIS - - use Safe; - - $compartment = new Safe; - - $compartment->permit(qw(time sort :browse)); - - $result = $compartment->reval($unsafe_code); - -=head1 DESCRIPTION - -The Safe extension module allows the creation of compartments -in which perl code can be evaluated. Each compartment has - -=over 8 - -=item a new namespace - -The "root" of the namespace (i.e. "main::") is changed to a -different package and code evaluated in the compartment cannot -refer to variables outside this namespace, even with run-time -glob lookups and other tricks. - -Code which is compiled outside the compartment can choose to place -variables into (or I<share> variables with) the compartment's namespace -and only that data will be visible to code evaluated in the -compartment. - -By default, the only variables shared with compartments are the -"underscore" variables $_ and @_ (and, technically, the less frequently -used %_, the _ filehandle and so on). This is because otherwise perl -operators which default to $_ will not work and neither will the -assignment of arguments to @_ on subroutine entry. - -=item an operator mask - -Each compartment has an associated "operator mask". Recall that -perl code is compiled into an internal format before execution. -Evaluating perl code (e.g. via "eval" or "do 'file'") causes -the code to be compiled into an internal format and then, -provided there was no error in the compilation, executed. -Code evaluated in a compartment compiles subject to the -compartment's operator mask. Attempting to evaluate code in a -compartment which contains a masked operator will cause the -compilation to fail with an error. The code will not be executed. - -The default operator mask for a newly created compartment is -the ':default' optag. - -It is important that you read the Opcode(3) module documentation -for more information, especially for detailed definitions of opnames, -optags and opsets. - -Since it is only at the compilation stage that the operator mask -applies, controlled access to potentially unsafe operations can -be achieved by having a handle to a wrapper subroutine (written -outside the compartment) placed into the compartment. For example, - - $cpt = new Safe; - sub wrapper { - # vet arguments and perform potentially unsafe operations - } - $cpt->share('&wrapper'); - -=back - - -=head1 WARNING - -The authors make B<no warranty>, implied or otherwise, about the -suitability of this software for safety or security purposes. - -The authors shall not in any case be liable for special, incidental, -consequential, indirect or other similar damages arising from the use -of this software. - -Your mileage will vary. If in any doubt B<do not use it>. - - -=head2 RECENT CHANGES - -The interface to the Safe module has changed quite dramatically since -version 1 (as supplied with Perl5.002). Study these pages carefully if -you have code written to use Safe version 1 because you will need to -makes changes. - - -=head2 Methods in class Safe - -To create a new compartment, use - - $cpt = new Safe; - -Optional argument is (NAMESPACE), where NAMESPACE is the root namespace -to use for the compartment (defaults to "Safe::Root0", incremented for -each new compartment). - -Note that version 1.00 of the Safe module supported a second optional -parameter, MASK. That functionality has been withdrawn pending deeper -consideration. Use the permit and deny methods described below. - -The following methods can then be used on the compartment -object returned by the above constructor. The object argument -is implicit in each case. - - -=over 8 - -=item permit (OP, ...) - -Permit the listed operators to be used when compiling code in the -compartment (in I<addition> to any operators already permitted). - -=item permit_only (OP, ...) - -Permit I<only> the listed operators to be used when compiling code in -the compartment (I<no> other operators are permitted). - -=item deny (OP, ...) - -Deny the listed operators from being used when compiling code in the -compartment (other operators may still be permitted). - -=item deny_only (OP, ...) - -Deny I<only> the listed operators from being used when compiling code -in the compartment (I<all> other operators will be permitted). - -=item trap (OP, ...) - -=item untrap (OP, ...) - -The trap and untrap methods are synonyms for deny and permit -respectfully. - -=item share (NAME, ...) - -This shares the variable(s) in the argument list with the compartment. -This is almost identical to exporting variables using the L<Exporter(3)> -module. - -Each NAME must be the B<name> of a variable, typically with the leading -type identifier included. A bareword is treated as a function name. - -Examples of legal names are '$foo' for a scalar, '@foo' for an -array, '%foo' for a hash, '&foo' or 'foo' for a subroutine and '*foo' -for a glob (i.e. all symbol table entries associated with "foo", -including scalar, array, hash, sub and filehandle). - -Each NAME is assumed to be in the calling package. See share_from -for an alternative method (which share uses). - -=item share_from (PACKAGE, ARRAYREF) - -This method is similar to share() but allows you to explicitly name the -package that symbols should be shared from. The symbol names (including -type characters) are supplied as an array reference. - - $safe->share_from('main', [ '$foo', '%bar', 'func' ]); - - -=item varglob (VARNAME) - -This returns a glob reference for the symbol table entry of VARNAME in -the package of the compartment. VARNAME must be the B<name> of a -variable without any leading type marker. For example, - - $cpt = new Safe 'Root'; - $Root::foo = "Hello world"; - # Equivalent version which doesn't need to know $cpt's package name: - ${$cpt->varglob('foo')} = "Hello world"; - - -=item reval (STRING) - -This evaluates STRING as perl code inside the compartment. - -The code can only see the compartment's namespace (as returned by the -B<root> method). The compartment's root package appears to be the -C<main::> package to the code inside the compartment. - -Any attempt by the code in STRING to use an operator which is not permitted -by the compartment will cause an error (at run-time of the main program -but at compile-time for the code in STRING). The error is of the form -"%s trapped by operation mask operation...". - -If an operation is trapped in this way, then the code in STRING will -not be executed. If such a trapped operation occurs or any other -compile-time or return error, then $@ is set to the error message, just -as with an eval(). - -If there is no error, then the method returns the value of the last -expression evaluated, or a return statement may be used, just as with -subroutines and B<eval()>. The context (list or scalar) is determined -by the caller as usual. - -This behaviour differs from the beta distribution of the Safe extension -where earlier versions of perl made it hard to mimic the return -behaviour of the eval() command and the context was always scalar. - -Some points to note: - -If the entereval op is permitted then the code can use eval "..." to -'hide' code which might use denied ops. This is not a major problem -since when the code tries to execute the eval it will fail because the -opmask is still in effect. However this technique would allow clever, -and possibly harmful, code to 'probe' the boundaries of what is -possible. - -Any string eval which is executed by code executing in a compartment, -or by code called from code executing in a compartment, will be eval'd -in the namespace of the compartment. This is potentially a serious -problem. - -Consider a function foo() in package pkg compiled outside a compartment -but shared with it. Assume the compartment has a root package called -'Root'. If foo() contains an eval statement like eval '$foo = 1' then, -normally, $pkg::foo will be set to 1. If foo() is called from the -compartment (by whatever means) then instead of setting $pkg::foo, the -eval will actually set $Root::pkg::foo. - -This can easily be demonstrated by using a module, such as the Socket -module, which uses eval "..." as part of an AUTOLOAD function. You can -'use' the module outside the compartment and share an (autoloaded) -function with the compartment. If an autoload is triggered by code in -the compartment, or by any code anywhere that is called by any means -from the compartment, then the eval in the Socket module's AUTOLOAD -function happens in the namespace of the compartment. Any variables -created or used by the eval'd code are now under the control of -the code in the compartment. - -A similar effect applies to I<all> runtime symbol lookups in code -called from a compartment but not compiled within it. - - - -=item rdo (FILENAME) - -This evaluates the contents of file FILENAME inside the compartment. -See above documentation on the B<reval> method for further details. - -=item root (NAMESPACE) - -This method returns the name of the package that is the root of the -compartment's namespace. - -Note that this behaviour differs from version 1.00 of the Safe module -where the root module could be used to change the namespace. That -functionality has been withdrawn pending deeper consideration. - -=item mask (MASK) - -This is a get-or-set method for the compartment's operator mask. - -With no MASK argument present, it returns the current operator mask of -the compartment. - -With the MASK argument present, it sets the operator mask for the -compartment (equivalent to calling the deny_only method). - -=back - - -=head2 Some Safety Issues - -This section is currently just an outline of some of the things code in -a compartment might do (intentionally or unintentionally) which can -have an effect outside the compartment. - -=over 8 - -=item Memory - -Consuming all (or nearly all) available memory. - -=item CPU - -Causing infinite loops etc. - -=item Snooping - -Copying private information out of your system. Even something as -simple as your user name is of value to others. Much useful information -could be gleaned from your environment variables for example. - -=item Signals - -Causing signals (especially SIGFPE and SIGALARM) to affect your process. - -Setting up a signal handler will need to be carefully considered -and controlled. What mask is in effect when a signal handler -gets called? If a user can get an imported function to get an -exception and call the user's signal handler, does that user's -restricted mask get re-instated before the handler is called? -Does an imported handler get called with its original mask or -the user's one? - -=item State Changes - -Ops such as chdir obviously effect the process as a whole and not just -the code in the compartment. Ops such as rand and srand have a similar -but more subtle effect. - -=back - -=head2 AUTHOR - -Originally designed and implemented by Malcolm Beattie, -mbeattie@sable.ox.ac.uk. - -Reworked to use the Opcode module and other changes added by Tim Bunce -E<lt>F<Tim.Bunce@ig.co.uk>E<gt>. - -=cut - diff --git a/contrib/perl5/ext/Opcode/ops.pm b/contrib/perl5/ext/Opcode/ops.pm deleted file mode 100644 index 9b553b7..0000000 --- a/contrib/perl5/ext/Opcode/ops.pm +++ /dev/null @@ -1,45 +0,0 @@ -package ops; - -use Opcode qw(opmask_add opset invert_opset); - -sub import { - shift; - # Not that unimport is the prefered form since import's don't - # accumulate well owing to the 'only ever add opmask' rule. - # E.g., perl -Mops=:set1 -Mops=:setb is unlikely to do as expected. - opmask_add(invert_opset opset(@_)) if @_; -} - -sub unimport { - shift; - opmask_add(opset(@_)) if @_; -} - -1; - -__END__ - -=head1 NAME - -ops - Perl pragma to restrict unsafe operations when compiling - -=head1 SYNOPSIS - - perl -Mops=:default ... # only allow reasonably safe operations - - perl -M-ops=system ... # disable the 'system' opcode - -=head1 DESCRIPTION - -Since the ops pragma currently has an irreversible global effect, it is -only of significant practical use with the C<-M> option on the command line. - -See the L<Opcode> module for information about opcodes, optags, opmasks -and important information about safety. - -=head1 SEE ALSO - -Opcode(3), Safe(3), perlrun(3) - -=cut - diff --git a/contrib/perl5/ext/POSIX/Makefile.PL b/contrib/perl5/ext/POSIX/Makefile.PL deleted file mode 100644 index 5127b4d..0000000 --- a/contrib/perl5/ext/POSIX/Makefile.PL +++ /dev/null @@ -1,14 +0,0 @@ -# $FreeBSD$ -use ExtUtils::MakeMaker; -use Config; -my @libs; -if ($^O ne 'MSWin32') { - @libs = ('LIBS' => ["-lm -lposix -lcposix"]); -} -WriteMakefile( - NAME => 'POSIX', - @libs, - MAN3PODS => {}, # Pods will be built by installman. - XSPROTOARG => '-noprototypes', # XXX remove later? - VERSION_FROM => 'POSIX.pm', -); diff --git a/contrib/perl5/ext/POSIX/POSIX.pm b/contrib/perl5/ext/POSIX/POSIX.pm deleted file mode 100644 index 252e5bb..0000000 --- a/contrib/perl5/ext/POSIX/POSIX.pm +++ /dev/null @@ -1,940 +0,0 @@ -package POSIX; - -our(@ISA, %EXPORT_TAGS, @EXPORT_OK, $AUTOLOAD) = (); - -use AutoLoader; - -use XSLoader (); - -our $VERSION = "1.03" ; - -# Grandfather old foo_h form to new :foo_h form -my $loaded; - -sub import { - load_imports() unless $loaded++; - my $this = shift; - my @list = map { m/^\w+_h$/ ? ":$_" : $_ } @_; - local $Exporter::ExportLevel = 1; - Exporter::import($this,@list); -} - -sub croak { require Carp; goto &Carp::croak } - -XSLoader::load 'POSIX', $VERSION; - -my $EINVAL = constant("EINVAL", 0); -my $EAGAIN = constant("EAGAIN", 0); - -sub AUTOLOAD { - if ($AUTOLOAD =~ /::(_?[a-z])/) { - # require AutoLoader; - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD - } - local $! = 0; - my $constname = $AUTOLOAD; - $constname =~ s/.*:://; - my $val = constant($constname, @_ ? $_[0] : 0); - if ($! == 0) { - *$AUTOLOAD = sub { $val }; - } - elsif ($! == $EAGAIN) { # Not really a constant, so always call. - *$AUTOLOAD = sub { constant($constname, $_[0]) }; - } - elsif ($! == $EINVAL) { - croak "$constname is not a valid POSIX macro"; - } - else { - croak "Your vendor has not defined POSIX macro $constname, used"; - } - - goto &$AUTOLOAD; -} - -sub usage { - my ($mess) = @_; - croak "Usage: POSIX::$mess"; -} - -sub redef { - my ($mess) = @_; - croak "Use method $mess instead"; -} - -sub unimpl { - my ($mess) = @_; - $mess =~ s/xxx//; - croak "Unimplemented: POSIX::$mess"; -} - -############################ -package POSIX::SigAction; - -sub new { - bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3] || 0}, $_[0]; -} - -############################ -package POSIX; # return to package POSIX so AutoSplit is happy -1; -__END__ - -sub assert { - usage "assert(expr)" if @_ != 1; - if (!$_[0]) { - croak "Assertion failed"; - } -} - -sub tolower { - usage "tolower(string)" if @_ != 1; - lc($_[0]); -} - -sub toupper { - usage "toupper(string)" if @_ != 1; - uc($_[0]); -} - -sub closedir { - usage "closedir(dirhandle)" if @_ != 1; - CORE::closedir($_[0]); -} - -sub opendir { - usage "opendir(directory)" if @_ != 1; - my $dirhandle; - CORE::opendir($dirhandle, $_[0]) - ? $dirhandle - : undef; -} - -sub readdir { - usage "readdir(dirhandle)" if @_ != 1; - CORE::readdir($_[0]); -} - -sub rewinddir { - usage "rewinddir(dirhandle)" if @_ != 1; - CORE::rewinddir($_[0]); -} - -sub errno { - usage "errno()" if @_ != 0; - $! + 0; -} - -sub creat { - usage "creat(filename, mode)" if @_ != 2; - &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[1]); -} - -sub fcntl { - usage "fcntl(filehandle, cmd, arg)" if @_ != 3; - CORE::fcntl($_[0], $_[1], $_[2]); -} - -sub getgrgid { - usage "getgrgid(gid)" if @_ != 1; - CORE::getgrgid($_[0]); -} - -sub getgrnam { - usage "getgrnam(name)" if @_ != 1; - CORE::getgrnam($_[0]); -} - -sub atan2 { - usage "atan2(x,y)" if @_ != 2; - CORE::atan2($_[0], $_[1]); -} - -sub cos { - usage "cos(x)" if @_ != 1; - CORE::cos($_[0]); -} - -sub exp { - usage "exp(x)" if @_ != 1; - CORE::exp($_[0]); -} - -sub fabs { - usage "fabs(x)" if @_ != 1; - CORE::abs($_[0]); -} - -sub log { - usage "log(x)" if @_ != 1; - CORE::log($_[0]); -} - -sub pow { - usage "pow(x,exponent)" if @_ != 2; - $_[0] ** $_[1]; -} - -sub sin { - usage "sin(x)" if @_ != 1; - CORE::sin($_[0]); -} - -sub sqrt { - usage "sqrt(x)" if @_ != 1; - CORE::sqrt($_[0]); -} - -sub getpwnam { - usage "getpwnam(name)" if @_ != 1; - CORE::getpwnam($_[0]); -} - -sub getpwuid { - usage "getpwuid(uid)" if @_ != 1; - CORE::getpwuid($_[0]); -} - -sub longjmp { - unimpl "longjmp() is C-specific: use die instead"; -} - -sub setjmp { - unimpl "setjmp() is C-specific: use eval {} instead"; -} - -sub siglongjmp { - unimpl "siglongjmp() is C-specific: use die instead"; -} - -sub sigsetjmp { - unimpl "sigsetjmp() is C-specific: use eval {} instead"; -} - -sub kill { - usage "kill(pid, sig)" if @_ != 2; - CORE::kill $_[1], $_[0]; -} - -sub raise { - usage "raise(sig)" if @_ != 1; - CORE::kill $_[0], $$; # Is this good enough? -} - -sub offsetof { - unimpl "offsetof() is C-specific, stopped"; -} - -sub clearerr { - redef "IO::Handle::clearerr()"; -} - -sub fclose { - redef "IO::Handle::close()"; -} - -sub fdopen { - redef "IO::Handle::new_from_fd()"; -} - -sub feof { - redef "IO::Handle::eof()"; -} - -sub fgetc { - redef "IO::Handle::getc()"; -} - -sub fgets { - redef "IO::Handle::gets()"; -} - -sub fileno { - redef "IO::Handle::fileno()"; -} - -sub fopen { - redef "IO::File::open()"; -} - -sub fprintf { - unimpl "fprintf() is C-specific--use printf instead"; -} - -sub fputc { - unimpl "fputc() is C-specific--use print instead"; -} - -sub fputs { - unimpl "fputs() is C-specific--use print instead"; -} - -sub fread { - unimpl "fread() is C-specific--use read instead"; -} - -sub freopen { - unimpl "freopen() is C-specific--use open instead"; -} - -sub fscanf { - unimpl "fscanf() is C-specific--use <> and regular expressions instead"; -} - -sub fseek { - redef "IO::Seekable::seek()"; -} - -sub ferror { - redef "IO::Handle::error()"; -} - -sub fflush { - redef "IO::Handle::flush()"; -} - -sub fgetpos { - redef "IO::Seekable::getpos()"; -} - -sub fsetpos { - redef "IO::Seekable::setpos()"; -} - -sub ftell { - redef "IO::Seekable::tell()"; -} - -sub fwrite { - unimpl "fwrite() is C-specific--use print instead"; -} - -sub getc { - usage "getc(handle)" if @_ != 1; - CORE::getc($_[0]); -} - -sub getchar { - usage "getchar()" if @_ != 0; - CORE::getc(STDIN); -} - -sub gets { - usage "gets()" if @_ != 0; - scalar <STDIN>; -} - -sub perror { - print STDERR "@_: " if @_; - print STDERR $!,"\n"; -} - -sub printf { - usage "printf(pattern, args...)" if @_ < 1; - CORE::printf STDOUT @_; -} - -sub putc { - unimpl "putc() is C-specific--use print instead"; -} - -sub putchar { - unimpl "putchar() is C-specific--use print instead"; -} - -sub puts { - unimpl "puts() is C-specific--use print instead"; -} - -sub remove { - usage "remove(filename)" if @_ != 1; - CORE::unlink($_[0]); -} - -sub rename { - usage "rename(oldfilename, newfilename)" if @_ != 2; - CORE::rename($_[0], $_[1]); -} - -sub rewind { - usage "rewind(filehandle)" if @_ != 1; - CORE::seek($_[0],0,0); -} - -sub scanf { - unimpl "scanf() is C-specific--use <> and regular expressions instead"; -} - -sub sprintf { - usage "sprintf(pattern,args)" if @_ == 0; - CORE::sprintf(shift,@_); -} - -sub sscanf { - unimpl "sscanf() is C-specific--use regular expressions instead"; -} - -sub tmpfile { - redef "IO::File::new_tmpfile()"; -} - -sub ungetc { - redef "IO::Handle::ungetc()"; -} - -sub vfprintf { - unimpl "vfprintf() is C-specific"; -} - -sub vprintf { - unimpl "vprintf() is C-specific"; -} - -sub vsprintf { - unimpl "vsprintf() is C-specific"; -} - -sub abs { - usage "abs(x)" if @_ != 1; - CORE::abs($_[0]); -} - -sub atexit { - unimpl "atexit() is C-specific: use END {} instead"; -} - -sub atof { - unimpl "atof() is C-specific, stopped"; -} - -sub atoi { - unimpl "atoi() is C-specific, stopped"; -} - -sub atol { - unimpl "atol() is C-specific, stopped"; -} - -sub bsearch { - unimpl "bsearch() not supplied"; -} - -sub calloc { - unimpl "calloc() is C-specific, stopped"; -} - -sub div { - unimpl "div() is C-specific, stopped"; -} - -sub exit { - usage "exit(status)" if @_ != 1; - CORE::exit($_[0]); -} - -sub free { - unimpl "free() is C-specific, stopped"; -} - -sub getenv { - usage "getenv(name)" if @_ != 1; - $ENV{$_[0]}; -} - -sub labs { - unimpl "labs() is C-specific, use abs instead"; -} - -sub ldiv { - unimpl "ldiv() is C-specific, use / and int instead"; -} - -sub malloc { - unimpl "malloc() is C-specific, stopped"; -} - -sub qsort { - unimpl "qsort() is C-specific, use sort instead"; -} - -sub rand { - unimpl "rand() is non-portable, use Perl's rand instead"; -} - -sub realloc { - unimpl "realloc() is C-specific, stopped"; -} - -sub srand { - unimpl "srand()"; -} - -sub system { - usage "system(command)" if @_ != 1; - CORE::system($_[0]); -} - -sub memchr { - unimpl "memchr() is C-specific, use index() instead"; -} - -sub memcmp { - unimpl "memcmp() is C-specific, use eq instead"; -} - -sub memcpy { - unimpl "memcpy() is C-specific, use = instead"; -} - -sub memmove { - unimpl "memmove() is C-specific, use = instead"; -} - -sub memset { - unimpl "memset() is C-specific, use x instead"; -} - -sub strcat { - unimpl "strcat() is C-specific, use .= instead"; -} - -sub strchr { - unimpl "strchr() is C-specific, use index() instead"; -} - -sub strcmp { - unimpl "strcmp() is C-specific, use eq instead"; -} - -sub strcpy { - unimpl "strcpy() is C-specific, use = instead"; -} - -sub strcspn { - unimpl "strcspn() is C-specific, use regular expressions instead"; -} - -sub strerror { - usage "strerror(errno)" if @_ != 1; - local $! = $_[0]; - $! . ""; -} - -sub strlen { - unimpl "strlen() is C-specific, use length instead"; -} - -sub strncat { - unimpl "strncat() is C-specific, use .= instead"; -} - -sub strncmp { - unimpl "strncmp() is C-specific, use eq instead"; -} - -sub strncpy { - unimpl "strncpy() is C-specific, use = instead"; -} - -sub strpbrk { - unimpl "strpbrk() is C-specific, stopped"; -} - -sub strrchr { - unimpl "strrchr() is C-specific, use rindex() instead"; -} - -sub strspn { - unimpl "strspn() is C-specific, stopped"; -} - -sub strstr { - usage "strstr(big, little)" if @_ != 2; - CORE::index($_[0], $_[1]); -} - -sub strtok { - unimpl "strtok() is C-specific, stopped"; -} - -sub chmod { - usage "chmod(mode, filename)" if @_ != 2; - CORE::chmod($_[0], $_[1]); -} - -sub fstat { - usage "fstat(fd)" if @_ != 1; - local *TMP; - CORE::open(TMP, "<&$_[0]"); # Gross. - my @l = CORE::stat(TMP); - CORE::close(TMP); - @l; -} - -sub mkdir { - usage "mkdir(directoryname, mode)" if @_ != 2; - CORE::mkdir($_[0], $_[1]); -} - -sub stat { - usage "stat(filename)" if @_ != 1; - CORE::stat($_[0]); -} - -sub umask { - usage "umask(mask)" if @_ != 1; - CORE::umask($_[0]); -} - -sub wait { - usage "wait()" if @_ != 0; - CORE::wait(); -} - -sub waitpid { - usage "waitpid(pid, options)" if @_ != 2; - CORE::waitpid($_[0], $_[1]); -} - -sub gmtime { - usage "gmtime(time)" if @_ != 1; - CORE::gmtime($_[0]); -} - -sub localtime { - usage "localtime(time)" if @_ != 1; - CORE::localtime($_[0]); -} - -sub time { - usage "time()" if @_ != 0; - CORE::time; -} - -sub alarm { - usage "alarm(seconds)" if @_ != 1; - CORE::alarm($_[0]); -} - -sub chdir { - usage "chdir(directory)" if @_ != 1; - CORE::chdir($_[0]); -} - -sub chown { - usage "chown(filename, uid, gid)" if @_ != 3; - CORE::chown($_[0], $_[1], $_[2]); -} - -sub execl { - unimpl "execl() is C-specific, stopped"; -} - -sub execle { - unimpl "execle() is C-specific, stopped"; -} - -sub execlp { - unimpl "execlp() is C-specific, stopped"; -} - -sub execv { - unimpl "execv() is C-specific, stopped"; -} - -sub execve { - unimpl "execve() is C-specific, stopped"; -} - -sub execvp { - unimpl "execvp() is C-specific, stopped"; -} - -sub fork { - usage "fork()" if @_ != 0; - CORE::fork; -} - -sub getcwd -{ - usage "getcwd()" if @_ != 0; - if ($^O eq 'MSWin32') { - # this perhaps applies to everyone else also? - require Cwd; - $cwd = &Cwd::cwd; - } - else { - chop($cwd = `pwd`); - } - $cwd; -} - -sub getegid { - usage "getegid()" if @_ != 0; - $) + 0; -} - -sub geteuid { - usage "geteuid()" if @_ != 0; - $> + 0; -} - -sub getgid { - usage "getgid()" if @_ != 0; - $( + 0; -} - -sub getgroups { - usage "getgroups()" if @_ != 0; - my %seen; - grep(!$seen{$_}++, split(' ', $) )); -} - -sub getlogin { - usage "getlogin()" if @_ != 0; - CORE::getlogin(); -} - -sub getpgrp { - usage "getpgrp()" if @_ != 0; - CORE::getpgrp; -} - -sub getpid { - usage "getpid()" if @_ != 0; - $$; -} - -sub getppid { - usage "getppid()" if @_ != 0; - CORE::getppid; -} - -sub getuid { - usage "getuid()" if @_ != 0; - $<; -} - -sub isatty { - usage "isatty(filehandle)" if @_ != 1; - -t $_[0]; -} - -sub link { - usage "link(oldfilename, newfilename)" if @_ != 2; - CORE::link($_[0], $_[1]); -} - -sub rmdir { - usage "rmdir(directoryname)" if @_ != 1; - CORE::rmdir($_[0]); -} - -sub setbuf { - redef "IO::Handle::setbuf()"; -} - -sub setgid { - usage "setgid(gid)" if @_ != 1; - $( = $_[0]; -} - -sub setuid { - usage "setuid(uid)" if @_ != 1; - $< = $_[0]; -} - -sub setvbuf { - redef "IO::Handle::setvbuf()"; -} - -sub sleep { - usage "sleep(seconds)" if @_ != 1; - CORE::sleep($_[0]); -} - -sub unlink { - usage "unlink(filename)" if @_ != 1; - CORE::unlink($_[0]); -} - -sub utime { - usage "utime(filename, atime, mtime)" if @_ != 3; - CORE::utime($_[1], $_[2], $_[0]); -} - -sub load_imports { -%EXPORT_TAGS = ( - - assert_h => [qw(assert NDEBUG)], - - ctype_h => [qw(isalnum isalpha iscntrl isdigit isgraph islower - isprint ispunct isspace isupper isxdigit tolower toupper)], - - dirent_h => [qw()], - - errno_h => [qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT - EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED - ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT - EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS - EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK - EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH - ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM - ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR - ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM - EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE - ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT - ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY - EUSERS EWOULDBLOCK EXDEV errno)], - - fcntl_h => [qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK - F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK - O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK - O_RDONLY O_RDWR O_TRUNC O_WRONLY - creat - SEEK_CUR SEEK_END SEEK_SET - S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU - S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG S_ISUID - S_IWGRP S_IWOTH S_IWUSR)], - - float_h => [qw(DBL_DIG DBL_EPSILON DBL_MANT_DIG - DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP - DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP - FLT_DIG FLT_EPSILON FLT_MANT_DIG - FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP - FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP - FLT_RADIX FLT_ROUNDS - LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG - LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP - LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP)], - - grp_h => [qw()], - - limits_h => [qw( ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX - INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON - MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX - PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN - SSIZE_MAX STREAM_MAX TZNAME_MAX UCHAR_MAX UINT_MAX - ULONG_MAX USHRT_MAX _POSIX_ARG_MAX _POSIX_CHILD_MAX - _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT - _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_OPEN_MAX - _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SSIZE_MAX - _POSIX_STREAM_MAX _POSIX_TZNAME_MAX)], - - locale_h => [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MONETARY LC_NUMERIC - LC_TIME NULL localeconv setlocale)], - - math_h => [qw(HUGE_VAL acos asin atan ceil cosh fabs floor fmod - frexp ldexp log10 modf pow sinh tan tanh)], - - pwd_h => [qw()], - - setjmp_h => [qw(longjmp setjmp siglongjmp sigsetjmp)], - - signal_h => [qw(SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK - SA_RESETHAND SA_RESTART SA_SIGINFO SIGABRT SIGALRM - SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL - SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN - SIGTTOU SIGUSR1 SIGUSR2 SIG_BLOCK SIG_DFL SIG_ERR - SIG_IGN SIG_SETMASK SIG_UNBLOCK raise sigaction signal - sigpending sigprocmask sigsuspend)], - - stdarg_h => [qw()], - - stddef_h => [qw(NULL offsetof)], - - stdio_h => [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid - L_tmpname NULL SEEK_CUR SEEK_END SEEK_SET - STREAM_MAX TMP_MAX stderr stdin stdout - clearerr fclose fdopen feof ferror fflush fgetc fgetpos - fgets fopen fprintf fputc fputs fread freopen - fscanf fseek fsetpos ftell fwrite getchar gets - perror putc putchar puts remove rewind - scanf setbuf setvbuf sscanf tmpfile tmpnam - ungetc vfprintf vprintf vsprintf)], - - stdlib_h => [qw(EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX NULL RAND_MAX - abort atexit atof atoi atol bsearch calloc div - free getenv labs ldiv malloc mblen mbstowcs mbtowc - qsort realloc strtod strtol strtoul wcstombs wctomb)], - - string_h => [qw(NULL memchr memcmp memcpy memmove memset strcat - strchr strcmp strcoll strcpy strcspn strerror strlen - strncat strncmp strncpy strpbrk strrchr strspn strstr - strtok strxfrm)], - - sys_stat_h => [qw(S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU - S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG - S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR - fstat mkfifo)], - - sys_times_h => [qw()], - - sys_types_h => [qw()], - - sys_utsname_h => [qw(uname)], - - sys_wait_h => [qw(WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED - WNOHANG WSTOPSIG WTERMSIG WUNTRACED)], - - termios_h => [qw( B0 B110 B1200 B134 B150 B1800 B19200 B200 B2400 - B300 B38400 B4800 B50 B600 B75 B9600 BRKINT CLOCAL - CREAD CS5 CS6 CS7 CS8 CSIZE CSTOPB ECHO ECHOE ECHOK - ECHONL HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR - INLCR INPCK ISIG ISTRIP IXOFF IXON NCCS NOFLSH OPOST - PARENB PARMRK PARODD TCIFLUSH TCIOFF TCIOFLUSH TCION - TCOFLUSH TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW - TOSTOP VEOF VEOL VERASE VINTR VKILL VMIN VQUIT VSTART - VSTOP VSUSP VTIME - cfgetispeed cfgetospeed cfsetispeed cfsetospeed tcdrain - tcflow tcflush tcgetattr tcsendbreak tcsetattr )], - - time_h => [qw(CLK_TCK CLOCKS_PER_SEC NULL asctime clock ctime - difftime mktime strftime tzset tzname)], - - unistd_h => [qw(F_OK NULL R_OK SEEK_CUR SEEK_END SEEK_SET - STDERR_FILENO STDIN_FILENO STDOUT_FILENO W_OK X_OK - _PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON - _PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX - _PC_PIPE_BUF _PC_VDISABLE _POSIX_CHOWN_RESTRICTED - _POSIX_JOB_CONTROL _POSIX_NO_TRUNC _POSIX_SAVED_IDS - _POSIX_VDISABLE _POSIX_VERSION _SC_ARG_MAX - _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL - _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_SAVED_IDS - _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION - _exit access ctermid cuserid - dup2 dup execl execle execlp execv execve execvp - fpathconf getcwd getegid geteuid getgid getgroups - getpid getuid isatty lseek pathconf pause setgid setpgid - setsid setuid sysconf tcgetpgrp tcsetpgrp ttyname)], - - utime_h => [qw()], - -); - -# Exporter::export_tags(); -for (values %EXPORT_TAGS) { - push @EXPORT, @$_; -} - -@EXPORT_OK = qw( - closedir opendir readdir rewinddir - fcntl open - getgrgid getgrnam - atan2 cos exp log sin sqrt - getpwnam getpwuid - kill - fileno getc printf rename sprintf - abs exit rand srand system - chmod mkdir stat umask - times - wait waitpid - gmtime localtime time - alarm chdir chown close fork getlogin getppid getpgrp link - pipe read rmdir sleep unlink write - utime - nice -); - -require Exporter; -} diff --git a/contrib/perl5/ext/POSIX/POSIX.pod b/contrib/perl5/ext/POSIX/POSIX.pod deleted file mode 100644 index 4976135..0000000 --- a/contrib/perl5/ext/POSIX/POSIX.pod +++ /dev/null @@ -1,1984 +0,0 @@ -=head1 NAME - -POSIX - Perl interface to IEEE Std 1003.1 - -=head1 SYNOPSIS - - use POSIX; - use POSIX qw(setsid); - use POSIX qw(:errno_h :fcntl_h); - - printf "EINTR is %d\n", EINTR; - - $sess_id = POSIX::setsid(); - - $fd = POSIX::open($path, O_CREAT|O_EXCL|O_WRONLY, 0644); - # note: that's a filedescriptor, *NOT* a filehandle - -=head1 DESCRIPTION - -The POSIX module permits you to access all (or nearly all) the standard -POSIX 1003.1 identifiers. Many of these identifiers have been given Perl-ish -interfaces. Things which are C<#defines> in C, like EINTR or O_NDELAY, are -automatically exported into your namespace. All functions are only exported -if you ask for them explicitly. Most likely people will prefer to use the -fully-qualified function names. - -This document gives a condensed list of the features available in the POSIX -module. Consult your operating system's manpages for general information on -most features. Consult L<perlfunc> for functions which are noted as being -identical to Perl's builtin functions. - -The first section describes POSIX functions from the 1003.1 specification. -The second section describes some classes for signal objects, TTY objects, -and other miscellaneous objects. The remaining sections list various -constants and macros in an organization which roughly follows IEEE Std -1003.1b-1993. - -=head1 NOTE - -The POSIX module is probably the most complex Perl module supplied with -the standard distribution. It incorporates autoloading, namespace games, -and dynamic loading of code that's in Perl, C, or both. It's a great -source of wisdom. - -=head1 CAVEATS - -A few functions are not implemented because they are C specific. If you -attempt to call these, they will print a message telling you that they -aren't implemented, and suggest using the Perl equivalent should one -exist. For example, trying to access the setjmp() call will elicit the -message "setjmp() is C-specific: use eval {} instead". - -Furthermore, some evil vendors will claim 1003.1 compliance, but in fact -are not so: they will not pass the PCTS (POSIX Compliance Test Suites). -For example, one vendor may not define EDEADLK, or the semantics of the -errno values set by open(2) might not be quite right. Perl does not -attempt to verify POSIX compliance. That means you can currently -successfully say "use POSIX", and then later in your program you find -that your vendor has been lax and there's no usable ICANON macro after -all. This could be construed to be a bug. - -=head1 FUNCTIONS - -=over 8 - -=item _exit - -This is identical to the C function C<_exit()>. It exits the program -immediately which means among other things buffered I/O is B<not> flushed. - -=item abort - -This is identical to the C function C<abort()>. It terminates the -process with a C<SIGABRT> signal unless caught by a signal handler or -if the handler does not return normally (it e.g. does a C<longjmp>). - -=item abs - -This is identical to Perl's builtin C<abs()> function, returning -the absolute value of its numerical argument. - -=item access - -Determines the accessibility of a file. - - if( POSIX::access( "/", &POSIX::R_OK ) ){ - print "have read permission\n"; - } - -Returns C<undef> on failure. Note: do not use C<access()> for -security purposes. Between the C<access()> call and the operation -you are preparing for the permissions might change: a classic -I<race condition>. - -=item acos - -This is identical to the C function C<acos()>, returning -the arcus cosine of its numerical argument. See also L<Math::Trig>. - -=item alarm - -This is identical to Perl's builtin C<alarm()> function, -either for arming or disarming the C<SIGARLM> timer. - -=item asctime - -This is identical to the C function C<asctime()>. It returns -a string of the form - - "Fri Jun 2 18:22:13 2000\n\0" - -and it is called thusly - - $asctime = asctime($sec, $min, $hour, $mday, $mon, $year, - $wday, $yday, $isdst); - -The C<$mon> is zero-based: January equals C<0>. The C<$year> is -1900-based: 2001 equals C<101>. The C<$wday>, C<$yday>, and C<$isdst> -default to zero (and the first two are usually ignored anyway). - -=item asin - -This is identical to the C function C<asin()>, returning -the arcus sine of its numerical argument. See also L<Math::Trig>. - -=item assert - -Unimplemented, but you can use L<perlfunc/die> and the L<Carp> module -to achieve similar things. - -=item atan - -This is identical to the C function C<atan()>, returning the -arcus tangent of its numerical argument. See also L<Math::Trig>. - -=item atan2 - -This is identical to Perl's builtin C<atan2()> function, returning -the arcus tangent defined by its two numerical arguments, the I<y> -coordinate and the I<x> coordinate. See also L<Math::Trig>. - -=item atexit - -atexit() is C-specific: use C<END {}> instead, see L<perlsub>. - -=item atof - -atof() is C-specific. Perl converts strings to numbers transparently. -If you need to force a scalar to a number, add a zero to it. - -=item atoi - -atoi() is C-specific. Perl converts strings to numbers transparently. -If you need to force a scalar to a number, add a zero to it. -If you need to have just the integer part, see L<perlfunc/int>. - -=item atol - -atol() is C-specific. Perl converts strings to numbers transparently. -If you need to force a scalar to a number, add a zero to it. -If you need to have just the integer part, see L<perlfunc/int>. - -=item bsearch - -bsearch() not supplied. For doing binary search on wordlists, -see L<Search::Dict>. - -=item calloc - -calloc() is C-specific. Perl does memory management transparently. - -=item ceil - -This is identical to the C function C<ceil()>, returning the smallest -integer value greater than or equal to the given numerical argument. - -=item chdir - -This is identical to Perl's builtin C<chdir()> function, allowing -one to change the working (default) directory, see L<perlfunc/chdir>. - -=item chmod - -This is identical to Perl's builtin C<chmod()> function, allowing -one to change file and directory permissions, see L<perlfunc/chmod>. - -=item chown - -This is identical to Perl's builtin C<chown()> function, allowing one -to change file and directory owners and groups, see L<perlfunc/chown>. - -=item clearerr - -Use the method L<IO::Handle::clearerr()> instead, to reset the error -state (if any) and EOF state (if any) of the given stream. - -=item clock - -This is identical to the C function C<clock()>, returning the -amount of spent processor time in microseconds. - -=item close - -Close the file. This uses file descriptors such as those obtained by calling -C<POSIX::open>. - - $fd = POSIX::open( "foo", &POSIX::O_RDONLY ); - POSIX::close( $fd ); - -Returns C<undef> on failure. - -See also L<perlfunc/close>. - -=item closedir - -This is identical to Perl's builtin C<closedir()> function for closing -a directory handle, see L<perlfunc/closedir>. - -=item cos - -This is identical to Perl's builtin C<cos()> function, for returning -the cosine of its numerical argument, see L<perlfunc/cos>. -See also L<Math::Trig>. - -=item cosh - -This is identical to the C function C<cosh()>, for returning -the hyperbolic cosine of its numeric argument. See also L<Math::Trig>. - -=item creat - -Create a new file. This returns a file descriptor like the ones returned by -C<POSIX::open>. Use C<POSIX::close> to close the file. - - $fd = POSIX::creat( "foo", 0611 ); - POSIX::close( $fd ); - -See also L<perlfunc/sysopen> and its C<O_CREAT> flag. - -=item ctermid - -Generates the path name for the controlling terminal. - - $path = POSIX::ctermid(); - -=item ctime - -This is identical to the C function C<ctime()> and equivalent -to C<asctime(localtime(...))>, see L</asctime> and L</localtime>. - -=item cuserid - -Get the login name of the owner of the current process. - - $name = POSIX::cuserid(); - -=item difftime - -This is identical to the C function C<difftime()>, for returning -the time difference (in seconds) between two times (as returned -by C<time()>), see L</time>. - -=item div - -div() is C-specific, use L<perlfunc/int> on the usual C</> division and -the modulus C<%>. - -=item dup - -This is similar to the C function C<dup()>, for duplicating a file -descriptor. - -This uses file descriptors such as those obtained by calling -C<POSIX::open>. - -Returns C<undef> on failure. - -=item dup2 - -This is similar to the C function C<dup2()>, for duplicating a file -descriptor to an another known file descriptor. - -This uses file descriptors such as those obtained by calling -C<POSIX::open>. - -Returns C<undef> on failure. - -=item errno - -Returns the value of errno. - - $errno = POSIX::errno(); - -This identical to the numerical values of the C<$!>, see L<perlvar/$ERRNO>. - -=item execl - -execl() is C-specific, see L<perlfunc/exec>. - -=item execle - -execle() is C-specific, see L<perlfunc/exec>. - -=item execlp - -execlp() is C-specific, see L<perlfunc/exec>. - -=item execv - -execv() is C-specific, see L<perlfunc/exec>. - -=item execve - -execve() is C-specific, see L<perlfunc/exec>. - -=item execvp - -execvp() is C-specific, see L<perlfunc/exec>. - -=item exit - -This is identical to Perl's builtin C<exit()> function for exiting the -program, see L<perlfunc/exit>. - -=item exp - -This is identical to Perl's builtin C<exp()> function for -returning the exponent (I<e>-based) of the numerical argument, -see L<perlfunc/exp>. - -=item fabs - -This is identical to Perl's builtin C<abs()> function for returning -the absolute value of the numerical argument, see L<perlfunc/abs>. - -=item fclose - -Use method C<IO::Handle::close()> instead, or see L<perlfunc/close>. - -=item fcntl - -This is identical to Perl's builtin C<fcntl()> function, -see L<perlfunc/fcntl>. - -=item fdopen - -Use method C<IO::Handle::new_from_fd()> instead, or see L<perlfunc/open>. - -=item feof - -Use method C<IO::Handle::eof()> instead, or see L<perlfunc/eof>. - -=item ferror - -Use method C<IO::Handle::error()> instead. - -=item fflush - -Use method C<IO::Handle::flush()> instead. -See also L<perlvar/$OUTPUT_AUTOFLUSH>. - -=item fgetc - -Use method C<IO::Handle::getc()> instead, or see L<perlfunc/read>. - -=item fgetpos - -Use method C<IO::Seekable::getpos()> instead, or see L<L/seek>. - -=item fgets - -Use method C<IO::Handle::gets()> instead. Similar to E<lt>E<gt>, also known -as L<perlfunc/readline>. - -=item fileno - -Use method C<IO::Handle::fileno()> instead, or see L<perlfunc/fileno>. - -=item floor - -This is identical to the C function C<floor()>, returning the largest -integer value less than or equal to the numerical argument. - -=item fmod - -This is identical to the C function C<fmod()>. - - $r = modf($x, $y); - -It returns the remainder C<$r = $x - $n*$y>, where C<$n = trunc($x/$y)>. -The C<$r> has the same sign as C<$x> and magnitude (absolute value) -less than the magnitude of C<$y>. - -=item fopen - -Use method C<IO::File::open()> instead, or see L<perlfunc/open>. - -=item fork - -This is identical to Perl's builtin C<fork()> function -for duplicating the current process, see L<perlfunc/fork> -and L<perlfork> if you are in Windows. - -=item fpathconf - -Retrieves the value of a configurable limit on a file or directory. This -uses file descriptors such as those obtained by calling C<POSIX::open>. - -The following will determine the maximum length of the longest allowable -pathname on the filesystem which holds C</tmp/foo>. - - $fd = POSIX::open( "/tmp/foo", &POSIX::O_RDONLY ); - $path_max = POSIX::fpathconf( $fd, &POSIX::_PC_PATH_MAX ); - -Returns C<undef> on failure. - -=item fprintf - -fprintf() is C-specific, see L<perlfunc/printf> instead. - -=item fputc - -fputc() is C-specific, see L<perlfunc/print> instead. - -=item fputs - -fputs() is C-specific, see L<perlfunc/print> instead. - -=item fread - -fread() is C-specific, see L<perlfunc/read> instead. - -=item free - -free() is C-specific. Perl does memory management transparently. - -=item freopen - -freopen() is C-specific, see L<perlfunc/open> instead. - -=item frexp - -Return the mantissa and exponent of a floating-point number. - - ($mantissa, $exponent) = POSIX::frexp( 1.234e56 ); - -=item fscanf - -fscanf() is C-specific, use E<lt>E<gt> and regular expressions instead. - -=item fseek - -Use method C<IO::Seekable::seek()> instead, or see L<perlfunc/seek>. - -=item fsetpos - -Use method C<IO::Seekable::setpos()> instead, or seek L<perlfunc/seek>. - -=item fstat - -Get file status. This uses file descriptors such as those obtained by -calling C<POSIX::open>. The data returned is identical to the data from -Perl's builtin C<stat> function. - - $fd = POSIX::open( "foo", &POSIX::O_RDONLY ); - @stats = POSIX::fstat( $fd ); - -=item ftell - -Use method C<IO::Seekable::tell()> instead, or see L<perlfunc/tell>. - -=item fwrite - -fwrite() is C-specific, see L<perlfunc/print> instead. - -=item getc - -This is identical to Perl's builtin C<getc()> function, -see L<perlfunc/getc>. - -=item getchar - -Returns one character from STDIN. Identical to Perl's C<getc()>, -see L<perlfunc/getc>. - -=item getcwd - -Returns the name of the current working directory. -See also L<Cwd>. - -=item getegid - -Returns the effective group identifier. Similar to Perl' s builtin -variable C<$(>, see L<perlvar/$EGID>. - -=item getenv - -Returns the value of the specified enironment variable. -The same information is available through the C<%ENV> array. - -=item geteuid - -Returns the effective user identifier. Identical to Perl's builtin C<$E<gt>> -variable, see L<perlvar/$EUID>. - -=item getgid - -Returns the user's real group identifier. Similar to Perl's builtin -variable C<$)>, see L<perlvar/$GID>. - -=item getgrgid - -This is identical to Perl's builtin C<getgrgid()> function for -returning group entries by group identifiers, see -L<perlfunc/getgrgid>. - -=item getgrnam - -This is identical to Perl's builtin C<getgrnam()> function for -returning group entries by group names, see L<perlfunc/getgrnam>. - -=item getgroups - -Returns the ids of the user's supplementary groups. Similar to Perl's -builtin variable C<$)>, see L<perlvar/$GID>. - -=item getlogin - -This is identical to Perl's builtin C<getlogin()> function for -returning the user name associated with the current session, see -L<perlfunc/getlogin>. - -=item getpgrp - -This is identical to Perl's builtin C<getpgrp()> function for -returning the prcess group identifier of the current process, see -L<perlfunc/getpgrp>. - -=item getpid - -Returns the process identifier. Identical to Perl's builtin -variable C<$$>, see L<perlvar/$PID>. - -=item getppid - -This is identical to Perl's builtin C<getppid()> function for -returning the process identifier of the parent process of the current -process , see L<perlfunc/getppid>. - -=item getpwnam - -This is identical to Perl's builtin C<getpwnam()> function for -returning user entries by user names, see L<perlfunc/getpwnam>. - -=item getpwuid - -This is identical to Perl's builtin C<getpwuid()> function for -returning user entries by user identifiers, see L<perlfunc/getpwuid>. - -=item gets - -Returns one line from C<STDIN>, similar to E<lt>E<gt>, also known -as the C<readline()> function, see L<perlfunc/readline>. - -B<NOTE>: if you have C programs that still use C<gets()>, be very -afraid. The C<gets()> function is a source of endless grief because -it has no buffer overrun checks. It should B<never> be used. The -C<fgets()> function should be preferred instead. - -=item getuid - -Returns the user's identifier. Identical to Perl's builtin C<$E<lt>> variable, -see L<perlvar/$UID>. - -=item gmtime - -This is identical to Perl's builtin C<gmtime()> function for -converting seconds since the epoch to a date in Greenwich Mean Time, -see L<perlfunc/gmtime>. - -=item isalnum - -This is identical to the C function, except that it can apply to a single -character or to a whole string. Consider using regular expressions and the -C</[[:isalnum:]]/> construct instead, or possibly the C</\w/> construct. - -=item isalpha - -This is identical to the C function, except that it can apply to a single -character or to a whole string. Consider using regular expressions and the -C</[[:isalpha:]]/> construct instead. - -=item isatty - -Returns a boolean indicating whether the specified filehandle is connected -to a tty. Similar to the C<-t> operator, see L<perlfunc/-X>. - -=item iscntrl - -This is identical to the C function, except that it can apply to a single -character or to a whole string. Consider using regular expressions and the -C</[[:iscntrl:]]/> construct instead. - -=item isdigit - -This is identical to the C function, except that it can apply to a single -character or to a whole string. Consider using regular expressions and the -C</[[:isdigit:]]/> construct instead, or the C</\d/> construct. - -=item isgraph - -This is identical to the C function, except that it can apply to a single -character or to a whole string. Consider using regular expressions and the -C</[[:isgraph:]]/> construct instead. - -=item islower - -This is identical to the C function, except that it can apply to a single -character or to a whole string. Consider using regular expressions and the -C</[[:islower:]]/> construct instead. Do B<not> use C</a-z/>. - -=item isprint - -This is identical to the C function, except that it can apply to a single -character or to a whole string. Consider using regular expressions and the -C</[[:isprint:]]/> construct instead. - -=item ispunct - -This is identical to the C function, except that it can apply to a single -character or to a whole string. Consider using regular expressions and the -C</[[:ispunct:]]/> construct instead. - -=item isspace - -This is identical to the C function, except that it can apply to a single -character or to a whole string. Consider using regular expressions and the -C</[[:isspace:]]/> construct instead, or the C</\s/> construct. - -=item isupper - -This is identical to the C function, except that it can apply to a single -character or to a whole string. Consider using regular expressions and the -C</[[:isupper:]]/> construct instead. Do B<not> use C</A-Z/>. - -=item isxdigit - -This is identical to the C function, except that it can apply to a single -character or to a whole string. Consider using regular expressions and the -C</[[:isxdigit:]]/> construct instead, or simply C</[0-9a-f]/i>. - -=item kill - -This is identical to Perl's builtin C<kill()> function for sending -signals to processes (often to terminate them), see L<perlfunc/kill>. - -=item labs - -(For returning absolute values of long integers.) -labs() is C-specific, see L<perlfunc/abs> instead. - -=item ldexp - -This is identical to the C function C<ldexp()> -for multiplying floating point numbers with powers of two. - - $x_quadrupled = POSIX::ldexp($x, 2); - -=item ldiv - -(For computing dividends of long integers.) -ldiv() is C-specific, use C</> and C<int()> instead. - -=item link - -This is identical to Perl's builtin C<link()> function -for creating hard links into files, see L<perlfunc/link>. - -=item localeconv - -Get numeric formatting information. Returns a reference to a hash -containing the current locale formatting values. - -Here is how to query the database for the B<de> (Deutsch or German) locale. - - $loc = POSIX::setlocale( &POSIX::LC_ALL, "de" ); - print "Locale = $loc\n"; - $lconv = POSIX::localeconv(); - print "decimal_point = ", $lconv->{decimal_point}, "\n"; - print "thousands_sep = ", $lconv->{thousands_sep}, "\n"; - print "grouping = ", $lconv->{grouping}, "\n"; - print "int_curr_symbol = ", $lconv->{int_curr_symbol}, "\n"; - print "currency_symbol = ", $lconv->{currency_symbol}, "\n"; - print "mon_decimal_point = ", $lconv->{mon_decimal_point}, "\n"; - print "mon_thousands_sep = ", $lconv->{mon_thousands_sep}, "\n"; - print "mon_grouping = ", $lconv->{mon_grouping}, "\n"; - print "positive_sign = ", $lconv->{positive_sign}, "\n"; - print "negative_sign = ", $lconv->{negative_sign}, "\n"; - print "int_frac_digits = ", $lconv->{int_frac_digits}, "\n"; - print "frac_digits = ", $lconv->{frac_digits}, "\n"; - print "p_cs_precedes = ", $lconv->{p_cs_precedes}, "\n"; - print "p_sep_by_space = ", $lconv->{p_sep_by_space}, "\n"; - print "n_cs_precedes = ", $lconv->{n_cs_precedes}, "\n"; - print "n_sep_by_space = ", $lconv->{n_sep_by_space}, "\n"; - print "p_sign_posn = ", $lconv->{p_sign_posn}, "\n"; - print "n_sign_posn = ", $lconv->{n_sign_posn}, "\n"; - -=item localtime - -This is identical to Perl's builtin C<localtime()> function for -converting seconds since the epoch to a date see L<perlfunc/localtime>. - -=item log - -This is identical to Perl's builtin C<log()> function, -returning the natural (I<e>-based) logarithm of the numerical argument, -see L<perlfunc/log>. - -=item log10 - -This is identical to the C function C<log10()>, -returning the 10-base logarithm of the numerical argument. -You can also use - - sub log10 { log($_[0]) / log(10) } - -or - - sub log10 { log($_[0]) / 2.30258509299405 } - -or - - sub log10 { log($_[0]) * 0.434294481903252 } - -=item longjmp - -longjmp() is C-specific: use L<perlfunc/die> instead. - -=item lseek - -Move the file's read/write position. This uses file descriptors such as -those obtained by calling C<POSIX::open>. - - $fd = POSIX::open( "foo", &POSIX::O_RDONLY ); - $off_t = POSIX::lseek( $fd, 0, &POSIX::SEEK_SET ); - -Returns C<undef> on failure. - -=item malloc - -malloc() is C-specific. Perl does memory management transparently. - -=item mblen - -This is identical to the C function C<mblen()>. -Perl does not have any support for the wide and multibyte -characters of the C standards, so this might be a rather -useless function. - -=item mbstowcs - -This is identical to the C function C<mbstowcs()>. -Perl does not have any support for the wide and multibyte -characters of the C standards, so this might be a rather -useless function. - -=item mbtowc - -This is identical to the C function C<mbtowc()>. -Perl does not have any support for the wide and multibyte -characters of the C standards, so this might be a rather -useless function. - -=item memchr - -memchr() is C-specific, see L<perlfunc/index> instead. - -=item memcmp - -memcmp() is C-specific, use C<eq> instead, see L<perlop>. - -=item memcpy - -memcpy() is C-specific, use C<=>, see L<perlop>, or see L<perlfunc/substr>. - -=item memmove - -memmove() is C-specific, use C<=>, see L<perlop>, or see L<perlfunc/substr>. - -=item memset - -memset() is C-specific, use C<x> instead, see L<perlop>. - -=item mkdir - -This is identical to Perl's builtin C<mkdir()> function -for creating directories, see L<perlfunc/mkdir>. - -=item mkfifo - -This is similar to the C function C<mkfifo()> for creating -FIFO special files. - - if (mkfifo($path, $mode)) { .... - -Returns C<undef> on failure. The C<$mode> is similar to the -mode of C<mkdir()>, see L<perlfunc/mkdir>. - -=item mktime - -Convert date/time info to a calendar time. - -Synopsis: - - mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0) - -The month (C<mon>), weekday (C<wday>), and yearday (C<yday>) begin at zero. -I.e. January is 0, not 1; Sunday is 0, not 1; January 1st is 0, not 1. The -year (C<year>) is given in years since 1900. I.e. The year 1995 is 95; the -year 2001 is 101. Consult your system's C<mktime()> manpage for details -about these and the other arguments. - -Calendar time for December 12, 1995, at 10:30 am. - - $time_t = POSIX::mktime( 0, 30, 10, 12, 11, 95 ); - print "Date = ", POSIX::ctime($time_t); - -Returns C<undef> on failure. - -=item modf - -Return the integral and fractional parts of a floating-point number. - - ($fractional, $integral) = POSIX::modf( 3.14 ); - -=item nice - -This is similar to the C function C<nice()>, for changing -the scheduling preference of the current process. Positive -arguments mean more polite process, negative values more -needy process. Normal user processes can only be more polite. - -Returns C<undef> on failure. - -=item offsetof - -offsetof() is C-specific, you probably want to see L<perlfunc/pack> instead. - -=item open - -Open a file for reading for writing. This returns file descriptors, not -Perl filehandles. Use C<POSIX::close> to close the file. - -Open a file read-only with mode 0666. - - $fd = POSIX::open( "foo" ); - -Open a file for read and write. - - $fd = POSIX::open( "foo", &POSIX::O_RDWR ); - -Open a file for write, with truncation. - - $fd = POSIX::open( "foo", &POSIX::O_WRONLY | &POSIX::O_TRUNC ); - -Create a new file with mode 0640. Set up the file for writing. - - $fd = POSIX::open( "foo", &POSIX::O_CREAT | &POSIX::O_WRONLY, 0640 ); - -Returns C<undef> on failure. - -See also L<perlfunc/sysopen>. - -=item opendir - -Open a directory for reading. - - $dir = POSIX::opendir( "/tmp" ); - @files = POSIX::readdir( $dir ); - POSIX::closedir( $dir ); - -Returns C<undef> on failure. - -=item pathconf - -Retrieves the value of a configurable limit on a file or directory. - -The following will determine the maximum length of the longest allowable -pathname on the filesystem which holds C</tmp>. - - $path_max = POSIX::pathconf( "/tmp", &POSIX::_PC_PATH_MAX ); - -Returns C<undef> on failure. - -=item pause - -This is similar to the C function C<pause()>, which suspends -the execution of the current process until a signal is received. - -Returns C<undef> on failure. - -=item perror - -This is identical to the C function C<perror()>, which outputs to the -standard error stream the specified message followed by ": " and the -current error string. Use the C<warn()> function and the C<$!> -variable instead, see L<perlfunc/warn> and L<perlvar/$ERRNO>. - -=item pipe - -Create an interprocess channel. This returns file descriptors like those -returned by C<POSIX::open>. - - ($fd0, $fd1) = POSIX::pipe(); - POSIX::write( $fd0, "hello", 5 ); - POSIX::read( $fd1, $buf, 5 ); - -See also L<perlfunc/pipe>. - -=item pow - -Computes C<$x> raised to the power C<$exponent>. - - $ret = POSIX::pow( $x, $exponent ); - -You can also use the C<**> operator, see L<perlop>. - -=item printf - -Formats and prints the specified arguments to STDOUT. -See also L<perlfunc/printf>. - -=item putc - -putc() is C-specific, see L<perlfunc/print> instead. - -=item putchar - -putchar() is C-specific, see L<perlfunc/print> instead. - -=item puts - -puts() is C-specific, see L<perlfunc/print> instead. - -=item qsort - -qsort() is C-specific, see L<perlfunc/sort> instead. - -=item raise - -Sends the specified signal to the current process. -See also L<perlfunc/kill> and the C<$$> in L<perlvar/$PID>. - -=item rand - -C<rand()> is non-portable, see L<perlfunc/rand> instead. - -=item read - -Read from a file. This uses file descriptors such as those obtained by -calling C<POSIX::open>. If the buffer C<$buf> is not large enough for the -read then Perl will extend it to make room for the request. - - $fd = POSIX::open( "foo", &POSIX::O_RDONLY ); - $bytes = POSIX::read( $fd, $buf, 3 ); - -Returns C<undef> on failure. - -See also L<perlfunc/sysread>. - -=item readdir - -This is identical to Perl's builtin C<readdir()> function -for reading directory entries, see L<perlfunc/readdir>. - -=item realloc - -realloc() is C-specific. Perl does memory management transparently. - -=item remove - -This is identical to Perl's builtin C<unlink()> function -for removing files, see L<perlfunc/unlink>. - -=item rename - -This is identical to Perl's builtin C<rename()> function -for renaming files, see L<perlfunc/rename>. - -=item rewind - -Seeks to the beginning of the file. - -=item rewinddir - -This is identical to Perl's builtin C<rewinddir()> function for -rewinding directory entry streams, see L<perlfunc/rewinddir>. - -=item rmdir - -This is identical to Perl's builtin C<rmdir()> function -for removing (empty) directories, see L<perlfunc/rmdir>. - -=item scanf - -scanf() is C-specific, use E<lt>E<gt> and regular expressions instead, -see L<perlre>. - -=item setgid - -Sets the real group identifier for this process. -Identical to assigning a value to the Perl's builtin C<$)> variable, -see L<perlvar/$UID>. - -=item setjmp - -C<setjmp()> is C-specific: use C<eval {}> instead, -see L<perlfunc/eval>. - -=item setlocale - -Modifies and queries program's locale. The following examples assume - - use POSIX qw(setlocale LC_ALL LC_CTYPE); - -has been issued. - -The following will set the traditional UNIX system locale behavior -(the second argument C<"C">). - - $loc = setlocale( LC_ALL, "C" ); - -The following will query the current LC_CTYPE category. (No second -argument means 'query'.) - - $loc = setlocale( LC_CTYPE ); - -The following will set the LC_CTYPE behaviour according to the locale -environment variables (the second argument C<"">). -Please see your systems L<setlocale(3)> documentation for the locale -environment variables' meaning or consult L<perllocale>. - - $loc = setlocale( LC_CTYPE, "" ); - -The following will set the LC_COLLATE behaviour to Argentinian -Spanish. B<NOTE>: The naming and availability of locales depends on -your operating system. Please consult L<perllocale> for how to find -out which locales are available in your system. - - $loc = setlocale( LC_ALL, "es_AR.ISO8859-1" ); - -=item setpgid - -This is similar to the C function C<setpgid()> for -setting the process group identifier of the current process. - -Returns C<undef> on failure. - -=item setsid - -This is identical to the C function C<setsid()> for -setting the session identifier of the current process. - -=item setuid - -Sets the real user identifier for this process. -Identical to assigning a value to the Perl's builtin C<$E<lt>> variable, -see L<perlvar/$UID>. - -=item sigaction - -Detailed signal management. This uses C<POSIX::SigAction> objects for the -C<action> and C<oldaction> arguments. Consult your system's C<sigaction> -manpage for details. - -Synopsis: - - sigaction(sig, action, oldaction = 0) - -Returns C<undef> on failure. - -=item siglongjmp - -siglongjmp() is C-specific: use L<perlfunc/die> instead. - -=item sigpending - -Examine signals that are blocked and pending. This uses C<POSIX::SigSet> -objects for the C<sigset> argument. Consult your system's C<sigpending> -manpage for details. - -Synopsis: - - sigpending(sigset) - -Returns C<undef> on failure. - -=item sigprocmask - -Change and/or examine calling process's signal mask. This uses -C<POSIX::SigSet> objects for the C<sigset> and C<oldsigset> arguments. -Consult your system's C<sigprocmask> manpage for details. - -Synopsis: - - sigprocmask(how, sigset, oldsigset = 0) - -Returns C<undef> on failure. - -=item sigsetjmp - -C<sigsetjmp()> is C-specific: use C<eval {}> instead, -see L<perlfunc/eval>. - -=item sigsuspend - -Install a signal mask and suspend process until signal arrives. This uses -C<POSIX::SigSet> objects for the C<signal_mask> argument. Consult your -system's C<sigsuspend> manpage for details. - -Synopsis: - - sigsuspend(signal_mask) - -Returns C<undef> on failure. - -=item sin - -This is identical to Perl's builtin C<sin()> function -for returning the sine of the numerical argument, -see L<perlfunc/sin>. See also L<Math::Trig>. - -=item sinh - -This is identical to the C function C<sinh()> -for returning the hyperbolic sine of the numerical argument. -See also L<Math::Trig>. - -=item sleep - -This is identical to Perl's builtin C<sleep()> function -for suspending the execution of the current for process -for certain number of seconds, see L<perlfunc/sleep>. - -=item sprintf - -This is similar to Perl's builtin C<sprintf()> function -for returning a string that has the arguments formatted as requested, -see L<perlfunc/sprintf>. - -=item sqrt - -This is identical to Perl's builtin C<sqrt()> function. -for returning the square root of the numerical argument, -see L<perlfunc/sqrt>. - -=item srand - -Give a seed the pseudorandom number generator, see L<perlfunc/srand>. - -=item sscanf - -sscanf() is C-specific, use regular expressions instead, -see L<perlre>. - -=item stat - -This is identical to Perl's builtin C<stat()> function -for retutning information about files and directories. - -=item strcat - -strcat() is C-specific, use C<.=> instead, see L<perlop>. - -=item strchr - -strchr() is C-specific, see L<perlfunc/index> instead. - -=item strcmp - -strcmp() is C-specific, use C<eq> or C<cmp> instead, see L<perlop>. - -=item strcoll - -This is identical to the C function C<strcoll()> -for collating (comparing) strings transformed using -the C<strxfrm()> function. Not really needed since -Perl can do this transparently, see L<perllocale>. - -=item strcpy - -strcpy() is C-specific, use C<=> instead, see L<perlop>. - -=item strcspn - -strcspn() is C-specific, use regular expressions instead, -see L<perlre>. - -=item strerror - -Returns the error string for the specified errno. -Identical to the string form of the C<$!>, see L<perlvar/$ERRNO>. - -=item strftime - -Convert date and time information to string. Returns the string. - -Synopsis: - - strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1) - -The month (C<mon>), weekday (C<wday>), and yearday (C<yday>) begin at zero. -I.e. January is 0, not 1; Sunday is 0, not 1; January 1st is 0, not 1. The -year (C<year>) is given in years since 1900. I.e., the year 1995 is 95; the -year 2001 is 101. Consult your system's C<strftime()> manpage for details -about these and the other arguments. -If you want your code to be portable, your format (C<fmt>) argument -should use only the conversion specifiers defined by the ANSI C -standard. These are C<aAbBcdHIjmMpSUwWxXyYZ%>. -The given arguments are made consistent -as though by calling C<mktime()> before calling your system's -C<strftime()> function, except that the C<isdst> value is not affected. - -The string for Tuesday, December 12, 1995. - - $str = POSIX::strftime( "%A, %B %d, %Y", 0, 0, 0, 12, 11, 95, 2 ); - print "$str\n"; - -=item strlen - -strlen() is C-specific, use C<length()> instead, see L<perlfunc/length>. - -=item strncat - -strncat() is C-specific, use C<.=> instead, see L<perlop>. - -=item strncmp - -strncmp() is C-specific, use C<eq> instead, see L<perlop>. - -=item strncpy - -strncpy() is C-specific, use C<=> instead, see L<perlop>. - -=item strpbrk - -strpbrk() is C-specific, use regular expressions instead, -see L<perlre>. - -=item strrchr - -strrchr() is C-specific, see L<perlfunc/rindex> instead. - -=item strspn - -strspn() is C-specific, use regular expressions instead, -see L<perlre>. - -=item strstr - -This is identical to Perl's builtin C<index()> function, -see L<perlfunc/index>. - -=item strtod - -String to double translation. Returns the parsed number and the number -of characters in the unparsed portion of the string. Truly -POSIX-compliant systems set $! ($ERRNO) to indicate a translation -error, so clear $! before calling strtod. However, non-POSIX systems -may not check for overflow, and therefore will never set $!. - -strtod should respect any POSIX I<setlocale()> settings. - -To parse a string $str as a floating point number use - - $! = 0; - ($num, $n_unparsed) = POSIX::strtod($str); - -The second returned item and $! can be used to check for valid input: - - if (($str eq '') || ($n_unparsed != 0) || !$!) { - die "Non-numeric input $str" . $! ? ": $!\n" : "\n"; - } - -When called in a scalar context strtod returns the parsed number. - -=item strtok - -strtok() is C-specific, use regular expressions instead, see -L<perlre>, or L<perlfunc/split>. - -=item strtol - -String to (long) integer translation. Returns the parsed number and -the number of characters in the unparsed portion of the string. Truly -POSIX-compliant systems set $! ($ERRNO) to indicate a translation -error, so clear $! before calling strtol. However, non-POSIX systems -may not check for overflow, and therefore will never set $!. - -strtol should respect any POSIX I<setlocale()> settings. - -To parse a string $str as a number in some base $base use - - $! = 0; - ($num, $n_unparsed) = POSIX::strtol($str, $base); - -The base should be zero or between 2 and 36, inclusive. When the base -is zero or omitted strtol will use the string itself to determine the -base: a leading "0x" or "0X" means hexadecimal; a leading "0" means -octal; any other leading characters mean decimal. Thus, "1234" is -parsed as a decimal number, "01234" as an octal number, and "0x1234" -as a hexadecimal number. - -The second returned item and $! can be used to check for valid input: - - if (($str eq '') || ($n_unparsed != 0) || !$!) { - die "Non-numeric input $str" . $! ? ": $!\n" : "\n"; - } - -When called in a scalar context strtol returns the parsed number. - -=item strtoul - -String to unsigned (long) integer translation. strtoul() is identical -to strtol() except that strtoul() only parses unsigned integers. See -L</strtol> for details. - -Note: Some vendors supply strtod() and strtol() but not strtoul(). -Other vendors that do supply strtoul() parse "-1" as a valid value. - -=item strxfrm - -String transformation. Returns the transformed string. - - $dst = POSIX::strxfrm( $src ); - -Used in conjunction with the C<strcoll()> function, see L</strcoll>. - -Not really needed since Perl can do this transparently, see -L<perllocale>. - -=item sysconf - -Retrieves values of system configurable variables. - -The following will get the machine's clock speed. - - $clock_ticks = POSIX::sysconf( &POSIX::_SC_CLK_TCK ); - -Returns C<undef> on failure. - -=item system - -This is identical to Perl's builtin C<system()> function, see -L<perlfunc/system>. - -=item tan - -This is identical to the C function C<tan()>, returning the -tangent of the numerical argument. See also L<Math::Trig>. - -=item tanh - -This is identical to the C function C<tanh()>, returning the -hyperbolic tangent of the numerical argument. See also L<Math::Trig>. - -=item tcdrain - -This is similar to the C function C<tcdrain()> for draining -the output queue of its argument stream. - -Returns C<undef> on failure. - -=item tcflow - -This is similar to the C function C<tcflow()> for controlling -the flow of its argument stream. - -Returns C<undef> on failure. - -=item tcflush - -This is similar to the C function C<tcflush()> for flushing -the I/O buffers of its argumeny stream. - -Returns C<undef> on failure. - -=item tcgetpgrp - -This is identical to the C function C<tcgetpgrp()> for returning the -process group identifier of the foreground process group of the controlling -terminal. - -=item tcsendbreak - -This is similar to the C function C<tcsendbreak()> for sending -a break on its argument stream. - -Returns C<undef> on failure. - -=item tcsetpgrp - -This is similar to the C function C<tcsetpgrp()> for setting the -process group identifier of the foreground process group of the controlling -terminal. - -Returns C<undef> on failure. - -=item time - -This is identical to Perl's builtin C<time()> function -for returning the number of seconds since the epoch -(whatever it is for the system), see L<perlfunc/time>. - -=item times - -The times() function returns elapsed realtime since some point in the past -(such as system startup), user and system times for this process, and user -and system times used by child processes. All times are returned in clock -ticks. - - ($realtime, $user, $system, $cuser, $csystem) = POSIX::times(); - -Note: Perl's builtin C<times()> function returns four values, measured in -seconds. - -=item tmpfile - -Use method C<IO::File::new_tmpfile()> instead, or see L<File::Temp>. - -=item tmpnam - -Returns a name for a temporary file. - - $tmpfile = POSIX::tmpnam(); - -For security reasons, which are probably detailed in your system's -documentation for the C library tmpnam() function, this interface -should not be used; instead see L<File::Temp>. - -=item tolower - -This is identical to the C function, except that it can apply to a single -character or to a whole string. Consider using the C<lc()> function, -see L<perlfunc/lc>, or the equivalent C<\L> operator inside doublequotish -strings. - -=item toupper - -This is identical to the C function, except that it can apply to a single -character or to a whole string. Consider using the C<uc()> function, -see L<perlfunc/uc>, or the equivalent C<\U> operator inside doublequotish -strings. - -=item ttyname - -This is identical to the C function C<ttyname()> for returning the -name of the current terminal. - -=item tzname - -Retrieves the time conversion information from the C<tzname> variable. - - POSIX::tzset(); - ($std, $dst) = POSIX::tzname(); - -=item tzset - -This is identical to the C function C<tzset()> for setting -the current timezone based on the environment variable C<TZ>, -to be used by C<ctime()>, C<localtime()>, C<mktime()>, and C<strftime()> -functions. - -=item umask - -This is identical to Perl's builtin C<umask()> function -for setting (and querying) the file creation permission mask, -see L<perlfunc/umask>. - -=item uname - -Get name of current operating system. - - ($sysname, $nodename, $release, $version, $machine) = POSIX::uname(); - -Note that the actual meanings of the various fields are not -that well standardized, do not expect any great portability. -The C<$sysname> might be the name of the operating system, -the C<$nodename> might be the name of the host, the C<$release> -might be the (major) release number of the operating system, -the C<$version> might be the (minor) release number of the -operating system, and the C<$machine> might be a hardware identifier. -Maybe. - -=item ungetc - -Use method C<IO::Handle::ungetc()> instead. - -=item unlink - -This is identical to Perl's builtin C<unlink()> function -for removing files, see L<perlfunc/unlink>. - -=item utime - -This is identical to Perl's builtin C<utime()> function -for changing the time stamps of files and directories, -see L<perlfunc/utime>. - -=item vfprintf - -vfprintf() is C-specific, see L<perlfunc/printf> instead. - -=item vprintf - -vprintf() is C-specific, see L<perlfunc/printf> instead. - -=item vsprintf - -vsprintf() is C-specific, see L<perlfunc/sprintf> instead. - -=item wait - -This is identical to Perl's builtin C<wait()> function, -see L<perlfunc/wait>. - -=item waitpid - -Wait for a child process to change state. This is identical to Perl's -builtin C<waitpid()> function, see L<perlfunc/waitpid>. - - $pid = POSIX::waitpid( -1, &POSIX::WNOHANG ); - print "status = ", ($? / 256), "\n"; - -=item wcstombs - -This is identical to the C function C<wcstombs()>. -Perl does not have any support for the wide and multibyte -characters of the C standards, so this might be a rather -useless function. - -=item wctomb - -This is identical to the C function C<wctomb()>. -Perl does not have any support for the wide and multibyte -characters of the C standards, so this might be a rather -useless function. - -=item write - -Write to a file. This uses file descriptors such as those obtained by -calling C<POSIX::open>. - - $fd = POSIX::open( "foo", &POSIX::O_WRONLY ); - $buf = "hello"; - $bytes = POSIX::write( $b, $buf, 5 ); - -Returns C<undef> on failure. - -See also L<perlfunc/syswrite>. - -=back - -=head1 CLASSES - -=head2 POSIX::SigAction - -=over 8 - -=item new - -Creates a new C<POSIX::SigAction> object which corresponds to the C -C<struct sigaction>. This object will be destroyed automatically when it is -no longer needed. The first parameter is the fully-qualified name of a sub -which is a signal-handler. The second parameter is a C<POSIX::SigSet> -object, it defaults to the empty set. The third parameter contains the -C<sa_flags>, it defaults to 0. - - $sigset = POSIX::SigSet->new(SIGINT, SIGQUIT); - $sigaction = POSIX::SigAction->new( 'main::handler', $sigset, &POSIX::SA_NOCLDSTOP ); - -This C<POSIX::SigAction> object should be used with the C<POSIX::sigaction()> -function. - -=back - -=head2 POSIX::SigSet - -=over 8 - -=item new - -Create a new SigSet object. This object will be destroyed automatically -when it is no longer needed. Arguments may be supplied to initialize the -set. - -Create an empty set. - - $sigset = POSIX::SigSet->new; - -Create a set with SIGUSR1. - - $sigset = POSIX::SigSet->new( &POSIX::SIGUSR1 ); - -=item addset - -Add a signal to a SigSet object. - - $sigset->addset( &POSIX::SIGUSR2 ); - -Returns C<undef> on failure. - -=item delset - -Remove a signal from the SigSet object. - - $sigset->delset( &POSIX::SIGUSR2 ); - -Returns C<undef> on failure. - -=item emptyset - -Initialize the SigSet object to be empty. - - $sigset->emptyset(); - -Returns C<undef> on failure. - -=item fillset - -Initialize the SigSet object to include all signals. - - $sigset->fillset(); - -Returns C<undef> on failure. - -=item ismember - -Tests the SigSet object to see if it contains a specific signal. - - if( $sigset->ismember( &POSIX::SIGUSR1 ) ){ - print "contains SIGUSR1\n"; - } - -=back - -=head2 POSIX::Termios - -=over 8 - -=item new - -Create a new Termios object. This object will be destroyed automatically -when it is no longer needed. A Termios object corresponds to the termios -C struct. new() mallocs a new one, getattr() fills it from a file descriptor, -and setattr() sets a file descriptor's parameters to match Termios' contents. - - $termios = POSIX::Termios->new; - -=item getattr - -Get terminal control attributes. - -Obtain the attributes for stdin. - - $termios->getattr() - -Obtain the attributes for stdout. - - $termios->getattr( 1 ) - -Returns C<undef> on failure. - -=item getcc - -Retrieve a value from the c_cc field of a termios object. The c_cc field is -an array so an index must be specified. - - $c_cc[1] = $termios->getcc(1); - -=item getcflag - -Retrieve the c_cflag field of a termios object. - - $c_cflag = $termios->getcflag; - -=item getiflag - -Retrieve the c_iflag field of a termios object. - - $c_iflag = $termios->getiflag; - -=item getispeed - -Retrieve the input baud rate. - - $ispeed = $termios->getispeed; - -=item getlflag - -Retrieve the c_lflag field of a termios object. - - $c_lflag = $termios->getlflag; - -=item getoflag - -Retrieve the c_oflag field of a termios object. - - $c_oflag = $termios->getoflag; - -=item getospeed - -Retrieve the output baud rate. - - $ospeed = $termios->getospeed; - -=item setattr - -Set terminal control attributes. - -Set attributes immediately for stdout. - - $termios->setattr( 1, &POSIX::TCSANOW ); - -Returns C<undef> on failure. - -=item setcc - -Set a value in the c_cc field of a termios object. The c_cc field is an -array so an index must be specified. - - $termios->setcc( &POSIX::VEOF, 1 ); - -=item setcflag - -Set the c_cflag field of a termios object. - - $termios->setcflag( $c_cflag | &POSIX::CLOCAL ); - -=item setiflag - -Set the c_iflag field of a termios object. - - $termios->setiflag( $c_iflag | &POSIX::BRKINT ); - -=item setispeed - -Set the input baud rate. - - $termios->setispeed( &POSIX::B9600 ); - -Returns C<undef> on failure. - -=item setlflag - -Set the c_lflag field of a termios object. - - $termios->setlflag( $c_lflag | &POSIX::ECHO ); - -=item setoflag - -Set the c_oflag field of a termios object. - - $termios->setoflag( $c_oflag | &POSIX::OPOST ); - -=item setospeed - -Set the output baud rate. - - $termios->setospeed( &POSIX::B9600 ); - -Returns C<undef> on failure. - -=item Baud rate values - -B38400 B75 B200 B134 B300 B1800 B150 B0 B19200 B1200 B9600 B600 B4800 B50 B2400 B110 - -=item Terminal interface values - -TCSADRAIN TCSANOW TCOON TCIOFLUSH TCOFLUSH TCION TCIFLUSH TCSAFLUSH TCIOFF TCOOFF - -=item c_cc field values - -VEOF VEOL VERASE VINTR VKILL VQUIT VSUSP VSTART VSTOP VMIN VTIME NCCS - -=item c_cflag field values - -CLOCAL CREAD CSIZE CS5 CS6 CS7 CS8 CSTOPB HUPCL PARENB PARODD - -=item c_iflag field values - -BRKINT ICRNL IGNBRK IGNCR IGNPAR INLCR INPCK ISTRIP IXOFF IXON PARMRK - -=item c_lflag field values - -ECHO ECHOE ECHOK ECHONL ICANON IEXTEN ISIG NOFLSH TOSTOP - -=item c_oflag field values - -OPOST - -=back - -=head1 PATHNAME CONSTANTS - -=over 8 - -=item Constants - -_PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON _PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX _PC_PIPE_BUF _PC_VDISABLE - -=back - -=head1 POSIX CONSTANTS - -=over 8 - -=item Constants - -_POSIX_ARG_MAX _POSIX_CHILD_MAX _POSIX_CHOWN_RESTRICTED _POSIX_JOB_CONTROL _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_NO_TRUNC _POSIX_OPEN_MAX _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SAVED_IDS _POSIX_SSIZE_MAX _POSIX_STREAM_MAX _POSIX_TZNAME_MAX _POSIX_VDISABLE _POSIX_VERSION - -=back - -=head1 SYSTEM CONFIGURATION - -=over 8 - -=item Constants - -_SC_ARG_MAX _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_SAVED_IDS _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION - -=back - -=head1 ERRNO - -=over 8 - -=item Constants - -E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT EAGAIN EALREADY EBADF -EBUSY ECHILD ECONNABORTED ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ -EDOM EDQUOT EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS EINTR -EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK EMSGSIZE ENAMETOOLONG -ENETDOWN ENETRESET ENETUNREACH ENFILE ENOBUFS ENODEV ENOENT ENOEXEC -ENOLCK ENOMEM ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR -ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM EPFNOSUPPORT EPIPE -EPROCLIM EPROTONOSUPPORT EPROTOTYPE ERANGE EREMOTE ERESTART EROFS -ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS -ETXTBSY EUSERS EWOULDBLOCK EXDEV - -=back - -=head1 FCNTL - -=over 8 - -=item Constants - -FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_OK F_RDLCK F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK O_RDONLY O_RDWR O_TRUNC O_WRONLY - -=back - -=head1 FLOAT - -=over 8 - -=item Constants - -DBL_DIG DBL_EPSILON DBL_MANT_DIG DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP FLT_DIG FLT_EPSILON FLT_MANT_DIG FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP FLT_RADIX FLT_ROUNDS LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP - -=back - -=head1 LIMITS - -=over 8 - -=item Constants - -ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN SSIZE_MAX STREAM_MAX TZNAME_MAX UCHAR_MAX UINT_MAX ULONG_MAX USHRT_MAX - -=back - -=head1 LOCALE - -=over 8 - -=item Constants - -LC_ALL LC_COLLATE LC_CTYPE LC_MONETARY LC_NUMERIC LC_TIME - -=back - -=head1 MATH - -=over 8 - -=item Constants - -HUGE_VAL - -=back - -=head1 SIGNAL - -=over 8 - -=item Constants - -SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK SA_RESETHAND SA_RESTART -SA_SIGINFO SIGABRT SIGALRM SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT -SIGKILL SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN SIGTTOU -SIGUSR1 SIGUSR2 SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK -SIG_UNBLOCK - -=back - -=head1 STAT - -=over 8 - -=item Constants - -S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU S_ISGID S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR - -=item Macros - -S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG - -=back - -=head1 STDLIB - -=over 8 - -=item Constants - -EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX RAND_MAX - -=back - -=head1 STDIO - -=over 8 - -=item Constants - -BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid L_tmpname TMP_MAX - -=back - -=head1 TIME - -=over 8 - -=item Constants - -CLK_TCK CLOCKS_PER_SEC - -=back - -=head1 UNISTD - -=over 8 - -=item Constants - -R_OK SEEK_CUR SEEK_END SEEK_SET STDIN_FILENO STDOUT_FILENO STDERR_FILENO W_OK X_OK - -=back - -=head1 WAIT - -=over 8 - -=item Constants - -WNOHANG WUNTRACED - -=item Macros - -WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG WIFSTOPPED WSTOPSIG - -=back - diff --git a/contrib/perl5/ext/POSIX/POSIX.xs b/contrib/perl5/ext/POSIX/POSIX.xs deleted file mode 100644 index ef7d78a..0000000 --- a/contrib/perl5/ext/POSIX/POSIX.xs +++ /dev/null @@ -1,3967 +0,0 @@ -/* $FreeBSD$ */ -#ifdef WIN32 -#define _POSIX_ -#endif - -#define PERL_NO_GET_CONTEXT - -#include "EXTERN.h" -#define PERLIO_NOT_STDIO 1 -#include "perl.h" -#include "XSUB.h" -#if defined(PERL_OBJECT) || defined(PERL_CAPI) || defined(PERL_IMPLICIT_SYS) -# undef signal -# undef open -# undef setmode -# define open PerlLIO_open3 -#endif -#include <ctype.h> -#ifdef I_DIRENT /* XXX maybe better to just rely on perl.h? */ -#include <dirent.h> -#endif -#include <errno.h> -#ifdef I_FLOAT -#include <float.h> -#endif -#ifdef I_LIMITS -#include <limits.h> -#endif -#include <locale.h> -#include <math.h> -#ifdef I_PWD -#include <pwd.h> -#endif -#include <setjmp.h> -#include <signal.h> -#include <stdarg.h> - -#ifdef I_STDDEF -#include <stddef.h> -#endif - -/* XXX This comment is just to make I_TERMIO and I_SGTTY visible to - metaconfig for future extension writers. We don't use them in POSIX. - (This is really sneaky :-) --AD -*/ -#if defined(I_TERMIOS) -#include <termios.h> -#endif -#ifdef I_STDLIB -#include <stdlib.h> -#endif -#include <string.h> -#include <sys/stat.h> -#include <sys/types.h> -#include <time.h> -#ifdef I_UNISTD -#include <unistd.h> -#endif -#ifdef MACOS_TRADITIONAL -#undef fdopen -#endif -#include <fcntl.h> - -#if defined(__VMS) && !defined(__POSIX_SOURCE) -# include <libdef.h> /* LIB$_INVARG constant */ -# include <lib$routines.h> /* prototype for lib$ediv() */ -# include <starlet.h> /* prototype for sys$gettim() */ -# if DECC_VERSION < 50000000 -# define pid_t int /* old versions of DECC miss this in types.h */ -# endif - -# undef mkfifo -# define mkfifo(a,b) (not_here("mkfifo"),-1) -# define tzset() not_here("tzset") - -#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) -# define HAS_TZNAME /* shows up in VMS 7.0 or Dec C 5.6 */ -# include <utsname.h> -# endif /* __VMS_VER >= 70000000 or Dec C 5.6 */ - - /* The POSIX notion of ttyname() is better served by getname() under VMS */ - static char ttnambuf[64]; -# define ttyname(fd) (isatty(fd) > 0 ? getname(fd,ttnambuf,0) : NULL) - - /* The non-POSIX CRTL times() has void return type, so we just get the - current time directly */ - clock_t vms_times(struct tms *bufptr) { - dTHX; - clock_t retval; - /* Get wall time and convert to 10 ms intervals to - * produce the return value that the POSIX standard expects */ -# if defined(__DECC) && defined (__ALPHA) -# include <ints.h> - uint64 vmstime; - _ckvmssts(sys$gettim(&vmstime)); - vmstime /= 100000; - retval = vmstime & 0x7fffffff; -# else - /* (Older hw or ccs don't have an atomic 64-bit type, so we - * juggle 32-bit ints (and a float) to produce a time_t result - * with minimal loss of information.) */ - long int vmstime[2],remainder,divisor = 100000; - _ckvmssts(sys$gettim((unsigned long int *)vmstime)); - vmstime[1] &= 0x7fff; /* prevent overflow in EDIV */ - _ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder)); -# endif - /* Fill in the struct tms using the CRTL routine . . .*/ - times((tbuffer_t *)bufptr); - return (clock_t) retval; - } -# define times(t) vms_times(t) -#else -#if defined (__CYGWIN__) -# define tzname _tzname -#endif -#if defined (WIN32) -# undef mkfifo -# define mkfifo(a,b) not_here("mkfifo") -# define ttyname(a) (char*)not_here("ttyname") -# define sigset_t long -# define pid_t long -# ifdef __BORLANDC__ -# define tzname _tzname -# endif -# ifdef _MSC_VER -# define mode_t short -# endif -# ifdef __MINGW32__ -# define mode_t short -# ifndef tzset -# define tzset() not_here("tzset") -# endif -# ifndef _POSIX_OPEN_MAX -# define _POSIX_OPEN_MAX FOPEN_MAX /* XXX bogus ? */ -# endif -# endif -# define sigaction(a,b,c) not_here("sigaction") -# define sigpending(a) not_here("sigpending") -# define sigprocmask(a,b,c) not_here("sigprocmask") -# define sigsuspend(a) not_here("sigsuspend") -# define sigemptyset(a) not_here("sigemptyset") -# define sigaddset(a,b) not_here("sigaddset") -# define sigdelset(a,b) not_here("sigdelset") -# define sigfillset(a) not_here("sigfillset") -# define sigismember(a,b) not_here("sigismember") -# define setuid(a) not_here("setuid") -# define setgid(a) not_here("setgid") -#else - -# ifndef HAS_MKFIFO -# if defined(OS2) || defined(MACOS_TRADITIONAL) -# define mkfifo(a,b) not_here("mkfifo") -# else /* !( defined OS2 ) */ -# ifndef mkfifo -# define mkfifo(path, mode) (mknod((path), (mode) | S_IFIFO, 0)) -# endif -# endif -# endif /* !HAS_MKFIFO */ - -# ifdef MACOS_TRADITIONAL -# define ttyname(a) (char*)not_here("ttyname") -# define tzset() not_here("tzset") -# else -# include <grp.h> -# include <sys/times.h> -# ifdef HAS_UNAME -# include <sys/utsname.h> -# endif -# include <sys/wait.h> -# endif -# ifdef I_UTIME -# include <utime.h> -# endif -#endif /* WIN32 */ -#endif /* __VMS */ - -typedef int SysRet; -typedef long SysRetLong; -typedef sigset_t* POSIX__SigSet; -typedef HV* POSIX__SigAction; -#ifdef I_TERMIOS -typedef struct termios* POSIX__Termios; -#else /* Define termios types to int, and call not_here for the functions.*/ -#define POSIX__Termios int -#define speed_t int -#define tcflag_t int -#define cc_t int -#define cfgetispeed(x) not_here("cfgetispeed") -#define cfgetospeed(x) not_here("cfgetospeed") -#define tcdrain(x) not_here("tcdrain") -#define tcflush(x,y) not_here("tcflush") -#define tcsendbreak(x,y) not_here("tcsendbreak") -#define cfsetispeed(x,y) not_here("cfsetispeed") -#define cfsetospeed(x,y) not_here("cfsetospeed") -#define ctermid(x) (char *) not_here("ctermid") -#define tcflow(x,y) not_here("tcflow") -#define tcgetattr(x,y) not_here("tcgetattr") -#define tcsetattr(x,y,z) not_here("tcsetattr") -#endif - -/* Possibly needed prototypes */ -char *cuserid (char *); -double strtod (const char *, char **); -long strtol (const char *, char **, int); -unsigned long strtoul (const char *, char **, int); - -#ifndef HAS_CUSERID -#define cuserid(a) (char *) not_here("cuserid") -#endif -#ifndef HAS_DIFFTIME -#ifndef difftime -#define difftime(a,b) not_here("difftime") -#endif -#endif -#ifndef HAS_FPATHCONF -#define fpathconf(f,n) (SysRetLong) not_here("fpathconf") -#endif -#ifndef HAS_MKTIME -#define mktime(a) not_here("mktime") -#endif -#ifndef HAS_NICE -#define nice(a) not_here("nice") -#endif -#ifndef HAS_PATHCONF -#define pathconf(f,n) (SysRetLong) not_here("pathconf") -#endif -#ifndef HAS_SYSCONF -#define sysconf(n) (SysRetLong) not_here("sysconf") -#endif -#ifndef HAS_READLINK -#define readlink(a,b,c) not_here("readlink") -#endif -#ifndef HAS_SETPGID -#define setpgid(a,b) not_here("setpgid") -#endif -#ifndef HAS_SETSID -#define setsid() not_here("setsid") -#endif -#ifndef HAS_STRCOLL -#define strcoll(s1,s2) not_here("strcoll") -#endif -#ifndef HAS_STRTOD -#define strtod(s1,s2) not_here("strtod") -#endif -#ifndef HAS_STRTOL -#define strtol(s1,s2,b) not_here("strtol") -#endif -#ifndef HAS_STRTOUL -#define strtoul(s1,s2,b) not_here("strtoul") -#endif -#ifndef HAS_STRXFRM -#define strxfrm(s1,s2,n) not_here("strxfrm") -#endif -#ifndef HAS_TCGETPGRP -#define tcgetpgrp(a) not_here("tcgetpgrp") -#endif -#ifndef HAS_TCSETPGRP -#define tcsetpgrp(a,b) not_here("tcsetpgrp") -#endif -#ifndef HAS_TIMES -#define times(a) not_here("times") -#endif -#ifndef HAS_UNAME -#define uname(a) not_here("uname") -#endif -#ifndef HAS_WAITPID -#define waitpid(a,b,c) not_here("waitpid") -#endif - -#ifndef HAS_MBLEN -#ifndef mblen -#define mblen(a,b) not_here("mblen") -#endif -#endif -#ifndef HAS_MBSTOWCS -#define mbstowcs(s, pwcs, n) not_here("mbstowcs") -#endif -#ifndef HAS_MBTOWC -#define mbtowc(pwc, s, n) not_here("mbtowc") -#endif -#ifndef HAS_WCSTOMBS -#define wcstombs(s, pwcs, n) not_here("wcstombs") -#endif -#ifndef HAS_WCTOMB -#define wctomb(s, wchar) not_here("wcstombs") -#endif -#if !defined(HAS_MBLEN) && !defined(HAS_MBSTOWCS) && !defined(HAS_MBTOWC) && !defined(HAS_WCSTOMBS) && !defined(HAS_WCTOMB) -/* If we don't have these functions, then we wouldn't have gotten a typedef - for wchar_t, the wide character type. Defining wchar_t allows the - functions referencing it to compile. Its actual type is then meaningless, - since without the above functions, all sections using it end up calling - not_here() and croak. --Kaveh Ghazi (ghazi@noc.rutgers.edu) 9/18/94. */ -#ifndef wchar_t -#define wchar_t char -#endif -#endif - -#ifndef HAS_LOCALECONV -#define localeconv() not_here("localeconv") -#endif - -#ifdef HAS_TZNAME -# if !defined(WIN32) && !defined(__CYGWIN__) -extern char *tzname[]; -# endif -#else -#if !defined(WIN32) || (defined(__MINGW32__) && !defined(tzname)) -char *tzname[] = { "" , "" }; -#endif -#endif - -/* XXX struct tm on some systems (SunOS4/BSD) contains extra (non POSIX) - * fields for which we don't have Configure support yet: - * char *tm_zone; -- abbreviation of timezone name - * long tm_gmtoff; -- offset from GMT in seconds - * To workaround core dumps from the uninitialised tm_zone we get the - * system to give us a reasonable struct to copy. This fix means that - * strftime uses the tm_zone and tm_gmtoff values returned by - * localtime(time()). That should give the desired result most of the - * time. But probably not always! - * - * This is a temporary workaround to be removed once Configure - * support is added and NETaa14816 is considered in full. - * It does not address tzname aspects of NETaa14816. - */ -#ifdef HAS_GNULIBC -# ifndef STRUCT_TM_HASZONE -# define STRUCT_TM_HASZONE -# endif -#endif - -#ifdef STRUCT_TM_HASZONE -static void -init_tm(struct tm *ptm) /* see mktime, strftime and asctime */ -{ - Time_t now; - (void)time(&now); - Copy(localtime(&now), ptm, 1, struct tm); -} - -#else -# define init_tm(ptm) -#endif - -/* - * mini_mktime - normalise struct tm values without the localtime() - * semantics (and overhead) of mktime(). - */ -static void -mini_mktime(struct tm *ptm) -{ - int yearday; - int secs; - int month, mday, year, jday; - int odd_cent, odd_year; - -#define DAYS_PER_YEAR 365 -#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1) -#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1) -#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1) -#define SECS_PER_HOUR (60*60) -#define SECS_PER_DAY (24*SECS_PER_HOUR) -/* parentheses deliberately absent on these two, otherwise they don't work */ -#define MONTH_TO_DAYS 153/5 -#define DAYS_TO_MONTH 5/153 -/* offset to bias by March (month 4) 1st between month/mday & year finding */ -#define YEAR_ADJUST (4*MONTH_TO_DAYS+1) -/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */ -#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */ - -/* - * Year/day algorithm notes: - * - * With a suitable offset for numeric value of the month, one can find - * an offset into the year by considering months to have 30.6 (153/5) days, - * using integer arithmetic (i.e., with truncation). To avoid too much - * messing about with leap days, we consider January and February to be - * the 13th and 14th month of the previous year. After that transformation, - * we need the month index we use to be high by 1 from 'normal human' usage, - * so the month index values we use run from 4 through 15. - * - * Given that, and the rules for the Gregorian calendar (leap years are those - * divisible by 4 unless also divisible by 100, when they must be divisible - * by 400 instead), we can simply calculate the number of days since some - * arbitrary 'beginning of time' by futzing with the (adjusted) year number, - * the days we derive from our month index, and adding in the day of the - * month. The value used here is not adjusted for the actual origin which - * it normally would use (1 January A.D. 1), since we're not exposing it. - * We're only building the value so we can turn around and get the - * normalised values for the year, month, day-of-month, and day-of-year. - * - * For going backward, we need to bias the value we're using so that we find - * the right year value. (Basically, we don't want the contribution of - * March 1st to the number to apply while deriving the year). Having done - * that, we 'count up' the contribution to the year number by accounting for - * full quadracenturies (400-year periods) with their extra leap days, plus - * the contribution from full centuries (to avoid counting in the lost leap - * days), plus the contribution from full quad-years (to count in the normal - * leap days), plus the leftover contribution from any non-leap years. - * At this point, if we were working with an actual leap day, we'll have 0 - * days left over. This is also true for March 1st, however. So, we have - * to special-case that result, and (earlier) keep track of the 'odd' - * century and year contributions. If we got 4 extra centuries in a qcent, - * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb. - * Otherwise, we add back in the earlier bias we removed (the 123 from - * figuring in March 1st), find the month index (integer division by 30.6), - * and the remainder is the day-of-month. We then have to convert back to - * 'real' months (including fixing January and February from being 14/15 in - * the previous year to being in the proper year). After that, to get - * tm_yday, we work with the normalised year and get a new yearday value for - * January 1st, which we subtract from the yearday value we had earlier, - * representing the date we've re-built. This is done from January 1 - * because tm_yday is 0-origin. - * - * Since POSIX time routines are only guaranteed to work for times since the - * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm - * applies Gregorian calendar rules even to dates before the 16th century - * doesn't bother me. Besides, you'd need cultural context for a given - * date to know whether it was Julian or Gregorian calendar, and that's - * outside the scope for this routine. Since we convert back based on the - * same rules we used to build the yearday, you'll only get strange results - * for input which needed normalising, or for the 'odd' century years which - * were leap years in the Julian calander but not in the Gregorian one. - * I can live with that. - * - * This algorithm also fails to handle years before A.D. 1 gracefully, but - * that's still outside the scope for POSIX time manipulation, so I don't - * care. - */ - - year = 1900 + ptm->tm_year; - month = ptm->tm_mon; - mday = ptm->tm_mday; - /* allow given yday with no month & mday to dominate the result */ - if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) { - month = 0; - mday = 0; - jday = 1 + ptm->tm_yday; - } - else { - jday = 0; - } - if (month >= 2) - month+=2; - else - month+=14, year--; - yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400; - yearday += month*MONTH_TO_DAYS + mday + jday; - /* - * Note that we don't know when leap-seconds were or will be, - * so we have to trust the user if we get something which looks - * like a sensible leap-second. Wild values for seconds will - * be rationalised, however. - */ - if ((unsigned) ptm->tm_sec <= 60) { - secs = 0; - } - else { - secs = ptm->tm_sec; - ptm->tm_sec = 0; - } - secs += 60 * ptm->tm_min; - secs += SECS_PER_HOUR * ptm->tm_hour; - if (secs < 0) { - if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) { - /* got negative remainder, but need positive time */ - /* back off an extra day to compensate */ - yearday += (secs/SECS_PER_DAY)-1; - secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1); - } - else { - yearday += (secs/SECS_PER_DAY); - secs -= SECS_PER_DAY * (secs/SECS_PER_DAY); - } - } - else if (secs >= SECS_PER_DAY) { - yearday += (secs/SECS_PER_DAY); - secs %= SECS_PER_DAY; - } - ptm->tm_hour = secs/SECS_PER_HOUR; - secs %= SECS_PER_HOUR; - ptm->tm_min = secs/60; - secs %= 60; - ptm->tm_sec += secs; - /* done with time of day effects */ - /* - * The algorithm for yearday has (so far) left it high by 428. - * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to - * bias it by 123 while trying to figure out what year it - * really represents. Even with this tweak, the reverse - * translation fails for years before A.D. 0001. - * It would still fail for Feb 29, but we catch that one below. - */ - jday = yearday; /* save for later fixup vis-a-vis Jan 1 */ - yearday -= YEAR_ADJUST; - year = (yearday / DAYS_PER_QCENT) * 400; - yearday %= DAYS_PER_QCENT; - odd_cent = yearday / DAYS_PER_CENT; - year += odd_cent * 100; - yearday %= DAYS_PER_CENT; - year += (yearday / DAYS_PER_QYEAR) * 4; - yearday %= DAYS_PER_QYEAR; - odd_year = yearday / DAYS_PER_YEAR; - year += odd_year; - yearday %= DAYS_PER_YEAR; - if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */ - month = 1; - yearday = 29; - } - else { - yearday += YEAR_ADJUST; /* recover March 1st crock */ - month = yearday*DAYS_TO_MONTH; - yearday -= month*MONTH_TO_DAYS; - /* recover other leap-year adjustment */ - if (month > 13) { - month-=14; - year++; - } - else { - month-=2; - } - } - ptm->tm_year = year - 1900; - if (yearday) { - ptm->tm_mday = yearday; - ptm->tm_mon = month; - } - else { - ptm->tm_mday = 31; - ptm->tm_mon = month - 1; - } - /* re-build yearday based on Jan 1 to get tm_yday */ - year--; - yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400; - yearday += 14*MONTH_TO_DAYS + 1; - ptm->tm_yday = jday - yearday; - /* fix tm_wday if not overridden by caller */ - if ((unsigned)ptm->tm_wday > 6) - ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7; -} - -#ifdef HAS_LONG_DOUBLE -# if LONG_DOUBLESIZE > NVSIZE -# undef HAS_LONG_DOUBLE /* XXX until we figure out how to use them */ -# endif -#endif - -#ifndef HAS_LONG_DOUBLE -#ifdef LDBL_MAX -#undef LDBL_MAX -#endif -#ifdef LDBL_MIN -#undef LDBL_MIN -#endif -#ifdef LDBL_EPSILON -#undef LDBL_EPSILON -#endif -#endif - -static int -not_here(char *s) -{ - croak("POSIX::%s not implemented on this architecture", s); - return -1; -} - -static -NV -constant(char *name, int arg) -{ - errno = 0; - switch (*name) { - case 'A': - if (strEQ(name, "ARG_MAX")) -#ifdef ARG_MAX - return ARG_MAX; -#else - goto not_there; -#endif - break; - case 'B': - if (strEQ(name, "BUFSIZ")) -#ifdef BUFSIZ - return BUFSIZ; -#else - goto not_there; -#endif - if (strEQ(name, "BRKINT")) -#ifdef BRKINT - return BRKINT; -#else - goto not_there; -#endif - if (strEQ(name, "B9600")) -#ifdef B9600 - return B9600; -#else - goto not_there; -#endif - if (strEQ(name, "B19200")) -#ifdef B19200 - return B19200; -#else - goto not_there; -#endif - if (strEQ(name, "B38400")) -#ifdef B38400 - return B38400; -#else - goto not_there; -#endif - if (strEQ(name, "B0")) -#ifdef B0 - return B0; -#else - goto not_there; -#endif - if (strEQ(name, "B110")) -#ifdef B110 - return B110; -#else - goto not_there; -#endif - if (strEQ(name, "B1200")) -#ifdef B1200 - return B1200; -#else - goto not_there; -#endif - if (strEQ(name, "B134")) -#ifdef B134 - return B134; -#else - goto not_there; -#endif - if (strEQ(name, "B150")) -#ifdef B150 - return B150; -#else - goto not_there; -#endif - if (strEQ(name, "B1800")) -#ifdef B1800 - return B1800; -#else - goto not_there; -#endif - if (strEQ(name, "B200")) -#ifdef B200 - return B200; -#else - goto not_there; -#endif - if (strEQ(name, "B2400")) -#ifdef B2400 - return B2400; -#else - goto not_there; -#endif - if (strEQ(name, "B300")) -#ifdef B300 - return B300; -#else - goto not_there; -#endif - if (strEQ(name, "B4800")) -#ifdef B4800 - return B4800; -#else - goto not_there; -#endif - if (strEQ(name, "B50")) -#ifdef B50 - return B50; -#else - goto not_there; -#endif - if (strEQ(name, "B600")) -#ifdef B600 - return B600; -#else - goto not_there; -#endif - if (strEQ(name, "B75")) -#ifdef B75 - return B75; -#else - goto not_there; -#endif - break; - case 'C': - if (strEQ(name, "CHAR_BIT")) -#ifdef CHAR_BIT - return CHAR_BIT; -#else - goto not_there; -#endif - if (strEQ(name, "CHAR_MAX")) -#ifdef CHAR_MAX - return CHAR_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "CHAR_MIN")) -#ifdef CHAR_MIN - return CHAR_MIN; -#else - goto not_there; -#endif - if (strEQ(name, "CHILD_MAX")) -#ifdef CHILD_MAX - return CHILD_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "CLK_TCK")) -#ifdef CLK_TCK - return CLK_TCK; -#else - goto not_there; -#endif - if (strEQ(name, "CLOCAL")) -#ifdef CLOCAL - return CLOCAL; -#else - goto not_there; -#endif - if (strEQ(name, "CLOCKS_PER_SEC")) -#ifdef CLOCKS_PER_SEC - return CLOCKS_PER_SEC; -#else - goto not_there; -#endif - if (strEQ(name, "CREAD")) -#ifdef CREAD - return CREAD; -#else - goto not_there; -#endif - if (strEQ(name, "CS5")) -#ifdef CS5 - return CS5; -#else - goto not_there; -#endif - if (strEQ(name, "CS6")) -#ifdef CS6 - return CS6; -#else - goto not_there; -#endif - if (strEQ(name, "CS7")) -#ifdef CS7 - return CS7; -#else - goto not_there; -#endif - if (strEQ(name, "CS8")) -#ifdef CS8 - return CS8; -#else - goto not_there; -#endif - if (strEQ(name, "CSIZE")) -#ifdef CSIZE - return CSIZE; -#else - goto not_there; -#endif - if (strEQ(name, "CSTOPB")) -#ifdef CSTOPB - return CSTOPB; -#else - goto not_there; -#endif - break; - case 'D': - if (strEQ(name, "DBL_MAX")) -#ifdef DBL_MAX - return DBL_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "DBL_MIN")) -#ifdef DBL_MIN - return DBL_MIN; -#else - goto not_there; -#endif - if (strEQ(name, "DBL_DIG")) -#ifdef DBL_DIG - return DBL_DIG; -#else - goto not_there; -#endif - if (strEQ(name, "DBL_EPSILON")) -#ifdef DBL_EPSILON - return DBL_EPSILON; -#else - goto not_there; -#endif - if (strEQ(name, "DBL_MANT_DIG")) -#ifdef DBL_MANT_DIG - return DBL_MANT_DIG; -#else - goto not_there; -#endif - if (strEQ(name, "DBL_MAX_10_EXP")) -#ifdef DBL_MAX_10_EXP - return DBL_MAX_10_EXP; -#else - goto not_there; -#endif - if (strEQ(name, "DBL_MAX_EXP")) -#ifdef DBL_MAX_EXP - return DBL_MAX_EXP; -#else - goto not_there; -#endif - if (strEQ(name, "DBL_MIN_10_EXP")) -#ifdef DBL_MIN_10_EXP - return DBL_MIN_10_EXP; -#else - goto not_there; -#endif - if (strEQ(name, "DBL_MIN_EXP")) -#ifdef DBL_MIN_EXP - return DBL_MIN_EXP; -#else - goto not_there; -#endif - break; - case 'E': - switch (name[1]) { - case 'A': - if (strEQ(name, "EACCES")) -#ifdef EACCES - return EACCES; -#else - goto not_there; -#endif - if (strEQ(name, "EADDRINUSE")) -#ifdef EADDRINUSE - return EADDRINUSE; -#else - goto not_there; -#endif - if (strEQ(name, "EADDRNOTAVAIL")) -#ifdef EADDRNOTAVAIL - return EADDRNOTAVAIL; -#else - goto not_there; -#endif - if (strEQ(name, "EAFNOSUPPORT")) -#ifdef EAFNOSUPPORT - return EAFNOSUPPORT; -#else - goto not_there; -#endif - if (strEQ(name, "EAGAIN")) -#ifdef EAGAIN - return EAGAIN; -#else - goto not_there; -#endif - if (strEQ(name, "EALREADY")) -#ifdef EALREADY - return EALREADY; -#else - goto not_there; -#endif - break; - case 'B': - if (strEQ(name, "EBADF")) -#ifdef EBADF - return EBADF; -#else - goto not_there; -#endif - if (strEQ(name, "EBUSY")) -#ifdef EBUSY - return EBUSY; -#else - goto not_there; -#endif - break; - case 'C': - if (strEQ(name, "ECHILD")) -#ifdef ECHILD - return ECHILD; -#else - goto not_there; -#endif - if (strEQ(name, "ECHO")) -#ifdef ECHO - return ECHO; -#else - goto not_there; -#endif - if (strEQ(name, "ECHOE")) -#ifdef ECHOE - return ECHOE; -#else - goto not_there; -#endif - if (strEQ(name, "ECHOK")) -#ifdef ECHOK - return ECHOK; -#else - goto not_there; -#endif - if (strEQ(name, "ECHONL")) -#ifdef ECHONL - return ECHONL; -#else - goto not_there; -#endif - if (strEQ(name, "ECONNABORTED")) -#ifdef ECONNABORTED - return ECONNABORTED; -#else - goto not_there; -#endif - if (strEQ(name, "ECONNREFUSED")) -#ifdef ECONNREFUSED - return ECONNREFUSED; -#else - goto not_there; -#endif - if (strEQ(name, "ECONNRESET")) -#ifdef ECONNRESET - return ECONNRESET; -#else - goto not_there; -#endif - break; - case 'D': - if (strEQ(name, "EDEADLK")) -#ifdef EDEADLK - return EDEADLK; -#else - goto not_there; -#endif - if (strEQ(name, "EDESTADDRREQ")) -#ifdef EDESTADDRREQ - return EDESTADDRREQ; -#else - goto not_there; -#endif - if (strEQ(name, "EDOM")) -#ifdef EDOM - return EDOM; -#else - goto not_there; -#endif - if (strEQ(name, "EDQUOT")) -#ifdef EDQUOT - return EDQUOT; -#else - goto not_there; -#endif - break; - case 'E': - if (strEQ(name, "EEXIST")) -#ifdef EEXIST - return EEXIST; -#else - goto not_there; -#endif - break; - case 'F': - if (strEQ(name, "EFAULT")) -#ifdef EFAULT - return EFAULT; -#else - goto not_there; -#endif - if (strEQ(name, "EFBIG")) -#ifdef EFBIG - return EFBIG; -#else - goto not_there; -#endif - break; - case 'H': - if (strEQ(name, "EHOSTDOWN")) -#ifdef EHOSTDOWN - return EHOSTDOWN; -#else - goto not_there; -#endif - if (strEQ(name, "EHOSTUNREACH")) -#ifdef EHOSTUNREACH - return EHOSTUNREACH; -#else - goto not_there; -#endif - break; - case 'I': - if (strEQ(name, "EINPROGRESS")) -#ifdef EINPROGRESS - return EINPROGRESS; -#else - goto not_there; -#endif - if (strEQ(name, "EINTR")) -#ifdef EINTR - return EINTR; -#else - goto not_there; -#endif - if (strEQ(name, "EINVAL")) -#ifdef EINVAL - return EINVAL; -#else - goto not_there; -#endif - if (strEQ(name, "EIO")) -#ifdef EIO - return EIO; -#else - goto not_there; -#endif - if (strEQ(name, "EISCONN")) -#ifdef EISCONN - return EISCONN; -#else - goto not_there; -#endif - if (strEQ(name, "EISDIR")) -#ifdef EISDIR - return EISDIR; -#else - goto not_there; -#endif - break; - case 'L': - if (strEQ(name, "ELOOP")) -#ifdef ELOOP - return ELOOP; -#else - goto not_there; -#endif - break; - case 'M': - if (strEQ(name, "EMFILE")) -#ifdef EMFILE - return EMFILE; -#else - goto not_there; -#endif - if (strEQ(name, "EMLINK")) -#ifdef EMLINK - return EMLINK; -#else - goto not_there; -#endif - if (strEQ(name, "EMSGSIZE")) -#ifdef EMSGSIZE - return EMSGSIZE; -#else - goto not_there; -#endif - break; - case 'N': - if (strEQ(name, "ENETDOWN")) -#ifdef ENETDOWN - return ENETDOWN; -#else - goto not_there; -#endif - if (strEQ(name, "ENETRESET")) -#ifdef ENETRESET - return ENETRESET; -#else - goto not_there; -#endif - if (strEQ(name, "ENETUNREACH")) -#ifdef ENETUNREACH - return ENETUNREACH; -#else - goto not_there; -#endif - if (strEQ(name, "ENOBUFS")) -#ifdef ENOBUFS - return ENOBUFS; -#else - goto not_there; -#endif - if (strEQ(name, "ENOEXEC")) -#ifdef ENOEXEC - return ENOEXEC; -#else - goto not_there; -#endif - if (strEQ(name, "ENOMEM")) -#ifdef ENOMEM - return ENOMEM; -#else - goto not_there; -#endif - if (strEQ(name, "ENOPROTOOPT")) -#ifdef ENOPROTOOPT - return ENOPROTOOPT; -#else - goto not_there; -#endif - if (strEQ(name, "ENOSPC")) -#ifdef ENOSPC - return ENOSPC; -#else - goto not_there; -#endif - if (strEQ(name, "ENOTBLK")) -#ifdef ENOTBLK - return ENOTBLK; -#else - goto not_there; -#endif - if (strEQ(name, "ENOTCONN")) -#ifdef ENOTCONN - return ENOTCONN; -#else - goto not_there; -#endif - if (strEQ(name, "ENOTDIR")) -#ifdef ENOTDIR - return ENOTDIR; -#else - goto not_there; -#endif - if (strEQ(name, "ENOTEMPTY")) -#ifdef ENOTEMPTY - return ENOTEMPTY; -#else - goto not_there; -#endif - if (strEQ(name, "ENOTSOCK")) -#ifdef ENOTSOCK - return ENOTSOCK; -#else - goto not_there; -#endif - if (strEQ(name, "ENOTTY")) -#ifdef ENOTTY - return ENOTTY; -#else - goto not_there; -#endif - if (strEQ(name, "ENFILE")) -#ifdef ENFILE - return ENFILE; -#else - goto not_there; -#endif - if (strEQ(name, "ENODEV")) -#ifdef ENODEV - return ENODEV; -#else - goto not_there; -#endif - if (strEQ(name, "ENOENT")) -#ifdef ENOENT - return ENOENT; -#else - goto not_there; -#endif - if (strEQ(name, "ENOLCK")) -#ifdef ENOLCK - return ENOLCK; -#else - goto not_there; -#endif - if (strEQ(name, "ENOSYS")) -#ifdef ENOSYS - return ENOSYS; -#else - goto not_there; -#endif - if (strEQ(name, "ENXIO")) -#ifdef ENXIO - return ENXIO; -#else - goto not_there; -#endif - if (strEQ(name, "ENAMETOOLONG")) -#ifdef ENAMETOOLONG - return ENAMETOOLONG; -#else - goto not_there; -#endif - break; - case 'O': - if (strEQ(name, "EOF")) -#ifdef EOF - return EOF; -#else - goto not_there; -#endif - if (strEQ(name, "EOPNOTSUPP")) -#ifdef EOPNOTSUPP - return EOPNOTSUPP; -#else - goto not_there; -#endif - break; - case 'P': - if (strEQ(name, "EPERM")) -#ifdef EPERM - return EPERM; -#else - goto not_there; -#endif - if (strEQ(name, "EPFNOSUPPORT")) -#ifdef EPFNOSUPPORT - return EPFNOSUPPORT; -#else - goto not_there; -#endif - if (strEQ(name, "EPIPE")) -#ifdef EPIPE - return EPIPE; -#else - goto not_there; -#endif - if (strEQ(name, "EPROCLIM")) -#ifdef EPROCLIM - return EPROCLIM; -#else - goto not_there; -#endif - if (strEQ(name, "EPROTONOSUPPORT")) -#ifdef EPROTONOSUPPORT - return EPROTONOSUPPORT; -#else - goto not_there; -#endif - if (strEQ(name, "EPROTOTYPE")) -#ifdef EPROTOTYPE - return EPROTOTYPE; -#else - goto not_there; -#endif - break; - case 'R': - if (strEQ(name, "ERANGE")) -#ifdef ERANGE - return ERANGE; -#else - goto not_there; -#endif - if (strEQ(name, "EREMOTE")) -#ifdef EREMOTE - return EREMOTE; -#else - goto not_there; -#endif - if (strEQ(name, "ERESTART")) -#ifdef ERESTART - return ERESTART; -#else - goto not_there; -#endif - if (strEQ(name, "EROFS")) -#ifdef EROFS - return EROFS; -#else - goto not_there; -#endif - break; - case 'S': - if (strEQ(name, "ESHUTDOWN")) -#ifdef ESHUTDOWN - return ESHUTDOWN; -#else - goto not_there; -#endif - if (strEQ(name, "ESOCKTNOSUPPORT")) -#ifdef ESOCKTNOSUPPORT - return ESOCKTNOSUPPORT; -#else - goto not_there; -#endif - if (strEQ(name, "ESPIPE")) -#ifdef ESPIPE - return ESPIPE; -#else - goto not_there; -#endif - if (strEQ(name, "ESRCH")) -#ifdef ESRCH - return ESRCH; -#else - goto not_there; -#endif - if (strEQ(name, "ESTALE")) -#ifdef ESTALE - return ESTALE; -#else - goto not_there; -#endif - break; - case 'T': - if (strEQ(name, "ETIMEDOUT")) -#ifdef ETIMEDOUT - return ETIMEDOUT; -#else - goto not_there; -#endif - if (strEQ(name, "ETOOMANYREFS")) -#ifdef ETOOMANYREFS - return ETOOMANYREFS; -#else - goto not_there; -#endif - if (strEQ(name, "ETXTBSY")) -#ifdef ETXTBSY - return ETXTBSY; -#else - goto not_there; -#endif - break; - case 'U': - if (strEQ(name, "EUSERS")) -#ifdef EUSERS - return EUSERS; -#else - goto not_there; -#endif - break; - case 'W': - if (strEQ(name, "EWOULDBLOCK")) -#ifdef EWOULDBLOCK - return EWOULDBLOCK; -#else - goto not_there; -#endif - break; - case 'X': - if (strEQ(name, "EXIT_FAILURE")) -#ifdef EXIT_FAILURE - return EXIT_FAILURE; -#else - return 1; -#endif - if (strEQ(name, "EXIT_SUCCESS")) -#ifdef EXIT_SUCCESS - return EXIT_SUCCESS; -#else - return 0; -#endif - if (strEQ(name, "EXDEV")) -#ifdef EXDEV - return EXDEV; -#else - goto not_there; -#endif - break; - } - if (strEQ(name, "E2BIG")) -#ifdef E2BIG - return E2BIG; -#else - goto not_there; -#endif - break; - case 'F': - if (strnEQ(name, "FLT_", 4)) { - if (strEQ(name, "FLT_MAX")) -#ifdef FLT_MAX - return FLT_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "FLT_MIN")) -#ifdef FLT_MIN - return FLT_MIN; -#else - goto not_there; -#endif - if (strEQ(name, "FLT_ROUNDS")) -#ifdef FLT_ROUNDS - return FLT_ROUNDS; -#else - goto not_there; -#endif - if (strEQ(name, "FLT_DIG")) -#ifdef FLT_DIG - return FLT_DIG; -#else - goto not_there; -#endif - if (strEQ(name, "FLT_EPSILON")) -#ifdef FLT_EPSILON - return FLT_EPSILON; -#else - goto not_there; -#endif - if (strEQ(name, "FLT_MANT_DIG")) -#ifdef FLT_MANT_DIG - return FLT_MANT_DIG; -#else - goto not_there; -#endif - if (strEQ(name, "FLT_MAX_10_EXP")) -#ifdef FLT_MAX_10_EXP - return FLT_MAX_10_EXP; -#else - goto not_there; -#endif - if (strEQ(name, "FLT_MAX_EXP")) -#ifdef FLT_MAX_EXP - return FLT_MAX_EXP; -#else - goto not_there; -#endif - if (strEQ(name, "FLT_MIN_10_EXP")) -#ifdef FLT_MIN_10_EXP - return FLT_MIN_10_EXP; -#else - goto not_there; -#endif - if (strEQ(name, "FLT_MIN_EXP")) -#ifdef FLT_MIN_EXP - return FLT_MIN_EXP; -#else - goto not_there; -#endif - if (strEQ(name, "FLT_RADIX")) -#ifdef FLT_RADIX - return FLT_RADIX; -#else - goto not_there; -#endif - break; - } - if (strnEQ(name, "F_", 2)) { - if (strEQ(name, "F_DUPFD")) -#ifdef F_DUPFD - return F_DUPFD; -#else - goto not_there; -#endif - if (strEQ(name, "F_GETFD")) -#ifdef F_GETFD - return F_GETFD; -#else - goto not_there; -#endif - if (strEQ(name, "F_GETFL")) -#ifdef F_GETFL - return F_GETFL; -#else - goto not_there; -#endif - if (strEQ(name, "F_GETLK")) -#ifdef F_GETLK - return F_GETLK; -#else - goto not_there; -#endif - if (strEQ(name, "F_OK")) -#ifdef F_OK - return F_OK; -#else - goto not_there; -#endif - if (strEQ(name, "F_RDLCK")) -#ifdef F_RDLCK - return F_RDLCK; -#else - goto not_there; -#endif - if (strEQ(name, "F_SETFD")) -#ifdef F_SETFD - return F_SETFD; -#else - goto not_there; -#endif - if (strEQ(name, "F_SETFL")) -#ifdef F_SETFL - return F_SETFL; -#else - goto not_there; -#endif - if (strEQ(name, "F_SETLK")) -#ifdef F_SETLK - return F_SETLK; -#else - goto not_there; -#endif - if (strEQ(name, "F_SETLKW")) -#ifdef F_SETLKW - return F_SETLKW; -#else - goto not_there; -#endif - if (strEQ(name, "F_UNLCK")) -#ifdef F_UNLCK - return F_UNLCK; -#else - goto not_there; -#endif - if (strEQ(name, "F_WRLCK")) -#ifdef F_WRLCK - return F_WRLCK; -#else - goto not_there; -#endif - break; - } - if (strEQ(name, "FD_CLOEXEC")) -#ifdef FD_CLOEXEC - return FD_CLOEXEC; -#else - goto not_there; -#endif - if (strEQ(name, "FILENAME_MAX")) -#ifdef FILENAME_MAX - return FILENAME_MAX; -#else - goto not_there; -#endif - break; - case 'H': - if (strEQ(name, "HUGE_VAL")) -#if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL) - /* HUGE_VALL is admittedly non-POSIX but if we are using long doubles - * we might as well use long doubles. --jhi */ - return HUGE_VALL; -#endif -#ifdef HUGE_VAL - return HUGE_VAL; -#else - goto not_there; -#endif - if (strEQ(name, "HUPCL")) -#ifdef HUPCL - return HUPCL; -#else - goto not_there; -#endif - break; - case 'I': - if (strEQ(name, "INT_MAX")) -#ifdef INT_MAX - return INT_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "INT_MIN")) -#ifdef INT_MIN - return INT_MIN; -#else - goto not_there; -#endif - if (strEQ(name, "ICANON")) -#ifdef ICANON - return ICANON; -#else - goto not_there; -#endif - if (strEQ(name, "ICRNL")) -#ifdef ICRNL - return ICRNL; -#else - goto not_there; -#endif - if (strEQ(name, "IEXTEN")) -#ifdef IEXTEN - return IEXTEN; -#else - goto not_there; -#endif - if (strEQ(name, "IGNBRK")) -#ifdef IGNBRK - return IGNBRK; -#else - goto not_there; -#endif - if (strEQ(name, "IGNCR")) -#ifdef IGNCR - return IGNCR; -#else - goto not_there; -#endif - if (strEQ(name, "IGNPAR")) -#ifdef IGNPAR - return IGNPAR; -#else - goto not_there; -#endif - if (strEQ(name, "INLCR")) -#ifdef INLCR - return INLCR; -#else - goto not_there; -#endif - if (strEQ(name, "INPCK")) -#ifdef INPCK - return INPCK; -#else - goto not_there; -#endif - if (strEQ(name, "ISIG")) -#ifdef ISIG - return ISIG; -#else - goto not_there; -#endif - if (strEQ(name, "ISTRIP")) -#ifdef ISTRIP - return ISTRIP; -#else - goto not_there; -#endif - if (strEQ(name, "IXOFF")) -#ifdef IXOFF - return IXOFF; -#else - goto not_there; -#endif - if (strEQ(name, "IXON")) -#ifdef IXON - return IXON; -#else - goto not_there; -#endif - break; - case 'L': - if (strnEQ(name, "LC_", 3)) { - if (strEQ(name, "LC_ALL")) -#ifdef LC_ALL - return LC_ALL; -#else - goto not_there; -#endif - if (strEQ(name, "LC_COLLATE")) -#ifdef LC_COLLATE - return LC_COLLATE; -#else - goto not_there; -#endif - if (strEQ(name, "LC_CTYPE")) -#ifdef LC_CTYPE - return LC_CTYPE; -#else - goto not_there; -#endif - if (strEQ(name, "LC_MONETARY")) -#ifdef LC_MONETARY - return LC_MONETARY; -#else - goto not_there; -#endif - if (strEQ(name, "LC_NUMERIC")) -#ifdef LC_NUMERIC - return LC_NUMERIC; -#else - goto not_there; -#endif - if (strEQ(name, "LC_TIME")) -#ifdef LC_TIME - return LC_TIME; -#else - goto not_there; -#endif - break; - } - if (strnEQ(name, "LDBL_", 5)) { - if (strEQ(name, "LDBL_MAX")) -#ifdef LDBL_MAX - return LDBL_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "LDBL_MIN")) -#ifdef LDBL_MIN - return LDBL_MIN; -#else - goto not_there; -#endif - if (strEQ(name, "LDBL_DIG")) -#ifdef LDBL_DIG - return LDBL_DIG; -#else - goto not_there; -#endif - if (strEQ(name, "LDBL_EPSILON")) -#ifdef LDBL_EPSILON - return LDBL_EPSILON; -#else - goto not_there; -#endif - if (strEQ(name, "LDBL_MANT_DIG")) -#ifdef LDBL_MANT_DIG - return LDBL_MANT_DIG; -#else - goto not_there; -#endif - if (strEQ(name, "LDBL_MAX_10_EXP")) -#ifdef LDBL_MAX_10_EXP - return LDBL_MAX_10_EXP; -#else - goto not_there; -#endif - if (strEQ(name, "LDBL_MAX_EXP")) -#ifdef LDBL_MAX_EXP - return LDBL_MAX_EXP; -#else - goto not_there; -#endif - if (strEQ(name, "LDBL_MIN_10_EXP")) -#ifdef LDBL_MIN_10_EXP - return LDBL_MIN_10_EXP; -#else - goto not_there; -#endif - if (strEQ(name, "LDBL_MIN_EXP")) -#ifdef LDBL_MIN_EXP - return LDBL_MIN_EXP; -#else - goto not_there; -#endif - break; - } - if (strnEQ(name, "L_", 2)) { - if (strEQ(name, "L_ctermid")) -#ifdef L_ctermid - return L_ctermid; -#else - goto not_there; -#endif - if (strEQ(name, "L_cuserid")) -#ifdef L_cuserid - return L_cuserid; -#else - goto not_there; -#endif - /* L_tmpnam[e] was a typo--retained for compatibility */ - if (strEQ(name, "L_tmpname") || strEQ(name, "L_tmpnam")) -#ifdef L_tmpnam - return L_tmpnam; -#else - goto not_there; -#endif - break; - } - if (strEQ(name, "LONG_MAX")) -#ifdef LONG_MAX - return LONG_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "LONG_MIN")) -#ifdef LONG_MIN - return LONG_MIN; -#else - goto not_there; -#endif - if (strEQ(name, "LINK_MAX")) -#ifdef LINK_MAX - return LINK_MAX; -#else - goto not_there; -#endif - break; - case 'M': - if (strEQ(name, "MAX_CANON")) -#ifdef MAX_CANON - return MAX_CANON; -#else - goto not_there; -#endif - if (strEQ(name, "MAX_INPUT")) -#ifdef MAX_INPUT - return MAX_INPUT; -#else - goto not_there; -#endif - if (strEQ(name, "MB_CUR_MAX")) -#ifdef MB_CUR_MAX - return MB_CUR_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "MB_LEN_MAX")) -#ifdef MB_LEN_MAX - return MB_LEN_MAX; -#else - goto not_there; -#endif - break; - case 'N': - if (strEQ(name, "NULL")) return 0; - if (strEQ(name, "NAME_MAX")) -#ifdef NAME_MAX - return NAME_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "NCCS")) -#ifdef NCCS - return NCCS; -#else - goto not_there; -#endif - if (strEQ(name, "NGROUPS_MAX")) -#ifdef NGROUPS_MAX - return NGROUPS_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "NOFLSH")) -#ifdef NOFLSH - return NOFLSH; -#else - goto not_there; -#endif - break; - case 'O': - if (strnEQ(name, "O_", 2)) { - if (strEQ(name, "O_APPEND")) -#ifdef O_APPEND - return O_APPEND; -#else - goto not_there; -#endif - if (strEQ(name, "O_CREAT")) -#ifdef O_CREAT - return O_CREAT; -#else - goto not_there; -#endif - if (strEQ(name, "O_TRUNC")) -#ifdef O_TRUNC - return O_TRUNC; -#else - goto not_there; -#endif - if (strEQ(name, "O_RDONLY")) -#ifdef O_RDONLY - return O_RDONLY; -#else - goto not_there; -#endif - if (strEQ(name, "O_RDWR")) -#ifdef O_RDWR - return O_RDWR; -#else - goto not_there; -#endif - if (strEQ(name, "O_WRONLY")) -#ifdef O_WRONLY - return O_WRONLY; -#else - goto not_there; -#endif - if (strEQ(name, "O_EXCL")) -#ifdef O_EXCL - return O_EXCL; -#else - goto not_there; -#endif - if (strEQ(name, "O_NOCTTY")) -#ifdef O_NOCTTY - return O_NOCTTY; -#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_ACCMODE")) -#ifdef O_ACCMODE - return O_ACCMODE; -#else - goto not_there; -#endif - break; - } - if (strEQ(name, "OPEN_MAX")) -#ifdef OPEN_MAX - return OPEN_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "OPOST")) -#ifdef OPOST - return OPOST; -#else - goto not_there; -#endif - break; - case 'P': - if (strEQ(name, "PATH_MAX")) -#ifdef PATH_MAX - return PATH_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "PARENB")) -#ifdef PARENB - return PARENB; -#else - goto not_there; -#endif - if (strEQ(name, "PARMRK")) -#ifdef PARMRK - return PARMRK; -#else - goto not_there; -#endif - if (strEQ(name, "PARODD")) -#ifdef PARODD - return PARODD; -#else - goto not_there; -#endif - if (strEQ(name, "PIPE_BUF")) -#ifdef PIPE_BUF - return PIPE_BUF; -#else - goto not_there; -#endif - break; - case 'R': - if (strEQ(name, "RAND_MAX")) -#ifdef RAND_MAX - return RAND_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "R_OK")) -#ifdef R_OK - return R_OK; -#else - goto not_there; -#endif - break; - case 'S': - if (strnEQ(name, "SIG", 3)) { - if (name[3] == '_') { - if (strEQ(name, "SIG_BLOCK")) -#ifdef SIG_BLOCK - return SIG_BLOCK; -#else - goto not_there; -#endif -#ifdef SIG_DFL - if (strEQ(name, "SIG_DFL")) return (IV)SIG_DFL; -#endif -#ifdef SIG_ERR - if (strEQ(name, "SIG_ERR")) return (IV)SIG_ERR; -#endif -#ifdef SIG_IGN - if (strEQ(name, "SIG_IGN")) return (IV)SIG_IGN; -#endif - if (strEQ(name, "SIG_SETMASK")) -#ifdef SIG_SETMASK - return SIG_SETMASK; -#else - goto not_there; -#endif - if (strEQ(name, "SIG_UNBLOCK")) -#ifdef SIG_UNBLOCK - return SIG_UNBLOCK; -#else - goto not_there; -#endif - break; - } - if (strEQ(name, "SIGABRT")) -#ifdef SIGABRT - return SIGABRT; -#else - goto not_there; -#endif - if (strEQ(name, "SIGALRM")) -#ifdef SIGALRM - return SIGALRM; -#else - goto not_there; -#endif - if (strEQ(name, "SIGCHLD")) -#ifdef SIGCHLD - return SIGCHLD; -#else - goto not_there; -#endif - if (strEQ(name, "SIGCONT")) -#ifdef SIGCONT - return SIGCONT; -#else - goto not_there; -#endif - if (strEQ(name, "SIGFPE")) -#ifdef SIGFPE - return SIGFPE; -#else - goto not_there; -#endif - if (strEQ(name, "SIGHUP")) -#ifdef SIGHUP - return SIGHUP; -#else - goto not_there; -#endif - if (strEQ(name, "SIGILL")) -#ifdef SIGILL - return SIGILL; -#else - goto not_there; -#endif - if (strEQ(name, "SIGINT")) -#ifdef SIGINT - return SIGINT; -#else - goto not_there; -#endif - if (strEQ(name, "SIGKILL")) -#ifdef SIGKILL - return SIGKILL; -#else - goto not_there; -#endif - if (strEQ(name, "SIGPIPE")) -#ifdef SIGPIPE - return SIGPIPE; -#else - goto not_there; -#endif - if (strEQ(name, "SIGQUIT")) -#ifdef SIGQUIT - return SIGQUIT; -#else - goto not_there; -#endif - if (strEQ(name, "SIGSEGV")) -#ifdef SIGSEGV - return SIGSEGV; -#else - goto not_there; -#endif - if (strEQ(name, "SIGSTOP")) -#ifdef SIGSTOP - return SIGSTOP; -#else - goto not_there; -#endif - if (strEQ(name, "SIGTERM")) -#ifdef SIGTERM - return SIGTERM; -#else - goto not_there; -#endif - if (strEQ(name, "SIGTSTP")) -#ifdef SIGTSTP - return SIGTSTP; -#else - goto not_there; -#endif - if (strEQ(name, "SIGTTIN")) -#ifdef SIGTTIN - return SIGTTIN; -#else - goto not_there; -#endif - if (strEQ(name, "SIGTTOU")) -#ifdef SIGTTOU - return SIGTTOU; -#else - goto not_there; -#endif - if (strEQ(name, "SIGUSR1")) -#ifdef SIGUSR1 - return SIGUSR1; -#else - goto not_there; -#endif - if (strEQ(name, "SIGUSR2")) -#ifdef SIGUSR2 - return SIGUSR2; -#else - goto not_there; -#endif - break; - } - if (name[1] == '_') { - if (strEQ(name, "S_ISGID")) -#ifdef S_ISGID - return S_ISGID; -#else - goto not_there; -#endif - if (strEQ(name, "S_ISUID")) -#ifdef S_ISUID - return S_ISUID; -#else - goto not_there; -#endif - if (strEQ(name, "S_IRGRP")) -#ifdef S_IRGRP - return S_IRGRP; -#else - goto not_there; -#endif - if (strEQ(name, "S_IROTH")) -#ifdef S_IROTH - return S_IROTH; -#else - goto not_there; -#endif - if (strEQ(name, "S_IRUSR")) -#ifdef S_IRUSR - return S_IRUSR; -#else - goto not_there; -#endif - if (strEQ(name, "S_IRWXG")) -#ifdef S_IRWXG - return S_IRWXG; -#else - goto not_there; -#endif - if (strEQ(name, "S_IRWXO")) -#ifdef S_IRWXO - return S_IRWXO; -#else - goto not_there; -#endif - if (strEQ(name, "S_IRWXU")) -#ifdef S_IRWXU - return S_IRWXU; -#else - goto not_there; -#endif - if (strEQ(name, "S_IWGRP")) -#ifdef S_IWGRP - return S_IWGRP; -#else - goto not_there; -#endif - if (strEQ(name, "S_IWOTH")) -#ifdef S_IWOTH - return S_IWOTH; -#else - goto not_there; -#endif - if (strEQ(name, "S_IWUSR")) -#ifdef S_IWUSR - return S_IWUSR; -#else - goto not_there; -#endif - if (strEQ(name, "S_IXGRP")) -#ifdef S_IXGRP - return S_IXGRP; -#else - goto not_there; -#endif - if (strEQ(name, "S_IXOTH")) -#ifdef S_IXOTH - return S_IXOTH; -#else - goto not_there; -#endif - if (strEQ(name, "S_IXUSR")) -#ifdef S_IXUSR - return S_IXUSR; -#else - goto not_there; -#endif - errno = EAGAIN; /* the following aren't constants */ -#ifdef S_ISBLK - if (strEQ(name, "S_ISBLK")) return S_ISBLK(arg); -#endif -#ifdef S_ISCHR - if (strEQ(name, "S_ISCHR")) return S_ISCHR(arg); -#endif -#ifdef S_ISDIR - if (strEQ(name, "S_ISDIR")) return S_ISDIR(arg); -#endif -#ifdef S_ISFIFO - if (strEQ(name, "S_ISFIFO")) return S_ISFIFO(arg); -#endif -#ifdef S_ISREG - if (strEQ(name, "S_ISREG")) return S_ISREG(arg); -#endif - break; - } - if (strEQ(name, "SEEK_CUR")) -#ifdef SEEK_CUR - return SEEK_CUR; -#else - goto not_there; -#endif - if (strEQ(name, "SEEK_END")) -#ifdef SEEK_END - return SEEK_END; -#else - goto not_there; -#endif - if (strEQ(name, "SEEK_SET")) -#ifdef SEEK_SET - return SEEK_SET; -#else - goto not_there; -#endif - if (strEQ(name, "STREAM_MAX")) -#ifdef STREAM_MAX - return STREAM_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "SHRT_MAX")) -#ifdef SHRT_MAX - return SHRT_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "SHRT_MIN")) -#ifdef SHRT_MIN - return SHRT_MIN; -#else - goto not_there; -#endif - if (strnEQ(name, "SA_", 3)) { - if (strEQ(name, "SA_NOCLDSTOP")) -#ifdef SA_NOCLDSTOP - return SA_NOCLDSTOP; -#else - goto not_there; -#endif - if (strEQ(name, "SA_NOCLDWAIT")) -#ifdef SA_NOCLDWAIT - return SA_NOCLDWAIT; -#else - goto not_there; -#endif - if (strEQ(name, "SA_NODEFER")) -#ifdef SA_NODEFER - return SA_NODEFER; -#else - goto not_there; -#endif - if (strEQ(name, "SA_ONSTACK")) -#ifdef SA_ONSTACK - return SA_ONSTACK; -#else - goto not_there; -#endif - if (strEQ(name, "SA_RESETHAND")) -#ifdef SA_RESETHAND - return SA_RESETHAND; -#else - goto not_there; -#endif - if (strEQ(name, "SA_RESTART")) -#ifdef SA_RESTART - return SA_RESTART; -#else - goto not_there; -#endif - if (strEQ(name, "SA_SIGINFO")) -#ifdef SA_SIGINFO - return SA_SIGINFO; -#else - goto not_there; -#endif - break; - } - if (strEQ(name, "SCHAR_MAX")) -#ifdef SCHAR_MAX - return SCHAR_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "SCHAR_MIN")) -#ifdef SCHAR_MIN - return SCHAR_MIN; -#else - goto not_there; -#endif - if (strEQ(name, "SSIZE_MAX")) -#ifdef SSIZE_MAX - return SSIZE_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "STDIN_FILENO")) -#ifdef STDIN_FILENO - return STDIN_FILENO; -#else - goto not_there; -#endif - if (strEQ(name, "STDOUT_FILENO")) -#ifdef STDOUT_FILENO - return STDOUT_FILENO; -#else - goto not_there; -#endif - if (strEQ(name, "STDERR_FILENO")) -#ifdef STDERR_FILENO - return STDERR_FILENO; -#else - goto not_there; -#endif - break; - case 'T': - if (strEQ(name, "TCIFLUSH")) -#ifdef TCIFLUSH - return TCIFLUSH; -#else - goto not_there; -#endif - if (strEQ(name, "TCIOFF")) -#ifdef TCIOFF - return TCIOFF; -#else - goto not_there; -#endif - if (strEQ(name, "TCIOFLUSH")) -#ifdef TCIOFLUSH - return TCIOFLUSH; -#else - goto not_there; -#endif - if (strEQ(name, "TCION")) -#ifdef TCION - return TCION; -#else - goto not_there; -#endif - if (strEQ(name, "TCOFLUSH")) -#ifdef TCOFLUSH - return TCOFLUSH; -#else - goto not_there; -#endif - if (strEQ(name, "TCOOFF")) -#ifdef TCOOFF - return TCOOFF; -#else - goto not_there; -#endif - if (strEQ(name, "TCOON")) -#ifdef TCOON - return TCOON; -#else - goto not_there; -#endif - if (strEQ(name, "TCSADRAIN")) -#ifdef TCSADRAIN - return TCSADRAIN; -#else - goto not_there; -#endif - if (strEQ(name, "TCSAFLUSH")) -#ifdef TCSAFLUSH - return TCSAFLUSH; -#else - goto not_there; -#endif - if (strEQ(name, "TCSANOW")) -#ifdef TCSANOW - return TCSANOW; -#else - goto not_there; -#endif - if (strEQ(name, "TMP_MAX")) -#ifdef TMP_MAX - return TMP_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "TOSTOP")) -#ifdef TOSTOP - return TOSTOP; -#else - goto not_there; -#endif - if (strEQ(name, "TZNAME_MAX")) -#ifdef TZNAME_MAX - return TZNAME_MAX; -#else - goto not_there; -#endif - break; - case 'U': - if (strEQ(name, "UCHAR_MAX")) -#ifdef UCHAR_MAX - return UCHAR_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "UINT_MAX")) -#ifdef UINT_MAX - return UINT_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "ULONG_MAX")) -#ifdef ULONG_MAX - return ULONG_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "USHRT_MAX")) -#ifdef USHRT_MAX - return USHRT_MAX; -#else - goto not_there; -#endif - break; - case 'V': - if (strEQ(name, "VEOF")) -#ifdef VEOF - return VEOF; -#else - goto not_there; -#endif - if (strEQ(name, "VEOL")) -#ifdef VEOL - return VEOL; -#else - goto not_there; -#endif - if (strEQ(name, "VERASE")) -#ifdef VERASE - return VERASE; -#else - goto not_there; -#endif - if (strEQ(name, "VINTR")) -#ifdef VINTR - return VINTR; -#else - goto not_there; -#endif - if (strEQ(name, "VKILL")) -#ifdef VKILL - return VKILL; -#else - goto not_there; -#endif - if (strEQ(name, "VMIN")) -#ifdef VMIN - return VMIN; -#else - goto not_there; -#endif - if (strEQ(name, "VQUIT")) -#ifdef VQUIT - return VQUIT; -#else - goto not_there; -#endif - if (strEQ(name, "VSTART")) -#ifdef VSTART - return VSTART; -#else - goto not_there; -#endif - if (strEQ(name, "VSTOP")) -#ifdef VSTOP - return VSTOP; -#else - goto not_there; -#endif - if (strEQ(name, "VSUSP")) -#ifdef VSUSP - return VSUSP; -#else - goto not_there; -#endif - if (strEQ(name, "VTIME")) -#ifdef VTIME - return VTIME; -#else - goto not_there; -#endif - break; - case 'W': - if (strEQ(name, "W_OK")) -#ifdef W_OK - return W_OK; -#else - goto not_there; -#endif - if (strEQ(name, "WNOHANG")) -#ifdef WNOHANG - return WNOHANG; -#else - goto not_there; -#endif - if (strEQ(name, "WUNTRACED")) -#ifdef WUNTRACED - return WUNTRACED; -#else - goto not_there; -#endif - errno = EAGAIN; /* the following aren't constants */ -#ifdef WEXITSTATUS - if (strEQ(name, "WEXITSTATUS")) return WEXITSTATUS(arg); -#endif -#ifdef WIFEXITED - if (strEQ(name, "WIFEXITED")) return WIFEXITED(arg); -#endif -#ifdef WIFSIGNALED - if (strEQ(name, "WIFSIGNALED")) return WIFSIGNALED(arg); -#endif -#ifdef WIFSTOPPED - if (strEQ(name, "WIFSTOPPED")) return WIFSTOPPED(arg); -#endif -#ifdef WSTOPSIG - if (strEQ(name, "WSTOPSIG")) return WSTOPSIG(arg); -#endif -#ifdef WTERMSIG - if (strEQ(name, "WTERMSIG")) return WTERMSIG(arg); -#endif - break; - case 'X': - if (strEQ(name, "X_OK")) -#ifdef X_OK - return X_OK; -#else - goto not_there; -#endif - break; - case '_': - if (strnEQ(name, "_PC_", 4)) { - if (strEQ(name, "_PC_CHOWN_RESTRICTED")) -#if defined(_PC_CHOWN_RESTRICTED) || HINT_SC_EXIST - return _PC_CHOWN_RESTRICTED; -#else - goto not_there; -#endif - if (strEQ(name, "_PC_LINK_MAX")) -#if defined(_PC_LINK_MAX) || HINT_SC_EXIST - return _PC_LINK_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "_PC_MAX_CANON")) -#if defined(_PC_MAX_CANON) || HINT_SC_EXIST - return _PC_MAX_CANON; -#else - goto not_there; -#endif - if (strEQ(name, "_PC_MAX_INPUT")) -#if defined(_PC_MAX_INPUT) || HINT_SC_EXIST - return _PC_MAX_INPUT; -#else - goto not_there; -#endif - if (strEQ(name, "_PC_NAME_MAX")) -#if defined(_PC_NAME_MAX) || HINT_SC_EXIST - return _PC_NAME_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "_PC_NO_TRUNC")) -#if defined(_PC_NO_TRUNC) || HINT_SC_EXIST - return _PC_NO_TRUNC; -#else - goto not_there; -#endif - if (strEQ(name, "_PC_PATH_MAX")) -#if defined(_PC_PATH_MAX) || HINT_SC_EXIST - return _PC_PATH_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "_PC_PIPE_BUF")) -#if defined(_PC_PIPE_BUF) || HINT_SC_EXIST - return _PC_PIPE_BUF; -#else - goto not_there; -#endif - if (strEQ(name, "_PC_VDISABLE")) -#if defined(_PC_VDISABLE) || HINT_SC_EXIST - return _PC_VDISABLE; -#else - goto not_there; -#endif - break; - } - if (strnEQ(name, "_POSIX_", 7)) { - if (strEQ(name, "_POSIX_ARG_MAX")) -#ifdef _POSIX_ARG_MAX - return _POSIX_ARG_MAX; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_CHILD_MAX")) -#ifdef _POSIX_CHILD_MAX - return _POSIX_CHILD_MAX; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_CHOWN_RESTRICTED")) -#ifdef _POSIX_CHOWN_RESTRICTED - return _POSIX_CHOWN_RESTRICTED; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_JOB_CONTROL")) -#ifdef _POSIX_JOB_CONTROL - return _POSIX_JOB_CONTROL; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_LINK_MAX")) -#ifdef _POSIX_LINK_MAX - return _POSIX_LINK_MAX; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_MAX_CANON")) -#ifdef _POSIX_MAX_CANON - return _POSIX_MAX_CANON; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_MAX_INPUT")) -#ifdef _POSIX_MAX_INPUT - return _POSIX_MAX_INPUT; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_NAME_MAX")) -#ifdef _POSIX_NAME_MAX - return _POSIX_NAME_MAX; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_NGROUPS_MAX")) -#ifdef _POSIX_NGROUPS_MAX - return _POSIX_NGROUPS_MAX; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_NO_TRUNC")) -#ifdef _POSIX_NO_TRUNC - return _POSIX_NO_TRUNC; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_OPEN_MAX")) -#ifdef _POSIX_OPEN_MAX - return _POSIX_OPEN_MAX; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_PATH_MAX")) -#ifdef _POSIX_PATH_MAX - return _POSIX_PATH_MAX; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_PIPE_BUF")) -#ifdef _POSIX_PIPE_BUF - return _POSIX_PIPE_BUF; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_SAVED_IDS")) -#ifdef _POSIX_SAVED_IDS - return _POSIX_SAVED_IDS; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_SSIZE_MAX")) -#ifdef _POSIX_SSIZE_MAX - return _POSIX_SSIZE_MAX; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_STREAM_MAX")) -#ifdef _POSIX_STREAM_MAX - return _POSIX_STREAM_MAX; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_TZNAME_MAX")) -#ifdef _POSIX_TZNAME_MAX - return _POSIX_TZNAME_MAX; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_VDISABLE")) -#ifdef _POSIX_VDISABLE - return _POSIX_VDISABLE; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_VERSION")) -#ifdef _POSIX_VERSION - return _POSIX_VERSION; -#else - return 0; -#endif - break; - } - if (strnEQ(name, "_SC_", 4)) { - if (strEQ(name, "_SC_ARG_MAX")) -#if defined(_SC_ARG_MAX) || HINT_SC_EXIST - return _SC_ARG_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "_SC_CHILD_MAX")) -#if defined(_SC_CHILD_MAX) || HINT_SC_EXIST - return _SC_CHILD_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "_SC_CLK_TCK")) -#if defined(_SC_CLK_TCK) || HINT_SC_EXIST - return _SC_CLK_TCK; -#else - goto not_there; -#endif - if (strEQ(name, "_SC_JOB_CONTROL")) -#if defined(_SC_JOB_CONTROL) || HINT_SC_EXIST - return _SC_JOB_CONTROL; -#else - goto not_there; -#endif - if (strEQ(name, "_SC_NGROUPS_MAX")) -#if defined(_SC_NGROUPS_MAX) || HINT_SC_EXIST - return _SC_NGROUPS_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "_SC_OPEN_MAX")) -#if defined(_SC_OPEN_MAX) || HINT_SC_EXIST - return _SC_OPEN_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "_SC_SAVED_IDS")) -#if defined(_SC_SAVED_IDS) || HINT_SC_EXIST - return _SC_SAVED_IDS; -#else - goto not_there; -#endif - if (strEQ(name, "_SC_STREAM_MAX")) -#if defined(_SC_STREAM_MAX) || HINT_SC_EXIST - return _SC_STREAM_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "_SC_TZNAME_MAX")) -#if defined(_SC_TZNAME_MAX) || HINT_SC_EXIST - return _SC_TZNAME_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "_SC_VERSION")) -#if defined(_SC_VERSION) || HINT_SC_EXIST - return _SC_VERSION; -#else - goto not_there; -#endif - break; - } - } - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - -MODULE = SigSet PACKAGE = POSIX::SigSet PREFIX = sig - -POSIX::SigSet -new(packname = "POSIX::SigSet", ...) - char * packname - CODE: - { - int i; - New(0, RETVAL, 1, sigset_t); - sigemptyset(RETVAL); - for (i = 1; i < items; i++) - sigaddset(RETVAL, SvIV(ST(i))); - } - OUTPUT: - RETVAL - -void -DESTROY(sigset) - POSIX::SigSet sigset - CODE: - Safefree(sigset); - -SysRet -sigaddset(sigset, sig) - POSIX::SigSet sigset - int sig - -SysRet -sigdelset(sigset, sig) - POSIX::SigSet sigset - int sig - -SysRet -sigemptyset(sigset) - POSIX::SigSet sigset - -SysRet -sigfillset(sigset) - POSIX::SigSet sigset - -int -sigismember(sigset, sig) - POSIX::SigSet sigset - int sig - - -MODULE = Termios PACKAGE = POSIX::Termios PREFIX = cf - -POSIX::Termios -new(packname = "POSIX::Termios", ...) - char * packname - CODE: - { -#ifdef I_TERMIOS - New(0, RETVAL, 1, struct termios); -#else - not_here("termios"); - RETVAL = 0; -#endif - } - OUTPUT: - RETVAL - -void -DESTROY(termios_ref) - POSIX::Termios termios_ref - CODE: -#ifdef I_TERMIOS - Safefree(termios_ref); -#else - not_here("termios"); -#endif - -SysRet -getattr(termios_ref, fd = 0) - POSIX::Termios termios_ref - int fd - CODE: - RETVAL = tcgetattr(fd, termios_ref); - OUTPUT: - RETVAL - -SysRet -setattr(termios_ref, fd = 0, optional_actions = 0) - POSIX::Termios termios_ref - int fd - int optional_actions - CODE: - RETVAL = tcsetattr(fd, optional_actions, termios_ref); - OUTPUT: - RETVAL - -speed_t -cfgetispeed(termios_ref) - POSIX::Termios termios_ref - -speed_t -cfgetospeed(termios_ref) - POSIX::Termios termios_ref - -tcflag_t -getiflag(termios_ref) - POSIX::Termios termios_ref - CODE: -#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ - RETVAL = termios_ref->c_iflag; -#else - not_here("getiflag"); - RETVAL = 0; -#endif - OUTPUT: - RETVAL - -tcflag_t -getoflag(termios_ref) - POSIX::Termios termios_ref - CODE: -#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ - RETVAL = termios_ref->c_oflag; -#else - not_here("getoflag"); - RETVAL = 0; -#endif - OUTPUT: - RETVAL - -tcflag_t -getcflag(termios_ref) - POSIX::Termios termios_ref - CODE: -#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ - RETVAL = termios_ref->c_cflag; -#else - not_here("getcflag"); - RETVAL = 0; -#endif - OUTPUT: - RETVAL - -tcflag_t -getlflag(termios_ref) - POSIX::Termios termios_ref - CODE: -#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ - RETVAL = termios_ref->c_lflag; -#else - not_here("getlflag"); - RETVAL = 0; -#endif - OUTPUT: - RETVAL - -cc_t -getcc(termios_ref, ccix) - POSIX::Termios termios_ref - int ccix - CODE: -#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ - if (ccix >= NCCS) - croak("Bad getcc subscript"); - RETVAL = termios_ref->c_cc[ccix]; -#else - not_here("getcc"); - RETVAL = 0; -#endif - OUTPUT: - RETVAL - -SysRet -cfsetispeed(termios_ref, speed) - POSIX::Termios termios_ref - speed_t speed - -SysRet -cfsetospeed(termios_ref, speed) - POSIX::Termios termios_ref - speed_t speed - -void -setiflag(termios_ref, iflag) - POSIX::Termios termios_ref - tcflag_t iflag - CODE: -#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ - termios_ref->c_iflag = iflag; -#else - not_here("setiflag"); -#endif - -void -setoflag(termios_ref, oflag) - POSIX::Termios termios_ref - tcflag_t oflag - CODE: -#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ - termios_ref->c_oflag = oflag; -#else - not_here("setoflag"); -#endif - -void -setcflag(termios_ref, cflag) - POSIX::Termios termios_ref - tcflag_t cflag - CODE: -#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ - termios_ref->c_cflag = cflag; -#else - not_here("setcflag"); -#endif - -void -setlflag(termios_ref, lflag) - POSIX::Termios termios_ref - tcflag_t lflag - CODE: -#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ - termios_ref->c_lflag = lflag; -#else - not_here("setlflag"); -#endif - -void -setcc(termios_ref, ccix, cc) - POSIX::Termios termios_ref - int ccix - cc_t cc - CODE: -#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ - if (ccix >= NCCS) - croak("Bad setcc subscript"); - termios_ref->c_cc[ccix] = cc; -#else - not_here("setcc"); -#endif - - -MODULE = POSIX PACKAGE = POSIX - -NV -constant(name,arg) - char * name - int arg - -int -isalnum(charstring) - unsigned char * charstring - CODE: - unsigned char *s = charstring; - unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ - for (RETVAL = 1; RETVAL && s < e; s++) - if (!isalnum(*s)) - RETVAL = 0; - OUTPUT: - RETVAL - -int -isalpha(charstring) - unsigned char * charstring - CODE: - unsigned char *s = charstring; - unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ - for (RETVAL = 1; RETVAL && s < e; s++) - if (!isalpha(*s)) - RETVAL = 0; - OUTPUT: - RETVAL - -int -iscntrl(charstring) - unsigned char * charstring - CODE: - unsigned char *s = charstring; - unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ - for (RETVAL = 1; RETVAL && s < e; s++) - if (!iscntrl(*s)) - RETVAL = 0; - OUTPUT: - RETVAL - -int -isdigit(charstring) - unsigned char * charstring - CODE: - unsigned char *s = charstring; - unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ - for (RETVAL = 1; RETVAL && s < e; s++) - if (!isdigit(*s)) - RETVAL = 0; - OUTPUT: - RETVAL - -int -isgraph(charstring) - unsigned char * charstring - CODE: - unsigned char *s = charstring; - unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ - for (RETVAL = 1; RETVAL && s < e; s++) - if (!isgraph(*s)) - RETVAL = 0; - OUTPUT: - RETVAL - -int -islower(charstring) - unsigned char * charstring - CODE: - unsigned char *s = charstring; - unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ - for (RETVAL = 1; RETVAL && s < e; s++) - if (!islower(*s)) - RETVAL = 0; - OUTPUT: - RETVAL - -int -isprint(charstring) - unsigned char * charstring - CODE: - unsigned char *s = charstring; - unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ - for (RETVAL = 1; RETVAL && s < e; s++) - if (!isprint(*s)) - RETVAL = 0; - OUTPUT: - RETVAL - -int -ispunct(charstring) - unsigned char * charstring - CODE: - unsigned char *s = charstring; - unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ - for (RETVAL = 1; RETVAL && s < e; s++) - if (!ispunct(*s)) - RETVAL = 0; - OUTPUT: - RETVAL - -int -isspace(charstring) - unsigned char * charstring - CODE: - unsigned char *s = charstring; - unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ - for (RETVAL = 1; RETVAL && s < e; s++) - if (!isspace(*s)) - RETVAL = 0; - OUTPUT: - RETVAL - -int -isupper(charstring) - unsigned char * charstring - CODE: - unsigned char *s = charstring; - unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ - for (RETVAL = 1; RETVAL && s < e; s++) - if (!isupper(*s)) - RETVAL = 0; - OUTPUT: - RETVAL - -int -isxdigit(charstring) - unsigned char * charstring - CODE: - unsigned char *s = charstring; - unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ - for (RETVAL = 1; RETVAL && s < e; s++) - if (!isxdigit(*s)) - RETVAL = 0; - OUTPUT: - RETVAL - -SysRet -open(filename, flags = O_RDONLY, mode = 0666) - char * filename - int flags - Mode_t mode - CODE: - if (flags & (O_APPEND|O_CREAT|O_TRUNC|O_RDWR|O_WRONLY|O_EXCL)) - TAINT_PROPER("open"); - RETVAL = open(filename, flags, mode); - OUTPUT: - RETVAL - - -HV * -localeconv() - CODE: -#ifdef HAS_LOCALECONV - struct lconv *lcbuf; - RETVAL = newHV(); - if ((lcbuf = localeconv())) { - /* the strings */ - if (lcbuf->decimal_point && *lcbuf->decimal_point) - hv_store(RETVAL, "decimal_point", 13, - newSVpv(lcbuf->decimal_point, 0), 0); - if (lcbuf->thousands_sep && *lcbuf->thousands_sep) - hv_store(RETVAL, "thousands_sep", 13, - newSVpv(lcbuf->thousands_sep, 0), 0); -#ifndef NO_LOCALECONV_GROUPING - if (lcbuf->grouping && *lcbuf->grouping) - hv_store(RETVAL, "grouping", 8, - newSVpv(lcbuf->grouping, 0), 0); -#endif - if (lcbuf->int_curr_symbol && *lcbuf->int_curr_symbol) - hv_store(RETVAL, "int_curr_symbol", 15, - newSVpv(lcbuf->int_curr_symbol, 0), 0); - if (lcbuf->currency_symbol && *lcbuf->currency_symbol) - hv_store(RETVAL, "currency_symbol", 15, - newSVpv(lcbuf->currency_symbol, 0), 0); - if (lcbuf->mon_decimal_point && *lcbuf->mon_decimal_point) - hv_store(RETVAL, "mon_decimal_point", 17, - newSVpv(lcbuf->mon_decimal_point, 0), 0); -#ifndef NO_LOCALECONV_MON_THOUSANDS_SEP - if (lcbuf->mon_thousands_sep && *lcbuf->mon_thousands_sep) - hv_store(RETVAL, "mon_thousands_sep", 17, - newSVpv(lcbuf->mon_thousands_sep, 0), 0); -#endif -#ifndef NO_LOCALECONV_MON_GROUPING - if (lcbuf->mon_grouping && *lcbuf->mon_grouping) - hv_store(RETVAL, "mon_grouping", 12, - newSVpv(lcbuf->mon_grouping, 0), 0); -#endif - if (lcbuf->positive_sign && *lcbuf->positive_sign) - hv_store(RETVAL, "positive_sign", 13, - newSVpv(lcbuf->positive_sign, 0), 0); - if (lcbuf->negative_sign && *lcbuf->negative_sign) - hv_store(RETVAL, "negative_sign", 13, - newSVpv(lcbuf->negative_sign, 0), 0); - /* the integers */ - if (lcbuf->int_frac_digits != CHAR_MAX) - hv_store(RETVAL, "int_frac_digits", 15, - newSViv(lcbuf->int_frac_digits), 0); - if (lcbuf->frac_digits != CHAR_MAX) - hv_store(RETVAL, "frac_digits", 11, - newSViv(lcbuf->frac_digits), 0); - if (lcbuf->p_cs_precedes != CHAR_MAX) - hv_store(RETVAL, "p_cs_precedes", 13, - newSViv(lcbuf->p_cs_precedes), 0); - if (lcbuf->p_sep_by_space != CHAR_MAX) - hv_store(RETVAL, "p_sep_by_space", 14, - newSViv(lcbuf->p_sep_by_space), 0); - if (lcbuf->n_cs_precedes != CHAR_MAX) - hv_store(RETVAL, "n_cs_precedes", 13, - newSViv(lcbuf->n_cs_precedes), 0); - if (lcbuf->n_sep_by_space != CHAR_MAX) - hv_store(RETVAL, "n_sep_by_space", 14, - newSViv(lcbuf->n_sep_by_space), 0); - if (lcbuf->p_sign_posn != CHAR_MAX) - hv_store(RETVAL, "p_sign_posn", 11, - newSViv(lcbuf->p_sign_posn), 0); - if (lcbuf->n_sign_posn != CHAR_MAX) - hv_store(RETVAL, "n_sign_posn", 11, - newSViv(lcbuf->n_sign_posn), 0); - } -#else - localeconv(); /* A stub to call not_here(). */ -#endif - OUTPUT: - RETVAL - -char * -setlocale(category, locale = 0) - int category - char * locale - CODE: - RETVAL = setlocale(category, locale); - if (RETVAL) { -#ifdef USE_LOCALE_CTYPE - if (category == LC_CTYPE -#ifdef LC_ALL - || category == LC_ALL -#endif - ) - { - char *newctype; -#ifdef LC_ALL - if (category == LC_ALL) - newctype = setlocale(LC_CTYPE, NULL); - else -#endif - newctype = RETVAL; - new_ctype(newctype); - } -#endif /* USE_LOCALE_CTYPE */ -#ifdef USE_LOCALE_COLLATE - if (category == LC_COLLATE -#ifdef LC_ALL - || category == LC_ALL -#endif - ) - { - char *newcoll; -#ifdef LC_ALL - if (category == LC_ALL) - newcoll = setlocale(LC_COLLATE, NULL); - else -#endif - newcoll = RETVAL; - new_collate(newcoll); - } -#endif /* USE_LOCALE_COLLATE */ -#ifdef USE_LOCALE_NUMERIC - if (category == LC_NUMERIC -#ifdef LC_ALL - || category == LC_ALL -#endif - ) - { - char *newnum; -#ifdef LC_ALL - if (category == LC_ALL) - newnum = setlocale(LC_NUMERIC, NULL); - else -#endif - newnum = RETVAL; - new_numeric(newnum); - } -#endif /* USE_LOCALE_NUMERIC */ - } - OUTPUT: - RETVAL - - -NV -acos(x) - NV x - -NV -asin(x) - NV x - -NV -atan(x) - NV x - -NV -ceil(x) - NV x - -NV -cosh(x) - NV x - -NV -floor(x) - NV x - -NV -fmod(x,y) - NV x - NV y - -void -frexp(x) - NV x - PPCODE: - int expvar; - /* (We already know stack is long enough.) */ - PUSHs(sv_2mortal(newSVnv(frexp(x,&expvar)))); - PUSHs(sv_2mortal(newSViv(expvar))); - -NV -ldexp(x,exp) - NV x - int exp - -NV -log10(x) - NV x - -void -modf(x) - NV x - PPCODE: - NV intvar; - /* (We already know stack is long enough.) */ - PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar)))); - PUSHs(sv_2mortal(newSVnv(intvar))); - -NV -sinh(x) - NV x - -NV -tan(x) - NV x - -NV -tanh(x) - NV x - -SysRet -sigaction(sig, action, oldaction = 0) - int sig - POSIX::SigAction action - POSIX::SigAction oldaction - CODE: -#ifdef WIN32 - RETVAL = not_here("sigaction"); -#else -# This code is really grody because we're trying to make the signal -# interface look beautiful, which is hard. - - { - GV *siggv = gv_fetchpv("SIG", TRUE, SVt_PVHV); - struct sigaction act; - struct sigaction oact; - POSIX__SigSet sigset; - SV** svp; - SV** sigsvp = hv_fetch(GvHVn(siggv), - PL_sig_name[sig], - strlen(PL_sig_name[sig]), - TRUE); - STRLEN n_a; - - /* Remember old handler name if desired. */ - if (oldaction) { - char *hand = SvPVx(*sigsvp, n_a); - svp = hv_fetch(oldaction, "HANDLER", 7, TRUE); - sv_setpv(*svp, *hand ? hand : "DEFAULT"); - } - - if (action) { - /* Vector new handler through %SIG. (We always use sighandler - for the C signal handler, which reads %SIG to dispatch.) */ - svp = hv_fetch(action, "HANDLER", 7, FALSE); - if (!svp) - croak("Can't supply an action without a HANDLER"); - sv_setpv(*sigsvp, SvPV(*svp, n_a)); - mg_set(*sigsvp); /* handles DEFAULT and IGNORE */ - act.sa_handler = PL_sighandlerp; - - /* Set up any desired mask. */ - svp = hv_fetch(action, "MASK", 4, FALSE); - if (svp && sv_isa(*svp, "POSIX::SigSet")) { - IV tmp = SvIV((SV*)SvRV(*svp)); - sigset = INT2PTR(sigset_t*, tmp); - act.sa_mask = *sigset; - } - else - sigemptyset(& act.sa_mask); - - /* Set up any desired flags. */ - svp = hv_fetch(action, "FLAGS", 5, FALSE); - act.sa_flags = svp ? SvIV(*svp) : 0; - } - - /* Now work around sigaction oddities */ - if (action && oldaction) - RETVAL = sigaction(sig, & act, & oact); - else if (action) - RETVAL = sigaction(sig, & act, (struct sigaction *)0); - else if (oldaction) - RETVAL = sigaction(sig, (struct sigaction *)0, & oact); - else - RETVAL = -1; - - if (oldaction) { - /* Get back the mask. */ - svp = hv_fetch(oldaction, "MASK", 4, TRUE); - if (sv_isa(*svp, "POSIX::SigSet")) { - IV tmp = SvIV((SV*)SvRV(*svp)); - sigset = INT2PTR(sigset_t*, tmp); - } - else { - New(0, sigset, 1, sigset_t); - sv_setptrobj(*svp, sigset, "POSIX::SigSet"); - } - *sigset = oact.sa_mask; - - /* Get back the flags. */ - svp = hv_fetch(oldaction, "FLAGS", 5, TRUE); - sv_setiv(*svp, oact.sa_flags); - } - } -#endif - OUTPUT: - RETVAL - -SysRet -sigpending(sigset) - POSIX::SigSet sigset - -SysRet -sigprocmask(how, sigset, oldsigset = 0) - int how - POSIX::SigSet sigset - POSIX::SigSet oldsigset = NO_INIT -INIT: - if ( items < 3 ) { - oldsigset = 0; - } - else if (sv_derived_from(ST(2), "POSIX::SigSet")) { - IV tmp = SvIV((SV*)SvRV(ST(2))); - oldsigset = INT2PTR(POSIX__SigSet,tmp); - } - else { - New(0, oldsigset, 1, sigset_t); - sigemptyset(oldsigset); - sv_setref_pv(ST(2), "POSIX::SigSet", (void*)oldsigset); - } - -SysRet -sigsuspend(signal_mask) - POSIX::SigSet signal_mask - -void -_exit(status) - int status - -SysRet -close(fd) - int fd - -SysRet -dup(fd) - int fd - -SysRet -dup2(fd1, fd2) - int fd1 - int fd2 - -SysRetLong -lseek(fd, offset, whence) - int fd - Off_t offset - int whence - -SysRet -nice(incr) - int incr - -void -pipe() - PPCODE: - int fds[2]; - if (pipe(fds) != -1) { - EXTEND(SP,2); - PUSHs(sv_2mortal(newSViv(fds[0]))); - PUSHs(sv_2mortal(newSViv(fds[1]))); - } - -SysRet -read(fd, buffer, nbytes) - PREINIT: - SV *sv_buffer = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1); - INPUT: - int fd - size_t nbytes - char * buffer = sv_grow( sv_buffer, nbytes+1 ); - CLEANUP: - if (RETVAL >= 0) { - SvCUR(sv_buffer) = RETVAL; - SvPOK_only(sv_buffer); - *SvEND(sv_buffer) = '\0'; - SvTAINTED_on(sv_buffer); - } - -SysRet -setpgid(pid, pgid) - pid_t pid - pid_t pgid - -pid_t -setsid() - -pid_t -tcgetpgrp(fd) - int fd - -SysRet -tcsetpgrp(fd, pgrp_id) - int fd - pid_t pgrp_id - -void -uname() - PPCODE: -#ifdef HAS_UNAME - struct utsname buf; - if (uname(&buf) >= 0) { - EXTEND(SP, 5); - PUSHs(sv_2mortal(newSVpv(buf.sysname, 0))); - PUSHs(sv_2mortal(newSVpv(buf.nodename, 0))); - PUSHs(sv_2mortal(newSVpv(buf.release, 0))); - PUSHs(sv_2mortal(newSVpv(buf.version, 0))); - PUSHs(sv_2mortal(newSVpv(buf.machine, 0))); - } -#else - uname((char *) 0); /* A stub to call not_here(). */ -#endif - -SysRet -write(fd, buffer, nbytes) - int fd - char * buffer - size_t nbytes - -SV * -tmpnam() - PREINIT: - STRLEN i; - int len; - CODE: - RETVAL = newSVpvn("", 0); - SvGROW(RETVAL, L_tmpnam); - len = strlen(tmpnam(SvPV(RETVAL, i))); - SvCUR_set(RETVAL, len); - OUTPUT: - RETVAL - -void -abort() - -int -mblen(s, n) - char * s - size_t n - -size_t -mbstowcs(s, pwcs, n) - wchar_t * s - char * pwcs - size_t n - -int -mbtowc(pwc, s, n) - wchar_t * pwc - char * s - size_t n - -int -wcstombs(s, pwcs, n) - char * s - wchar_t * pwcs - size_t n - -int -wctomb(s, wchar) - char * s - wchar_t wchar - -int -strcoll(s1, s2) - char * s1 - char * s2 - -void -strtod(str) - char * str - PREINIT: - double num; - char *unparsed; - PPCODE: - SET_NUMERIC_LOCAL(); - num = strtod(str, &unparsed); - PUSHs(sv_2mortal(newSVnv(num))); - if (GIMME == G_ARRAY) { - EXTEND(SP, 1); - if (unparsed) - PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); - else - PUSHs(&PL_sv_undef); - } - -void -strtol(str, base = 0) - char * str - int base - PREINIT: - long num; - char *unparsed; - PPCODE: - num = strtol(str, &unparsed, base); -#if IVSIZE <= LONGSIZE - if (num < IV_MIN || num > IV_MAX) - PUSHs(sv_2mortal(newSVnv((double)num))); - else -#endif - PUSHs(sv_2mortal(newSViv((IV)num))); - if (GIMME == G_ARRAY) { - EXTEND(SP, 1); - if (unparsed) - PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); - else - PUSHs(&PL_sv_undef); - } - -void -strtoul(str, base = 0) - char * str - int base - PREINIT: - unsigned long num; - char *unparsed; - PPCODE: - num = strtoul(str, &unparsed, base); - if (num <= IV_MAX) - PUSHs(sv_2mortal(newSViv((IV)num))); - else - PUSHs(sv_2mortal(newSVnv((double)num))); - if (GIMME == G_ARRAY) { - EXTEND(SP, 1); - if (unparsed) - PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); - else - PUSHs(&PL_sv_undef); - } - -void -strxfrm(src) - SV * src - CODE: - { - STRLEN srclen; - STRLEN dstlen; - char *p = SvPV(src,srclen); - srclen++; - ST(0) = sv_2mortal(NEWSV(800,srclen)); - dstlen = strxfrm(SvPVX(ST(0)), p, (size_t)srclen); - if (dstlen > srclen) { - dstlen++; - SvGROW(ST(0), dstlen); - strxfrm(SvPVX(ST(0)), p, (size_t)dstlen); - dstlen--; - } - SvCUR(ST(0)) = dstlen; - SvPOK_only(ST(0)); - } - -SysRet -mkfifo(filename, mode) - char * filename - Mode_t mode - CODE: - TAINT_PROPER("mkfifo"); - RETVAL = mkfifo(filename, mode); - OUTPUT: - RETVAL - -SysRet -tcdrain(fd) - int fd - - -SysRet -tcflow(fd, action) - int fd - int action - - -SysRet -tcflush(fd, queue_selector) - int fd - int queue_selector - -SysRet -tcsendbreak(fd, duration) - int fd - int duration - -char * -asctime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0) - int sec - int min - int hour - int mday - int mon - int year - int wday - int yday - int isdst - CODE: - { - struct tm mytm; - init_tm(&mytm); /* XXX workaround - see init_tm() above */ - mytm.tm_sec = sec; - mytm.tm_min = min; - mytm.tm_hour = hour; - mytm.tm_mday = mday; - mytm.tm_mon = mon; - mytm.tm_year = year; - mytm.tm_wday = wday; - mytm.tm_yday = yday; - mytm.tm_isdst = isdst; - RETVAL = asctime(&mytm); - } - OUTPUT: - RETVAL - -long -clock() - -char * -ctime(time) - Time_t &time - -void -times() - PPCODE: - struct tms tms; - clock_t realtime; - realtime = times( &tms ); - EXTEND(SP,5); - PUSHs( sv_2mortal( newSViv( (IV) realtime ) ) ); - PUSHs( sv_2mortal( newSViv( (IV) tms.tms_utime ) ) ); - PUSHs( sv_2mortal( newSViv( (IV) tms.tms_stime ) ) ); - PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cutime ) ) ); - PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cstime ) ) ); - -double -difftime(time1, time2) - Time_t time1 - Time_t time2 - -SysRetLong -mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0) - int sec - int min - int hour - int mday - int mon - int year - int wday - int yday - int isdst - CODE: - { - struct tm mytm; - init_tm(&mytm); /* XXX workaround - see init_tm() above */ - mytm.tm_sec = sec; - mytm.tm_min = min; - mytm.tm_hour = hour; - mytm.tm_mday = mday; - mytm.tm_mon = mon; - mytm.tm_year = year; - mytm.tm_wday = wday; - mytm.tm_yday = yday; - mytm.tm_isdst = isdst; - RETVAL = mktime(&mytm); - } - OUTPUT: - RETVAL - -#XXX: if $xsubpp::WantOptimize is always the default -# sv_setpv(TARG, ...) could be used rather than -# ST(0) = sv_2mortal(newSVpv(...)) -void -strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1) - char * fmt - int sec - int min - int hour - int mday - int mon - int year - int wday - int yday - int isdst - CODE: - { - char tmpbuf[128]; - struct tm mytm; - int len; -#ifdef __FreeBSD__ - long sgmtoff; - int sisdst; - char *szone; -#endif - init_tm(&mytm); /* XXX workaround - see init_tm() above */ - mytm.tm_sec = sec; - mytm.tm_min = min; - mytm.tm_hour = hour; - mytm.tm_mday = mday; - mytm.tm_mon = mon; - mytm.tm_year = year; - mytm.tm_wday = wday; - mytm.tm_yday = yday; - mytm.tm_isdst = isdst; -#ifdef __FreeBSD__ - sgmtoff = mytm.tm_gmtoff; - sisdst = mytm.tm_isdst; - szone = mytm.tm_zone; - /* to prevent mess with shifted hours/days/etc. */ - (void) timegm(&mytm); - mytm.tm_gmtoff = sgmtoff; - mytm.tm_isdst = sisdst; - mytm.tm_zone = szone; -#else - mini_mktime(&mytm); -#endif - len = strftime(tmpbuf, sizeof tmpbuf, fmt, &mytm); - /* - ** The following is needed to handle to the situation where - ** tmpbuf overflows. Basically we want to allocate a buffer - ** and try repeatedly. The reason why it is so complicated - ** is that getting a return value of 0 from strftime can indicate - ** one of the following: - ** 1. buffer overflowed, - ** 2. illegal conversion specifier, or - ** 3. the format string specifies nothing to be returned(not - ** an error). This could be because format is an empty string - ** or it specifies %p that yields an empty string in some locale. - ** If there is a better way to make it portable, go ahead by - ** all means. - */ - if ((len > 0 && len < sizeof(tmpbuf)) || (len == 0 && *fmt == '\0')) - ST(0) = sv_2mortal(newSVpv(tmpbuf, len)); - else { - /* Possibly buf overflowed - try again with a bigger buf */ - int fmtlen = strlen(fmt); - int bufsize = fmtlen + sizeof(tmpbuf); - char* buf; - int buflen; - - New(0, buf, bufsize, char); - while (buf) { - buflen = strftime(buf, bufsize, fmt, &mytm); - if (buflen > 0 && buflen < bufsize) - break; - /* heuristic to prevent out-of-memory errors */ - if (bufsize > 100*fmtlen) { - Safefree(buf); - buf = NULL; - break; - } - bufsize *= 2; - Renew(buf, bufsize, char); - } - if (buf) { - ST(0) = sv_2mortal(newSVpvn(buf, buflen)); - Safefree(buf); - } - else - ST(0) = sv_2mortal(newSVpvn(tmpbuf, len)); - } - } - -void -tzset() - -void -tzname() - PPCODE: - EXTEND(SP,2); - PUSHs(sv_2mortal(newSVpvn(tzname[0],strlen(tzname[0])))); - PUSHs(sv_2mortal(newSVpvn(tzname[1],strlen(tzname[1])))); - -SysRet -access(filename, mode) - char * filename - Mode_t mode - -char * -ctermid(s = 0) - char * s = 0; - -char * -cuserid(s = 0) - char * s = 0; - -SysRetLong -fpathconf(fd, name) - int fd - int name - -SysRetLong -pathconf(filename, name) - char * filename - int name - -SysRet -pause() - -SysRetLong -sysconf(name) - int name - -char * -ttyname(fd) - int fd diff --git a/contrib/perl5/ext/POSIX/hints/bsdos.pl b/contrib/perl5/ext/POSIX/hints/bsdos.pl deleted file mode 100644 index 62732ac..0000000 --- a/contrib/perl5/ext/POSIX/hints/bsdos.pl +++ /dev/null @@ -1,3 +0,0 @@ -# BSD platforms have extra fields in struct tm that need to be initialized. -# XXX A Configure test is needed. -$self->{CCFLAGS} = $Config{ccflags} . ' -DSTRUCT_TM_HASZONE' ; diff --git a/contrib/perl5/ext/POSIX/hints/dynixptx.pl b/contrib/perl5/ext/POSIX/hints/dynixptx.pl deleted file mode 100644 index 9b63684..0000000 --- a/contrib/perl5/ext/POSIX/hints/dynixptx.pl +++ /dev/null @@ -1,4 +0,0 @@ -# Need to add an extra '-lc' to the end to work around a DYNIX/ptx bug -# PR#227670 - linker error on fpgetround() - -$self->{LIBS} = ['-ldb -lm -lc']; diff --git a/contrib/perl5/ext/POSIX/hints/freebsd.pl b/contrib/perl5/ext/POSIX/hints/freebsd.pl deleted file mode 100644 index 62732ac..0000000 --- a/contrib/perl5/ext/POSIX/hints/freebsd.pl +++ /dev/null @@ -1,3 +0,0 @@ -# BSD platforms have extra fields in struct tm that need to be initialized. -# XXX A Configure test is needed. -$self->{CCFLAGS} = $Config{ccflags} . ' -DSTRUCT_TM_HASZONE' ; diff --git a/contrib/perl5/ext/POSIX/hints/linux.pl b/contrib/perl5/ext/POSIX/hints/linux.pl deleted file mode 100644 index f1d1981..0000000 --- a/contrib/perl5/ext/POSIX/hints/linux.pl +++ /dev/null @@ -1,5 +0,0 @@ -# libc6, aka glibc2, seems to need STRUCT_TM_HASZONE defined. -# Thanks to Bart Schuller <schuller@Lunatech.com> -# See Message-ID: <19971009002636.50729@tanglefoot> -# XXX A Configure test is needed. -$self->{CCFLAGS} = $Config{ccflags} . ' -DSTRUCT_TM_HASZONE -DHINT_SC_EXIST' ; diff --git a/contrib/perl5/ext/POSIX/hints/mint.pl b/contrib/perl5/ext/POSIX/hints/mint.pl deleted file mode 100644 index b975cbb..0000000 --- a/contrib/perl5/ext/POSIX/hints/mint.pl +++ /dev/null @@ -1,2 +0,0 @@ -$self->{CCFLAGS} = $Config{ccflags} . ' -DNO_LOCALECONV_GROUPING -DNO_LOCALECONV_MON_GROUPING'; - diff --git a/contrib/perl5/ext/POSIX/hints/netbsd.pl b/contrib/perl5/ext/POSIX/hints/netbsd.pl deleted file mode 100644 index 62732ac..0000000 --- a/contrib/perl5/ext/POSIX/hints/netbsd.pl +++ /dev/null @@ -1,3 +0,0 @@ -# BSD platforms have extra fields in struct tm that need to be initialized. -# XXX A Configure test is needed. -$self->{CCFLAGS} = $Config{ccflags} . ' -DSTRUCT_TM_HASZONE' ; diff --git a/contrib/perl5/ext/POSIX/hints/next_3.pl b/contrib/perl5/ext/POSIX/hints/next_3.pl deleted file mode 100644 index d907783..0000000 --- a/contrib/perl5/ext/POSIX/hints/next_3.pl +++ /dev/null @@ -1,5 +0,0 @@ -# NeXT *does* have setpgid when we use the -posix flag, but -# doesn't when we don't. The main perl sources are compiled -# without -posix, so the hints/next_3.sh hint file tells Configure -# that d_setpgid=undef. -$self->{CCFLAGS} = $Config{ccflags} . ' -posix -DHAS_SETPGID' ; diff --git a/contrib/perl5/ext/POSIX/hints/openbsd.pl b/contrib/perl5/ext/POSIX/hints/openbsd.pl deleted file mode 100644 index 62732ac..0000000 --- a/contrib/perl5/ext/POSIX/hints/openbsd.pl +++ /dev/null @@ -1,3 +0,0 @@ -# BSD platforms have extra fields in struct tm that need to be initialized. -# XXX A Configure test is needed. -$self->{CCFLAGS} = $Config{ccflags} . ' -DSTRUCT_TM_HASZONE' ; diff --git a/contrib/perl5/ext/POSIX/hints/sunos_4.pl b/contrib/perl5/ext/POSIX/hints/sunos_4.pl deleted file mode 100644 index 32b3558..0000000 --- a/contrib/perl5/ext/POSIX/hints/sunos_4.pl +++ /dev/null @@ -1,10 +0,0 @@ -# SunOS 4.1.3 has two extra fields in struct tm. This works around -# the problem. Other BSD platforms may have similar problems. -# This state of affairs also persists in glibc2, found -# on linux systems running libc6. -# XXX A Configure test is needed. - -# Although <unistd.h> is inappropriate in general for SunOS, we need it -# in POSIX.xs to get the correct prototype for ttyname(). - -$self->{CCFLAGS} = $Config{ccflags} . ' -DSTRUCT_TM_HASZONE -DI_UNISTD' ; diff --git a/contrib/perl5/ext/POSIX/hints/svr4.pl b/contrib/perl5/ext/POSIX/hints/svr4.pl deleted file mode 100644 index 07f2cb0..0000000 --- a/contrib/perl5/ext/POSIX/hints/svr4.pl +++ /dev/null @@ -1,12 +0,0 @@ -# NCR MP-RAS. Thanks to Doug Hendricks for this info. -# Configure sets osname=svr4.0, osvers=3.0, archname='3441-svr4.0' -# This system needs to explicitly link against -lmw to pull in some -# symbols such as _mwoflocheckl and possibly others. -# A. Dougherty Thu Dec 7 11:55:28 EST 2000 -if ($Config{'archname'} =~ /3441-svr4/) { - $self->{LIBS} = ['-lm -posix -lcposix -lmw']; -} -# Not sure what OS this one is. -elsif ($Config{archname} =~ /RM\d\d\d-svr4/) { - $self->{LIBS} = ['-lm -lc -lposix -lcposix']; -} diff --git a/contrib/perl5/ext/POSIX/typemap b/contrib/perl5/ext/POSIX/typemap deleted file mode 100644 index baf9bfc..0000000 --- a/contrib/perl5/ext/POSIX/typemap +++ /dev/null @@ -1,15 +0,0 @@ -Mode_t T_NV -pid_t T_NV -Uid_t T_NV -Time_t T_NV -Gid_t T_NV -Off_t T_NV -Dev_t T_NV -NV T_NV -fd T_IV -speed_t T_IV -tcflag_t T_IV -cc_t T_IV -POSIX::SigSet T_PTROBJ -POSIX::Termios T_PTROBJ -POSIX::SigAction T_HVREF diff --git a/contrib/perl5/ext/SDBM_File/Makefile.PL b/contrib/perl5/ext/SDBM_File/Makefile.PL deleted file mode 100644 index a1debb9..0000000 --- a/contrib/perl5/ext/SDBM_File/Makefile.PL +++ /dev/null @@ -1,49 +0,0 @@ -use ExtUtils::MakeMaker; - -# The existence of the ./sdbm/Makefile.PL file causes MakeMaker -# to automatically include Makefile code for the targets -# config, all, clean, realclean and sdbm/Makefile -# which perform the corresponding actions in the subdirectory. - -$define = ($^O eq 'MSWin32') ? '-DMSDOS' : ''; -if ($^O eq 'MSWin32') { $myextlib = 'sdbm\\libsdbm$(LIB_EXT)'; } -else { $myextlib = 'sdbm/libsdbm$(LIB_EXT)'; } - -WriteMakefile( - NAME => 'SDBM_File', - MYEXTLIB => $myextlib, - MAN3PODS => {}, # Pods will be built by installman. - XSPROTOARG => '-noprototypes', # XXX remove later? - VERSION_FROM => 'SDBM_File.pm', - DEFINE => $define, - PERL_MALLOC_OK => 1, - ); - -sub MY::postamble { - if ($^O =~ /MSWin32/ && Win32::IsWin95()) { - # XXX: dmake-specific, like rest of Win95 port - return - ' -$(MYEXTLIB): sdbm/Makefile -@[ - cd sdbm - $(MAKE) all - cd .. -] -'; - } - elsif ($^O ne 'VMS') { - ' -$(MYEXTLIB): sdbm/Makefile - cd sdbm && $(MAKE) all -'; - } - else { - ' -$(MYEXTLIB) : [.sdbm]descrip.mms - set def [.sdbm] - $(MMS) all - set def [-] -'; - } -} diff --git a/contrib/perl5/ext/SDBM_File/SDBM_File.pm b/contrib/perl5/ext/SDBM_File/SDBM_File.pm deleted file mode 100644 index ee82a54..0000000 --- a/contrib/perl5/ext/SDBM_File/SDBM_File.pm +++ /dev/null @@ -1,116 +0,0 @@ -package SDBM_File; - -use strict; -use warnings; - -require Tie::Hash; -use XSLoader (); - -our @ISA = qw(Tie::Hash); -our $VERSION = "1.03" ; - -XSLoader::load 'SDBM_File', $VERSION; - -1; - -__END__ - -=head1 NAME - -SDBM_File - Tied access to sdbm files - -=head1 SYNOPSIS - - use Fcntl; # For O_RDWR, O_CREAT, etc. - use SDBM_File; - - tie(%h, 'SDBM_File', 'filename', O_RDWR|O_CREAT, 0666) - or die "Couldn't tie SDBM file 'filename': $!; aborting"; - - # Now read and change the hash - $h{newkey} = newvalue; - print $h{oldkey}; - ... - - untie %h; - -=head1 DESCRIPTION - -C<SDBM_File> establishes a connection between a Perl hash variable and -a file in SDBM_File format;. You can manipulate the data in the file -just as if it were in a Perl hash, but when your program exits, the -data will remain in the file, to be used the next time your program -runs. - -Use C<SDBM_File> with the Perl built-in C<tie> function to establish -the connection between the variable and the file. The arguments to -C<tie> should be: - -=over 4 - -=item 1. - -The hash variable you want to tie. - -=item 2. - -The string C<"SDBM_File">. (Ths tells Perl to use the C<SDBM_File> -package to perform the functions of the hash.) - -=item 3. - -The name of the file you want to tie to the hash. - -=item 4. - -Flags. Use one of: - -=over 2 - -=item C<O_RDONLY> - -Read-only access to the data in the file. - -=item C<O_WRONLY> - -Write-only access to the data in the file. - -=item C<O_RDWR> - -Both read and write access. - -=back - -If you want to create the file if it does not exist, add C<O_CREAT> to -any of these, as in the example. If you omit C<O_CREAT> and the file -does not already exist, the C<tie> call will fail. - -=item 5. - -The default permissions to use if a new file is created. The actual -permissions will be modified by the user's umask, so you should -probably use 0666 here. (See L<perlfunc/umask>.) - -=back - -=head1 DIAGNOSTICS - -On failure, the C<tie> call returns an undefined value and probably -sets C<$!> to contain the reason the file could not be tied. - -=head2 C<sdbm store returned -1, errno 22, key "..." at ...> - -This warning is emmitted when you try to store a key or a value that -is too long. It means that the change was not recorded in the -database. See BUGS AND WARNINGS below. - -=head1 BUGS AND WARNINGS - -There are a number of limits on the size of the data that you can -store in the SDBM file. The most important is that the length of a -key, plus the length of its associated value, may not exceed 1008 -bytes. - -See L<perlfunc/tie>, L<perldbmfilter>, L<Fcntl> - -=cut diff --git a/contrib/perl5/ext/SDBM_File/SDBM_File.xs b/contrib/perl5/ext/SDBM_File/SDBM_File.xs deleted file mode 100644 index 859730b..0000000 --- a/contrib/perl5/ext/SDBM_File/SDBM_File.xs +++ /dev/null @@ -1,191 +0,0 @@ -#define PERL_NO_GET_CONTEXT -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" -#include "sdbm/sdbm.h" - -typedef struct { - DBM * dbp ; - SV * filter_fetch_key ; - SV * filter_store_key ; - SV * filter_fetch_value ; - SV * filter_store_value ; - int filtering ; - } SDBM_File_type; - -typedef SDBM_File_type * SDBM_File ; -typedef datum datum_key ; -typedef datum datum_value ; - -#define ckFilter(arg,type,name) \ - if (db->type) { \ - SV * save_defsv ; \ - /* printf("filtering %s\n", name) ;*/ \ - if (db->filtering) \ - croak("recursion detected in %s", name) ; \ - db->filtering = TRUE ; \ - save_defsv = newSVsv(DEFSV) ; \ - sv_setsv(DEFSV, arg) ; \ - PUSHMARK(sp) ; \ - (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); \ - sv_setsv(arg, DEFSV) ; \ - sv_setsv(DEFSV, save_defsv) ; \ - SvREFCNT_dec(save_defsv) ; \ - db->filtering = FALSE ; \ - /*printf("end of filtering %s\n", name) ;*/ \ - } - -#define sdbm_TIEHASH(dbtype,filename,flags,mode) sdbm_open(filename,flags,mode) -#define sdbm_FETCH(db,key) sdbm_fetch(db->dbp,key) -#define sdbm_STORE(db,key,value,flags) sdbm_store(db->dbp,key,value,flags) -#define sdbm_DELETE(db,key) sdbm_delete(db->dbp,key) -#define sdbm_EXISTS(db,key) sdbm_exists(db->dbp,key) -#define sdbm_FIRSTKEY(db) sdbm_firstkey(db->dbp) -#define sdbm_NEXTKEY(db,key) sdbm_nextkey(db->dbp) - - -MODULE = SDBM_File PACKAGE = SDBM_File PREFIX = sdbm_ - -SDBM_File -sdbm_TIEHASH(dbtype, filename, flags, mode) - char * dbtype - char * filename - int flags - int mode - CODE: - { - DBM * dbp ; - - RETVAL = NULL ; - if ((dbp = sdbm_open(filename,flags,mode))) { - RETVAL = (SDBM_File)safemalloc(sizeof(SDBM_File_type)) ; - Zero(RETVAL, 1, SDBM_File_type) ; - RETVAL->dbp = dbp ; - } - - } - OUTPUT: - RETVAL - -void -sdbm_DESTROY(db) - SDBM_File db - CODE: - sdbm_close(db->dbp); - if (db->filter_fetch_key) - SvREFCNT_dec(db->filter_fetch_key) ; - if (db->filter_store_key) - SvREFCNT_dec(db->filter_store_key) ; - if (db->filter_fetch_value) - SvREFCNT_dec(db->filter_fetch_value) ; - if (db->filter_store_value) - SvREFCNT_dec(db->filter_store_value) ; - safefree(db) ; - -datum_value -sdbm_FETCH(db, key) - SDBM_File db - datum_key key - -int -sdbm_STORE(db, key, value, flags = DBM_REPLACE) - SDBM_File db - datum_key key - datum_value value - int flags - CLEANUP: - if (RETVAL) { - if (RETVAL < 0 && errno == EPERM) - croak("No write permission to sdbm file"); - croak("sdbm store returned %d, errno %d, key \"%s\"", - RETVAL,errno,key.dptr); - sdbm_clearerr(db->dbp); - } - -int -sdbm_DELETE(db, key) - SDBM_File db - datum_key key - -int -sdbm_EXISTS(db,key) - SDBM_File db - datum_key key - -datum_key -sdbm_FIRSTKEY(db) - SDBM_File db - -datum_key -sdbm_NEXTKEY(db, key) - SDBM_File db - datum_key key - -int -sdbm_error(db) - SDBM_File db - CODE: - RETVAL = sdbm_error(db->dbp) ; - OUTPUT: - RETVAL - -int -sdbm_clearerr(db) - SDBM_File db - CODE: - RETVAL = sdbm_clearerr(db->dbp) ; - OUTPUT: - RETVAL - - -#define setFilter(type) \ - { \ - if (db->type) \ - RETVAL = sv_mortalcopy(db->type) ; \ - ST(0) = RETVAL ; \ - if (db->type && (code == &PL_sv_undef)) { \ - SvREFCNT_dec(db->type) ; \ - db->type = NULL ; \ - } \ - else if (code) { \ - if (db->type) \ - sv_setsv(db->type, code) ; \ - else \ - db->type = newSVsv(code) ; \ - } \ - } - - - -SV * -filter_fetch_key(db, code) - SDBM_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_fetch_key) ; - -SV * -filter_store_key(db, code) - SDBM_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_store_key) ; - -SV * -filter_fetch_value(db, code) - SDBM_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_fetch_value) ; - -SV * -filter_store_value(db, code) - SDBM_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - setFilter(filter_store_value) ; - diff --git a/contrib/perl5/ext/SDBM_File/sdbm/CHANGES b/contrib/perl5/ext/SDBM_File/sdbm/CHANGES deleted file mode 100644 index f7296d1..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/CHANGES +++ /dev/null @@ -1,18 +0,0 @@ -Changes from the earlier BETA releases. - -o dbm_prep does everything now, so dbm_open is just a simple - wrapper that builds the default filenames. dbm_prep no longer - requires a (DBM *) db parameter: it allocates one itself. It - returns (DBM *) db or (DBM *) NULL. - -o makroom is now reliable. In the common-case optimization of the page - split, the page into which the incoming key/value pair is to be inserted - is write-deferred (if the split is successful), thereby saving a cosly - write. BUT, if the split does not make enough room (unsuccessful), the - deferred page is written out, as the failure-window is now dependent on - the number of split attempts. - -o if -DDUFF is defined, hash function will also use the DUFF construct. - This may look like a micro-performance tweak (maybe it is), but in fact, - the hash function is the third most-heavily used function, after read - and write. diff --git a/contrib/perl5/ext/SDBM_File/sdbm/COMPARE b/contrib/perl5/ext/SDBM_File/sdbm/COMPARE deleted file mode 100644 index a595e83..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/COMPARE +++ /dev/null @@ -1,88 +0,0 @@ - -Script started on Thu Sep 28 15:41:06 1989 -% uname -a -titan titan 4_0 UMIPS mips -% make all x-dbm - cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c dbm.c - cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c sdbm.c - cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c pair.c - cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c hash.c - ar cr libsdbm.a sdbm.o pair.o hash.o - ranlib libsdbm.a - cc -o dbm dbm.o libsdbm.a - cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c dba.c - cc -o dba dba.o - cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c dbd.c - cc -o dbd dbd.o - cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -o x-dbm dbm.o -% -% -% wc history - 65110 218344 3204883 history -% -% /bin/time dbm build foo <history - -real 5:56.9 -user 13.3 -sys 26.3 -% ls -s -total 14251 - 5 README 2 dbd.c 1 hash.c 1 pair.h - 0 SCRIPT 5 dbd.o 1 hash.o 5 pair.o - 1 WISHLIST 62 dbm 3130 history 1 port.h - 46 dba 5 dbm.c 11 howtodbm.txt 11 sdbm.c - 3 dba.c 8 dbm.o 14 libsdbm.a 2 sdbm.h - 6 dba.o 4 foo.dir 1 makefile 8 sdbm.o - 46 dbd 10810 foo.pag 6 pair.c 60 x-dbm -% ls -l foo.* --rw-r--r-- 1 oz 4096 Sep 28 15:48 foo.dir --rw-r--r-- 1 oz 11069440 Sep 28 15:48 foo.pag -% -% /bin/time x-dbm build bar <history - -real 5:59.4 -user 24.7 -sys 29.1 -% -% ls -s -total 27612 - 5 README 46 dbd 1 hash.c 5 pair.o - 1 SCRIPT 2 dbd.c 1 hash.o 1 port.h - 1 WISHLIST 5 dbd.o 3130 history 11 sdbm.c - 4 bar.dir 62 dbm 11 howtodbm.txt 2 sdbm.h -13356 bar.pag 5 dbm.c 14 libsdbm.a 8 sdbm.o - 46 dba 8 dbm.o 1 makefile 60 x-dbm - 3 dba.c 4 foo.dir 6 pair.c - 6 dba.o 10810 foo.pag 1 pair.h -% -% ls -l bar.* --rw-r--r-- 1 oz 4096 Sep 28 15:54 bar.dir --rw-r--r-- 1 oz 13676544 Sep 28 15:54 bar.pag -% -% dba foo | tail -#10801: ok. no entries. -#10802: ok. no entries. -#10803: ok. no entries. -#10804: ok. no entries. -#10805: ok. no entries. -#10806: ok. no entries. -#10807: ok. no entries. -#10808: ok. no entries. -#10809: ok. 11 entries 67% used free 337. -10810 pages (6036 holes): 65073 entries -% -% dba bar | tail -#13347: ok. no entries. -#13348: ok. no entries. -#13349: ok. no entries. -#13350: ok. no entries. -#13351: ok. no entries. -#13352: ok. no entries. -#13353: ok. no entries. -#13354: ok. no entries. -#13355: ok. 7 entries 33% used free 676. -13356 pages (8643 holes): 65073 entries -% -% exit -script done on Thu Sep 28 16:08:45 1989 - diff --git a/contrib/perl5/ext/SDBM_File/sdbm/Makefile.PL b/contrib/perl5/ext/SDBM_File/sdbm/Makefile.PL deleted file mode 100644 index 4453dea..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/Makefile.PL +++ /dev/null @@ -1,67 +0,0 @@ -use ExtUtils::MakeMaker; - -$define = '-DSDBM -DDUFF'; -$define .= ' -DWIN32 -DPERL_STATIC_SYMS' if ($^O eq 'MSWin32'); - -if ($^O eq 'VMS') { # Old VAXC compiler can't handle Duff's device - require Config; - $define =~ s/\s+-DDUFF// if $Config::Config{'vms_cc_type'} eq 'vaxc'; -} - -WriteMakefile( - NAME => 'sdbm', # (doesn't matter what the name is here) oh yes it does -# LINKTYPE => 'static', - DEFINE => $define, - INC => '-I$(PERL_INC)', # force PERL_INC dir ahead of system -I's - INST_ARCHLIB => '.', - SKIP => [qw(dynamic dynamic_lib dlsyms)], - OBJECT => '$(O_FILES)', - clean => {'FILES' => 'dbu libsdbm.a dbd dba dbe x-dbu *.dir *.pag'}, - H => [qw(tune.h sdbm.h pair.h $(PERL_INC)/config.h)], - C => [qw(sdbm.c pair.c hash.c)] -); - -sub MY::constants { - package MY; - my $r = shift->SUPER::constants(); - if ($^O eq 'VMS') { - $r =~ s/^INST_STATIC =.*$/INST_STATIC = libsdbm\$(LIB_EXT)/m - } - return $r; -} - -sub MY::post_constants { - package MY; - if ($^O eq 'VMS') { - shift->SUPER::post_constants(); - } else { -' -INST_STATIC = libsdbm$(LIB_EXT) -' - } -} - -sub MY::top_targets { - my $noecho = shift->{NOECHO}; - - my $r = ' -all :: static - ' . $noecho . '$(NOOP) - -config :: - ' . $noecho . '$(NOOP) - -lint: - lint -abchx $(LIBSRCS) - -'; - $r .= ' -# This is a workaround, the problem is that our old GNU make exports -# variables into the environment so $(MYEXTLIB) is set in here to this -# value which can not be built. -sdbm/libsdbm.a: - ' . $noecho . '$(NOOP) -' unless $^O eq 'VMS'; - - return $r; -} diff --git a/contrib/perl5/ext/SDBM_File/sdbm/README b/contrib/perl5/ext/SDBM_File/sdbm/README deleted file mode 100644 index cd7312c..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/README +++ /dev/null @@ -1,396 +0,0 @@ - - - - - - - sdbm - Substitute DBM - or - Berkeley ndbm for Every UN*X[1] Made Simple - - Ozan (oz) Yigit - - The Guild of PD Software Toolmakers - Toronto - Canada - - oz@nexus.yorku.ca - - - -Implementation is the sincerest form of flattery. - L. Peter -Deutsch - -A The Clone of the ndbm library - - The sources accompanying this notice - sdbm - consti- -tute the first public release (Dec. 1990) of a complete -clone of the Berkeley UN*X ndbm library. The sdbm library is -meant to clone the proven functionality of ndbm as closely -as possible, including a few improvements. It is practical, -easy to understand, and compatible. The sdbm library is not -derived from any licensed, proprietary or copyrighted -software. - - The sdbm implementation is based on a 1978 algorithm -[Lar78] by P.-A. (Paul) Larson known as ``Dynamic Hashing''. -In the course of searching for a substitute for ndbm, I pro- -totyped three different external-hashing algorithms [Lar78, -Fag79, Lit80] and ultimately chose Larson's algorithm as a -basis of the sdbm implementation. The Bell Labs dbm (and -therefore ndbm) is based on an algorithm invented by Ken -Thompson, [Tho90, Tor87] and predates Larson's work. - - The sdbm programming interface is totally compatible -with ndbm and includes a slight improvement in database ini- -tialization. It is also expected to be binary-compatible -under most UN*X versions that support the ndbm library. - - The sdbm implementation shares the shortcomings of the -ndbm library, as a side effect of various simplifications to -the original Larson algorithm. It does produce holes in the -page file as it writes pages past the end of file. (Larson's -paper include a clever solution to this problem that is a -result of using the hash value directly as a block address.) -On the other hand, extensive tests seem to indicate that -sdbm creates fewer holes in general, and the resulting page- -files are smaller. The sdbm implementation is also faster -than ndbm in database creation. Unlike the ndbm, the sdbm -_________________________ - - [1] UN*X is not a trademark of any (dis)organization. - - - - - - - - - - - 2 - - - -store operation will not ``wander away'' trying to split its -data pages to insert a datum that cannot (due to elaborate -worst-case situations) be inserted. (It will fail after a -pre-defined number of attempts.) - -Important Compatibility Warning - - The sdbm and ndbm libraries cannot share databases: one -cannot read the (dir/pag) database created by the other. -This is due to the differences between the ndbm and sdbm -algorithms[2], and the hash functions used. It is easy to -convert between the dbm/ndbm databases and sdbm by ignoring -the index completely: see dbd, dbu etc. - - -Notice of Intellectual Property - -The entire sdbm library package, as authored by me, Ozan S. -Yigit, is hereby placed in the public domain. As such, the -author is not responsible for the consequences of use of -this software, no matter how awful, even if they arise from -defects in it. There is no expressed or implied warranty for -the sdbm library. - - Since the sdbm library package is in the public domain, -this original release or any additional public-domain -releases of the modified original cannot possibly (by defin- -ition) be withheld from you. Also by definition, You (singu- -lar) have all the rights to this code (including the right -to sell without permission, the right to hoard[3] and the -right to do other icky things as you see fit) but those -rights are also granted to everyone else. - - Please note that all previous distributions of this -software contained a copyright (which is now dropped) to -protect its origins and its current public domain status -against any possible claims and/or challenges. - -Acknowledgments - - Many people have been very helpful and supportive. A -partial list would necessarily include Rayan Zacherissen -(who contributed the man page, and also hacked a MMAP -_________________________ - - [2] Torek's discussion [Tor87] indicates that -dbm/ndbm implementations use the hash value to traverse -the radix trie differently than sdbm and as a result, -the page indexes are generated in different order. For -more information, send e-mail to the author. - [3] You cannot really hoard something that is avail- -able to the public at large, but try if it makes you -feel any better. - - - - - - - - - - - - 3 - - - -version of sdbm), Arnold Robbins, Chris Lewis, Bill David- -sen, Henry Spencer, Geoff Collyer, Rich Salz (who got me -started in the first place), Johannes Ruschein (who did the -minix port) and David Tilbrook. I thank you all. - -Distribution Manifest and Notes - -This distribution of sdbm includes (at least) the following: - - CHANGES change log - README this file. - biblio a small bibliography on external hashing - dba.c a crude (n/s)dbm page file analyzer - dbd.c a crude (n/s)dbm page file dumper (for conversion) - dbe.1 man page for dbe.c - dbe.c Janick's database editor - dbm.c a dbm library emulation wrapper for ndbm/sdbm - dbm.h header file for the above - dbu.c a crude db management utility - hash.c hashing function - makefile guess. - pair.c page-level routines (posted earlier) - pair.h header file for the above - readme.ms troff source for the README file - sdbm.3 man page - sdbm.c the real thing - sdbm.h header file for the above - tune.h place for tuning & portability thingies - util.c miscellaneous - - dbu is a simple database manipulation program[4] that -tries to look like Bell Labs' cbt utility. It is currently -incomplete in functionality. I use dbu to test out the rou- -tines: it takes (from stdin) tab separated key/value pairs -for commands like build or insert or takes keys for commands -like delete or look. - - dbu <build|creat|look|insert|cat|delete> dbmfile - - dba is a crude analyzer of dbm/sdbm/ndbm page files. It -scans the entire page file, reporting page level statistics, -and totals at the end. - - dbd is a crude dump program for dbm/ndbm/sdbm data- -bases. It ignores the bitmap, and dumps the data pages in -sequence. It can be used to create input for the dbu util- -ity. Note that dbd will skip any NULLs in the key and data -fields, thus is unsuitable to convert some peculiar -_________________________ - - [4] The dbd, dba, dbu utilities are quick hacks and -are not fit for production use. They were developed -late one night, just to test out sdbm, and convert some -databases. - - - - - - - - - - - 4 - - - -databases that insist in including the terminating null. - - I have also included a copy of the dbe (ndbm DataBase -Editor) by Janick Bergeron [janick@bnr.ca] for your pleas- -ure. You may find it more useful than the little dbu util- -ity. - - dbm.[ch] is a dbm library emulation on top of ndbm (and -hence suitable for sdbm). Written by Robert Elz. - - The sdbm library has been around in beta test for quite -a long time, and from whatever little feedback I received -(maybe no news is good news), I believe it has been func- -tioning without any significant problems. I would, of -course, appreciate all fixes and/or improvements. Portabil- -ity enhancements would especially be useful. - -Implementation Issues - - Hash functions: The algorithm behind sdbm implementa- -tion needs a good bit-scrambling hash function to be effec- -tive. I ran into a set of constants for a simple hash func- -tion that seem to help sdbm perform better than ndbm for -various inputs: - - /* - * polynomial conversion ignoring overflows - * 65599 nice. 65587 even better. - */ - long - dbm_hash(char *str, int len) { - register unsigned long n = 0; - - while (len--) - n = n * 65599 + *str++; - return n; - } - - There may be better hash functions for the purposes of -dynamic hashing. Try your favorite, and check the pagefile. -If it contains too many pages with too many holes, (in rela- -tion to this one for example) or if sdbm simply stops work- -ing (fails after SPLTMAX attempts to split) when you feed -your NEWS history file to it, you probably do not have a -good hashing function. If you do better (for different -types of input), I would like to know about the function you -use. - - Block sizes: It seems (from various tests on a few -machines) that a page file block size PBLKSIZ of 1024 is by -far the best for performance, but this also happens to limit -the size of a key/value pair. Depending on your needs, you -may wish to increase the page size, and also adjust PAIRMAX -(the maximum size of a key/value pair allowed: should always - - - - - - - - - - - 5 - - - -be at least three words smaller than PBLKSIZ.) accordingly. -The system-wide version of the library should probably be -configured with 1024 (distribution default), as this appears -to be sufficient for most common uses of sdbm. - -Portability - - This package has been tested in many different UN*Xes -even including minix, and appears to be reasonably portable. -This does not mean it will port easily to non-UN*X systems. - -Notes and Miscellaneous - - The sdbm is not a very complicated package, at least -not after you familiarize yourself with the literature on -external hashing. There are other interesting algorithms in -existence that ensure (approximately) single-read access to -a data value associated with any key. These are directory- -less schemes such as linear hashing [Lit80] (+ Larson varia- -tions), spiral storage [Mar79] or directory schemes such as -extensible hashing [Fag79] by Fagin et al. I do hope these -sources provide a reasonable playground for experimentation -with other algorithms. See the June 1988 issue of ACM Com- -puting Surveys [Enb88] for an excellent overview of the -field. - -References - - -[Lar78] - P.-A. Larson, ``Dynamic Hashing'', BIT, vol. 18, pp. - 184-201, 1978. - -[Tho90] - Ken Thompson, private communication, Nov. 1990 - -[Lit80] - W. Litwin, `` Linear Hashing: A new tool for file and - table addressing'', Proceedings of the 6th Conference on - Very Large Dabatases (Montreal), pp. 212-223, Very - Large Database Foundation, Saratoga, Calif., 1980. - -[Fag79] - R. Fagin, J. Nievergelt, N. Pippinger, and H. R. - Strong, ``Extendible Hashing - A Fast Access Method for - Dynamic Files'', ACM Trans. Database Syst., vol. 4, - no.3, pp. 315-344, Sept. 1979. - -[Wal84] - Rich Wales, ``Discussion of "dbm" data base system'', - USENET newsgroup unix.wizards, Jan. 1984. - -[Tor87] - Chris Torek, ``Re: dbm.a and ndbm.a archives'', - - - - - - - - - - - 6 - - - - USENET newsgroup comp.unix, 1987. - -[Mar79] - G. N. Martin, ``Spiral Storage: Incrementally Augment- - able Hash Addressed Storage'', Technical Report #27, - University of Varwick, Coventry, U.K., 1979. - -[Enb88] - R. J. Enbody and H. C. Du, ``Dynamic Hashing - Schemes'',ACM Computing Surveys, vol. 20, no. 2, pp. - 85-113, June 1988. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/contrib/perl5/ext/SDBM_File/sdbm/README.too b/contrib/perl5/ext/SDBM_File/sdbm/README.too deleted file mode 100644 index 1fec315..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/README.too +++ /dev/null @@ -1,14 +0,0 @@ -This version of sdbm merely has all the dbm_* names translated to sdbm_* -so that we can link ndbm and sdbm into the same executable. (It also has -the bad() macro redefined to allow a zero-length key.) - - -Fri Apr 15 10:15:30 EDT 1994. - -Additional portability/configuration changes for libsdbm by Andy Dougherty -doughera@lafcol.lafayette.edu. - - -Mon Mar 22 03:24:47 PST 1999. - -sdbm_exists added to the library by Russ Allbery <rra@stanford.edu>. diff --git a/contrib/perl5/ext/SDBM_File/sdbm/biblio b/contrib/perl5/ext/SDBM_File/sdbm/biblio deleted file mode 100644 index 0be09fa..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/biblio +++ /dev/null @@ -1,64 +0,0 @@ -%A R. J. Enbody -%A H. C. Du -%T Dynamic Hashing Schemes -%J ACM Computing Surveys -%V 20 -%N 2 -%D June 1988 -%P 85-113 -%K surveys - -%A P.-A. Larson -%T Dynamic Hashing -%J BIT -%V 18 -%P 184-201 -%D 1978 -%K dynamic - -%A W. Litwin -%T Linear Hashing: A new tool for file and table addressing -%J Proceedings of the 6th Conference on Very Large Dabatases (Montreal) -%I Very Large Database Foundation -%C Saratoga, Calif. -%P 212-223 -%D 1980 -%K linear - -%A R. Fagin -%A J. Nievergelt -%A N. Pippinger -%A H. R. Strong -%T Extendible Hashing - A Fast Access Method for Dynamic Files -%J ACM Trans. Database Syst. -%V 4 -%N 3 -%D Sept. 1979 -%P 315-344 -%K extend - -%A G. N. Martin -%T Spiral Storage: Incrementally Augmentable Hash Addressed Storage -%J Technical Report #27 -%I University of Varwick -%C Coventry, U.K. -%D 1979 -%K spiral - -%A Chris Torek -%T Re: dbm.a and ndbm.a archives -%B USENET newsgroup comp.unix -%D 1987 -%K torek - -%A Rich Wales -%T Discusson of "dbm" data base system -%B USENET newsgroup unix.wizards -%D Jan. 1984 -%K rich - - - - - - diff --git a/contrib/perl5/ext/SDBM_File/sdbm/dba.c b/contrib/perl5/ext/SDBM_File/sdbm/dba.c deleted file mode 100644 index 7406776..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/dba.c +++ /dev/null @@ -1,87 +0,0 @@ -/* - * dba dbm analysis/recovery - */ - -#include <stdio.h> -#include <sys/file.h> -#include "EXTERN.h" -#include "sdbm.h" - -char *progname; -extern void oops(); - -int -main(int argc, char **argv) -{ - int n; - char *p; - char *name; - int pagf; - - progname = argv[0]; - - if (p = argv[1]) { - name = (char *) malloc((n = strlen(p)) + 5); - if (!name) - oops("cannot get memory"); - - strcpy(name, p); - strcpy(name + n, ".pag"); - - if ((pagf = open(name, O_RDONLY)) < 0) - oops("cannot open %s.", name); - - sdump(pagf); - } - else - oops("usage: %s dbname", progname); - - return 0; -} - -void -sdump(int pagf) -{ - register b; - register n = 0; - register t = 0; - register o = 0; - register e; - char pag[PBLKSIZ]; - - while ((b = read(pagf, pag, PBLKSIZ)) > 0) { - printf("#%d: ", n); - if (!okpage(pag)) - printf("bad\n"); - else { - printf("ok. "); - if (!(e = pagestat(pag))) - o++; - else - t += e; - } - n++; - } - - if (b == 0) - printf("%d pages (%d holes): %d entries\n", n, o, t); - else - oops("read failed: block %d", n); -} - -int -pagestat(char *pag) -{ - register n; - register free; - register short *ino = (short *) pag; - - if (!(n = ino[0])) - printf("no entries.\n"); - else { - free = ino[n] - (n + 1) * sizeof(short); - printf("%3d entries %2d%% used free %d.\n", - n / 2, ((PBLKSIZ - free) * 100) / PBLKSIZ, free); - } - return n / 2; -} diff --git a/contrib/perl5/ext/SDBM_File/sdbm/dbd.c b/contrib/perl5/ext/SDBM_File/sdbm/dbd.c deleted file mode 100644 index 0a58d9a..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/dbd.c +++ /dev/null @@ -1,113 +0,0 @@ -/* - * dbd - dump a dbm data file - */ - -#include <stdio.h> -#include <sys/file.h> -#include "EXTERN.h" -#include "sdbm.h" - -char *progname; -extern void oops(); - - -#define empty(page) (((short *) page)[0] == 0) - -int -main(int argc, char **argv) -{ - int n; - char *p; - char *name; - int pagf; - - progname = argv[0]; - - if (p = argv[1]) { - name = (char *) malloc((n = strlen(p)) + 5); - if (!name) - oops("cannot get memory"); - - strcpy(name, p); - strcpy(name + n, ".pag"); - - if ((pagf = open(name, O_RDONLY)) < 0) - oops("cannot open %s.", name); - - sdump(pagf); - } - else - oops("usage: %s dbname", progname); - return 0; -} - -void -sdump(int pagf) -{ - register r; - register n = 0; - register o = 0; - char pag[PBLKSIZ]; - - while ((r = read(pagf, pag, PBLKSIZ)) > 0) { - if (!okpage(pag)) - fprintf(stderr, "%d: bad page.\n", n); - else if (empty(pag)) - o++; - else - dispage(pag); - n++; - } - - if (r == 0) - fprintf(stderr, "%d pages (%d holes).\n", n, o); - else - oops("read failed: block %d", n); -} - - -#ifdef OLD -int -dispage(char *pag) -{ - register i, n; - register off; - register short *ino = (short *) pag; - - off = PBLKSIZ; - for (i = 1; i < ino[0]; i += 2) { - printf("\t[%d]: ", ino[i]); - for (n = ino[i]; n < off; n++) - putchar(pag[n]); - putchar(' '); - off = ino[i]; - printf("[%d]: ", ino[i + 1]); - for (n = ino[i + 1]; n < off; n++) - putchar(pag[n]); - off = ino[i + 1]; - putchar('\n'); - } -} -#else -void -dispage(char *pag) -{ - register i, n; - register off; - register short *ino = (short *) pag; - - off = PBLKSIZ; - for (i = 1; i < ino[0]; i += 2) { - for (n = ino[i]; n < off; n++) - if (pag[n] != 0) - putchar(pag[n]); - putchar('\t'); - off = ino[i]; - for (n = ino[i + 1]; n < off; n++) - if (pag[n] != 0) - putchar(pag[n]); - putchar('\n'); - off = ino[i + 1]; - } -} -#endif diff --git a/contrib/perl5/ext/SDBM_File/sdbm/dbe.1 b/contrib/perl5/ext/SDBM_File/sdbm/dbe.1 deleted file mode 100644 index 3b32272..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/dbe.1 +++ /dev/null @@ -1,46 +0,0 @@ -.TH dbe 1 "ndbm(3) EDITOR" -.SH NAME -dbe \- Edit a ndbm(3) database -.SH USAGE -dbe <database> [-m r|w|rw] [-crtvx] -a|-d|-f|-F|-s [<key> [<content>]] -.SH DESCRIPTION -\fIdbme\fP operates on ndbm(3) databases. -It can be used to create them, look at them or change them. -When specifying the value of a key or the content of its associated entry, -\\nnn, \\0, \\n, \\t, \\f and \\r are interpreted as usual. -When displaying key/content pairs, non-printable characters are displayed -using the \\nnn notation. -.SH OPTIONS -.IP -a -List all entries in the database. -.IP -c -Create the database if it does not exist. -.IP -d -Delete the entry associated with the specified key. -.IP -f -Fetch and display the entry associated with the specified key. -.IP -F -Fetch and display all the entries whose key match the specified -regular-expression -.IP "-m r|w|rw" -Open the database in read-only, write-only or read-write mode -.IP -r -Replace the entry associated with the specified key if it already exists. -See option -s. -.IP -s -Store an entry under a specific key. -An error occurs if the key already exists and the option -r was not specified. -.IP -t -Re-initialize the database before executing the command. -.IP -v -Verbose mode. -Confirm stores and deletions. -.IP -x -If option -x is used with option -c, then if the database already exists, -an error occurs. -This can be used to implement a simple exclusive access locking mechanism. -.SH SEE ALSO -ndbm(3) -.SH AUTHOR -janick@bnr.ca - diff --git a/contrib/perl5/ext/SDBM_File/sdbm/dbe.c b/contrib/perl5/ext/SDBM_File/sdbm/dbe.c deleted file mode 100644 index 166e64e..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/dbe.c +++ /dev/null @@ -1,435 +0,0 @@ -#include <stdio.h> -#ifndef VMS -#include <sys/file.h> -#include <ndbm.h> -#else -#include "file.h" -#include "ndbm.h" -#endif -#include <ctype.h> - -/***************************************************************************\ -** ** -** Function name: getopt() ** -** Author: Henry Spencer, UofT ** -** Coding date: 84/04/28 ** -** ** -** Description: ** -** ** -** Parses argv[] for arguments. ** -** Works with Whitesmith's C compiler. ** -** ** -** Inputs - The number of arguments ** -** - The base address of the array of arguments ** -** - A string listing the valid options (':' indicates an ** -** argument to the preceding option is required, a ';' ** -** indicates an argument to the preceding option is optional) ** -** ** -** Outputs - Returns the next option character, ** -** '?' for non '-' arguments ** -** or ':' when there is no more arguments. ** -** ** -** Side Effects + The argument to an option is pointed to by 'optarg' ** -** ** -***************************************************************************** -** ** -** REVISION HISTORY: ** -** ** -** DATE NAME DESCRIPTION ** -** YY/MM/DD ------------------ ------------------------------------ ** -** 88/10/20 Janick Bergeron Returns '?' on unamed arguments ** -** returns '!' on unknown options ** -** and 'EOF' only when exhausted. ** -** 88/11/18 Janick Bergeron Return ':' when no more arguments ** -** 89/08/11 Janick Bergeron Optional optarg when ';' in optstring ** -** ** -\***************************************************************************/ - -char *optarg; /* Global argument pointer. */ - -#ifdef VMS -#define index strchr -#endif - -char -getopt(int argc, char **argv, char *optstring) -{ - register int c; - register char *place; - extern char *index(); - static int optind = 0; - static char *scan = NULL; - - optarg = NULL; - - if (scan == NULL || *scan == '\0') { - - if (optind == 0) - optind++; - if (optind >= argc) - return ':'; - - optarg = place = argv[optind++]; - if (place[0] != '-' || place[1] == '\0') - return '?'; - if (place[1] == '-' && place[2] == '\0') - return '?'; - scan = place + 1; - } - - c = *scan++; - place = index(optstring, c); - if (place == NULL || c == ':' || c == ';') { - - (void) fprintf(stderr, "%s: unknown option %c\n", argv[0], c); - scan = NULL; - return '!'; - } - if (*++place == ':') { - - if (*scan != '\0') { - - optarg = scan; - scan = NULL; - - } - else { - - if (optind >= argc) { - - (void) fprintf(stderr, "%s: %c requires an argument\n", - argv[0], c); - return '!'; - } - optarg = argv[optind]; - optind++; - } - } - else if (*place == ';') { - - if (*scan != '\0') { - - optarg = scan; - scan = NULL; - - } - else { - - if (optind >= argc || *argv[optind] == '-') - optarg = NULL; - else { - optarg = argv[optind]; - optind++; - } - } - } - return c; -} - - -void -print_datum(datum db) -{ - int i; - - putchar('"'); - for (i = 0; i < db.dsize; i++) { - if (isprint((unsigned char)db.dptr[i])) - putchar(db.dptr[i]); - else { - putchar('\\'); - putchar('0' + ((db.dptr[i] >> 6) & 0x07)); - putchar('0' + ((db.dptr[i] >> 3) & 0x07)); - putchar('0' + (db.dptr[i] & 0x07)); - } - } - putchar('"'); -} - - -datum -read_datum(char *s) -{ - datum db; - char *p; - int i; - - db.dsize = 0; - db.dptr = (char *) malloc(strlen(s) * sizeof(char)); - if (!db.dptr) - oops("cannot get memory"); - - for (p = db.dptr; *s != '\0'; p++, db.dsize++, s++) { - if (*s == '\\') { - if (*++s == 'n') - *p = '\n'; - else if (*s == 'r') - *p = '\r'; - else if (*s == 'f') - *p = '\f'; - else if (*s == 't') - *p = '\t'; - else if (isdigit((unsigned char)*s) - && isdigit((unsigned char)*(s + 1)) - && isdigit((unsigned char)*(s + 2))) - { - i = (*s++ - '0') << 6; - i |= (*s++ - '0') << 3; - i |= *s - '0'; - *p = i; - } - else if (*s == '0') - *p = '\0'; - else - *p = *s; - } - else - *p = *s; - } - - return db; -} - - -char * -key2s(datum db) -{ - char *buf; - char *p1, *p2; - - buf = (char *) malloc((db.dsize + 1) * sizeof(char)); - if (!buf) - oops("cannot get memory"); - for (p1 = buf, p2 = db.dptr; *p2 != '\0'; *p1++ = *p2++); - *p1 = '\0'; - return buf; -} - -int -main(int argc, char **argv) -{ - typedef enum { - YOW, FETCH, STORE, DELETE, SCAN, REGEXP - } commands; - char opt; - int flags; - int giveusage = 0; - int verbose = 0; - commands what = YOW; - char *comarg[3]; - int st_flag = DBM_INSERT; - int argn; - DBM *db; - datum key; - datum content; - - flags = O_RDWR; - argn = 0; - - while ((opt = getopt(argc, argv, "acdfFm:rstvx")) != ':') { - switch (opt) { - case 'a': - what = SCAN; - break; - case 'c': - flags |= O_CREAT; - break; - case 'd': - what = DELETE; - break; - case 'f': - what = FETCH; - break; - case 'F': - what = REGEXP; - break; - case 'm': - flags &= ~(000007); - if (strcmp(optarg, "r") == 0) - flags |= O_RDONLY; - else if (strcmp(optarg, "w") == 0) - flags |= O_WRONLY; - else if (strcmp(optarg, "rw") == 0) - flags |= O_RDWR; - else { - fprintf(stderr, "Invalid mode: \"%s\"\n", optarg); - giveusage = 1; - } - break; - case 'r': - st_flag = DBM_REPLACE; - break; - case 's': - what = STORE; - break; - case 't': - flags |= O_TRUNC; - break; - case 'v': - verbose = 1; - break; - case 'x': - flags |= O_EXCL; - break; - case '!': - giveusage = 1; - break; - case '?': - if (argn < 3) - comarg[argn++] = optarg; - else { - fprintf(stderr, "Too many arguments.\n"); - giveusage = 1; - } - break; - } - } - - if (giveusage || what == YOW || argn < 1) { - fprintf(stderr, "Usage: %s databse [-m r|w|rw] [-crtx] -a|-d|-f|-F|-s [key [content]]\n", argv[0]); - exit(-1); - } - - if ((db = dbm_open(comarg[0], flags, 0777)) == NULL) { - fprintf(stderr, "Error opening database \"%s\"\n", comarg[0]); - exit(-1); - } - - if (argn > 1) - key = read_datum(comarg[1]); - if (argn > 2) - content = read_datum(comarg[2]); - - switch (what) { - - case SCAN: - key = dbm_firstkey(db); - if (dbm_error(db)) { - fprintf(stderr, "Error when fetching first key\n"); - goto db_exit; - } - while (key.dptr != NULL) { - content = dbm_fetch(db, key); - if (dbm_error(db)) { - fprintf(stderr, "Error when fetching "); - print_datum(key); - printf("\n"); - goto db_exit; - } - print_datum(key); - printf(": "); - print_datum(content); - printf("\n"); - if (dbm_error(db)) { - fprintf(stderr, "Error when fetching next key\n"); - goto db_exit; - } - key = dbm_nextkey(db); - } - break; - - case REGEXP: - if (argn < 2) { - fprintf(stderr, "Missing regular expression.\n"); - goto db_exit; - } - if (re_comp(comarg[1])) { - fprintf(stderr, "Invalid regular expression\n"); - goto db_exit; - } - key = dbm_firstkey(db); - if (dbm_error(db)) { - fprintf(stderr, "Error when fetching first key\n"); - goto db_exit; - } - while (key.dptr != NULL) { - if (re_exec(key2s(key))) { - content = dbm_fetch(db, key); - if (dbm_error(db)) { - fprintf(stderr, "Error when fetching "); - print_datum(key); - printf("\n"); - goto db_exit; - } - print_datum(key); - printf(": "); - print_datum(content); - printf("\n"); - if (dbm_error(db)) { - fprintf(stderr, "Error when fetching next key\n"); - goto db_exit; - } - } - key = dbm_nextkey(db); - } - break; - - case FETCH: - if (argn < 2) { - fprintf(stderr, "Missing fetch key.\n"); - goto db_exit; - } - content = dbm_fetch(db, key); - if (dbm_error(db)) { - fprintf(stderr, "Error when fetching "); - print_datum(key); - printf("\n"); - goto db_exit; - } - if (content.dptr == NULL) { - fprintf(stderr, "Cannot find "); - print_datum(key); - printf("\n"); - goto db_exit; - } - print_datum(key); - printf(": "); - print_datum(content); - printf("\n"); - break; - - case DELETE: - if (argn < 2) { - fprintf(stderr, "Missing delete key.\n"); - goto db_exit; - } - if (dbm_delete(db, key) || dbm_error(db)) { - fprintf(stderr, "Error when deleting "); - print_datum(key); - printf("\n"); - goto db_exit; - } - if (verbose) { - print_datum(key); - printf(": DELETED\n"); - } - break; - - case STORE: - if (argn < 3) { - fprintf(stderr, "Missing key and/or content.\n"); - goto db_exit; - } - if (dbm_store(db, key, content, st_flag) || dbm_error(db)) { - fprintf(stderr, "Error when storing "); - print_datum(key); - printf("\n"); - goto db_exit; - } - if (verbose) { - print_datum(key); - printf(": "); - print_datum(content); - printf(" STORED\n"); - } - break; - } - -db_exit: - dbm_clearerr(db); - dbm_close(db); - if (dbm_error(db)) { - fprintf(stderr, "Error closing database \"%s\"\n", comarg[0]); - exit(-1); - } -} diff --git a/contrib/perl5/ext/SDBM_File/sdbm/dbm.c b/contrib/perl5/ext/SDBM_File/sdbm/dbm.c deleted file mode 100644 index 321ac3e..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/dbm.c +++ /dev/null @@ -1,134 +0,0 @@ -/* - * Copyright (c) 1985 The Regents of the University of California. - * All rights reserved. - * - * Redistribution and use in source and binary forms are permitted - * provided that the above copyright notice and this notice are - * duplicated in all such forms. - * - * [additional clause stricken -- see below] - * - * The name of the University may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR - * PURPOSE. - * - * This notice previously contained the additional clause: - * - * and that any documentation, advertising materials, and other - * materials related to such distribution and use acknowledge that - * the software was developed by the University of California, - * Berkeley. - * - * Pursuant to the licensing change made by the Office of Technology - * Licensing of the University of California, Berkeley on July 22, - * 1999 and documented in: - * - * ftp://ftp.cs.berkeley.edu/pub/4bsd/README.Impt.License.Change - * - * this clause has been stricken and no longer is applicable to this - * software. - */ - -#ifndef lint -static char sccsid[] = "@(#)dbm.c 5.4 (Berkeley) 5/24/89"; -#endif /* not lint */ - -#include "dbm.h" - -#define NODB ((DBM *)0) - -static DBM *cur_db = NODB; - -static char no_db[] = "dbm: no open database\n"; - -int -dbminit(char *file) -{ - if (cur_db != NODB) - dbm_close(cur_db); - - cur_db = dbm_open(file, 2, 0); - if (cur_db == NODB) { - cur_db = dbm_open(file, 0, 0); - if (cur_db == NODB) - return (-1); - } - return (0); -} - -long -forder(datum key) -{ - if (cur_db == NODB) { - printf(no_db); - return (0L); - } - return (dbm_forder(cur_db, key)); -} - -datum -fetch(datum key) -{ - datum item; - - if (cur_db == NODB) { - printf(no_db); - item.dptr = 0; - return (item); - } - return (dbm_fetch(cur_db, key)); -} - -int -delete(datum key) -{ - if (cur_db == NODB) { - printf(no_db); - return (-1); - } - if (dbm_rdonly(cur_db)) - return (-1); - return (dbm_delete(cur_db, key)); -} - -int -store(datum key, datum dat) -{ - if (cur_db == NODB) { - printf(no_db); - return (-1); - } - if (dbm_rdonly(cur_db)) - return (-1); - - return (dbm_store(cur_db, key, dat, DBM_REPLACE)); -} - -datum -firstkey(void) -{ - datum item; - - if (cur_db == NODB) { - printf(no_db); - item.dptr = 0; - return (item); - } - return (dbm_firstkey(cur_db)); -} - -datum -nextkey(datum key) -{ - datum item; - - if (cur_db == NODB) { - printf(no_db); - item.dptr = 0; - return (item); - } - return (dbm_nextkey(cur_db, key)); -} diff --git a/contrib/perl5/ext/SDBM_File/sdbm/dbm.h b/contrib/perl5/ext/SDBM_File/sdbm/dbm.h deleted file mode 100644 index e2c9355..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/dbm.h +++ /dev/null @@ -1,52 +0,0 @@ -/* - * Copyright (c) 1983 The Regents of the University of California. - * All rights reserved. - * - * Redistribution and use in source and binary forms are permitted - * provided that the above copyright notice and this notice are - * duplicated in all such forms. - * - * [additional clause stricken -- see below] - * - * The name of the University may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR - * PURPOSE. - * - * This notice previously contained the additional clause: - * - * and that any documentation, advertising materials, and other - * materials related to such distribution and use acknowledge that - * the software was developed by the University of California, - * Berkeley. - * - * Pursuant to the licensing change made by the Office of Technology - * Licensing of the University of California, Berkeley on July 22, - * 1999 and documented in: - * - * ftp://ftp.cs.berkeley.edu/pub/4bsd/README.Impt.License.Change - * - * this clause has been stricken and no longer is applicable to this - * software. - * - * @(#)dbm.h 5.2 (Berkeley) 5/24/89 - */ - -#ifndef NULL -/* - * this is lunacy, we no longer use it (and never should have - * unconditionally defined it), but, this whole file is for - * backwards compatability - someone may rely on this. - */ -#define NULL ((char *) 0) -#endif - -#ifdef I_NDBM -# include <ndbm.h> -#endif - -datum fetch(); -datum firstkey(); -datum nextkey(); diff --git a/contrib/perl5/ext/SDBM_File/sdbm/dbu.c b/contrib/perl5/ext/SDBM_File/sdbm/dbu.c deleted file mode 100644 index e68b78d..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/dbu.c +++ /dev/null @@ -1,243 +0,0 @@ -#include <stdio.h> -#include <sys/file.h> -#ifdef SDBM -#include "EXTERN.h" -#include "sdbm.h" -#else -#include <ndbm.h> -#endif -#include <string.h> - -#ifdef BSD42 -#define strchr index -#endif - -extern int getopt(); -extern char *strchr(); -extern void oops(); - -char *progname; - -static int rflag; -static char *usage = "%s [-R] cat | look |... dbmname"; - -#define DERROR 0 -#define DLOOK 1 -#define DINSERT 2 -#define DDELETE 3 -#define DCAT 4 -#define DBUILD 5 -#define DPRESS 6 -#define DCREAT 7 - -#define LINEMAX 8192 - -typedef struct { - char *sname; - int scode; - int flags; -} cmd; - -static cmd cmds[] = { - - "fetch", DLOOK, O_RDONLY, - "get", DLOOK, O_RDONLY, - "look", DLOOK, O_RDONLY, - "add", DINSERT, O_RDWR, - "insert", DINSERT, O_RDWR, - "store", DINSERT, O_RDWR, - "delete", DDELETE, O_RDWR, - "remove", DDELETE, O_RDWR, - "dump", DCAT, O_RDONLY, - "list", DCAT, O_RDONLY, - "cat", DCAT, O_RDONLY, - "creat", DCREAT, O_RDWR | O_CREAT | O_TRUNC, - "new", DCREAT, O_RDWR | O_CREAT | O_TRUNC, - "build", DBUILD, O_RDWR | O_CREAT, - "squash", DPRESS, O_RDWR, - "compact", DPRESS, O_RDWR, - "compress", DPRESS, O_RDWR -}; - -#define CTABSIZ (sizeof (cmds)/sizeof (cmd)) - -static cmd *parse(); -static void badk(), doit(), prdatum(); - -int -main(int argc, char **argv) -{ - int c; - register cmd *act; - extern int optind; - extern char *optarg; - - progname = argv[0]; - - while ((c = getopt(argc, argv, "R")) != EOF) - switch (c) { - case 'R': /* raw processing */ - rflag++; - break; - - default: - oops("usage: %s", usage); - break; - } - - if ((argc -= optind) < 2) - oops("usage: %s", usage); - - if ((act = parse(argv[optind])) == NULL) - badk(argv[optind]); - optind++; - doit(act, argv[optind]); - return 0; -} - -static void -doit(register cmd *act, char *file) -{ - datum key; - datum val; - register DBM *db; - register char *op; - register int n; - char *line; -#ifdef TIME - long start; - extern long time(); -#endif - - if ((db = dbm_open(file, act->flags, 0644)) == NULL) - oops("cannot open: %s", file); - - if ((line = (char *) malloc(LINEMAX)) == NULL) - oops("%s: cannot get memory", "line alloc"); - - switch (act->scode) { - - case DLOOK: - while (fgets(line, LINEMAX, stdin) != NULL) { - n = strlen(line) - 1; - line[n] = 0; - key.dptr = line; - key.dsize = n; - val = dbm_fetch(db, key); - if (val.dptr != NULL) { - prdatum(stdout, val); - putchar('\n'); - continue; - } - prdatum(stderr, key); - fprintf(stderr, ": not found.\n"); - } - break; - case DINSERT: - break; - case DDELETE: - while (fgets(line, LINEMAX, stdin) != NULL) { - n = strlen(line) - 1; - line[n] = 0; - key.dptr = line; - key.dsize = n; - if (dbm_delete(db, key) == -1) { - prdatum(stderr, key); - fprintf(stderr, ": not found.\n"); - } - } - break; - case DCAT: - for (key = dbm_firstkey(db); key.dptr != 0; - key = dbm_nextkey(db)) { - prdatum(stdout, key); - putchar('\t'); - prdatum(stdout, dbm_fetch(db, key)); - putchar('\n'); - } - break; - case DBUILD: -#ifdef TIME - start = time(0); -#endif - while (fgets(line, LINEMAX, stdin) != NULL) { - n = strlen(line) - 1; - line[n] = 0; - key.dptr = line; - if ((op = strchr(line, '\t')) != 0) { - key.dsize = op - line; - *op++ = 0; - val.dptr = op; - val.dsize = line + n - op; - } - else - oops("bad input; %s", line); - - if (dbm_store(db, key, val, DBM_REPLACE) < 0) { - prdatum(stderr, key); - fprintf(stderr, ": "); - oops("store: %s", "failed"); - } - } -#ifdef TIME - printf("done: %d seconds.\n", time(0) - start); -#endif - break; - case DPRESS: - break; - case DCREAT: - break; - } - - dbm_close(db); -} - -static void -badk(char *word) -{ - register int i; - - if (progname) - fprintf(stderr, "%s: ", progname); - fprintf(stderr, "bad keywd %s. use one of\n", word); - for (i = 0; i < (int)CTABSIZ; i++) - fprintf(stderr, "%-8s%c", cmds[i].sname, - ((i + 1) % 6 == 0) ? '\n' : ' '); - fprintf(stderr, "\n"); - exit(1); - /*NOTREACHED*/ -} - -static cmd * -parse(register char *str) -{ - register int i = CTABSIZ; - register cmd *p; - - for (p = cmds; i--; p++) - if (strcmp(p->sname, str) == 0) - return p; - return NULL; -} - -static void -prdatum(FILE *stream, datum d) -{ - register int c; - register char *p = d.dptr; - register int n = d.dsize; - - while (n--) { - c = *p++ & 0377; - if (c & 0200) { - fprintf(stream, "M-"); - c &= 0177; - } - if (c == 0177 || c < ' ') - fprintf(stream, "^%c", (c == 0177) ? '?' : c + '@'); - else - putc(c, stream); - } -} - - diff --git a/contrib/perl5/ext/SDBM_File/sdbm/grind b/contrib/perl5/ext/SDBM_File/sdbm/grind deleted file mode 100755 index 23728b7..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/grind +++ /dev/null @@ -1,9 +0,0 @@ -#!/bin/sh -rm -f /tmp/*.dir /tmp/*.pag -awk -e '{ - printf "%s\t", $0 - for (i = 0; i < 40; i++) - printf "%s.", $0 - printf "\n" -}' < /usr/dict/words | $1 build /tmp/$2 - diff --git a/contrib/perl5/ext/SDBM_File/sdbm/hash.c b/contrib/perl5/ext/SDBM_File/sdbm/hash.c deleted file mode 100644 index 9b27648..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/hash.c +++ /dev/null @@ -1,47 +0,0 @@ -/* - * sdbm - ndbm work-alike hashed database library - * based on Per-Aake Larson's Dynamic Hashing algorithms. BIT 18 (1978). - * author: oz@nexus.yorku.ca - * status: public domain. keep it that way. - * - * hashing routine - */ - -#include "config.h" -#include "EXTERN.h" -#include "sdbm.h" -/* - * polynomial conversion ignoring overflows - * [this seems to work remarkably well, in fact better - * then the ndbm hash function. Replace at your own risk] - * use: 65599 nice. - * 65587 even better. - */ -long -sdbm_hash(register char *str, register int len) -{ - register unsigned long n = 0; - -#ifdef DUFF - -#define HASHC n = *str++ + 65599 * n - - if (len > 0) { - register int loop = (len + 8 - 1) >> 3; - - switch(len & (8 - 1)) { - case 0: do { - HASHC; case 7: HASHC; - case 6: HASHC; case 5: HASHC; - case 4: HASHC; case 3: HASHC; - case 2: HASHC; case 1: HASHC; - } while (--loop); - } - - } -#else - while (len--) - n = *str++ + 65599 * n; -#endif - return n; -} diff --git a/contrib/perl5/ext/SDBM_File/sdbm/linux.patches b/contrib/perl5/ext/SDBM_File/sdbm/linux.patches deleted file mode 100644 index cb7b1b7..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/linux.patches +++ /dev/null @@ -1,67 +0,0 @@ -*** sdbm.dist/./dbu.c Mon Feb 17 21:18:52 1992 ---- sdbm/./dbu.c Mon Feb 17 21:11:20 1992 -*************** -*** 12,18 **** - #endif - - extern int getopt(); -! extern char *strchr(); - extern void oops(); - - char *progname; ---- 12,18 ---- - #endif - - extern int getopt(); -! /* extern char *strchr(); */ - extern void oops(); - - char *progname; -*** sdbm.dist/./makefile Mon Feb 17 21:18:56 1992 ---- sdbm/./makefile Mon Feb 17 21:10:46 1992 -*************** -*** 2,8 **** - # makefile for public domain ndbm-clone: sdbm - # DUFF: use duff's device (loop unroll) in parts of the code - # -! CFLAGS = -O -DSDBM -DDUFF -DBSD42 - #LDFLAGS = -p - - OBJS = sdbm.o pair.o hash.o ---- 2,8 ---- - # makefile for public domain ndbm-clone: sdbm - # DUFF: use duff's device (loop unroll) in parts of the code - # -! CFLAGS = -O -DSDBM -DDUFF - #LDFLAGS = -p - - OBJS = sdbm.o pair.o hash.o -*** sdbm.dist/./sdbm.c Mon Feb 17 21:19:17 1992 ---- sdbm/./sdbm.c Mon Feb 17 21:12:59 1992 -*************** -*** 25,30 **** ---- 25,31 ---- - #endif - #include <errno.h> - #include <string.h> -+ #include <unistd.h> - - #ifdef __STDC__ - #include <stddef.h> -*************** -*** 43,49 **** - - extern char *malloc proto((unsigned int)); - extern void free proto((void *)); -! extern long lseek(); - - /* - * forward ---- 44,50 ---- - - extern char *malloc proto((unsigned int)); - extern void free proto((void *)); -! /* extern long lseek(); */ - - /* - * forward diff --git a/contrib/perl5/ext/SDBM_File/sdbm/makefile.sdbm b/contrib/perl5/ext/SDBM_File/sdbm/makefile.sdbm deleted file mode 100644 index c959c1f..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/makefile.sdbm +++ /dev/null @@ -1,55 +0,0 @@ -# -# makefile for public domain ndbm-clone: sdbm -# DUFF: use duff's device (loop unroll) in parts of the code -# -CFLAGS = -O -DSDBM -DDUFF -DBSD42 -pic -#LDFLAGS = -p - -OBJS = sdbm.o pair.o hash.o -SRCS = sdbm.c pair.c hash.c dbu.c dba.c dbd.c util.c -HDRS = tune.h sdbm.h pair.h -MISC = README CHANGES COMPARE sdbm.3 dbe.c dbe.1 dbm.c dbm.h biblio \ - readme.ms readme.ps - -all: dbu dba dbd dbe - -dbu: dbu.o sdbm util.o - cc $(LDFLAGS) -o dbu dbu.o util.o libsdbm.a - -dba: dba.o util.o - cc $(LDFLAGS) -o dba dba.o util.o -dbd: dbd.o util.o - cc $(LDFLAGS) -o dbd dbd.o util.o -dbe: dbe.o sdbm - cc $(LDFLAGS) -o dbe dbe.o libsdbm.a - -sdbm: $(OBJS) - ar cr libsdbm.a $(OBJS) - ranlib libsdbm.a -### cp libsdbm.a /usr/lib/libsdbm.a - -dba.o: sdbm.h -dbu.o: sdbm.h -util.o:sdbm.h - -$(OBJS): sdbm.h tune.h pair.h - -# -# dbu using berkelezoid ndbm routines [if you have them] for testing -# -#x-dbu: dbu.o util.o -# cc $(CFLAGS) -o x-dbu dbu.o util.o -lint: - lint -abchx $(SRCS) - -clean: - rm -f *.o mon.out core - -purge: clean - rm -f dbu libsdbm.a dbd dba dbe x-dbu *.dir *.pag - -shar: - shar $(MISC) makefile $(SRCS) $(HDRS) >SDBM.SHAR - -readme: - nroff -ms readme.ms | col -b >README diff --git a/contrib/perl5/ext/SDBM_File/sdbm/pair.c b/contrib/perl5/ext/SDBM_File/sdbm/pair.c deleted file mode 100644 index 4f0fde2..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/pair.c +++ /dev/null @@ -1,298 +0,0 @@ -/* - * sdbm - ndbm work-alike hashed database library - * based on Per-Aake Larson's Dynamic Hashing algorithms. BIT 18 (1978). - * author: oz@nexus.yorku.ca - * status: public domain. - * - * page-level routines - */ - -#include "config.h" -#ifdef __CYGWIN__ -# define EXTCONST extern const -#else -# include "EXTERN.h" -#endif -#include "sdbm.h" -#include "tune.h" -#include "pair.h" - -#define exhash(item) sdbm_hash((item).dptr, (item).dsize) - -/* - * forward - */ -static int seepair proto((char *, int, char *, int)); - -/* - * page format: - * +------------------------------+ - * ino | n | keyoff | datoff | keyoff | - * +------------+--------+--------+ - * | datoff | - - - ----> | - * +--------+---------------------+ - * | F R E E A R E A | - * +--------------+---------------+ - * | <---- - - - | data | - * +--------+-----+----+----------+ - * | key | data | key | - * +--------+----------+----------+ - * - * calculating the offsets for free area: if the number - * of entries (ino[0]) is zero, the offset to the END of - * the free area is the block size. Otherwise, it is the - * nth (ino[ino[0]]) entry's offset. - */ - -int -fitpair(char *pag, int need) -{ - register int n; - register int off; - register int free; - register short *ino = (short *) pag; - - off = ((n = ino[0]) > 0) ? ino[n] : PBLKSIZ; - free = off - (n + 1) * sizeof(short); - need += 2 * sizeof(short); - - debug(("free %d need %d\n", free, need)); - - return need <= free; -} - -void -putpair(char *pag, datum key, datum val) -{ - register int n; - register int off; - register short *ino = (short *) pag; - - off = ((n = ino[0]) > 0) ? ino[n] : PBLKSIZ; -/* - * enter the key first - */ - off -= key.dsize; - (void) memcpy(pag + off, key.dptr, key.dsize); - ino[n + 1] = off; -/* - * now the data - */ - off -= val.dsize; - (void) memcpy(pag + off, val.dptr, val.dsize); - ino[n + 2] = off; -/* - * adjust item count - */ - ino[0] += 2; -} - -datum -getpair(char *pag, datum key) -{ - register int i; - register int n; - datum val; - register short *ino = (short *) pag; - - if ((n = ino[0]) == 0) - return nullitem; - - if ((i = seepair(pag, n, key.dptr, key.dsize)) == 0) - return nullitem; - - val.dptr = pag + ino[i + 1]; - val.dsize = ino[i] - ino[i + 1]; - return val; -} - -int -exipair(char *pag, datum key) -{ - register short *ino = (short *) pag; - - if (ino[0] == 0) - return 0; - - return (seepair(pag, ino[0], key.dptr, key.dsize) != 0); -} - -#ifdef SEEDUPS -int -duppair(char *pag, datum key) -{ - register short *ino = (short *) pag; - return ino[0] > 0 && seepair(pag, ino[0], key.dptr, key.dsize) > 0; -} -#endif - -datum -getnkey(char *pag, int num) -{ - datum key; - register int off; - register short *ino = (short *) pag; - - num = num * 2 - 1; - if (ino[0] == 0 || num > ino[0]) - return nullitem; - - off = (num > 1) ? ino[num - 1] : PBLKSIZ; - - key.dptr = pag + ino[num]; - key.dsize = off - ino[num]; - - return key; -} - -int -delpair(char *pag, datum key) -{ - register int n; - register int i; - register short *ino = (short *) pag; - - if ((n = ino[0]) == 0) - return 0; - - if ((i = seepair(pag, n, key.dptr, key.dsize)) == 0) - return 0; -/* - * found the key. if it is the last entry - * [i.e. i == n - 1] we just adjust the entry count. - * hard case: move all data down onto the deleted pair, - * shift offsets onto deleted offsets, and adjust them. - * [note: 0 < i < n] - */ - if (i < n - 1) { - register int m; - register char *dst = pag + (i == 1 ? PBLKSIZ : ino[i - 1]); - register char *src = pag + ino[i + 1]; - register int zoo = dst - src; - - debug(("free-up %d ", zoo)); -/* - * shift data/keys down - */ - m = ino[i + 1] - ino[n]; -#ifdef DUFF -#define MOVB *--dst = *--src - - if (m > 0) { - register int loop = (m + 8 - 1) >> 3; - - switch (m & (8 - 1)) { - case 0: do { - MOVB; case 7: MOVB; - case 6: MOVB; case 5: MOVB; - case 4: MOVB; case 3: MOVB; - case 2: MOVB; case 1: MOVB; - } while (--loop); - } - } -#else -#ifdef HAS_MEMMOVE - dst -= m; - src -= m; - memmove(dst, src, m); -#else - while (m--) - *--dst = *--src; -#endif -#endif -/* - * adjust offset index up - */ - while (i < n - 1) { - ino[i] = ino[i + 2] + zoo; - i++; - } - } - ino[0] -= 2; - return 1; -} - -/* - * search for the key in the page. - * return offset index in the range 0 < i < n. - * return 0 if not found. - */ -static int -seepair(char *pag, register int n, register char *key, register int siz) -{ - register int i; - register int off = PBLKSIZ; - register short *ino = (short *) pag; - - for (i = 1; i < n; i += 2) { - if (siz == off - ino[i] && - memEQ(key, pag + ino[i], siz)) - return i; - off = ino[i + 1]; - } - return 0; -} - -void -splpage(char *pag, char *New, long int sbit) -{ - datum key; - datum val; - - register int n; - register int off = PBLKSIZ; - char cur[PBLKSIZ]; - register short *ino = (short *) cur; - - (void) memcpy(cur, pag, PBLKSIZ); - (void) memset(pag, 0, PBLKSIZ); - (void) memset(New, 0, PBLKSIZ); - - n = ino[0]; - for (ino++; n > 0; ino += 2) { - key.dptr = cur + ino[0]; - key.dsize = off - ino[0]; - val.dptr = cur + ino[1]; - val.dsize = ino[0] - ino[1]; -/* - * select the page pointer (by looking at sbit) and insert - */ - (void) putpair((exhash(key) & sbit) ? New : pag, key, val); - - off = ino[1]; - n -= 2; - } - - debug(("%d split %d/%d\n", ((short *) cur)[0] / 2, - ((short *) New)[0] / 2, - ((short *) pag)[0] / 2)); -} - -/* - * check page sanity: - * number of entries should be something - * reasonable, and all offsets in the index should be in order. - * this could be made more rigorous. - */ -int -chkpage(char *pag) -{ - register int n; - register int off; - register short *ino = (short *) pag; - - if ((n = ino[0]) < 0 || n > PBLKSIZ / sizeof(short)) - return 0; - - if (n > 0) { - off = PBLKSIZ; - for (ino++; n > 0; ino += 2) { - if (ino[0] > off || ino[1] > off || - ino[1] > ino[0]) - return 0; - off = ino[1]; - n -= 2; - } - } - return 1; -} diff --git a/contrib/perl5/ext/SDBM_File/sdbm/pair.h b/contrib/perl5/ext/SDBM_File/sdbm/pair.h deleted file mode 100644 index b6944ed..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/pair.h +++ /dev/null @@ -1,22 +0,0 @@ -/* Mini EMBED (pair.c) */ -#define chkpage sdbm__chkpage -#define delpair sdbm__delpair -#define duppair sdbm__duppair -#define exipair sdbm__exipair -#define fitpair sdbm__fitpair -#define getnkey sdbm__getnkey -#define getpair sdbm__getpair -#define putpair sdbm__putpair -#define splpage sdbm__splpage - -extern int fitpair proto((char *, int)); -extern void putpair proto((char *, datum, datum)); -extern datum getpair proto((char *, datum)); -extern int exipair proto((char *, datum)); -extern int delpair proto((char *, datum)); -extern int chkpage proto((char *)); -extern datum getnkey proto((char *, int)); -extern void splpage proto((char *, char *, long)); -#ifdef SEEDUPS -extern int duppair proto((char *, datum)); -#endif diff --git a/contrib/perl5/ext/SDBM_File/sdbm/readme.ms b/contrib/perl5/ext/SDBM_File/sdbm/readme.ms deleted file mode 100644 index 01ca17c..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/readme.ms +++ /dev/null @@ -1,353 +0,0 @@ -.\" tbl | readme.ms | [tn]roff -ms | ... -.\" note the "C" (courier) and "CB" fonts: you will probably have to -.\" change these. -.\" $Id: readme.ms,v 1.1 90/12/13 13:09:15 oz Exp Locker: oz $ - -.de P1 -.br -.nr dT 4 -.nf -.ft C -.sp .5 -.nr t \\n(dT*\\w'x'u -.ta 1u*\\ntu 2u*\\ntu 3u*\\ntu 4u*\\ntu 5u*\\ntu 6u*\\ntu 7u*\\ntu 8u*\\ntu 9u*\\ntu 10u*\\ntu 11u*\\ntu 12u*\\ntu 13u*\\ntu 14u*\\ntu -.. -.de P2 -.br -.ft 1 -.br -.sp .5 -.br -.fi -.. -.\" CW uses the typewriter/courier font. -.de CW -\fC\\$1\\fP\\$2 -.. - -.\" Footnote numbering [by Henry Spencer] -.\" <text>\*f for a footnote number.. -.\" .FS -.\" \*F <footnote text> -.\" .FE -.\" -.ds f \\u\\s-2\\n+f\\s+2\\d -.nr f 0 1 -.ds F \\n+F. -.nr F 0 1 - -.ND -.LP -.TL -\fIsdbm\fP \(em Substitute DBM -.br -or -.br -Berkeley \fIndbm\fP for Every UN*X\** Made Simple -.AU -Ozan (oz) Yigit -.AI -The Guild of PD Software Toolmakers -Toronto - Canada -.sp -oz@nexus.yorku.ca -.LP -.FS -UN*X is not a trademark of any (dis)organization. -.FE -.sp 2 -\fIImplementation is the sincerest form of flattery. \(em L. Peter Deutsch\fP -.SH -A The Clone of the \fIndbm\fP library -.PP -The sources accompanying this notice \(em \fIsdbm\fP \(em constitute -the first public release (Dec. 1990) of a complete clone of -the Berkeley UN*X \fIndbm\fP library. The \fIsdbm\fP library is meant to -clone the proven functionality of \fIndbm\fP as closely as possible, -including a few improvements. It is practical, easy to understand, and -compatible. -The \fIsdbm\fP library is not derived from any licensed, proprietary or -copyrighted software. -.PP -The \fIsdbm\fP implementation is based on a 1978 algorithm -[Lar78] by P.-A. (Paul) Larson known as ``Dynamic Hashing''. -In the course of searching for a substitute for \fIndbm\fP, I -prototyped three different external-hashing algorithms [Lar78, Fag79, Lit80] -and ultimately chose Larson's algorithm as a basis of the \fIsdbm\fP -implementation. The Bell Labs -\fIdbm\fP (and therefore \fIndbm\fP) is based on an algorithm invented by -Ken Thompson, [Tho90, Tor87] and predates Larson's work. -.PP -The \fIsdbm\fR programming interface is totally compatible -with \fIndbm\fP and includes a slight improvement in database initialization. -It is also expected to be binary-compatible under most UN*X versions that -support the \fIndbm\fP library. -.PP -The \fIsdbm\fP implementation shares the shortcomings of the \fIndbm\fP -library, as a side effect of various simplifications to the original Larson -algorithm. It does produce \fIholes\fP in the page file as it writes -pages past the end of file. (Larson's paper include a clever solution to -this problem that is a result of using the hash value directly as a block -address.) On the other hand, extensive tests seem to indicate that \fIsdbm\fP -creates fewer holes in general, and the resulting pagefiles are -smaller. The \fIsdbm\fP implementation is also faster than \fIndbm\fP -in database creation. -Unlike the \fIndbm\fP, the \fIsdbm\fP -.CW store -operation will not ``wander away'' trying to split its -data pages to insert a datum that \fIcannot\fP (due to elaborate worst-case -situations) be inserted. (It will fail after a pre-defined number of attempts.) -.SH -Important Compatibility Warning -.PP -The \fIsdbm\fP and \fIndbm\fP -libraries \fIcannot\fP share databases: one cannot read the (dir/pag) -database created by the other. This is due to the differences -between the \fIndbm\fP and \fIsdbm\fP algorithms\**, -.FS -Torek's discussion [Tor87] -indicates that \fIdbm/ndbm\fP implementations use the hash -value to traverse the radix trie differently than \fIsdbm\fP -and as a result, the page indexes are generated in \fIdifferent\fP order. -For more information, send e-mail to the author. -.FE -and the hash functions -used. -It is easy to convert between the \fIdbm/ndbm\fP databases and \fIsdbm\fP -by ignoring the index completely: see -.CW dbd , -.CW dbu -etc. -.R -.LP -.SH -Notice of Intellectual Property -.LP -\fIThe entire\fP sdbm \fIlibrary package, as authored by me,\fP Ozan S. Yigit, -\fIis hereby placed in the public domain.\fP As such, the author is not -responsible for the consequences of use of this software, no matter how -awful, even if they arise from defects in it. There is no expressed or -implied warranty for the \fIsdbm\fP library. -.PP -Since the \fIsdbm\fP -library package is in the public domain, this \fIoriginal\fP -release or any additional public-domain releases of the modified original -cannot possibly (by definition) be withheld from you. Also by definition, -You (singular) have all the rights to this code (including the right to -sell without permission, the right to hoard\** -.FS -You cannot really hoard something that is available to the public at -large, but try if it makes you feel any better. -.FE -and the right to do other icky things as -you see fit) but those rights are also granted to everyone else. -.PP -Please note that all previous distributions of this software contained -a copyright (which is now dropped) to protect its -origins and its current public domain status against any possible claims -and/or challenges. -.SH -Acknowledgments -.PP -Many people have been very helpful and supportive. A partial list would -necessarily include Rayan Zacherissen (who contributed the man page, -and also hacked a MMAP version of \fIsdbm\fP), -Arnold Robbins, Chris Lewis, -Bill Davidsen, Henry Spencer, Geoff Collyer, Rich Salz (who got me started -in the first place), Johannes Ruschein -(who did the minix port) and David Tilbrook. I thank you all. -.SH -Distribution Manifest and Notes -.LP -This distribution of \fIsdbm\fP includes (at least) the following: -.P1 - CHANGES change log - README this file. - biblio a small bibliography on external hashing - dba.c a crude (n/s)dbm page file analyzer - dbd.c a crude (n/s)dbm page file dumper (for conversion) - dbe.1 man page for dbe.c - dbe.c Janick's database editor - dbm.c a dbm library emulation wrapper for ndbm/sdbm - dbm.h header file for the above - dbu.c a crude db management utility - hash.c hashing function - makefile guess. - pair.c page-level routines (posted earlier) - pair.h header file for the above - readme.ms troff source for the README file - sdbm.3 man page - sdbm.c the real thing - sdbm.h header file for the above - tune.h place for tuning & portability thingies - util.c miscellaneous -.P2 -.PP -.CW dbu -is a simple database manipulation program\** that tries to look -.FS -The -.CW dbd , -.CW dba , -.CW dbu -utilities are quick hacks and are not fit for production use. They were -developed late one night, just to test out \fIsdbm\fP, and convert some -databases. -.FE -like Bell Labs' -.CW cbt -utility. It is currently incomplete in functionality. -I use -.CW dbu -to test out the routines: it takes (from stdin) tab separated -key/value pairs for commands like -.CW build -or -.CW insert -or takes keys for -commands like -.CW delete -or -.CW look . -.P1 - dbu <build|creat|look|insert|cat|delete> dbmfile -.P2 -.PP -.CW dba -is a crude analyzer of \fIdbm/sdbm/ndbm\fP -page files. It scans the entire -page file, reporting page level statistics, and totals at the end. -.PP -.CW dbd -is a crude dump program for \fIdbm/ndbm/sdbm\fP -databases. It ignores the -bitmap, and dumps the data pages in sequence. It can be used to create -input for the -.CW dbu -utility. -Note that -.CW dbd -will skip any NULLs in the key and data -fields, thus is unsuitable to convert some peculiar databases that -insist in including the terminating null. -.PP -I have also included a copy of the -.CW dbe -(\fIndbm\fP DataBase Editor) by Janick Bergeron [janick@bnr.ca] for -your pleasure. You may find it more useful than the little -.CW dbu -utility. -.PP -.CW dbm.[ch] -is a \fIdbm\fP library emulation on top of \fIndbm\fP -(and hence suitable for \fIsdbm\fP). Written by Robert Elz. -.PP -The \fIsdbm\fP -library has been around in beta test for quite a long time, and from whatever -little feedback I received (maybe no news is good news), I believe it has been -functioning without any significant problems. I would, of course, appreciate -all fixes and/or improvements. Portability enhancements would especially be -useful. -.SH -Implementation Issues -.PP -Hash functions: -The algorithm behind \fIsdbm\fP implementation needs a good bit-scrambling -hash function to be effective. I ran into a set of constants for a simple -hash function that seem to help \fIsdbm\fP perform better than \fIndbm\fP -for various inputs: -.P1 - /* - * polynomial conversion ignoring overflows - * 65599 nice. 65587 even better. - */ - long - dbm_hash(char *str, int len) { - register unsigned long n = 0; - - while (len--) - n = n * 65599 + *str++; - return n; - } -.P2 -.PP -There may be better hash functions for the purposes of dynamic hashing. -Try your favorite, and check the pagefile. If it contains too many pages -with too many holes, (in relation to this one for example) or if -\fIsdbm\fP -simply stops working (fails after -.CW SPLTMAX -attempts to split) when you feed your -NEWS -.CW history -file to it, you probably do not have a good hashing function. -If you do better (for different types of input), I would like to know -about the function you use. -.PP -Block sizes: It seems (from various tests on a few machines) that a page -file block size -.CW PBLKSIZ -of 1024 is by far the best for performance, but -this also happens to limit the size of a key/value pair. Depending on your -needs, you may wish to increase the page size, and also adjust -.CW PAIRMAX -(the maximum size of a key/value pair allowed: should always be at least -three words smaller than -.CW PBLKSIZ .) -accordingly. The system-wide version of the library -should probably be -configured with 1024 (distribution default), as this appears to be sufficient -for most common uses of \fIsdbm\fP. -.SH -Portability -.PP -This package has been tested in many different UN*Xes even including minix, -and appears to be reasonably portable. This does not mean it will port -easily to non-UN*X systems. -.SH -Notes and Miscellaneous -.PP -The \fIsdbm\fP is not a very complicated package, at least not after you -familiarize yourself with the literature on external hashing. There are -other interesting algorithms in existence that ensure (approximately) -single-read access to a data value associated with any key. These are -directory-less schemes such as \fIlinear hashing\fP [Lit80] (+ Larson -variations), \fIspiral storage\fP [Mar79] or directory schemes such as -\fIextensible hashing\fP [Fag79] by Fagin et al. I do hope these sources -provide a reasonable playground for experimentation with other algorithms. -See the June 1988 issue of ACM Computing Surveys [Enb88] for an -excellent overview of the field. -.PG -.SH -References -.LP -.IP [Lar78] 4m -P.-A. Larson, -``Dynamic Hashing'', \fIBIT\fP, vol. 18, pp. 184-201, 1978. -.IP [Tho90] 4m -Ken Thompson, \fIprivate communication\fP, Nov. 1990 -.IP [Lit80] 4m -W. Litwin, -`` Linear Hashing: A new tool for file and table addressing'', -\fIProceedings of the 6th Conference on Very Large Dabatases (Montreal)\fP, -pp. 212-223, Very Large Database Foundation, Saratoga, Calif., 1980. -.IP [Fag79] 4m -R. Fagin, J. Nievergelt, N. Pippinger, and H. R. Strong, -``Extendible Hashing - A Fast Access Method for Dynamic Files'', -\fIACM Trans. Database Syst.\fP, vol. 4, no.3, pp. 315-344, Sept. 1979. -.IP [Wal84] 4m -Rich Wales, -``Discussion of "dbm" data base system'', \fIUSENET newsgroup unix.wizards\fP, -Jan. 1984. -.IP [Tor87] 4m -Chris Torek, -``Re: dbm.a and ndbm.a archives'', \fIUSENET newsgroup comp.unix\fP, -1987. -.IP [Mar79] 4m -G. N. Martin, -``Spiral Storage: Incrementally Augmentable Hash Addressed Storage'', -\fITechnical Report #27\fP, University of Varwick, Coventry, U.K., 1979. -.IP [Enb88] 4m -R. J. Enbody and H. C. Du, -``Dynamic Hashing Schemes'',\fIACM Computing Surveys\fP, -vol. 20, no. 2, pp. 85-113, June 1988. diff --git a/contrib/perl5/ext/SDBM_File/sdbm/sdbm.3 b/contrib/perl5/ext/SDBM_File/sdbm/sdbm.3 deleted file mode 100644 index fe6fe76..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/sdbm.3 +++ /dev/null @@ -1,295 +0,0 @@ -.\" $Id: sdbm.3,v 1.2 90/12/13 13:00:57 oz Exp $ -.TH SDBM 3 "1 March 1990" -.SH NAME -sdbm, sdbm_open, sdbm_prep, sdbm_close, sdbm_fetch, sdbm_store, sdbm_delete, sdbm_exists, sdbm_firstkey, sdbm_nextkey, sdbm_hash, sdbm_rdonly, sdbm_error, sdbm_clearerr, sdbm_dirfno, sdbm_pagfno \- data base subroutines -.SH SYNOPSIS -.nf -.ft B -#include <sdbm.h> -.sp -typedef struct { - char *dptr; - int dsize; -} datum; -.sp -datum nullitem = { NULL, 0 }; -.sp -\s-1DBM\s0 *sdbm_open(char *file, int flags, int mode) -.sp -\s-1DBM\s0 *sdbm_prep(char *dirname, char *pagname, int flags, int mode) -.sp -void sdbm_close(\s-1DBM\s0 *db) -.sp -datum sdbm_fetch(\s-1DBM\s0 *db, key) -.sp -int sdbm_store(\s-1DBM\s0 *db, datum key, datum val, int flags) -.sp -int sdbm_delete(\s-1DBM\s0 *db, datum key) -.sp -int sdbm_exists(\s-1DBM\s0 *db, datum key) -.sp -datum sdbm_firstkey(\s-1DBM\s0 *db) -.sp -datum sdbm_nextkey(\s-1DBM\s0 *db) -.sp -long sdbm_hash(char *string, int len) -.sp -int sdbm_rdonly(\s-1DBM\s0 *db) -int sdbm_error(\s-1DBM\s0 *db) -sdbm_clearerr(\s-1DBM\s0 *db) -int sdbm_dirfno(\s-1DBM\s0 *db) -int sdbm_pagfno(\s-1DBM\s0 *db) -.ft R -.fi -.SH DESCRIPTION -.IX "database library" sdbm "" "\fLsdbm\fR" -.IX sdbm_open "" "\fLsdbm_open\fR \(em open \fLsdbm\fR database" -.IX sdbm_prep "" "\fLsdbm_prep\fR \(em prepare \fLsdbm\fR database" -.IX sdbm_close "" "\fLsdbm_close\fR \(em close \fLsdbm\fR routine" -.IX sdbm_fetch "" "\fLsdbm_fetch\fR \(em fetch \fLsdbm\fR database data" -.IX sdbm_store "" "\fLsdbm_store\fR \(em add data to \fLsdbm\fR database" -.IX sdbm_delete "" "\fLsdbm_delete\fR \(em remove data from \fLsdbm\fR database" -.IX sdbm_exists "" "\fLsdbm_exists\fR \(em test \fLsdbm\fR key existence" -.IX sdbm_firstkey "" "\fLsdbm_firstkey\fR \(em access \fLsdbm\fR database" -.IX sdbm_nextkey "" "\fLsdbm_nextkey\fR \(em access \fLsdbm\fR database" -.IX sdbm_hash "" "\fLsdbm_hash\fR \(em string hash for \fLsdbm\fR database" -.IX sdbm_rdonly "" "\fLsdbm_rdonly\fR \(em return \fLsdbm\fR database read-only mode" -.IX sdbm_error "" "\fLsdbm_error\fR \(em return \fLsdbm\fR database error condition" -.IX sdbm_clearerr "" "\fLsdbm_clearerr\fR \(em clear \fLsdbm\fR database error condition" -.IX sdbm_dirfno "" "\fLsdbm_dirfno\fR \(em return \fLsdbm\fR database bitmap file descriptor" -.IX sdbm_pagfno "" "\fLsdbm_pagfno\fR \(em return \fLsdbm\fR database data file descriptor" -.IX "database functions \(em \fLsdbm\fR" sdbm_open "" \fLsdbm_open\fP -.IX "database functions \(em \fLsdbm\fR" sdbm_prep "" \fLsdbm_prep\fP -.IX "database functions \(em \fLsdbm\fR" sdbm_close "" \fLsdbm_close\fP -.IX "database functions \(em \fLsdbm\fR" sdbm_fetch "" \fLsdbm_fetch\fP -.IX "database functions \(em \fLsdbm\fR" sdbm_store "" \fLsdbm_store\fP -.IX "database functions \(em \fLsdbm\fR" sdbm_delete "" \fLsdbm_delete\fP -.IX "database functions \(em \fLsdbm\fR" sdbm_firstkey "" \fLsdbm_firstkey\fP -.IX "database functions \(em \fLsdbm\fR" sdbm_nextkey "" \fLsdbm_nextkey\fP -.IX "database functions \(em \fLsdbm\fR" sdbm_rdonly "" \fLsdbm_rdonly\fP -.IX "database functions \(em \fLsdbm\fR" sdbm_error "" \fLsdbm_error\fP -.IX "database functions \(em \fLsdbm\fR" sdbm_clearerr "" \fLsdbm_clearerr\fP -.IX "database functions \(em \fLsdbm\fR" sdbm_dirfno "" \fLsdbm_dirfno\fP -.IX "database functions \(em \fLsdbm\fR" sdbm_pagfno "" \fLsdbm_pagfno\fP -.LP -This package allows an application to maintain a mapping of <key,value> pairs -in disk files. This is not to be considered a real database system, but is -still useful in many simple applications built around fast retrieval of a data -value from a key. This implementation uses an external hashing scheme, -called Dynamic Hashing, as described by Per-Aake Larson in BIT 18 (1978) pp. -184-201. Retrieval of any item usually requires a single disk access. -The application interface is compatible with the -.IR ndbm (3) -library. -.LP -An -.B sdbm -database is kept in two files usually given the extensions -.B \.dir -and -.BR \.pag . -The -.B \.dir -file contains a bitmap representing a forest of binary hash trees, the leaves -of which indicate data pages in the -.B \.pag -file. -.LP -The application interface uses the -.B datum -structure to describe both -.I keys -and -.IR value s. -A -.B datum -specifies a byte sequence of -.I dsize -size pointed to by -.IR dptr . -If you use -.SM ASCII -strings as -.IR key s -or -.IR value s, -then you must decide whether or not to include the terminating -.SM NUL -byte which sometimes defines strings. Including it will require larger -database files, but it will be possible to get sensible output from a -.IR strings (1) -command applied to the data file. -.LP -In order to allow a process using this package to manipulate multiple -databases, the applications interface always requires a -.IR handle , -a -.BR "DBM *" , -to identify the database to be manipulated. Such a handle can be obtained -from the only routines that do not require it, namely -.BR sdbm_open (\|) -or -.BR sdbm_prep (\|). -Either of these will open or create the two necessary files. The -difference is that the latter allows explicitly naming the bitmap and data -files whereas -.BR sdbm_open (\|) -will take a base file name and call -.BR sdbm_prep (\|) -with the default extensions. -The -.I flags -and -.I mode -parameters are the same as for -.BR open (2). -.LP -To free the resources occupied while a database handle is active, call -.BR sdbm_close (\|). -.LP -Given a handle, one can retrieve data associated with a key by using the -.BR sdbm_fetch (\|) -routine, and associate data with a key by using the -.BR sdbm_store (\|) -routine. -.BR sdbm_exists (\|) -will say whether a given key exists in the database. -.LP -The values of the -.I flags -parameter for -.BR sdbm_store (\|) -can be either -.BR \s-1DBM_INSERT\s0 , -which will not change an existing entry with the same key, or -.BR \s-1DBM_REPLACE\s0 , -which will replace an existing entry with the same key. -Keys are unique within the database. -.LP -To delete a key and its associated value use the -.BR sdbm_delete (\|) -routine. -.LP -To retrieve every key in the database, use a loop like: -.sp -.nf -.ft B -for (key = sdbm_firstkey(db); key.dptr != NULL; key = sdbm_nextkey(db)) - ; -.ft R -.fi -.LP -The order of retrieval is unspecified. -.LP -If you determine that the performance of the database is inadequate or -you notice clustering or other effects that may be due to the hashing -algorithm used by this package, you can override it by supplying your -own -.BR sdbm_hash (\|) -routine. Doing so will make the database unintelligable to any other -applications that do not use your specialized hash function. -.sp -.LP -The following macros are defined in the header file: -.IP -.BR sdbm_rdonly (\|) -returns true if the database has been opened read\-only. -.IP -.BR sdbm_error (\|) -returns true if an I/O error has occurred. -.IP -.BR sdbm_clearerr (\|) -allows you to clear the error flag if you think you know what the error -was and insist on ignoring it. -.IP -.BR sdbm_dirfno (\|) -returns the file descriptor associated with the bitmap file. -.IP -.BR sdbm_pagfno (\|) -returns the file descriptor associated with the data file. -.SH SEE ALSO -.IR open (2). -.SH DIAGNOSTICS -Functions that return a -.B "DBM *" -handle will use -.SM NULL -to indicate an error. -Functions that return an -.B int -will use \-1 to indicate an error. The normal return value in that case is 0. -Functions that return a -.B datum -will return -.B nullitem -to indicate an error. -.LP -As a special case of -.BR sdbm_store (\|), -if it is called with the -.B \s-1DBM_INSERT\s0 -flag and the key already exists in the database, the return value will be 1. -.LP -In general, if a function parameter is invalid, -.B errno -will be set to -.BR \s-1EINVAL\s0 . -If a write operation is requested on a read-only database, -.B errno -will be set to -.BR \s-1ENOPERM\s0 . -If a memory allocation (using -.IR malloc (3)) -failed, -.B errno -will be set to -.BR \s-1ENOMEM\s0 . -For I/O operation failures -.B errno -will contain the value set by the relevant failed system call, either -.IR read (2), -.IR write (2), -or -.IR lseek (2). -.SH AUTHOR -.IP "Ozan S. Yigit" (oz@nexus.yorku.ca) -.SH BUGS -The sum of key and value data sizes must not exceed -.B \s-1PAIRMAX\s0 -(1008 bytes). -.LP -The sum of the key and value data sizes where several keys hash to the -same value must fit within one bitmap page. -.LP -The -.B \.pag -file will contain holes, so its apparent size is larger than its contents. -When copied through the filesystem the holes will be filled. -.LP -The contents of -.B datum -values returned are in volatile storage. If you want to retain the values -pointed to, you must copy them immediately before another call to this package. -.LP -The only safe way for multiple processes to (read and) update a database at -the same time, is to implement a private locking scheme outside this package -and open and close the database between lock acquisitions. It is safe for -multiple processes to concurrently access a database read-only. -.SH APPLICATIONS PORTABILITY -For complete source code compatibility with the Berkeley Unix -.IR ndbm (3) -library, the -.B sdbm.h -header file should be installed in -.BR /usr/include/ndbm.h . -.LP -The -.B nullitem -data item, and the -.BR sdbm_prep (\|), -.BR sdbm_hash (\|), -.BR sdbm_rdonly (\|), -.BR sdbm_dirfno (\|), -and -.BR sdbm_pagfno (\|) -functions are unique to this package. diff --git a/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c b/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c deleted file mode 100644 index d41c770..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c +++ /dev/null @@ -1,539 +0,0 @@ -/* - * sdbm - ndbm work-alike hashed database library - * based on Per-Aake Larson's Dynamic Hashing algorithms. BIT 18 (1978). - * author: oz@nexus.yorku.ca - * status: public domain. - * - * core routines - */ - -#include "INTERN.h" -#include "config.h" -#ifdef WIN32 -#include "io.h" -#endif -#include "sdbm.h" -#include "tune.h" -#include "pair.h" - -#ifdef I_FCNTL -# include <fcntl.h> -#endif -#ifdef I_SYS_FILE -# include <sys/file.h> -#endif - -#ifdef I_STRING -# include <string.h> -#else -# include <strings.h> -#endif - -/* - * externals - */ -#ifndef WIN32 -#ifndef sun -extern int errno; -#endif - -extern Malloc_t malloc proto((MEM_SIZE)); -extern Free_t free proto((Malloc_t)); - -#endif - -/* - * forward - */ -static int getdbit proto((DBM *, long)); -static int setdbit proto((DBM *, long)); -static int getpage proto((DBM *, long)); -static datum getnext proto((DBM *)); -static int makroom proto((DBM *, long, int)); - -/* - * useful macros - */ -#define bad(x) ((x).dptr == NULL || (x).dsize < 0) -#define exhash(item) sdbm_hash((item).dptr, (item).dsize) -#define ioerr(db) ((db)->flags |= DBM_IOERR) - -#define OFF_PAG(off) (long) (off) * PBLKSIZ -#define OFF_DIR(off) (long) (off) * DBLKSIZ - -static long masks[] = { - 000000000000, 000000000001, 000000000003, 000000000007, - 000000000017, 000000000037, 000000000077, 000000000177, - 000000000377, 000000000777, 000000001777, 000000003777, - 000000007777, 000000017777, 000000037777, 000000077777, - 000000177777, 000000377777, 000000777777, 000001777777, - 000003777777, 000007777777, 000017777777, 000037777777, - 000077777777, 000177777777, 000377777777, 000777777777, - 001777777777, 003777777777, 007777777777, 017777777777 -}; - -DBM * -sdbm_open(register char *file, register int flags, register int mode) -{ - register DBM *db; - register char *dirname; - register char *pagname; - register int n; - - if (file == NULL || !*file) - return errno = EINVAL, (DBM *) NULL; -/* - * need space for two seperate filenames - */ - n = strlen(file) * 2 + strlen(DIRFEXT) + strlen(PAGFEXT) + 2; - - if ((dirname = (char *) malloc((unsigned) n)) == NULL) - return errno = ENOMEM, (DBM *) NULL; -/* - * build the file names - */ - dirname = strcat(strcpy(dirname, file), DIRFEXT); - pagname = strcpy(dirname + strlen(dirname) + 1, file); - pagname = strcat(pagname, PAGFEXT); - - db = sdbm_prep(dirname, pagname, flags, mode); - free((char *) dirname); - return db; -} - -DBM * -sdbm_prep(char *dirname, char *pagname, int flags, int mode) -{ - register DBM *db; - struct stat dstat; - - if ((db = (DBM *) malloc(sizeof(DBM))) == NULL) - return errno = ENOMEM, (DBM *) NULL; - - db->flags = 0; - db->hmask = 0; - db->blkptr = 0; - db->keyptr = 0; -/* - * adjust user flags so that WRONLY becomes RDWR, - * as required by this package. Also set our internal - * flag for RDONLY if needed. - */ - if (flags & O_WRONLY) - flags = (flags & ~O_WRONLY) | O_RDWR; - - else if ((flags & 03) == O_RDONLY) - db->flags = DBM_RDONLY; -/* - * open the files in sequence, and stat the dirfile. - * If we fail anywhere, undo everything, return NULL. - */ -#if defined(OS2) || defined(MSDOS) || defined(WIN32) || defined(__CYGWIN__) - flags |= O_BINARY; -# endif - if ((db->pagf = open(pagname, flags, mode)) > -1) { - if ((db->dirf = open(dirname, flags, mode)) > -1) { -/* - * need the dirfile size to establish max bit number. - */ - if (fstat(db->dirf, &dstat) == 0) { -/* - * zero size: either a fresh database, or one with a single, - * unsplit data page: dirpage is all zeros. - */ - db->dirbno = (!dstat.st_size) ? 0 : -1; - db->pagbno = -1; - db->maxbno = dstat.st_size * BYTESIZ; - - (void) memset(db->pagbuf, 0, PBLKSIZ); - (void) memset(db->dirbuf, 0, DBLKSIZ); - /* - * success - */ - return db; - } - (void) close(db->dirf); - } - (void) close(db->pagf); - } - free((char *) db); - return (DBM *) NULL; -} - -void -sdbm_close(register DBM *db) -{ - if (db == NULL) - errno = EINVAL; - else { - (void) close(db->dirf); - (void) close(db->pagf); - free((char *) db); - } -} - -datum -sdbm_fetch(register DBM *db, datum key) -{ - if (db == NULL || bad(key)) - return errno = EINVAL, nullitem; - - if (getpage(db, exhash(key))) - return getpair(db->pagbuf, key); - - return ioerr(db), nullitem; -} - -int -sdbm_exists(register DBM *db, datum key) -{ - if (db == NULL || bad(key)) - return errno = EINVAL, -1; - - if (getpage(db, exhash(key))) - return exipair(db->pagbuf, key); - - return ioerr(db), -1; -} - -int -sdbm_delete(register DBM *db, datum key) -{ - if (db == NULL || bad(key)) - return errno = EINVAL, -1; - if (sdbm_rdonly(db)) - return errno = EPERM, -1; - - if (getpage(db, exhash(key))) { - if (!delpair(db->pagbuf, key)) - return -1; -/* - * update the page file - */ - if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 - || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) - return ioerr(db), -1; - - return 0; - } - - return ioerr(db), -1; -} - -int -sdbm_store(register DBM *db, datum key, datum val, int flags) -{ - int need; - register long hash; - - if (db == NULL || bad(key)) - return errno = EINVAL, -1; - if (sdbm_rdonly(db)) - return errno = EPERM, -1; - - need = key.dsize + val.dsize; -/* - * is the pair too big (or too small) for this database ?? - */ - if (need < 0 || need > PAIRMAX) - return errno = EINVAL, -1; - - if (getpage(db, (hash = exhash(key)))) { -/* - * if we need to replace, delete the key/data pair - * first. If it is not there, ignore. - */ - if (flags == DBM_REPLACE) - (void) delpair(db->pagbuf, key); -#ifdef SEEDUPS - else if (duppair(db->pagbuf, key)) - return 1; -#endif -/* - * if we do not have enough room, we have to split. - */ - if (!fitpair(db->pagbuf, need)) - if (!makroom(db, hash, need)) - return ioerr(db), -1; -/* - * we have enough room or split is successful. insert the key, - * and update the page file. - */ - (void) putpair(db->pagbuf, key, val); - - if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 - || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) - return ioerr(db), -1; - /* - * success - */ - return 0; - } - - return ioerr(db), -1; -} - -/* - * makroom - make room by splitting the overfull page - * this routine will attempt to make room for SPLTMAX times before - * giving up. - */ -static int -makroom(register DBM *db, long int hash, int need) -{ - long newp; - char twin[PBLKSIZ]; -#if defined(DOSISH) || defined(WIN32) - char zer[PBLKSIZ]; - long oldtail; -#endif - char *pag = db->pagbuf; - char *New = twin; - register int smax = SPLTMAX; - - do { -/* - * split the current page - */ - (void) splpage(pag, New, db->hmask + 1); -/* - * address of the new page - */ - newp = (hash & db->hmask) | (db->hmask + 1); - -/* - * write delay, read avoidence/cache shuffle: - * select the page for incoming pair: if key is to go to the new page, - * write out the previous one, and copy the new one over, thus making - * it the current page. If not, simply write the new page, and we are - * still looking at the page of interest. current page is not updated - * here, as sdbm_store will do so, after it inserts the incoming pair. - */ - -#if defined(DOSISH) || defined(WIN32) - /* - * Fill hole with 0 if made it. - * (hole is NOT read as 0) - */ - oldtail = lseek(db->pagf, 0L, SEEK_END); - memset(zer, 0, PBLKSIZ); - while (OFF_PAG(newp) > oldtail) { - if (lseek(db->pagf, 0L, SEEK_END) < 0 || - write(db->pagf, zer, PBLKSIZ) < 0) { - - return 0; - } - oldtail += PBLKSIZ; - } -#endif - if (hash & (db->hmask + 1)) { - if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 - || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) - return 0; - db->pagbno = newp; - (void) memcpy(pag, New, PBLKSIZ); - } - else if (lseek(db->pagf, OFF_PAG(newp), SEEK_SET) < 0 - || write(db->pagf, New, PBLKSIZ) < 0) - return 0; - - if (!setdbit(db, db->curbit)) - return 0; -/* - * see if we have enough room now - */ - if (fitpair(pag, need)) - return 1; -/* - * try again... update curbit and hmask as getpage would have - * done. because of our update of the current page, we do not - * need to read in anything. BUT we have to write the current - * [deferred] page out, as the window of failure is too great. - */ - db->curbit = 2 * db->curbit + - ((hash & (db->hmask + 1)) ? 2 : 1); - db->hmask |= db->hmask + 1; - - if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 - || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) - return 0; - - } while (--smax); -/* - * if we are here, this is real bad news. After SPLTMAX splits, - * we still cannot fit the key. say goodnight. - */ -#ifdef BADMESS - (void) write(2, "sdbm: cannot insert after SPLTMAX attempts.\n", 44); -#endif - return 0; - -} - -/* - * the following two routines will break if - * deletions aren't taken into account. (ndbm bug) - */ -datum -sdbm_firstkey(register DBM *db) -{ - if (db == NULL) - return errno = EINVAL, nullitem; -/* - * start at page 0 - */ - if (lseek(db->pagf, OFF_PAG(0), SEEK_SET) < 0 - || read(db->pagf, db->pagbuf, PBLKSIZ) < 0) - return ioerr(db), nullitem; - db->pagbno = 0; - db->blkptr = 0; - db->keyptr = 0; - - return getnext(db); -} - -datum -sdbm_nextkey(register DBM *db) -{ - if (db == NULL) - return errno = EINVAL, nullitem; - return getnext(db); -} - -/* - * all important binary trie traversal - */ -static int -getpage(register DBM *db, register long int hash) -{ - register int hbit; - register long dbit; - register long pagb; - - dbit = 0; - hbit = 0; - while (dbit < db->maxbno && getdbit(db, dbit)) - dbit = 2 * dbit + ((hash & (1 << hbit++)) ? 2 : 1); - - debug(("dbit: %d...", dbit)); - - db->curbit = dbit; - db->hmask = masks[hbit]; - - pagb = hash & db->hmask; -/* - * see if the block we need is already in memory. - * note: this lookaside cache has about 10% hit rate. - */ - if (pagb != db->pagbno) { -/* - * note: here, we assume a "hole" is read as 0s. - * if not, must zero pagbuf first. - */ - if (lseek(db->pagf, OFF_PAG(pagb), SEEK_SET) < 0 - || read(db->pagf, db->pagbuf, PBLKSIZ) < 0) - return 0; - if (!chkpage(db->pagbuf)) - return 0; - db->pagbno = pagb; - - debug(("pag read: %d\n", pagb)); - } - return 1; -} - -static int -getdbit(register DBM *db, register long int dbit) -{ - register long c; - register long dirb; - - c = dbit / BYTESIZ; - dirb = c / DBLKSIZ; - - if (dirb != db->dirbno) { - int got; - if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 - || (got=read(db->dirf, db->dirbuf, DBLKSIZ)) < 0) - return 0; - if (got==0) - memset(db->dirbuf,0,DBLKSIZ); - db->dirbno = dirb; - - debug(("dir read: %d\n", dirb)); - } - - return db->dirbuf[c % DBLKSIZ] & (1 << dbit % BYTESIZ); -} - -static int -setdbit(register DBM *db, register long int dbit) -{ - register long c; - register long dirb; - - c = dbit / BYTESIZ; - dirb = c / DBLKSIZ; - - if (dirb != db->dirbno) { - int got; - if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 - || (got=read(db->dirf, db->dirbuf, DBLKSIZ)) < 0) - return 0; - if (got==0) - memset(db->dirbuf,0,DBLKSIZ); - db->dirbno = dirb; - - debug(("dir read: %d\n", dirb)); - } - - db->dirbuf[c % DBLKSIZ] |= (1 << dbit % BYTESIZ); - -#if 0 - if (dbit >= db->maxbno) - db->maxbno += DBLKSIZ * BYTESIZ; -#else - if (OFF_DIR((dirb+1))*BYTESIZ > db->maxbno) - db->maxbno=OFF_DIR((dirb+1))*BYTESIZ; -#endif - - if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 - || write(db->dirf, db->dirbuf, DBLKSIZ) < 0) - return 0; - - return 1; -} - -/* - * getnext - get the next key in the page, and if done with - * the page, try the next page in sequence - */ -static datum -getnext(register DBM *db) -{ - datum key; - - for (;;) { - db->keyptr++; - key = getnkey(db->pagbuf, db->keyptr); - if (key.dptr != NULL) - return key; -/* - * we either run out, or there is nothing on this page.. - * try the next one... If we lost our position on the - * file, we will have to seek. - */ - db->keyptr = 0; - if (db->pagbno != db->blkptr++) - if (lseek(db->pagf, OFF_PAG(db->blkptr), SEEK_SET) < 0) - break; - db->pagbno = db->blkptr; - if (read(db->pagf, db->pagbuf, PBLKSIZ) <= 0) - break; - if (!chkpage(db->pagbuf)) - break; - } - - return ioerr(db), nullitem; -} - diff --git a/contrib/perl5/ext/SDBM_File/sdbm/sdbm.h b/contrib/perl5/ext/SDBM_File/sdbm/sdbm.h deleted file mode 100644 index 86ba82d..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/sdbm.h +++ /dev/null @@ -1,285 +0,0 @@ -/* - * sdbm - ndbm work-alike hashed database library - * based on Per-Ake Larson's Dynamic Hashing algorithms. BIT 18 (1978). - * author: oz@nexus.yorku.ca - * status: public domain. - */ -#define DBLKSIZ 4096 -#define PBLKSIZ 1024 -#define PAIRMAX 1008 /* arbitrary on PBLKSIZ-N */ -#define SPLTMAX 10 /* maximum allowed splits */ - /* for a single insertion */ -#ifdef VMS -#define DIRFEXT ".sdbm_dir" -#else -#define DIRFEXT ".dir" -#endif -#define PAGFEXT ".pag" - -typedef struct { - int dirf; /* directory file descriptor */ - int pagf; /* page file descriptor */ - int flags; /* status/error flags, see below */ - long maxbno; /* size of dirfile in bits */ - long curbit; /* current bit number */ - long hmask; /* current hash mask */ - long blkptr; /* current block for nextkey */ - int keyptr; /* current key for nextkey */ - long blkno; /* current page to read/write */ - long pagbno; /* current page in pagbuf */ - char pagbuf[PBLKSIZ]; /* page file block buffer */ - long dirbno; /* current block in dirbuf */ - char dirbuf[DBLKSIZ]; /* directory file block buffer */ -} DBM; - -#define DBM_RDONLY 0x1 /* data base open read-only */ -#define DBM_IOERR 0x2 /* data base I/O error */ - -/* - * utility macros - */ -#define sdbm_rdonly(db) ((db)->flags & DBM_RDONLY) -#define sdbm_error(db) ((db)->flags & DBM_IOERR) - -#define sdbm_clearerr(db) ((db)->flags &= ~DBM_IOERR) /* ouch */ - -#define sdbm_dirfno(db) ((db)->dirf) -#define sdbm_pagfno(db) ((db)->pagf) - -typedef struct { - char *dptr; - int dsize; -} datum; - -EXTCONST datum nullitem -#ifdef DOINIT - = {0, 0} -#endif - ; - -#if defined(__STDC__) || defined(__cplusplus) || defined(CAN_PROTOTYPE) -#define proto(p) p -#else -#define proto(p) () -#endif - -/* - * flags to sdbm_store - */ -#define DBM_INSERT 0 -#define DBM_REPLACE 1 - -/* - * ndbm interface - */ -extern DBM *sdbm_open proto((char *, int, int)); -extern void sdbm_close proto((DBM *)); -extern datum sdbm_fetch proto((DBM *, datum)); -extern int sdbm_delete proto((DBM *, datum)); -extern int sdbm_store proto((DBM *, datum, datum, int)); -extern datum sdbm_firstkey proto((DBM *)); -extern datum sdbm_nextkey proto((DBM *)); -extern int sdbm_exists proto((DBM *, datum)); - -/* - * other - */ -extern DBM *sdbm_prep proto((char *, char *, int, int)); -extern long sdbm_hash proto((char *, int)); - -#ifndef SDBM_ONLY -#define dbm_open sdbm_open -#define dbm_close sdbm_close -#define dbm_fetch sdbm_fetch -#define dbm_store sdbm_store -#define dbm_delete sdbm_delete -#define dbm_firstkey sdbm_firstkey -#define dbm_nextkey sdbm_nextkey -#define dbm_error sdbm_error -#define dbm_clearerr sdbm_clearerr -#endif - -/* Most of the following is stolen from perl.h. We don't include - perl.h here because we just want the portability parts of perl.h, - not everything else. -*/ -#ifndef H_PERL /* Include guard */ -#include "embed.h" /* Follow all the global renamings. */ - -/* - * The following contortions are brought to you on behalf of all the - * standards, semi-standards, de facto standards, not-so-de-facto standards - * of the world, as well as all the other botches anyone ever thought of. - * The basic theory is that if we work hard enough here, the rest of the - * code can be a lot prettier. Well, so much for theory. Sorry, Henry... - */ - -#include <errno.h> -#ifdef HAS_SOCKET -# ifdef I_NET_ERRNO -# include <net/errno.h> -# endif -#endif - -#if defined(__STDC__) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus) -# define STANDARD_C 1 -#endif - -#include <stdio.h> -#include <ctype.h> -#include <setjmp.h> - -#if defined(I_UNISTD) -#include <unistd.h> -#endif - -#ifdef VMS -# include <file.h> -# include <unixio.h> -#endif - -#ifdef I_SYS_PARAM -# if !defined(MSDOS) && !defined(WIN32) && !defined(VMS) -# ifdef PARAM_NEEDS_TYPES -# include <sys/types.h> -# endif -# include <sys/param.h> -# endif -#endif - -#ifndef _TYPES_ /* If types.h defines this it's easy. */ -# ifndef major /* Does everyone's types.h define this? */ -# include <sys/types.h> -# endif -#endif - -#include <sys/stat.h> - -#ifndef SEEK_SET -# ifdef L_SET -# define SEEK_SET L_SET -# else -# define SEEK_SET 0 /* Wild guess. */ -# endif -#endif - -/* Use all the "standard" definitions? */ -#if defined(STANDARD_C) && defined(I_STDLIB) -# include <stdlib.h> -#endif /* STANDARD_C */ - -#define MEM_SIZE Size_t - -/* This comes after <stdlib.h> so we don't try to change the standard - * library prototypes; we'll use our own instead. */ - -#if defined(MYMALLOC) && !defined(PERL_POLLUTE_MALLOC) -# define malloc Perl_malloc -# define calloc Perl_calloc -# define realloc Perl_realloc -# define free Perl_mfree - -Malloc_t Perl_malloc proto((MEM_SIZE nbytes)); -Malloc_t Perl_calloc proto((MEM_SIZE elements, MEM_SIZE size)); -Malloc_t Perl_realloc proto((Malloc_t where, MEM_SIZE nbytes)); -Free_t Perl_mfree proto((Malloc_t where)); -#endif /* MYMALLOC */ - -#ifdef I_STRING -#include <string.h> -#else -#include <strings.h> -#endif - -#ifdef I_MEMORY -#include <memory.h> -#endif - -#ifdef __cplusplus -#define HAS_MEMCPY -#endif - -#ifdef HAS_MEMCPY -# if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) -# ifndef memcpy - extern char * memcpy proto((char*, char*, int)); -# endif -# endif -#else -# ifndef memcpy -# ifdef HAS_BCOPY -# define memcpy(d,s,l) bcopy(s,d,l) -# else -# define memcpy(d,s,l) my_bcopy(s,d,l) -# endif -# endif -#endif /* HAS_MEMCPY */ - -#ifdef HAS_MEMSET -# if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) -# ifndef memset - extern char *memset proto((char*, int, int)); -# endif -# endif -# define memzero(d,l) memset(d,0,l) -#else -# ifndef memzero -# ifdef HAS_BZERO -# define memzero(d,l) bzero(d,l) -# else -# define memzero(d,l) my_bzero(d,l) -# endif -# endif -#endif /* HAS_MEMSET */ - -#if defined(mips) && defined(ultrix) && !defined(__STDC__) -# undef HAS_MEMCMP -#endif - -#if defined(HAS_MEMCMP) && defined(HAS_SANE_MEMCMP) -# if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) -# ifndef memcmp - extern int memcmp proto((char*, char*, int)); -# endif -# endif -# ifdef BUGGY_MSC - # pragma function(memcmp) -# endif -#else -# ifndef memcmp - /* maybe we should have included the full embedding header... */ -# ifdef NO_EMBED -# define memcmp my_memcmp -# else -# define memcmp Perl_my_memcmp -# endif -#ifndef __cplusplus - extern int memcmp proto((char*, char*, int)); -#endif -# endif -#endif /* HAS_MEMCMP */ - -#ifndef HAS_BCMP -# ifndef bcmp -# define bcmp(s1,s2,l) memcmp(s1,s2,l) -# endif -#endif /* !HAS_BCMP */ - -#ifdef HAS_MEMCMP -# define memNE(s1,s2,l) (memcmp(s1,s2,l)) -# define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) -#else -# define memNE(s1,s2,l) (bcmp(s1,s2,l)) -# define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) -#endif - -#ifdef I_NETINET_IN -# ifdef VMS -# include <in.h> -# else -# include <netinet/in.h> -# endif -#endif - -#endif /* Include guard */ - diff --git a/contrib/perl5/ext/SDBM_File/sdbm/tune.h b/contrib/perl5/ext/SDBM_File/sdbm/tune.h deleted file mode 100644 index b95c8c8..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/tune.h +++ /dev/null @@ -1,23 +0,0 @@ -/* - * sdbm - ndbm work-alike hashed database library - * tuning and portability constructs [not nearly enough] - * author: oz@nexus.yorku.ca - */ - -#define BYTESIZ 8 - -/* - * important tuning parms (hah) - */ - -#define SEEDUPS /* always detect duplicates */ -#define BADMESS /* generate a message for worst case: - cannot make room after SPLTMAX splits */ -/* - * misc - */ -#ifdef DEBUG -#define debug(x) printf x -#else -#define debug(x) -#endif diff --git a/contrib/perl5/ext/SDBM_File/sdbm/util.c b/contrib/perl5/ext/SDBM_File/sdbm/util.c deleted file mode 100644 index 16bd4ac..0000000 --- a/contrib/perl5/ext/SDBM_File/sdbm/util.c +++ /dev/null @@ -1,47 +0,0 @@ -#include <stdio.h> -#ifdef SDBM -#include "sdbm.h" -#else -#include "ndbm.h" -#endif - -void -oops(register char *s1, register char *s2) -{ - extern int errno, sys_nerr; - extern char *sys_errlist[]; - extern char *progname; - - if (progname) - fprintf(stderr, "%s: ", progname); - fprintf(stderr, s1, s2); - if (errno > 0 && errno < sys_nerr) - fprintf(stderr, " (%s)", sys_errlist[errno]); - fprintf(stderr, "\n"); - exit(1); -} - -int -okpage(char *pag) -{ - register unsigned n; - register off; - register short *ino = (short *) pag; - - if ((n = ino[0]) > PBLKSIZ / sizeof(short)) - return 0; - - if (!n) - return 1; - - off = PBLKSIZ; - for (ino++; n; ino += 2) { - if (ino[0] > off || ino[1] > off || - ino[1] > ino[0]) - return 0; - off = ino[1]; - n -= 2; - } - - return 1; -} diff --git a/contrib/perl5/ext/SDBM_File/typemap b/contrib/perl5/ext/SDBM_File/typemap deleted file mode 100644 index 40b95f2..0000000 --- a/contrib/perl5/ext/SDBM_File/typemap +++ /dev/null @@ -1,43 +0,0 @@ -# -#################################### DBM SECTION -# - -datum_key T_DATUM_K -datum_value T_DATUM_V -gdatum T_GDATUM -NDBM_File T_PTROBJ -GDBM_File T_PTROBJ -SDBM_File T_PTROBJ -ODBM_File T_PTROBJ -DB_File T_PTROBJ -DBZ_File T_PTROBJ -FATALFUNC T_OPAQUEPTR - -INPUT -T_DATUM_K - ckFilter($arg, filter_store_key, \"filter_store_key\"); - $var.dptr = SvPV($arg, PL_na); - $var.dsize = (int)PL_na; -T_DATUM_V - ckFilter($arg, filter_store_value, \"filter_store_value\"); - if (SvOK($arg)) { - $var.dptr = SvPV($arg, PL_na); - $var.dsize = (int)PL_na; - } - else { - $var.dptr = \"\"; - $var.dsize = 0; - } -T_GDATUM - UNIMPLEMENTED -OUTPUT -T_DATUM_K - sv_setpvn($arg, $var.dptr, $var.dsize); - ckFilter($arg, filter_fetch_key,\"filter_fetch_key\"); -T_DATUM_V - sv_setpvn($arg, $var.dptr, $var.dsize); - ckFilter($arg, filter_fetch_value,\"filter_fetch_value\"); -T_GDATUM - sv_usepvn($arg, $var.dptr, $var.dsize); -T_PTROBJ - sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/contrib/perl5/ext/Socket/Makefile.PL b/contrib/perl5/ext/Socket/Makefile.PL deleted file mode 100644 index 339c45a..0000000 --- a/contrib/perl5/ext/Socket/Makefile.PL +++ /dev/null @@ -1,9 +0,0 @@ -use ExtUtils::MakeMaker; -use Config; -WriteMakefile( - NAME => 'Socket', - VERSION_FROM => 'Socket.pm', - ($Config{libs} =~ /(-lsocks\S*)/ ? (LIBS => [ "$1" ] ) : ()), - MAN3PODS => {}, # Pods will be built by installman. - XSPROTOARG => '-noprototypes', # XXX remove later? -); diff --git a/contrib/perl5/ext/Socket/Socket.pm b/contrib/perl5/ext/Socket/Socket.pm deleted file mode 100644 index d89b2f6..0000000 --- a/contrib/perl5/ext/Socket/Socket.pm +++ /dev/null @@ -1,453 +0,0 @@ -package Socket; - -our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); -$VERSION = "1.72"; - -=head1 NAME - -Socket, sockaddr_in, sockaddr_un, inet_aton, inet_ntoa - load the C socket.h defines and structure manipulators - -=head1 SYNOPSIS - - use Socket; - - $proto = getprotobyname('udp'); - socket(Socket_Handle, PF_INET, SOCK_DGRAM, $proto); - $iaddr = gethostbyname('hishost.com'); - $port = getservbyname('time', 'udp'); - $sin = sockaddr_in($port, $iaddr); - send(Socket_Handle, 0, 0, $sin); - - $proto = getprotobyname('tcp'); - socket(Socket_Handle, PF_INET, SOCK_STREAM, $proto); - $port = getservbyname('smtp', 'tcp'); - $sin = sockaddr_in($port,inet_aton("127.1")); - $sin = sockaddr_in(7,inet_aton("localhost")); - $sin = sockaddr_in(7,INADDR_LOOPBACK); - connect(Socket_Handle,$sin); - - ($port, $iaddr) = sockaddr_in(getpeername(Socket_Handle)); - $peer_host = gethostbyaddr($iaddr, AF_INET); - $peer_addr = inet_ntoa($iaddr); - - $proto = getprotobyname('tcp'); - socket(Socket_Handle, PF_UNIX, SOCK_STREAM, $proto); - unlink('/tmp/usock'); - $sun = sockaddr_un('/tmp/usock'); - connect(Socket_Handle,$sun); - -=head1 DESCRIPTION - -This module is just a translation of the C F<socket.h> file. -Unlike the old mechanism of requiring a translated F<socket.ph> -file, this uses the B<h2xs> program (see the Perl source distribution) -and your native C compiler. This means that it has a -far more likely chance of getting the numbers right. This includes -all of the commonly used pound-defines like AF_INET, SOCK_STREAM, etc. - -Also, some common socket "newline" constants are provided: the -constants C<CR>, C<LF>, and C<CRLF>, as well as C<$CR>, C<$LF>, and -C<$CRLF>, which map to C<\015>, C<\012>, and C<\015\012>. If you do -not want to use the literal characters in your programs, then use -the constants provided here. They are not exported by default, but can -be imported individually, and with the C<:crlf> export tag: - - use Socket qw(:DEFAULT :crlf); - -In addition, some structure manipulation functions are available: - -=over - -=item inet_aton HOSTNAME - -Takes a string giving the name of a host, and translates that -to the 4-byte string (structure). Takes arguments of both -the 'rtfm.mit.edu' type and '18.181.0.24'. If the host name -cannot be resolved, returns undef. For multi-homed hosts (hosts -with more than one address), the first address found is returned. - -=item inet_ntoa IP_ADDRESS - -Takes a four byte ip address (as returned by inet_aton()) -and translates it into a string of the form 'd.d.d.d' -where the 'd's are numbers less than 256 (the normal -readable four dotted number notation for internet addresses). - -=item INADDR_ANY - -Note: does not return a number, but a packed string. - -Returns the 4-byte wildcard ip address which specifies any -of the hosts ip addresses. (A particular machine can have -more than one ip address, each address corresponding to -a particular network interface. This wildcard address -allows you to bind to all of them simultaneously.) -Normally equivalent to inet_aton('0.0.0.0'). - -=item INADDR_BROADCAST - -Note: does not return a number, but a packed string. - -Returns the 4-byte 'this-lan' ip broadcast address. -This can be useful for some protocols to solicit information -from all servers on the same LAN cable. -Normally equivalent to inet_aton('255.255.255.255'). - -=item INADDR_LOOPBACK - -Note - does not return a number. - -Returns the 4-byte loopback address. Normally equivalent -to inet_aton('localhost'). - -=item INADDR_NONE - -Note - does not return a number. - -Returns the 4-byte 'invalid' ip address. Normally equivalent -to inet_aton('255.255.255.255'). - -=item sockaddr_in PORT, ADDRESS - -=item sockaddr_in SOCKADDR_IN - -In a list context, unpacks its SOCKADDR_IN argument and returns an array -consisting of (PORT, ADDRESS). In a scalar context, packs its (PORT, -ADDRESS) arguments as a SOCKADDR_IN and returns it. If this is confusing, -use pack_sockaddr_in() and unpack_sockaddr_in() explicitly. - -=item pack_sockaddr_in PORT, IP_ADDRESS - -Takes two arguments, a port number and a 4 byte IP_ADDRESS (as returned by -inet_aton()). Returns the sockaddr_in structure with those arguments -packed in with AF_INET filled in. For internet domain sockets, this -structure is normally what you need for the arguments in bind(), -connect(), and send(), and is also returned by getpeername(), -getsockname() and recv(). - -=item unpack_sockaddr_in SOCKADDR_IN - -Takes a sockaddr_in structure (as returned by pack_sockaddr_in()) and -returns an array of two elements: the port and the 4-byte ip-address. -Will croak if the structure does not have AF_INET in the right place. - -=item sockaddr_un PATHNAME - -=item sockaddr_un SOCKADDR_UN - -In a list context, unpacks its SOCKADDR_UN argument and returns an array -consisting of (PATHNAME). In a scalar context, packs its PATHNAME -arguments as a SOCKADDR_UN and returns it. If this is confusing, use -pack_sockaddr_un() and unpack_sockaddr_un() explicitly. -These are only supported if your system has E<lt>F<sys/un.h>E<gt>. - -=item pack_sockaddr_un PATH - -Takes one argument, a pathname. Returns the sockaddr_un structure with -that path packed in with AF_UNIX filled in. For unix domain sockets, this -structure is normally what you need for the arguments in bind(), -connect(), and send(), and is also returned by getpeername(), -getsockname() and recv(). - -=item unpack_sockaddr_un SOCKADDR_UN - -Takes a sockaddr_un structure (as returned by pack_sockaddr_un()) -and returns the pathname. Will croak if the structure does not -have AF_UNIX in the right place. - -=back - -=cut - -use Carp; -use warnings::register; - -require Exporter; -use XSLoader (); -@ISA = qw(Exporter); -@EXPORT = qw( - inet_aton inet_ntoa pack_sockaddr_in unpack_sockaddr_in - pack_sockaddr_un unpack_sockaddr_un - sockaddr_in sockaddr_un - INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE - AF_802 - AF_APPLETALK - AF_CCITT - AF_CHAOS - AF_DATAKIT - AF_DECnet - AF_DLI - AF_ECMA - AF_GOSIP - AF_HYLINK - AF_IMPLINK - AF_INET - AF_LAT - AF_MAX - AF_NBS - AF_NIT - AF_NS - AF_OSI - AF_OSINET - AF_PUP - AF_SNA - AF_UNIX - AF_UNSPEC - AF_X25 - IOV_MAX - MSG_BCAST - MSG_CTLFLAGS - MSG_CTLIGNORE - MSG_CTRUNC - MSG_DONTROUTE - MSG_DONTWAIT - MSG_EOF - MSG_EOR - MSG_ERRQUEUE - MSG_FIN - MSG_MAXIOVLEN - MSG_MCAST - MSG_NOSIGNAL - MSG_OOB - MSG_PEEK - MSG_PROXY - MSG_RST - MSG_SYN - MSG_TRUNC - MSG_URG - MSG_WAITALL - PF_802 - PF_APPLETALK - PF_CCITT - PF_CHAOS - PF_DATAKIT - PF_DECnet - PF_DLI - PF_ECMA - PF_GOSIP - PF_HYLINK - PF_IMPLINK - PF_INET - PF_LAT - PF_MAX - PF_NBS - PF_NIT - PF_NS - PF_OSI - PF_OSINET - PF_PUP - PF_SNA - PF_UNIX - PF_UNSPEC - PF_X25 - SCM_CONNECT - SCM_CREDENTIALS - SCM_CREDS - SCM_RIGHTS - SCM_TIMESTAMP - SHUT_RD - SHUT_RDWR - SHUT_WR - SOCK_DGRAM - SOCK_RAW - SOCK_RDM - SOCK_SEQPACKET - SOCK_STREAM - SOL_SOCKET - SOMAXCONN - SO_ACCEPTCONN - SO_BROADCAST - SO_DEBUG - SO_DONTLINGER - SO_DONTROUTE - SO_ERROR - SO_KEEPALIVE - SO_LINGER - SO_OOBINLINE - SO_RCVBUF - SO_RCVLOWAT - SO_RCVTIMEO - SO_REUSEADDR - SO_REUSEPORT - SO_SNDBUF - SO_SNDLOWAT - SO_SNDTIMEO - SO_TYPE - SO_USELOOPBACK - UIO_MAXIOV -); - -@EXPORT_OK = qw(CR LF CRLF $CR $LF $CRLF - - IPPROTO_TCP - TCP_KEEPALIVE - TCP_MAXRT - TCP_MAXSEG - TCP_NODELAY - TCP_STDURG); - -%EXPORT_TAGS = ( - crlf => [qw(CR LF CRLF $CR $LF $CRLF)], - all => [@EXPORT, @EXPORT_OK], -); - -BEGIN { - sub CR () {"\015"} - sub LF () {"\012"} - sub CRLF () {"\015\012"} -} - -*CR = \CR(); -*LF = \LF(); -*CRLF = \CRLF(); - -sub sockaddr_in { - if (@_ == 6 && !wantarray) { # perl5.001m compat; use this && die - my($af, $port, @quad) = @_; - 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; - unpack_sockaddr_in(@_); - } else { - croak "usage: sin_sv = sockaddr_in(port,iaddr))" unless @_ == 2; - pack_sockaddr_in(@_); - } -} - -sub sockaddr_un { - if (wantarray) { - croak "usage: (filename) = sockaddr_un(sun_sv)" unless @_ == 1; - unpack_sockaddr_un(@_); - } else { - croak "usage: sun_sv = sockaddr_un(filename)" unless @_ == 1; - pack_sockaddr_un(@_); - } -} - -sub INADDR_ANY (); -sub INADDR_BROADCAST (); -sub INADDR_LOOPBACK (); -sub INADDR_LOOPBACK (); - -sub AF_802 (); -sub AF_APPLETALK (); -sub AF_CCITT (); -sub AF_CHAOS (); -sub AF_DATAKIT (); -sub AF_DECnet (); -sub AF_DLI (); -sub AF_ECMA (); -sub AF_GOSIP (); -sub AF_HYLINK (); -sub AF_IMPLINK (); -sub AF_INET (); -sub AF_LAT (); -sub AF_MAX (); -sub AF_NBS (); -sub AF_NIT (); -sub AF_NS (); -sub AF_OSI (); -sub AF_OSINET (); -sub AF_PUP (); -sub AF_SNA (); -sub AF_UNIX (); -sub AF_UNSPEC (); -sub AF_X25 (); -sub IOV_MAX (); -sub MSG_BCAST (); -sub MSG_CTLFLAGS (); -sub MSG_CTLIGNORE (); -sub MSG_CTRUNC (); -sub MSG_DONTROUTE (); -sub MSG_DONTWAIT (); -sub MSG_EOF (); -sub MSG_EOR (); -sub MSG_ERRQUEUE (); -sub MSG_FIN (); -sub MSG_MAXIOVLEN (); -sub MSG_MCAST (); -sub MSG_NOSIGNAL (); -sub MSG_OOB (); -sub MSG_PEEK (); -sub MSG_PROXY (); -sub MSG_RST (); -sub MSG_SYN (); -sub MSG_TRUNC (); -sub MSG_URG (); -sub MSG_WAITALL (); -sub PF_802 (); -sub PF_APPLETALK (); -sub PF_CCITT (); -sub PF_CHAOS (); -sub PF_DATAKIT (); -sub PF_DECnet (); -sub PF_DLI (); -sub PF_ECMA (); -sub PF_GOSIP (); -sub PF_HYLINK (); -sub PF_IMPLINK (); -sub PF_INET (); -sub PF_LAT (); -sub PF_MAX (); -sub PF_NBS (); -sub PF_NIT (); -sub PF_NS (); -sub PF_OSI (); -sub PF_OSINET (); -sub PF_PUP (); -sub PF_SNA (); -sub PF_UNIX (); -sub PF_UNSPEC (); -sub PF_X25 (); -sub SCM_CONNECT (); -sub SCM_CREDENTIALS (); -sub SCM_CREDS (); -sub SCM_RIGHTS (); -sub SCM_TIMESTAMP (); -sub SHUT_RD (); -sub SHUT_RDWR (); -sub SHUT_WR (); -sub SOCK_DGRAM (); -sub SOCK_RAW (); -sub SOCK_RDM (); -sub SOCK_SEQPACKET (); -sub SOCK_STREAM (); -sub SOL_SOCKET (); -sub SOMAXCONN (); -sub SO_ACCEPTCONN (); -sub SO_BROADCAST (); -sub SO_DEBUG (); -sub SO_DONTLINGER (); -sub SO_DONTROUTE (); -sub SO_ERROR (); -sub SO_KEEPALIVE (); -sub SO_LINGER (); -sub SO_OOBINLINE (); -sub SO_RCVBUF (); -sub SO_RCVLOWAT (); -sub SO_RCVTIMEO (); -sub SO_REUSEADDR (); -sub SO_SNDBUF (); -sub SO_SNDLOWAT (); -sub SO_SNDTIMEO (); -sub SO_TYPE (); -sub SO_USELOOPBACK (); -sub UIO_MAXIOV (); - -sub AUTOLOAD { - my($constname); - ($constname = $AUTOLOAD) =~ s/.*:://; - my $val = constant($constname, @_ ? $_[0] : 0); - if ($! != 0) { - my ($pack,$file,$line) = caller; - croak "Your vendor has not defined Socket macro $constname, used"; - } - eval "sub $AUTOLOAD () { $val }"; - goto &$AUTOLOAD; -} - -XSLoader::load 'Socket', $VERSION; - -1; diff --git a/contrib/perl5/ext/Socket/Socket.xs b/contrib/perl5/ext/Socket/Socket.xs deleted file mode 100644 index e089829..0000000 --- a/contrib/perl5/ext/Socket/Socket.xs +++ /dev/null @@ -1,1116 +0,0 @@ -#define PERL_NO_GET_CONTEXT -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#ifndef VMS -# ifdef I_SYS_TYPES -# include <sys/types.h> -# endif -# include <sys/socket.h> -# if defined(USE_SOCKS) && defined(I_SOCKS) -# include <socks.h> -# endif -# ifdef MPE -# define PF_INET AF_INET -# define PF_UNIX AF_UNIX -# define SOCK_RAW 3 -# endif -# 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 -# ifdef I_NETDB -# include <netdb.h> -# endif -# ifdef I_ARPA_INET -# include <arpa/inet.h> -# endif -# ifdef I_NETINET_TCP -# include <netinet/tcp.h> -# endif -#else -# include "sockadapt.h" -#endif - -#ifdef I_SYSUIO -# include <sys/uio.h> -#endif - -#ifndef AF_NBS -# undef PF_NBS -#endif - -#ifndef AF_X25 -# undef PF_X25 -#endif - -#ifndef INADDR_NONE -# define INADDR_NONE 0xffffffff -#endif /* INADDR_NONE */ -#ifndef INADDR_BROADCAST -# define INADDR_BROADCAST 0xffffffff -#endif /* INADDR_BROADCAST */ -#ifndef INADDR_LOOPBACK -# define INADDR_LOOPBACK 0x7F000001 -#endif /* INADDR_LOOPBACK */ - -#ifndef HAS_INET_ATON - -/* - * Check whether "cp" is a valid ascii representation - * of an Internet address and convert to a binary address. - * Returns 1 if the address is valid, 0 if not. - * This replaces inet_addr, the return value from which - * cannot distinguish between failure and a local broadcast address. - */ -static int -my_inet_aton(register const char *cp, struct in_addr *addr) -{ - dTHX; - register U32 val; - register int base; - register char c; - int nparts; - const char *s; - unsigned int parts[4]; - register unsigned int *pp = parts; - - if (!cp) - return 0; - for (;;) { - /* - * Collect number up to ``.''. - * Values are specified as for C: - * 0x=hex, 0=octal, other=decimal. - */ - val = 0; base = 10; - if (*cp == '0') { - if (*++cp == 'x' || *cp == 'X') - base = 16, cp++; - else - base = 8; - } - while ((c = *cp) != '\0') { - if (isDIGIT(c)) { - val = (val * base) + (c - '0'); - cp++; - continue; - } - if (base == 16 && (s=strchr(PL_hexdigit,c))) { - val = (val << 4) + - ((s - PL_hexdigit) & 15); - cp++; - continue; - } - break; - } - if (*cp == '.') { - /* - * Internet format: - * a.b.c.d - * a.b.c (with c treated as 16-bits) - * a.b (with b treated as 24 bits) - */ - if (pp >= parts + 3 || val > 0xff) - return 0; - *pp++ = val, cp++; - } else - break; - } - /* - * Check for trailing characters. - */ - if (*cp && !isSPACE(*cp)) - return 0; - /* - * Concoct the address according to - * the number of parts specified. - */ - nparts = pp - parts + 1; /* force to an int for switch() */ - switch (nparts) { - - case 1: /* a -- 32 bits */ - break; - - case 2: /* a.b -- 8.24 bits */ - if (val > 0xffffff) - return 0; - val |= parts[0] << 24; - break; - - case 3: /* a.b.c -- 8.8.16 bits */ - if (val > 0xffff) - return 0; - val |= (parts[0] << 24) | (parts[1] << 16); - break; - - case 4: /* a.b.c.d -- 8.8.8.8 bits */ - if (val > 0xff) - return 0; - val |= (parts[0] << 24) | (parts[1] << 16) | (parts[2] << 8); - break; - } - addr->s_addr = htonl(val); - return 1; -} - -#undef inet_aton -#define inet_aton my_inet_aton - -#endif /* ! HAS_INET_ATON */ - - -static int -not_here(char *s) -{ - croak("Socket::%s not implemented on this architecture", s); - return -1; -} - -static double -constant(char *name, int arg) -{ - errno = 0; - switch (*name) { - case 'A': - if (strEQ(name, "AF_802")) -#ifdef AF_802 - return AF_802; -#else - goto not_there; -#endif - if (strEQ(name, "AF_APPLETALK")) -#ifdef AF_APPLETALK - return AF_APPLETALK; -#else - goto not_there; -#endif - if (strEQ(name, "AF_CCITT")) -#ifdef AF_CCITT - return AF_CCITT; -#else - goto not_there; -#endif - if (strEQ(name, "AF_CHAOS")) -#ifdef AF_CHAOS - return AF_CHAOS; -#else - goto not_there; -#endif - if (strEQ(name, "AF_DATAKIT")) -#ifdef AF_DATAKIT - return AF_DATAKIT; -#else - goto not_there; -#endif - if (strEQ(name, "AF_DECnet")) -#ifdef AF_DECnet - return AF_DECnet; -#else - goto not_there; -#endif - if (strEQ(name, "AF_DLI")) -#ifdef AF_DLI - return AF_DLI; -#else - goto not_there; -#endif - if (strEQ(name, "AF_ECMA")) -#ifdef AF_ECMA - return AF_ECMA; -#else - goto not_there; -#endif - if (strEQ(name, "AF_GOSIP")) -#ifdef AF_GOSIP - return AF_GOSIP; -#else - goto not_there; -#endif - if (strEQ(name, "AF_HYLINK")) -#ifdef AF_HYLINK - return AF_HYLINK; -#else - goto not_there; -#endif - if (strEQ(name, "AF_IMPLINK")) -#ifdef AF_IMPLINK - return AF_IMPLINK; -#else - goto not_there; -#endif - if (strEQ(name, "AF_INET")) -#ifdef AF_INET - return AF_INET; -#else - goto not_there; -#endif - if (strEQ(name, "AF_LAT")) -#ifdef AF_LAT - return AF_LAT; -#else - goto not_there; -#endif - if (strEQ(name, "AF_MAX")) -#ifdef AF_MAX - return AF_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "AF_NBS")) -#ifdef AF_NBS - return AF_NBS; -#else - goto not_there; -#endif - if (strEQ(name, "AF_NIT")) -#ifdef AF_NIT - return AF_NIT; -#else - goto not_there; -#endif - if (strEQ(name, "AF_NS")) -#ifdef AF_NS - return AF_NS; -#else - goto not_there; -#endif - if (strEQ(name, "AF_OSI")) -#ifdef AF_OSI - return AF_OSI; -#else - goto not_there; -#endif - if (strEQ(name, "AF_OSINET")) -#ifdef AF_OSINET - return AF_OSINET; -#else - goto not_there; -#endif - if (strEQ(name, "AF_PUP")) -#ifdef AF_PUP - return AF_PUP; -#else - goto not_there; -#endif - if (strEQ(name, "AF_SNA")) -#ifdef AF_SNA - return AF_SNA; -#else - goto not_there; -#endif - if (strEQ(name, "AF_UNIX")) -#ifdef AF_UNIX - return AF_UNIX; -#else - goto not_there; -#endif - if (strEQ(name, "AF_UNSPEC")) -#ifdef AF_UNSPEC - return AF_UNSPEC; -#else - goto not_there; -#endif - if (strEQ(name, "AF_X25")) -#ifdef AF_X25 - return AF_X25; -#else - goto not_there; -#endif - break; - case 'B': - break; - case 'C': - break; - case 'D': - break; - case 'E': - break; - case 'F': - break; - case 'G': - break; - case 'H': - break; - case 'I': - if (strEQ(name, "IOV_MAX")) -#ifdef IOV_MAX - return IOV_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "IPPROTO_TCP")) -#ifdef IPPROTO_TCP - return IPPROTO_TCP; -#else - goto not_there; -#endif - break; - case 'J': - break; - case 'K': - break; - case 'L': - break; - case 'M': - if (strEQ(name, "MSG_BCAST")) -#ifdef MSG_BCAST - return MSG_BCAST; -#else - goto not_there; -#endif - if (strEQ(name, "MSG_CTLFLAGS")) -#ifdef MSG_CTLFLAGS - return MSG_CTLFLAGS; -#else - goto not_there; -#endif - if (strEQ(name, "MSG_CTLIGNORE")) -#ifdef MSG_CTLIGNORE - return MSG_CTLIGNORE; -#else - goto not_there; -#endif - if (strEQ(name, "MSG_CTRUNC")) -#if defined(MSG_TRUNC) || defined(HAS_MSG_CTRUNC) /* might be an enum */ - return MSG_CTRUNC; -#else - goto not_there; -#endif - if (strEQ(name, "MSG_DONTROUTE")) -#if defined(MSG_DONTROUTE) || defined(HAS_MSG_DONTROUTE) /* might be an enum */ - return MSG_DONTROUTE; -#else - goto not_there; -#endif - if (strEQ(name, "MSG_DONTWAIT")) -#ifdef MSG_DONTWAIT - return MSG_DONTWAIT; -#else - goto not_there; -#endif - if (strEQ(name, "MSG_EOF")) -#ifdef MSG_EOF - return MSG_EOF; -#else - goto not_there; -#endif - if (strEQ(name, "MSG_EOR")) -#ifdef MSG_EOR - return MSG_EOR; -#else - goto not_there; -#endif - if (strEQ(name, "MSG_ERRQUEUE")) -#ifdef MSG_ERRQUEUE - return MSG_ERRQUEUE; -#else - goto not_there; -#endif - if (strEQ(name, "MSG_FIN")) -#ifdef MSG_FIN - return MSG_FIN; -#else - goto not_there; -#endif - if (strEQ(name, "MSG_MAXIOVLEN")) -#ifdef MSG_MAXIOVLEN - return MSG_MAXIOVLEN; -#else - goto not_there; -#endif - if (strEQ(name, "MSG_MCAST")) -#ifdef MSG_MCAST - return MSG_MCAST; -#else - goto not_there; -#endif - if (strEQ(name, "MSG_NOSIGNAL")) -#ifdef MSG_NOSIGNAL - return MSG_NOSIGNAL; -#else - goto not_there; -#endif - if (strEQ(name, "MSG_OOB")) -#if defined(MSG_OOB) || defined(HAS_MSG_OOB) /* might be an enum */ - return MSG_OOB; -#else - goto not_there; -#endif - if (strEQ(name, "MSG_PEEK")) -#if defined(MSG_PEEK) || defined(HAS_MSG_PEEK) /* might be an enum */ - return MSG_PEEK; -#else - goto not_there; -#endif - if (strEQ(name, "MSG_PROXY")) -#if defined(MSG_PROXY) || defined(HAS_MSG_PROXY) /* might be an enum */ - return MSG_PROXY; -#else - goto not_there; -#endif - if (strEQ(name, "MSG_RST")) -#ifdef MSG_RST - return MSG_RST; -#else - goto not_there; -#endif - if (strEQ(name, "MSG_SYN")) -#ifdef MSG_SYN - return MSG_SYN; -#else - goto not_there; -#endif - if (strEQ(name, "MSG_TRUNC")) -#ifdef MSG_TRUNC - return MSG_TRUNC; -#else - goto not_there; -#endif - if (strEQ(name, "MSG_WAITALL")) -#ifdef MSG_WAITALL - return MSG_WAITALL; -#else - goto not_there; -#endif - break; - case 'N': - break; - case 'O': - break; - case 'P': - if (strEQ(name, "PF_802")) -#ifdef PF_802 - return PF_802; -#else - goto not_there; -#endif - if (strEQ(name, "PF_APPLETALK")) -#ifdef PF_APPLETALK - return PF_APPLETALK; -#else - goto not_there; -#endif - if (strEQ(name, "PF_CCITT")) -#ifdef PF_CCITT - return PF_CCITT; -#else - goto not_there; -#endif - if (strEQ(name, "PF_CHAOS")) -#ifdef PF_CHAOS - return PF_CHAOS; -#else - goto not_there; -#endif - if (strEQ(name, "PF_DATAKIT")) -#ifdef PF_DATAKIT - return PF_DATAKIT; -#else - goto not_there; -#endif - if (strEQ(name, "PF_DECnet")) -#ifdef PF_DECnet - return PF_DECnet; -#else - goto not_there; -#endif - if (strEQ(name, "PF_DLI")) -#ifdef PF_DLI - return PF_DLI; -#else - goto not_there; -#endif - if (strEQ(name, "PF_ECMA")) -#ifdef PF_ECMA - return PF_ECMA; -#else - goto not_there; -#endif - if (strEQ(name, "PF_GOSIP")) -#ifdef PF_GOSIP - return PF_GOSIP; -#else - goto not_there; -#endif - if (strEQ(name, "PF_HYLINK")) -#ifdef PF_HYLINK - return PF_HYLINK; -#else - goto not_there; -#endif - if (strEQ(name, "PF_IMPLINK")) -#ifdef PF_IMPLINK - return PF_IMPLINK; -#else - goto not_there; -#endif - if (strEQ(name, "PF_INET")) -#ifdef PF_INET - return PF_INET; -#else - goto not_there; -#endif - if (strEQ(name, "PF_LAT")) -#ifdef PF_LAT - return PF_LAT; -#else - goto not_there; -#endif - if (strEQ(name, "PF_MAX")) -#ifdef PF_MAX - return PF_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "PF_NBS")) -#ifdef PF_NBS - return PF_NBS; -#else - goto not_there; -#endif - if (strEQ(name, "PF_NIT")) -#ifdef PF_NIT - return PF_NIT; -#else - goto not_there; -#endif - if (strEQ(name, "PF_NS")) -#ifdef PF_NS - return PF_NS; -#else - goto not_there; -#endif - if (strEQ(name, "PF_OSI")) -#ifdef PF_OSI - return PF_OSI; -#else - goto not_there; -#endif - if (strEQ(name, "PF_OSINET")) -#ifdef PF_OSINET - return PF_OSINET; -#else - goto not_there; -#endif - if (strEQ(name, "PF_PUP")) -#ifdef PF_PUP - return PF_PUP; -#else - goto not_there; -#endif - if (strEQ(name, "PF_SNA")) -#ifdef PF_SNA - return PF_SNA; -#else - goto not_there; -#endif - if (strEQ(name, "PF_UNIX")) -#ifdef PF_UNIX - return PF_UNIX; -#else - goto not_there; -#endif - if (strEQ(name, "PF_UNSPEC")) -#ifdef PF_UNSPEC - return PF_UNSPEC; -#else - goto not_there; -#endif - if (strEQ(name, "PF_X25")) -#ifdef PF_X25 - return PF_X25; -#else - goto not_there; -#endif - break; - case 'Q': - break; - case 'R': - break; - case 'S': - if (strEQ(name, "SCM_CONNECT")) -#ifdef SCM_CONNECT - return SCM_CONNECT; -#else - goto not_there; -#endif - if (strEQ(name, "SCM_CREDENTIALS")) -#ifdef SCM_CREDENTIALS - return SCM_CREDENTIALS; -#else - goto not_there; -#endif - if (strEQ(name, "SCM_CREDS")) -#ifdef SCM_CREDS - return SCM_CREDS; -#else - goto not_there; -#endif - if (strEQ(name, "SCM_RIGHTS")) -#if defined(SCM_RIGHTS) || defined(HAS_SCM_RIGHTS) /* might be an enum */ - return SCM_RIGHTS; -#else - goto not_there; -#endif - if (strEQ(name, "SCM_TIMESTAMP")) -#ifdef SCM_TIMESTAMP - return SCM_TIMESTAMP; -#else - goto not_there; -#endif - if (strEQ(name, "SHUT_RD")) -#ifdef SHUT_RD - return SHUT_RD; -#else - return 0; -#endif - if (strEQ(name, "SHUT_RDWR")) -#ifdef SHUT_RDWR - return SHUT_RDWR; -#else - return 2; -#endif - if (strEQ(name, "SHUT_WR")) -#ifdef SHUT_WR - return SHUT_WR; -#else - return 1; -#endif - if (strEQ(name, "SOCK_DGRAM")) -#ifdef SOCK_DGRAM - return SOCK_DGRAM; -#else - goto not_there; -#endif - if (strEQ(name, "SOCK_RAW")) -#ifdef SOCK_RAW - return SOCK_RAW; -#else - goto not_there; -#endif - if (strEQ(name, "SOCK_RDM")) -#ifdef SOCK_RDM - return SOCK_RDM; -#else - goto not_there; -#endif - if (strEQ(name, "SOCK_SEQPACKET")) -#ifdef SOCK_SEQPACKET - return SOCK_SEQPACKET; -#else - goto not_there; -#endif - if (strEQ(name, "SOCK_STREAM")) -#ifdef SOCK_STREAM - return SOCK_STREAM; -#else - goto not_there; -#endif - if (strEQ(name, "SOL_SOCKET")) -#ifdef SOL_SOCKET - return SOL_SOCKET; -#else - goto not_there; -#endif - if (strEQ(name, "SOMAXCONN")) -#ifdef SOMAXCONN - return SOMAXCONN; -#else - goto not_there; -#endif - if (strEQ(name, "SO_ACCEPTCONN")) -#ifdef SO_ACCEPTCONN - return SO_ACCEPTCONN; -#else - goto not_there; -#endif - if (strEQ(name, "SO_BROADCAST")) -#ifdef SO_BROADCAST - return SO_BROADCAST; -#else - goto not_there; -#endif - if (strEQ(name, "SO_DEBUG")) -#ifdef SO_DEBUG - return SO_DEBUG; -#else - goto not_there; -#endif - if (strEQ(name, "SO_DONTLINGER")) -#ifdef SO_DONTLINGER - return SO_DONTLINGER; -#else - goto not_there; -#endif - if (strEQ(name, "SO_DONTROUTE")) -#ifdef SO_DONTROUTE - return SO_DONTROUTE; -#else - goto not_there; -#endif - if (strEQ(name, "SO_ERROR")) -#ifdef SO_ERROR - return SO_ERROR; -#else - goto not_there; -#endif - if (strEQ(name, "SO_KEEPALIVE")) -#ifdef SO_KEEPALIVE - return SO_KEEPALIVE; -#else - goto not_there; -#endif - if (strEQ(name, "SO_LINGER")) -#ifdef SO_LINGER - return SO_LINGER; -#else - goto not_there; -#endif - if (strEQ(name, "SO_OOBINLINE")) -#ifdef SO_OOBINLINE - return SO_OOBINLINE; -#else - goto not_there; -#endif - if (strEQ(name, "SO_RCVBUF")) -#ifdef SO_RCVBUF - return SO_RCVBUF; -#else - goto not_there; -#endif - if (strEQ(name, "SO_RCVLOWAT")) -#ifdef SO_RCVLOWAT - return SO_RCVLOWAT; -#else - goto not_there; -#endif - if (strEQ(name, "SO_RCVTIMEO")) -#ifdef SO_RCVTIMEO - return SO_RCVTIMEO; -#else - goto not_there; -#endif - if (strEQ(name, "SO_REUSEADDR")) -#ifdef SO_REUSEADDR - return SO_REUSEADDR; -#else - goto not_there; -#endif - if (strEQ(name, "SO_REUSEPORT")) -#ifdef SO_REUSEPORT - return SO_REUSEPORT; -#else - goto not_there; -#endif - if (strEQ(name, "SO_SNDBUF")) -#ifdef SO_SNDBUF - return SO_SNDBUF; -#else - goto not_there; -#endif - if (strEQ(name, "SO_SNDLOWAT")) -#ifdef SO_SNDLOWAT - return SO_SNDLOWAT; -#else - goto not_there; -#endif - if (strEQ(name, "SO_SNDTIMEO")) -#ifdef SO_SNDTIMEO - return SO_SNDTIMEO; -#else - goto not_there; -#endif - if (strEQ(name, "SO_TYPE")) -#ifdef SO_TYPE - return SO_TYPE; -#else - goto not_there; -#endif - if (strEQ(name, "SO_USELOOPBACK")) -#ifdef SO_USELOOPBACK - return SO_USELOOPBACK; -#else - goto not_there; -#endif - break; - case 'T': - if (strEQ(name, "TCP_KEEPALIVE")) -#ifdef TCP_KEEPALIVE - return TCP_KEEPALIVE; -#else - goto not_there; -#endif - if (strEQ(name, "TCP_MAXRT")) -#ifdef TCP_MAXRT - return TCP_MAXRT; -#else - goto not_there; -#endif - if (strEQ(name, "TCP_MAXSEG")) -#ifdef TCP_MAXSEG - return TCP_MAXSEG; -#else - goto not_there; -#endif - if (strEQ(name, "TCP_NODELAY")) -#ifdef TCP_NODELAY - return TCP_NODELAY; -#else - goto not_there; -#endif - if (strEQ(name, "TCP_STDURG")) -#ifdef TCP_STDURG - return TCP_STDURG; -#else - goto not_there; -#endif - break; - case 'U': - if (strEQ(name, "UIO_MAXIOV")) -#ifdef UIO_MAXIOV - return UIO_MAXIOV; -#else - goto not_there; -#endif - break; - case 'V': - break; - case 'W': - break; - case 'X': - break; - case 'Y': - break; - case 'Z': - break; - } - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - - -MODULE = Socket PACKAGE = Socket - -double -constant(name,arg) - char * name - int arg - - -void -inet_aton(host) - char * host - CODE: - { - struct in_addr ip_address; - struct hostent * phe; - int ok = inet_aton(host, &ip_address); - - if (!ok && (phe = gethostbyname(host))) { - Copy( phe->h_addr, &ip_address, phe->h_length, char ); - ok = 1; - } - - ST(0) = sv_newmortal(); - if (ok) { - sv_setpvn( ST(0), (char *)&ip_address, sizeof ip_address ); - } - } - -void -inet_ntoa(ip_address_sv) - SV * ip_address_sv - CODE: - { - STRLEN addrlen; - struct in_addr addr; - char * addr_str; - char * ip_address = SvPV(ip_address_sv,addrlen); - if (addrlen != sizeof(addr)) { - croak("Bad arg length for %s, length is %d, should be %d", - "Socket::inet_ntoa", - addrlen, sizeof(addr)); - } - - Copy( ip_address, &addr, sizeof addr, char ); - addr_str = inet_ntoa(addr); - - ST(0) = sv_2mortal(newSVpvn(addr_str, strlen(addr_str))); - } - -void -pack_sockaddr_un(pathname) - char * pathname - CODE: - { -#ifdef I_SYS_UN - struct sockaddr_un sun_ad; /* fear using sun */ - STRLEN len; - - Zero( &sun_ad, sizeof sun_ad, char ); - sun_ad.sun_family = AF_UNIX; - len = strlen(pathname); - if (len > sizeof(sun_ad.sun_path)) - len = sizeof(sun_ad.sun_path); -# ifdef OS2 /* Name should start with \socket\ and contain backslashes! */ - { - int off; - char *s, *e; - - if (pathname[0] != '/' && pathname[0] != '\\') - croak("Relative UNIX domain socket name '%s' unsupported", pathname); - else if (len < 8 - || pathname[7] != '/' && pathname[7] != '\\' - || !strnicmp(pathname + 1, "socket", 6)) - off = 7; - else - off = 0; /* Preserve names starting with \socket\ */ - Copy( "\\socket", sun_ad.sun_path, off, char); - Copy( pathname, sun_ad.sun_path + off, len, char ); - - s = sun_ad.sun_path + off - 1; - e = s + len + 1; - while (++s < e) - if (*s = '/') - *s = '\\'; - } -# else /* !( defined OS2 ) */ - Copy( pathname, sun_ad.sun_path, len, char ); -# endif - ST(0) = sv_2mortal(newSVpvn((char *)&sun_ad, sizeof sun_ad)); -#else - ST(0) = (SV *) not_here("pack_sockaddr_un"); -#endif - - } - -void -unpack_sockaddr_un(sun_sv) - SV * sun_sv - CODE: - { -#ifdef I_SYS_UN - struct sockaddr_un addr; - STRLEN sockaddrlen; - char * sun_ad = SvPV(sun_sv,sockaddrlen); - char * e; -# ifndef __linux__ - /* On Linux sockaddrlen on sockets returned by accept, recvfrom, - getpeername and getsockname is not equal to sizeof(addr). */ - if (sockaddrlen != sizeof(addr)) { - croak("Bad arg length for %s, length is %d, should be %d", - "Socket::unpack_sockaddr_un", - sockaddrlen, sizeof(addr)); - } -# endif - - Copy( sun_ad, &addr, sizeof addr, char ); - - if ( addr.sun_family != AF_UNIX ) { - croak("Bad address family for %s, got %d, should be %d", - "Socket::unpack_sockaddr_un", - addr.sun_family, - AF_UNIX); - } - e = addr.sun_path; - while (*e && e < addr.sun_path + sizeof addr.sun_path) - ++e; - ST(0) = sv_2mortal(newSVpvn(addr.sun_path, e - addr.sun_path)); -#else - ST(0) = (SV *) not_here("unpack_sockaddr_un"); -#endif - } - -void -pack_sockaddr_in(port,ip_address) - unsigned short port - char * ip_address - CODE: - { - struct sockaddr_in sin; - - Zero( &sin, sizeof sin, char ); - sin.sin_family = AF_INET; - sin.sin_port = htons(port); - Copy( ip_address, &sin.sin_addr, sizeof sin.sin_addr, char ); - - ST(0) = sv_2mortal(newSVpvn((char *)&sin, sizeof sin)); - } - -void -unpack_sockaddr_in(sin_sv) - SV * sin_sv - PPCODE: - { - STRLEN sockaddrlen; - struct sockaddr_in addr; - unsigned short port; - struct in_addr ip_address; - char * sin = SvPV(sin_sv,sockaddrlen); - if (sockaddrlen != sizeof(addr)) { - croak("Bad arg length for %s, length is %d, should be %d", - "Socket::unpack_sockaddr_in", - sockaddrlen, sizeof(addr)); - } - Copy( sin, &addr,sizeof addr, char ); - if ( addr.sin_family != AF_INET ) { - croak("Bad address family for %s, got %d, should be %d", - "Socket::unpack_sockaddr_in", - addr.sin_family, - AF_INET); - } - port = ntohs(addr.sin_port); - ip_address = addr.sin_addr; - - EXTEND(SP, 2); - PUSHs(sv_2mortal(newSViv((IV) port))); - PUSHs(sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address))); - } - -void -INADDR_ANY() - CODE: - { - struct in_addr ip_address; - ip_address.s_addr = htonl(INADDR_ANY); - ST(0) = sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address )); - } - -void -INADDR_LOOPBACK() - CODE: - { - struct in_addr ip_address; - ip_address.s_addr = htonl(INADDR_LOOPBACK); - ST(0) = sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address)); - } - -void -INADDR_NONE() - CODE: - { - struct in_addr ip_address; - ip_address.s_addr = htonl(INADDR_NONE); - ST(0) = sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address)); - } - -void -INADDR_BROADCAST() - CODE: - { - struct in_addr ip_address; - ip_address.s_addr = htonl(INADDR_BROADCAST); - ST(0) = sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address)); - } diff --git a/contrib/perl5/ext/Sys/Hostname/Hostname.pm b/contrib/perl5/ext/Sys/Hostname/Hostname.pm deleted file mode 100644 index 1efc897..0000000 --- a/contrib/perl5/ext/Sys/Hostname/Hostname.pm +++ /dev/null @@ -1,153 +0,0 @@ -package Sys::Hostname; - -use strict; - -use Carp; - -require Exporter; -use XSLoader (); -require AutoLoader; - -our @ISA = qw/ Exporter AutoLoader /; -our @EXPORT = qw/ hostname /; - -our $VERSION = '1.1'; - -our $host; - -XSLoader::load 'Sys::Hostname', $VERSION; - -sub hostname { - - # method 1 - we already know it - return $host if defined $host; - - # method 1' - try to ask the system - $host = ghname(); - return $host if defined $host; - - if ($^O eq 'VMS') { - - # method 2 - no sockets ==> return DECnet node name - eval { local $SIG{__DIE__}; $host = (gethostbyname('me'))[0] }; - if ($@) { return $host = $ENV{'SYS$NODE'}; } - - # method 3 - has someone else done the job already? It's common for the - # TCP/IP stack to advertise the hostname via a logical name. (Are - # there any other logicals which TCP/IP stacks use for the host name?) - $host = $ENV{'ARPANET_HOST_NAME'} || $ENV{'INTERNET_HOST_NAME'} || - $ENV{'MULTINET_HOST_NAME'} || $ENV{'UCX$INET_HOST'} || - $ENV{'TCPWARE_DOMAINNAME'} || $ENV{'NEWS_ADDRESS'}; - return $host if $host; - - # method 4 - does hostname happen to work? - my($rslt) = `hostname`; - if ($rslt !~ /IVVERB/) { ($host) = $rslt =~ /^(\S+)/; } - return $host if $host; - - # rats! - $host = ''; - Carp::croak "Cannot get host name of local machine"; - - } - elsif ($^O eq 'MSWin32') { - ($host) = gethostbyname('localhost'); - chomp($host = `hostname 2> NUL`) unless defined $host; - return $host; - } - elsif ($^O eq 'epoc') { - $host = 'localhost'; - return $host; - } - else { # Unix - # is anyone going to make it here? - - # method 2 - syscall is preferred since it avoids tainting problems - # XXX: is it such a good idea to return hostname untainted? - eval { - local $SIG{__DIE__}; - require "syscall.ph"; - $host = "\0" x 65; ## preload scalar - syscall(&SYS_gethostname, $host, 65) == 0; - } - - # method 2a - syscall using systeminfo instead of gethostname - # -- needed on systems like Solaris - || eval { - local $SIG{__DIE__}; - require "sys/syscall.ph"; - require "sys/systeminfo.ph"; - $host = "\0" x 65; ## preload scalar - syscall(&SYS_systeminfo, &SI_HOSTNAME, $host, 65) != -1; - } - - # method 3 - trusty old hostname command - || eval { - local $SIG{__DIE__}; - local $SIG{CHLD}; - $host = `(hostname) 2>/dev/null`; # bsdish - } - - # method 4 - use POSIX::uname(), which strictly can't be expected to be - # correct - || eval { - local $SIG{__DIE__}; - require POSIX; - $host = (POSIX::uname())[1]; - } - - # method 5 - sysV uname command (may truncate) - || eval { - local $SIG{__DIE__}; - $host = `uname -n 2>/dev/null`; ## sysVish - } - - # method 6 - Apollo pre-SR10 - || eval { - local $SIG{__DIE__}; - my($a,$b,$c,$d); - ($host,$a,$b,$c,$d)=split(/[:\. ]/,`/com/host`,6); - } - - # bummer - || Carp::croak "Cannot get host name of local machine"; - - # remove garbage - $host =~ tr/\0\r\n//d; - $host; - } -} - -1; - -__END__ - -=head1 NAME - -Sys::Hostname - Try every conceivable way to get hostname - -=head1 SYNOPSIS - - use Sys::Hostname; - $host = hostname; - -=head1 DESCRIPTION - -Attempts several methods of getting the system hostname and -then caches the result. It tries the first available of the C -library's gethostname(), C<`$Config{aphostname}`>, uname(2), -C<syscall(SYS_gethostname)>, C<`hostname`>, C<`uname -n`>, -and the file F</com/host>. If all that fails it C<croak>s. - -All NULs, returns, and newlines are removed from the result. - -=head1 AUTHOR - -David Sundstrom E<lt>F<sunds@asictest.sc.ti.com>E<gt> - -Texas Instruments - -XS code added by Greg Bacon E<lt>F<gbacon@cs.uah.edu>E<gt> - -=cut - diff --git a/contrib/perl5/ext/Sys/Hostname/Hostname.xs b/contrib/perl5/ext/Sys/Hostname/Hostname.xs deleted file mode 100644 index f104383..0000000 --- a/contrib/perl5/ext/Sys/Hostname/Hostname.xs +++ /dev/null @@ -1,76 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#if defined(I_UNISTD) && defined(HAS_GETHOSTNAME) -# include <unistd.h> -#endif - -/* a reasonable default */ -#ifndef MAXHOSTNAMELEN -# define MAXHOSTNAMELEN 256 -#endif - -/* swiped from POSIX.xs */ -#if defined(__VMS) && !defined(__POSIX_SOURCE) -# if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) -# include <utsname.h> -# endif -#endif - -#ifdef I_SYSUTSNAME -# include <sys/utsname.h> -#endif - -MODULE = Sys::Hostname PACKAGE = Sys::Hostname - -void -ghname() - PREINIT: - IV retval = -1; - SV *sv; - PPCODE: - EXTEND(SP, 1); -#ifdef HAS_GETHOSTNAME - { - char tmps[MAXHOSTNAMELEN]; - retval = PerlSock_gethostname(tmps, sizeof(tmps)); - sv = newSVpvn(tmps, strlen(tmps)); - } -#else -# ifdef HAS_PHOSTNAME - { - PerlIO *io; - char tmps[MAXHOSTNAMELEN]; - char *p = tmps; - char c; - io = PerlProc_popen(PHOSTNAME, "r"); - if (!io) - goto check_out; - while (PerlIO_read(io, &c, sizeof(c)) == 1) { - if (isSPACE(c) || p - tmps >= sizeof(tmps)) - break; - *p++ = c; - } - PerlProc_pclose(io); - *p = '\0'; - retval = 0; - sv = newSVpvn(tmps, strlen(tmps)); - } -# else -# ifdef HAS_UNAME - { - struct utsname u; - if (PerlEnv_uname(&u) == -1) - goto check_out; - sv = newSVpvn(u.nodename, strlen(u.nodename)); - retval = 0; - } -# endif -# endif -#endif - check_out: - if (retval == -1) - XSRETURN_UNDEF; - else - PUSHs(sv_2mortal(sv)); diff --git a/contrib/perl5/ext/Sys/Hostname/Makefile.PL b/contrib/perl5/ext/Sys/Hostname/Makefile.PL deleted file mode 100644 index a0892f6..0000000 --- a/contrib/perl5/ext/Sys/Hostname/Makefile.PL +++ /dev/null @@ -1,8 +0,0 @@ -use ExtUtils::MakeMaker; - -WriteMakefile( - NAME => 'Sys::Hostname', - VERSION_FROM => 'Hostname.pm', - MAN3PODS => {}, # Pods will be built by installman. - XSPROTOARG => '-noprototypes', -); diff --git a/contrib/perl5/ext/Sys/Syslog/Makefile.PL b/contrib/perl5/ext/Sys/Syslog/Makefile.PL deleted file mode 100644 index e5edf3e..0000000 --- a/contrib/perl5/ext/Sys/Syslog/Makefile.PL +++ /dev/null @@ -1,8 +0,0 @@ -use ExtUtils::MakeMaker; - -WriteMakefile( - NAME => 'Sys::Syslog', - VERSION_FROM => 'Syslog.pm', - MAN3PODS => {}, # Pods will be built by installman. - XSPROTOARG => '-noprototypes', -); diff --git a/contrib/perl5/ext/Sys/Syslog/Syslog.pm b/contrib/perl5/ext/Sys/Syslog/Syslog.pm deleted file mode 100644 index 92b82a1..0000000 --- a/contrib/perl5/ext/Sys/Syslog/Syslog.pm +++ /dev/null @@ -1,302 +0,0 @@ -package Sys::Syslog; -require 5.000; -require Exporter; -require DynaLoader; -use Carp; - -@ISA = qw(Exporter DynaLoader); -@EXPORT = qw(openlog closelog setlogmask syslog); -@EXPORT_OK = qw(setlogsock); -$VERSION = '0.01'; - -use Socket; -use Sys::Hostname; - -# adapted from syslog.pl -# -# Tom Christiansen <tchrist@convex.com> -# modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov> -# NOTE: openlog now takes three arguments, just like openlog(3) -# Modified to add UNIX domain sockets by Sean Robinson <robinson_s@sc.maricopa.edu> -# with support from Tim Bunce <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list -# Modified to use an XS backend instead of syslog.ph by Tom Hughes <tom@compton.nu> - -# Todo: enable connect to try all three types before failing (auto setlogsock)? - -=head1 NAME - -Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX syslog(3) calls - -=head1 SYNOPSIS - - use Sys::Syslog; # all except setlogsock, or: - use Sys::Syslog qw(:DEFAULT setlogsock); # default set, plus setlogsock - - setlogsock $sock_type; - openlog $ident, $logopt, $facility; - syslog $priority, $format, @args; - $oldmask = setlogmask $mask_priority; - closelog; - -=head1 DESCRIPTION - -Sys::Syslog is an interface to the UNIX C<syslog(3)> program. -Call C<syslog()> with a string priority and a list of C<printf()> args -just like C<syslog(3)>. - -Syslog provides the functions: - -=over - -=item openlog $ident, $logopt, $facility - -I<$ident> is prepended to every message. -I<$logopt> contains zero or more of the words I<pid>, I<ndelay>, I<cons>, I<nowait>. -I<$facility> specifies the part of the system - -=item syslog $priority, $format, @args - -If I<$priority> permits, logs I<($format, @args)> -printed as by C<printf(3V)>, with the addition that I<%m> -is replaced with C<"$!"> (the latest error message). - -=item setlogmask $mask_priority - -Sets log mask I<$mask_priority> and returns the old mask. - -=item setlogsock $sock_type (added in 5.004_02) - -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 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. - -=item closelog - -Closes the log file. - -=back - -Note that C<openlog> now takes three arguments, just like C<openlog(3)>. - -=head1 EXAMPLES - - openlog($program, 'cons,pid', 'user'); - syslog('info', 'this is another test'); - syslog('mail|warning', 'this is a better test: %d', time); - closelog(); - - syslog('debug', 'this is the last test'); - - setlogsock('unix'); - openlog("$program $$", 'ndelay', 'user'); - syslog('notice', 'fooprogram: this is really done'); - - setlogsock('inet'); - $! = 55; - syslog('info', 'problem was %m'); # %m == $! in syslog(3) - -=head1 SEE ALSO - -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 -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 - -sub AUTOLOAD { - # This AUTOLOAD is used to 'autoload' constants from the constant() - # XS function. - - my $constname; - our $AUTOLOAD; - ($constname = $AUTOLOAD) =~ s/.*:://; - croak "& not defined" if $constname eq 'constant'; - my $val = constant($constname); - if ($! != 0) { - croak "Your vendor has not defined Sys::Syslog macro $constname"; - } - *$AUTOLOAD = sub { $val }; - goto &$AUTOLOAD; -} - -bootstrap Sys::Syslog $VERSION; - -$maskpri = &LOG_UPTO(&LOG_DEBUG); - -sub openlog { - ($ident, $logopt, $facility) = @_; # package vars - $lo_pid = $logopt =~ /\bpid\b/; - $lo_ndelay = $logopt =~ /\bndelay\b/; - $lo_cons = $logopt =~ /\bcons\b/; - $lo_nowait = $logopt =~ /\bnowait\b/; - return 1 unless $lo_ndelay; - &connect; -} - -sub closelog { - $facility = $ident = ''; - &disconnect; -} - -sub setlogmask { - local($oldmask) = $maskpri; - $maskpri = shift; - $oldmask; -} - -sub setlogsock { - local($setsock) = shift; - &disconnect if $connected; - if (lc($setsock) eq 'unix') { - if (length _PATH_LOG()) { - $sock_type = 1; - } else { - return undef; - } - } elsif (lc($setsock) eq 'inet') { - if (getservbyname('syslog','udp')) { - undef($sock_type); - } else { - return undef; - } - } else { - croak "Invalid argument passed to setlogsock; must be 'unix' or 'inet'"; - } - return 1; -} - -sub syslog { - local($priority) = shift; - local($mask) = shift; - local($message, $whoami); - local(@words, $num, $numpri, $numfac, $sum); - local($facility) = $facility; # may need to change temporarily. - - croak "syslog: expected both priority and mask" unless $mask && $priority; - - @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility". - undef $numpri; - undef $numfac; - foreach (@words) { - $num = &xlate($_); # Translate word to number. - if (/^kern$/ || $num < 0) { - croak "syslog: invalid level/facility: $_"; - } - elsif ($num <= &LOG_PRIMASK) { - croak "syslog: too many levels given: $_" if defined($numpri); - $numpri = $num; - return 0 unless &LOG_MASK($numpri) & $maskpri; - } - else { - croak "syslog: too many facilities given: $_" if defined($numfac); - $facility = $_; - $numfac = $num; - } - } - - croak "syslog: level must be given" unless defined($numpri); - - if (!defined($numfac)) { # Facility not specified in this call. - $facility = 'user' unless $facility; - $numfac = &xlate($facility); - } - - &connect unless $connected; - - $whoami = $ident; - - if (!$whoami && $mask =~ /^(\S.*?):\s?(.*)/) { - $whoami = $1; - $mask = $2; - } - - unless ($whoami) { - ($whoami = getlogin) || - ($whoami = getpwuid($<)) || - ($whoami = 'syslog'); - } - - $whoami .= "[$$]" if $lo_pid; - - $mask =~ s/%m/$!/g; - $mask .= "\n" unless $mask =~ /\n$/; - $message = sprintf ($mask, @_); - - $sum = $numpri + $numfac; - unless (send(SYSLOG,"<$sum>$whoami: $message\0",0)) { - if ($lo_cons) { - if ($pid = fork) { - unless ($lo_nowait) { - $died = waitpid($pid, 0); - } - } - else { - if (open(CONS,">/dev/console")) { - print CONS "<$facility.$priority>$whoami: $message\r"; - close CONS; - } - exit if defined $pid; # if fork failed, we're parent - } - } - } -} - -sub xlate { - local($name) = @_; - $name = uc $name; - $name = "LOG_$name" unless $name =~ /^LOG_/; - $name = "Sys::Syslog::$name"; - eval { &$name } || -1; -} - -sub connect { - unless ($host) { - require Sys::Hostname; - my($host_uniq) = Sys::Hostname::hostname(); - ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _) - } - unless ( $sock_type ) { - my $udp = getprotobyname('udp') || croak "getprotobyname failed for udp"; - my $syslog = getservbyname('syslog','udp') || croak "getservbyname failed"; - my $this = sockaddr_in($syslog, INADDR_ANY); - my $that = sockaddr_in($syslog, inet_aton($host) || croak "Can't lookup $host"); - socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp) || croak "socket: $!"; - connect(SYSLOG,$that) || croak "connect: $!"; - } else { - 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)) { - socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0) || croak "socket: $!"; - connect(SYSLOG,$that) || croak "connect: $! (SOCK_DGRAM after trying SOCK_STREAM)"; - } - } - local($old) = select(SYSLOG); $| = 1; select($old); - $connected = 1; -} - -sub disconnect { - close SYSLOG; - $connected = 0; -} - -1; diff --git a/contrib/perl5/ext/Sys/Syslog/Syslog.xs b/contrib/perl5/ext/Sys/Syslog/Syslog.xs deleted file mode 100644 index 31c0e84..0000000 --- a/contrib/perl5/ext/Sys/Syslog/Syslog.xs +++ /dev/null @@ -1,641 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#ifdef I_SYSLOG -#include <syslog.h> -#endif - -static double -constant_LOG_NO(char *name, int len) -{ - switch (name[6 + 0]) { - case 'T': - if (strEQ(name + 6, "TICE")) { /* LOG_NO removed */ -#ifdef LOG_NOTICE - return LOG_NOTICE; -#else - goto not_there; -#endif - } - case 'W': - if (strEQ(name + 6, "WAIT")) { /* LOG_NO removed */ -#ifdef LOG_NOWAIT - return LOG_NOWAIT; -#else - goto not_there; -#endif - } - } - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - -static double -constant_LOG_N(char *name, int len) -{ - switch (name[5 + 0]) { - case 'D': - if (strEQ(name + 5, "DELAY")) { /* LOG_N removed */ -#ifdef LOG_NDELAY - return LOG_NDELAY; -#else - goto not_there; -#endif - } - case 'E': - if (strEQ(name + 5, "EWS")) { /* LOG_N removed */ -#ifdef LOG_NEWS - return LOG_NEWS; -#else - goto not_there; -#endif - } - case 'F': - if (strEQ(name + 5, "FACILITIES")) { /* LOG_N removed */ -#ifdef LOG_NFACILITIES - return LOG_NFACILITIES; -#else - goto not_there; -#endif - } - case 'O': - return constant_LOG_NO(name, len); - } - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - -static double -constant_LOG_P(char *name, int len) -{ - switch (name[5 + 0]) { - case 'I': - if (strEQ(name + 5, "ID")) { /* LOG_P removed */ -#ifdef LOG_PID - return LOG_PID; -#else - goto not_there; -#endif - } - case 'R': - if (strEQ(name + 5, "RIMASK")) { /* LOG_P removed */ -#ifdef LOG_PRIMASK - return LOG_PRIMASK; -#else - goto not_there; -#endif - } - } - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - -static double -constant_LOG_AU(char *name, int len) -{ - if (6 + 2 >= len ) { - errno = EINVAL; - return 0; - } - switch (name[6 + 2]) { - case '\0': - if (strEQ(name + 6, "TH")) { /* LOG_AU removed */ -#ifdef LOG_AUTH - return LOG_AUTH; -#else - goto not_there; -#endif - } - case 'P': - if (strEQ(name + 6, "THPRIV")) { /* LOG_AU removed */ -#ifdef LOG_AUTHPRIV - return LOG_AUTHPRIV; -#else - goto not_there; -#endif - } - } - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - -static double -constant_LOG_A(char *name, int len) -{ - switch (name[5 + 0]) { - case 'L': - if (strEQ(name + 5, "LERT")) { /* LOG_A removed */ -#ifdef LOG_ALERT - return LOG_ALERT; -#else - goto not_there; -#endif - } - case 'U': - return constant_LOG_AU(name, len); - } - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - -static double -constant_LOG_CR(char *name, int len) -{ - switch (name[6 + 0]) { - case 'I': - if (strEQ(name + 6, "IT")) { /* LOG_CR removed */ -#ifdef LOG_CRIT - return LOG_CRIT; -#else - goto not_there; -#endif - } - case 'O': - if (strEQ(name + 6, "ON")) { /* LOG_CR removed */ -#ifdef LOG_CRON - return LOG_CRON; -#else - goto not_there; -#endif - } - } - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - -static double -constant_LOG_C(char *name, int len) -{ - switch (name[5 + 0]) { - case 'O': - if (strEQ(name + 5, "ONS")) { /* LOG_C removed */ -#ifdef LOG_CONS - return LOG_CONS; -#else - goto not_there; -#endif - } - case 'R': - return constant_LOG_CR(name, len); - } - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - -static double -constant_LOG_D(char *name, int len) -{ - switch (name[5 + 0]) { - case 'A': - if (strEQ(name + 5, "AEMON")) { /* LOG_D removed */ -#ifdef LOG_DAEMON - return LOG_DAEMON; -#else - goto not_there; -#endif - } - case 'E': - if (strEQ(name + 5, "EBUG")) { /* LOG_D removed */ -#ifdef LOG_DEBUG - return LOG_DEBUG; -#else - goto not_there; -#endif - } - } - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - -static double -constant_LOG_U(char *name, int len) -{ - switch (name[5 + 0]) { - case 'S': - if (strEQ(name + 5, "SER")) { /* LOG_U removed */ -#ifdef LOG_USER - return LOG_USER; -#else - goto not_there; -#endif - } - case 'U': - if (strEQ(name + 5, "UCP")) { /* LOG_U removed */ -#ifdef LOG_UUCP - return LOG_UUCP; -#else - goto not_there; -#endif - } - } - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - -static double -constant_LOG_E(char *name, int len) -{ - switch (name[5 + 0]) { - case 'M': - if (strEQ(name + 5, "MERG")) { /* LOG_E removed */ -#ifdef LOG_EMERG - return LOG_EMERG; -#else - goto not_there; -#endif - } - case 'R': - if (strEQ(name + 5, "RR")) { /* LOG_E removed */ -#ifdef LOG_ERR - return LOG_ERR; -#else - goto not_there; -#endif - } - } - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - -static double -constant_LOG_F(char *name, int len) -{ - switch (name[5 + 0]) { - case 'A': - if (strEQ(name + 5, "ACMASK")) { /* LOG_F removed */ -#ifdef LOG_FACMASK - return LOG_FACMASK; -#else - goto not_there; -#endif - } - case 'T': - if (strEQ(name + 5, "TP")) { /* LOG_F removed */ -#ifdef LOG_FTP - return LOG_FTP; -#else - goto not_there; -#endif - } - } - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - -static double -constant_LOG_LO(char *name, int len) -{ - if (6 + 3 >= len ) { - errno = EINVAL; - return 0; - } - switch (name[6 + 3]) { - case '0': - if (strEQ(name + 6, "CAL0")) { /* LOG_LO removed */ -#ifdef LOG_LOCAL0 - return LOG_LOCAL0; -#else - goto not_there; -#endif - } - case '1': - if (strEQ(name + 6, "CAL1")) { /* LOG_LO removed */ -#ifdef LOG_LOCAL1 - return LOG_LOCAL1; -#else - goto not_there; -#endif - } - case '2': - if (strEQ(name + 6, "CAL2")) { /* LOG_LO removed */ -#ifdef LOG_LOCAL2 - return LOG_LOCAL2; -#else - goto not_there; -#endif - } - case '3': - if (strEQ(name + 6, "CAL3")) { /* LOG_LO removed */ -#ifdef LOG_LOCAL3 - return LOG_LOCAL3; -#else - goto not_there; -#endif - } - case '4': - if (strEQ(name + 6, "CAL4")) { /* LOG_LO removed */ -#ifdef LOG_LOCAL4 - return LOG_LOCAL4; -#else - goto not_there; -#endif - } - case '5': - if (strEQ(name + 6, "CAL5")) { /* LOG_LO removed */ -#ifdef LOG_LOCAL5 - return LOG_LOCAL5; -#else - goto not_there; -#endif - } - case '6': - if (strEQ(name + 6, "CAL6")) { /* LOG_LO removed */ -#ifdef LOG_LOCAL6 - return LOG_LOCAL6; -#else - goto not_there; -#endif - } - case '7': - if (strEQ(name + 6, "CAL7")) { /* LOG_LO removed */ -#ifdef LOG_LOCAL7 - return LOG_LOCAL7; -#else - goto not_there; -#endif - } - } - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - -static double -constant_LOG_L(char *name, int len) -{ - switch (name[5 + 0]) { - case 'F': - if (strEQ(name + 5, "FMT")) { /* LOG_L removed */ -#ifdef LOG_LFMT - return LOG_LFMT; -#else - goto not_there; -#endif - } - case 'O': - return constant_LOG_LO(name, len); - case 'P': - if (strEQ(name + 5, "PR")) { /* LOG_L removed */ -#ifdef LOG_LPR - return LOG_LPR; -#else - goto not_there; -#endif - } - } - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - -static double -constant(char *name, int len) -{ - errno = 0; - if (0 + 4 >= len ) { - errno = EINVAL; - return 0; - } - switch (name[0 + 4]) { - case 'A': - if (!strnEQ(name + 0,"LOG_", 4)) - break; - return constant_LOG_A(name, len); - case 'C': - if (!strnEQ(name + 0,"LOG_", 4)) - break; - return constant_LOG_C(name, len); - case 'D': - if (!strnEQ(name + 0,"LOG_", 4)) - break; - return constant_LOG_D(name, len); - case 'E': - if (!strnEQ(name + 0,"LOG_", 4)) - break; - return constant_LOG_E(name, len); - case 'F': - if (!strnEQ(name + 0,"LOG_", 4)) - break; - return constant_LOG_F(name, len); - case 'I': - if (strEQ(name + 0, "LOG_INFO")) { /* removed */ -#ifdef LOG_INFO - return LOG_INFO; -#else - goto not_there; -#endif - } - case 'K': - if (strEQ(name + 0, "LOG_KERN")) { /* removed */ -#ifdef LOG_KERN - return LOG_KERN; -#else - goto not_there; -#endif - } - case 'L': - if (!strnEQ(name + 0,"LOG_", 4)) - break; - return constant_LOG_L(name, len); - case 'M': - if (strEQ(name + 0, "LOG_MAIL")) { /* removed */ -#ifdef LOG_MAIL - return LOG_MAIL; -#else - goto not_there; -#endif - } - case 'N': - if (!strnEQ(name + 0,"LOG_", 4)) - break; - return constant_LOG_N(name, len); - case 'O': - if (strEQ(name + 0, "LOG_ODELAY")) { /* removed */ -#ifdef LOG_ODELAY - return LOG_ODELAY; -#else - goto not_there; -#endif - } - case 'P': - if (!strnEQ(name + 0,"LOG_", 4)) - break; - return constant_LOG_P(name, len); - case 'S': - if (strEQ(name + 0, "LOG_SYSLOG")) { /* removed */ -#ifdef LOG_SYSLOG - return LOG_SYSLOG; -#else - goto not_there; -#endif - } - case 'U': - if (!strnEQ(name + 0,"LOG_", 4)) - break; - return constant_LOG_U(name, len); - case 'W': - if (strEQ(name + 0, "LOG_WARNING")) { /* removed */ -#ifdef LOG_WARNING - return LOG_WARNING; -#else - goto not_there; -#endif - } - } - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - - -MODULE = Sys::Syslog PACKAGE = Sys::Syslog - -char * -_PATH_LOG() - CODE: -#ifdef _PATH_LOG - RETVAL = _PATH_LOG; -#else - RETVAL = ""; -#endif - OUTPUT: - RETVAL - -int -LOG_FAC(p) - INPUT: - int p - CODE: -#ifdef LOG_FAC - RETVAL = LOG_FAC(p); -#else - croak("Your vendor has not defined the Sys::Syslog macro LOG_FAC"); - RETVAL = -1; -#endif - OUTPUT: - RETVAL - -int -LOG_PRI(p) - INPUT: - int p - CODE: -#ifdef LOG_PRI - RETVAL = LOG_PRI(p); -#else - croak("Your vendor has not defined the Sys::Syslog macro LOG_PRI"); - RETVAL = -1; -#endif - OUTPUT: - RETVAL - -int -LOG_MAKEPRI(fac,pri) - INPUT: - int fac - int pri - CODE: -#ifdef LOG_MAKEPRI - RETVAL = LOG_MAKEPRI(fac,pri); -#else - croak("Your vendor has not defined the Sys::Syslog macro LOG_MAKEPRI"); - RETVAL = -1; -#endif - OUTPUT: - RETVAL - -int -LOG_MASK(pri) - INPUT: - int pri - CODE: -#ifdef LOG_MASK - RETVAL = LOG_MASK(pri); -#else - croak("Your vendor has not defined the Sys::Syslog macro LOG_MASK"); - RETVAL = -1; -#endif - OUTPUT: - RETVAL - -int -LOG_UPTO(pri) - INPUT: - int pri - CODE: -#ifdef LOG_UPTO - RETVAL = LOG_UPTO(pri); -#else - croak("Your vendor has not defined the Sys::Syslog macro LOG_UPTO"); - RETVAL = -1; -#endif - OUTPUT: - RETVAL - - -double -constant(sv) - PREINIT: - STRLEN len; - INPUT: - SV * sv - char * s = SvPV(sv, len); - CODE: - RETVAL = constant(s,len); - OUTPUT: - RETVAL - diff --git a/contrib/perl5/ext/Thread/Makefile.PL b/contrib/perl5/ext/Thread/Makefile.PL deleted file mode 100644 index e67fbb7..0000000 --- a/contrib/perl5/ext/Thread/Makefile.PL +++ /dev/null @@ -1,7 +0,0 @@ -use ExtUtils::MakeMaker; -WriteMakefile( - NAME => 'Thread', - VERSION_FROM => 'Thread.pm', - MAN3PODS => {} - ); - diff --git a/contrib/perl5/ext/Thread/Notes b/contrib/perl5/ext/Thread/Notes deleted file mode 100644 index 1505877..0000000 --- a/contrib/perl5/ext/Thread/Notes +++ /dev/null @@ -1,13 +0,0 @@ -Should cvcache be per CV (keyed by thread) or per thread (keyed by CV)? - -Maybe ought to protect all SVs by a mutex for SvREFCNT_{dec,inc}, -upgrades and so on. Then use SvMUTEX instead of CvMUTEX for CVs. -On the other hand, people shouldn't expect concurrent operations -on non-lexicals to be safe anyway. - -Probably don't need to bother keeping track of CvOWNER on clones. - -Either @_ needs to be made lexical or other arrangments need to be -made so that some globs (or just *_) are per-thread. - -tokenbuf and buf probably ought to be global protected by a global lock. diff --git a/contrib/perl5/ext/Thread/README b/contrib/perl5/ext/Thread/README deleted file mode 100644 index a6b22fb..0000000 --- a/contrib/perl5/ext/Thread/README +++ /dev/null @@ -1,20 +0,0 @@ -See the README.threads in the main perl 5.004_xx development -distribution (x >= 50) for details of how to build and use this. -If all else fails, read on. - -If your version of patch can't create a file from scratch, then you'll -need to create an empty thread.h manually first. Perl itself will need -to be built with -DUSE_THREADS yet. If you're using MIT pthreads or -another threads package that needs pthread_init() to be called, then -add -DNEED_PTHREAD_INIT. If you're using a threads library that only -follows one of the old POSIX drafts, then you'll probably need to add --DOLD_PTHREADS_API. I haven't tested -DOLD_PTHREADS_API properly yet -and I think you may still have to tweak a couple of the mutex calls -to follow the old API. - -This extension is copyright Malcolm Beattie 1995-1997 and is freely -distributable under your choice of the GNU Public License or the -Artistic License (see the main perl distribution). - -Malcolm Beattie -mbeattie@sable.ox.ac.uk diff --git a/contrib/perl5/ext/Thread/Thread.pm b/contrib/perl5/ext/Thread/Thread.pm deleted file mode 100644 index 23f9fe5..0000000 --- a/contrib/perl5/ext/Thread/Thread.pm +++ /dev/null @@ -1,225 +0,0 @@ -package Thread; -require Exporter; -use XSLoader (); -our($VERSION, @ISA, @EXPORT); - -$VERSION = "1.0"; - -@ISA = qw(Exporter); -@EXPORT_OK = qw(yield cond_signal cond_broadcast cond_wait async); - -=head1 NAME - -Thread - manipulate threads in Perl (EXPERIMENTAL, subject to change) - -=head1 CAVEAT - -The Thread extension requires Perl to be built in a particular way to -enable the older 5.005 threading model. Just to confuse matters, there -is an alternate threading model known as "ithreads" that does NOT -support this extension. If you are using a binary distribution such -as ActivePerl that is built with ithreads support, this extension CANNOT -be used. - -=head1 SYNOPSIS - - use Thread; - - my $t = new Thread \&start_sub, @start_args; - - $result = $t->join; - $result = $t->eval; - $t->detach; - - if($t->equal($another_thread)) { - # ... - } - - my $tid = Thread->self->tid; - my $tlist = Thread->list; - - lock($scalar); - yield(); - - use Thread 'async'; - -=head1 DESCRIPTION - - 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! - -The C<Thread> module provides multithreading support for perl. - -=head1 FUNCTIONS - -=over 8 - -=item new \&start_sub - -=item new \&start_sub, LIST - -C<new> starts a new thread of execution in the referenced subroutine. The -optional list is passed as parameters to the subroutine. Execution -continues in both the subroutine and the code after the C<new> call. - -C<new Thread> returns a thread object representing the newly created -thread. - -=item lock VARIABLE - -C<lock> places a lock on a variable until the lock goes out of scope. If -the variable is locked by another thread, the C<lock> call will block until -it's available. C<lock> is recursive, so multiple calls to C<lock> are -safe--the variable will remain locked until the outermost lock on the -variable goes out of scope. - -Locks on variables only affect C<lock> calls--they do I<not> affect normal -access to a variable. (Locks on subs are different, and covered in a bit) -If you really, I<really> want locks to block access, then go ahead and tie -them to something and manage this yourself. This is done on purpose. While -managing access to variables is a good thing, perl doesn't force you out of -its living room... - -If a container object, such as a hash or array, is locked, all the elements -of that container are not locked. For example, if a thread does a C<lock -@a>, any other thread doing a C<lock($a[12])> won't block. - -You may also C<lock> a sub, using C<lock &sub>. Any calls to that sub from -another thread will block until the lock is released. This behaviour is not -equivalent to declaring the sub with the C<locked> attribute. The C<locked> -attribute serializes access to a subroutine, but allows different threads -non-simultaneous access. C<lock &sub>, on the other hand, will not allow -I<any> other thread access for the duration of the lock. - -Finally, C<lock> will traverse up references exactly I<one> level. -C<lock(\$a)> is equivalent to C<lock($a)>, while C<lock(\\$a)> is not. - -=item async BLOCK; - -C<async> creates a thread to execute the block immediately following -it. This block is treated as an anonymous sub, and so must have a -semi-colon after the closing brace. Like C<new Thread>, C<async> returns a -thread object. - -=item Thread->self - -The C<Thread-E<gt>self> function returns a thread object that represents -the thread making the C<Thread-E<gt>self> call. - -=item Thread->list - -C<Thread-E<gt>list> returns a list of thread objects for all running and -finished but un-C<join>ed threads. - -=item cond_wait VARIABLE - -The C<cond_wait> function takes a B<locked> variable as a parameter, -unlocks the variable, and blocks until another thread does a C<cond_signal> -or C<cond_broadcast> for that same locked variable. The variable that -C<cond_wait> blocked on is relocked after the C<cond_wait> is satisfied. -If there are multiple threads C<cond_wait>ing on the same variable, all but -one will reblock waiting to reaquire the lock on the variable. (So if -you're only using C<cond_wait> for synchronization, give up the lock as -soon as possible) - -=item cond_signal VARIABLE - -The C<cond_signal> function takes a locked variable as a parameter and -unblocks one thread that's C<cond_wait>ing on that variable. If more than -one thread is blocked in a C<cond_wait> on that variable, only one (and -which one is indeterminate) will be unblocked. - -If there are no threads blocked in a C<cond_wait> on the variable, the -signal is discarded. - -=item cond_broadcast VARIABLE - -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. - -=item yield - -The C<yield> function allows another thread to take control of the -CPU. The exact results are implementation-dependent. - -=back - -=head1 METHODS - -=over 8 - -=item join - -C<join> waits for a thread to end and returns any values the thread exited -with. C<join> will block until the thread has ended, though it won't block -if the thread has already terminated. - -If the thread being C<join>ed C<die>d, the error it died with will be -returned at this time. If you don't want the thread performing the C<join> -to die as well, you should either wrap the C<join> in an C<eval> or use the -C<eval> thread method instead of C<join>. - -=item eval - -The C<eval> method wraps an C<eval> around a C<join>, and so waits for a -thread to exit, passing along any values the thread might have returned. -Errors, of course, get placed into C<$@>. - -=item detach - -C<detach> tells a thread that it is never going to be joined i.e. -that all traces of its existence can be removed once it stops running. -Errors in detached threads will not be visible anywhere - if you want -to catch them, you should use $SIG{__DIE__} or something like that. - -=item equal - -C<equal> tests whether two thread objects represent the same thread and -returns true if they do. - -=item tid - -The C<tid> method returns the tid of a thread. The tid is a monotonically -increasing integer assigned when a thread is created. The main thread of a -program will have a tid of zero, while subsequent threads will have tids -assigned starting with one. - -=back - -=head1 LIMITATIONS - -The sequence number used to assign tids is a simple integer, and no -checking is done to make sure the tid isn't currently in use. If a program -creates more than 2^32 - 1 threads in a single run, threads may be assigned -duplicate tids. This limitation may be lifted in a future version of Perl. - -=head1 SEE ALSO - -L<attributes>, L<Thread::Queue>, L<Thread::Semaphore>, L<Thread::Specific>. - -=cut - -# -# Methods -# - -# -# Exported functions -# -sub async (&) { - return new Thread $_[0]; -} - -sub eval { - return eval { shift->join; }; -} - -XSLoader::load 'Thread'; - -1; diff --git a/contrib/perl5/ext/Thread/Thread.xs b/contrib/perl5/ext/Thread/Thread.xs deleted file mode 100644 index 15e2aa2..0000000 --- a/contrib/perl5/ext/Thread/Thread.xs +++ /dev/null @@ -1,670 +0,0 @@ -#define PERL_NO_GET_CONTEXT -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -/* Magic signature for Thread's mg_private is "Th" */ -#define Thread_MAGIC_SIGNATURE 0x5468 - -#ifdef __cplusplus -#ifdef I_UNISTD -#include <unistd.h> -#endif -#endif -#include <fcntl.h> - -static int sig_pipe[2]; - -#ifndef THREAD_RET_TYPE -#define THREAD_RET_TYPE void * -#define THREAD_RET_CAST(x) ((THREAD_RET_TYPE) x) -#endif - -static void -remove_thread(pTHX_ Thread t) -{ -#ifdef USE_THREADS - DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log, - "%p: remove_thread %p\n", thr, t))); - MUTEX_LOCK(&PL_threads_mutex); - MUTEX_DESTROY(&t->mutex); - PL_nthreads--; - t->prev->next = t->next; - t->next->prev = t->prev; - SvREFCNT_dec(t->oursv); - COND_BROADCAST(&PL_nthreads_cond); - MUTEX_UNLOCK(&PL_threads_mutex); -#endif -} - -static THREAD_RET_TYPE -threadstart(void *arg) -{ -#ifdef USE_THREADS -#ifdef FAKE_THREADS - Thread savethread = thr; - LOGOP myop; - dSP; - I32 oldscope = PL_scopestack_ix; - I32 retval; - AV *av; - int i; - - DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p starting at %s\n", - thr, SvPEEK(TOPs))); - thr = (Thread) arg; - savemark = TOPMARK; - thr->prev = thr->prev_run = savethread; - thr->next = savethread->next; - thr->next_run = savethread->next_run; - savethread->next = savethread->next_run = thr; - thr->wait_queue = 0; - thr->private = 0; - - /* Now duplicate most of perl_call_sv but with a few twists */ - PL_op = (OP*)&myop; - Zero(PL_op, 1, LOGOP); - myop.op_flags = OPf_STACKED; - myop.op_next = Nullop; - myop.op_flags |= OPf_KNOW; - myop.op_flags |= OPf_WANT_LIST; - PL_op = pp_entersub(ARGS); - DEBUG_S(if (!PL_op) - PerlIO_printf(Perl_debug_log, "thread starts at Nullop\n")); - /* - * When this thread is next scheduled, we start in the right - * place. When the thread runs off the end of the sub, perl.c - * handles things, using savemark to figure out how much of the - * stack is the return value for any join. - */ - thr = savethread; /* back to the old thread */ - return 0; -#else - Thread thr = (Thread) arg; - LOGOP myop; - dSP; - I32 oldmark = TOPMARK; - I32 oldscope = PL_scopestack_ix; - I32 retval; - SV *sv; - AV *av; - int i, ret; - dJMPENV; - -#if defined(MULTIPLICITY) - PERL_SET_INTERP(thr->interp); -#endif - - DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p waiting to start\n", - thr)); - - /* - * Wait until our creator releases us. If we didn't do this, then - * it would be potentially possible for out thread to carry on and - * do stuff before our creator fills in our "self" field. For example, - * if we went and created another thread which tried to JOIN with us, - * then we'd be in a mess. - */ - MUTEX_LOCK(&thr->mutex); - MUTEX_UNLOCK(&thr->mutex); - - /* - * It's safe to wait until now to set the thread-specific pointer - * from our pthread_t structure to our struct perl_thread, since - * we're the only thread who can get at it anyway. - */ - PERL_SET_THX(thr); - - DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p starting at %s\n", - thr, SvPEEK(TOPs))); - - av = newAV(); - sv = POPs; - PUTBACK; - ENTER; - SAVETMPS; - perl_call_sv(sv, G_ARRAY|G_EVAL); - SPAGAIN; - retval = SP - (PL_stack_base + oldmark); - SP = PL_stack_base + oldmark + 1; - if (SvCUR(thr->errsv)) { - MUTEX_LOCK(&thr->mutex); - thr->flags |= THRf_DID_DIE; - MUTEX_UNLOCK(&thr->mutex); - av_store(av, 0, &PL_sv_no); - av_store(av, 1, newSVsv(thr->errsv)); - DEBUG_S(PerlIO_printf(Perl_debug_log, "%p died: %s\n", - thr, SvPV(thr->errsv, PL_na))); - } - else { - DEBUG_S(STMT_START { - for (i = 1; i <= retval; i++) { - PerlIO_printf(Perl_debug_log, "%p return[%d] = %s\n", - thr, i, SvPEEK(SP[i - 1])); - } - } STMT_END); - av_store(av, 0, &PL_sv_yes); - for (i = 1; i <= retval; i++, SP++) - sv_setsv(*av_fetch(av, i, TRUE), SvREFCNT_inc(*SP)); - } - FREETMPS; - LEAVE; - - finishoff: -#if 0 - /* removed for debug */ - SvREFCNT_dec(PL_curstack); -#endif - SvREFCNT_dec(thr->cvcache); - SvREFCNT_dec(thr->threadsv); - SvREFCNT_dec(thr->specific); - SvREFCNT_dec(thr->errsv); - - /*Safefree(cxstack);*/ - while (PL_curstackinfo->si_next) - PL_curstackinfo = PL_curstackinfo->si_next; - while (PL_curstackinfo) { - PERL_SI *p = PL_curstackinfo->si_prev; - SvREFCNT_dec(PL_curstackinfo->si_stack); - Safefree(PL_curstackinfo->si_cxstack); - Safefree(PL_curstackinfo); - PL_curstackinfo = p; - } - Safefree(PL_markstack); - Safefree(PL_scopestack); - Safefree(PL_savestack); - Safefree(PL_retstack); - Safefree(PL_tmps_stack); - Safefree(PL_ofs); - - SvREFCNT_dec(PL_rs); - SvREFCNT_dec(PL_nrs); - SvREFCNT_dec(PL_statname); - SvREFCNT_dec(PL_errors); - Safefree(PL_screamfirst); - Safefree(PL_screamnext); - Safefree(PL_reg_start_tmp); - SvREFCNT_dec(PL_lastscream); - SvREFCNT_dec(PL_defoutgv); - Safefree(PL_reg_poscache); - - MUTEX_LOCK(&thr->mutex); - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p: threadstart finishing: state is %u\n", - thr, ThrSTATE(thr))); - switch (ThrSTATE(thr)) { - case THRf_R_JOINABLE: - ThrSETSTATE(thr, THRf_ZOMBIE); - MUTEX_UNLOCK(&thr->mutex); - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p: R_JOINABLE thread finished\n", thr)); - break; - case THRf_R_JOINED: - ThrSETSTATE(thr, THRf_DEAD); - MUTEX_UNLOCK(&thr->mutex); - remove_thread(aTHX_ thr); - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p: R_JOINED thread finished\n", thr)); - break; - case THRf_R_DETACHED: - ThrSETSTATE(thr, THRf_DEAD); - MUTEX_UNLOCK(&thr->mutex); - SvREFCNT_dec(av); - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p: DETACHED thread finished\n", thr)); - remove_thread(aTHX_ thr); /* This might trigger main thread to finish */ - break; - default: - MUTEX_UNLOCK(&thr->mutex); - croak("panic: illegal state %u at end of threadstart", ThrSTATE(thr)); - /* NOTREACHED */ - } - return THREAD_RET_CAST(av); /* Available for anyone to join with */ - /* us unless we're detached, in which */ - /* case noone sees the value anyway. */ -#endif -#else - return THREAD_RET_CAST(NULL); -#endif -} - -static SV * -newthread (pTHX_ SV *startsv, AV *initargs, char *classname) -{ -#ifdef USE_THREADS - dSP; - Thread savethread; - int i; - SV *sv; - int err; -#ifndef THREAD_CREATE - static pthread_attr_t attr; - static int attr_inited = 0; - sigset_t fullmask, oldmask; - static int attr_joinable = PTHREAD_CREATE_JOINABLE; -#endif - - savethread = thr; - thr = new_struct_thread(thr); - /* temporarily pretend to be the child thread in case the - * XPUSHs() below want to grow the child's stack. This is - * safe, since the other thread is not yet created, and we - * are the only ones who know about it */ - PERL_SET_THX(thr); - SPAGAIN; - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p: newthread (%p), tid is %u, preparing stack\n", - savethread, thr, thr->tid)); - /* The following pushes the arg list and startsv onto the *new* stack */ - PUSHMARK(SP); - /* Could easily speed up the following greatly */ - for (i = 0; i <= AvFILL(initargs); i++) - XPUSHs(SvREFCNT_inc(*av_fetch(initargs, i, FALSE))); - XPUSHs(SvREFCNT_inc(startsv)); - PUTBACK; - - /* On your marks... */ - PERL_SET_THX(savethread); - MUTEX_LOCK(&thr->mutex); - -#ifdef THREAD_CREATE - err = THREAD_CREATE(thr, threadstart); -#else - /* Get set... */ - sigfillset(&fullmask); - if (sigprocmask(SIG_SETMASK, &fullmask, &oldmask) == -1) - croak("panic: sigprocmask"); - err = 0; - if (!attr_inited) { - attr_inited = 1; - err = pthread_attr_init(&attr); -# ifdef PTHREAD_ATTR_SETDETACHSTATE - if (err == 0) - err = PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable); - -# else - croak("panic: can't pthread_attr_setdetachstate"); -# endif - } - if (err == 0) - err = PTHREAD_CREATE(&thr->self, attr, threadstart, (void*) thr); -#endif - - if (err) { - MUTEX_UNLOCK(&thr->mutex); - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p: create of %p failed %d\n", - savethread, thr, err)); - /* Thread creation failed--clean up */ - SvREFCNT_dec(thr->cvcache); - remove_thread(aTHX_ thr); - for (i = 0; i <= AvFILL(initargs); i++) - SvREFCNT_dec(*av_fetch(initargs, i, FALSE)); - SvREFCNT_dec(startsv); - return NULL; - } - -#ifdef THREAD_POST_CREATE - THREAD_POST_CREATE(thr); -#else - if (sigprocmask(SIG_SETMASK, &oldmask, 0)) - croak("panic: sigprocmask"); -#endif - - sv = newSViv(thr->tid); - sv_magic(sv, thr->oursv, '~', 0, 0); - SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE; - sv = sv_bless(newRV_noinc(sv), gv_stashpv(classname, TRUE)); - - /* Go */ - MUTEX_UNLOCK(&thr->mutex); - - return sv; -#else -# ifdef USE_ITHREADS - croak("This perl was built for \"ithreads\", which currently does not support Thread.pm.\n" - "Run \"perldoc Thread\" for more information"); -# else - croak("This perl was not built with support for 5.005-style threads.\n" - "Run \"perldoc Thread\" for more information"); -# endif - return &PL_sv_undef; -#endif -} - -static Signal_t handle_thread_signal (int sig); - -static Signal_t -handle_thread_signal(int sig) -{ - dTHXo; - unsigned char c = (unsigned char) sig; - /* - * We're not really allowed to call fprintf in a signal handler - * so don't be surprised if this isn't robust while debugging - * with -DL. - */ - DEBUG_S(PerlIO_printf(Perl_debug_log, - "handle_thread_signal: got signal %d\n", sig);); - write(sig_pipe[1], &c, 1); -} - -MODULE = Thread PACKAGE = Thread -PROTOTYPES: DISABLE - -void -new(classname, startsv, ...) - char * classname - SV * startsv - AV * av = av_make(items - 2, &ST(2)); - PPCODE: - XPUSHs(sv_2mortal(newthread(aTHX_ startsv, av, classname))); - -void -join(t) - Thread t - AV * av = NO_INIT - int i = NO_INIT - PPCODE: -#ifdef USE_THREADS - if (t == thr) - croak("Attempt to join self"); - DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: joining %p (state %u)\n", - thr, t, ThrSTATE(t));); - MUTEX_LOCK(&t->mutex); - switch (ThrSTATE(t)) { - case THRf_R_JOINABLE: - case THRf_R_JOINED: - ThrSETSTATE(t, THRf_R_JOINED); - MUTEX_UNLOCK(&t->mutex); - break; - case THRf_ZOMBIE: - ThrSETSTATE(t, THRf_DEAD); - MUTEX_UNLOCK(&t->mutex); - remove_thread(aTHX_ t); - break; - default: - MUTEX_UNLOCK(&t->mutex); - croak("can't join with thread"); - /* NOTREACHED */ - } - JOIN(t, &av); - - sv_2mortal((SV*)av); - - if (SvTRUE(*av_fetch(av, 0, FALSE))) { - /* Could easily speed up the following if necessary */ - for (i = 1; i <= AvFILL(av); i++) - XPUSHs(*av_fetch(av, i, FALSE)); - } - else { - STRLEN n_a; - char *mess = SvPV(*av_fetch(av, 1, FALSE), n_a); - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p: join propagating die message: %s\n", - thr, mess)); - croak(mess); - } -#endif - -void -detach(t) - Thread t - CODE: -#ifdef USE_THREADS - DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: detaching %p (state %u)\n", - thr, t, ThrSTATE(t));); - MUTEX_LOCK(&t->mutex); - switch (ThrSTATE(t)) { - case THRf_R_JOINABLE: - ThrSETSTATE(t, THRf_R_DETACHED); - /* fall through */ - case THRf_R_DETACHED: - DETACH(t); - MUTEX_UNLOCK(&t->mutex); - break; - case THRf_ZOMBIE: - ThrSETSTATE(t, THRf_DEAD); - DETACH(t); - MUTEX_UNLOCK(&t->mutex); - remove_thread(aTHX_ t); - break; - default: - MUTEX_UNLOCK(&t->mutex); - croak("can't detach thread"); - /* NOTREACHED */ - } -#endif - -void -equal(t1, t2) - Thread t1 - Thread t2 - PPCODE: - PUSHs((t1 == t2) ? &PL_sv_yes : &PL_sv_no); - -void -flags(t) - Thread t - PPCODE: -#ifdef USE_THREADS - PUSHs(sv_2mortal(newSViv(t->flags))); -#endif - -void -self(classname) - char * classname - PREINIT: - SV *sv; - PPCODE: -#ifdef USE_THREADS - sv = newSViv(thr->tid); - sv_magic(sv, thr->oursv, '~', 0, 0); - SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE; - PUSHs(sv_2mortal(sv_bless(newRV_noinc(sv), - gv_stashpv(classname, TRUE)))); -#endif - -U32 -tid(t) - Thread t - CODE: -#ifdef USE_THREADS - MUTEX_LOCK(&t->mutex); - RETVAL = t->tid; - MUTEX_UNLOCK(&t->mutex); -#else - RETVAL = 0; -#endif - OUTPUT: - RETVAL - -void -DESTROY(t) - SV * t - PPCODE: - PUSHs(&PL_sv_yes); - -void -yield() - CODE: -{ -#ifdef USE_THREADS - YIELD; -#endif -} - -void -cond_wait(sv) - SV * sv - MAGIC * mg = NO_INIT -CODE: -#ifdef USE_THREADS - if (SvROK(sv)) - sv = SvRV(sv); - - mg = condpair_magic(sv); - DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: cond_wait %p\n", thr, sv)); - MUTEX_LOCK(MgMUTEXP(mg)); - if (MgOWNER(mg) != thr) { - MUTEX_UNLOCK(MgMUTEXP(mg)); - croak("cond_wait for lock that we don't own\n"); - } - MgOWNER(mg) = 0; - COND_SIGNAL(MgOWNERCONDP(mg)); - COND_WAIT(MgCONDP(mg), MgMUTEXP(mg)); - while (MgOWNER(mg)) - COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); - MgOWNER(mg) = thr; - MUTEX_UNLOCK(MgMUTEXP(mg)); -#endif - -void -cond_signal(sv) - SV * sv - MAGIC * mg = NO_INIT -CODE: -#ifdef USE_THREADS - if (SvROK(sv)) - sv = SvRV(sv); - - mg = condpair_magic(sv); - DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: cond_signal %p\n",thr,sv)); - MUTEX_LOCK(MgMUTEXP(mg)); - if (MgOWNER(mg) != thr) { - MUTEX_UNLOCK(MgMUTEXP(mg)); - croak("cond_signal for lock that we don't own\n"); - } - COND_SIGNAL(MgCONDP(mg)); - MUTEX_UNLOCK(MgMUTEXP(mg)); -#endif - -void -cond_broadcast(sv) - SV * sv - MAGIC * mg = NO_INIT -CODE: -#ifdef USE_THREADS - if (SvROK(sv)) - sv = SvRV(sv); - - mg = condpair_magic(sv); - DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: cond_broadcast %p\n", - thr, sv)); - MUTEX_LOCK(MgMUTEXP(mg)); - if (MgOWNER(mg) != thr) { - MUTEX_UNLOCK(MgMUTEXP(mg)); - croak("cond_broadcast for lock that we don't own\n"); - } - COND_BROADCAST(MgCONDP(mg)); - MUTEX_UNLOCK(MgMUTEXP(mg)); -#endif - -void -list(classname) - char * classname - PREINIT: - Thread t; - AV * av; - SV ** svp; - int n = 0; - PPCODE: -#ifdef USE_THREADS - av = newAV(); - /* - * Iterate until we have enough dynamic storage for all threads. - * We mustn't do any allocation while holding threads_mutex though. - */ - MUTEX_LOCK(&PL_threads_mutex); - do { - n = PL_nthreads; - MUTEX_UNLOCK(&PL_threads_mutex); - if (AvFILL(av) < n - 1) { - int i = AvFILL(av); - for (i = AvFILL(av); i < n - 1; i++) { - SV *sv = newSViv(0); /* fill in tid later */ - sv_magic(sv, 0, '~', 0, 0); /* fill in other magic later */ - av_push(av, sv_bless(newRV_noinc(sv), - gv_stashpv(classname, TRUE))); - - } - } - MUTEX_LOCK(&PL_threads_mutex); - } while (n < PL_nthreads); - n = PL_nthreads; /* Get the final correct value */ - - /* - * At this point, there's enough room to fill in av. - * Note that we are holding threads_mutex so the list - * won't change out from under us but all the remaining - * processing is "fast" (no blocking, malloc etc.) - */ - t = thr; - svp = AvARRAY(av); - do { - SV *sv = (SV*)SvRV(*svp); - sv_setiv(sv, t->tid); - SvMAGIC(sv)->mg_obj = SvREFCNT_inc(t->oursv); - SvMAGIC(sv)->mg_flags |= MGf_REFCOUNTED; - SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE; - t = t->next; - svp++; - } while (t != thr); - /* */ - MUTEX_UNLOCK(&PL_threads_mutex); - /* Truncate any unneeded slots in av */ - av_fill(av, n - 1); - /* Finally, push all the new objects onto the stack and drop av */ - EXTEND(SP, n); - for (svp = AvARRAY(av); n > 0; n--, svp++) - PUSHs(*svp); - (void)sv_2mortal((SV*)av); -#endif - - -MODULE = Thread PACKAGE = Thread::Signal - -void -kill_sighandler_thread() - PPCODE: - write(sig_pipe[1], "\0", 1); - PUSHs(&PL_sv_yes); - -void -init_thread_signals() - PPCODE: - PL_sighandlerp = handle_thread_signal; - if (pipe(sig_pipe) == -1) - XSRETURN_UNDEF; - PUSHs(&PL_sv_yes); - -void -await_signal() - PREINIT: - unsigned char c; - SSize_t ret; - CODE: - do { - ret = read(sig_pipe[0], &c, 1); - } while (ret == -1 && errno == EINTR); - if (ret == -1) - croak("panic: await_signal"); - ST(0) = sv_newmortal(); - if (ret) - sv_setsv(ST(0), c ? PL_psig_ptr[c] : &PL_sv_no); - DEBUG_S(PerlIO_printf(Perl_debug_log, - "await_signal returning %s\n", SvPEEK(ST(0)));); - -MODULE = Thread PACKAGE = Thread::Specific - -void -data(classname = "Thread::Specific") - char * classname - PPCODE: -#ifdef USE_THREADS - if (AvFILL(thr->specific) == -1) { - GV *gv = gv_fetchpv("Thread::Specific::FIELDS", TRUE, SVt_PVHV); - av_store(thr->specific, 0, newRV((SV*)GvHV(gv))); - } - XPUSHs(sv_bless(newRV((SV*)thr->specific),gv_stashpv(classname,TRUE))); -#endif diff --git a/contrib/perl5/ext/Thread/Thread/Queue.pm b/contrib/perl5/ext/Thread/Thread/Queue.pm deleted file mode 100644 index 831573c..0000000 --- a/contrib/perl5/ext/Thread/Thread/Queue.pm +++ /dev/null @@ -1,95 +0,0 @@ -package Thread::Queue; -use Thread qw(cond_wait cond_broadcast); - -=head1 NAME - -Thread::Queue - thread-safe queues - -=head1 SYNOPSIS - - use Thread::Queue; - my $q = new Thread::Queue; - $q->enqueue("foo", "bar"); - my $foo = $q->dequeue; # The "bar" is still in the queue. - my $foo = $q->dequeue_nb; # returns "bar", or undef if the queue was - # empty - my $left = $q->pending; # returns the number of items still in the queue - -=head1 DESCRIPTION - -A queue, as implemented by C<Thread::Queue> is a thread-safe data structure -much like a list. Any number of threads can safely add elements to the end -of the list, or remove elements from the head of the list. (Queues don't -permit adding or removing elements from the middle of the list) - -=head1 FUNCTIONS AND METHODS - -=over 8 - -=item new - -The C<new> function creates a new empty queue. - -=item enqueue LIST - -The C<enqueue> method adds a list of scalars on to the end of the queue. -The queue will grow as needed to accomodate the list. - -=item dequeue - -The C<dequeue> method removes a scalar from the head of the queue and -returns it. If the queue is currently empty, C<dequeue> will block the -thread until another thread C<enqueue>s a scalar. - -=item dequeue_nb - -The C<dequeue_nb> method, like the C<dequeue> method, removes a scalar from -the head of the queue and returns it. Unlike C<dequeue>, though, -C<dequeue_nb> won't block if the queue is empty, instead returning -C<undef>. - -=item pending - -The C<pending> method returns the number of items still in the queue. (If -there can be multiple readers on the queue it's best to lock the queue -before checking to make sure that it stays in a consistent state) - -=back - -=head1 SEE ALSO - -L<Thread> - -=cut - -sub new { - my $class = shift; - return bless [@_], $class; -} - -sub dequeue : locked : method { - my $q = shift; - cond_wait $q until @$q; - return shift @$q; -} - -sub dequeue_nb : locked : method { - my $q = shift; - if (@$q) { - return shift @$q; - } else { - return undef; - } -} - -sub enqueue : locked : method { - my $q = shift; - push(@$q, @_) and cond_broadcast $q; -} - -sub pending : locked : method { - my $q = shift; - return scalar(@$q); -} - -1; diff --git a/contrib/perl5/ext/Thread/Thread/Semaphore.pm b/contrib/perl5/ext/Thread/Thread/Semaphore.pm deleted file mode 100644 index 3cd6338..0000000 --- a/contrib/perl5/ext/Thread/Thread/Semaphore.pm +++ /dev/null @@ -1,85 +0,0 @@ -package Thread::Semaphore; -use Thread qw(cond_wait cond_broadcast); - -=head1 NAME - -Thread::Semaphore - thread-safe semaphores - -=head1 SYNOPSIS - - use Thread::Semaphore; - my $s = new Thread::Semaphore; - $s->up; # Also known as the semaphore V -operation. - # The guarded section is here - $s->down; # Also known as the semaphore P -operation. - - # The default semaphore value is 1. - my $s = new Thread::Semaphore($initial_value); - $s->up($up_value); - $s->down($up_value); - -=head1 DESCRIPTION - -Semaphores provide a mechanism to regulate access to resources. Semaphores, -unlike locks, aren't tied to particular scalars, and so may be used to -control access to anything you care to use them for. - -Semaphores don't limit their values to zero or one, so they can be used to -control access to some resource that may have more than one of. (For -example, filehandles) Increment and decrement amounts aren't fixed at one -either, so threads can reserve or return multiple resources at once. - -=head1 FUNCTIONS AND METHODS - -=over 8 - -=item new - -=item new NUMBER - -C<new> creates a new semaphore, and initializes its count to the passed -number. If no number is passed, the semaphore's count is set to one. - -=item down - -=item down NUMBER - -The C<down> method decreases the semaphore's count by the specified number, -or one if no number has been specified. If the semaphore's count would drop -below zero, this method will block until such time that the semaphore's -count is equal to or larger than the amount you're C<down>ing the -semaphore's count by. - -=item up - -=item up NUMBER - -The C<up> method increases the semaphore's count by the number specified, -or one if no number's been specified. This will unblock any thread blocked -trying to C<down> the semaphore if the C<up> raises the semaphore count -above what the C<down>s are trying to decrement it by. - -=back - -=cut - -sub new { - my $class = shift; - my $val = @_ ? shift : 1; - bless \$val, $class; -} - -sub down : locked : method { - my $s = shift; - my $inc = @_ ? shift : 1; - cond_wait $s until $$s >= $inc; - $$s -= $inc; -} - -sub up : locked : method { - my $s = shift; - my $inc = @_ ? shift : 1; - ($$s += $inc) > 0 and cond_broadcast $s; -} - -1; diff --git a/contrib/perl5/ext/Thread/Thread/Signal.pm b/contrib/perl5/ext/Thread/Thread/Signal.pm deleted file mode 100644 index f5f03db..0000000 --- a/contrib/perl5/ext/Thread/Thread/Signal.pm +++ /dev/null @@ -1,50 +0,0 @@ -package Thread::Signal; -use Thread qw(async); - -=head1 NAME - -Thread::Signal - Start a thread which runs signal handlers reliably - -=head1 SYNOPSIS - - use Thread::Signal; - - $SIG{HUP} = \&some_handler; - -=head1 DESCRIPTION - -The C<Thread::Signal> module starts up a special signal handler thread. -All signals to the process are delivered to it and it runs the -associated C<$SIG{FOO}> handlers for them. Without this module, -signals arriving at inopportune moments (such as when perl's internals -are in the middle of updating critical structures) cause the perl -code of the handler to be run unsafely which can cause memory corruption -or worse. - -=head1 BUGS - -This module changes the semantics of signal handling slightly in that -the signal handler is run separately from the main thread (and in -parallel with it). This means that tricks such as calling C<die> from -a signal handler behave differently (and, in particular, can't be -used to exit directly from a system call). - -=cut - -if (!init_thread_signals()) { - require Carp; - Carp::croak("init_thread_signals failed: $!"); -} - -async { - my $sig; - while ($sig = await_signal()) { - &$sig(); - } -}; - -END { - kill_sighandler_thread(); -} - -1; diff --git a/contrib/perl5/ext/Thread/Thread/Specific.pm b/contrib/perl5/ext/Thread/Thread/Specific.pm deleted file mode 100644 index a6271a4..0000000 --- a/contrib/perl5/ext/Thread/Thread/Specific.pm +++ /dev/null @@ -1,28 +0,0 @@ -package Thread::Specific; - -=head1 NAME - -Thread::Specific - thread-specific keys - -=head1 SYNOPSIS - - use Thread::Specific; - my $k = key_create Thread::Specific; - -=head1 DESCRIPTION - -C<key_create> returns a unique thread-specific key. - -=cut - -sub import : locked : method { - require fields; - fields::->import(@_); -} - -sub key_create : locked : method { - our %FIELDS; # suppress "used only once" - return ++$FIELDS{__MAX__}; -} - -1; diff --git a/contrib/perl5/ext/Thread/create.t b/contrib/perl5/ext/Thread/create.t deleted file mode 100644 index df8fc77..0000000 --- a/contrib/perl5/ext/Thread/create.t +++ /dev/null @@ -1,26 +0,0 @@ -use Thread 'async'; -use Config; -use Tie::Hash; - -sub start_here { - my $i; - print "In start_here with args: @_\n"; - for ($i = 1; $i <= 5; $i++) { - print "start_here: $i\n"; - sleep 1; - } -} - -async { - tie my(%h), 'Tie::StdHash'; - %h = %Config; - print "running on $h{archname}\n"; -}; - -print "Starting new thread now\n"; -$t = new Thread \&start_here, qw(foo bar baz); -print "Started thread $t\n"; -for ($count = 1; $count <= 5; $count++) { - print "main: $count\n"; - sleep 1; -} diff --git a/contrib/perl5/ext/Thread/die.t b/contrib/perl5/ext/Thread/die.t deleted file mode 100644 index 6239405..0000000 --- a/contrib/perl5/ext/Thread/die.t +++ /dev/null @@ -1,16 +0,0 @@ -use Thread 'async'; - -$t = async { - print "here\n"; - die "success"; - print "shouldn't get here\n"; -}; - -sleep 1; -print "joining...\n"; -eval { @r = $t->join; }; -if ($@) { - print "thread died with message: $@"; -} else { - print "thread failed to die successfully\n"; -} diff --git a/contrib/perl5/ext/Thread/die2.t b/contrib/perl5/ext/Thread/die2.t deleted file mode 100644 index f6b6955..0000000 --- a/contrib/perl5/ext/Thread/die2.t +++ /dev/null @@ -1,16 +0,0 @@ -use Thread 'async'; - -$t = async { - sleep 1; - print "here\n"; - die "success if preceded by 'thread died...'"; - print "shouldn't get here\n"; -}; - -print "joining...\n"; -@r = eval { $t->join; }; -if ($@) { - print "thread died with message: $@"; -} else { - print "thread failed to die successfully\n"; -} diff --git a/contrib/perl5/ext/Thread/io.t b/contrib/perl5/ext/Thread/io.t deleted file mode 100644 index 6012008..0000000 --- a/contrib/perl5/ext/Thread/io.t +++ /dev/null @@ -1,39 +0,0 @@ -use Thread; - -sub counter { -$count = 10; -while ($count--) { - sleep 1; - print "ping $count\n"; -} -} - -sub reader { - my $line; - while ($line = <STDIN>) { - print "reader: $line"; - } - print "End of input in reader\n"; - return 0; -} - -print <<'EOT'; -This test starts up a thread to read and echo whatever is typed on -the keyboard/stdin, line by line, while the main thread counts down -to zero. The test stays running until both the main thread has -finished counting down and the I/O thread has seen end-of-file on -the terminal/stdin. -EOT - -$r = new Thread \&counter; - -&reader; - -__END__ - - -$count = 10; -while ($count--) { - sleep 1; - print "ping $count\n"; -} diff --git a/contrib/perl5/ext/Thread/join.t b/contrib/perl5/ext/Thread/join.t deleted file mode 100644 index cba2c1c..0000000 --- a/contrib/perl5/ext/Thread/join.t +++ /dev/null @@ -1,11 +0,0 @@ -use Thread; -sub foo { - print "In foo with args: @_\n"; - return (7, 8, 9); -} - -print "Starting thread\n"; -$t = new Thread \&foo, qw(foo bar baz); -print "Joining with $t\n"; -@results = $t->join(); -print "Joining returned ", scalar(@results), " values: @results\n"; diff --git a/contrib/perl5/ext/Thread/join2.t b/contrib/perl5/ext/Thread/join2.t deleted file mode 100644 index 99b43a5..0000000 --- a/contrib/perl5/ext/Thread/join2.t +++ /dev/null @@ -1,12 +0,0 @@ -use Thread; -sub foo { - print "In foo with args: @_\n"; - return (7, 8, 9); -} - -print "Starting thread\n"; -$t = new Thread \&foo, qw(foo bar baz); -sleep 2; -print "Joining with $t\n"; -@results = $t->join(); -print "Joining returned @results\n"; diff --git a/contrib/perl5/ext/Thread/list.t b/contrib/perl5/ext/Thread/list.t deleted file mode 100644 index f13f4b2..0000000 --- a/contrib/perl5/ext/Thread/list.t +++ /dev/null @@ -1,30 +0,0 @@ -use Thread qw(async); -use Thread::Semaphore; - -my $sem = Thread::Semaphore->new(0); - -$nthreads = 4; - -for (my $i = 0; $i < $nthreads; $i++) { - async { - my $tid = Thread->self->tid; - print "thread $tid started...\n"; - $sem->down; - print "thread $tid finishing\n"; - }; -} - -print "main: started $nthreads threads\n"; -sleep 2; - -my @list = Thread->list; -printf "main: Thread->list returned %d threads\n", scalar(@list); - -foreach my $t (@list) { - print "inspecting thread $t...\n"; - print "...deref is $$t\n"; - print "...flags = ", $t->flags, "\n"; - print "...tid = ", $t->tid, "\n"; -} -print "main thread telling workers to finish off...\n"; -$sem->up($nthreads); diff --git a/contrib/perl5/ext/Thread/lock.t b/contrib/perl5/ext/Thread/lock.t deleted file mode 100644 index fefb129..0000000 --- a/contrib/perl5/ext/Thread/lock.t +++ /dev/null @@ -1,27 +0,0 @@ -use Thread; - -$level = 0; - -sub worker -{ - my $num = shift; - my $i; - print "thread $num starting\n"; - for ($i = 1; $i <= 20; $i++) { - print "thread $num iteration $i\n"; - select(undef, undef, undef, rand(10)/100); - { - lock($lock); - warn "thread $num saw non-zero level = $level\n" if $level; - $level++; - print "thread $num has lock\n"; - select(undef, undef, undef, rand(10)/100); - $level--; - } - print "thread $num released lock\n"; - } -} - -for ($t = 1; $t <= 5; $t++) { - new Thread \&worker, $t; -} diff --git a/contrib/perl5/ext/Thread/queue.t b/contrib/perl5/ext/Thread/queue.t deleted file mode 100644 index 4672ba6..0000000 --- a/contrib/perl5/ext/Thread/queue.t +++ /dev/null @@ -1,36 +0,0 @@ -use Thread; -use Thread::Queue; - -$q = new Thread::Queue; - -sub reader { - my $tid = Thread->self->tid; - my $i = 0; - while (1) { - $i++; - print "reader (tid $tid): waiting for element $i...\n"; - my $el = $q->dequeue; - print "reader (tid $tid): dequeued element $i: value $el\n"; - select(undef, undef, undef, rand(2)); - if ($el == -1) { - # end marker - print "reader (tid $tid) returning\n"; - return; - } - } -} - -my $nthreads = 3; - -for (my $i = 0; $i < $nthreads; $i++) { - Thread->new(\&reader, $i); -} - -for (my $i = 1; $i <= 10; $i++) { - my $el = int(rand(100)); - select(undef, undef, undef, rand(2)); - print "writer: enqueuing value $el\n"; - $q->enqueue($el); -} - -$q->enqueue((-1) x $nthreads); # one end marker for each thread diff --git a/contrib/perl5/ext/Thread/specific.t b/contrib/perl5/ext/Thread/specific.t deleted file mode 100644 index da130b1..0000000 --- a/contrib/perl5/ext/Thread/specific.t +++ /dev/null @@ -1,17 +0,0 @@ -use Thread; - -use Thread::Specific qw(foo); - -sub count { - my $tid = Thread->self->tid; - my Thread::Specific $tsd = Thread::Specific::data; - for (my $i = 0; $i < 5; $i++) { - $tsd->{foo} = $i; - print "thread $tid count: $tsd->{foo}\n"; - select(undef, undef, undef, rand(2)); - } -}; - -for(my $t = 0; $t < 5; $t++) { - new Thread \&count; -} diff --git a/contrib/perl5/ext/Thread/sync.t b/contrib/perl5/ext/Thread/sync.t deleted file mode 100644 index 6445b55..0000000 --- a/contrib/perl5/ext/Thread/sync.t +++ /dev/null @@ -1,60 +0,0 @@ -use Thread; - -$level = 0; - -sub single_file : locked { - my $arg = shift; - $level++; - print "Level $level for $arg\n"; - print "(something is wrong)\n" if $level < 0 || $level > 1; - sleep 1; - $level--; - print "Back to level $level\n"; -} - -sub start_bar { - my $i; - print "start bar\n"; - for $i (1..3) { - print "bar $i\n"; - single_file("bar $i"); - sleep 1 if rand > 0.5; - } - print "end bar\n"; - return 1; -} - -sub start_foo { - my $i; - print "start foo\n"; - for $i (1..3) { - print "foo $i\n"; - single_file("foo $i"); - sleep 1 if rand > 0.5; - } - print "end foo\n"; - return 1; -} - -sub start_baz { - my $i; - print "start baz\n"; - for $i (1..3) { - print "baz $i\n"; - single_file("baz $i"); - sleep 1 if rand > 0.5; - } - print "end baz\n"; - return 1; -} - -$| = 1; -srand($$^$^T); - -$foo = new Thread \&start_foo; -$bar = new Thread \&start_bar; -$baz = new Thread \&start_baz; -$foo->join(); -$bar->join(); -$baz->join(); -print "main: threads finished, exiting\n"; diff --git a/contrib/perl5/ext/Thread/sync2.t b/contrib/perl5/ext/Thread/sync2.t deleted file mode 100644 index ffc74b4..0000000 --- a/contrib/perl5/ext/Thread/sync2.t +++ /dev/null @@ -1,68 +0,0 @@ -use Thread; - -$global = undef; - -sub single_file : locked { - my $who = shift; - my $i; - - print "Uh oh: $who entered while locked by $global\n" if $global; - $global = $who; - print "["; - for ($i = 0; $i < int(10 * rand); $i++) { - print $who; - select(undef, undef, undef, 0.1); - } - print "]"; - $global = undef; -} - -sub start_a { - my ($i, $j); - for ($j = 0; $j < 10; $j++) { - single_file("A"); - for ($i = 0; $i < int(10 * rand); $i++) { - print "a"; - select(undef, undef, undef, 0.1); - } - } -} - -sub start_b { - my ($i, $j); - for ($j = 0; $j < 10; $j++) { - single_file("B"); - for ($i = 0; $i < int(10 * rand); $i++) { - print "b"; - select(undef, undef, undef, 0.1); - } - } -} - -sub start_c { - my ($i, $j); - for ($j = 0; $j < 10; $j++) { - single_file("C"); - for ($i = 0; $i < int(10 * rand); $i++) { - print "c"; - select(undef, undef, undef, 0.1); - } - } -} - -$| = 1; -srand($$^$^T); - -print <<'EOT'; -Each pair of square brackets [...] should contain a repeated sequence of -a unique upper case letter. Lower case letters may appear randomly both -in and out of the brackets. -EOT -$foo = new Thread \&start_a; -$bar = new Thread \&start_b; -$baz = new Thread \&start_c; -print "\nmain: joining...\n"; -#$foo->join; -#$bar->join; -#$baz->join; -print "\ndone\n"; diff --git a/contrib/perl5/ext/Thread/typemap b/contrib/perl5/ext/Thread/typemap deleted file mode 100644 index 7ce7d5c..0000000 --- a/contrib/perl5/ext/Thread/typemap +++ /dev/null @@ -1,24 +0,0 @@ -Thread T_XSCPTR - -INPUT -T_XSCPTR - STMT_START { - MAGIC *mg; - SV *sv = ($arg); - - if (!sv_isobject(sv)) - croak(\"$var is not an object\"); - sv = (SV*)SvRV(sv); - if (!SvRMAGICAL(sv) || !(mg = mg_find(sv, '~')) - || mg->mg_private != ${ntype}_MAGIC_SIGNATURE) - croak(\"XSUB ${func_name}: $var is a forged ${ntype} object\"); - $var = ($type) SvPVX(mg->mg_obj); - DEBUG_S(PerlIO_printf(Perl_debug_log, - \"XSUB ${func_name}: %p\\n\", $var);) - } STMT_END -T_IVREF - if (SvROK($arg)) - $var = ($type) SvIV((SV*)SvRV($arg)); - else - croak(\"$var is not a reference\") - diff --git a/contrib/perl5/ext/Thread/unsync.t b/contrib/perl5/ext/Thread/unsync.t deleted file mode 100644 index f0a51ef..0000000 --- a/contrib/perl5/ext/Thread/unsync.t +++ /dev/null @@ -1,37 +0,0 @@ -use Thread; - -$| = 1; - -if (@ARGV) { - srand($ARGV[0]); -} else { - my $seed = $$ ^ $^T; - print "Randomising to $seed\n"; - srand($seed); -} - -sub whoami { - my ($depth, $a, $b, $c) = @_; - my $i; - print "whoami ($depth): $a $b $c\n"; - sleep 1; - whoami($depth - 1, $a, $b, $c) if $depth > 0; -} - -sub start_foo { - my $r = 3 + int(10 * rand); - print "start_foo: r is $r\n"; - whoami($r, "start_foo", "foo1", "foo2"); - print "start_foo: finished\n"; -} - -sub start_bar { - my $r = 3 + int(10 * rand); - print "start_bar: r is $r\n"; - whoami($r, "start_bar", "bar1", "bar2"); - print "start_bar: finished\n"; -} - -$foo = new Thread \&start_foo; -$bar = new Thread \&start_bar; -print "main: exiting\n"; diff --git a/contrib/perl5/ext/Thread/unsync2.t b/contrib/perl5/ext/Thread/unsync2.t deleted file mode 100644 index fb955ac..0000000 --- a/contrib/perl5/ext/Thread/unsync2.t +++ /dev/null @@ -1,36 +0,0 @@ -use Thread; - -$| = 1; - -srand($$^$^T); - -sub printargs { - my $thread = shift; - my $arg; - my $i; - while ($arg = shift) { - my $delay = int(rand(500)); - $i++; - print "$thread arg $i is $arg\n"; - 1 while $delay--; - } -} - -sub start_thread { - my $thread = shift; - my $count = 10; - while ($count--) { - my(@args) = ($thread) x int(rand(10)); - print "$thread $count calling printargs @args\n"; - printargs($thread, @args); - } -} - -new Thread (\&start_thread, "A"); -new Thread (\&start_thread, "B"); -#new Thread (\&start_thread, "C"); -#new Thread (\&start_thread, "D"); -#new Thread (\&start_thread, "E"); -#new Thread (\&start_thread, "F"); - -print "main: exiting\n"; diff --git a/contrib/perl5/ext/Thread/unsync3.t b/contrib/perl5/ext/Thread/unsync3.t deleted file mode 100644 index e03e9c8..0000000 --- a/contrib/perl5/ext/Thread/unsync3.t +++ /dev/null @@ -1,50 +0,0 @@ -use Thread; - -$| = 1; - -srand($$^$^T); - -sub whoami { - my $thread = shift; - print $thread; -} - -sub uppercase { - my $count = 100; - while ($count--) { - my $i = int(rand(1000)); - 1 while $i--; - print "A"; - $i = int(rand(1000)); - 1 while $i--; - whoami("B"); - } -} - -sub lowercase { - my $count = 100; - while ($count--) { - my $i = int(rand(1000)); - 1 while $i--; - print "x"; - $i = int(rand(1000)); - 1 while $i--; - whoami("y"); - } -} - -sub numbers { - my $count = 100; - while ($count--) { - my $i = int(rand(1000)); - 1 while $i--; - print 1; - $i = int(rand(1000)); - 1 while $i--; - whoami(2); - } -} - -new Thread \&numbers; -new Thread \&uppercase; -new Thread \&lowercase; diff --git a/contrib/perl5/ext/Thread/unsync4.t b/contrib/perl5/ext/Thread/unsync4.t deleted file mode 100644 index 494ad2b..0000000 --- a/contrib/perl5/ext/Thread/unsync4.t +++ /dev/null @@ -1,38 +0,0 @@ -use Thread; - -$| = 1; - -srand($$^$^T); - -sub printargs { - my(@copyargs) = @_; - my $thread = shift @copyargs; - my $arg; - my $i; - while ($arg = shift @copyargs) { - my $delay = int(rand(500)); - $i++; - print "$thread arg $i is $arg\n"; - 1 while $delay--; - } -} - -sub start_thread { - my(@threadargs) = @_; - my $thread = $threadargs[0]; - my $count = 10; - while ($count--) { - my(@args) = ($thread) x int(rand(10)); - print "$thread $count calling printargs @args\n"; - printargs($thread, @args); - } -} - -new Thread (\&start_thread, "A"); -new Thread (\&start_thread, "B"); -new Thread (\&start_thread, "C"); -new Thread (\&start_thread, "D"); -new Thread (\&start_thread, "E"); -new Thread (\&start_thread, "F"); - -print "main: exiting\n"; diff --git a/contrib/perl5/ext/attrs/Makefile.PL b/contrib/perl5/ext/attrs/Makefile.PL deleted file mode 100644 index 86ed3f3..0000000 --- a/contrib/perl5/ext/attrs/Makefile.PL +++ /dev/null @@ -1,7 +0,0 @@ -use ExtUtils::MakeMaker; -WriteMakefile( - NAME => 'attrs', - VERSION_FROM => 'attrs.pm', - MAN3PODS => {}, # Pods will be built by installman. - XSPROTOARG => '-noprototypes' -); diff --git a/contrib/perl5/ext/attrs/attrs.pm b/contrib/perl5/ext/attrs/attrs.pm deleted file mode 100644 index 2070632..0000000 --- a/contrib/perl5/ext/attrs/attrs.pm +++ /dev/null @@ -1,58 +0,0 @@ -package attrs; -use XSLoader (); - -$VERSION = "1.0"; - -=head1 NAME - -attrs - set/get attributes of a subroutine (deprecated) - -=head1 SYNOPSIS - - sub foo { - use attrs qw(locked method); - ... - } - - @a = attrs::get(\&foo); - -=head1 DESCRIPTION - -NOTE: Use of this pragma is deprecated. Use the syntax - - sub foo : locked method { } - -to declare attributes instead. See also L<attributes>. - -This pragma lets you set and get attributes for subroutines. -Setting attributes takes place at compile time; trying to set -invalid attribute names causes a compile-time error. Calling -C<attrs::get> on a subroutine reference or name returns its list -of attribute names. Notice that C<attrs::get> is not exported. -Valid attributes are as follows. - -=over - -=item method - -Indicates that the invoking subroutine is a method. - -=item locked - -Setting this attribute is only meaningful when the subroutine or -method is to be called by multiple threads. When set on a method -subroutine (i.e. one marked with the B<method> attribute above), -perl ensures that any invocation of it implicitly locks its first -argument before execution. When set on a non-method subroutine, -perl ensures that a lock is taken on the subroutine itself before -execution. The semantics of the lock are exactly those of one -explicitly taken with the C<lock> operator immediately after the -subroutine is entered. - -=back - -=cut - -XSLoader::load 'attrs', $VERSION; - -1; diff --git a/contrib/perl5/ext/attrs/attrs.xs b/contrib/perl5/ext/attrs/attrs.xs deleted file mode 100644 index 4c00cd7..0000000 --- a/contrib/perl5/ext/attrs/attrs.xs +++ /dev/null @@ -1,66 +0,0 @@ -#define PERL_NO_GET_CONTEXT -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -static cv_flags_t -get_flag(char *attr) -{ - if (strnEQ(attr, "method", 6)) - return CVf_METHOD; - else if (strnEQ(attr, "locked", 6)) - return CVf_LOCKED; - else - return 0; -} - -MODULE = attrs PACKAGE = attrs - -void -import(Class, ...) -char * Class - ALIAS: - unimport = 1 - PREINIT: - int i; - CV *cv; - PPCODE: - if (!PL_compcv || !(cv = CvOUTSIDE(PL_compcv))) - croak("can't set attributes outside a subroutine scope"); - if (ckWARN(WARN_DEPRECATED)) - Perl_warner(aTHX_ WARN_DEPRECATED, - "pragma \"attrs\" is deprecated, " - "use \"sub NAME : ATTRS\" instead"); - for (i = 1; i < items; i++) { - STRLEN n_a; - char *attr = SvPV(ST(i), n_a); - cv_flags_t flag = get_flag(attr); - if (!flag) - croak("invalid attribute name %s", attr); - if (ix) - CvFLAGS(cv) &= ~flag; - else - CvFLAGS(cv) |= flag; - } - -void -get(sub) -SV * sub - PPCODE: - if (SvROK(sub)) { - sub = SvRV(sub); - if (SvTYPE(sub) != SVt_PVCV) - sub = Nullsv; - } - else { - STRLEN n_a; - char *name = SvPV(sub, n_a); - sub = (SV*)perl_get_cv(name, FALSE); - } - if (!sub) - croak("invalid subroutine reference or name"); - if (CvFLAGS(sub) & CVf_METHOD) - XPUSHs(sv_2mortal(newSVpvn("method", 6))); - if (CvFLAGS(sub) & CVf_LOCKED) - XPUSHs(sv_2mortal(newSVpvn("locked", 6))); - diff --git a/contrib/perl5/ext/re/Makefile.PL b/contrib/perl5/ext/re/Makefile.PL deleted file mode 100644 index bc31b2c..0000000 --- a/contrib/perl5/ext/re/Makefile.PL +++ /dev/null @@ -1,38 +0,0 @@ -use ExtUtils::MakeMaker; -use File::Spec; - -WriteMakefile( - NAME => 're', - VERSION_FROM => 're.pm', - MAN3PODS => {}, # Pods will be built by installman. - XSPROTOARG => '-noprototypes', - OBJECT => 're_exec$(OBJ_EXT) re_comp$(OBJ_EXT) re$(OBJ_EXT)', - DEFINE => '-DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG', - clean => { FILES => '*$(OBJ_EXT) *.c ../../lib/re.pm' }, -); - -package MY; - -sub upupfile { - File::Spec->catfile(File::Spec->updir, File::Spec->updir, $_[0]); -} - -sub postamble { - my $regcomp_c = upupfile('regcomp.c'); - my $regexec_c = upupfile('regexec.c'); - - <<EOF; -re_comp.c : $regcomp_c - - \$(RM_F) re_comp.c - \$(CP) $regcomp_c re_comp.c - -re_comp\$(OBJ_EXT) : re_comp.c - -re_exec.c : $regexec_c - - \$(RM_F) re_exec.c - \$(CP) $regexec_c re_exec.c - -re_exec\$(OBJ_EXT) : re_exec.c - -EOF -} diff --git a/contrib/perl5/ext/re/hints/aix.pl b/contrib/perl5/ext/re/hints/aix.pl deleted file mode 100644 index 4fbfefd..0000000 --- a/contrib/perl5/ext/re/hints/aix.pl +++ /dev/null @@ -1,22 +0,0 @@ -# Add explicit link to deb.o to pick up .Perl_deb symbol which is not -# mentioned in perl.exp for earlier cc (xlc) versions in at least -# non DEBUGGING builds -# Peter Prymmer <pvhp@best.com> - -use Config; - -if ($^O eq 'aix' && defined($Config{'ccversion'}) && - ( $Config{'ccversion'} =~ /^3\.\d/ - # needed for at least these versions: - # $Config{'ccversion'} eq '3.6.6.0' - # $Config{'ccversion'} eq '3.6.4.0' - # $Config{'ccversion'} eq '3.1.4.0' AIX 4.2 - # $Config{'ccversion'} eq '3.1.4.10' AIX 4.2 - # $Config{'ccversion'} eq '3.1.3.3' - || - $Config{'ccversion'} =~ /^4\.4\.0\.[0-3]/ - ) - ) { - $self->{OBJECT} .= ' ../../deb$(OBJ_EXT)'; -} - diff --git a/contrib/perl5/ext/re/hints/mpeix.pl b/contrib/perl5/ext/re/hints/mpeix.pl deleted file mode 100644 index d1fbb91..0000000 --- a/contrib/perl5/ext/re/hints/mpeix.pl +++ /dev/null @@ -1,3 +0,0 @@ -# Fall back to -O optimization to avoid known gcc 2.8.0 -O2 problems on MPE/iX. -# Mark Bixby <markb@cccd.edu> -$self->{OPTIMIZE} = '-O'; diff --git a/contrib/perl5/ext/re/re.pm b/contrib/perl5/ext/re/re.pm deleted file mode 100644 index 3f142d9..0000000 --- a/contrib/perl5/ext/re/re.pm +++ /dev/null @@ -1,129 +0,0 @@ -package re; - -$VERSION = 0.02; - -=head1 NAME - -re - Perl pragma to alter regular expression behaviour - -=head1 SYNOPSIS - - use re 'taint'; - ($x) = ($^X =~ /^(.*)$/s); # $x is tainted here - - $pat = '(?{ $foo = 1 })'; - use re 'eval'; - /foo${pat}bar/; # won't fail (when not under -T switch) - - { - no re 'taint'; # the default - ($x) = ($^X =~ /^(.*)$/s); # $x is not tainted here - - no re 'eval'; # the default - /foo${pat}bar/; # disallowed (with or without -T switch) - } - - use re 'debug'; # NOT lexically scoped (as others are) - /^(.*)$/s; # output debugging info during - # compile and run time - - use re 'debugcolor'; # same as 'debug', but with colored output - ... - -(We use $^X in these examples because it's tainted by default.) - -=head1 DESCRIPTION - -When C<use re 'taint'> is in effect, and a tainted string is the target -of a regex, the regex memories (or values returned by the m// operator -in list context) are tainted. This feature is useful when regex operations -on tainted data aren't meant to extract safe substrings, but to perform -other transformations. - -When C<use re 'eval'> is in effect, a regex is allowed to contain -C<(?{ ... })> zero-width assertions even if regular expression contains -variable interpolation. That is normally disallowed, since it is a -potential security risk. Note that this pragma is ignored when the regular -expression is obtained from tainted data, i.e. evaluation is always -disallowed with tainted regular expresssions. See L<perlre/(?{ code })>. - -For the purpose of this pragma, interpolation of precompiled regular -expressions (i.e., the result of C<qr//>) is I<not> considered variable -interpolation. Thus: - - /foo${pat}bar/ - -I<is> allowed if $pat is a precompiled regular expression, even -if $pat contains C<(?{ ... })> assertions. - -When C<use re 'debug'> is in effect, perl emits debugging messages when -compiling and using regular expressions. The output is the same as that -obtained by running a C<-DDEBUGGING>-enabled perl interpreter with the -B<-Dr> switch. It may be quite voluminous depending on the complexity -of the match. Using C<debugcolor> instead of C<debug> enables a -form of output that can be used to get a colorful display on terminals -that understand termcap color sequences. Set C<$ENV{PERL_RE_TC}> to a -comma-separated list of C<termcap> properties to use for highlighting -strings on/off, pre-point part on/off. -See L<perldebug/"Debugging regular expressions"> for additional info. - -The directive C<use re 'debug'> is I<not lexically scoped>, as the -other directives are. It has both compile-time and run-time effects. - -See L<perlmodlib/Pragmatic Modules>. - -=cut - -# N.B. File::Basename contains a literal for 'taint' as a fallback. If -# taint is changed here, File::Basename must be updated as well. -my %bitmask = ( -taint => 0x00100000, -eval => 0x00200000, -); - -sub setcolor { - eval { # Ignore errors - require Term::Cap; - - my $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning. - my $props = $ENV{PERL_RE_TC} || 'md,me,so,se,us,ue'; - my @props = split /,/, $props; - my $colors = join "\t", map {$terminal->Tputs($_,1)} @props; - - $colors =~ s/\0//g; - $ENV{PERL_RE_COLORS} = $colors; - }; -} - -sub bits { - my $on = shift; - my $bits = 0; - unless(@_) { - require Carp; - Carp::carp("Useless use of \"re\" pragma"); - } - foreach my $s (@_){ - if ($s eq 'debug' or $s eq 'debugcolor') { - setcolor() if $s eq 'debugcolor'; - require XSLoader; - XSLoader::load('re'); - install() if $on; - uninstall() unless $on; - next; - } - $bits |= $bitmask{$s} || 0; - } - $bits; -} - -sub import { - shift; - $^H |= bits(1,@_); -} - -sub unimport { - shift; - $^H &= ~ bits(0,@_); -} - -1; diff --git a/contrib/perl5/ext/re/re.xs b/contrib/perl5/ext/re/re.xs deleted file mode 100644 index 25c2a90..0000000 --- a/contrib/perl5/ext/re/re.xs +++ /dev/null @@ -1,61 +0,0 @@ -/* We need access to debugger hooks */ -#ifndef DEBUGGING -# define DEBUGGING -#endif - -#define PERL_NO_GET_CONTEXT -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -extern regexp* my_regcomp (pTHX_ char* exp, char* xend, PMOP* pm); -extern I32 my_regexec (pTHX_ regexp* prog, char* stringarg, char* strend, - char* strbeg, I32 minend, SV* screamer, - void* data, U32 flags); -extern void my_regfree (pTHX_ struct regexp* r); -extern char* my_re_intuit_start (pTHX_ regexp *prog, SV *sv, char *strpos, - char *strend, U32 flags, - struct re_scream_pos_data_s *data); -extern SV* my_re_intuit_string (pTHX_ regexp *prog); - -static int oldfl; - -#define R_DB 512 - -static void -deinstall(pTHX) -{ - PL_regexecp = Perl_regexec_flags; - PL_regcompp = Perl_pregcomp; - PL_regint_start = Perl_re_intuit_start; - PL_regint_string = Perl_re_intuit_string; - PL_regfree = Perl_pregfree; - - if (!oldfl) - PL_debug &= ~R_DB; -} - -static void -install(pTHX) -{ - PL_colorset = 0; /* Allow reinspection of ENV. */ - PL_regexecp = &my_regexec; - PL_regcompp = &my_regcomp; - PL_regint_start = &my_re_intuit_start; - PL_regint_string = &my_re_intuit_string; - PL_regfree = &my_regfree; - oldfl = PL_debug & R_DB; - PL_debug |= R_DB; -} - -MODULE = re PACKAGE = re - -void -install() - CODE: - install(aTHX); - -void -deinstall() - CODE: - deinstall(aTHX); diff --git a/contrib/perl5/ext/util/make_ext b/contrib/perl5/ext/util/make_ext deleted file mode 100644 index 54caf7d..0000000 --- a/contrib/perl5/ext/util/make_ext +++ /dev/null @@ -1,141 +0,0 @@ -#!/bin/sh - -# This script acts as a simple interface for building extensions. -# It primarily used by the perl Makefile: -# -# d_dummy $(dynamic_ext): miniperl preplibrary FORCE -# @sh ext/util/make_ext dynamic $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) -# -# It may be deleted in a later release of perl so try to -# avoid using it for other purposes. - -target=$1; shift -extspec=$1; shift -makecmd=$1; shift # Should be something like MAKE=make -passthru="$*" # allow extra macro=value to be passed through -echo "" - -# Previously, $make was taken from config.sh. However, the user might -# instead be running a possibly incompatible make. This might happen if -# the user types "gmake" instead of a plain "make", for example. The -# correct current value of MAKE will come through from the main perl -# makefile as MAKE=/whatever/make in $makecmd. We'll be cautious in -# case third party users of this script (are there any?) don't have the -# MAKE=$(MAKE) argument, which was added after 5.004_03. -case "$makecmd" in -MAKE=*) - eval $makecmd - ;; -*) echo 'ext/util/make_ext: WARNING: Please include MAKE=$(MAKE)' - echo ' in your call to make_ext. See ext/util/make_ext for details.' - exit 1 - ;; -esac - - -case $CONFIG in -'') - if test -f config.sh; then TOP=.; - elif test -f ../config.sh; then TOP=..; - elif test -f ../../config.sh; then TOP=../..; - elif test -f ../../../config.sh; then TOP=../../..; - elif test -f ../../../../config.sh; then TOP=../../../..; - else - echo "Can't find config.sh generated by Configure"; exit 1 - fi - . $TOP/config.sh - ;; -esac - -if test "X$extspec" = X; then - echo "make_ext: no extension specified" - exit 1; -fi - -# The Perl Makefile.SH will expand all extensions to -# lib/auto/X/X.a (or lib/auto/X/Y/Y.a if nested) -# A user wishing to run make_ext might use -# X (or X/Y or X::Y if nested) - -# canonise into X/Y form (pname) -case "$extspec" in -lib*) # Remove lib/auto prefix and /*.* suffix - pname=`echo "$extspec" | sed -e 's:^lib/auto/::' -e 's:/[^/]*\.[^/]*$::' ` ;; -ext*) # Remove ext/ prefix and /pm_to_blib suffix - pname=`echo "$extspec" | sed -e 's:^ext/::' -e 's:/pm_to_blib$::' ` ;; -*::*) # Convert :: to / - pname=`echo "$extspec" | sed -e 's/::/\//g' ` ;; -*) pname="$extspec" ;; -esac -# echo "Converted $extspec to $pname" - -mname=`echo "$pname" | sed -e 's!/!::!g'` -depth=`echo "$pname" | sed -e 's![^/][^/]*!..!g'` -makefile=Makefile -makeargs='' -makeopts='' - -if test ! -d "ext/$pname"; then - echo " Skipping $extspec (directory does not exist)" - exit 0 # not an error ? -fi - - -echo " Making $mname ($target)" - -cd ext/$pname - -# check link type and do any preliminaries -case "$target" in - # convert 'static' or 'dynamic' into 'all LINKTYPE=XXX' -static) makeargs="LINKTYPE=static CCCDLFLAGS=" - target=all - ;; -dynamic) makeargs="LINKTYPE=dynamic"; - target=all - ;; - -nonxs) makeargs=""; - target=all - ;; - -*clean) # If Makefile has been moved to Makefile.old by a make clean - # then use Makefile.old for realclean rather than rebuild it - if test ! -f $makefile -a -f Makefile.old; then - makefile=Makefile.old - makeopts="-f $makefile" - echo "Note: Using Makefile.old" - fi - ;; - -*) # for the time being we are strict about what make_ext is used for - echo "make_ext: unknown make target '$target'"; exit 1 - ;; -'') echo "make_ext: no make target specified (eg static or dynamic)"; exit 1 - ;; -esac - -if test ! -f $makefile ; then - test -f Makefile.PL && ../$depth/miniperl -I../$depth/lib Makefile.PL INSTALLDIRS=perl $passthru -fi -if test ! -f $makefile ; then - if test -f Makefile.SH; then - echo "Warning: Writing $makefile from old-style Makefile.SH!" - sh Makefile.SH - else - echo "Warning: No Makefile!" - fi -fi - -case "$target" in -clean) ;; -realclean) ;; -*) # Give makefile an opportunity to rewrite itself. - # reassure users that life goes on... - $MAKE config $passthru || echo "$MAKE config failed, continuing anyway..." - ;; -esac - -$MAKE $makeopts $target $makeargs $passthru || exit - -exit $? diff --git a/contrib/perl5/ext/util/mkbootstrap b/contrib/perl5/ext/util/mkbootstrap deleted file mode 100644 index 6c3a7e1..0000000 --- a/contrib/perl5/ext/util/mkbootstrap +++ /dev/null @@ -1,5 +0,0 @@ -#!../../miniperl -w -I../../lib - -use ExtUtils::MakeMaker; -&mkbootstrap(join(" ",@ARGV)); -exit; |
