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/finished 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 Memory consumption On most systems, frequent and continual creation and destruction of threads can lead to ever-increasing growth in the memory footprint of the Perl interpreter. While it is simple to just launch threads and then C<-Ejoin()> or C<-Edetach()> them, for long-lived applications, it is better to maintain a pool of threads, and to reuse them for the work needed, using L to notify threads of pending work. The CPAN distribution of this module contains a simple example (F) illustrating the creation, use and monitoring of a pool of I threads. =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 Catching signals Signals are I by the main thread (thread ID = 0) of a script. Therefore, setting up signal handlers in threads for purposes other than L as documented above will not accomplish what is intended. This is especially true if trying to catch C in a thread. To handle alarms in threads, set up a signal handler in the main thread, and then use L to relay the signal to the thread: # Create thread with a task that may time out my $thr = threads->create(sub { threads->yield(); eval { $SIG{ALRM} = sub { die("Timeout\n"); }; alarm(10); ... # Do work here alarm(0); }; if ($@ =~ /Timeout/) { warn("Task in thread timed out\n"); } }; # Set signal handler to relay SIGALRM to thread $SIG{ALRM} = sub { $thr->kill('ALRM') }; ... # Main thread continues working =item Parent-child threads On some platforms, it might not be possible to destroy I threads while there are still existing I threads. =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 Identity of objects returned from threads When a value is returned from a thread through a C operation, the value and everything that it references is copied across to the joining thread, in much the same way that values are copied upon thread creation. This works fine for most kinds of value, including arrays, hashes, and subroutines. The copying recurses through array elements, reference scalars, variables closed over by subroutines, and other kinds of reference. However, everything referenced by the returned value is a fresh copy in the joining thread, even if a returned object had in the child thread been a copy of something that previously existed in the parent thread. After joining, the parent will therefore have a duplicate of each such object. This sometimes matters, especially if the object gets mutated; this can especially matter for private data to which a returned subroutine provides access. =item Returning blessed objects from threads Returning blessed 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 Open directory handles In perl 5.14 and higher, on systems other than Windows that do not support the C C function, directory handles (see L) will not be copied to new threads. You can use the C variable in L to determine whether your system supports it. In prior perl versions, spawning threads with open directory handles would crash the interpreter. L<[perl #75154]|http://rt.perl.org/rt3/Public/Bug/Display.html?id=75154> =item Detached threads and global destruction If the main thread exits while there are detached threads which are still running, then Perl's global destruction phase is not executed because otherwise certain global structures that control the operation of threads and that are allocated in the main thread's memory may get destroyed before the detached thread is destroyed. If you are using any code that requires the execution of the global destruction phase for clean up (e.g., removing temp files), then do not use detached threads, but rather join all threads before exiting the program. =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 threads on MetaCPAN: L Code repository for CPAN distribution: L L, L L and L Perl threads mailing list: L Stack size discussion: L Sample code in the I directory of this distribution on CPAN. =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!�����a�aversion/Internals.podnu�[���
=head1 NAME version::Internals - Perl extension for Version Objects =head1 DESCRIPTION Overloaded version objects for all modern versions of Perl. This documents the internal data representation and underlying code for version.pm. See F for daily usage. This document is only useful for users interested in the gory details. =head1 WHAT IS A VERSION? For the purposes of this module, a version "number" is a sequence of positive integer values separated by one or more decimal points and optionally a single underscore. This corresponds to what Perl itself uses for a version, as well as extending the "version as number" that is discussed in the various editions of the Camel book. There are actually two distinct kinds of version objects: =over 4 =item Decimal versions Any version which "looks like a number", see L. This also includes versions with a single decimal point and a single embedded underscore, see L, even though these must be quoted to preserve the underscore formatting. =item Dotted-Decimal versions Also referred to as "Dotted-Integer", these contains more than one decimal point and may have an optional embedded underscore, see L. This is what is commonly used in most open source software as the "external" version (the one used as part of the tag or tarfile name). A leading 'v' character is now required and will warn if it missing. =back Both of these methods will produce similar version objects, in that the default stringification will yield the version L only if required: $v = version->new(1.002); # 1.002, but compares like 1.2.0 $v = version->new(1.002003); # 1.002003 $v2 = version->new("v1.2.3"); # v1.2.3 In specific, version numbers initialized as L will stringify as they were originally created (i.e. the same string that was passed to C. Version numbers initialized as L will be stringified as L. =head2 Decimal Versions These correspond to historical versions of Perl itself prior to 5.6.0, as well as all other modules which follow the Camel rules for the $VERSION scalar. A Decimal version is initialized with what looks like a floating point number. Leading zeros B significant and trailing zeros are implied so that a minimum of three places is maintained between subversions. What this means is that any subversion (digits to the right of the decimal place) that contains less than three digits will have trailing zeros added to make up the difference, but only for purposes of comparison with other version objects. For example: # Prints Equivalent to $v = version->new( 1.2); # 1.2 v1.200.0 $v = version->new( 1.02); # 1.02 v1.20.0 $v = version->new( 1.002); # 1.002 v1.2.0 $v = version->new( 1.0023); # 1.0023 v1.2.300 $v = version->new( 1.00203); # 1.00203 v1.2.30 $v = version->new( 1.002003); # 1.002003 v1.2.3 All of the preceding examples are true whether or not the input value is quoted. The important feature is that the input value contains only a single decimal. See also L. IMPORTANT NOTE: As shown above, if your Decimal version contains more than 3 significant digits after the decimal place, it will be split on each multiple of 3, so 1.0003 is equivalent to v1.0.300, due to the need to remain compatible with Perl's own 5.005_03 == 5.5.30 interpretation. Any trailing zeros are ignored for mathematical comparison purposes. =head2 Dotted-Decimal Versions These are the newest form of versions, and correspond to Perl's own version style beginning with 5.6.0. Starting with Perl 5.10.0, and most likely Perl 6, this is likely to be the preferred form. This method normally requires that the input parameter be quoted, although Perl's after 5.8.1 can use v-strings as a special form of quoting, but this is highly discouraged. Unlike L, Dotted-Decimal Versions have more than a single decimal point, e.g.: # Prints $v = version->new( "v1.200"); # v1.200.0 $v = version->new("v1.20.0"); # v1.20.0 $v = qv("v1.2.3"); # v1.2.3 $v = qv("1.2.3"); # v1.2.3 $v = qv("1.20"); # v1.20.0 In general, Dotted-Decimal Versions permit the greatest amount of freedom to specify a version, whereas Decimal Versions enforce a certain uniformity. Just like L, Dotted-Decimal Versions can be used as L. =head2 Alpha Versions For module authors using CPAN, the convention has been to note unstable releases with an underscore in the version string. (See L.) version.pm follows this convention and alpha releases will test as being newer than the more recent stable release, and less than the next stable release. Only the last element may be separated by an underscore: # Declaring use version 0.77; our $VERSION = version->declare("v1.2_3"); # Parsing $v1 = version->parse("v1.2_3"); $v1 = version->parse("1.002_003"); Note that you B quote the version when writing an alpha Decimal version. The stringified form of Decimal versions will always be the same string that was used to initialize the version object. =head2 Regular Expressions for Version Parsing A formalized definition of the legal forms for version strings is included in the C class. Primitives are included for common elements, although they are scoped to the file so they are useful for reference purposes only. There are two publicly accessible scalars that can be used in other code (not exported): =over 4 =item C<$version::LAX> This regexp covers all of the legal forms allowed under the current version string parser. This is not to say that all of these forms are recommended, and some of them can only be used when quoted. For dotted decimals: v1.2 1.2345.6 v1.23_4 The leading 'v' is optional if two or more decimals appear. If only a single decimal is included, then the leading 'v' is required to trigger the dotted-decimal parsing. A leading zero is permitted, though not recommended except when quoted, because of the risk that Perl will treat the number as octal. A trailing underscore plus one or more digits denotes an alpha or development release (and must be quoted to be parsed properly). For decimal versions: 1 1.2345 1.2345_01 an integer portion, an optional decimal point, and optionally one or more digits to the right of the decimal are all required. A trailing underscore is permitted and a leading zero is permitted. Just like the lax dotted-decimal version, quoting the values is required for alpha/development forms to be parsed correctly. =item C<$version::STRICT> This regexp covers a much more limited set of formats and constitutes the best practices for initializing version objects. Whether you choose to employ decimal or dotted-decimal for is a personal preference however. =over 4 =item v1.234.5 For dotted-decimal versions, a leading 'v' is required, with three or more sub-versions of no more than three digits. A leading 0 (zero) before the first sub-version (in the above example, '1') is also prohibited. =item 2.3456 For decimal versions, an integer portion (no leading 0), a decimal point, and one or more digits to the right of the decimal are all required. =back =back Both of the provided scalars are already compiled as regular expressions and do not contain either anchors or implicit groupings, so they can be included in your own regular expressions freely. For example, consider the following code: ($pkg, $ver) =~ / ^[ \t]* use [ \t]+($PKGNAME) (?:[ \t]+($version::STRICT))? [ \t]*; /x; This would match a line of the form: use Foo::Bar::Baz v1.2.3; # legal only in Perl 5.8.1+ where C<$PKGNAME> is another regular expression that defines the legal forms for package names. =head1 IMPLEMENTATION DETAILS =head2 Equivalence between Decimal and Dotted-Decimal Versions When Perl 5.6.0 was released, the decision was made to provide a transformation between the old-style decimal versions and new-style dotted-decimal versions: 5.6.0 == 5.006000 5.005_04 == 5.5.40 The floating point number is taken and split first on the single decimal place, then each group of three digits to the right of the decimal makes up the next digit, and so on until the number of significant digits is exhausted, B enough trailing zeros to reach the next multiple of three. This was the method that version.pm adopted as well. Some examples may be helpful: equivalent decimal zero-padded dotted-decimal ------- ----------- -------------- 1.2 1.200 v1.200.0 1.02 1.020 v1.20.0 1.002 1.002 v1.2.0 1.0023 1.002300 v1.2.300 1.00203 1.002030 v1.2.30 1.002003 1.002003 v1.2.3 =head2 Quoting Rules Because of the nature of the Perl parsing and tokenizing routines, certain initialization values B be quoted in order to correctly parse as the intended version, especially when using the C or L methods. While you do not have to quote decimal numbers when creating version objects, it is always safe to quote B initial values when using version.pm methods, as this will ensure that what you type is what is used. Additionally, if you quote your initializer, then the quoted value that goes B will be exactly what comes B when your $VERSION is printed (stringified). If you do not quote your value, Perl's normal numeric handling comes into play and you may not get back what you were expecting. If you use a mathematic formula that resolves to a floating point number, you are dependent on Perl's conversion routines to yield the version you expect. You are pretty safe by dividing by a power of 10, for example, but other operations are not likely to be what you intend. For example: $VERSION = version->new((qw$Revision: 1.4)[1]/10); print $VERSION; # yields 0.14 $V2 = version->new(100/9); # Integer overflow in decimal number print $V2; # yields something like 11.111.111.100 Perl 5.8.1 and beyond are able to automatically quote v-strings but that is not possible in earlier versions of Perl. In other words: $version = version->new("v2.5.4"); # legal in all versions of Perl $newvers = version->new(v2.5.4); # legal only in Perl >= 5.8.1 =head2 What about v-strings? There are two ways to enter v-strings: a bare number with two or more decimal points, or a bare number with one or more decimal points and a leading 'v' character (also bare). For example: $vs1 = 1.2.3; # encoded as \1\2\3 $vs2 = v1.2; # encoded as \1\2 However, the use of bare v-strings to initialize version objects is B discouraged in all circumstances. Also, bare v-strings are not completely supported in any version of Perl prior to 5.8.1. If you insist on using bare v-strings with Perl > 5.6.0, be aware of the following limitations: 1) For Perl releases 5.6.0 through 5.8.0, the v-string code merely guesses, based on some characteristics of v-strings. You B use a three part version, e.g. 1.2.3 or v1.2.3 in order for this heuristic to be successful. 2) For Perl releases 5.8.1 and later, v-strings have changed in the Perl core to be magical, which means that the version.pm code can automatically determine whether the v-string encoding was used. 3) In all cases, a version created using v-strings will have a stringified form that has a leading 'v' character, for the simple reason that sometimes it is impossible to tell whether one was present initially. =head2 Version Object Internals version.pm provides an overloaded version object that is designed to both encapsulate the author's intended $VERSION assignment as well as make it completely natural to use those objects as if they were numbers (e.g. for comparisons). To do this, a version object contains both the original representation as typed by the author, as well as a parsed representation to ease comparisons. Version objects employ L methods to simplify code that needs to compare, print, etc the objects. The internal structure of version objects is a blessed hash with several components: bless( { 'original' => 'v1.2.3_4', 'alpha' => 1, 'qv' => 1, 'version' => [ 1, 2, 3, 4 ] }, 'version' ); =over 4 =item original A faithful representation of the value used to initialize this version object. The only time this will not be precisely the same characters that exist in the source file is if a short dotted-decimal version like v1.2 was used (in which case it will contain 'v1.2'). This form is B discouraged, in that it will confuse you and your users. =item qv A boolean that denotes whether this is a decimal or dotted-decimal version. See L. =item alpha A boolean that denotes whether this is an alpha version. NOTE: that the underscore can only appear in the last position. See L. =item version An array of non-negative integers that is used for comparison purposes with other version objects. =back =head2 Replacement UNIVERSAL::VERSION In addition to the version objects, this modules also replaces the core UNIVERSAL::VERSION function with one that uses version objects for its comparisons. The return from this operator is always the stringified form as a simple scalar (i.e. not an object), but the warning message generated includes either the stringified form or the normal form, depending on how it was called. For example: package Foo; $VERSION = 1.2; package Bar; $VERSION = "v1.3.5"; # works with all Perl's (since it is quoted) package main; use version; print $Foo::VERSION; # prints 1.2 print $Bar::VERSION; # prints 1.003005 eval "use foo 10"; print $@; # prints "foo version 10 required..." eval "use foo 1.3.5; # work in Perl 5.6.1 or better print $@; # prints "foo version 1.3.5 required..." eval "use bar 1.3.6"; print $@; # prints "bar version 1.3.6 required..." eval "use bar 1.004"; # note Decimal version print $@; # prints "bar version 1.004 required..." IMPORTANT NOTE: This may mean that code which searches for a specific string (to determine whether a given module is available) may need to be changed. It is always better to use the built-in comparison implicit in C or C, rather than manually poking at C<< class->VERSION >> and then doing a comparison yourself. The replacement UNIVERSAL::VERSION, when used as a function, like this: print $module->VERSION; will also exclusively return the stringified form. See L for more details. =head1 USAGE DETAILS =head2 Using modules that use version.pm As much as possible, the version.pm module remains compatible with all current code. However, if your module is using a module that has defined C<$VERSION> using the version class, there are a couple of things to be aware of. For purposes of discussion, we will assume that we have the following module installed: package Example; use version; $VERSION = qv('1.2.2'); ...module code here... 1; =over 4 =item Decimal versions always work Code of the form: use Example 1.002003; will always work correctly. The C will perform an automatic C<$VERSION> comparison using the floating point number given as the first term after the module name (e.g. above 1.002.003). In this case, the installed module is too old for the requested line, so you would see an error like: Example version 1.002003 (v1.2.3) required--this is only version 1.002002 (v1.2.2)... =item Dotted-Decimal version work sometimes With Perl >= 5.6.2, you can also use a line like this: use Example 1.2.3; and it will again work (i.e. give the error message as above), even with releases of Perl which do not normally support v-strings (see L above). This has to do with that fact that C only checks to see if the second term I and passes that to the replacement L. This is not true in Perl 5.005_04, however, so you are B to always use a Decimal version in your code, even for those versions of Perl which support the Dotted-Decimal version. =back =head2 Object Methods =over 4 =item new() Like many OO interfaces, the new() method is used to initialize version objects. If two arguments are passed to C, the B one will be used as if it were prefixed with "v". This is to support historical use of the C operator with the CVS variable $Revision, which is automatically incremented by CVS every time the file is committed to the repository. In order to facilitate this feature, the following code can be employed: $VERSION = version->new(qw$Revision: 2.7 $); and the version object will be created as if the following code were used: $VERSION = version->new("v2.7"); In other words, the version will be automatically parsed out of the string, and it will be quoted to preserve the meaning CVS normally carries for versions. The CVS $Revision$ increments differently from Decimal versions (i.e. 1.10 follows 1.9), so it must be handled as if it were a Dotted-Decimal Version. A new version object can be created as a copy of an existing version object, either as a class method: $v1 = version->new(12.3); $v2 = version->new($v1); or as an object method: $v1 = version->new(12.3); $v2 = $v1->new(12.3); and in each case, $v1 and $v2 will be identical. NOTE: if you create a new object using an existing object like this: $v2 = $v1->new(); the new object B be a clone of the existing object. In the example case, $v2 will be an empty object of the same type as $v1. =back =over 4 =item qv() An alternate way to create a new version object is through the exported qv() sub. This is not strictly like other q? operators (like qq, qw), in that the only delimiters supported are parentheses (or spaces). It is the best way to initialize a short version without triggering the floating point interpretation. For example: $v1 = qv(1.2); # v1.2.0 $v2 = qv("1.2"); # also v1.2.0 As you can see, either a bare number or a quoted string can usually be used interchangeably, except in the case of a trailing zero, which must be quoted to be converted properly. For this reason, it is strongly recommended that all initializers to qv() be quoted strings instead of bare numbers. To prevent the C function from being exported to the caller's namespace, either use version with a null parameter: use version (); or just require version, like this: require version; Both methods will prevent the import() method from firing and exporting the C sub. =back For the subsequent examples, the following three objects will be used: $ver = version->new("1.2.3.4"); # see "Quoting Rules" $alpha = version->new("1.2.3_4"); # see "Alpha Versions" $nver = version->new(1.002); # see "Decimal Versions" =over 4 =item Normal Form For any version object which is initialized with multiple decimal places (either quoted or if possible v-string), or initialized using the L operator, the stringified representation is returned in a normalized or reduced form (no extraneous zeros), and with a leading 'v': print $ver->normal; # prints as v1.2.3.4 print $ver->stringify; # ditto print $ver; # ditto print $nver->normal; # prints as v1.2.0 print $nver->stringify; # prints as 1.002, # see "Stringification" In order to preserve the meaning of the processed version, the normalized representation will always contain at least three sub terms. In other words, the following is guaranteed to always be true: my $newver = version->new($ver->stringify); if ($newver eq $ver ) # always true {...} =back =over 4 =item Numification Although all mathematical operations on version objects are forbidden by default, it is possible to retrieve a number which corresponds to the version object through the use of the $obj->numify method. For formatting purposes, when displaying a number which corresponds a version object, all sub versions are assumed to have three decimal places. So for example: print $ver->numify; # prints 1.002003004 print $nver->numify; # prints 1.002 Unlike the stringification operator, there is never any need to append trailing zeros to preserve the correct version value. =back =over 4 =item Stringification The default stringification for version objects returns exactly the same string as was used to create it, whether you used C or C, with one exception. The sole exception is if the object was created using C and the initializer did not have two decimal places or a leading 'v' (both optional), then the stringified form will have a leading 'v' prepended, in order to support round-trip processing. For example: Initialized as Stringifies to ============== ============== version->new("1.2") 1.2 version->new("v1.2") v1.2 qv("1.2.3") 1.2.3 qv("v1.3.5") v1.3.5 qv("1.2") v1.2 ### exceptional case See also L, as this also returns the stringified form when used as a class method. IMPORTANT NOTE: There is one exceptional cases shown in the above table where the "initializer" is not stringwise equivalent to the stringified representation. If you use the C() operator on a version without a leading 'v' B with only a single decimal place, the stringified output will have a leading 'v', to preserve the sense. See the L operator for more details. IMPORTANT NOTE 2: Attempting to bypass the normal stringification rules by manually applying L and L will sometimes yield surprising results: print version->new(version->new("v1.0")->numify)->normal; # v1.0.0 The reason for this is that the L operator will turn "v1.0" into the equivalent string "1.000000". Forcing the outer version object to L form will display the mathematically equivalent "v1.0.0". As the example in L shows, you can always create a copy of an existing version object with the same value by the very compact: $v2 = $v1->new($v1); and be assured that both C<$v1> and C<$v2> will be completely equivalent, down to the same internal representation as well as stringification. =back =over 4 =item Comparison operators Both C and C=E> operators perform the same comparison between terms (upgrading to a version object automatically). Perl automatically generates all of the other comparison operators based on those two. In addition to the obvious equalities listed below, appending a single trailing 0 term does not change the value of a version for comparison purposes. In other words "v1.2" and "1.2.0" will compare as identical. For example, the following relations hold: As Number As String Truth Value ------------- ---------------- ----------- $ver > 1.0 $ver gt "1.0" true $ver < 2.5 $ver lt true $ver != 1.3 $ver ne "1.3" true $ver == 1.2 $ver eq "1.2" false $ver == 1.2.3.4 $ver eq "1.2.3.4" see discussion below It is probably best to chose either the Decimal notation or the string notation and stick with it, to reduce confusion. Perl6 version objects B only support Decimal comparisons. See also L. WARNING: Comparing version with unequal numbers of decimal points (whether explicitly or implicitly initialized), may yield unexpected results at first glance. For example, the following inequalities hold: version->new(0.96) > version->new(0.95); # 0.960.0 > 0.950.0 version->new("0.96.1") < version->new(0.95); # 0.096.1 < 0.950.0 For this reason, it is best to use either exclusively L or L with multiple decimal points. =back =over 4 =item Logical Operators If you need to test whether a version object has been initialized, you can simply test it directly: $vobj = version->new($something); if ( $vobj ) # true only if $something was non-blank You can also test whether a version object is an alpha version, for example to prevent the use of some feature not present in the main release: $vobj = version->new("1.2_3"); # MUST QUOTE ...later... if ( $vobj->is_alpha ) # True =back =head1 AUTHOR John Peacock Ejpeacock@cpan.orgE =head1 SEE ALSO L. =cut PK!E���
�
version/vxs.pmnu�[���
#!perl -w package version::vxs; use v5.10; use strict; our $VERSION = 0.9924; our $CLASS = 'version::vxs'; our @ISA; eval { require XSLoader; local $^W; # shut up the 'redefined' warning for UNIVERSAL::VERSION XSLoader::load('version::vxs', $VERSION); 1; } or do { require DynaLoader; push @ISA, 'DynaLoader'; local $^W; # shut up the 'redefined' warning for UNIVERSAL::VERSION bootstrap version::vxs $VERSION; }; # Preloaded methods go here. 1; PK!�N�kgUgUversion/vpp.pmnu�[���
package charstar; # a little helper class to emulate C char* semantics in Perl # so that prescan_version can use the same code as in C use overload ( '""' => \&thischar, '0+' => \&thischar, '++' => \&increment, '--' => \&decrement, '+' => \&plus, '-' => \&minus, '*' => \&multiply, 'cmp' => \&cmp, '<=>' => \&spaceship, 'bool' => \&thischar, '=' => \&clone, ); sub new { my ($self, $string) = @_; my $class = ref($self) || $self; my $obj = { string => [split(//,$string)], current => 0, }; return bless $obj, $class; } sub thischar { my ($self) = @_; my $last = $#{$self->{string}}; my $curr = $self->{current}; if ($curr >= 0 && $curr <= $last) { return $self->{string}->[$curr]; } else { return ''; } } sub increment { my ($self) = @_; $self->{current}++; } sub decrement { my ($self) = @_; $self->{current}--; } sub plus { my ($self, $offset) = @_; my $rself = $self->clone; $rself->{current} += $offset; return $rself; } sub minus { my ($self, $offset) = @_; my $rself = $self->clone; $rself->{current} -= $offset; return $rself; } sub multiply { my ($left, $right, $swapped) = @_; my $char = $left->thischar(); return $char * $right; } sub spaceship { my ($left, $right, $swapped) = @_; unless (ref($right)) { # not an object already $right = $left->new($right); } return $left->{current} <=> $right->{current}; } sub cmp { my ($left, $right, $swapped) = @_; unless (ref($right)) { # not an object already if (length($right) == 1) { # comparing single character only return $left->thischar cmp $right; } $right = $left->new($right); } return $left->currstr cmp $right->currstr; } sub bool { my ($self) = @_; my $char = $self->thischar; return ($char ne ''); } sub clone { my ($left, $right, $swapped) = @_; $right = { string => [@{$left->{string}}], current => $left->{current}, }; return bless $right, ref($left); } sub currstr { my ($self, $s) = @_; my $curr = $self->{current}; my $last = $#{$self->{string}}; if (defined($s) && $s->{current} < $last) { $last = $s->{current}; } my $string = join('', @{$self->{string}}[$curr..$last]); return $string; } package version::vpp; use 5.006002; use strict; use warnings::register; use Config; our $VERSION = 0.9924; our $CLASS = 'version::vpp'; our ($LAX, $STRICT, $WARN_CATEGORY); if ($] > 5.015) { warnings::register_categories(qw/version/); $WARN_CATEGORY = 'version'; } else { $WARN_CATEGORY = 'numeric'; } require version::regex; *version::vpp::is_strict = \&version::regex::is_strict; *version::vpp::is_lax = \&version::regex::is_lax; *LAX = \$version::regex::LAX; *STRICT = \$version::regex::STRICT; use overload ( '""' => \&stringify, '0+' => \&numify, 'cmp' => \&vcmp, '<=>' => \&vcmp, 'bool' => \&vbool, '+' => \&vnoop, '-' => \&vnoop, '*' => \&vnoop, '/' => \&vnoop, '+=' => \&vnoop, '-=' => \&vnoop, '*=' => \&vnoop, '/=' => \&vnoop, 'abs' => \&vnoop, ); sub import { no strict 'refs'; my ($class) = shift; # Set up any derived class unless ($class eq $CLASS) { local $^W; *{$class.'::declare'} = \&{$CLASS.'::declare'}; *{$class.'::qv'} = \&{$CLASS.'::qv'}; } my %args; if (@_) { # any remaining terms are arguments map { $args{$_} = 1 } @_ } else { # no parameters at all on use line %args = ( qv => 1, 'UNIVERSAL::VERSION' => 1, ); } my $callpkg = caller(); if (exists($args{declare})) { *{$callpkg.'::declare'} = sub {return $class->declare(shift) } unless defined(&{$callpkg.'::declare'}); } if (exists($args{qv})) { *{$callpkg.'::qv'} = sub {return $class->qv(shift) } unless defined(&{$callpkg.'::qv'}); } if (exists($args{'UNIVERSAL::VERSION'})) { no warnings qw/redefine/; *UNIVERSAL::VERSION = \&{$CLASS.'::_VERSION'}; } if (exists($args{'VERSION'})) { *{$callpkg.'::VERSION'} = \&{$CLASS.'::_VERSION'}; } if (exists($args{'is_strict'})) { *{$callpkg.'::is_strict'} = \&{$CLASS.'::is_strict'} unless defined(&{$callpkg.'::is_strict'}); } if (exists($args{'is_lax'})) { *{$callpkg.'::is_lax'} = \&{$CLASS.'::is_lax'} unless defined(&{$callpkg.'::is_lax'}); } } my $VERSION_MAX = 0x7FFFFFFF; # implement prescan_version as closely to the C version as possible use constant TRUE => 1; use constant FALSE => 0; sub isDIGIT { my ($char) = shift->thischar(); return ($char =~ /\d/); } sub isALPHA { my ($char) = shift->thischar(); return ($char =~ /[a-zA-Z]/); } sub isSPACE { my ($char) = shift->thischar(); return ($char =~ /\s/); } sub BADVERSION { my ($s, $errstr, $error) = @_; if ($errstr) { $$errstr = $error; } return $s; } sub prescan_version { my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_; my $qv = defined $sqv ? $$sqv : FALSE; my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0; my $width = defined $swidth ? $$swidth : 3; my $alpha = defined $salpha ? $$salpha : FALSE; my $d = $s; if ($qv && isDIGIT($d)) { goto dotted_decimal_version; } if ($d eq 'v') { # explicit v-string $d++; if (isDIGIT($d)) { $qv = TRUE; } else { # degenerate v-string # requires v1.2.3 return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); } dotted_decimal_version: if ($strict && $d eq '0' && isDIGIT($d+1)) { # no leading zeros allowed return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)"); } while (isDIGIT($d)) { # integer part $d++; } if ($d eq '.') { $saw_decimal++; $d++; # decimal point } else { if ($strict) { # require v1.2.3 return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); } else { goto version_prescan_finish; } } { my $i = 0; my $j = 0; while (isDIGIT($d)) { # just keep reading $i++; while (isDIGIT($d)) { $d++; $j++; # maximum 3 digits between decimal if ($strict && $j > 3) { return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)"); } } if ($d eq '_') { if ($strict) { return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); } if ( $alpha ) { return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)"); } $d++; $alpha = TRUE; } elsif ($d eq '.') { if ($alpha) { return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)"); } $saw_decimal++; $d++; } elsif (!isDIGIT($d)) { last; } $j = 0; } if ($strict && $i < 2) { # requires v1.2.3 return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); } } } # end if dotted-decimal else { # decimal versions my $j = 0; # special $strict case for leading '.' or '0' if ($strict) { if ($d eq '.') { return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)"); } if ($d eq '0' && isDIGIT($d+1)) { return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)"); } } # and we never support negative version numbers if ($d eq '-') { return BADVERSION($s,$errstr,"Invalid version format (negative version number)"); } # consume all of the integer part while (isDIGIT($d)) { $d++; } # look for a fractional part if ($d eq '.') { # we found it, so consume it $saw_decimal++; $d++; } elsif (!$d || $d eq ';' || isSPACE($d) || $d eq '}') { if ( $d == $s ) { # found nothing return BADVERSION($s,$errstr,"Invalid version format (version required)"); } # found just an integer goto version_prescan_finish; } elsif ( $d == $s ) { # didn't find either integer or period return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); } elsif ($d eq '_') { # underscore can't come after integer part if ($strict) { return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); } elsif (isDIGIT($d+1)) { return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)"); } else { return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)"); } } elsif ($d) { # anything else after integer part is just invalid data return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); } # scan the fractional part after the decimal point if ($d && !isDIGIT($d) && ($strict || ! ($d eq ';' || isSPACE($d) || $d eq '}') )) { # $strict or lax-but-not-the-end return BADVERSION($s,$errstr,"Invalid version format (fractional part required)"); } while (isDIGIT($d)) { $d++; $j++; if ($d eq '.' && isDIGIT($d-1)) { if ($alpha) { return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)"); } if ($strict) { return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')"); } $d = $s; # start all over again $qv = TRUE; goto dotted_decimal_version; } if ($d eq '_') { if ($strict) { return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); } if ( $alpha ) { return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)"); } if ( ! isDIGIT($d+1) ) { return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)"); } $width = $j; $d++; $alpha = TRUE; } } } version_prescan_finish: while (isSPACE($d)) { $d++; } if ($d && !isDIGIT($d) && (! ($d eq ';' || $d eq '}') )) { # trailing non-numeric data return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); } if ($saw_decimal > 1 && ($d-1) eq '.') { # no trailing period allowed return BADVERSION($s,$errstr,"Invalid version format (trailing decimal)"); } if (defined $sqv) { $$sqv = $qv; } if (defined $swidth) { $$swidth = $width; } if (defined $ssaw_decimal) { $$ssaw_decimal = $saw_decimal; } if (defined $salpha) { $$salpha = $alpha; } return $d; } sub scan_version { my ($s, $rv, $qv) = @_; my $start; my $pos; my $last; my $errstr; my $saw_decimal = 0; my $width = 3; my $alpha = FALSE; my $vinf = FALSE; my @av; $s = new charstar $s; while (isSPACE($s)) { # leading whitespace is OK $s++; } $last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal, \$width, \$alpha); if ($errstr) { # 'undef' is a special case and not an error if ( $s ne 'undef') { require Carp; Carp::croak($errstr); } } $start = $s; if ($s eq 'v') { $s++; } $pos = $s; if ( $qv ) { $$rv->{qv} = $qv; } if ( $alpha ) { $$rv->{alpha} = $alpha; } if ( !$qv && $width < 3 ) { $$rv->{width} = $width; } while (isDIGIT($pos) || $pos eq '_') { $pos++; } if (!isALPHA($pos)) { my $rev; for (;;) { $rev = 0; { # this is atoi() that delimits on underscores my $end = $pos; my $mult = 1; my $orev; # the following if() will only be true after the decimal # point of a version originally created with a bare # floating point number, i.e. not quoted in any way # if ( !$qv && $s > $start && $saw_decimal == 1 ) { $mult *= 100; while ( $s < $end ) { next if $s eq '_'; $orev = $rev; $rev += $s * $mult; $mult /= 10; if ( (abs($orev) > abs($rev)) || (abs($rev) > $VERSION_MAX )) { warn("Integer overflow in version %d", $VERSION_MAX); $s = $end - 1; $rev = $VERSION_MAX; $vinf = 1; } $s++; if ( $s eq '_' ) { $s++; } } } else { while (--$end >= $s) { next if $end eq '_'; $orev = $rev; $rev += $end * $mult; $mult *= 10; if ( (abs($orev) > abs($rev)) || (abs($rev) > $VERSION_MAX )) { warn("Integer overflow in version"); $end = $s - 1; $rev = $VERSION_MAX; $vinf = 1; } } } } # Append revision push @av, $rev; if ( $vinf ) { $s = $last; last; } elsif ( $pos eq '.' ) { $s = ++$pos; } elsif ( $pos eq '_' && isDIGIT($pos+1) ) { $s = ++$pos; } elsif ( $pos eq ',' && isDIGIT($pos+1) ) { $s = ++$pos; } elsif ( isDIGIT($pos) ) { $s = $pos; } else { $s = $pos; last; } if ( $qv ) { while ( isDIGIT($pos) || $pos eq '_') { $pos++; } } else { my $digits = 0; while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) { if ( $pos ne '_' ) { $digits++; } $pos++; } } } } if ( $qv ) { # quoted versions always get at least three terms my $len = $#av; # This for loop appears to trigger a compiler bug on OS X, as it # loops infinitely. Yes, len is negative. No, it makes no sense. # Compiler in question is: # gcc version 3.3 20030304 (Apple Computer, Inc. build 1640) # for ( len = 2 - len; len > 0; len-- ) # av_push(MUTABLE_AV(sv), newSViv(0)); # $len = 2 - $len; while ($len-- > 0) { push @av, 0; } } # need to save off the current version string for later if ( $vinf ) { $$rv->{original} = "v.Inf"; $$rv->{vinf} = 1; } elsif ( $s > $start ) { $$rv->{original} = $start->currstr($s); if ( $qv && $saw_decimal == 1 && $start ne 'v' ) { # need to insert a v to be consistent $$rv->{original} = 'v' . $$rv->{original}; } } else { $$rv->{original} = '0'; push(@av, 0); } # And finally, store the AV in the hash $$rv->{version} = \@av; # fix RT#19517 - special case 'undef' as string if ($s eq 'undef') { $s += 5; } return $s; } sub new { my $class = shift; unless (defined $class or $#_ > 1) { require Carp; Carp::croak('Usage: version::new(class, version)'); } my $self = bless ({}, ref ($class) || $class); my $qv = FALSE; if ( $#_ == 1 ) { # must be CVS-style $qv = TRUE; } my $value = pop; # always going to be the last element if ( ref($value) && eval('$value->isa("version")') ) { # Can copy the elements directly $self->{version} = [ @{$value->{version} } ]; $self->{qv} = 1 if $value->{qv}; $self->{alpha} = 1 if $value->{alpha}; $self->{original} = ''.$value->{original}; return $self; } if ( not defined $value or $value =~ /^undef$/ ) { # RT #19517 - special case for undef comparison # or someone forgot to pass a value push @{$self->{version}}, 0; $self->{original} = "0"; return ($self); } if (ref($value) =~ m/ARRAY|HASH/) { require Carp; Carp::croak("Invalid version format (non-numeric data)"); } $value = _un_vstring($value); if ($Config{d_setlocale}) { use POSIX qw/locale_h/; use if $Config{d_setlocale}, 'locale'; my $currlocale = setlocale(LC_ALL); # if the current locale uses commas for decimal points, we # just replace commas with decimal places, rather than changing # locales if ( localeconv()->{decimal_point} eq ',' ) { $value =~ tr/,/./; } } # exponential notation if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) { $value = sprintf("%.9f",$value); $value =~ s/(0+)$//; # trim trailing zeros } my $s = scan_version($value, \$self, $qv); if ($s) { # must be something left over warn(sprintf "Version string '%s' contains invalid data; " ."ignoring: '%s'", $value, $s); } return ($self); } *parse = \&new; sub numify { my ($self) = @_; unless (_verify($self)) { require Carp; Carp::croak("Invalid version object"); } my $alpha = $self->{alpha} || ""; my $len = $#{$self->{version}}; my $digit = $self->{version}[0]; my $string = sprintf("%d.", $digit ); if ($alpha and warnings::enabled()) { warnings::warn($WARN_CATEGORY, 'alpha->numify() is lossy'); } for ( my $i = 1 ; $i <= $len ; $i++ ) { $digit = $self->{version}[$i]; $string .= sprintf("%03d", $digit); } if ( $len == 0 ) { $string .= sprintf("000"); } return $string; } sub normal { my ($self) = @_; unless (_verify($self)) { require Carp; Carp::croak("Invalid version object"); } my $len = $#{$self->{version}}; my $digit = $self->{version}[0]; my $string = sprintf("v%d", $digit ); for ( my $i = 1 ; $i <= $len ; $i++ ) { $digit = $self->{version}[$i]; $string .= sprintf(".%d", $digit); } if ( $len <= 2 ) { for ( $len = 2 - $len; $len != 0; $len-- ) { $string .= sprintf(".%0d", 0); } } return $string; } sub stringify { my ($self) = @_; unless (_verify($self)) { require Carp; Carp::croak("Invalid version object"); } return exists $self->{original} ? $self->{original} : exists $self->{qv} ? $self->normal : $self->numify; } sub vcmp { my ($left,$right,$swap) = @_; my $class = ref($left); unless ( UNIVERSAL::isa($right, $class) ) { $right = $class->new($right); } if ( $swap ) { ($left, $right) = ($right, $left); } unless (_verify($left)) { require Carp; Carp::croak("Invalid version object"); } unless (_verify($right)) { require Carp; Carp::croak("Invalid version format"); } my $l = $#{$left->{version}}; my $r = $#{$right->{version}}; my $m = $l < $r ? $l : $r; my $lalpha = $left->is_alpha; my $ralpha = $right->is_alpha; my $retval = 0; my $i = 0; while ( $i <= $m && $retval == 0 ) { $retval = $left->{version}[$i] <=> $right->{version}[$i]; $i++; } # possible match except for trailing 0's if ( $retval == 0 && $l != $r ) { if ( $l < $r ) { while ( $i <= $r && $retval == 0 ) { if ( $right->{version}[$i] != 0 ) { $retval = -1; # not a match after all } $i++; } } else { while ( $i <= $l && $retval == 0 ) { if ( $left->{version}[$i] != 0 ) { $retval = +1; # not a match after all } $i++; } } } return $retval; } sub vbool { my ($self) = @_; return vcmp($self,$self->new("0"),1); } sub vnoop { require Carp; Carp::croak("operation not supported with version object"); } sub is_alpha { my ($self) = @_; return (exists $self->{alpha}); } sub qv { my $value = shift; my $class = $CLASS; if (@_) { $class = ref($value) || $value; $value = shift; } $value = _un_vstring($value); $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/; my $obj = $CLASS->new($value); return bless $obj, $class; } *declare = \&qv; sub is_qv { my ($self) = @_; return (exists $self->{qv}); } sub _verify { my ($self) = @_; if ( ref($self) && eval { exists $self->{version} } && ref($self->{version}) eq 'ARRAY' ) { return 1; } else { return 0; } } sub _is_non_alphanumeric { my $s = shift; $s = new charstar $s; while ($s) { return 0 if isSPACE($s); # early out return 1 unless (isALPHA($s) || isDIGIT($s) || $s =~ /[.-]/); $s++; } return 0; } sub _un_vstring { my $value = shift; # may be a v-string if ( length($value) >= 1 && $value !~ /[,._]/ && _is_non_alphanumeric($value)) { my $tvalue; if ( $] >= 5.008_001 ) { $tvalue = _find_magic_vstring($value); $value = $tvalue if length $tvalue; } elsif ( $] >= 5.006_000 ) { $tvalue = sprintf("v%vd",$value); if ( $tvalue =~ /^v\d+(\.\d+)*$/ ) { # must be a v-string $value = $tvalue; } } } return $value; } sub _find_magic_vstring { my $value = shift; my $tvalue = ''; require B; my $sv = B::svref_2object(\$value); my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef; while ( $magic ) { if ( $magic->TYPE eq 'V' ) { $tvalue = $magic->PTR; $tvalue =~ s/^v?(.+)$/v$1/; last; } else { $magic = $magic->MOREMAGIC; } } $tvalue =~ tr/_//d; return $tvalue; } sub _VERSION { my ($obj, $req) = @_; my $class = ref($obj) || $obj; no strict 'refs'; if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) { # file but no package require Carp; Carp::croak( "$class defines neither package nor VERSION" ."--version check failed"); } my $version = eval "\$$class\::VERSION"; if ( defined $version ) { local $^W if $] <= 5.008; $version = version::vpp->new($version); } if ( defined $req ) { unless ( defined $version ) { require Carp; my $msg = $] < 5.006 ? "$class version $req required--this is only version " : "$class does not define \$$class\::VERSION" ."--version check failed"; if ( $ENV{VERSION_DEBUG} ) { Carp::confess($msg); } else { Carp::croak($msg); } } $req = version::vpp->new($req); if ( $req > $version ) { require Carp; if ( $req->is_qv ) { Carp::croak( sprintf ("%s version %s required--". "this is only version %s", $class, $req->normal, $version->normal) ); } else { Carp::croak( sprintf ("%s version %s required--". "this is only version %s", $class, $req->stringify, $version->stringify) ); } } } return defined $version ? $version->stringify : undef; } 1; #this line is important and will help the module return a true value PK!L7���version/regex.pmnu�[���
package version::regex; use strict; our $VERSION = 0.9924; #--------------------------------------------------------------------------# # Version regexp components #--------------------------------------------------------------------------# # Fraction part of a decimal version number. This is a common part of # both strict and lax decimal versions my $FRACTION_PART = qr/\.[0-9]+/; # First part of either decimal or dotted-decimal strict version number. # Unsigned integer with no leading zeroes (except for zero itself) to # avoid confusion with octal. my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/; # First part of either decimal or dotted-decimal lax version number. # Unsigned integer, but allowing leading zeros. Always interpreted # as decimal. However, some forms of the resulting syntax give odd # results if used as ordinary Perl expressions, due to how perl treats # octals. E.g. # version->new("010" ) == 10 # version->new( 010 ) == 8 # version->new( 010.2) == 82 # "8" . "2" my $LAX_INTEGER_PART = qr/[0-9]+/; # Second and subsequent part of a strict dotted-decimal version number. # Leading zeroes are permitted, and the number is always decimal. # Limited to three digits to avoid overflow when converting to decimal # form and also avoid problematic style with excessive leading zeroes. my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/; # Second and subsequent part of a lax dotted-decimal version number. # Leading zeroes are permitted, and the number is always decimal. No # limit on the numerical value or number of digits, so there is the # possibility of overflow when converting to decimal form. my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/; # Alpha suffix part of lax version number syntax. Acts like a # dotted-decimal part. my $LAX_ALPHA_PART = qr/_[0-9]+/; #--------------------------------------------------------------------------# # Strict version regexp definitions #--------------------------------------------------------------------------# # Strict decimal version number. our $STRICT_DECIMAL_VERSION = qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x; # Strict dotted-decimal version number. Must have both leading "v" and # at least three parts, to avoid confusion with decimal syntax. our $STRICT_DOTTED_DECIMAL_VERSION = qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x; # Complete strict version number syntax -- should generally be used # anchored: qr/ \A $STRICT \z /x our $STRICT = qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x; #--------------------------------------------------------------------------# # Lax version regexp definitions #--------------------------------------------------------------------------# # Lax decimal version number. Just like the strict one except for # allowing an alpha suffix or allowing a leading or trailing # decimal-point our $LAX_DECIMAL_VERSION = qr/ $LAX_INTEGER_PART (?: $FRACTION_PART | \. )? $LAX_ALPHA_PART? | $FRACTION_PART $LAX_ALPHA_PART? /x; # Lax dotted-decimal version number. Distinguished by having either # leading "v" or at least three non-alpha parts. Alpha part is only # permitted if there are at least two non-alpha parts. Strangely # enough, without the leading "v", Perl takes .1.2 to mean v0.1.2, # so when there is no "v", the leading part is optional our $LAX_DOTTED_DECIMAL_VERSION = qr/ v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )? | $LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART? /x; # Complete lax version number syntax -- should generally be used # anchored: qr/ \A $LAX \z /x # # The string 'undef' is a special case to make for easier handling # of return values from ExtUtils::MM->parse_version our $LAX = qr/ undef | $LAX_DOTTED_DECIMAL_VERSION | $LAX_DECIMAL_VERSION /x; #--------------------------------------------------------------------------# # Preloaded methods go here. sub is_strict { defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x } sub is_lax { defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x } 1; PK!F��0'U'UCwd.pmnu�[���
package Cwd; use strict; use Exporter; our $VERSION = '3.74'; my $xs_version = $VERSION; $VERSION =~ tr/_//d; our @ISA = qw/ Exporter /; our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd); push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32'; our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); # sys_cwd may keep the builtin command # All the functionality of this module may provided by builtins, # there is no sense to process the rest of the file. # The best choice may be to have this in BEGIN, but how to return from BEGIN? if ($^O eq 'os2') { local $^W = 0; *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; *getcwd = \&cwd; *fastgetcwd = \&cwd; *fastcwd = \&cwd; *fast_abs_path = \&sys_abspath if defined &sys_abspath; *abs_path = \&fast_abs_path; *realpath = \&fast_abs_path; *fast_realpath = \&fast_abs_path; return 1; } # Need to look up the feature settings on VMS. The preferred way is to use the # VMS::Feature module, but that may not be available to dual life modules. my $use_vms_feature; BEGIN { if ($^O eq 'VMS') { if (eval { local $SIG{__DIE__}; local @INC = @INC; pop @INC if $INC[-1] eq '.'; require VMS::Feature; }) { $use_vms_feature = 1; } } } # Need to look up the UNIX report mode. This may become a dynamic mode # in the future. sub _vms_unix_rpt { my $unix_rpt; if ($use_vms_feature) { $unix_rpt = VMS::Feature::current("filename_unix_report"); } else { my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; } return $unix_rpt; } # Need to look up the EFS character set mode. This may become a dynamic # mode in the future. sub _vms_efs { my $efs; if ($use_vms_feature) { $efs = VMS::Feature::current("efs_charset"); } else { my $env_efs = $ENV{'DECC$EFS_CHARSET'} || ''; $efs = $env_efs =~ /^[ET1]/i; } return $efs; } # If loading the XS stuff doesn't work, we can fall back to pure perl if(! defined &getcwd && defined &DynaLoader::boot_DynaLoader) { # skipped on miniperl require XSLoader; XSLoader::load( __PACKAGE__, $xs_version); } # Big nasty table of function aliases my %METHOD_MAP = ( VMS => { cwd => '_vms_cwd', getcwd => '_vms_cwd', fastcwd => '_vms_cwd', fastgetcwd => '_vms_cwd', abs_path => '_vms_abs_path', fast_abs_path => '_vms_abs_path', }, MSWin32 => { # We assume that &_NT_cwd is defined as an XSUB or in the core. cwd => '_NT_cwd', getcwd => '_NT_cwd', fastcwd => '_NT_cwd', fastgetcwd => '_NT_cwd', abs_path => 'fast_abs_path', realpath => 'fast_abs_path', }, dos => { cwd => '_dos_cwd', getcwd => '_dos_cwd', fastgetcwd => '_dos_cwd', fastcwd => '_dos_cwd', abs_path => 'fast_abs_path', }, # QNX4. QNX6 has a $os of 'nto'. qnx => { cwd => '_qnx_cwd', getcwd => '_qnx_cwd', fastgetcwd => '_qnx_cwd', fastcwd => '_qnx_cwd', abs_path => '_qnx_abs_path', fast_abs_path => '_qnx_abs_path', }, cygwin => { getcwd => 'cwd', fastgetcwd => 'cwd', fastcwd => 'cwd', abs_path => 'fast_abs_path', realpath => 'fast_abs_path', }, amigaos => { getcwd => '_backtick_pwd', fastgetcwd => '_backtick_pwd', fastcwd => '_backtick_pwd', abs_path => 'fast_abs_path', } ); $METHOD_MAP{NT} = $METHOD_MAP{MSWin32}; # Find the pwd command in the expected locations. We assume these # are safe. This prevents _backtick_pwd() consulting $ENV{PATH} # so everything works under taint mode. my $pwd_cmd; if($^O ne 'MSWin32') { foreach my $try ('/bin/pwd', '/usr/bin/pwd', '/QOpenSys/bin/pwd', # OS/400 PASE. ) { if( -x $try ) { $pwd_cmd = $try; last; } } } # Android has a built-in pwd. Using $pwd_cmd will DTRT if # this perl was compiled with -Dd_useshellcmds, which is the # default for Android, but the block below is needed for the # miniperl running on the host when cross-compiling, and # potentially for native builds with -Ud_useshellcmds. if ($^O =~ /android/) { # If targetsh is executable, then we're either a full # perl, or a miniperl for a native build. if (-x $Config::Config{targetsh}) { $pwd_cmd = "$Config::Config{targetsh} -c pwd" } else { my $sh = $Config::Config{sh} || (-x '/system/bin/sh' ? '/system/bin/sh' : 'sh'); $pwd_cmd = "$sh -c pwd" } } my $found_pwd_cmd = defined($pwd_cmd); unless ($pwd_cmd) { # Isn't this wrong? _backtick_pwd() will fail if someone has # pwd in their path but it is not /bin/pwd or /usr/bin/pwd? # See [perl #16774]. --jhi $pwd_cmd = 'pwd'; } # Lazy-load Carp sub _carp { require Carp; Carp::carp(@_) } sub _croak { require Carp; Carp::croak(@_) } # The 'natural and safe form' for UNIX (pwd may be setuid root) sub _backtick_pwd { # Localize %ENV entries in a way that won't create new hash keys. # Under AmigaOS we don't want to localize as it stops perl from # finding 'sh' in the PATH. my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV) if $^O ne "amigaos"; local @ENV{@localize} if @localize; my $cwd = `$pwd_cmd`; # Belt-and-suspenders in case someone said "undef $/". local $/ = "\n"; # `pwd` may fail e.g. if the disk is full chomp($cwd) if defined $cwd; $cwd; } # Since some ports may predefine cwd internally (e.g., NT) # we take care not to override an existing definition for cwd(). unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) { # The pwd command is not available in some chroot(2)'ed environments my $sep = $Config::Config{path_sep} || ':'; my $os = $^O; # Protect $^O from tainting # Try again to find a pwd, this time searching the whole PATH. if (defined $ENV{PATH} and $os ne 'MSWin32') { # no pwd on Windows my @candidates = split($sep, $ENV{PATH}); while (!$found_pwd_cmd and @candidates) { my $candidate = shift @candidates; $found_pwd_cmd = 1 if -x "$candidate/pwd"; } } if( $found_pwd_cmd ) { *cwd = \&_backtick_pwd; } else { *cwd = \&getcwd; } } if ($^O eq 'cygwin') { # We need to make sure cwd() is called with no args, because it's # got an arg-less prototype and will die if args are present. local $^W = 0; my $orig_cwd = \&cwd; *cwd = sub { &$orig_cwd() } } # set a reasonable (and very safe) default for fastgetcwd, in case it # isn't redefined later (20001212 rspier) *fastgetcwd = \&cwd; # A non-XS version of getcwd() - also used to bootstrap the perl build # process, when miniperl is running and no XS loading happens. sub _perl_getcwd { abs_path('.'); } # By John Bazik # # Usage: $cwd = &fastcwd; # # This is a faster version of getcwd. It's also more dangerous because # you might chdir out of a directory that you can't chdir back into. sub fastcwd_ { my($odev, $oino, $cdev, $cino, $tdev, $tino); my(@path, $path); local(*DIR); my($orig_cdev, $orig_cino) = stat('.'); ($cdev, $cino) = ($orig_cdev, $orig_cino); for (;;) { my $direntry; ($odev, $oino) = ($cdev, $cino); CORE::chdir('..') || return undef; ($cdev, $cino) = stat('.'); last if $odev == $cdev && $oino == $cino; opendir(DIR, '.') || return undef; for (;;) { $direntry = readdir(DIR); last unless defined $direntry; next if $direntry eq '.'; next if $direntry eq '..'; ($tdev, $tino) = lstat($direntry); last unless $tdev != $odev || $tino != $oino; } closedir(DIR); return undef unless defined $direntry; # should never happen unshift(@path, $direntry); } $path = '/' . join('/', @path); if ($^O eq 'apollo') { $path = "/".$path; } # At this point $path may be tainted (if tainting) and chdir would fail. # Untaint it then check that we landed where we started. $path =~ /^(.*)\z/s # untaint && CORE::chdir($1) or return undef; ($cdev, $cino) = stat('.'); die "Unstable directory path, current directory changed unexpectedly" if $cdev != $orig_cdev || $cino != $orig_cino; $path; } if (not defined &fastcwd) { *fastcwd = \&fastcwd_ } # Keeps track of current working directory in PWD environment var # Usage: # use Cwd 'chdir'; # chdir $newdir; my $chdir_init = 0; sub chdir_init { if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') { my($dd,$di) = stat('.'); my($pd,$pi) = stat($ENV{'PWD'}); if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { $ENV{'PWD'} = cwd(); } } else { my $wd = cwd(); $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32'; $ENV{'PWD'} = $wd; } # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar) if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) { my($pd,$pi) = stat($2); my($dd,$di) = stat($1); if (defined $pd and defined $dd and $di == $pi and $dd == $pd) { $ENV{'PWD'}="$2$3"; } } $chdir_init = 1; } sub chdir { my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir) if ($^O eq "cygwin") { $newdir =~ s|\A///+|//|; $newdir =~ s|(?<=[^/])//+|/|g; } elsif ($^O ne 'MSWin32') { $newdir =~ s|///*|/|g; } chdir_init() unless $chdir_init; my $newpwd; if ($^O eq 'MSWin32') { # get the full path name *before* the chdir() $newpwd = Win32::GetFullPathName($newdir); } return 0 unless CORE::chdir $newdir; if ($^O eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} } elsif ($^O eq 'MSWin32') { $ENV{'PWD'} = $newpwd; return 1; } if (ref $newdir eq 'GLOB') { # in case a file/dir handle is passed in $ENV{'PWD'} = cwd(); } elsif ($newdir =~ m#^/#s) { $ENV{'PWD'} = $newdir; } else { my @curdir = split(m#/#,$ENV{'PWD'}); @curdir = ('') unless @curdir; my $component; foreach $component (split(m#/#, $newdir)) { next if $component eq '.'; pop(@curdir),next if $component eq '..'; push(@curdir,$component); } $ENV{'PWD'} = join('/',@curdir) || '/'; } 1; } sub _perl_abs_path { my $start = @_ ? shift : '.'; my($dotdots, $cwd, @pst, @cst, $dir, @tst); unless (@cst = stat( $start )) { return undef; } unless (-d _) { # Make sure we can be invoked on plain files, not just directories. # NOTE that this routine assumes that '/' is the only directory separator. my ($dir, $file) = $start =~ m{^(.*)/(.+)$} or return cwd() . '/' . $start; # Can't use "-l _" here, because the previous stat was a stat(), not an lstat(). if (-l $start) { my $link_target = readlink($start); die "Can't resolve link $start: $!" unless defined $link_target; require File::Spec; $link_target = $dir . '/' . $link_target unless File::Spec->file_name_is_absolute($link_target); return abs_path($link_target); } return $dir ? abs_path($dir) . "/$file" : "/$file"; } $cwd = ''; $dotdots = $start; do { $dotdots .= '/..'; @pst = @cst; local *PARENT; unless (opendir(PARENT, $dotdots)) { return undef; } unless (@cst = stat($dotdots)) { my $e = $!; closedir(PARENT); $! = $e; return undef; } if ($pst[0] == $cst[0] && $pst[1] == $cst[1]) { $dir = undef; } else { do { unless (defined ($dir = readdir(PARENT))) { closedir(PARENT); require Errno; $! = Errno::ENOENT(); return undef; } $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir")) } while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] || $tst[1] != $pst[1]); } $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ; closedir(PARENT); } while (defined $dir); chop($cwd) unless $cwd eq '/'; # drop the trailing / $cwd; } my $Curdir; sub fast_abs_path { local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage my $cwd = getcwd(); defined $cwd or return undef; require File::Spec; my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir); # Detaint else we'll explode in taint mode. This is safe because # we're not doing anything dangerous with it. ($path) = $path =~ /(.*)/s; ($cwd) = $cwd =~ /(.*)/s; unless (-e $path) { require Errno; $! = Errno::ENOENT(); return undef; } unless (-d _) { # Make sure we can be invoked on plain files, not just directories. my ($vol, $dir, $file) = File::Spec->splitpath($path); return File::Spec->catfile($cwd, $path) unless length $dir; if (-l $path) { my $link_target = readlink($path); defined $link_target or return undef; $link_target = File::Spec->catpath($vol, $dir, $link_target) unless File::Spec->file_name_is_absolute($link_target); return fast_abs_path($link_target); } return $dir eq File::Spec->rootdir ? File::Spec->catpath($vol, $dir, $file) : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file; } if (!CORE::chdir($path)) { return undef; } my $realpath = getcwd(); if (! ((-d $cwd) && (CORE::chdir($cwd)))) { _croak("Cannot chdir back to $cwd: $!"); } $realpath; } # added function alias to follow principle of least surprise # based on previous aliasing. --tchrist 27-Jan-00 *fast_realpath = \&fast_abs_path; # --- PORTING SECTION --- # VMS: $ENV{'DEFAULT'} points to default directory at all times # 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu # Note: Use of Cwd::chdir() causes the logical name PWD to be defined # in the process logical name table as the default device and directory # seen by Perl. This may not be the same as the default device # and directory seen by DCL after Perl exits, since the effects # the CRTL chdir() function persist only until Perl exits. sub _vms_cwd { return $ENV{'DEFAULT'}; } sub _vms_abs_path { return $ENV{'DEFAULT'} unless @_; my $path = shift; my $efs = _vms_efs; my $unix_rpt = _vms_unix_rpt; if (defined &VMS::Filespec::vmsrealpath) { my $path_unix = 0; my $path_vms = 0; $path_unix = 1 if ($path =~ m#(?<=\^)/#); $path_unix = 1 if ($path =~ /^\.\.?$/); $path_vms = 1 if ($path =~ m#[\[<\]]#); $path_vms = 1 if ($path =~ /^--?$/); my $unix_mode = $path_unix; if ($efs) { # In case of a tie, the Unix report mode decides. if ($path_vms == $path_unix) { $unix_mode = $unix_rpt; } else { $unix_mode = 0 if $path_vms; } } if ($unix_mode) { # Unix format return VMS::Filespec::unixrealpath($path); } # VMS format my $new_path = VMS::Filespec::vmsrealpath($path); # Perl expects directories to be in directory format $new_path = VMS::Filespec::pathify($new_path) if -d $path; return $new_path; } # Fallback to older algorithm if correct ones are not # available. if (-l $path) { my $link_target = readlink($path); die "Can't resolve link $path: $!" unless defined $link_target; return _vms_abs_path($link_target); } # may need to turn foo.dir into [.foo] my $pathified = VMS::Filespec::pathify($path); $path = $pathified if defined $pathified; return VMS::Filespec::rmsexpand($path); } sub _os2_cwd { my $pwd = `cmd /c cd`; chomp $pwd; $pwd =~ s:\\:/:g ; $ENV{'PWD'} = $pwd; return $pwd; } sub _win32_cwd_simple { my $pwd = `cd`; chomp $pwd; $pwd =~ s:\\:/:g ; $ENV{'PWD'} = $pwd; return $pwd; } sub _win32_cwd { my $pwd; $pwd = Win32::GetCwd(); $pwd =~ s:\\:/:g ; $ENV{'PWD'} = $pwd; return $pwd; } *_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_win32_cwd_simple; sub _dos_cwd { my $pwd; if (!defined &Dos::GetCwd) { chomp($pwd = `command /c cd`); $pwd =~ s:\\:/:g ; } else { $pwd = Dos::GetCwd(); } $ENV{'PWD'} = $pwd; return $pwd; } sub _qnx_cwd { local $ENV{PATH} = ''; local $ENV{CDPATH} = ''; local $ENV{ENV} = ''; my $pwd = `/usr/bin/fullpath -t`; chomp $pwd; $ENV{'PWD'} = $pwd; return $pwd; } sub _qnx_abs_path { local $ENV{PATH} = ''; local $ENV{CDPATH} = ''; local $ENV{ENV} = ''; my $path = @_ ? shift : '.'; local *REALPATH; defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or die "Can't open /usr/bin/fullpath: $!"; my $realpath = ; close REALPATH; chomp $realpath; return $realpath; } # Now that all the base-level functions are set up, alias the # user-level functions to the right places if (exists $METHOD_MAP{$^O}) { my $map = $METHOD_MAP{$^O}; foreach my $name (keys %$map) { local $^W = 0; # assignments trigger 'subroutine redefined' warning no strict 'refs'; *{$name} = \&{$map->{$name}}; } } # In case the XS version doesn't load. *abs_path = \&_perl_abs_path unless defined &abs_path; *getcwd = \&_perl_getcwd unless defined &getcwd; # added function alias for those of us more # used to the libc function. --tchrist 27-Jan-00 *realpath = \&abs_path; 1; __END__ =head1 NAME Cwd - get pathname of current working directory =head1 SYNOPSIS use Cwd; my $dir = getcwd; use Cwd 'abs_path'; my $abs_path = abs_path($file); =head1 DESCRIPTION This module provides functions for determining the pathname of the current working directory. It is recommended that getcwd (or another *cwd() function) be used in I code to ensure portability. By default, it exports the functions cwd(), getcwd(), fastcwd(), and fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace. =head2 getcwd and friends Each of these functions are called without arguments and return the absolute path of the current working directory. =over 4 =item getcwd my $cwd = getcwd(); Returns the current working directory. On error returns C, with C<$!> set to indicate the error. Exposes the POSIX function getcwd(3) or re-implements it if it's not available. =item cwd my $cwd = cwd(); The cwd() is the most natural form for the current architecture. For most systems it is identical to `pwd` (but without the trailing line terminator). =item fastcwd my $cwd = fastcwd(); A more dangerous version of getcwd(), but potentially faster. It might conceivably chdir() you out of a directory that it can't chdir() you back into. If fastcwd encounters a problem it will return undef but will probably leave you in a different directory. For a measure of extra security, if everything appears to have worked, the fastcwd() function will check that it leaves you in the same directory that it started in. If it has changed it will C with the message "Unstable directory path, current directory changed unexpectedly". That should never happen. =item fastgetcwd my $cwd = fastgetcwd(); The fastgetcwd() function is provided as a synonym for cwd(). =item getdcwd my $cwd = getdcwd(); my $cwd = getdcwd('C:'); The getdcwd() function is also provided on Win32 to get the current working directory on the specified drive, since Windows maintains a separate current working directory for each drive. If no drive is specified then the current drive is assumed. This function simply calls the Microsoft C library _getdcwd() function. =back =head2 abs_path and friends These functions are exported only on request. They each take a single argument and return the absolute pathname for it. If no argument is given they'll use the current working directory. =over 4 =item abs_path my $abs_path = abs_path($file); Uses the same algorithm as getcwd(). Symbolic links and relative-path components ("." and "..") are resolved to return the canonical pathname, just like realpath(3). On error returns C, with C<$!> set to indicate the error. =item realpath my $abs_path = realpath($file); A synonym for abs_path(). =item fast_abs_path my $abs_path = fast_abs_path($file); A more dangerous, but potentially faster version of abs_path. =back =head2 $ENV{PWD} If you ask to override your chdir() built-in function, use Cwd qw(chdir); then your PWD environment variable will be kept up to date. Note that it will only be kept up to date if all packages which use chdir import it from Cwd. =head1 NOTES =over 4 =item * Since the path separators are different on some operating systems ('/' on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec modules wherever portability is a concern. =item * Actually, on Mac OS, the C, C and C functions are all aliases for the C function, which, on Mac OS, calls `pwd`. Likewise, the C function is an alias for C. =back =head1 AUTHOR Originally by the perl5-porters. Maintained by Ken Williams =head1 COPYRIGHT Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Portions of the C code in this library are copyright (c) 1994 by the Regents of the University of California. All rights reserved. The license on this code is compatible with the licensing of the rest of the distribution - please see the source code in F for the details. =head1 SEE ALSO L =cut PK!��b�A�A� Encode.pmnu�[���
# # $Id: Encode.pm,v 2.97 2018/02/21 12:14:24 dankogai Exp $ # package Encode; use strict; use warnings; use constant DEBUG => !!$ENV{PERL_ENCODE_DEBUG}; our $VERSION; BEGIN { $VERSION = sprintf "%d.%02d", q$Revision: 2.97 $ =~ /(\d+)/g; require XSLoader; XSLoader::load( __PACKAGE__, $VERSION ); } use Exporter 5.57 'import'; our @CARP_NOT = qw(Encode::Encoder); # Public, encouraged API is exported by default our @EXPORT = qw( decode decode_utf8 encode encode_utf8 str2bytes bytes2str encodings find_encoding find_mime_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 (); use Encode::MIME::Name; use Storable; # 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 handlers inside eval{} are disabled. eval { local $SIG{__DIE__}; local $SIG{__WARN__}; local @INC = @INC; pop @INC if $INC[-1] eq '.'; require Encode::ConfigLocal; }; sub encodings { my %enc; my $arg = $_[1] || ''; if ( $arg eq ":all" ) { %enc = ( %Encoding, %ExtModule ); } else { %enc = %Encoding; for my $mod ( map { m/::/ ? $_ : "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 ); } my $class = ref($obj); push @Encode::CARP_NOT, $class unless grep { $_ eq $class } @Encode::CARP_NOT; push @Encode::Encoding::CARP_NOT, $class unless grep { $_ eq $class } @Encode::Encoding::CARP_NOT; return $obj; } sub getEncoding { my ( $class, $name, $skip_external ) = @_; defined($name) or return; $name =~ s/\s+//g; # https://rt.cpan.org/Ticket/Display.html?id=65796 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; } # HACK: These two functions must be defined in Encode and because of # cyclic dependency between Encode and Encode::Alias, Exporter does not work sub find_alias { goto &Encode::Alias::find_alias; } sub define_alias { goto &Encode::Alias::define_alias; } sub find_encoding($;$) { my ( $name, $skip_external ) = @_; return __PACKAGE__->getEncoding( $name, $skip_external ); } sub find_mime_encoding($;$) { my ( $mime_name, $skip_external ) = @_; my $name = Encode::MIME::Name::get_encode_name( $mime_name ); return find_encoding( $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; return Storable::dclone($obj); } sub encode($$;$) { my ( $name, $string, $check ) = @_; return undef unless defined $string; $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'"); } # For Unicode, warnings need to be caught and re-issued at this level # so that callers can disable utf8 warnings lexically. my $octets; if ( ref($enc) eq 'Encode::Unicode' ) { my $warn = ''; { local $SIG{__WARN__} = sub { $warn = shift }; $octets = $enc->encode( $string, $check ); } warnings::warnif('utf8', $warn) if length $warn; } else { $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 .= ''; $check ||= 0; my $enc = find_encoding($name); unless ( defined $enc ) { require Carp; Carp::croak("Unknown encoding '$name'"); } # For Unicode, warnings need to be caught and re-issued at this level # so that callers can disable utf8 warnings lexically. my $string; if ( ref($enc) eq 'Encode::Unicode' ) { my $warn = ''; { local $SIG{__WARN__} = sub { $warn = shift }; $string = $enc->decode( $octets, $check ); } warnings::warnif('utf8', $warn) if length $warn; } else { $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'"); } # For Unicode, warnings need to be caught and re-issued at this level # so that callers can disable utf8 warnings lexically. my $uni; if ( ref($f) eq 'Encode::Unicode' ) { my $warn = ''; { local $SIG{__WARN__} = sub { $warn = shift }; $uni = $f->decode($string); } warnings::warnif('utf8', $warn) if length $warn; } else { $uni = $f->decode($string); } if ( ref($t) eq 'Encode::Unicode' ) { my $warn = ''; { local $SIG{__WARN__} = sub { $warn = shift }; $_[0] = $string = $t->encode( $uni, $check ); } warnings::warnif('utf8', $warn) if length $warn; } else { $_[0] = $string = $t->encode( $uni, $check ); } return undef if ( $check && length($uni) ); return defined( $_[0] ) ? length($string) : undef; } sub encode_utf8($) { my ($str) = @_; return undef unless defined $str; utf8::encode($str); return $str; } my $utf8enc; sub decode_utf8($;$) { my ( $octets, $check ) = @_; return undef unless defined $octets; $octets .= ''; $check ||= 0; $utf8enc ||= find_encoding('utf8'); my $string = $utf8enc->decode( $octets, $check ); $_[0] = $octets if $check and !ref $check and !( $check & LEAVE_SRC ); return $string; } onBOOT; if ($ON_EBCDIC) { package Encode::UTF_EBCDIC; use parent 'Encode::Encoding'; my $obj = bless { Name => "UTF_EBCDIC" } => "Encode::UTF_EBCDIC"; Encode::define_encoding($obj, 'Unicode'); sub decode { my ( undef, $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; } sub encode { my ( undef, $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; } } else { package Encode::Internal; use parent 'Encode::Encoding'; my $obj = bless { Name => "Internal" } => "Encode::Internal"; Encode::define_encoding($obj, 'Unicode'); sub decode { my ( undef, $str, $chk ) = @_; utf8::upgrade($str); $_[1] = '' if $chk; return $str; } *encode = \&decode; } { # https://rt.cpan.org/Public/Bug/Display.html?id=103253 package Encode::XS; use parent 'Encode::Encoding'; } { package Encode::utf8; use parent 'Encode::Encoding'; my %obj = ( 'utf8' => { Name => 'utf8' }, 'utf-8-strict' => { Name => 'utf-8-strict', strict_utf8 => 1 } ); for ( keys %obj ) { bless $obj{$_} => __PACKAGE__; Encode::define_encoding( $obj{$_} => $_ ); } sub cat_decode { # ($obj, $dst, $src, $pos, $trm, $chk) # currently ignores $chk my ( undef, 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 ''; } } 1; __END__ =head1 NAME Encode - character encodings in Perl =head1 SYNOPSIS use Encode qw(decode encode); $characters = decode('UTF-8', $octets, Encode::FB_CROAK); $octets = encode('UTF-8', $characters, Encode::FB_CROAK); =head2 Table of Contents Encode consists of a collection of modules whose details are too extensive to fit in one document. This one itself explains the top-level APIs and general topics at a glance. For other topics and more details, see the documentation for these modules: =over 2 =item L - Alias definitions to encodings =item L - Encode Implementation Base Class =item L - List of Supported Encodings =item L - Simplified Chinese Encodings =item L - Japanese Encodings =item L - Korean Encodings =item L - Traditional Chinese Encodings =back =head1 DESCRIPTION The C module provides the interface between Perl strings and the rest of the system. Perl strings are sequences of I. The repertoire of characters that Perl can represent is a superset of those defined by the Unicode Consortium. On most platforms the ordinal values of a character as returned by C)> is the I for that character. The exceptions are platforms where the legacy encoding is some variant of EBCDIC rather than a superset of ASCII; see L. During recent history, data is moved around a computer in 8-bit chunks, often called "bytes" but also known as "octets" in standards documents. 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: because a byte has 256 possible values, it easily fits in Perl's much larger "logical character". This document mostly explains the I. L and L explain the I. =head2 TERMINOLOGY =head3 character A character in the range 0 .. 2**32-1 (or more); what Perl's strings are made of. =head3 byte A character in the range 0..255; a special case of a Perl character. =head3 octet 8 bits of data, with ordinal values 0..255; term for bytes passed to or from a non-Perl context, such as a disk file, standard I/O stream, database, command-line argument, environment variable, socket etc. =head1 THE PERL ENCODING API =head2 Basic methods =head3 encode $octets = encode(ENCODING, STRING[, CHECK]) Encodes the scalar value I from Perl's internal form into I and returns a sequence of octets. I can be either a canonical name or an alias. For encoding names and aliases, see L. For CHECK, see L. B: the input scalar I might be modified in-place depending on what is set in CHECK. See L if you want your inputs to be left unchanged. For example, to convert a string from Perl's internal format into ISO-8859-1, also known as Latin1: $octets = encode("iso-8859-1", $string); B: When you run C<$octets = encode("UTF-8", $string)>, then $octets I $string. Though both contain the same data, the UTF8 flag for $octets is I off. When you encode anything, the UTF8 flag on the result is always off, even when it contains a completely valid UTF-8 string. See L below. If the $string is C, then C is returned. C may be used as an alias for C. =head3 decode $string = decode(ENCODING, OCTETS[, CHECK]) This function returns the string that results from decoding the scalar value I, assumed to be a sequence of octets in I, into Perl's internal form. As with encode(), I can be either a canonical name or an alias. For encoding names and aliases, see L; for I, see L. B: the input scalar I might be modified in-place depending on what is set in CHECK. See L if you want your inputs to be left unchanged. For example, to convert ISO-8859-1 data into a string in Perl's internal format: $string = decode("iso-8859-1", $octets); B: When you run C<$string = decode("UTF-8", $octets)>, then $string I $octets. Though both contain the same data, the UTF8 flag for $string is on. See L below. If the $string is C, then C is returned. C may be used as an alias for C. =head3 find_encoding [$obj =] find_encoding(ENCODING) Returns the I corresponding to I. Returns C if no matching I is find. The returned object is what does the actual encoding or decoding. $string = decode($name, $bytes); is in fact $string = do { $obj = find_encoding($name); croak qq(encoding "$name" not found) unless ref $obj; $obj->decode($bytes); }; with more error checking. You can therefore save time by reusing this object as follows; my $enc = find_encoding("iso-8859-1"); while(<>) { my $string = $enc->decode($_); ... # now do something with $string; } Besides L and L, other methods are available as well. For instance, C returns the canonical name of the encoding object. find_encoding("latin1")->name; # iso-8859-1 See L for details. =head3 find_mime_encoding [$obj =] find_mime_encoding(MIME_ENCODING) Returns the I corresponding to I. Acts same as C but C of returned object must match to I. So as opposite of C canonical names and aliases are not used when searching for object. find_mime_encoding("utf8"); # returns undef because "utf8" is not valid I find_mime_encoding("utf-8"); # returns encode object "utf-8-strict" find_mime_encoding("UTF-8"); # same as "utf-8" because I is case insensitive find_mime_encoding("utf-8-strict"); returns undef because "utf-8-strict" is not valid I =head3 from_to [$length =] from_to($octets, FROM_ENC, TO_ENC [, CHECK]) Converts I data between two encodings. The data in $octets must be encoded as octets and I as characters in Perl's internal format. For example, to convert ISO-8859-1 data into Microsoft's CP1250 encoding: from_to($octets, "iso-8859-1", "cp1250"); and to convert it back: from_to($octets, "cp1250", "iso-8859-1"); Because the conversion happens in place, the data to be converted cannot be a string constant: it must be a scalar variable. C returns the length of the converted string in octets on success, and C on error. B: The following operations may look the same, but are not: from_to($data, "iso-8859-1", "UTF-8"); #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 the UTF8 flag on. #1 is equivalent to: $data = encode("UTF-8", 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 I respect the $check during decoding. It is deliberately done that way. If you need minute control, use C followed by C as follows: $octets = encode($to, decode($from, $octets, $check_from), $check_to); =head3 encode_utf8 $octets = encode_utf8($string); Equivalent to C<$octets = encode("utf8", $string)>. The characters in $string are encoded in Perl's internal format, and the result is returned as a sequence of octets. Because all possible characters in Perl have a (loose, not strict) utf8 representation, this function cannot fail. B: do not use this function for data exchange as it can produce not strict utf8 $octets! For strictly valid UTF-8 output use C<$octets = encode("UTF-8", $string)>. =head3 decode_utf8 $string = decode_utf8($octets [, CHECK]); Equivalent to C<$string = decode("utf8", $octets [, CHECK])>. The sequence of octets represented by $octets is decoded from (loose, not strict) utf8 into a sequence of logical characters. Because not all sequences of octets are valid not strict utf8, it is quite possible for this function to fail. For CHECK, see L. B: do not use this function for data exchange as it can produce $string with not strict utf8 representation! For strictly valid UTF-8 $string representation use C<$string = decode("UTF-8", $octets [, CHECK])>. B: the input I<$octets> might be modified in-place depending on what is set in CHECK. See L if you want your inputs to be left unchanged. =head2 Listing available encodings use Encode; @list = Encode->encodings(); Returns a list of canonical names of available encodings that have already been loaded. To get a list of all available encodings including those that have not yet been loaded, say: @all_encodings = Encode->encodings(":all"); Or you can give the name of a specific module: @with_jp = Encode->encodings("Encode::JP"); When "C<::>" is not in the name, "C" 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, I can be used as an alias for I. I may be either the name of an encoding or an I. Before you do that, first make sure the alias is nonexistent using C, which returns the canonical name thereof. For example: 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 C does not need C; it can be imported 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 Character Set Registry, commonly seen as C<< Content-Type: text/plain; charset=I >>. For most cases, the canonical name works, but sometimes it does not, most notably with "utf-8-strict". As of C version 2.21, a new method C is therefore 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 C (which is the default), you can use a C layer to decode and encode directly via a filehandle. The following two examples are fully identical in functionality: ### Version 1 via PerlIO open(INPUT, "< :encoding(shiftjis)", $infile) || die "Can't open < $infile for reading: $!"; open(OUTPUT, "> :encoding(euc-jp)", $outfile) || die "Can't open > $output for writing: $!"; while () { # auto decodes $_ print OUTPUT; # auto encodes $_ } close(INPUT) || die "can't close $infile: $!"; close(OUTPUT) || die "can't close $outfile: $!"; ### Version 2 via from_to() open(INPUT, "< :raw", $infile) || die "Can't open < $infile for reading: $!"; open(OUTPUT, "> :raw", $outfile) || die "Can't open > $output for writing: $!"; while () { from_to($_, "shiftjis", "euc-jp", 1); # switch encoding print OUTPUT; # emit raw (but properly encoded) data } close(INPUT) || die "can't close $infile: $!"; close(OUTPUT) || die "can't close $outfile: $!"; In the first version above, you let the appropriate encoding layer handle the conversion. In the second, you explicitly translate from one encoding to the other. Unfortunately, it may be that encodings are not C-savvy. You can check to see whether your encoding is supported by C by invoking the C method on it: Encode::perlio_ok("hz"); # false find_encoding("euc-cn")->perlio_ok; # true wherever PerlIO is available use Encode qw(perlio_ok); # imported upon request perlio_ok("euc-jp") Fortunately, all encodings that come with C core are C-savvy except for C and C. For the gory details, see L and L. =head1 Handling Malformed Data The optional I argument tells C what to do when encountering malformed data. Without I, C (== 0) is assumed. As of version 2.12, C supports coderef values for C; see below. B Not all encodings support this feature. Some encodings ignore the I argument. For example, L ignores I and it always croaks on error. =head2 List of I values =head3 FB_DEFAULT I = Encode::FB_DEFAULT ( == 0) If I is 0, encoding and decoding replace any malformed character with a I. When you encode, I is used. When you decode, the Unicode REPLACEMENT CHARACTER, code point U+FFFD, is used. If the data is supposed to be UTF-8, an optional lexical warning of warning category C<"utf8"> is given. =head3 FB_CROAK I = Encode::FB_CROAK ( == 1) If I is 1, methods immediately die with an error message. Therefore, when I is 1, you should trap exceptions with C, unless you really want to let it C. =head3 FB_QUIET I = Encode::FB_QUIET If I is set to C, encoding and decoding immediately return the portion of the data that has been processed so far when an error occurs. The data argument is overwritten with everything after that point; that is, the unprocessed portion of the data. This is handy when you have to call C repeatedly in the case where your source data may contain partial multi-byte character sequences, (that is, you are reading with a fixed-width buffer). Here's some sample code to do exactly that: my($buffer, $string) = ("", ""); while (read($fh, $buffer, 256, length($buffer))) { $string .= decode($encoding, $buffer, Encode::FB_QUIET); # $buffer now contains the unprocessed partial character } =head3 FB_WARN I = Encode::FB_WARN This is the same as C above, except that instead of being silent on errors, it issues a warning. This is handy for when you are debugging. =head3 FB_PERLQQ FB_HTMLCREF FB_XMLCREF =over 2 =item perlqq mode (I = Encode::FB_PERLQQ) =item HTML charref mode (I = Encode::FB_HTMLCREF) =item XML charref mode (I = Encode::FB_XMLCREF) =back For encodings that are implemented by the C module, C C<==> C puts C and C into C fallback mode. When you decode, C<\xI> is inserted for a malformed character, where I is the hex representation of the octet that could not be decoded to utf8. When you encode, C<\x{I}> will be inserted, where I is the Unicode code point (in any number of hex digits) of the character that cannot be found in the character repertoire of the encoding. The 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 C 2.10 or later, C is also implied. =head3 The bitmask These modes are all actually set via a bitmask. Here is how the C> constants are laid out. You can import the C> constants via C, and 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 =head3 LEAVE_SRC Encode::LEAVE_SRC If the C bit is I set but I is set, then the source string to encode() or decode() will be overwritten in place. If you're not interested in this, then bitwise-OR it with the bitmask. =head2 coderef for CHECK As of C 2.12, C can also be a code reference which takes the ordinal value of the unmapped character as an argument and returns octets that represent the fallback character. For instance: $ascii = encode("ascii", $utf8, sub{ sprintf "", shift }); Acts like C but U+I is used instead of C<\x{I}>. Fallback for C must return decoded string (sequence of characters) and takes a list of ordinal values as its arguments. So for example if you wish to decode octets as UTF-8, and use ISO-8859-15 as a fallback for bytes that are not valid UTF-8, you could write $str = decode 'UTF-8', $octets, sub { my $tmp = join '', map chr, @_; return decode 'ISO-8859-15', $tmp; }; =head1 Defining Encodings To define a new encoding, use: use Encode qw(define_encoding); define_encoding($object, CANONICAL_NAME [, alias...]); I will be associated with I<$object>. The object should provide the interface described in L. If more than two arguments are provided, additional arguments are considered aliases for I<$object>. See L for 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 quote from page 402 of I =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 When I was written, not even Perl 5.6.0 had been born yet, many features documented in the book remained unimplemented for a long time. Perl 5.8 corrected much of this, and the introduction of the UTF8 flag is one of them. You can think of there being two fundamentally different kinds of strings and string-operations in Perl: one a byte-oriented mode for when the internal UTF8 flag is off, and the other a character-oriented mode for when the internal UTF8 flag is on. This UTF8 flag is not visible in Perl scripts, exactly for the same reason you cannot (or rather, you I) see whether a scalar contains a string, an integer, or a floating-point number. But you can still peek and poke these if you will. See the next section. =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 in a future release. =head3 is_utf8 is_utf8(STRING [, CHECK]) [INTERNAL] Tests whether the UTF8 flag is turned on in the I. If I is true, also checks whether I contains well-formed UTF-8. Returns true if successful, false otherwise. Typically only necessary for debugging and testing. Don't use this flag as a marker to distinguish character and binary data, that should be decided for each variable when you write your code. B: If I has UTF8 flag set, it does B mean that I is UTF-8 encoded and vice-versa. As of Perl 5.8.1, L also has the C function. =head3 _utf8_on _utf8_on(STRING) [INTERNAL] Turns the I's internal UTF8 flag B. The I is I checked for containing only well-formed UTF-8. Do not use this unless you I that the STRING holds only 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 I is not a string. B: For security reasons, this function does not work on tainted values. =head3 _utf8_off _utf8_off(STRING) [INTERNAL] Turns the I's internal UTF8 flag B. Do not use frivolously. Returns the previous state of the UTF8 flag, or C if I is not a string. Do not treat the return value as indicative of success or failure, because that isn't what it means: it is only the previous setting. B: For security reasons, this function does not work on tainted values. =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 historically been Perl's notion of UTF-8, as that is how UTF-8 was first conceived by Ken Thompson when he invented it. However, thanks to later revisions to the applicable standards, official UTF-8 is now rather stricter than that. For example, its range is much narrower (0 .. 0x10_FFFF to cover only 21 bits instead of 32 or 64 bits) and some sequences are not allowed, like those used in surrogate pairs, the 31 non-character code points 0xFDD0 .. 0xFDEF, the last two code points in I plane (0xI_FFFE and 0xI_FFFF), all non-shortest encodings, etc. The former default in which Perl would always use a loose interpretation of UTF-8 has now been overruled: 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 Got that? As of Perl 5.8.7, B<"UTF-8"> means UTF-8 in its current sense, which is conservative and strict and security-conscious, whereas B<"utf8"> means UTF-8 in its former sense, which was liberal and loose and lax. C version 2.10 or later thus groks this subtle but critically important distinction between C<"UTF-8"> and C<"utf8">. encode("utf8", "\x{FFFF_FFFF}", 1); # okay encode("UTF-8", "\x{FFFF_FFFF}", 1); # croaks In the C module, C<"UTF-8"> is actually a canonical name for C<"utf-8-strict">. That hyphen between the C<"UTF"> and the C<"8"> is critical; without it, C goes "liberal" and (perhaps overly-)permissive: 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'. Perl's internal UTF8 flag is called "UTF8", without a hyphen. It indicates whether a string is internally encoded as "utf8", also without a hyphen. =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L L, the Perl Unicode Mailing List L =head1 MAINTAINER This project was originated by the late Nick Ing-Simmons and later maintained by Dan Kogai I<< >>. See AUTHORS for a full list of people involved. For any questions, send mail to I<< >> so that we can all share. While Dan Kogai retains the copyright as a maintainer, credit should go to all those involved. See AUTHORS for a list of those who submitted code to the project. =head1 COPYRIGHT Copyright 2002-2014 Dan Kogai I<< >>. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK!�>�PPthreads/shared.pmnu�[���
package threads::shared; use 5.008; use strict; use warnings; use Scalar::Util qw(reftype refaddr blessed); our $VERSION = '1.58'; # Please update the pod, too. my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; # Declare that we have been loaded $threads::shared::threads_shared = 1; # Method of complaint about things we can't clone $threads::shared::clone_warn = undef; # Load the XS code, if applicable if ($threads::threads) { require XSLoader; XSLoader::load('threads::shared', $XS_VERSION); *is_shared = \&_id; } else { # String eval is generally evil, but we don't want these subs to # exist at all if 'threads' is not loaded successfully. # Vivifying them conditionally this way saves on average about 4K # of memory per thread. eval <<'_MARKER_'; sub share (\[$@%]) { return $_[0] } sub is_shared (\[$@%]) { undef } sub cond_wait (\[$@%];\[$@%]) { undef } sub cond_timedwait (\[$@%]$;\[$@%]) { undef } sub cond_signal (\[$@%]) { undef } sub cond_broadcast (\[$@%]) { undef } _MARKER_ } ### Export ### sub import { # Exported subroutines my @EXPORT = qw(share is_shared cond_wait cond_timedwait cond_signal cond_broadcast shared_clone); if ($threads::threads) { push(@EXPORT, 'bless'); } # Export subroutine names my $caller = caller(); foreach my $sym (@EXPORT) { no strict 'refs'; *{$caller.'::'.$sym} = \&{$sym}; } } # Predeclarations for internal functions my ($make_shared); ### Methods, etc. ### sub threads::shared::tie::SPLICE { require Carp; Carp::croak('Splice not implemented for shared arrays'); } # Create a thread-shared clone of a complex data structure or object sub shared_clone { if (@_ != 1) { require Carp; Carp::croak('Usage: shared_clone(REF)'); } return $make_shared->(shift, {}); } ### Internal Functions ### # Used by shared_clone() to recursively clone # a complex data structure or object $make_shared = sub { my ($item, $cloned) = @_; # Just return the item if: # 1. Not a ref; # 2. Already shared; or # 3. Not running 'threads'. return $item if (! ref($item) || is_shared($item) || ! $threads::threads); # Check for previously cloned references # (this takes care of circular refs as well) my $addr = refaddr($item); if (exists($cloned->{$addr})) { # Return the already existing clone return $cloned->{$addr}; } # Make copies of array, hash and scalar refs and refs of refs my $copy; my $ref_type = reftype($item); # Copy an array ref if ($ref_type eq 'ARRAY') { # Make empty shared array ref $copy = &share([]); # Add to clone checking hash $cloned->{$addr} = $copy; # Recursively copy and add contents push(@$copy, map { $make_shared->($_, $cloned) } @$item); } # Copy a hash ref elsif ($ref_type eq 'HASH') { # Make empty shared hash ref $copy = &share({}); # Add to clone checking hash $cloned->{$addr} = $copy; # Recursively copy and add contents foreach my $key (keys(%{$item})) { $copy->{$key} = $make_shared->($item->{$key}, $cloned); } } # Copy a scalar ref elsif ($ref_type eq 'SCALAR') { $copy = \do{ my $scalar = $$item; }; share($copy); # Add to clone checking hash $cloned->{$addr} = $copy; } # Copy of a ref of a ref elsif ($ref_type eq 'REF') { # Special handling for $x = \$x if ($addr == refaddr($$item)) { $copy = \$copy; share($copy); $cloned->{$addr} = $copy; } else { my $tmp; $copy = \$tmp; share($copy); # Add to clone checking hash $cloned->{$addr} = $copy; # Recursively copy and add contents $tmp = $make_shared->($$item, $cloned); } } else { require Carp; if (! defined($threads::shared::clone_warn)) { Carp::croak("Unsupported ref type: ", $ref_type); } elsif ($threads::shared::clone_warn) { Carp::carp("Unsupported ref type: ", $ref_type); } return undef; } # If input item is an object, then bless the copy into the same class if (my $class = blessed($item)) { bless($copy, $class); } # Clone READONLY flag if ($ref_type eq 'SCALAR') { if (Internals::SvREADONLY($$item)) { Internals::SvREADONLY($$copy, 1) if ($] >= 5.008003); } } if (Internals::SvREADONLY($item)) { Internals::SvREADONLY($copy, 1) if ($] >= 5.008003); } return $copy; }; 1; __END__ =head1 NAME threads::shared - Perl extension for sharing data structures between threads =head1 VERSION This document describes threads::shared version 1.58 =head1 SYNOPSIS use threads; use threads::shared; my $var :shared; my %hsh :shared; my @ary :shared; my ($scalar, @array, %hash); share($scalar); share(@array); share(%hash); $var = $scalar_value; $var = $shared_ref_value; $var = shared_clone($non_shared_ref_value); $var = shared_clone({'foo' => [qw/foo bar baz/]}); $hsh{'foo'} = $scalar_value; $hsh{'bar'} = $shared_ref_value; $hsh{'baz'} = shared_clone($non_shared_ref_value); $hsh{'quz'} = shared_clone([1..3]); $ary[0] = $scalar_value; $ary[1] = $shared_ref_value; $ary[2] = shared_clone($non_shared_ref_value); $ary[3] = shared_clone([ {}, [] ]); { lock(%hash); ... } cond_wait($scalar); cond_timedwait($scalar, time() + 30); cond_broadcast(@array); cond_signal(%hash); my $lockvar :shared; # condition var != lock var cond_wait($var, $lockvar); cond_timedwait($var, time()+30, $lockvar); =head1 DESCRIPTION By default, variables are private to each thread, and each newly created thread gets a private copy of each existing variable. This module allows you to share variables across different threads (and pseudo-forks on Win32). It is used together with the L module. This module supports the sharing of the following data types only: scalars and scalar refs, arrays and array refs, and hashes and hash refs. =head1 EXPORT The following functions are exported by this module: C, C, C, C, C, C and C Note that if this module is imported when L has not yet been loaded, then these functions all become no-ops. This makes it possible to write modules that will work in both threaded and non-threaded environments. =head1 FUNCTIONS =over 4 =item share VARIABLE C takes a variable and marks it as shared: my ($scalar, @array, %hash); share($scalar); share(@array); share(%hash); C will return the shared rvalue, but always as a reference. Variables can also be marked as shared at compile time by using the C<:shared> attribute: my ($var, %hash, @array) :shared; Shared variables can only store scalars, refs of shared variables, or refs of shared data (discussed in next section): my ($var, %hash, @array) :shared; my $bork; # Storing scalars $var = 1; $hash{'foo'} = 'bar'; $array[0] = 1.5; # Storing shared refs $var = \%hash; $hash{'ary'} = \@array; $array[1] = \$var; # The following are errors: # $var = \$bork; # ref of non-shared variable # $hash{'bork'} = []; # non-shared array ref # push(@array, { 'x' => 1 }); # non-shared hash ref =item shared_clone REF C takes a reference, and returns a shared version of its argument, performing a deep copy on any non-shared elements. Any shared elements in the argument are used as is (i.e., they are not cloned). my $cpy = shared_clone({'foo' => [qw/foo bar baz/]}); Object status (i.e., the class an object is blessed into) is also cloned. my $obj = {'foo' => [qw/foo bar baz/]}; bless($obj, 'Foo'); my $cpy = shared_clone($obj); print(ref($cpy), "\n"); # Outputs 'Foo' For cloning empty array or hash refs, the following may also be used: $var = &share([]); # Same as $var = shared_clone([]); $var = &share({}); # Same as $var = shared_clone({}); Not all Perl data types can be cloned (e.g., globs, code refs). By default, C will L if it encounters such items. To change this behaviour to a warning, then set the following: $threads::shared::clone_warn = 1; In this case, C will be substituted for the item to be cloned. If set to zero: $threads::shared::clone_warn = 0; then the C substitution will be performed silently. =item is_shared VARIABLE C checks if the specified variable is shared or not. If shared, returns the variable's internal ID (similar to C (see L). Otherwise, returns C. if (is_shared($var)) { print("\$var is shared\n"); } else { print("\$var is not shared\n"); } When used on an element of an array or hash, C checks if the specified element belongs to a shared array or hash. (It does not check the contents of that element.) my %hash :shared; if (is_shared(%hash)) { print("\%hash is shared\n"); } $hash{'elem'} = 1; if (is_shared($hash{'elem'})) { print("\$hash{'elem'} is in a shared hash\n"); } =item lock VARIABLE C places a B lock on a variable until the lock goes out of scope. If the variable is locked by another thread, the C call will block until it's available. Multiple calls to C by the same thread from within dynamically nested scopes are safe -- the variable will remain locked until the outermost lock on the variable goes out of scope. C follows references exactly I level: my %hash :shared; my $ref = \%hash; lock($ref); # This is equivalent to lock(%hash) Note that you cannot explicitly unlock a variable; you can only wait for the lock to go out of scope. This is most easily accomplished by locking the variable inside a block. my $var :shared; { lock($var); # $var is locked from here to the end of the block ... } # $var is now unlocked As locks are advisory, they do not prevent data access or modification by another thread that does not itself attempt to obtain a lock on the variable. You cannot lock the individual elements of a container variable: my %hash :shared; $hash{'foo'} = 'bar'; #lock($hash{'foo'}); # Error lock(%hash); # Works If you need more fine-grained control over shared variable access, see L. =item cond_wait VARIABLE =item cond_wait CONDVAR, LOCKVAR The C function takes a B variable as a parameter, unlocks the variable, and blocks until another thread does a C or C for that same locked variable. The variable that C blocked on is re-locked after the C is satisfied. If there are multiple threads Cing on the same variable, all but one will re-block waiting to reacquire the lock on the variable. (So if you're only using C for synchronization, give up the lock as soon as possible). The two actions of unlocking the variable and entering the blocked wait state are atomic, the two actions of exiting from the blocked wait state and re-locking the variable are not. In its second form, C takes a shared, B variable followed by a shared, B variable. The second variable is unlocked and thread execution suspended until another thread signals the first variable. It is important to note that the variable can be notified even if no thread C or C on the variable. It is therefore important to check the value of the variable and go back to waiting if the requirement is not fulfilled. For example, to pause until a shared counter drops to zero: { lock($counter); cond_wait($counter) until $counter == 0; } =item cond_timedwait VARIABLE, ABS_TIMEOUT =item cond_timedwait CONDVAR, ABS_TIMEOUT, LOCKVAR In its two-argument form, C takes a B variable and an absolute timeout in I seconds (see L for more) as parameters, unlocks the variable, and blocks until the timeout is reached or another thread signals the variable. A false value is returned if the timeout is reached, and a true value otherwise. In either case, the variable is re-locked upon return. Like C, this function may take a shared, B variable as an additional parameter; in this case the first parameter is an B condition variable protected by a distinct lock variable. Again like C, waking up and reacquiring the lock are not atomic, and you should always check your desired condition after this function returns. Since the timeout is an absolute value, however, it does not have to be recalculated with each pass: lock($var); my $abs = time() + 15; until ($ok = desired_condition($var)) { last if !cond_timedwait($var, $abs); } # we got it if $ok, otherwise we timed out! =item cond_signal VARIABLE The C function takes a B variable as a parameter and unblocks one thread that's Cing on that variable. If more than one thread is blocked in a C on that variable, only one (and which one is indeterminate) will be unblocked. If there are no threads blocked in a C on the variable, the signal is discarded. By always locking before signaling, you can (with care), avoid signaling before another thread has entered cond_wait(). C will normally generate a warning if you attempt to use it on an unlocked variable. On the rare occasions where doing this may be sensible, you can suppress the warning with: { no warnings 'threads'; cond_signal($foo); } =item cond_broadcast VARIABLE The C function works similarly to C. C, though, will unblock B the threads that are blocked in a C on the locked variable, rather than only one. =back =head1 OBJECTS L exports a version of L that works on shared objects such that I propagate across threads. # Create a shared 'Foo' object my $foo :shared = shared_clone({}); bless($foo, 'Foo'); # Create a shared 'Bar' object my $bar :shared = shared_clone({}); bless($bar, 'Bar'); # Put 'bar' inside 'foo' $foo->{'bar'} = $bar; # Rebless the objects via a thread threads->create(sub { # Rebless the outer object bless($foo, 'Yin'); # Cannot directly rebless the inner object #bless($foo->{'bar'}, 'Yang'); # Retrieve and rebless the inner object my $obj = $foo->{'bar'}; bless($obj, 'Yang'); $foo->{'bar'} = $obj; })->join(); print(ref($foo), "\n"); # Prints 'Yin' print(ref($foo->{'bar'}), "\n"); # Prints 'Yang' print(ref($bar), "\n"); # Also prints 'Yang' =head1 NOTES L is designed to disable itself silently if threads are not available. This allows you to write modules and packages that can be used in both threaded and non-threaded applications. If you want access to threads, you must C before you C. L will emit a warning if you use it after L. =head1 WARNINGS =over 4 =item cond_broadcast() called on unlocked variable =item cond_signal() called on unlocked variable See L, above. =back =head1 BUGS AND LIMITATIONS When C is used on arrays, hashes, array refs or hash refs, any data they contain will be lost. my @arr = qw(foo bar baz); share(@arr); # @arr is now empty (i.e., == ()); # Create a 'foo' object my $foo = { 'data' => 99 }; bless($foo, 'foo'); # Share the object share($foo); # Contents are now wiped out print("ERROR: \$foo is empty\n") if (! exists($foo->{'data'})); Therefore, populate such variables B declaring them as shared. (Scalar and scalar refs are not affected by this problem.) Blessing a shared item after it has been nested in another shared item does not propagate the blessing to the shared reference: my $foo = &share({}); my $bar = &share({}); $bar->{foo} = $foo; bless($foo, 'baz'); # $foo is now of class 'baz', # but $bar->{foo} is unblessed. Therefore, you should bless objects before sharing them. It is often not wise to share an object unless the class itself has been written to support sharing. For example, a shared object's destructor may get called multiple times, once for each thread's scope exit, or may not get called at all if it is embedded inside another shared object. Another issue is that the contents of hash-based objects will be lost due to the above mentioned limitation. See F (in the CPAN distribution of this module) for how to create a class that supports object sharing. Destructors may not be called on objects if those objects still exist at global destruction time. If the destructors must be called, make sure there are no circular references and that nothing is referencing the objects before the program ends. Does not support C on arrays. Does not support explicitly changing array lengths via $#array -- use C and C instead. Taking references to the elements of shared arrays and hashes does not autovivify the elements, and neither does slicing a shared array/hash over non-existent indices/keys autovivify the elements. C allows you to C<< share($hashref->{key}) >> and C<< share($arrayref->[idx]) >> without giving any error message. But the C<< $hashref->{key} >> or C<< $arrayref->[idx] >> is B shared, causing the error "lock can only be used on shared values" to occur when you attempt to C<< lock($hashref->{key}) >> or C<< lock($arrayref->[idx]) >> in another thread. Using C is unreliable for testing whether or not two shared references are equivalent (e.g., when testing for circular references). Use L, instead: use threads; use threads::shared; use Scalar::Util qw(refaddr); # If ref is shared, use threads::shared's internal ID. # Otherwise, use refaddr(). my $addr1 = is_shared($ref1) || refaddr($ref1); my $addr2 = is_shared($ref2) || refaddr($ref2); if ($addr1 == $addr2) { # The refs are equivalent } L does not work properly on shared references embedded in shared structures. For example: my %foo :shared; $foo{'bar'} = shared_clone({'a'=>'x', 'b'=>'y', 'c'=>'z'}); while (my ($key, $val) = each(%{$foo{'bar'}})) { ... } Either of the following will work instead: my $ref = $foo{'bar'}; while (my ($key, $val) = each(%{$ref})) { ... } foreach my $key (keys(%{$foo{'bar'}})) { my $val = $foo{'bar'}{$key}; ... } This module supports dual-valued variables created using C from L. However, while C<$!> acts like a dualvar, it is implemented as a tied SV. To propagate its value, use the follow construct, if needed: my $errno :shared = dualvar($!,$!); View existing bug reports at, and submit any new bugs, problems, patches, etc. to: L =head1 SEE ALSO threads::shared on MetaCPAN: L Code repository for CPAN distribution: L L, L L and L Perl threads mailing list: L Sample code in the I directory of this distribution on CPAN. =head1 AUTHOR Artur Bergman Esky AT crucially DOT netE Documentation borrowed from the old Thread.pm. CPAN version produced by Jerry D. Hedden Ejdhedden AT cpan DOT orgE. =head1 LICENSE threads::shared is released under the same license as Perl. =cut PK!C�yJJMIME/Base64.pmnu�[���
package MIME::Base64; use strict; use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); require Exporter; @ISA = qw(Exporter); @EXPORT = qw(encode_base64 decode_base64); @EXPORT_OK = qw(encode_base64url decode_base64url encoded_base64_length decoded_base64_length); $VERSION = '3.15'; require XSLoader; XSLoader::load('MIME::Base64', $VERSION); *encode = \&encode_base64; *decode = \&decode_base64; sub encode_base64url { my $e = encode_base64(shift, ""); $e =~ s/=+\z//; $e =~ tr[+/][-_]; return $e; } sub decode_base64url { my $s = shift; $s =~ tr[-_][+/]; $s .= '=' while length($s) % 4; return decode_base64($s); } 1; __END__ =head1 NAME MIME::Base64 - Encoding and decoding of base64 strings =head1 SYNOPSIS use MIME::Base64; $encoded = encode_base64('Aladdin:open sesame'); $decoded = decode_base64($encoded); =head1 DESCRIPTION This module provides functions to encode and decode strings into and from the base64 encoding specified in RFC 2045 - I. The base64 encoding is designed to represent arbitrary sequences of octets in a form that need not be humanly readable. A 65-character subset ([A-Za-z0-9+/=]) of US-ASCII is used, enabling 6 bits to be represented per printable character. The following primary functions are provided: =over 4 =item encode_base64( $bytes ) =item encode_base64( $bytes, $eol ); Encode data by calling the encode_base64() function. The first argument is the byte string to encode. The second argument is the line-ending sequence to use. It is optional and defaults to "\n". The returned encoded string is broken into lines of no more than 76 characters each and it will end with $eol unless it is empty. Pass an empty string as second argument if you do not want the encoded string to be broken into lines. The function will croak with "Wide character in subroutine entry" if $bytes contains characters with code above 255. The base64 encoding is only defined for single-byte characters. Use the Encode module to select the byte encoding you want. =item decode_base64( $str ) Decode a base64 string by calling the decode_base64() function. This function takes a single argument which is the string to decode and returns the decoded data. Any character not part of the 65-character base64 subset is silently ignored. Characters occurring after a '=' padding character are never decoded. =back If you prefer not to import these routines into your namespace, you can call them as: use MIME::Base64 (); $encoded = MIME::Base64::encode($decoded); $decoded = MIME::Base64::decode($encoded); Additional functions not exported by default: =over 4 =item encode_base64url( $bytes ) =item decode_base64url( $str ) Encode and decode according to the base64 scheme for "URL applications" [1]. This is a variant of the base64 encoding which does not use padding, does not break the string into multiple lines and use the characters "-" and "_" instead of "+" and "/" to avoid using reserved URL characters. =item encoded_base64_length( $bytes ) =item encoded_base64_length( $bytes, $eol ) Returns the length that the encoded string would have without actually encoding it. This will return the same value as C<< length(encode_base64($bytes)) >>, but should be more efficient. =item decoded_base64_length( $str ) Returns the length that the decoded string would have without actually decoding it. This will return the same value as C<< length(decode_base64($str)) >>, but should be more efficient. =back =head1 EXAMPLES If you want to encode a large file, you should encode it in chunks that are a multiple of 57 bytes. This ensures that the base64 lines line up and that you do not end up with padding in the middle. 57 bytes of data fills one complete base64 line (76 == 57*4/3): use MIME::Base64 qw(encode_base64); open(FILE, "/var/log/wtmp") or die "$!"; while (read(FILE, $buf, 60*57)) { print encode_base64($buf); } or if you know you have enough memory use MIME::Base64 qw(encode_base64); local($/) = undef; # slurp print encode_base64(); The same approach as a command line: perl -MMIME::Base64 -0777 -ne 'print encode_base64($_)' and Joerg Reichelt and code posted to comp.lang.perl <3pd2lp$6gf@wsinti07.win.tue.nl> by Hans Mulder The XS implementation uses code from metamail. Copyright 1991 Bell Communications Research, Inc. (Bellcore) =head1 SEE ALSO L [1] L =cut PK!q0����MIME/QuotedPrint.pmnu�[���
package MIME::QuotedPrint; use strict; use vars qw(@ISA @EXPORT $VERSION); require Exporter; @ISA = qw(Exporter); @EXPORT = qw(encode_qp decode_qp); $VERSION = "3.13"; use MIME::Base64; # will load XS version of {en,de}code_qp() *encode = \&encode_qp; *decode = \&decode_qp; 1; __END__ =head1 NAME MIME::QuotedPrint - Encoding and decoding of quoted-printable strings =head1 SYNOPSIS use MIME::QuotedPrint; $encoded = encode_qp($decoded); $decoded = decode_qp($encoded); =head1 DESCRIPTION This module provides functions to encode and decode strings into and from the quoted-printable encoding specified in RFC 2045 - I. The quoted-printable encoding is intended to represent data that largely consists of bytes that correspond to printable characters in the ASCII character set. Each non-printable character (as defined by English Americans) is represented by a triplet consisting of the character "=" followed by two hexadecimal digits. The following functions are provided: =over 4 =item encode_qp( $str) =item encode_qp( $str, $eol) =item encode_qp( $str, $eol, $binmode ) This function returns an encoded version of the string ($str) given as argument. The second argument ($eol) is the line-ending sequence to use. It is optional and defaults to "\n". Every occurrence of "\n" is replaced with this string, and it is also used for additional "soft line breaks" to ensure that no line end up longer than 76 characters. Pass it as "\015\012" to produce data suitable for external consumption. The string "\r\n" produces the same result on many platforms, but not all. The third argument ($binmode) will select binary mode if passed as a TRUE value. In binary mode "\n" will be encoded in the same way as any other non-printable character. This ensures that a decoder will end up with exactly the same string whatever line ending sequence it uses. In general it is preferable to use the base64 encoding for binary data; see L. An $eol of "" (the empty string) is special. In this case, no "soft line breaks" are introduced and binary mode is effectively enabled so that any "\n" in the original data is encoded as well. =item decode_qp( $str ) This function returns the plain text version of the string given as argument. The lines of the result are "\n" terminated, even if the $str argument contains "\r\n" terminated lines. =back If you prefer not to import these routines into your namespace, you can call them as: use MIME::QuotedPrint (); $encoded = MIME::QuotedPrint::encode($decoded); $decoded = MIME::QuotedPrint::decode($encoded); Perl v5.8 and better allow extended Unicode characters in strings. Such strings cannot be encoded directly, as the quoted-printable encoding is only defined for single-byte characters. The solution is to use the Encode module to select the byte encoding you want. For example: use MIME::QuotedPrint qw(encode_qp); use Encode qw(encode); $encoded = encode_qp(encode("UTF-8", "\x{FFFF}\n")); print $encoded; =head1 COPYRIGHT Copyright 1995-1997,2002-2004 Gisle Aas. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L =cut PK!�He���HTML/LinkExtor.pmnu�[���
package HTML::LinkExtor; require HTML::Parser; @ISA = qw(HTML::Parser); $VERSION = "3.69"; =head1 NAME HTML::LinkExtor - Extract links from an HTML document =head1 SYNOPSIS require HTML::LinkExtor; $p = HTML::LinkExtor->new(\&cb, "http://www.perl.org/"); sub cb { my($tag, %links) = @_; print "$tag @{[%links]}\n"; } $p->parse_file("index.html"); =head1 DESCRIPTION I is an HTML parser that extracts links from an HTML document. The I is a subclass of I. This means that the document should be given to the parser by calling the $p->parse() or $p->parse_file() methods. =cut use strict; use HTML::Tagset (); # legacy (some applications grabs this hash directly) use vars qw(%LINK_ELEMENT); *LINK_ELEMENT = \%HTML::Tagset::linkElements; =over 4 =item $p = HTML::LinkExtor->new =item $p = HTML::LinkExtor->new( $callback ) =item $p = HTML::LinkExtor->new( $callback, $base ) The constructor takes two optional arguments. The first is a reference to a callback routine. It will be called as links are found. If a callback is not provided, then links are just accumulated internally and can be retrieved by calling the $p->links() method. The $base argument is an optional base URL used to absolutize all URLs found. You need to have the I module installed if you provide $base. The callback is called with the lowercase tag name as first argument, and then all link attributes as separate key/value pairs. All non-link attributes are removed. =cut sub new { my($class, $cb, $base) = @_; my $self = $class->SUPER::new( start_h => ["_start_tag", "self,tagname,attr"], report_tags => [keys %HTML::Tagset::linkElements], ); $self->{extractlink_cb} = $cb; if ($base) { require URI; $self->{extractlink_base} = URI->new($base); } $self; } sub _start_tag { my($self, $tag, $attr) = @_; my $base = $self->{extractlink_base}; my $links = $HTML::Tagset::linkElements{$tag}; $links = [$links] unless ref $links; my @links; my $a; for $a (@$links) { next unless exists $attr->{$a}; (my $link = $attr->{$a}) =~ s/^\s+//; $link =~ s/\s+$//; # HTML5 push(@links, $a, $base ? URI->new($link, $base)->abs($base) : $link); } return unless @links; $self->_found_link($tag, @links); } sub _found_link { my $self = shift; my $cb = $self->{extractlink_cb}; if ($cb) { &$cb(@_); } else { push(@{$self->{'links'}}, [@_]); } } =item $p->links Returns a list of all links found in the document. The returned values will be anonymous arrays with the following elements: [$tag, $attr => $url1, $attr2 => $url2,...] The $p->links method will also truncate the internal link list. This means that if the method is called twice without any parsing between them the second call will return an empty list. Also note that $p->links will always be empty if a callback routine was provided when the I was created. =cut sub links { my $self = shift; exists($self->{'links'}) ? @{delete $self->{'links'}} : (); } # We override the parse_file() method so that we can clear the links # before we start a new file. sub parse_file { my $self = shift; delete $self->{'links'}; $self->SUPER::parse_file(@_); } =back =head1 EXAMPLE This is an example showing how you can extract links from a document received using LWP: use LWP::UserAgent; use HTML::LinkExtor; use URI::URL; $url = "http://www.perl.org/"; # for instance $ua = LWP::UserAgent->new; # Set up a callback that collect image links my @imgs = (); sub callback { my($tag, %attr) = @_; return if $tag ne 'img'; # we only look closer at push(@imgs, values %attr); } # Make the parser. Unfortunately, we don't know the base yet # (it might be different from $url) $p = HTML::LinkExtor->new(\&callback); # Request document and parse it as it arrives $res = $ua->request(HTTP::Request->new(GET => $url), sub {$p->parse($_[0])}); # Expand all image URLs to absolute ones my $base = $res->base; @imgs = map { $_ = url($_, $base)->abs; } @imgs; # Print them out print join("\n", @imgs), "\n"; =head1 SEE ALSO L, L, L, L =head1 COPYRIGHT Copyright 1996-2001 Gisle Aas. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; PK!,911HTML/PullParser.pmnu�[���
package HTML::PullParser; require HTML::Parser; @ISA=qw(HTML::Parser); $VERSION = "3.57"; use strict; use Carp (); sub new { my($class, %cnf) = @_; # Construct argspecs for the various events my %argspec; for (qw(start end text declaration comment process default)) { my $tmp = delete $cnf{$_}; next unless defined $tmp; $argspec{$_} = $tmp; } Carp::croak("Info not collected for any events") unless %argspec; my $file = delete $cnf{file}; my $doc = delete $cnf{doc}; Carp::croak("Can't parse from both 'doc' and 'file' at the same time") if defined($file) && defined($doc); Carp::croak("No 'doc' or 'file' given to parse from") unless defined($file) || defined($doc); # Create object $cnf{api_version} = 3; my $self = $class->SUPER::new(%cnf); my $accum = $self->{pullparser_accum} = []; while (my($event, $argspec) = each %argspec) { $self->SUPER::handler($event => $accum, $argspec); } if (defined $doc) { $self->{pullparser_str_ref} = ref($doc) ? $doc : \$doc; $self->{pullparser_str_pos} = 0; } else { if (!ref($file) && ref(\$file) ne "GLOB") { require IO::File; $file = IO::File->new($file, "r") || return; } $self->{pullparser_file} = $file; } $self; } sub handler { Carp::croak("Can't set handlers for HTML::PullParser"); } sub get_token { my $self = shift; while (!@{$self->{pullparser_accum}} && !$self->{pullparser_eof}) { if (my $f = $self->{pullparser_file}) { # must try to parse more from the file my $buf; if (read($f, $buf, 512)) { $self->parse($buf); } else { $self->eof; $self->{pullparser_eof}++; delete $self->{pullparser_file}; } } elsif (my $sref = $self->{pullparser_str_ref}) { # must try to parse more from the scalar my $pos = $self->{pullparser_str_pos}; my $chunk = substr($$sref, $pos, 512); $self->parse($chunk); $pos += length($chunk); if ($pos < length($$sref)) { $self->{pullparser_str_pos} = $pos; } else { $self->eof; $self->{pullparser_eof}++; delete $self->{pullparser_str_ref}; delete $self->{pullparser_str_pos}; } } else { die; } } shift @{$self->{pullparser_accum}}; } sub unget_token { my $self = shift; unshift @{$self->{pullparser_accum}}, @_; $self; } 1; __END__ =head1 NAME HTML::PullParser - Alternative HTML::Parser interface =head1 SYNOPSIS use HTML::PullParser; $p = HTML::PullParser->new(file => "index.html", start => 'event, tagname, @attr', end => 'event, tagname', ignore_elements => [qw(script style)], ) || die "Can't open: $!"; while (my $token = $p->get_token) { #...do something with $token } =head1 DESCRIPTION The HTML::PullParser is an alternative interface to the HTML::Parser class. It basically turns the HTML::Parser inside out. You associate a file (or any IO::Handle object or string) with the parser at construction time and then repeatedly call $parser->get_token to obtain the tags and text found in the parsed document. The following methods are provided: =over 4 =item $p = HTML::PullParser->new( file => $file, %options ) =item $p = HTML::PullParser->new( doc => \$doc, %options ) A C can be made to parse from either a file or a literal document based on whether the C or C option is passed to the parser's constructor. The C passed in can either be a file name or a file handle object. If a file name is passed, and it can't be opened for reading, then the constructor will return an undefined value and $! will tell you why it failed. Otherwise the argument is taken to be some object that the C can read() from when it needs more data. The stream will be read() until EOF, but not closed. A C can be passed plain or as a reference to a scalar. If a reference is passed then the value of this scalar should not be changed before all tokens have been extracted. Next the information to be returned for the different token types must be set up. This is done by simply associating an argspec (as defined in L) with the events you have an interest in. For instance, if you want C tokens to be reported as the string C<'S'> followed by the tagname and the attributes you might pass an C-option like this: $p = HTML::PullParser->new( doc => $document_to_parse, start => '"S", tagname, @attr', end => '"E", tagname', ); At last other C options, like C, and C, can be passed in. Note that you should not use the I_h options to set up parser handlers. That would confuse the inner logic of C. =item $token = $p->get_token This method will return the next I found in the HTML document, or C at the end of the document. The token is returned as an array reference. The content of this array match the argspec set up during C construction. =item $p->unget_token( @tokens ) If you find out you have read too many tokens you can push them back, so that they are returned again the next time $p->get_token is called. =back =head1 EXAMPLES The 'eg/hform' script shows how we might parse the form section of HTML::Documents using HTML::PullParser. =head1 SEE ALSO L, L =head1 COPYRIGHT Copyright 1998-2001 Gisle Aas. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK!=�«���HTML/Parser.pmnu�[���
package HTML::Parser; use strict; use vars qw($VERSION @ISA); $VERSION = "3.72"; require HTML::Entities; require XSLoader; XSLoader::load('HTML::Parser', $VERSION); sub new { my $class = shift; my $self = bless {}, $class; return $self->init(@_); } sub init { my $self = shift; $self->_alloc_pstate; my %arg = @_; my $api_version = delete $arg{api_version} || (@_ ? 3 : 2); if ($api_version >= 4) { require Carp; Carp::croak("API version $api_version not supported " . "by HTML::Parser $VERSION"); } if ($api_version < 3) { # Set up method callbacks compatible with HTML-Parser-2.xx $self->handler(text => "text", "self,text,is_cdata"); $self->handler(end => "end", "self,tagname,text"); $self->handler(process => "process", "self,token0,text"); $self->handler(start => "start", "self,tagname,attr,attrseq,text"); $self->handler(comment => sub { my($self, $tokens) = @_; for (@$tokens) { $self->comment($_); } }, "self,tokens"); $self->handler(declaration => sub { my $self = shift; $self->declaration(substr($_[0], 2, -1)); }, "self,text"); } if (my $h = delete $arg{handlers}) { $h = {@$h} if ref($h) eq "ARRAY"; while (my($event, $cb) = each %$h) { $self->handler($event => @$cb); } } # In the end we try to assume plain attribute or handler while (my($option, $val) = each %arg) { if ($option =~ /^(\w+)_h$/) { $self->handler($1 => @$val); } elsif ($option =~ /^(text|start|end|process|declaration|comment)$/) { require Carp; Carp::croak("Bad constructor option '$option'"); } else { $self->$option($val); } } return $self; } sub parse_file { my($self, $file) = @_; my $opened; if (!ref($file) && ref(\$file) ne "GLOB") { # Assume $file is a filename local(*F); open(F, "<", $file) || return undef; binmode(F); # should we? good for byte counts $opened++; $file = *F; } my $chunk = ''; while (read($file, $chunk, 512)) { $self->parse($chunk) || last; } close($file) if $opened; $self->eof; } sub netscape_buggy_comment # legacy { my $self = shift; require Carp; Carp::carp("netscape_buggy_comment() is deprecated. " . "Please use the strict_comment() method instead"); my $old = !$self->strict_comment; $self->strict_comment(!shift) if @_; return $old; } # set up method stubs sub text { } *start = \&text; *end = \&text; *comment = \&text; *declaration = \&text; *process = \&text; 1; __END__ =head1 NAME HTML::Parser - HTML parser class =head1 SYNOPSIS use HTML::Parser (); # Create parser object $p = HTML::Parser->new( api_version => 3, start_h => [\&start, "tagname, attr"], end_h => [\&end, "tagname"], marked_sections => 1, ); # Parse document text chunk by chunk $p->parse($chunk1); $p->parse($chunk2); #... $p->eof; # signal end of document # Parse directly from file $p->parse_file("foo.html"); # or open(my $fh, "<:utf8", "foo.html") || die; $p->parse_file($fh); =head1 DESCRIPTION Objects of the C class will recognize markup and separate it from plain text (alias data content) in HTML documents. As different kinds of markup and text are recognized, the corresponding event handlers are invoked. C is not a generic SGML parser. We have tried to make it able to deal with the HTML that is actually "out there", and it normally parses as closely as possible to the way the popular web browsers do it instead of strictly following one of the many HTML specifications from W3C. Where there is disagreement, there is often an option that you can enable to get the official behaviour. The document to be parsed may be supplied in arbitrary chunks. This makes on-the-fly parsing as documents are received from the network possible. If event driven parsing does not feel right for your application, you might want to use C. This is an C subclass that allows a more conventional program structure. =head1 METHODS The following method is used to construct a new C object: =over =item $p = HTML::Parser->new( %options_and_handlers ) This class method creates a new C object and returns it. Key/value argument pairs may be provided to assign event handlers or initialize parser options. The handlers and parser options can also be set or modified later by the method calls described below. If a top level key is in the form "_h" (e.g., "text_h") then it assigns a handler to that event, otherwise it initializes a parser option. The event handler specification value must be an array reference. Multiple handlers may also be assigned with the 'handlers => [%handlers]' option. See examples below. If new() is called without any arguments, it will create a parser that uses callback methods compatible with version 2 of C. See the section on "version 2 compatibility" below for details. The special constructor option 'api_version => 2' can be used to initialize version 2 callbacks while still setting other options and handlers. The 'api_version => 3' option can be used if you don't want to set any options and don't want to fall back to v2 compatible mode. Examples: $p = HTML::Parser->new(api_version => 3, text_h => [ sub {...}, "dtext" ]); This creates a new parser object with a text event handler subroutine that receives the original text with general entities decoded. $p = HTML::Parser->new(api_version => 3, start_h => [ 'my_start', "self,tokens" ]); This creates a new parser object with a start event handler method that receives the $p and the tokens array. $p = HTML::Parser->new(api_version => 3, handlers => { text => [\@array, "event,text"], comment => [\@array, "event,text"], }); This creates a new parser object that stores the event type and the original text in @array for text and comment events. =back The following methods feed the HTML document to the C object: =over =item $p->parse( $string ) Parse $string as the next chunk of the HTML document. Handlers invoked should not attempt to modify the $string in-place until $p->parse returns. If an invoked event handler aborts parsing by calling $p->eof, then $p->parse() will return a FALSE value. Otherwise the return value is a reference to the parser object ($p). =item $p->parse( $code_ref ) If a code reference is passed as the argument to be parsed, then the chunks to be parsed are obtained by invoking this function repeatedly. Parsing continues until the function returns an empty (or undefined) result. When this happens $p->eof is automatically signaled. Parsing will also abort if one of the event handlers calls $p->eof. The effect of this is the same as: while (1) { my $chunk = &$code_ref(); if (!defined($chunk) || !length($chunk)) { $p->eof; return $p; } $p->parse($chunk) || return undef; } But it is more efficient as this loop runs internally in XS code. =item $p->parse_file( $file ) Parse text directly from a file. The $file argument can be a filename, an open file handle, or a reference to an open file handle. If $file contains a filename and the file can't be opened, then the method returns an undefined value and $! tells why it failed. Otherwise the return value is a reference to the parser object. If a file handle is passed as the $file argument, then the file will normally be read until EOF, but not closed. If an invoked event handler aborts parsing by calling $p->eof, then $p->parse_file() may not have read the entire file. On systems with multi-byte line terminators, the values passed for the offset and length argspecs may be too low if parse_file() is called on a file handle that is not in binary mode. If a filename is passed in, then parse_file() will open the file in binary mode. =item $p->eof Signals the end of the HTML document. Calling the $p->eof method outside a handler callback will flush any remaining buffered text (which triggers the C event if there is any remaining text). Calling $p->eof inside a handler will terminate parsing at that point and cause $p->parse to return a FALSE value. This also terminates parsing by $p->parse_file(). After $p->eof has been called, the parse() and parse_file() methods can be invoked to feed new documents with the parser object. The return value from eof() is a reference to the parser object. =back Most parser options are controlled by boolean attributes. Each boolean attribute is enabled by calling the corresponding method with a TRUE argument and disabled with a FALSE argument. The attribute value is left unchanged if no argument is given. The return value from each method is the old attribute value. Methods that can be used to get and/or set parser options are: =over =item $p->attr_encoded =item $p->attr_encoded( $bool ) By default, the C and C<@attr> argspecs will have general entities for attribute values decoded. Enabling this attribute leaves entities alone. =item $p->backquote =item $p->backquote( $bool ) By default, only ' and " are recognized as quote characters around attribute values. MSIE also recognizes backquotes for some reason. Enabling this attribute provides compatibility with this behaviour. =item $p->boolean_attribute_value( $val ) This method sets the value reported for boolean attributes inside HTML start tags. By default, the name of the attribute is also used as its value. This affects the values reported for C and C argspecs. =item $p->case_sensitive =item $p->case_sensitive( $bool ) By default, tagnames and attribute names are down-cased. Enabling this attribute leaves them as found in the HTML source document. =item $p->closing_plaintext =item $p->closing_plaintext( $bool ) By default, "plaintext" element can never be closed. Everything up to the end of the document is parsed in CDATA mode. This historical behaviour is what at least MSIE does. Enabling this attribute makes closing "" tag effective and the parsing process will resume after seeing this tag. This emulates early gecko-based browsers. =item $p->empty_element_tags =item $p->empty_element_tags( $bool ) By default, empty element tags are not recognized as such and the "/" before ">" is just treated like a normal name character (unless C is enabled). Enabling this attribute make C recognize these tags. Empty element tags look like start tags, but end with the character sequence "/>" instead of ">". When recognized by C they cause an artificial end event in addition to the start event. The C for the artificial end event will be empty and the C array will be undefined even though the token array will have one element containing the tag name. =item $p->marked_sections =item $p->marked_sections( $bool ) By default, section markings like are treated like ordinary text. When this attribute is enabled section markings are honoured. There are currently no events associated with the marked section markup, but the text can be returned as C. =item $p->strict_comment =item $p->strict_comment( $bool ) By default, comments are terminated by the first occurrence of "-->". This is the behaviour of most popular browsers (like Mozilla, Opera and MSIE), but it is not correct according to the official HTML standard. Officially, you need an even number of "--" tokens before the closing ">" is recognized and there may not be anything but whitespace between an even and an odd "--". The official behaviour is enabled by enabling this attribute. Enabling of 'strict_comment' also disables recognizing these forms as comments: =item $p->strict_end =item $p->strict_end( $bool ) By default, attributes and other junk are allowed to be present on end tags in a manner that emulates MSIE's behaviour. The official behaviour is enabled with this attribute. If enabled, only whitespace is allowed between the tagname and the final ">". =item $p->strict_names =item $p->strict_names( $bool ) By default, almost anything is allowed in tag and attribute names. This is the behaviour of most popular browsers and allows us to parse some broken tags with invalid attribute values like: By default, "LIST]" is parsed as a boolean attribute, not as part of the ALT value as was clearly intended. This is also what Mozilla sees. The official behaviour is enabled by enabling this attribute. If enabled, it will cause the tag above to be reported as text since "LIST]" is not a legal attribute name. =item $p->unbroken_text =item $p->unbroken_text( $bool ) By default, blocks of text are given to the text handler as soon as possible (but the parser takes care always to break text at a boundary between whitespace and non-whitespace so single words and entities can always be decoded safely). This might create breaks that make it hard to do transformations on the text. When this attribute is enabled, blocks of text are always reported in one piece. This will delay the text event until the following (non-text) event has been recognized by the parser. Note that the C argspec will give you the offset of the first segment of text and C is the combined length of the segments. Since there might be ignored tags in between, these numbers can't be used to directly index in the original document file. =item $p->utf8_mode =item $p->utf8_mode( $bool ) Enable this option when parsing raw undecoded UTF-8. This tells the parser that the entities expanded for strings reported by C, C<@attr> and C should be expanded as decoded UTF-8 so they end up compatible with the surrounding text. If C is enabled then it is an error to pass strings containing characters with code above 255 to the parse() method, and the parse() method will croak if you try. Example: The Unicode character "\x{2665}" is "\xE2\x99\xA5" when UTF-8 encoded. The character can also be represented by the entity "♥" or "♥". If we feed the parser: $p->parse("\xE2\x99\xA5♥"); then C will be reported as "\xE2\x99\xA5\x{2665}" without C enabled, but as "\xE2\x99\xA5\xE2\x99\xA5" when enabled. The later string is what you want. This option is only available with perl-5.8 or better. =item $p->xml_mode =item $p->xml_mode( $bool ) Enabling this attribute changes the parser to allow some XML constructs. This enables the behaviour controlled by individually by the C, C, C and C attributes and also suppresses special treatment of elements that are parsed as CDATA for HTML. =item $p->xml_pic =item $p->xml_pic( $bool ) By default, I are terminated by ">". When this attribute is enabled, processing instructions are terminated by "?>" instead. =back As markup and text is recognized, handlers are invoked. The following method is used to set up handlers for different events: =over =item $p->handler( event => \&subroutine, $argspec ) =item $p->handler( event => $method_name, $argspec ) =item $p->handler( event => \@accum, $argspec ) =item $p->handler( event => "" ); =item $p->handler( event => undef ); =item $p->handler( event ); This method assigns a subroutine, method, or array to handle an event. Event is one of C, C, C, C, C, C, C, C or C. The C<\&subroutine> is a reference to a subroutine which is called to handle the event. The C<$method_name> is the name of a method of $p which is called to handle the event. The C<@accum> is an array that will hold the event information as sub-arrays. If the second argument is "", the event is ignored. If it is undef, the default handler is invoked for the event. The C<$argspec> is a string that describes the information to be reported for the event. Any requested information that does not apply to a specific event is passed as C. If argspec is omitted, then it is left unchanged. The return value from $p->handler is the old callback routine or a reference to the accumulator array. Any return values from handler callback routines/methods are always ignored. A handler callback can request parsing to be aborted by invoking the $p->eof method. A handler callback is not allowed to invoke the $p->parse() or $p->parse_file() method. An exception will be raised if it tries. Examples: $p->handler(start => "start", 'self, attr, attrseq, text' ); This causes the "start" method of object $p to be called for 'start' events. The callback signature is $p->start(\%attr, \@attr_seq, $text). $p->handler(start => \&start, 'attr, attrseq, text' ); This causes subroutine start() to be called for 'start' events. The callback signature is start(\%attr, \@attr_seq, $text). $p->handler(start => \@accum, '"S", attr, attrseq, text' ); This causes 'start' event information to be saved in @accum. The array elements will be ['S', \%attr, \@attr_seq, $text]. $p->handler(start => ""); This causes 'start' events to be ignored. It also suppresses invocations of any default handler for start events. It is in most cases equivalent to $p->handler(start => sub {}), but is more efficient. It is different from the empty-sub-handler in that C is not reset by it. $p->handler(start => undef); This causes no handler to be associated with start events. If there is a default handler it will be invoked. =back Filters based on tags can be set up to limit the number of events reported. The main bottleneck during parsing is often the huge number of callbacks made from the parser. Applying filters can improve performance significantly. The following methods control filters: =over =item $p->ignore_elements( @tags ) Both the C event and the C event as well as any events that would be reported in between are suppressed. The ignored elements can contain nested occurrences of itself. Example: $p->ignore_elements(qw(script style)); The C