thread, this behaves the same as C. =item threads->exit(status) When called from a thread, this behaves like Cexit()> (i.e., the exit status code is ignored). When called from the I

thread, this behaves the same as C. =item die() Calling C in a thread indicates an abnormal exit for the thread. Any C<$SIG{__DIE__}> handler in the thread will be called first, and then the thread will exit with a warning message that will contain any arguments passed in the C call. =item exit(status) Calling L inside a thread causes the whole application to terminate. Because of this, the use of C inside threaded code, or in modules that might be used in threaded applications, is strongly discouraged. If C really is needed, then consider using the following: threads->exit() if threads->can('exit'); # Thread friendly exit(status); =item use threads 'exit' => 'threads_only' This globally overrides the default behavior of calling C inside a thread, and effectively causes such calls to behave the same as Cexit()>. In other words, with this setting, calling C causes only the thread to terminate. Because of its global effect, this setting should not be used inside modules or the like. The I

thread is unaffected by this setting. =item threads->create({'exit' => 'thread_only'}, ...) This overrides the default behavior of C inside the newly created thread only. =item $thr->set_thread_exit_only(boolean) This can be used to change the I behavior for a thread after it has been created. With a I argument, C will cause only the thread to exit. With a I argument, C will terminate the application. The I

thread is unaffected by this call. =item threads->set_thread_exit_only(boolean) Class method for use inside a thread to change its own behavior for C. The I

thread is unaffected by this call. =back =head1 THREAD STATE The following boolean methods are useful in determining the I of a thread. =over =item $thr->is_running() Returns true if a thread is still running (i.e., if its entry point function has not yet finished or exited). =item $thr->is_joinable() Returns true if the thread has finished running, is not detached and has not yet been joined. In other words, the thread is ready to be joined, and a call to C<$thr-Ejoin()> will not I. =item $thr->is_detached() Returns true if the thread has been detached. =item threads->is_detached() Class method that allows a thread to determine whether or not it is detached. =back =head1 THREAD CONTEXT As with subroutines, the type of value returned from a thread's entry point function may be determined by the thread's I: list, scalar or void. The thread's context is determined at thread creation. This is necessary so that the context is available to the entry point function via L. The thread may then specify a value of the appropriate type to be returned from C<-Ejoin()>. =head2 Explicit context Because thread creation and thread joining may occur in different contexts, it may be desirable to state the context explicitly to the thread's entry point function. This may be done by calling C<-Ecreate()> with a hash reference as the first argument: my $thr = threads->create({'context' => 'list'}, \&foo); ... my @results = $thr->join(); In the above, the threads object is returned to the parent thread in scalar context, and the thread's entry point function C will be called in list (array) context such that the parent thread can receive a list (array) from the C<-Ejoin()> call. (C<'array'> is synonymous with C<'list'>.) Similarly, if you need the threads object, but your thread will not be returning a value (i.e., I context), you would do the following: my $thr = threads->create({'context' => 'void'}, \&foo); ... $thr->join(); The context type may also be used as the I in the hash reference followed by a I value: threads->create({'scalar' => 1}, \&foo); ... my ($thr) = threads->list(); my $result = $thr->join(); =head2 Implicit context If not explicitly stated, the thread's context is implied from the context of the C<-Ecreate()> call: # Create thread in list context my ($thr) = threads->create(...); # Create thread in scalar context my $thr = threads->create(...); # Create thread in void context threads->create(...); =head2 $thr->wantarray() This returns the thread's context in the same manner as L. =head2 threads->wantarray() Class method to return the current thread's context. This returns the same value as running L inside the current thread's entry point function. =head1 THREAD STACK SIZE The default per-thread stack size for different platforms varies significantly, and is almost always far more than is needed for most applications. On Win32, Perl's makefile explicitly sets the default stack to 16 MB; on most other platforms, the system default is used, which again may be much larger than is needed. By tuning the stack size to more accurately reflect your application's needs, you may significantly reduce your application's memory usage, and increase the number of simultaneously running threads. Note that on Windows, address space allocation granularity is 64 KB, therefore, setting the stack smaller than that on Win32 Perl will not save any more memory. =over =item threads->get_stack_size(); Returns the current default per-thread stack size. The default is zero, which means the system default stack size is currently in use. =item $size = $thr->get_stack_size(); Returns the stack size for a particular thread. A return value of zero indicates the system default stack size was used for the thread. =item $old_size = threads->set_stack_size($new_size); Sets a new default per-thread stack size, and returns the previous setting. Some platforms have a minimum thread stack size. Trying to set the stack size below this value will result in a warning, and the minimum stack size will be used. Some Linux platforms have a maximum stack size. Setting too large of a stack size will cause thread creation to fail. If needed, C<$new_size> will be rounded up to the next multiple of the memory page size (usually 4096 or 8192). Threads created after the stack size is set will then either call C I<(for pthreads platforms)>, or supply the stack size to C I<(for Win32 Perl)>. (Obviously, this call does not affect any currently extant threads.) =item use threads ('stack_size' => VALUE); This sets the default per-thread stack size at the start of the application. =item $ENV{'PERL5_ITHREADS_STACK_SIZE'} The default per-thread stack size may be set at the start of the application through the use of the environment variable C: PERL5_ITHREADS_STACK_SIZE=1048576 export PERL5_ITHREADS_STACK_SIZE perl -e'use threads; print(threads->get_stack_size(), "\n")' This value overrides any C parameter given to C. Its primary purpose is to permit setting the per-thread stack size for legacy threaded applications. =item threads->create({'stack_size' => VALUE}, FUNCTION, ARGS) To specify a particular stack size for any individual thread, call C<-Ecreate()> with a hash reference as the first argument: my $thr = threads->create({'stack_size' => 32*4096}, \&foo, @args); =item $thr2 = $thr1->create(FUNCTION, ARGS) This creates a new thread (C<$thr2>) that inherits the stack size from an existing thread (C<$thr1>). This is shorthand for the following: my $stack_size = $thr1->get_stack_size(); my $thr2 = threads->create({'stack_size' => $stack_size}, FUNCTION, ARGS); =back =head1 THREAD SIGNALLING When safe signals is in effect (the default behavior - see L for more details), then signals may be sent and acted upon by individual threads. =over 4 =item $thr->kill('SIG...'); Sends the specified signal to the thread. Signal names and (positive) signal numbers are the same as those supported by L. For example, 'SIGTERM', 'TERM' and (depending on the OS) 15 are all valid arguments to C<-Ekill()>. Returns the thread object to allow for method chaining: $thr->kill('SIG...')->join(); =back Signal handlers need to be set up in the threads for the signals they are expected to act upon. Here's an example for I a thread: use threads; sub thr_func { # Thread 'cancellation' signal handler $SIG{'KILL'} = sub { threads->exit(); }; ... } # Create a thread my $thr = threads->create('thr_func'); ... # Signal the thread to terminate, and then detach # it so that it will get cleaned up automatically $thr->kill('KILL')->detach(); Here's another simplistic example that illustrates the use of thread signalling in conjunction with a semaphore to provide rudimentary I and I capabilities: use threads; use Thread::Semaphore; sub thr_func { my $sema = shift; # Thread 'suspend/resume' signal handler $SIG{'STOP'} = sub { $sema->down(); # Thread suspended $sema->up(); # Thread resumes }; ... } # Create a semaphore and pass it to a thread my $sema = Thread::Semaphore->new(); my $thr = threads->create('thr_func', $sema); # Suspend the thread $sema->down(); $thr->kill('STOP'); ... # Allow the thread to continue $sema->up(); CAVEAT: The thread signalling capability provided by this module does not actually send signals via the OS. It I signals at the Perl-level such that signal handlers are called in the appropriate thread. For example, sending C<$thr-Ekill('STOP')> does not actually suspend a thread (or the whole process), but does cause a C<$SIG{'STOP'}> handler to be called in that thread (as illustrated above). As such, signals that would normally not be appropriate to use in the C command (e.g., C) are okay to use with the C<-Ekill()> method (again, as illustrated above). Correspondingly, sending a signal to a thread does not disrupt the operation the thread is currently working on: The signal will be acted upon after the current operation has completed. For instance, if the thread is I on an I/O call, sending it a signal will not cause the I/O call to be interrupted such that the signal is acted up immediately. Sending a signal to a terminated thread is ignored. =head1 WARNINGS =over 4 =item Perl exited with active threads: If the program exits without all threads having either been joined or detached, then this warning will be issued. NOTE: If the I

thread exits, then this warning cannot be suppressed using C as suggested below. =item Thread creation failed: pthread_create returned # See the appropriate I page for C to determine the actual cause for the failure. =item Thread # terminated abnormally: ... A thread terminated in some manner other than just returning from its entry point function, or by using Cexit()>. For example, the thread may have terminated because of an error, or by using C. =item Using minimum thread stack size of # Some platforms have a minimum thread stack size. Trying to set the stack size below this value will result in the above warning, and the stack size will be set to the minimum. =item Thread creation failed: pthread_attr_setstacksize(I) returned 22 The specified I exceeds the system's maximum stack size. Use a smaller value for the stack size. =back If needed, thread warnings can be suppressed by using: no warnings 'threads'; in the appropriate scope. =head1 ERRORS =over 4 =item This Perl not built to support threads The particular copy of Perl that you're trying to use was not built using the C configuration option. Having threads support requires all of Perl and all of the XS modules in the Perl installation to be rebuilt; it is not just a question of adding the L module (i.e., threaded and non-threaded Perls are binary incompatible.) =item Cannot change stack size of an existing thread The stack size of currently extant threads cannot be changed, therefore, the following results in the above error: $thr->set_stack_size($size); =item Cannot signal threads without safe signals Safe signals must be in effect to use the C<-Ekill()> signalling method. See L for more details. =item Unrecognized signal name: ... The particular copy of Perl that you're trying to use does not support the specified signal being used in a C<-Ekill()> call. =back =head1 BUGS AND LIMITATIONS Before you consider posting a bug report, please consult, and possibly post a message to the discussion forum to see if what you've encountered is a known problem. =over =item Thread-safe modules See L when creating modules that may be used in threaded applications, especially if those modules use non-Perl data, or XS code. =item Using non-thread-safe modules Unfortunately, you may encounter Perl modules that are not I. For example, they may crash the Perl interpreter during execution, or may dump core on termination. Depending on the module and the requirements of your application, it may be possible to work around such difficulties. If the module will only be used inside a thread, you can try loading the module from inside the thread entry point function using C (and C if needed): sub thr_func { require Unsafe::Module # Unsafe::Module->import(...); .... } If the module is needed inside the I

thread, try modifying your application so that the module is loaded (again using C and C<-Eimport()>) after any threads are started, and in such a way that no other threads are started afterwards. If the above does not work, or is not adequate for your application, then file a bug report on L against the problematic module. =item Current working directory On all platforms except MSWin32, the setting for the current working directory is shared among all threads such that changing it in one thread (e.g., using C) will affect all the threads in the application. On MSWin32, each thread maintains its own the current working directory setting. =item Environment variables Currently, on all platforms except MSWin32, all I calls (e.g., using C or back-ticks) made from threads use the environment variable settings from the I

thread. In other words, changes made to C<%ENV> in a thread will not be visible in I calls made by that thread. To work around this, set environment variables as part of the I call. For example: my $msg = 'hello'; system("FOO=$msg; echo \$FOO"); # Outputs 'hello' to STDOUT On MSWin32, each thread maintains its own set of environment variables. =item Parent-child threads On some platforms, it might not be possible to destroy I threads while there are still existing I threads. =item Creating threads inside special blocks Creating threads inside C, C or C blocks should not be relied upon. Depending on the Perl version and the application code, results may range from success, to (apparently harmless) warnings of leaked scalar, or all the way up to crashing of the Perl interpreter. =item Unsafe signals Since Perl 5.8.0, signals have been made safer in Perl by postponing their handling until the interpreter is in a I state. See L and L for more details. Safe signals is the default behavior, and the old, immediate, unsafe signalling behavior is only in effect in the following situations: =over 4 =item * Perl has been built with C (see C). =item * The environment variable C is set to C (see L). =item * The module L is used. =back If unsafe signals is in effect, then signal handling is not thread-safe, and the C<-Ekill()> signalling method cannot be used. =item Returning closures from threads Returning closures from threads should not be relied upon. Depending of the Perl version and the application code, results may range from success, to (apparently harmless) warnings of leaked scalar, or all the way up to crashing of the Perl interpreter. =item Returning objects from threads Returning objects from threads does not work. Depending on the classes involved, you may be able to work around this by returning a serialized version of the object (e.g., using L or L), and then reconstituting it in the joining thread. If you're using Perl 5.10.0 or later, and if the class supports L, you can pass them via L. =item END blocks in threads It is possible to add L to threads by using L or L with the appropriate code. These C blocks will then be executed when the thread's interpreter is destroyed (i.e., either during a C<-Ejoin()> call, or at program termination). However, calling any L methods in such an C block will most likely I (e.g., the application may hang, or generate an error) due to mutexes that are needed to control functionality within the L module. For this reason, the use of C blocks in threads is B discouraged. =item Perl Bugs and the CPAN Version of L Support for threads extends beyond the code in this module (i.e., F and F), and into the Perl interpreter itself. Older versions of Perl contain bugs that may manifest themselves despite using the latest version of L from CPAN. There is no workaround for this other than upgrading to the latest version of Perl. Even with the latest version of Perl, it is known that certain constructs with threads may result in warning messages concerning leaked scalars or unreferenced scalars. However, such warnings are harmless, and may safely be ignored. You can search for L related bug reports at L. If needed submit any new bugs, problems, patches, etc. to: L =back =head1 REQUIREMENTS Perl 5.8.0 or later =head1 SEE ALSO L Discussion Forum on CPAN: L Annotated POD for L: L Source repository: L L, L L and L Perl threads mailing list: L Stack size discussion: L =head1 AUTHOR Artur Bergman Esky AT crucially DOT netE CPAN version produced by Jerry D. Hedden =head1 LICENSE threads is released under the same license as Perl. =head1 ACKNOWLEDGEMENTS Richard Soderberg Eperl AT crystalflame DOT netE - Helping me out tons, trying to find reasons for races and other weird bugs! Simon Cozens Esimon AT brecon DOT co DOT ukE - Being there to answer zillions of annoying questions Rocco Caputo Etroc AT netrus DOT netE Vipul Ved Prakash Email AT vipul DOT netE - Helping with debugging Dean Arnold Edarnold AT presicient DOT comE - Stack size API =cut PK��[[�>�� � 5.10.1/SDBM_File.pmnuW+A��
package SDBM_File; use strict; use warnings; require Tie::Hash; use XSLoader (); our @ISA = qw(Tie::Hash); our $VERSION = "1.06"; 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 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 with the Perl built-in C function to establish the connection between the variable and the file. The arguments to C 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 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 Read-only access to the data in the file. =item C Write-only access to the data in the file. =item C Both read and write access. =back If you want to create the file if it does not exist, add C to any of these, as in the example. If you omit C and the file does not already exist, the C 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.) =back =head1 DIAGNOSTICS On failure, the C call returns an undefined value and probably sets C<$!> to contain the reason the file could not be tied. =head2 C This warning is emitted 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, L, L =cut PK��[[�,{����5.10.1/Data/Dumper.pmnuW+A��
# # 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.124'; # Don't forget to set version and release date in POD! #$| = 1; use 5.006_001; require Exporter; require overload; use Carp; BEGIN { @ISA = qw(Exporter); @EXPORT = qw(Dumper); @EXPORT_OK = qw(DumperX); # if run under miniperl, or otherwise lacking dynamic loading, # XSLoader should be attempted to load, or the pure perl flag # toggled on load failure. eval { require XSLoader; }; $Useperl = 1 if $@; } XSLoader::load( 'Data::Dumper' ) unless $Useperl; # 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; $Pair = ' => ' unless defined $Pair; $Useperl = 0 unless defined $Useperl; $Sortkeys = 0 unless defined $Sortkeys; $Deparse = 0 unless defined $Deparse; # # 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($n) 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 pair => $Pair, # hash key/value separator: defaults to ' => ' 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 useperl => $Useperl, # use the pure Perl implementation sortkeys => $Sortkeys, # flag or filter for sorting hash keys deparse => $Deparse, # use B::Deparse for coderefs }; if ($Indent > 0) { $s->{xpad} = " "; $s->{sep} = "\n"; } return bless($s, $c); } if ($] >= 5.008) { # Packed numeric addresses take less memory. Plus pack is faster than sprintf *init_refaddr_format = sub {}; *format_refaddr = sub { require Scalar::Util; pack "J", Scalar::Util::refaddr(shift); }; } else { *init_refaddr_format = sub { require Config; my $f = $Config::Config{uvxformat}; $f =~ tr/"//d; our $refaddr_format = "0x%" . $f; }; *format_refaddr = sub { require Scalar::Util; sprintf our $refaddr_format, Scalar::Util::refaddr(shift); } } # # add-to or query the table of already seen references # sub Seen { my($s, $g) = @_; if (defined($g) && (ref($g) eq 'HASH')) { init_refaddr_format(); my($k, $v, $id); while (($k, $v) = each %$g) { if (defined $v and ref $v) { $id = format_refaddr($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::Useperl || (ref($_[0]) && $_[0]->{useperl}) || $Data::Dumper::Useqq || (ref($_[0]) && $_[0]->{useqq}) || $Data::Dumper::Deparse || (ref($_[0]) && $_[0]->{deparse}); 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); init_refaddr_format(); $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); } # wrap string in single quotes (escaping if needed) sub _quote { my $val = shift; $val =~ s/([\\\'])/\\$1/g; return "'" . $val . "'"; } # # twist, toil and turn; # and recurse, of course. # sometimes sordidly; # and curse if no recourse. # sub _dump { my($s, $val, $name) = @_; my($sname); my($out, $realpack, $realtype, $type, $ipad, $id, $blesspad); $type = ref $val; $out = ""; if ($type) { # Call the freezer method if it's specified and the object has the # method. Trap errors and warn() instead of die()ing, like the XS # implementation. my $freezer = $s->{freezer}; if ($freezer and UNIVERSAL::can($val, $freezer)) { eval { $val->$freezer() }; warn "WARNING(Freezer method call failed): $@" if $@; } require Scalar::Util; $realpack = Scalar::Util::blessed($val); $realtype = $realpack ? Scalar::Util::reftype($val) : ref $val; $id = format_refaddr($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 ]; } } my $no_bless = 0; my $is_regex = 0; if ( $realpack and ($] >= 5.009005 ? re::is_regexp($val) : $realpack eq 'Regexp') ) { $is_regex = 1; $no_bless = $realpack eq 'Regexp'; } # 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 and !$no_bless) { $out = $s->{'bless'} . '( '; $blesspad = $s->{apad}; $s->{apad} .= ' ' if ($s->{indent} >= 2); } $s->{level}++; $ipad = $s->{xpad} x $s->{level}; if ($is_regex) { my $pat; # This really sucks, re:regexp_pattern is in ext/re/re.xs and not in # universal.c, and even worse we cant just require that re to be loaded # we *have* to use() it. # We should probably move it to universal.c for 5.10.1 and fix this. # Currently we only use re::regexp_pattern when the re is blessed into another # package. This has the disadvantage of meaning that a DD dump won't round trip # as the pattern will be repeatedly wrapped with the same modifiers. # This is an aesthetic issue so we will leave it for now, but we could use # regexp_pattern() in list context to get the modifiers separately. # But since this means loading the full debugging engine in process we wont # bother unless its necessary for accuracy. if (($realpack ne 'Regexp') && defined(*re::regexp_pattern{CODE})) { $pat = re::regexp_pattern($val); } else { $pat = "$val"; } $pat =~ s,/,\\/,g; $out .= "qr/$pat/"; } elsif ($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, $pair); $out .= ($name =~ /^\%/) ? '(' : '{'; $pad = $s->{sep} . $s->{pad} . $s->{apad}; $lpad = $s->{apad}; $pair = $s->{pair}; ($name =~ /^\%(.*)$/) ? ($mname = "\$" . $1) : # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar} ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) : ($mname = $name . '->'); $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/; my ($sortkeys, $keys, $key) = ("$s->{sortkeys}"); if ($sortkeys) { if (ref($s->{sortkeys}) eq 'CODE') { $keys = $s->{sortkeys}($val); unless (ref($keys) eq 'ARRAY') { carp "Sortkeys subroutine did not return ARRAYREF"; $keys = []; } } else { $keys = [ sort keys %$val ]; } } # Ensure hash iterator is reset keys(%$val); while (($k, $v) = ! $sortkeys ? (each %$val) : @$keys ? ($key = shift(@$keys), $val->{$key}) : () ) { my $nk = $s->_dump($k, ""); $nk = $1 if !$s->{quotekeys} and $nk =~ /^[\"\']([A-Za-z_]\w*)[\"\']$/; $sname = $mname . '{' . $nk . '}'; $out .= $pad . $ipad . $nk . $pair; # 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') { if ($s->{deparse}) { require B::Deparse; my $sub = 'sub ' . (B::Deparse->new)->coderef2text($val); $pad = $s->{sep} . $s->{pad} . $s->{apad} . $s->{xpad} x ($s->{level} - 1); $sub =~ s/\n/$pad/gse; $out .= $sub; } else { $out .= 'sub { "DUMMY" }'; carp "Encountered CODE ref, using dummy placeholder" if $s->{purity}; } } else { croak "Can\'t handle $realtype type."; } if ($realpack and !$no_bless) { # we have a blessed ref $out .= ', ' . _quote($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 = format_refaddr($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})\z/) { # safe decimal number $out .= $val; } else { # string if ($s->{useqq} or $val =~ tr/\0-\377//c) { # Fall back to qq if there's Unicode $out .= qquote($val, $s->{useqq}); } else { $out .= _quote($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 Pair { my($s, $v) = @_; defined($v) ? (($s->{pair} = $v), return $s) : $s->{pair}; } 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'}; } sub Useperl { my($s, $v) = @_; defined($v) ? (($s->{'useperl'} = $v), return $s) : $s->{'useperl'}; } sub Sortkeys { my($s, $v) = @_; defined($v) ? (($s->{'sortkeys'} = $v), return $s) : $s->{'sortkeys'}; } sub Deparse { my($s, $v) = @_; defined($v) ? (($s->{'deparse'} = $v), return $s) : $s->{'deparse'}; } # 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; my $bytes; { use bytes; $bytes = length } s/([^\x00-\x7f])/'\x{'.sprintf("%x",ord($1)).'}'/ge if $bytes > length; 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; s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge; } } 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("$_"); } # helper sub to sort hash keys in Perl < 5.8.0 where we don't have # access to sortsv() from XS sub _sortkeys { [ sort keys %{$_[0]} ] } 1; __END__ =head1 NAME Data::Dumper - stringified perl data structures, suitable for both printing and C =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::Dumper::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 Ced 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 (where I is a numeric suffix), and other duplicate references to substructures within C<$VAR>I will be appropriately labeled using arrow notation. You can specify names for individual values to be dumped if you use the C 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 Ced, but the nested references to C<$VAR>I will be undefined, since a recursive structure cannot be constructed using one Perl statement. You should set the C flag to 1 to get additional statements that will correctly fill in these references. Moreover, if Ced when strictures are in effect, you need to ensure that any variables it accesses are previously declared. 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 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 flag. See L below for details. =head2 Methods =over 4 =item I->new(I, I) Returns a newly created C 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 I->Dump(I, I) Returns the stringified form of the values stored in the object (preserving the order in which they were supplied to C), 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 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 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 an anonymous hash of name => value pairs. Same rules apply for names as in C. 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) Returns the stringified form of the values in the list, subject to the configuration options below. The values will be named C<$VAR>I in the output, where I 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 Cized 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 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 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 I<$OBJ>->Purity(I<[NEWVAL]>) Controls the degree to which the output can be Ced 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 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 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 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 will run slower if this flag is set, since the fast XSUB implementation doesn't support it yet. =item * $Data::Dumper::Terse I 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 names will be avoided where possible, but be advised that such output may not always be parseable by C. =item * $Data::Dumper::Freezer I $I->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. If an object does not support the method specified (determined using UNIVERSAL::can()) then the call will be skipped. If the method dies a warning will be generated. =item * $Data::Dumper::Toaster I $I->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 CMETHOD()>. 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 $I->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 $I->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 $I->Bless(I<[NEWVAL]>) Can be set to a string that specifies an alternative to the C 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. =item * $Data::Dumper::Pair I $I->Pair(I<[NEWVAL]>) Can be set to a string that specifies the separator between hash keys and values. To dump nested hash, array and scalar values to JavaScript, use: C<$Data::Dumper::Pair = ' : ';>. Implementing C in JavaScript is left as an exercise for the reader. A function with the specified name exists, and accepts the same arguments as the builtin. Default is: C< =E >. =item * $Data::Dumper::Maxdepth I $I->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 is set. (Useful in debugger when we often don't want to see more than enough). Default is 0, which means there is no maximum depth. =item * $Data::Dumper::Useperl I $I->Useperl(I<[NEWVAL]>) Can be set to a boolean value which controls whether the pure Perl implementation of C is used. The C module is a dual implementation, with almost all functionality written in both pure Perl and also in XS ('C'). Since the XS version is much faster, it will always be used if possible. This option lets you override the default behavior, usually for testing purposes only. Default is 0, which means the XS implementation will be used if possible. =item * $Data::Dumper::Sortkeys I $I->Sortkeys(I<[NEWVAL]>) Can be set to a boolean value to control whether hash keys are dumped in sorted order. A true value will cause the keys of all hashes to be dumped in Perl's default sort order. Can also be set to a subroutine reference which will be called for each hash that is dumped. In this case C will call the subroutine once for each hash, passing it the reference of the hash. The purpose of the subroutine is to return a reference to an array of the keys that will be dumped, in the order that they should be dumped. Using this feature, you can control both the order of the keys, and which keys are actually used. In other words, this subroutine acts as a filter by which you can exclude certain keys from being dumped. Default is 0, which means that hash keys are not sorted. =item * $Data::Dumper::Deparse I $I->Deparse(I<[NEWVAL]>) Can be set to a boolean value to control whether code references are turned into perl source code. If set to a true value, C will be used to get the source of the code reference. Using this option will force using the Perl implementation of the dumper, since the fast XSUB implementation doesn't support it. Caution : use this option only if you know that your coderefs will be properly reconstructed by C. =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); $Data::Dumper::Pair = " : "; # specify hash key/value separator 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; ######## # sorting and filtering hash keys ######## $Data::Dumper::Sortkeys = \&my_filter; my $foo = { map { (ord, "$_$_$_") } 'I'..'Q' }; my $bar = { %$foo }; my $baz = { reverse %$foo }; print Dumper [ $foo, $bar, $baz ]; sub my_filter { my ($hash) = @_; # return an array ref containing the hash keys to dump # in the order that you want them to be dumped return [ # Sort the keys of %$foo in reverse numeric order $hash eq $foo ? (sort {$b <=> $a} keys %$hash) : # Only dump the odd number keys of %$bar $hash eq $bar ? (grep {$_ % 2} keys %$hash) : # Sort keys in default order for all other hashes (sort keys %$hash) ]; } =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, now that Perl has subroutine prototypes. 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 cheats with CODE references. If a code reference is encountered in the structure being processed (and if you haven't set the C flag), an anonymous subroutine that contains the string '"DUMMY"' will be inserted in its place, and a warning will be printed if C is set. You can C 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 method to pre-seed the internal reference table and make the dumped output point to them, instead. See L above. The C and C flags makes Dump() run slower, since the XSUB implementation does not support them. SCALAR objects have the weirdest looking C workaround. Pure Perl version of C escapes UTF-8 strings correctly only in Perl 5.8.0 and later. =head2 NOTE Starting from Perl 5.8.1 different runs of Perl will have different ordering of hash keys. The change was done for greater security, see L. This means that different runs of Perl will have different Data::Dumper outputs if the data contains hashes. If you need to have identical Data::Dumper outputs from different runs of Perl, use the environment variable PERL_HASH_SEED, see L. Using this restores the old (platform-specific) ordering: an even prettier solution might be to use the C filter of Data::Dumper. =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.124 (Jun 13 2009) =head1 SEE ALSO perl(1) =cut PK��[[�+���5.10.1/Scalar/Util.pmnuW+A��
# Scalar::Util.pm # # Copyright (c) 1997-2007 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. package Scalar::Util; use strict; use vars qw(@ISA @EXPORT_OK $VERSION @EXPORT_FAIL); require Exporter; require List::Util; # List::Util loads the XS @ISA = qw(Exporter); @EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype); $VERSION = "1.21"; $VERSION = eval $VERSION; unless (defined &dualvar) { # Load Pure Perl version if XS not loaded require Scalar::Util::PP; Scalar::Util::PP->import; push @EXPORT_FAIL, qw(weaken isweak dualvar isvstring set_prototype); } sub export_fail { if (grep { /dualvar/ } @EXPORT_FAIL) { # no XS loaded my $pat = join("|", @EXPORT_FAIL); if (my ($err) = grep { /^($pat)$/ } @_ ) { require Carp; Carp::croak("$err is only available with the XS version of Scalar::Util"); } } if (grep { /^(weaken|isweak)$/ } @_ ) { require Carp; Carp::croak("Weak references are not implemented in the version of perl"); } if (grep { /^(isvstring)$/ } @_ ) { require Carp; Carp::croak("Vstrings are not implemented in the version of perl"); } @_; } sub openhandle ($) { my $fh = shift; my $rt = reftype($fh) || ''; return defined(fileno($fh)) ? $fh : undef if $rt eq 'IO'; if (reftype(\$fh) eq 'GLOB') { # handle openhandle(*DATA) $fh = \(my $tmp=$fh); } elsif ($rt ne 'GLOB') { return undef; } (tied(*$fh) or defined(fileno($fh))) ? $fh : undef; } 1; __END__ PK��[[�Q����5.10.1/Scalar/Util/PP.pmnuW+A��
# Scalar::Util::PP.pm # # Copyright (c) 1997-2009 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. # # This module is normally only loaded if the XS module is not available package Scalar::Util::PP; use strict; use warnings; use vars qw(@ISA @EXPORT $VERSION $recurse); require Exporter; use B qw(svref_2object); @ISA = qw(Exporter); @EXPORT = qw(blessed reftype tainted readonly refaddr looks_like_number); $VERSION = "1.21"; $VERSION = eval $VERSION; sub blessed ($) { return undef unless length(ref($_[0])); my $b = svref_2object($_[0]); return undef unless $b->isa('B::PVMG'); my $s = $b->SvSTASH; return $s->isa('B::HV') ? $s->NAME : undef; } sub refaddr($) { return undef unless length(ref($_[0])); my $addr; if(defined(my $pkg = blessed($_[0]))) { $addr .= bless $_[0], 'Scalar::Util::Fake'; bless $_[0], $pkg; } else { $addr .= $_[0] } $addr =~ /0x(\w+)/; local $^W; hex($1); } { my %tmap = qw( B::HV HASH B::AV ARRAY B::CV CODE B::IO IO B::NULL SCALAR B::NV SCALAR B::PV SCALAR B::GV GLOB B::RV REF B::REGEXP REGEXP ); sub reftype ($) { my $r = shift; return undef unless length(ref($r)); my $t = ref(svref_2object($r)); return exists $tmap{$t} ? $tmap{$t} : length(ref($$r)) ? 'REF' : 'SCALAR'; } } sub tainted { local($@, $SIG{__DIE__}, $SIG{__WARN__}); local $^W = 0; no warnings; eval { kill 0 * $_[0] }; $@ =~ /^Insecure/; } sub readonly { return 0 if tied($_[0]) || (ref(\($_[0])) ne "SCALAR"); local($@, $SIG{__DIE__}, $SIG{__WARN__}); my $tmp = $_[0]; !eval { $_[0] = $tmp; 1 }; } sub looks_like_number { local $_ = shift; # checks from perlfaq4 return 0 if !defined($_); if (ref($_)) { require overload; return overload::Overloaded($_) ? defined(0 + $_) : 0; } return 1 if (/^[+-]?\d+$/); # is a +/- integer return 1 if (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/); # a C float return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i); 0; } 1; PK��[[rQº�5.10.1/asm-generic/termios.phnuW+A��
require '_h2ph_pre.ph'; no warnings qw(redefine misc); unless(defined(&_ASM_GENERIC_TERMIOS_H)) { eval 'sub _ASM_GENERIC_TERMIOS_H () {1;}' unless defined(&_ASM_GENERIC_TERMIOS_H); require 'asm/termbits.ph'; require 'asm/ioctls.ph'; eval 'sub NCC () {8;}' unless defined(&NCC); eval 'sub TIOCM_LE () {0x1;}' unless defined(&TIOCM_LE); eval 'sub TIOCM_DTR () {0x2;}' unless defined(&TIOCM_DTR); eval 'sub TIOCM_RTS () {0x4;}' unless defined(&TIOCM_RTS); eval 'sub TIOCM_ST () {0x8;}' unless defined(&TIOCM_ST); eval 'sub TIOCM_SR () {0x10;}' unless defined(&TIOCM_SR); eval 'sub TIOCM_CTS () {0x20;}' unless defined(&TIOCM_CTS); eval 'sub TIOCM_CAR () {0x40;}' unless defined(&TIOCM_CAR); eval 'sub TIOCM_RNG () {0x80;}' unless defined(&TIOCM_RNG); eval 'sub TIOCM_DSR () {0x100;}' unless defined(&TIOCM_DSR); eval 'sub TIOCM_CD () { &TIOCM_CAR;}' unless defined(&TIOCM_CD); eval 'sub TIOCM_RI () { &TIOCM_RNG;}' unless defined(&TIOCM_RI); eval 'sub TIOCM_OUT1 () {0x2000;}' unless defined(&TIOCM_OUT1); eval 'sub TIOCM_OUT2 () {0x4000;}' unless defined(&TIOCM_OUT2); eval 'sub TIOCM_LOOP () {0x8000;}' unless defined(&TIOCM_LOOP); } 1; PK��[[q,�{��5.10.1/asm-generic/sockios.phnuW+A��
require '_h2ph_pre.ph'; no warnings qw(redefine misc); unless(defined(&__ASM_GENERIC_SOCKIOS_H)) { eval 'sub __ASM_GENERIC_SOCKIOS_H () {1;}' unless defined(&__ASM_GENERIC_SOCKIOS_H); eval 'sub FIOSETOWN () {0x8901;}' unless defined(&FIOSETOWN); eval 'sub SIOCSPGRP () {0x8902;}' unless defined(&SIOCSPGRP); eval 'sub FIOGETOWN () {0x8903;}' unless defined(&FIOGETOWN); eval 'sub SIOCGPGRP () {0x8904;}' unless defined(&SIOCGPGRP); eval 'sub SIOCATMARK () {0x8905;}' unless defined(&SIOCATMARK); eval 'sub SIOCGSTAMP () {0x8906;}' unless defined(&SIOCGSTAMP); eval 'sub SIOCGSTAMPNS () {0x8907;}' unless defined(&SIOCGSTAMPNS); } 1; PK��[[N�.'��5.10.1/asm-generic/socket.phnuW+A��
require '_h2ph_pre.ph'; no warnings qw(redefine misc); unless(defined(&__ASM_GENERIC_SOCKET_H)) { eval 'sub __ASM_GENERIC_SOCKET_H () {1;}' unless defined(&__ASM_GENERIC_SOCKET_H); require 'asm/sockios.ph'; eval 'sub SOL_SOCKET () {1;}' unless defined(&SOL_SOCKET); eval 'sub SO_DEBUG () {1;}' unless defined(&SO_DEBUG); eval 'sub SO_REUSEADDR () {2;}' unless defined(&SO_REUSEADDR); eval 'sub SO_TYPE () {3;}' unless defined(&SO_TYPE); eval 'sub SO_ERROR () {4;}' unless defined(&SO_ERROR); eval 'sub SO_DONTROUTE () {5;}' unless defined(&SO_DONTROUTE); eval 'sub SO_BROADCAST () {6;}' unless defined(&SO_BROADCAST); eval 'sub SO_SNDBUF () {7;}' unless defined(&SO_SNDBUF); eval 'sub SO_RCVBUF () {8;}' unless defined(&SO_RCVBUF); eval 'sub SO_SNDBUFFORCE () {32;}' unless defined(&SO_SNDBUFFORCE); eval 'sub SO_RCVBUFFORCE () {33;}' unless defined(&SO_RCVBUFFORCE); eval 'sub SO_KEEPALIVE () {9;}' unless defined(&SO_KEEPALIVE); eval 'sub SO_OOBINLINE () {10;}' unless defined(&SO_OOBINLINE); eval 'sub SO_NO_CHECK () {11;}' unless defined(&SO_NO_CHECK); eval 'sub SO_PRIORITY () {12;}' unless defined(&SO_PRIORITY); eval 'sub SO_LINGER () {13;}' unless defined(&SO_LINGER); eval 'sub SO_BSDCOMPAT () {14;}' unless defined(&SO_BSDCOMPAT); unless(defined(&SO_PASSCRED)) { eval 'sub SO_PASSCRED () {16;}' unless defined(&SO_PASSCRED); eval 'sub SO_PEERCRED () {17;}' unless defined(&SO_PEERCRED); eval 'sub SO_RCVLOWAT () {18;}' unless defined(&SO_RCVLOWAT); eval 'sub SO_SNDLOWAT () {19;}' unless defined(&SO_SNDLOWAT); eval 'sub SO_RCVTIMEO () {20;}' unless defined(&SO_RCVTIMEO); eval 'sub SO_SNDTIMEO () {21;}' unless defined(&SO_SNDTIMEO); } eval 'sub SO_SECURITY_AUTHENTICATION () {22;}' unless defined(&SO_SECURITY_AUTHENTICATION); eval 'sub SO_SECURITY_ENCRYPTION_TRANSPORT () {23;}' unless defined(&SO_SECURITY_ENCRYPTION_TRANSPORT); eval 'sub SO_SECURITY_ENCRYPTION_NETWORK () {24;}' unless defined(&SO_SECURITY_ENCRYPTION_NETWORK); eval 'sub SO_BINDTODEVICE () {25;}' unless defined(&SO_BINDTODEVICE); eval 'sub SO_ATTACH_FILTER () {26;}' unless defined(&SO_ATTACH_FILTER); eval 'sub SO_DETACH_FILTER () {27;}' unless defined(&SO_DETACH_FILTER); eval 'sub SO_PEERNAME () {28;}' unless defined(&SO_PEERNAME); eval 'sub SO_TIMESTAMP () {29;}' unless defined(&SO_TIMESTAMP); eval 'sub SCM_TIMESTAMP () { &SO_TIMESTAMP;}' unless defined(&SCM_TIMESTAMP); eval 'sub SO_ACCEPTCONN () {30;}' unless defined(&SO_ACCEPTCONN); eval 'sub SO_PEERSEC () {31;}' unless defined(&SO_PEERSEC); eval 'sub SO_PASSSEC () {34;}' unless defined(&SO_PASSSEC); eval 'sub SO_TIMESTAMPNS () {35;}' unless defined(&SO_TIMESTAMPNS); eval 'sub SCM_TIMESTAMPNS () { &SO_TIMESTAMPNS;}' unless defined(&SCM_TIMESTAMPNS); eval 'sub SO_MARK () {36;}' unless defined(&SO_MARK); eval 'sub SO_TIMESTAMPING () {37;}' unless defined(&SO_TIMESTAMPING); eval 'sub SCM_TIMESTAMPING () { &SO_TIMESTAMPING;}' unless defined(&SCM_TIMESTAMPING); eval 'sub SO_PROTOCOL () {38;}' unless defined(&SO_PROTOCOL); eval 'sub SO_DOMAIN () {39;}' unless defined(&SO_DOMAIN); } 1; PK��[[���I��5.10.1/asm-generic/ioctls.phnuW+A��
require '_h2ph_pre.ph'; no warnings qw(redefine misc); unless(defined(&__ASM_GENERIC_IOCTLS_H)) { eval 'sub __ASM_GENERIC_IOCTLS_H () {1;}' unless defined(&__ASM_GENERIC_IOCTLS_H); require 'linux/ioctl.ph'; eval 'sub TCGETS () {0x5401;}' unless defined(&TCGETS); eval 'sub TCSETS () {0x5402;}' unless defined(&TCSETS); eval 'sub TCSETSW () {0x5403;}' unless defined(&TCSETSW); eval 'sub TCSETSF () {0x5404;}' unless defined(&TCSETSF); eval 'sub TCGETA () {0x5405;}' unless defined(&TCGETA); eval 'sub TCSETA () {0x5406;}' unless defined(&TCSETA); eval 'sub TCSETAW () {0x5407;}' unless defined(&TCSETAW); eval 'sub TCSETAF () {0x5408;}' unless defined(&TCSETAF); eval 'sub TCSBRK () {0x5409;}' unless defined(&TCSBRK); eval 'sub TCXONC () {0x540a;}' unless defined(&TCXONC); eval 'sub TCFLSH () {0x540b;}' unless defined(&TCFLSH); eval 'sub TIOCEXCL () {0x540c;}' unless defined(&TIOCEXCL); eval 'sub TIOCNXCL () {0x540d;}' unless defined(&TIOCNXCL); eval 'sub TIOCSCTTY () {0x540e;}' unless defined(&TIOCSCTTY); eval 'sub TIOCGPGRP () {0x540f;}' unless defined(&TIOCGPGRP); eval 'sub TIOCSPGRP () {0x5410;}' unless defined(&TIOCSPGRP); eval 'sub TIOCOUTQ () {0x5411;}' unless defined(&TIOCOUTQ); eval 'sub TIOCSTI () {0x5412;}' unless defined(&TIOCSTI); eval 'sub TIOCGWINSZ () {0x5413;}' unless defined(&TIOCGWINSZ); eval 'sub TIOCSWINSZ () {0x5414;}' unless defined(&TIOCSWINSZ); eval 'sub TIOCMGET () {0x5415;}' unless defined(&TIOCMGET); eval 'sub TIOCMBIS () {0x5416;}' unless defined(&TIOCMBIS); eval 'sub TIOCMBIC () {0x5417;}' unless defined(&TIOCMBIC); eval 'sub TIOCMSET () {0x5418;}' unless defined(&TIOCMSET); eval 'sub TIOCGSOFTCAR () {0x5419;}' unless defined(&TIOCGSOFTCAR); eval 'sub TIOCSSOFTCAR () {0x541a;}' unless defined(&TIOCSSOFTCAR); eval 'sub FIONREAD () {0x541b;}' unless defined(&FIONREAD); eval 'sub TIOCINQ () { &FIONREAD;}' unless defined(&TIOCINQ); eval 'sub TIOCLINUX () {0x541c;}' unless defined(&TIOCLINUX); eval 'sub TIOCCONS () {0x541d;}' unless defined(&TIOCCONS); eval 'sub TIOCGSERIAL () {0x541e;}' unless defined(&TIOCGSERIAL); eval 'sub TIOCSSERIAL () {0x541f;}' unless defined(&TIOCSSERIAL); eval 'sub TIOCPKT () {0x5420;}' unless defined(&TIOCPKT); eval 'sub FIONBIO () {0x5421;}' unless defined(&FIONBIO); eval 'sub TIOCNOTTY () {0x5422;}' unless defined(&TIOCNOTTY); eval 'sub TIOCSETD () {0x5423;}' unless defined(&TIOCSETD); eval 'sub TIOCGETD () {0x5424;}' unless defined(&TIOCGETD); eval 'sub TCSBRKP () {0x5425;}' unless defined(&TCSBRKP); eval 'sub TIOCSBRK () {0x5427;}' unless defined(&TIOCSBRK); eval 'sub TIOCCBRK () {0x5428;}' unless defined(&TIOCCBRK); eval 'sub TIOCGSID () {0x5429;}' unless defined(&TIOCGSID); eval 'sub TCGETS2 () { &_IOR(ord(\'T\'), 0x2a, 1;}' unless defined(&TCGETS2); eval 'sub TCSETS2 () { &_IOW(ord(\'T\'), 0x2b, 1;}' unless defined(&TCSETS2); eval 'sub TCSETSW2 () { &_IOW(ord(\'T\'), 0x2c, 1;}' unless defined(&TCSETSW2); eval 'sub TCSETSF2 () { &_IOW(ord(\'T\'), 0x2d, 1;}' unless defined(&TCSETSF2); eval 'sub TIOCGRS485 () {0x542e;}' unless defined(&TIOCGRS485); eval 'sub TIOCSRS485 () {0x542f;}' unless defined(&TIOCSRS485); eval 'sub TIOCGPTN () { &_IOR(ord(\'T\'), 0x30, \'unsigned int\');}' unless defined(&TIOCGPTN); eval 'sub TIOCSPTLCK () { &_IOW(ord(\'T\'), 0x31, \'int\');}' unless defined(&TIOCSPTLCK); eval 'sub TCGETX () {0x5432;}' unless defined(&TCGETX); eval 'sub TCSETX () {0x5433;}' unless defined(&TCSETX); eval 'sub TCSETXF () {0x5434;}' unless defined(&TCSETXF); eval 'sub TCSETXW () {0x5435;}' unless defined(&TCSETXW); eval 'sub FIONCLEX () {0x5450;}' unless defined(&FIONCLEX); eval 'sub FIOCLEX () {0x5451;}' unless defined(&FIOCLEX); eval 'sub FIOASYNC () {0x5452;}' unless defined(&FIOASYNC); eval 'sub TIOCSERCONFIG () {0x5453;}' unless defined(&TIOCSERCONFIG); eval 'sub TIOCSERGWILD () {0x5454;}' unless defined(&TIOCSERGWILD); eval 'sub TIOCSERSWILD () {0x5455;}' unless defined(&TIOCSERSWILD); eval 'sub TIOCGLCKTRMIOS () {0x5456;}' unless defined(&TIOCGLCKTRMIOS); eval 'sub TIOCSLCKTRMIOS () {0x5457;}' unless defined(&TIOCSLCKTRMIOS); eval 'sub TIOCSERGSTRUCT () {0x5458;}' unless defined(&TIOCSERGSTRUCT); eval 'sub TIOCSERGETLSR () {0x5459;}' unless defined(&TIOCSERGETLSR); eval 'sub TIOCSERGETMULTI () {0x545a;}' unless defined(&TIOCSERGETMULTI); eval 'sub TIOCSERSETMULTI () {0x545b;}' unless defined(&TIOCSERSETMULTI); eval 'sub TIOCMIWAIT () {0x545c;}' unless defined(&TIOCMIWAIT); eval 'sub TIOCGICOUNT () {0x545d;}' unless defined(&TIOCGICOUNT); unless(defined(&FIOQSIZE)) { eval 'sub TIOCGHAYESESP () {0x545e;}' unless defined(&TIOCGHAYESESP); eval 'sub TIOCSHAYESESP () {0x545f;}' unless defined(&TIOCSHAYESESP); eval 'sub FIOQSIZE () {0x5460;}' unless defined(&FIOQSIZE); } eval 'sub TIOCPKT_DATA () {0;}' unless defined(&TIOCPKT_DATA); eval 'sub TIOCPKT_FLUSHREAD () {1;}' unless defined(&TIOCPKT_FLUSHREAD); eval 'sub TIOCPKT_FLUSHWRITE () {2;}' unless defined(&TIOCPKT_FLUSHWRITE); eval 'sub TIOCPKT_STOP () {4;}' unless defined(&TIOCPKT_STOP); eval 'sub TIOCPKT_START () {8;}' unless defined(&TIOCPKT_START); eval 'sub TIOCPKT_NOSTOP () {16;}' unless defined(&TIOCPKT_NOSTOP); eval 'sub TIOCPKT_DOSTOP () {32;}' unless defined(&TIOCPKT_DOSTOP); eval 'sub TIOCSER_TEMT () {0x1;}' unless defined(&TIOCSER_TEMT); } 1; PK��[[�+��5.10.1/asm-generic/ioctl.phnuW+A��
require '_h2ph_pre.ph'; no warnings qw(redefine misc); unless(defined(&_ASM_GENERIC_IOCTL_H)) { eval 'sub _ASM_GENERIC_IOCTL_H () {1;}' unless defined(&_ASM_GENERIC_IOCTL_H); eval 'sub _IOC_NRBITS () {8;}' unless defined(&_IOC_NRBITS); eval 'sub _IOC_TYPEBITS () {8;}' unless defined(&_IOC_TYPEBITS); unless(defined(&_IOC_SIZEBITS)) { eval 'sub _IOC_SIZEBITS () {14;}' unless defined(&_IOC_SIZEBITS); } unless(defined(&_IOC_DIRBITS)) { eval 'sub _IOC_DIRBITS () {2;}' unless defined(&_IOC_DIRBITS); } eval 'sub _IOC_NRMASK () {((1<< &_IOC_NRBITS)-1);}' unless defined(&_IOC_NRMASK); eval 'sub _IOC_TYPEMASK () {((1<< &_IOC_TYPEBITS)-1);}' unless defined(&_IOC_TYPEMASK); eval 'sub _IOC_SIZEMASK () {((1<< &_IOC_SIZEBITS)-1);}' unless defined(&_IOC_SIZEMASK); eval 'sub _IOC_DIRMASK () {((1<< &_IOC_DIRBITS)-1);}' unless defined(&_IOC_DIRMASK); eval 'sub _IOC_NRSHIFT () {0;}' unless defined(&_IOC_NRSHIFT); eval 'sub _IOC_TYPESHIFT () {( &_IOC_NRSHIFT+ &_IOC_NRBITS);}' unless defined(&_IOC_TYPESHIFT); eval 'sub _IOC_SIZESHIFT () {( &_IOC_TYPESHIFT+ &_IOC_TYPEBITS);}' unless defined(&_IOC_SIZESHIFT); eval 'sub _IOC_DIRSHIFT () {( &_IOC_SIZESHIFT+ &_IOC_SIZEBITS);}' unless defined(&_IOC_DIRSHIFT); unless(defined(&_IOC_NONE)) { eval 'sub _IOC_NONE () {0;}' unless defined(&_IOC_NONE); } unless(defined(&_IOC_WRITE)) { eval 'sub _IOC_WRITE () {1;}' unless defined(&_IOC_WRITE); } unless(defined(&_IOC_READ)) { eval 'sub _IOC_READ () {2;}' unless defined(&_IOC_READ); } eval 'sub _IOC { my($dir,$type,$nr,$size) = @_; eval q(((($dir) << &_IOC_DIRSHIFT) | (($type) << &_IOC_TYPESHIFT) | (($nr) << &_IOC_NRSHIFT) | (($size) << &_IOC_SIZESHIFT))); }' unless defined(&_IOC); eval 'sub _IOC_TYPECHECK { my($t) = @_; eval q(($sizeof{$t})); }' unless defined(&_IOC_TYPECHECK); eval 'sub _IO { my($type,$nr) = @_; eval q( &_IOC( &_IOC_NONE,($type),($nr),0)); }' unless defined(&_IO); eval 'sub _IOR { my($type,$nr,$size) = @_; eval q( &_IOC( &_IOC_READ,($type),($nr),( &_IOC_TYPECHECK($size)))); }' unless defined(&_IOR); eval 'sub _IOW { my($type,$nr,$size) = @_; eval q( &_IOC( &_IOC_WRITE,($type),($nr),( &_IOC_TYPECHECK($size)))); }' unless defined(&_IOW); eval 'sub _IOWR { my($type,$nr,$size) = @_; eval q( &_IOC( &_IOC_READ| &_IOC_WRITE,($type),($nr),( &_IOC_TYPECHECK($size)))); }' unless defined(&_IOWR); eval 'sub _IOR_BAD { my($type,$nr,$size) = @_; eval q( &_IOC( &_IOC_READ,($type),($nr),$sizeof{$size})); }' unless defined(&_IOR_BAD); eval 'sub _IOW_BAD { my($type,$nr,$size) = @_; eval q( &_IOC( &_IOC_WRITE,($type),($nr),$sizeof{$size})); }' unless defined(&_IOW_BAD); eval 'sub _IOWR_BAD { my($type,$nr,$size) = @_; eval q( &_IOC( &_IOC_READ| &_IOC_WRITE,($type),($nr),$sizeof{$size})); }' unless defined(&_IOWR_BAD); eval 'sub _IOC_DIR { my($nr) = @_; eval q(((($nr) >> &_IOC_DIRSHIFT) & &_IOC_DIRMASK)); }' unless defined(&_IOC_DIR); eval 'sub _IOC_TYPE { my($nr) = @_; eval q(((($nr) >> &_IOC_TYPESHIFT) & &_IOC_TYPEMASK)); }' unless defined(&_IOC_TYPE); eval 'sub _IOC_NR { my($nr) = @_; eval q(((($nr) >> &_IOC_NRSHIFT) & &_IOC_NRMASK)); }' unless defined(&_IOC_NR); eval 'sub _IOC_SIZE { my($nr) = @_; eval q(((($nr) >> &_IOC_SIZESHIFT) & &_IOC_SIZEMASK)); }' unless defined(&_IOC_SIZE); eval 'sub IOC_IN () {( &_IOC_WRITE << &_IOC_DIRSHIFT);}' unless defined(&IOC_IN); eval 'sub IOC_OUT () {( &_IOC_READ << &_IOC_DIRSHIFT);}' unless defined(&IOC_OUT); eval 'sub IOC_INOUT () {(( &_IOC_WRITE| &_IOC_READ) << &_IOC_DIRSHIFT);}' unless defined(&IOC_INOUT); eval 'sub IOCSIZE_MASK () {( &_IOC_SIZEMASK << &_IOC_SIZESHIFT);}' unless defined(&IOCSIZE_MASK); eval 'sub IOCSIZE_SHIFT () {( &_IOC_SIZESHIFT);}' unless defined(&IOCSIZE_SHIFT); } 1; PK��[[!��� � 5.10.1/asm-generic/termbits.phnuW+A��
require '_h2ph_pre.ph'; no warnings qw(redefine misc); unless(defined(&__ASM_GENERIC_TERMBITS_H)) { eval 'sub __ASM_GENERIC_TERMBITS_H () {1;}' unless defined(&__ASM_GENERIC_TERMBITS_H); require 'linux/posix_types.ph'; eval 'sub NCCS () {19;}' unless defined(&NCCS); eval 'sub VINTR () {0;}' unless defined(&VINTR); eval 'sub VQUIT () {1;}' unless defined(&VQUIT); eval 'sub VERASE () {2;}' unless defined(&VERASE); eval 'sub VKILL () {3;}' unless defined(&VKILL); eval 'sub VEOF () {4;}' unless defined(&VEOF); eval 'sub VTIME () {5;}' unless defined(&VTIME); eval 'sub VMIN () {6;}' unless defined(&VMIN); eval 'sub VSWTC () {7;}' unless defined(&VSWTC); eval 'sub VSTART () {8;}' unless defined(&VSTART); eval 'sub VSTOP () {9;}' unless defined(&VSTOP); eval 'sub VSUSP () {10;}' unless defined(&VSUSP); eval 'sub VEOL () {11;}' unless defined(&VEOL); eval 'sub VREPRINT () {12;}' unless defined(&VREPRINT); eval 'sub VDISCARD () {13;}' unless defined(&VDISCARD); eval 'sub VWERASE () {14;}' unless defined(&VWERASE); eval 'sub VLNEXT () {15;}' unless defined(&VLNEXT); eval 'sub VEOL2 () {16;}' unless defined(&VEOL2); eval 'sub IGNBRK () {0000001;}' unless defined(&IGNBRK); eval 'sub BRKINT () {0000002;}' unless defined(&BRKINT); eval 'sub IGNPAR () {0000004;}' unless defined(&IGNPAR); eval 'sub PARMRK () {0000010;}' unless defined(&PARMRK); eval 'sub INPCK () {0000020;}' unless defined(&INPCK); eval 'sub ISTRIP () {0000040;}' unless defined(&ISTRIP); eval 'sub INLCR () {0000100;}' unless defined(&INLCR); eval 'sub IGNCR () {0000200;}' unless defined(&IGNCR); eval 'sub ICRNL () {0000400;}' unless defined(&ICRNL); eval 'sub IUCLC () {0001000;}' unless defined(&IUCLC); eval 'sub IXON () {0002000;}' unless defined(&IXON); eval 'sub IXANY () {0004000;}' unless defined(&IXANY); eval 'sub IXOFF () {0010000;}' unless defined(&IXOFF); eval 'sub IMAXBEL () {0020000;}' unless defined(&IMAXBEL); eval 'sub IUTF8 () {0040000;}' unless defined(&IUTF8); eval 'sub OPOST () {0000001;}' unless defined(&OPOST); eval 'sub OLCUC () {0000002;}' unless defined(&OLCUC); eval 'sub ONLCR () {0000004;}' unless defined(&ONLCR); eval 'sub OCRNL () {0000010;}' unless defined(&OCRNL); eval 'sub ONOCR () {0000020;}' unless defined(&ONOCR); eval 'sub ONLRET () {0000040;}' unless defined(&ONLRET); eval 'sub OFILL () {0000100;}' unless defined(&OFILL); eval 'sub OFDEL () {0000200;}' unless defined(&OFDEL); eval 'sub NLDLY () {0000400;}' unless defined(&NLDLY); eval 'sub NL0 () {0000000;}' unless defined(&NL0); eval 'sub NL1 () {0000400;}' unless defined(&NL1); eval 'sub CRDLY () {0003000;}' unless defined(&CRDLY); eval 'sub CR0 () {0000000;}' unless defined(&CR0); eval 'sub CR1 () {0001000;}' unless defined(&CR1); eval 'sub CR2 () {0002000;}' unless defined(&CR2); eval 'sub CR3 () {0003000;}' unless defined(&CR3); eval 'sub TABDLY () {0014000;}' unless defined(&TABDLY); eval 'sub TAB0 () {0000000;}' unless defined(&TAB0); eval 'sub TAB1 () {0004000;}' unless defined(&TAB1); eval 'sub TAB2 () {0010000;}' unless defined(&TAB2); eval 'sub TAB3 () {0014000;}' unless defined(&TAB3); eval 'sub XTABS () {0014000;}' unless defined(&XTABS); eval 'sub BSDLY () {0020000;}' unless defined(&BSDLY); eval 'sub BS0 () {0000000;}' unless defined(&BS0); eval 'sub BS1 () {0020000;}' unless defined(&BS1); eval 'sub VTDLY () {0040000;}' unless defined(&VTDLY); eval 'sub VT0 () {0000000;}' unless defined(&VT0); eval 'sub VT1 () {0040000;}' unless defined(&VT1); eval 'sub FFDLY () {0100000;}' unless defined(&FFDLY); eval 'sub FF0 () {0000000;}' unless defined(&FF0); eval 'sub FF1 () {0100000;}' unless defined(&FF1); eval 'sub CBAUD () {0010017;}' unless defined(&CBAUD); eval 'sub B0 () {0000000;}' unless defined(&B0); eval 'sub B50 () {0000001;}' unless defined(&B50); eval 'sub B75 () {0000002;}' unless defined(&B75); eval 'sub B110 () {0000003;}' unless defined(&B110); eval 'sub B134 () {0000004;}' unless defined(&B134); eval 'sub B150 () {0000005;}' unless defined(&B150); eval 'sub B200 () {0000006;}' unless defined(&B200); eval 'sub B300 () {0000007;}' unless defined(&B300); eval 'sub B600 () {0000010;}' unless defined(&B600); eval 'sub B1200 () {0000011;}' unless defined(&B1200); eval 'sub B1800 () {0000012;}' unless defined(&B1800); eval 'sub B2400 () {0000013;}' unless defined(&B2400); eval 'sub B4800 () {0000014;}' unless defined(&B4800); eval 'sub B9600 () {0000015;}' unless defined(&B9600); eval 'sub B19200 () {0000016;}' unless defined(&B19200); eval 'sub B38400 () {0000017;}' unless defined(&B38400); eval 'sub EXTA () { &B19200;}' unless defined(&EXTA); eval 'sub EXTB () { &B38400;}' unless defined(&EXTB); eval 'sub CSIZE () {0000060;}' unless defined(&CSIZE); eval 'sub CS5 () {0000000;}' unless defined(&CS5); eval 'sub CS6 () {0000020;}' unless defined(&CS6); eval 'sub CS7 () {0000040;}' unless defined(&CS7); eval 'sub CS8 () {0000060;}' unless defined(&CS8); eval 'sub CSTOPB () {0000100;}' unless defined(&CSTOPB); eval 'sub CREAD () {0000200;}' unless defined(&CREAD); eval 'sub PARENB () {0000400;}' unless defined(&PARENB); eval 'sub PARODD () {0001000;}' unless defined(&PARODD); eval 'sub HUPCL () {0002000;}' unless defined(&HUPCL); eval 'sub CLOCAL () {0004000;}' unless defined(&CLOCAL); eval 'sub CBAUDEX () {0010000;}' unless defined(&CBAUDEX); eval 'sub BOTHER () {0010000;}' unless defined(&BOTHER); eval 'sub B57600 () {0010001;}' unless defined(&B57600); eval 'sub B115200 () {0010002;}' unless defined(&B115200); eval 'sub B230400 () {0010003;}' unless defined(&B230400); eval 'sub B460800 () {0010004;}' unless defined(&B460800); eval 'sub B500000 () {0010005;}' unless defined(&B500000); eval 'sub B576000 () {0010006;}' unless defined(&B576000); eval 'sub B921600 () {0010007;}' unless defined(&B921600); eval 'sub B1000000 () {0010010;}' unless defined(&B1000000); eval 'sub B1152000 () {0010011;}' unless defined(&B1152000); eval 'sub B1500000 () {0010012;}' unless defined(&B1500000); eval 'sub B2000000 () {0010013;}' unless defined(&B2000000); eval 'sub B2500000 () {0010014;}' unless defined(&B2500000); eval 'sub B3000000 () {0010015;}' unless defined(&B3000000); eval 'sub B3500000 () {0010016;}' unless defined(&B3500000); eval 'sub B4000000 () {0010017;}' unless defined(&B4000000); eval 'sub CIBAUD () {002003600000;}' unless defined(&CIBAUD); eval 'sub CMSPAR () {010000000000;}' unless defined(&CMSPAR); eval 'sub CRTSCTS () {020000000000;}' unless defined(&CRTSCTS); eval 'sub IBSHIFT () {16;}' unless defined(&IBSHIFT); eval 'sub ISIG () {0000001;}' unless defined(&ISIG); eval 'sub ICANON () {0000002;}' unless defined(&ICANON); eval 'sub XCASE () {0000004;}' unless defined(&XCASE); eval 'sub ECHO () {0000010;}' unless defined(&ECHO); eval 'sub ECHOE () {0000020;}' unless defined(&ECHOE); eval 'sub ECHOK () {0000040;}' unless defined(&ECHOK); eval 'sub ECHONL () {0000100;}' unless defined(&ECHONL); eval 'sub NOFLSH () {0000200;}' unless defined(&NOFLSH); eval 'sub TOSTOP () {0000400;}' unless defined(&TOSTOP); eval 'sub ECHOCTL () {0001000;}' unless defined(&ECHOCTL); eval 'sub ECHOPRT () {0002000;}' unless defined(&ECHOPRT); eval 'sub ECHOKE () {0004000;}' unless defined(&ECHOKE); eval 'sub FLUSHO () {0010000;}' unless defined(&FLUSHO); eval 'sub PENDIN () {0040000;}' unless defined(&PENDIN); eval 'sub IEXTEN () {0100000;}' unless defined(&IEXTEN); eval 'sub TCOOFF () {0;}' unless defined(&TCOOFF); eval 'sub TCOON () {1;}' unless defined(&TCOON); eval 'sub TCIOFF () {2;}' unless defined(&TCIOFF); eval 'sub TCION () {3;}' unless defined(&TCION); eval 'sub TCIFLUSH () {0;}' unless defined(&TCIFLUSH); eval 'sub TCOFLUSH () {1;}' unless defined(&TCOFLUSH); eval 'sub TCIOFLUSH () {2;}' unless defined(&TCIOFLUSH); eval 'sub TCSANOW () {0;}' unless defined(&TCSANOW); eval 'sub TCSADRAIN () {1;}' unless defined(&TCSADRAIN); eval 'sub TCSAFLUSH () {2;}' unless defined(&TCSAFLUSH); } 1; PK��[[M�1QQ5.10.1/re.pmnuW+A��
package re; # pragma for controlling the regex engine use strict; use warnings; our $VERSION = "0.09"; our @ISA = qw(Exporter); my @XS_FUNCTIONS = qw(regmust); my %XS_FUNCTIONS = map { $_ => 1 } @XS_FUNCTIONS; our @EXPORT_OK = (@XS_FUNCTIONS, qw(is_regexp regexp_pattern regname regnames regnames_count)); our %EXPORT_OK = map { $_ => 1 } @EXPORT_OK; # *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING *** # # If you modify these values see comment below! my %bitmask = ( taint => 0x00100000, # HINT_RE_TAINT eval => 0x00200000, # HINT_RE_EVAL ); # - File::Basename contains a literal for 'taint' as a fallback. If # taint is changed here, File::Basename must be updated as well. # # - ExtUtils::ParseXS uses a hardcoded # BEGIN { $^H |= 0x00200000 } # in it to allow re.xs to be built. So if 'eval' is changed here then # ExtUtils::ParseXS must be changed as well. # # *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING *** 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; }; if ($@) { $ENV{PERL_RE_COLORS} ||= qq'\t\t> <\t> <\t\t'; } } my %flags = ( COMPILE => 0x0000FF, PARSE => 0x000001, OPTIMISE => 0x000002, TRIEC => 0x000004, DUMP => 0x000008, FLAGS => 0x000010, EXECUTE => 0x00FF00, INTUIT => 0x000100, MATCH => 0x000200, TRIEE => 0x000400, EXTRA => 0xFF0000, TRIEM => 0x010000, OFFSETS => 0x020000, OFFSETSDBG => 0x040000, STATE => 0x080000, OPTIMISEM => 0x100000, STACK => 0x280000, BUFFERS => 0x400000, ); $flags{ALL} = -1 & ~($flags{OFFSETS}|$flags{OFFSETSDBG}|$flags{BUFFERS}); $flags{All} = $flags{all} = $flags{DUMP} | $flags{EXECUTE}; $flags{Extra} = $flags{EXECUTE} | $flags{COMPILE}; $flags{More} = $flags{MORE} = $flags{All} | $flags{TRIEC} | $flags{TRIEM} | $flags{STATE}; $flags{State} = $flags{DUMP} | $flags{EXECUTE} | $flags{STATE}; $flags{TRIE} = $flags{DUMP} | $flags{EXECUTE} | $flags{TRIEC}; my $installed; my $installed_error; sub _do_install { if ( ! defined($installed) ) { require XSLoader; $installed = eval { XSLoader::load('re', $VERSION) } || 0; $installed_error = $@; } } sub _load_unload { my ($on)= @_; if ($on) { _do_install(); if ( ! $installed ) { die "'re' not installed!? ($installed_error)"; } else { # We call install() every time, as if we didn't, we wouldn't # "see" any changes to the color environment var since # the last time it was called. # install() returns an integer, which if casted properly # in C resolves to a structure containing the regex # hooks. Setting it to a random integer will guarantee # segfaults. $^H{regcomp} = install(); } } else { delete $^H{regcomp}; } } sub bits { my $on = shift; my $bits = 0; unless (@_) { require Carp; Carp::carp("Useless use of \"re\" pragma"); } foreach my $idx (0..$#_){ my $s=$_[$idx]; if ($s eq 'Debug' or $s eq 'Debugcolor') { setcolor() if $s =~/color/i; ${^RE_DEBUG_FLAGS} = 0 unless defined ${^RE_DEBUG_FLAGS}; for my $idx ($idx+1..$#_) { if ($flags{$_[$idx]}) { if ($on) { ${^RE_DEBUG_FLAGS} |= $flags{$_[$idx]}; } else { ${^RE_DEBUG_FLAGS} &= ~ $flags{$_[$idx]}; } } else { require Carp; Carp::carp("Unknown \"re\" Debug flag '$_[$idx]', possible flags: ", join(", ",sort keys %flags ) ); } } _load_unload($on ? 1 : ${^RE_DEBUG_FLAGS}); last; } elsif ($s eq 'debug' or $s eq 'debugcolor') { setcolor() if $s =~/color/i; _load_unload($on); last; } elsif (exists $bitmask{$s}) { $bits |= $bitmask{$s}; } elsif ($XS_FUNCTIONS{$s}) { _do_install(); if (! $installed) { require Carp; Carp::croak("\"re\" function '$s' not available"); } require Exporter; re->export_to_level(2, 're', $s); } elsif ($EXPORT_OK{$s}) { require Exporter; re->export_to_level(2, 're', $s); } else { require Carp; Carp::carp("Unknown \"re\" subpragma '$s' (known ones are: ", join(', ', map {qq('$_')} 'debug', 'debugcolor', sort keys %bitmask), ")"); } } $bits; } sub import { shift; $^H |= bits(1, @_); } sub unimport { shift; $^H &= ~ bits(0, @_); } 1; __END__ PK��[[L�Qf#t#t5.10.1/Encode.pmnuW+A��
# # $Id: Encode.pm,v 2.35 2009/07/13 00:49:38 dankogai Exp $ # package Encode; use strict; use warnings; our $VERSION = sprintf "%d.%02d", q$Revision: 2.35 $ =~ /(\d+)/g; sub DEBUG () { 0 } use XSLoader (); XSLoader::load( __PACKAGE__, $VERSION ); require Exporter; use base qw/Exporter/; # Public, encouraged API is exported by default our @EXPORT = qw( decode decode_utf8 encode encode_utf8 str2bytes bytes2str encodings find_encoding clone_encoding ); our @FB_FLAGS = qw( DIE_ON_ERR WARN_ON_ERR RETURN_ON_ERR LEAVE_SRC PERLQQ HTMLCREF XMLCREF STOP_AT_PARTIAL ); our @FB_CONSTS = qw( FB_DEFAULT FB_CROAK FB_QUIET FB_WARN FB_PERLQQ FB_HTMLCREF FB_XMLCREF ); our @EXPORT_OK = ( qw( _utf8_off _utf8_on define_encoding from_to is_16bit is_8bit is_utf8 perlio_ok resolve_alias utf8_downgrade utf8_upgrade ), @FB_FLAGS, @FB_CONSTS, ); our %EXPORT_TAGS = ( all => [ @EXPORT, @EXPORT_OK ], default => [ @EXPORT ], fallbacks => [ @FB_CONSTS ], fallback_all => [ @FB_CONSTS, @FB_FLAGS ], ); # Documentation moved after __END__ for speed - NI-S our $ON_EBCDIC = ( ord("A") == 193 ); use Encode::Alias; # Make a %Encoding package variable to allow a certain amount of cheating our %Encoding; our %ExtModule; require Encode::Config; # See # https://bugzilla.redhat.com/show_bug.cgi?id=435505#c2 # to find why sig handers inside eval{} are disabled. eval { local $SIG{__DIE__}; local $SIG{__WARN__}; require Encode::ConfigLocal; }; sub encodings { my $class = shift; my %enc; if ( @_ and $_[0] eq ":all" ) { %enc = ( %Encoding, %ExtModule ); } else { %enc = %Encoding; for my $mod ( map { m/::/o ? $_ : "Encode::$_" } @_ ) { DEBUG and warn $mod; for my $enc ( keys %ExtModule ) { $ExtModule{$enc} eq $mod and $enc{$enc} = $mod; } } } return sort { lc $a cmp lc $b } grep { !/^(?:Internal|Unicode|Guess)$/o } keys %enc; } sub perlio_ok { my $obj = ref( $_[0] ) ? $_[0] : find_encoding( $_[0] ); $obj->can("perlio_ok") and return $obj->perlio_ok(); return 0; # safety net } sub define_encoding { my $obj = shift; my $name = shift; $Encoding{$name} = $obj; my $lc = lc($name); define_alias( $lc => $obj ) unless $lc eq $name; while (@_) { my $alias = shift; define_alias( $alias, $obj ); } return $obj; } sub getEncoding { my ( $class, $name, $skip_external ) = @_; ref($name) && $name->can('renew') and return $name; exists $Encoding{$name} and return $Encoding{$name}; my $lc = lc $name; exists $Encoding{$lc} and return $Encoding{$lc}; my $oc = $class->find_alias($name); defined($oc) and return $oc; $lc ne $name and $oc = $class->find_alias($lc); defined($oc) and return $oc; unless ($skip_external) { if ( my $mod = $ExtModule{$name} || $ExtModule{$lc} ) { $mod =~ s,::,/,g; $mod .= '.pm'; eval { require $mod; }; exists $Encoding{$name} and return $Encoding{$name}; } } return; } sub find_encoding($;$) { my ( $name, $skip_external ) = @_; return __PACKAGE__->getEncoding( $name, $skip_external ); } sub resolve_alias($) { my $obj = find_encoding(shift); defined $obj and return $obj->name; return; } sub clone_encoding($) { my $obj = find_encoding(shift); ref $obj or return; eval { require Storable }; $@ and return; return Storable::dclone($obj); } sub encode($$;$) { my ( $name, $string, $check ) = @_; return undef unless defined $string; $string .= '' if ref $string; # stringify; $check ||= 0; unless ( defined $name ) { require Carp; Carp::croak("Encoding name should not be undef"); } my $enc = find_encoding($name); unless ( defined $enc ) { require Carp; Carp::croak("Unknown encoding '$name'"); } my $octets = $enc->encode( $string, $check ); $_[1] = $string if $check and !ref $check and !( $check & LEAVE_SRC() ); return $octets; } *str2bytes = \&encode; sub decode($$;$) { my ( $name, $octets, $check ) = @_; return undef unless defined $octets; $octets .= '' if ref $octets; $check ||= 0; my $enc = find_encoding($name); unless ( defined $enc ) { require Carp; Carp::croak("Unknown encoding '$name'"); } my $string = $enc->decode( $octets, $check ); $_[1] = $octets if $check and !ref $check and !( $check & LEAVE_SRC() ); return $string; } *bytes2str = \&decode; sub from_to($$$;$) { my ( $string, $from, $to, $check ) = @_; return undef unless defined $string; $check ||= 0; my $f = find_encoding($from); unless ( defined $f ) { require Carp; Carp::croak("Unknown encoding '$from'"); } my $t = find_encoding($to); unless ( defined $t ) { require Carp; Carp::croak("Unknown encoding '$to'"); } my $uni = $f->decode($string); $_[0] = $string = $t->encode( $uni, $check ); return undef if ( $check && length($uni) ); return defined( $_[0] ) ? length($string) : undef; } sub encode_utf8($) { my ($str) = @_; utf8::encode($str); return $str; } sub decode_utf8($;$) { my ( $str, $check ) = @_; return $str if is_utf8($str); if ($check) { return decode( "utf8", $str, $check ); } else { return decode( "utf8", $str ); return $str; } } predefine_encodings(1); # # This is to restore %Encoding if really needed; # sub predefine_encodings { require Encode::Encoding; no warnings 'redefine'; my $use_xs = shift; if ($ON_EBCDIC) { # was in Encode::UTF_EBCDIC package Encode::UTF_EBCDIC; push @Encode::UTF_EBCDIC::ISA, 'Encode::Encoding'; *decode = sub { my ( $obj, $str, $chk ) = @_; my $res = ''; for ( my $i = 0 ; $i < length($str) ; $i++ ) { $res .= chr( utf8::unicode_to_native( ord( substr( $str, $i, 1 ) ) ) ); } $_[1] = '' if $chk; return $res; }; *encode = sub { my ( $obj, $str, $chk ) = @_; my $res = ''; for ( my $i = 0 ; $i < length($str) ; $i++ ) { $res .= chr( utf8::native_to_unicode( ord( substr( $str, $i, 1 ) ) ) ); } $_[1] = '' if $chk; return $res; }; $Encode::Encoding{Unicode} = bless { Name => "UTF_EBCDIC" } => "Encode::UTF_EBCDIC"; } else { package Encode::Internal; push @Encode::Internal::ISA, 'Encode::Encoding'; *decode = sub { my ( $obj, $str, $chk ) = @_; utf8::upgrade($str); $_[1] = '' if $chk; return $str; }; *encode = \&decode; $Encode::Encoding{Unicode} = bless { Name => "Internal" } => "Encode::Internal"; } { # was in Encode::utf8 package Encode::utf8; push @Encode::utf8::ISA, 'Encode::Encoding'; # if ($use_xs) { Encode::DEBUG and warn __PACKAGE__, " XS on"; *decode = \&decode_xs; *encode = \&encode_xs; } else { Encode::DEBUG and warn __PACKAGE__, " XS off"; *decode = sub { my ( $obj, $octets, $chk ) = @_; my $str = Encode::decode_utf8($octets); if ( defined $str ) { $_[1] = '' if $chk; return $str; } return undef; }; *encode = sub { my ( $obj, $string, $chk ) = @_; my $octets = Encode::encode_utf8($string); $_[1] = '' if $chk; return $octets; }; } *cat_decode = sub { # ($obj, $dst, $src, $pos, $trm, $chk) # currently ignores $chk my ( $obj, undef, undef, $pos, $trm ) = @_; my ( $rdst, $rsrc, $rpos ) = \@_[ 1, 2, 3 ]; use bytes; if ( ( my $npos = index( $$rsrc, $trm, $pos ) ) >= 0 ) { $$rdst .= substr( $$rsrc, $pos, $npos - $pos + length($trm) ); $$rpos = $npos + length($trm); return 1; } $$rdst .= substr( $$rsrc, $pos ); $$rpos = length($$rsrc); return ''; }; $Encode::Encoding{utf8} = bless { Name => "utf8" } => "Encode::utf8"; $Encode::Encoding{"utf-8-strict"} = bless { Name => "utf-8-strict", strict_utf8 => 1 } => "Encode::utf8"; } } 1; __END__ =head1 NAME Encode - character encodings =head1 SYNOPSIS use Encode; =head2 Table of Contents Encode consists of a collection of modules whose details are too big to fit in one document. This POD itself explains the top-level APIs and general topics at a glance. For other topics and more details, see the PODs below: Name Description -------------------------------------------------------- Encode::Alias Alias definitions to encodings Encode::Encoding Encode Implementation Base Class Encode::Supported List of Supported Encodings Encode::CN Simplified Chinese Encodings Encode::JP Japanese Encodings Encode::KR Korean Encodings Encode::TW Traditional Chinese Encodings -------------------------------------------------------- =head1 DESCRIPTION The C module provides the interfaces between Perl's strings and the rest of the system. Perl strings are sequences of B. The repertoire of characters that Perl can represent is at least that defined by the Unicode Consortium. On most platforms the ordinal values of the characters (as returned by C) is the "Unicode codepoint" for the character (the exceptions are those platforms where the legacy encoding is some variant of EBCDIC rather than a super-set of ASCII - see L). Traditionally, computer data has been moved around in 8-bit chunks often called "bytes". These chunks are also known as "octets" in networking standards. Perl is widely used to manipulate data of many types - not only strings of characters representing human or computer languages but also "binary" data being the machine's representation of numbers, pixels in an image - or just about anything. When Perl is processing "binary data", the programmer wants Perl to process "sequences of bytes". This is not a problem for Perl - as a byte has 256 possible values, it easily fits in Perl's much larger "logical character". =head2 TERMINOLOGY =over 2 =item * I: a character in the range 0..(2**32-1) (or more). (What Perl's strings are made of.) =item * I: a character in the range 0..255 (A special case of a Perl character.) =item * I: 8 bits of data, with ordinal values 0..255 (Term for bytes passed to or from a non-Perl context, e.g. a disk file.) =back =head1 PERL ENCODING API =over 2 =item $octets = encode(ENCODING, $string [, CHECK]) Encodes a string from Perl's internal form into I and returns a sequence of octets. ENCODING can be either a canonical name or an alias. For encoding names and aliases, see L. For CHECK, see L. For example, to convert a string from Perl's internal format to iso-8859-1 (also known as Latin1), $octets = encode("iso-8859-1", $string); B: When you run C<$octets = encode("utf8", $string)>, then $octets B $string. Though they both contain the same data, the UTF8 flag for $octets is B off. When you encode anything, UTF8 flag of the result is always off, even when it contains completely valid utf8 string. See L below. If the $string is C then C is returned. =item $string = decode(ENCODING, $octets [, CHECK]) Decodes a sequence of octets assumed to be in I into Perl's internal form and returns the resulting string. As in encode(), ENCODING can be either a canonical name or an alias. For encoding names and aliases, see L. For CHECK, see L. For example, to convert ISO-8859-1 data to a string in Perl's internal format: $string = decode("iso-8859-1", $octets); B: When you run C<$string = decode("utf8", $octets)>, then $string B $octets. Though they both contain the same data, the UTF8 flag for $string is on unless $octets entirely consists of ASCII data (or EBCDIC on EBCDIC machines). See L below. If the $string is C then C is returned. =item [$obj =] find_encoding(ENCODING) Returns the I corresponding to ENCODING. Returns undef if no matching ENCODING is find. This object is what actually does the actual (en|de)coding. $utf8 = decode($name, $bytes); is in fact $utf8 = do{ $obj = find_encoding($name); croak qq(encoding "$name" not found) unless ref $obj; $obj->decode($bytes) }; with more error checking. Therefore you can save time by reusing this object as follows; my $enc = find_encoding("iso-8859-1"); while(<>){ my $utf8 = $enc->decode($_); # and do someting with $utf8; } Besides C<< ->decode >> and C<< ->encode >>, other methods are available as well. For instance, C<< -> name >> returns the canonical name of the encoding object. find_encoding("latin1")->name; # iso-8859-1 See L for details. =item [$length =] from_to($octets, FROM_ENC, TO_ENC [, CHECK]) Converts B data between two encodings. The data in $octets must be encoded as octets and not as characters in Perl's internal format. For example, to convert ISO-8859-1 data to Microsoft's CP1250 encoding: from_to($octets, "iso-8859-1", "cp1250"); and to convert it back: from_to($octets, "cp1250", "iso-8859-1"); Note that because the conversion happens in place, the data to be converted cannot be a string constant; it must be a scalar variable. from_to() returns the length of the converted string in octets on success, I on error. B: The following operations look the same but are not quite so; from_to($data, "iso-8859-1", "utf8"); #1 $data = decode("iso-8859-1", $data); #2 Both #1 and #2 make $data consist of a completely valid UTF-8 string but only #2 turns UTF8 flag on. #1 is equivalent to $data = encode("utf8", decode("iso-8859-1", $data)); See L below. Also note that from_to($octets, $from, $to, $check); is equivalent to $octets = encode($to, decode($from, $octets), $check); Yes, it does not respect the $check during decoding. It is deliberately done that way. If you need minute control, C then C as follows; $octets = encode($to, decode($from, $octets, $check_from), $check_to); =item $octets = encode_utf8($string); Equivalent to C<$octets = encode("utf8", $string);> The characters that comprise $string are encoded in Perl's internal format and the result is returned as a sequence of octets. All possible characters have a UTF-8 representation so this function cannot fail. =item $string = decode_utf8($octets [, CHECK]); equivalent to C<$string = decode("utf8", $octets [, CHECK])>. The sequence of octets represented by $octets is decoded from UTF-8 into a sequence of logical characters. Not all sequences of octets form valid UTF-8 encodings, so it is possible for this call to fail. For CHECK, see L. =back =head2 Listing available encodings use Encode; @list = Encode->encodings(); Returns a list of the canonical names of the available encodings that are loaded. To get a list of all available encodings including the ones that are not loaded yet, say @all_encodings = Encode->encodings(":all"); Or you can give the name of a specific module. @with_jp = Encode->encodings("Encode::JP"); When "::" is not in the name, "Encode::" is assumed. @ebcdic = Encode->encodings("EBCDIC"); To find out in detail which encodings are supported by this package, see L. =head2 Defining Aliases To add a new alias to a given encoding, use: use Encode; use Encode::Alias; define_alias(newName => ENCODING); After that, newName can be used as an alias for ENCODING. ENCODING may be either the name of an encoding or an I But before you do so, make sure the alias is nonexistent with C, which returns the canonical name thereof. i.e. Encode::resolve_alias("latin1") eq "iso-8859-1" # true Encode::resolve_alias("iso-8859-12") # false; nonexistent Encode::resolve_alias($name) eq $name # true if $name is canonical resolve_alias() does not need C; it can be exported via C. See L for details. =head2 Finding IANA Character Set Registry names The canonical name of a given encoding does not necessarily agree with IANA IANA Character Set Registry, commonly seen as C<< Content-Type: text/plain; charset=I >>. For most cases canonical names work but sometimes it does not (notably 'utf-8-strict'). Therefore as of Encode version 2.21, a new method C is added. use Encode; my $enc = find_encoding('UTF-8'); warn $enc->name; # utf-8-strict warn $enc->mime_name; # UTF-8 See also: L =head1 Encoding via PerlIO If your perl supports I (which is the default), you can use a PerlIO layer to decode and encode directly via a filehandle. The following two examples are totally identical in their functionality. # via PerlIO open my $in, "<:encoding(shiftjis)", $infile or die; open my $out, ">:encoding(euc-jp)", $outfile or die; while(<$in>){ print $out $_; } # via from_to open my $in, "<", $infile or die; open my $out, ">", $outfile or die; while(<$in>){ from_to($_, "shiftjis", "euc-jp", 1); print $out $_; } Unfortunately, it may be that encodings are PerlIO-savvy. You can check if your encoding is supported by PerlIO by calling the C method. Encode::perlio_ok("hz"); # False find_encoding("euc-cn")->perlio_ok; # True where PerlIO is available use Encode qw(perlio_ok); # exported upon request perlio_ok("euc-jp") Fortunately, all encodings that come with Encode core are PerlIO-savvy except for hz and ISO-2022-kr. For gory details, see L and L. =head1 Handling Malformed Data The optional I argument tells Encode what to do when it encounters malformed data. Without CHECK, Encode::FB_DEFAULT ( == 0 ) is assumed. As of version 2.12 Encode supports coderef values for CHECK. See below. =over 2 =item B Not all encoding support this feature Some encodings ignore I argument. For example, L ignores I and it always croaks on error. =back Now here is the list of I values available =over 2 =item I = Encode::FB_DEFAULT ( == 0) If I is 0, (en|de)code will put a I in place of a malformed character. When you encode, EsubcharE will be used. When you decode the code point C<0xFFFD> is used. If the data is supposed to be UTF-8, an optional lexical warning (category utf8) is given. =item I = Encode::FB_CROAK ( == 1) If I is 1, methods will die on error immediately with an error message. Therefore, when I is set to 1, you should trap the error with eval{} unless you really want to let it die. =item I = Encode::FB_QUIET If I is set to Encode::FB_QUIET, (en|de)code will immediately return the portion of the data that has been processed so far when an error occurs. The data argument will be overwritten with everything after that point (that is, the unprocessed part of data). This is handy when you have to call decode repeatedly in the case where your source data may contain partial multi-byte character sequences, (i.e. you are reading with a fixed-width buffer). Here is a sample code that does exactly this: my $buffer = ''; my $string = ''; while(read $fh, $buffer, 256, length($buffer)){ $string .= decode($encoding, $buffer, Encode::FB_QUIET); # $buffer now contains the unprocessed partial character } =item I = Encode::FB_WARN This is the same as above, except that it warns on error. Handy when you are debugging the mode above. =item perlqq mode (I = Encode::FB_PERLQQ) =item HTML charref mode (I = Encode::FB_HTMLCREF) =item XML charref mode (I = Encode::FB_XMLCREF) For encodings that are implemented by Encode::XS, CHECK == Encode::FB_PERLQQ turns (en|de)code into C fallback mode. When you decode, C<\xI> will be inserted for a malformed character, where I is the hex representation of the octet that could not be decoded to utf8. And when you encode, C<\x{I}> will be inserted, where I is the Unicode ID of the character that cannot be found in the character repertoire of the encoding. HTML/XML character reference modes are about the same, in place of C<\x{I}>, HTML uses C<&#I;> where I is a decimal number and XML uses C<&#xI;> where I is the hexadecimal number. In Encode 2.10 or later, C is also implied. =item The bitmask These modes are actually set via a bitmask. Here is how the FB_XX constants are laid out. You can import the FB_XX constants via C; you can import the generic bitmask constants via C. FB_DEFAULT FB_CROAK FB_QUIET FB_WARN FB_PERLQQ DIE_ON_ERR 0x0001 X WARN_ON_ERR 0x0002 X RETURN_ON_ERR 0x0004 X X LEAVE_SRC 0x0008 X PERLQQ 0x0100 X HTMLCREF 0x0200 XMLCREF 0x0400 =back =over 2 =item Encode::LEAVE_SRC If the C bit is not set, but I is, then the second argument to C or C may be assigned to by the functions. If you're not interested in this, then bitwise-or the bitmask with it. =back =head2 coderef for CHECK As of Encode 2.12 CHECK can also be a code reference which takes the ord value of unmapped caharacter as an argument and returns a string that represents the fallback character. For instance, $ascii = encode("ascii", $utf8, sub{ sprintf "", shift }); Acts like FB_PERLQQ but EU+IE is used instead of \x{I}. =head1 Defining Encodings To define a new encoding, use: use Encode qw(define_encoding); define_encoding($object, 'canonicalName' [, alias...]); I will be associated with I<$object>. The object should provide the interface described in L. If more than two arguments are provided then additional arguments are taken as aliases for I<$object>. See L for more details. =head1 The UTF8 flag Before the introduction of Unicode support in perl, The C operator just compared the strings represented by two scalars. Beginning with perl 5.8, C compares two strings with simultaneous consideration of I. To explain why we made it so, I will quote page 402 of C =over 2 =item Goal #1: Old byte-oriented programs should not spontaneously break on the old byte-oriented data they used to work on. =item Goal #2: Old byte-oriented programs should magically start working on the new character-oriented data when appropriate. =item Goal #3: Programs should run just as fast in the new character-oriented mode as in the old byte-oriented mode. =item Goal #4: Perl should remain one language, rather than forking into a byte-oriented Perl and a character-oriented Perl. =back Back when C was written, not even Perl 5.6.0 was born and many features documented in the book remained unimplemented for a long time. Perl 5.8 corrected this and the introduction of the UTF8 flag is one of them. You can think of this perl notion as of a byte-oriented mode (UTF8 flag off) and a character-oriented mode (UTF8 flag on). Here is how Encode takes care of the UTF8 flag. =over 2 =item * When you encode, the resulting UTF8 flag is always off. =item * When you decode, the resulting UTF8 flag is on unless you can unambiguously represent data. Here is the definition of dis-ambiguity. After C<$utf8 = decode('foo', $octet);>, When $octet is... The UTF8 flag in $utf8 is --------------------------------------------- In ASCII only (or EBCDIC only) OFF In ISO-8859-1 ON In any other Encoding ON --------------------------------------------- As you see, there is one exception, In ASCII. That way you can assume Goal #1. And with Encode Goal #2 is assumed but you still have to be careful in such cases mentioned in B paragraphs. This UTF8 flag is not visible in perl scripts, exactly for the same reason you cannot (or you I) see if a scalar contains a string, integer, or floating point number. But you can still peek and poke these if you will. See the section below. =back =head2 Messing with Perl's Internals The following API uses parts of Perl's internals in the current implementation. As such, they are efficient but may change. =over 2 =item is_utf8(STRING [, CHECK]) [INTERNAL] Tests whether the UTF8 flag is turned on in the STRING. If CHECK is true, also checks the data in STRING for being well-formed UTF-8. Returns true if successful, false otherwise. As of perl 5.8.1, L also has utf8::is_utf8(). =item _utf8_on(STRING) [INTERNAL] Turns on the UTF8 flag in STRING. The data in STRING is B checked for being well-formed UTF-8. Do not use unless you B that the STRING is well-formed UTF-8. Returns the previous state of the UTF8 flag (so please don't treat the return value as indicating success or failure), or C if STRING is not a string. This function does not work on tainted values. =item _utf8_off(STRING) [INTERNAL] Turns off the UTF8 flag in STRING. Do not use frivolously. Returns the previous state of the UTF8 flag (so please don't treat the return value as indicating success or failure), or C if STRING is not a string. This function does not work on tainted values. =back =head1 UTF-8 vs. utf8 vs. UTF8 ....We now view strings not as sequences of bytes, but as sequences of numbers in the range 0 .. 2**32-1 (or in the case of 64-bit computers, 0 .. 2**64-1) -- Programming Perl, 3rd ed. That has been the perl's notion of UTF-8 but official UTF-8 is more strict; Its ranges is much narrower (0 .. 10FFFF), some sequences are not allowed (i.e. Those used in the surrogate pair, 0xFFFE, et al). Now that is overruled by Larry Wall himself. From: Larry Wall Date: December 04, 2004 11:51:58 JST To: perl-unicode@perl.org Subject: Re: Make Encode.pm support the real UTF-8 Message-Id: <20041204025158.GA28754@wall.org> On Fri, Dec 03, 2004 at 10:12:12PM +0000, Tim Bunce wrote: : I've no problem with 'utf8' being perl's unrestricted uft8 encoding, : but "UTF-8" is the name of the standard and should give the : corresponding behaviour. For what it's worth, that's how I've always kept them straight in my head. Also for what it's worth, Perl 6 will mostly default to strict but make it easy to switch back to lax. Larry Do you copy? As of Perl 5.8.7, B means strict, official UTF-8 while B means liberal, lax, version thereof. And Encode version 2.10 or later thus groks the difference between C and C"utf8". encode("utf8", "\x{FFFF_FFFF}", 1); # okay encode("UTF-8", "\x{FFFF_FFFF}", 1); # croaks C in Encode is actually a canonical name for C. Yes, the hyphen between "UTF" and "8" is important. Without it Encode goes "liberal" find_encoding("UTF-8")->name # is 'utf-8-strict' find_encoding("utf-8")->name # ditto. names are case insensitive find_encoding("utf_8")->name # ditto. "_" are treated as "-" find_encoding("UTF8")->name # is 'utf8'. The UTF8 flag is internally called UTF8, without a hyphen. It indicates whether a string is internally encoded as utf8, also without a hypen. =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L L, the Perl Unicode Mailing List Eperl-unicode@perl.orgE =head1 MAINTAINER This project was originated by Nick Ing-Simmons and later maintained by Dan Kogai Edankogai@dan.co.jpE. See AUTHORS for a full list of people involved. For any questions, use Eperl-unicode@perl.orgE so we can all share. While Dan Kogai retains the copyright as a maintainer, the credit should go to all those involoved. See AUTHORS for those submitted codes. =head1 COPYRIGHT Copyright 2002-2006 Dan Kogai Edankogai@dan.co.jpE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK��[[���ޖ�5.10.1/Text/Soundex.pmnuW+A��
# -*- perl -*- # (c) Copyright 1998-2007 by Mark Mielke # # Freedom to use these sources for whatever you want, as long as credit # is given where credit is due, is hereby granted. You may make modifications # where you see fit but leave this copyright somewhere visible. As well, try # to initial any changes you make so that if I like the changes I can # incorporate them into later versions. # # - Mark Mielke # package Text::Soundex; require 5.006; use Exporter (); use XSLoader (); use strict; our $VERSION = '3.03'; our @EXPORT_OK = qw(soundex soundex_unicode soundex_nara soundex_nara_unicode $soundex_nocode); our @EXPORT = qw(soundex soundex_nara $soundex_nocode); our @ISA = qw(Exporter); our $nocode; # Previous releases of Text::Soundex made $nocode available as $soundex_nocode. # For now, this part of the interface is exported and maintained. # In the feature, $soundex_nocode will be deprecated. *Text::Soundex::soundex_nocode = \$nocode; sub soundex_noxs { # Original Soundex algorithm my @results = map { my $code = uc($_); $code =~ tr/AaEeHhIiOoUuWwYyBbFfPpVvCcGgJjKkQqSsXxZzDdTtLlMmNnRr//cd; if (length($code)) { my $firstchar = substr($code, 0, 1); $code =~ tr[AaEeHhIiOoUuWwYyBbFfPpVvCcGgJjKkQqSsXxZzDdTtLlMmNnRr] [0000000000000000111111112222222222222222333344555566]s; ($code = substr($code, 1)) =~ tr/0//d; substr($firstchar . $code . '000', 0, 4); } else { $nocode; } } @_; wantarray ? @results : $results[0]; } sub soundex_nara { # US census (NARA) algorithm. my @results = map { my $code = uc($_); $code =~ tr/AaEeHhIiOoUuWwYyBbFfPpVvCcGgJjKkQqSsXxZzDdTtLlMmNnRr//cd; if (length($code)) { my $firstchar = substr($code, 0, 1); $code =~ tr[AaEeHhIiOoUuWwYyBbFfPpVvCcGgJjKkQqSsXxZzDdTtLlMmNnRr] [0000990000009900111111112222222222222222333344555566]s; $code =~ s/(.)9\1/$1/gs; ($code = substr($code, 1)) =~ tr/09//d; substr($firstchar . $code . '000', 0, 4); } else { $nocode } } @_; wantarray ? @results : $results[0]; } sub soundex_unicode { require Text::Unidecode unless defined &Text::Unidecode::unidecode; soundex(Text::Unidecode::unidecode(@_)); } sub soundex_nara_unicode { require Text::Unidecode unless defined &Text::Unidecode::unidecode; soundex_nara(Text::Unidecode::unidecode(@_)); } eval { XSLoader::load(__PACKAGE__, $VERSION) }; if (defined(&soundex_xs)) { *soundex = \&soundex_xs; } else { *soundex = \&soundex_noxs; *soundex_xs = sub { require Carp; Carp::croak("XS implementation of Text::Soundex::soundex_xs() ". "could not be loaded"); }; } 1; __END__ # Implementation of the soundex algorithm. # # Some of this documention was written by Mike Stok. # # Examples: # # Euler, Ellery -> E460 # Gauss, Ghosh -> G200 # Hilbert, Heilbronn -> H416 # Knuth, Kant -> K530 # Lloyd, Ladd -> L300 # Lukasiewicz, Lissajous -> L222 # =head1 NAME Text::Soundex - Implementation of the soundex algorithm. =head1 SYNOPSIS use Text::Soundex; # Original algorithm. $code = soundex($name); # Get the soundex code for a name. @codes = soundex(@names); # Get the list of codes for a list of names. # American Soundex variant (NARA) - Used for US census data. $code = soundex_nara($name); # Get the soundex code for a name. @codes = soundex_nara(@names); # Get the list of codes for a list of names. # Redefine the value that soundex() will return if the input string # contains no identifiable sounds within it. $Text::Soundex::nocode = 'Z000'; =head1 DESCRIPTION Soundex is a phonetic algorithm for indexing names by sound, as pronounced in English. The goal is for names with the same pronunciation to be encoded to the same representation so that they can be matched despite minor differences in spelling. Soundex is the most widely known of all phonetic algorithms and is often used (incorrectly) as a synonym for "phonetic algorithm". Improvements to Soundex are the basis for many modern phonetic algorithms. (Wikipedia, 2007) This module implements the original soundex algorithm developed by Robert Russell and Margaret Odell, patented in 1918 and 1922, as well as a variation called "American Soundex" used for US census data, and current maintained by the National Archives and Records Administration (NARA). The soundex algorithm may be recognized from Donald Knuth's B. The algorithm described by Knuth is the NARA algorithm. The value returned for strings which have no soundex encoding is defined using C<$Text::Soundex::nocode>. The default value is C, however values such as C<'Z000'> are commonly used alternatives. For backward compatibility with older versions of this module the C<$Text::Soundex::nocode> is exported into the caller's namespace as C<$soundex_nocode>. In scalar context, C returns the soundex code of its first argument. In list context, a list is returned in which each element is the soundex code for the corresponding argument passed to C. For example, the following code assigns @codes the value C<('M200', 'S320')>: @codes = soundex qw(Mike Stok); To use C to generate codes that can be used to search one of the publically available US Censuses, a variant of the soundex algorithm must be used: use Text::Soundex; $code = soundex_nara($name); An example of where these algorithm differ follows: use Text::Soundex; print soundex("Ashcraft"), "\n"; # prints: A226 print soundex_nara("Ashcraft"), "\n"; # prints: A261 =head1 EXAMPLES Donald Knuth's examples of names and the soundex codes they map to are listed below: Euler, Ellery -> E460 Gauss, Ghosh -> G200 Hilbert, Heilbronn -> H416 Knuth, Kant -> K530 Lloyd, Ladd -> L300 Lukasiewicz, Lissajous -> L222 so: $code = soundex 'Knuth'; # $code contains 'K530' @list = soundex qw(Lloyd Gauss); # @list contains 'L300', 'G200' =head1 LIMITATIONS As the soundex algorithm was originally used a B time ago in the US it considers only the English alphabet and pronunciation. In particular, non-ASCII characters will be ignored. The recommended method of dealing with characters that have accents, or other unicode characters, is to use the Text::Unidecode module available from CPAN. Either use the module explicitly: use Text::Soundex; use Text::Unidecode; print soundex(unidecode("Fran\xE7ais")), "\n"; # Prints "F652\n" Or use the convenient wrapper routine: use Text::Soundex 'soundex_unicode'; print soundex_unicode("Fran\xE7ais"), "\n"; # Prints "F652\n" Since the soundex algorithm maps a large space (strings of arbitrary length) onto a small space (single letter plus 3 digits) no inference can be made about the similarity of two strings which end up with the same soundex code. For example, both C and C end up with a soundex code of C. =head1 MAINTAINER This module is currently maintain by Mark Mielke (C). =head1 HISTORY Version 3 is a significant update to provide support for versions of Perl later than Perl 5.004. Specifically, the XS version of the soundex() subroutine understands strings that are encoded using UTF-8 (unicode strings). Version 2 of this module was a re-write by Mark Mielke (C) to improve the speed of the subroutines. The XS version of the soundex() subroutine was introduced in 2.00. Version 1 of this module was written by Mike Stok (C) and was included into the Perl core library set. Dave Carlsen (C) made the request for the NARA algorithm to be included. The NARA soundex page can be viewed at: C Ian Phillips (C) and Rich Pinder (C) supplied ideas and spotted mistakes for v1.x. =cut PK��[[Z��/�/�5.10.1/DB_File.pmnuW+A��
# DB_File.pm -- Perl 5 interface to Berkeley DB # # written by Paul Marquess (pmqs@cpan.org) # last modified 28th October 2007 # version 1.818 # # Copyright (c) 1995-2009 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.00404; 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 => { bsize => 1, ffactor => 1, nelem => 1, cachesize => 1, hash => 2, lorder => 1, }, 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 ; my $type = $self->{VALID}{$key}; if ( $type ) { croak "Key '$key' not associated with a code reference" if $type == 2 && !ref $value && ref $value ne 'CODE'; $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 => { flags => 1, cachesize => 1, maxkeypage => 1, minkeypage => 1, psize => 1, compare => 2, prefix => 2, lorder => 1, }, GOT => {}, }, $pkg ; } package DB_File ; use warnings; use strict; our ($VERSION, @ISA, @EXPORT, $AUTOLOAD, $DB_BTREE, $DB_HASH, $DB_RECNO); our ($db_version, $use_XSLoader, $splice_end_array, $Error); use Carp; $VERSION = "1.820" ; $VERSION = eval $VERSION; # needed for dev releases { local $SIG{__WARN__} = sub {$splice_end_array = "@_";}; my @a =(1); splice(@a, 3); $splice_end_array = ($splice_end_array =~ /^splice\(\) offset past end of array at /); } #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 ; { local $SIG{__DIE__} ; 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 ($error, $val) = constant($constname); Carp::croak $error if $error; no strict 'refs'; *{$AUTOLOAD} = sub { $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/ ) ; use File::Spec; $arg[1] = File::Spec->rel2abs($arg[1]) if defined $arg[1] ; $arg[4] = tied %{ $arg[4] } if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ; $arg[2] = O_CREAT()|O_RDWR() if @arg >=3 && ! defined $arg[2]; $arg[3] = 0666 if @arg >=4 && ! defined $arg[3]; # make recno in Berkeley DB version 2 (or better) work like # recno in version 1. if ($db_version >= 4 and ! $tieHASH) { $arg[2] |= O_CREAT(); } 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 SPLICE { my $self = shift; my $offset = shift; if (not defined $offset) { warnings::warnif('uninitialized', 'Use of uninitialized value in splice'); $offset = 0; } my $length = @_ ? shift : 0; # Carping about definedness comes _after_ the OFFSET sanity check. # This is so we get the same error messages as Perl's splice(). # my @list = @_; my $size = $self->FETCHSIZE(); # 'If OFFSET is negative then it start that far from the end of # the array.' # if ($offset < 0) { my $new_offset = $size + $offset; if ($new_offset < 0) { die "Modification of non-creatable array value attempted, " . "subscript $offset"; } $offset = $new_offset; } if (not defined $length) { warnings::warnif('uninitialized', 'Use of uninitialized value in splice'); $length = 0; } if ($offset > $size) { $offset = $size; warnings::warnif('misc', 'splice() offset past end of array') if $splice_end_array; } # 'If LENGTH is omitted, removes everything from OFFSET onward.' if (not defined $length) { $length = $size - $offset; } # 'If LENGTH is negative, leave that many elements off the end of # the array.' # if ($length < 0) { $length = $size - $offset + $length; if ($length < 0) { # The user must have specified a length bigger than the # length of the array passed in. But perl's splice() # doesn't catch this, it just behaves as for length=0. # $length = 0; } } if ($length > $size - $offset) { $length = $size - $offset; } # $num_elems holds the current number of elements in the database. my $num_elems = $size; # 'Removes the elements designated by OFFSET and LENGTH from an # array,'... # my @removed = (); foreach (0 .. $length - 1) { my $old; my $status = $self->get($offset, $old); if ($status != 0) { my $msg = "error from Berkeley DB on get($offset, \$old)"; if ($status == 1) { $msg .= ' (no such element?)'; } else { $msg .= ": error status $status"; if (defined $! and $! ne '') { $msg .= ", message $!"; } } die $msg; } push @removed, $old; $status = $self->del($offset); if ($status != 0) { my $msg = "error from Berkeley DB on del($offset)"; if ($status == 1) { $msg .= ' (no such element?)'; } else { $msg .= ": error status $status"; if (defined $! and $! ne '') { $msg .= ", message $!"; } } die $msg; } -- $num_elems; } # ...'and replaces them with the elements of LIST, if any.' my $pos = $offset; while (defined (my $elem = shift @list)) { my $old_pos = $pos; my $status; if ($pos >= $num_elems) { $status = $self->put($pos, $elem); } else { $status = $self->put($pos, $elem, $self->R_IBEFORE); } if ($status != 0) { my $msg = "error from Berkeley DB on put($pos, $elem, ...)"; if ($status == 1) { $msg .= ' (no such element?)'; } else { $msg .= ", error status $status"; if (defined $! and $! ne '') { $msg .= ", message $!"; } } die $msg; } die "pos unexpectedly changed from $old_pos to $pos with R_IBEFORE" if $old_pos != $pos; ++ $pos; ++ $num_elems; } if (wantarray) { # 'In list context, returns the elements removed from the # array.' # return @removed; } elsif (defined wantarray and not wantarray) { # 'In scalar context, returns the last element removed, or # undef if no elements are removed.' # if (@removed) { my $last = pop @removed; return "$last"; } else { return undef; } } elsif (not defined wantarray) { # Void context } else { die } } sub ::DB_File::splice { &SPLICE } 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); @r = $X->splice(offset, length, elements); # 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 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). 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 provides an interface to all three of the database types currently supported by Berkeley DB. The file types are: =over 5 =item B 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 use it instead. =item B 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 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 greater Although B is intended to be used with Berkeley DB version 1, it can also be used with version 2, 3 or 4. In this case the interface is limited to the functionality provided by Berkeley DB 1.x. Anywhere the version 2 or greater interface differs, B arranges for it to work like version 1. This feature allows B scripts that were built with version 1 to be migrated to version 2 or greater 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 instead. B The database file format has changed multiple times in Berkeley DB version 2, 3 and 4. If you cannot recreate your databases, you must dump any existing databases with either the C or the C utility that comes with Berkeley DB. Once you have rebuilt DB_File to use Berkeley DB version 2 or greater, your databases can be recreated using C. Refer to the Berkeley DB documentation for further details. Please read L<"COPYRIGHT"> before using version 2.x or greater of Berkeley DB with DB_File. =head2 Interface to Berkeley DB B allows access to Berkeley DB files using the tie() mechanism in Perl 5 (for full details, see L). This facility allows B 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. =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 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 points to a data structure which allows tailoring of the specific interface method. This interface is handled slightly differently in B. Here is an equivalent call using B: tie %array, 'DB_File', $filename, $flags, $mode, $DB_HASH ; The C, C and C parameters are the direct equivalent of their dbopen() counterparts. The final parameter $DB_HASH performs the function of both the C and C parameters in dbopen(). In the example above $DB_HASH is actually a pre-defined reference to a hash object. B 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, C, C, C, C and C. 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 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, C and C store pointers to C functions. In B 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 for an example of using the C template. If you are using the DB_RECNO interface and you intend making use of C, you should check out L. =head2 Default Parameters It is possible to omit some or all of the final 4 parameters in the call to C 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 for a discussion on the use of C 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 uses C 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 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 ; our (%h, $k, $v) ; unlink "fruit" ; tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0666, $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, 0666, $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. =item 3 Duplicate keys are entirely defined by the comparison function. In the case-insensitive example above, the keys: 'KEY' and 'key' would be considered duplicates, and assigning to the second one would overwrite the first. If duplicates are allowed for (with the R_DUP flag discussed below), only a single copy of duplicate keys is stored in the database --- so (again with example above) assigning three values to the keys: 'KEY', 'Key', and 'key' would leave just the first key: 'KEY' in the database with three values. For some situations this results in information loss, so care should be taken to provide fully qualified comparison functions when necessary. For example, the above comparison routine could be modified to additionally compare case-sensitively if two keys are equal in the case insensitive comparison: sub compare { my($key1, $key2) = @_; lc $key1 cmp lc $key2 || $key1 cmp $key2; } And now you will only have duplicates when the keys themselves are truly the same. (note: in versions of the db library prior to about November 1996, such duplicate keys were retained so it was possible to recover the original keys in sets of keys that compared as equal). =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 ; my ($filename, %h) ; $filename = "tree" ; unlink $filename ; # Enable duplicate records $DB_BTREE->{'flags'} = R_DUP ; tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $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 - the only thing is, when they are retrieved from the database they I to have the same value, namely C. 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. This method allows sequential access to key/value pairs. See L for details of both the C method and the API in general. Here is the script above rewritten using the C API method. use warnings ; use strict ; use DB_File ; my ($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, 0666, $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. To make life easier when dealing with duplicate keys, B comes with a few utility methods. =head2 The get_dup() Method The C 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 like this: use warnings ; use strict ; use DB_File ; my ($filename, $x, %h) ; $filename = "tree" ; # Enable duplicate records $DB_BTREE->{'flags'} = R_DUP ; $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $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 ; my ($filename, $x, %h, $found) ; $filename = "tree" ; # Enable duplicate records $DB_BTREE->{'flags'} = R_DUP ; $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $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 database use warnings ; use strict ; use DB_File ; my ($filename, $x, %h, $found) ; $filename = "tree" ; # Enable duplicate records $DB_BTREE->{'flags'} = R_DUP ; $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $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 available when the C 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 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 ; my ($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, 0666, $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? Well, the behavior defined in the quote above is quite useful, so B 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. Also note that the bval option only allows you to specify a single byte as a delimiter. =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 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, 0666, $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, C, C, C 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 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-Epush(list) ;> Pushes the elements of C to the end of the array. =item B<$value = $X-Epop ;> Removes and returns the last element of the array. =item B<$X-Eshift> Removes and returns the first element of the array. =item B<$X-Eunshift(list) ;> Pushes the elements of C to the start of the array. =item B<$X-Elength> Returns the number of elements in the array. =item B<$X-Esplice(offset, length, elements);> Returns a splice of 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). use warnings ; use strict ; my (@h, $H, $file, $i) ; use DB_File ; use Fcntl ; $file = "text" ; unlink $file ; $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0666, $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 method was used the record index was specified using a variable, C<$i>, rather than the literal value itself. This is because C 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 methods directly like this: $db->put($key, $value, R_NOOVERWRITE) ; B If you have saved a copy of the object returned from C, the underlying database file will I 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 for more details. All the functions defined in L are available except for close() and dbopen() itself. The B 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 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 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-Eget($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-Eput($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-Edel($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-Efd ;> Returns the file descriptor for the underlying database. See L for an explanation for why you should not use C to lock your database. =item B<$status = $X-Eseq($key, $value, $flags) ;> This interface allows sequential retrieval from the database. See L 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-Esync([$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 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 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 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 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 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 in not. To delete a filter pass C 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 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 = "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} = "something" ; 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 when writing, and C when reading. Here is a DBM Filter that does it: use warnings ; use strict ; use DB_File ; my %hash ; my $filename = "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 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', 'foo.db', O_CREAT|O_RDWR, 0644) || die "dbcreat 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 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 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 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, provides an interface to this locking functionality. If you are serious about locking Berkeley DB databases, I strongly recommend using B. If using B 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 A B 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 A B 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 An extremely lightweight B 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 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 script (available from your nearest CPAN archive in F). use warnings ; use strict ; use DB_File ; use Fcntl ; my ($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 strongly recommended that you read L. 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 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 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 destructor, DESTROY, will not be called until I 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 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 cannot do this directly, there is a module which can layer transparently over B to accomplish this feat. Check out the MLDBM module, available on CPAN in the directory F. =head2 What does "Invalid Argument" mean? You will get this error message when one of the parameters in the C 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 pragma (or the full strict pragma) in your script. Consider this script: use warnings ; use strict ; use DB_File ; my %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 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 in all your scripts. =head1 REFERENCES Articles that are either about B or make use of it. =over 5 =item 1. I, 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 comes with the standard Perl source distribution. Look in the directory F. 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 for details), in the directory F. This version of B 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. All versions of Berkeley DB are available there. Alternatively, Berkeley DB version 1 is available at your nearest CPAN archive in F. If you are running IRIX, then get Berkeley DB version 1 from F. It has the patches necessary to compile properly on IRIX 5.3. =head1 COPYRIGHT Copyright (c) 1995-2007 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 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) 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, L, L, L, L, L =head1 AUTHOR The DB_File interface was written by Paul Marquess Epmqs@cpan.orgE. =cut PK��[[�뭃�5.10.1/Hash/Util.pmnuW+A��
package Hash::Util; require 5.007003; use strict; use Carp; use warnings; use warnings::register; use Scalar::Util qw(reftype); require Exporter; our @ISA = qw(Exporter); our @EXPORT_OK = qw( fieldhash fieldhashes all_keys lock_keys unlock_keys lock_value unlock_value lock_hash unlock_hash lock_keys_plus hash_locked hidden_keys legal_keys lock_ref_keys unlock_ref_keys lock_ref_value unlock_ref_value lock_hashref unlock_hashref lock_ref_keys_plus hashref_locked hidden_ref_keys legal_ref_keys hash_seed hv_store ); our $VERSION = 0.07; require DynaLoader; local @ISA = qw(DynaLoader); bootstrap Hash::Util $VERSION; sub import { my $class = shift; if ( grep /fieldhash/, @_ ) { require Hash::Util::FieldHash; Hash::Util::FieldHash->import(':all'); # for re-export } unshift @_, $class; goto &Exporter::import; } sub lock_ref_keys { my($hash, @keys) = @_; Internals::hv_clear_placeholders %$hash; if( @keys ) { my %keys = map { ($_ => 1) } @keys; my %original_keys = map { ($_ => 1) } keys %$hash; foreach my $k (keys %original_keys) { croak "Hash has key '$k' which is not in the new key set" unless $keys{$k}; } foreach my $k (@keys) { $hash->{$k} = undef unless exists $hash->{$k}; } Internals::SvREADONLY %$hash, 1; foreach my $k (@keys) { delete $hash->{$k} unless $original_keys{$k}; } } else { Internals::SvREADONLY %$hash, 1; } return $hash; } sub unlock_ref_keys { my $hash = shift; Internals::SvREADONLY %$hash, 0; return $hash; } sub lock_keys (\%;@) { lock_ref_keys(@_) } sub unlock_keys (\%) { unlock_ref_keys(@_) } sub lock_ref_keys_plus { my ($hash,@keys)=@_; my @delete; Internals::hv_clear_placeholders(%$hash); foreach my $key (@keys) { unless (exists($hash->{$key})) { $hash->{$key}=undef; push @delete,$key; } } Internals::SvREADONLY(%$hash,1); delete @{$hash}{@delete}; return $hash } sub lock_keys_plus(\%;@) { lock_ref_keys_plus(@_) } sub lock_ref_value { my($hash, $key) = @_; # I'm doubtful about this warning, as it seems not to be true. # Marking a value in the hash as RO is useful, regardless # of the status of the hash itself. carp "Cannot usefully lock values in an unlocked hash" if !Internals::SvREADONLY(%$hash) && warnings::enabled; Internals::SvREADONLY $hash->{$key}, 1; return $hash } sub unlock_ref_value { my($hash, $key) = @_; Internals::SvREADONLY $hash->{$key}, 0; return $hash } sub lock_value (\%$) { lock_ref_value(@_) } sub unlock_value (\%$) { unlock_ref_value(@_) } sub lock_hashref { my $hash = shift; lock_ref_keys($hash); foreach my $value (values %$hash) { Internals::SvREADONLY($value,1); } return $hash; } sub unlock_hashref { my $hash = shift; foreach my $value (values %$hash) { Internals::SvREADONLY($value, 0); } unlock_ref_keys($hash); return $hash; } sub lock_hash (\%) { lock_hashref(@_) } sub unlock_hash (\%) { unlock_hashref(@_) } sub lock_hashref_recurse { my $hash = shift; lock_ref_keys($hash); foreach my $value (values %$hash) { if (reftype($value) eq 'HASH') { lock_hashref_recurse($value); } Internals::SvREADONLY($value,1); } return $hash } sub unlock_hashref_recurse { my $hash = shift; foreach my $value (values %$hash) { if (reftype($value) eq 'HASH') { unlock_hashref_recurse($value); } Internals::SvREADONLY($value,1); } unlock_ref_keys($hash); return $hash; } sub lock_hash_recurse (\%) { lock_hashref_recurse(@_) } sub unlock_hash_recurse (\%) { unlock_hashref_recurse(@_) } sub hashref_unlocked { my $hash=shift; return Internals::SvREADONLY($hash) } sub hash_unlocked(\%) { hashref_unlocked(@_) } sub legal_keys(\%) { legal_ref_keys(@_) } sub hidden_keys(\%){ hidden_ref_keys(@_) } sub hash_seed () { Internals::rehash_seed(); } 1; PK��[[[��btbt5.10.1/Hash/Util/FieldHash.pmnuW+A��
package Hash::Util::FieldHash; use 5.009004; use strict; use warnings; use Scalar::Util qw( reftype); our $VERSION = '1.04'; require Exporter; our @ISA = qw(Exporter); our %EXPORT_TAGS = ( 'all' => [ qw( fieldhash fieldhashes idhash idhashes id id_2obj register )], ); our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); { require XSLoader; my %ob_reg; # private object registry sub _ob_reg { \ %ob_reg } XSLoader::load('Hash::Util::FieldHash', $VERSION); } sub fieldhash (\%) { for ( shift ) { return unless ref() && reftype( $_) eq 'HASH'; return $_ if Hash::Util::FieldHash::_fieldhash( $_, 0); return $_ if Hash::Util::FieldHash::_fieldhash( $_, 2) == 2; return; } } sub idhash (\%) { for ( shift ) { return unless ref() && reftype( $_) eq 'HASH'; return $_ if Hash::Util::FieldHash::_fieldhash( $_, 0); return $_ if Hash::Util::FieldHash::_fieldhash( $_, 1) == 1; return; } } sub fieldhashes { map &fieldhash( $_), @_ } sub idhashes { map &idhash( $_), @_ } 1; __END__ =head1 NAME Hash::Util::FieldHash - Support for Inside-Out Classes =head1 SYNOPSIS ### Create fieldhashes use Hash::Util qw(fieldhash fieldhashes); # Create a single field hash fieldhash my %foo; # Create three at once... fieldhashes \ my(%foo, %bar, %baz); # ...or any number fieldhashes @hashrefs; ### Create an idhash and register it for garbage collection use Hash::Util::FieldHash qw(idhash register); idhash my %name; my $object = \ do { my $o }; # register the idhash for garbage collection with $object register($object, \ %name); # the following entry will be deleted when $object goes out of scope $name{$object} = 'John Doe'; ### Register an ordinary hash for garbage collection use Hash::Util::FieldHash qw(id register); my %name; my $object = \ do { my $o }; # register the hash %name for garbage collection of $object's id register $object, \ %name; # the following entry will be deleted when $object goes out of scope $name{id $object} = 'John Doe'; =head1 FUNCTIONS C offers a number of functions in support of L of class construction. =over =item id id($obj) Returns the reference address of a reference $obj. If $obj is not a reference, returns $obj. This function is a stand-in replacement for L, that is, it returns the reference address of its argument as a numeric value. The only difference is that C returns C when given a non-reference while C returns its argument unchanged. C also uses a caching technique that makes it faster when the id of an object is requested often, but slower if it is needed only once or twice. =item id_2obj $obj = id_2obj($id) If C<$id> is the id of a registered object (see L), returns the object, otherwise an undefined value. For registered objects this is the inverse function of C. =item register register($obj) register($obj, @hashrefs) In the first form, registers an object to work with for the function C. In the second form, it additionally marks the given hashrefs down for garbage collection. This means that when the object goes out of scope, any entries in the given hashes under the key of C will be deleted from the hashes. It is a fatal error to register a non-reference $obj. Any non-hashrefs among the following arguments are silently ignored. It is I an error to register the same object multiple times with varying sets of hashrefs. Any hashrefs that are not registered yet will be added, others ignored. Registry also implies thread support. When a new thread is created, all references are replaced with new ones, including all objects. If a hash uses the reference address of an object as a key, that connection would be broken. With a registered object, its id will be updated in all hashes registered with it. =item idhash idhash my %hash Makes an idhash from the argument, which must be a hash. An I works like a normal hash, except that it stringifies a I differently. A reference is stringified as if the C function had been invoked on it, that is, its reference address in decimal is used as the key. =item idhashes idhashes \ my(%hash, %gnash, %trash) idhashes \ @hashrefs Creates many idhashes from its hashref arguments. Returns those arguments that could be converted or their number in scalar context. =item fieldhash fieldhash %hash; Creates a single fieldhash. The argument must be a hash. Returns a reference to the given hash if successful, otherwise nothing. A I is, in short, an idhash with auto-registry. When an object (or, indeed, any reference) is used as a fieldhash key, the fieldhash is automatically registered for garbage collection with the object, as if C had been called. =item fieldhashes fieldhashes @hashrefs; Creates any number of field hashes. Arguments must be hash references. Returns the converted hashrefs in list context, their number in scalar context. =back =head1 DESCRIPTION A word on terminology: I shall use the term I for a scalar piece of data that a class associates with an object. Other terms that have been used for this concept are "object variable", "(object) property", "(object) attribute" and more. Especially "attribute" has some currency among Perl programmer, but that clashes with the C pragma. The term "field" also has some currency in this sense and doesn't seem to conflict with other Perl terminology. In Perl, an object is a blessed reference. The standard way of associating data with an object is to store the data inside the object's body, that is, the piece of data pointed to by the reference. In consequence, if two or more classes want to access an object they I agree on the type of reference and also on the organization of data within the object body. Failure to agree on the type results in immediate death when the wrong method tries to access an object. Failure to agree on data organization may lead to one class trampling over the data of another. This object model leads to a tight coupling between subclasses. If one class wants to inherit from another (and both classes access object data), the classes must agree about implementation details. Inheritance can only be used among classes that are maintained together, in a single source or not. In particular, it is not possible to write general-purpose classes in this technique, classes that can advertise themselves as "Put me on your @ISA list and use my methods". If the other class has different ideas about how the object body is used, there is trouble. For reference L in L shows the standard implementation of a simple class C in the well-known hash based way. It also demonstrates the predictable failure to construct a common subclass C of C and the class C (whose objects I be globrefs). Thus, techniques are of interest that store object data I in the object body but some other place. =head2 The Inside-out Technique With I classes, each class declares a (typically lexical) hash for each field it wants to use. The reference address of an object is used as the hash key. By definition, the reference address is unique to each object so this guarantees a place for each field that is private to the class and unique to each object. See L in L for a simple example. In comparison to the standard implementation where the object is a hash and the fields correspond to hash keys, here the fields correspond to hashes, and the object determines the hash key. Thus the hashes appear to be turned I. The body of an object is never examined by an inside-out class, only its reference address is used. This allows for the body of an actual object to be I while the object methods of the class still work as designed. This is a key feature of inside-out classes. =head2 Problems of Inside-out Inside-out classes give us freedom of inheritance, but as usual there is a price. Most obviously, there is the necessity of retrieving the reference address of an object for each data access. It's a minor inconvenience, but it does clutter the code. More important (and less obvious) is the necessity of garbage collection. When a normal object dies, anything stored in the object body is garbage-collected by perl. With inside-out objects, Perl knows nothing about the data stored in field hashes by a class, but these must be deleted when the object goes out of scope. Thus the class must provide a C method to take care of that. In the presence of multiple classes it can be non-trivial to make sure that every relevant destructor is called for every object. Perl calls the first one it finds on the inheritance tree (if any) and that's it. A related issue is thread-safety. When a new thread is created, the Perl interpreter is cloned, which implies that all reference addresses in use will be replaced with new ones. Thus, if a class tries to access a field of a cloned object its (cloned) data will still be stored under the now invalid reference address of the original in the parent thread. A general C method must be provided to re-establish the association. =head2 Solutions C addresses these issues on several levels. The C function is provided in addition to the existing C. Besides its short name it can be a little faster under some circumstances (and a bit slower under others). Benchmark if it matters. The working of C also allows the use of the class name as a I as described L. The C function is incorporated in I in the sense that it is called automatically on every key that is used with the hash. No explicit call is necessary. The problems of garbage collection and thread safety are both addressed by the function C. It registers an object together with any number of hashes. Registry means that when the object dies, an entry in any of the hashes under the reference address of this object will be deleted. This guarantees garbage collection in these hashes. It also means that on thread cloning the object's entries in registered hashes will be replaced with updated entries whose key is the cloned object's reference address. Thus the object-data association becomes thread-safe. Object registry is best done when the object is initialized for use with a class. That way, garbage collection and thread safety are established for every object and every field that is initialized. Finally, I incorporate all these functions in one package. Besides automatically calling the C function on every object used as a key, the object is registered with the field hash on first use. Classes based on field hashes are fully garbage-collected and thread safe without further measures. =head2 More Problems Another problem that occurs with inside-out classes is serialization. Since the object data is not in its usual place, standard routines like C, C and C can't deal with it on their own. Both C and C provide the necessary hooks to make things work, but the functions or methods used by the hooks must be provided by each inside-out class. A general solution to the serialization problem would require another level of registry, one that that associates I and fields. So far, the functions of C are unaware of any classes, which I consider a feature. Therefore C doesn't address the serialization problems. =head2 The Generic Object Classes based on the C function (and hence classes based on C and C) show a peculiar behavior in that the class name can be used like an object. Specifically, methods that set or read data associated with an object continue to work as class methods, just as if the class name were an object, distinct from all other objects, with its own data. This object may be called the I of the class. This works because field hashes respond to keys that are not references like a normal hash would and use the string offered as the hash key. Thus, if a method is called as a class method, the field hash is presented with the class name instead of an object and blithely uses it as a key. Since the keys of real objects are decimal numbers, there is no conflict and the slot in the field hash can be used like any other. The C function behaves correspondingly with respect to non-reference arguments. Two possible uses (besides ignoring the property) come to mind. A singleton class could be implemented this using the generic object. If necessary, an C method could die or ignore calls with actual objects (references), so only the generic object will ever exist. Another use of the generic object would be as a template. It is a convenient place to store class-specific defaults for various fields to be used in actual object initialization. Usually, the feature can be entirely ignored. Calling I