+++ /dev/null
-#!/usr/local/bin/perl
-# Time-stamp: "2000-05-13 20:03:22 MDT" -*-Perl-*-
-
-package Class::ISA;
-require 5;
-use strict;
-use vars qw($Debug $VERSION);
-$VERSION = 0.32;
-$Debug = 0 unless defined $Debug;
-
-=head1 NAME
-
-Class::ISA -- report the search path for a class's ISA tree
-
-=head1 SYNOPSIS
-
- # Suppose you go: use Food::Fishstick, and that uses and
- # inherits from other things, which in turn use and inherit
- # from other things. And suppose, for sake of brevity of
- # example, that their ISA tree is the same as:
-
- @Food::Fishstick::ISA = qw(Food::Fish Life::Fungus Chemicals);
- @Food::Fish::ISA = qw(Food);
- @Food::ISA = qw(Matter);
- @Life::Fungus::ISA = qw(Life);
- @Chemicals::ISA = qw(Matter);
- @Life::ISA = qw(Matter);
- @Matter::ISA = qw();
-
- use Class::ISA;
- print "Food::Fishstick path is:\n ",
- join(", ", Class::ISA::super_path('Food::Fishstick')),
- "\n";
-
-That prints:
-
- Food::Fishstick path is:
- Food::Fish, Food, Matter, Life::Fungus, Life, Chemicals
-
-=head1 DESCRIPTION
-
-Suppose you have a class (like Food::Fish::Fishstick) that is derived,
-via its @ISA, from one or more superclasses (as Food::Fish::Fishstick
-is from Food::Fish, Life::Fungus, and Chemicals), and some of those
-superclasses may themselves each be derived, via its @ISA, from one or
-more superclasses (as above).
-
-When, then, you call a method in that class ($fishstick->calories),
-Perl first searches there for that method, but if it's not there, it
-goes searching in its superclasses, and so on, in a depth-first (or
-maybe "height-first" is the word) search. In the above example, it'd
-first look in Food::Fish, then Food, then Matter, then Life::Fungus,
-then Life, then Chemicals.
-
-This library, Class::ISA, provides functions that return that list --
-the list (in order) of names of classes Perl would search to find a
-method, with no duplicates.
-
-=head1 FUNCTIONS
-
-=over
-
-=item the function Class::ISA::super_path($CLASS)
-
-This returns the ordered list of names of classes that Perl would
-search thru in order to find a method, with no duplicates in the list.
-$CLASS is not included in the list. UNIVERSAL is not included -- if
-you need to consider it, add it to the end.
-
-
-=item the function Class::ISA::self_and_super_path($CLASS)
-
-Just like C<super_path>, except that $CLASS is included as the first
-element.
-
-=item the function Class::ISA::self_and_super_versions($CLASS)
-
-This returns a hash whose keys are $CLASS and its
-(super-)superclasses, and whose values are the contents of each
-class's $VERSION (or undef, for classes with no $VERSION).
-
-The code for self_and_super_versions is meant to serve as an example
-for precisely the kind of tasks I anticipate that self_and_super_path
-and super_path will be used for. You are strongly advised to read the
-source for self_and_super_versions, and the comments there.
-
-=back
-
-=head1 CAUTIONARY NOTES
-
-* Class::ISA doesn't export anything. You have to address the
-functions with a "Class::ISA::" on the front.
-
-* Contrary to its name, Class::ISA isn't a class; it's just a package.
-Strange, isn't it?
-
-* Say you have a loop in the ISA tree of the class you're calling one
-of the Class::ISA functions on: say that Food inherits from Matter,
-but Matter inherits from Food (for sake of argument). If Perl, while
-searching for a method, actually discovers this cyclicity, it will
-throw a fatal error. The functions in Class::ISA effectively ignore
-this cyclicity; the Class::ISA algorithm is "never go down the same
-path twice", and cyclicities are just a special case of that.
-
-* The Class::ISA functions just look at @ISAs. But theoretically, I
-suppose, AUTOLOADs could bypass Perl's ISA-based search mechanism and
-do whatever they please. That would be bad behavior, tho; and I try
-not to think about that.
-
-* If Perl can't find a method anywhere in the ISA tree, it then looks
-in the magical class UNIVERSAL. This is rarely relevant to the tasks
-that I expect Class::ISA functions to be put to, but if it matters to
-you, then instead of this:
-
- @supers = Class::Tree::super_path($class);
-
-do this:
-
- @supers = (Class::Tree::super_path($class), 'UNIVERSAL');
-
-And don't say no-one ever told ya!
-
-* When you call them, the Class::ISA functions look at @ISAs anew --
-that is, there is no memoization, and so if ISAs change during
-runtime, you get the current ISA tree's path, not anything memoized.
-However, changing ISAs at runtime is probably a sign that you're out
-of your mind!
-
-=head1 COPYRIGHT
-
-Copyright (c) 1999, 2000 Sean M. Burke. All rights reserved.
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=head1 AUTHOR
-
-Sean M. Burke C<sburke@cpan.org>
-
-=cut
-
-###########################################################################
-
-sub self_and_super_versions {
- no strict 'refs';
- map {
- $_ => (defined(${"$_\::VERSION"}) ? ${"$_\::VERSION"} : undef)
- } self_and_super_path($_[0])
-}
-
-# Also consider magic like:
-# no strict 'refs';
-# my %class2SomeHashr =
-# map { defined(%{"$_\::SomeHash"}) ? ($_ => \%{"$_\::SomeHash"}) : () }
-# Class::ISA::self_and_super_path($class);
-# to get a hash of refs to all the defined (and non-empty) hashes in
-# $class and its superclasses.
-#
-# Or even consider this incantation for doing something like hash-data
-# inheritance:
-# no strict 'refs';
-# %union_hash =
-# map { defined(%{"$_\::SomeHash"}) ? %{"$_\::SomeHash"}) : () }
-# reverse(Class::ISA::self_and_super_path($class));
-# Consider that reverse() is necessary because with
-# %foo = ('a', 'wun', 'b', 'tiw', 'a', 'foist');
-# $foo{'a'} is 'foist', not 'wun'.
-
-###########################################################################
-sub super_path {
- my @ret = &self_and_super_path(@_);
- shift @ret if @ret;
- return @ret;
-}
-
-#--------------------------------------------------------------------------
-sub self_and_super_path {
- # Assumption: searching is depth-first.
- # Assumption: '' (empty string) can't be a class package name.
- # Note: 'UNIVERSAL' is not given any special treatment.
- return () unless @_;
-
- my @out = ();
-
- my @in_stack = ($_[0]);
- my %seen = ($_[0] => 1);
-
- my $current;
- while(@in_stack) {
- next unless defined($current = shift @in_stack) && length($current);
- print "At $current\n" if $Debug;
- push @out, $current;
- no strict 'refs';
- unshift @in_stack,
- map
- { my $c = $_; # copy, to avoid being destructive
- substr($c,0,2) = "main::" if substr($c,0,2) eq '::';
- # Canonize the :: -> main::, ::foo -> main::foo thing.
- # Should I ever canonize the Foo'Bar = Foo::Bar thing?
- $seen{$c}++ ? () : $c;
- }
- @{"$current\::ISA"}
- ;
- # I.e., if this class has any parents (at least, ones I've never seen
- # before), push them, in order, onto the stack of classes I need to
- # explore.
- }
-
- return @out;
-}
-#--------------------------------------------------------------------------
-1;
-
-__END__
+++ /dev/null
-package Digest;
-
-use strict;
-use vars qw($VERSION %MMAP $AUTOLOAD);
-
-$VERSION = "1.00";
-
-%MMAP = (
- "SHA-1" => "Digest::SHA1",
- "HMAC-MD5" => "Digest::HMAC_MD5",
- "HMAC-SHA-1" => "Digest::HMAC_SHA1",
-);
-
-sub new
-{
- shift; # class ignored
- my $algorithm = shift;
- my $class = $MMAP{$algorithm} || "Digest::$algorithm";
- no strict 'refs';
- unless (exists ${"$class\::"}{"VERSION"}) {
- eval "require $class";
- die $@ if $@;
- }
- $class->new(@_);
-}
-
-sub AUTOLOAD
-{
- my $class = shift;
- my $algorithm = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
- $class->new($algorithm, @_);
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Digest:: - Modules that calculate message digests
-
-=head1 SYNOPSIS
-
- $md2 = Digest->MD2;
- $md5 = Digest->MD5;
-
- $sha1 = Digest->SHA1;
- $sha1 = Digest->new("SHA-1");
-
- $hmac = Digest->HMAC_MD5($key);
-
-=head1 DESCRIPTION
-
-The C<Digest::> modules calculate digests, also called "fingerprints"
-or "hashes", of some data, called a message. The digest is (usually)
-some small/fixed size string. The actual size of the digest depend of
-the algorithm used. The message is simply a sequence of arbitrary
-bytes.
-
-An important property of the digest algorithms is that the digest is
-I<likely> to change if the message change in some way. Another
-property is that digest functions are one-way functions, i.e. it
-should be I<hard> to find a message that correspond to some given
-digest. Algorithms differ in how "likely" and how "hard", as well as
-how efficient they are to compute.
-
-All C<Digest::> modules provide the same programming interface. A
-functional interface for simple use, as well as an object oriented
-interface that can handle messages of arbitrary length and which can
-read files directly.
-
-The digest can be delivered in three formats:
-
-=over 8
-
-=item I<binary>
-
-This is the most compact form, but it is not well suited for printing
-or embedding in places that can't handle arbitrary data.
-
-=item I<hex>
-
-A twice as long string of (lowercase) hexadecimal digits.
-
-=item I<base64>
-
-A string of portable printable characters. This is the base64 encoded
-representation of the digest with any trailing padding removed. The
-string will be about 30% longer than the binary version.
-L<MIME::Base64> tells you more about this encoding.
-
-=back
-
-
-The functional interface is simply importable functions with the same
-name as the algorithm. The functions take the message as argument and
-return the digest. Example:
-
- use Digest::MD5 qw(md5);
- $digest = md5($message);
-
-There are also versions of the functions with "_hex" or "_base64"
-appended to the name, which returns the digest in the indicated form.
-
-=head1 OO INTERFACE
-
-The following methods are available for all C<Digest::> modules:
-
-=over 4
-
-=item $ctx = Digest->XXX($arg,...)
-
-=item $ctx = Digest->new(XXX => $arg,...)
-
-=item $ctx = Digest::XXX->new($arg,...)
-
-The constructor returns some object that encapsulate the state of the
-message-digest algorithm. You can add data to the object and finally
-ask for the digest. The "XXX" should of course be replaced by the proper
-name of the digest algorithm you want to use.
-
-The two first forms are simply syntactic sugar which automatically
-load the right module on first use. The second form allow you to use
-algorithm names which contains letters which are not legal perl
-identifiers, e.g. "SHA-1".
-
-If new() is called as a instance method (i.e. $ctx->new) it will just
-reset the state the object to the state of a newly created object. No
-new object is created in this case, and the return value is the
-reference to the object (i.e. $ctx).
-
-=item $ctx->reset
-
-This is just an alias for $ctx->new.
-
-=item $ctx->add($data,...)
-
-The $data provided as argument are appended to the message we
-calculate the digest for. The return value is the $ctx object itself.
-
-=item $ctx->addfile($io_handle)
-
-The $io_handle is read until EOF and the content is appended to the
-message we calculate the digest for. The return value is the $ctx
-object itself.
-
-=item $ctx->digest
-
-Return the binary digest for the message.
-
-Note that the C<digest> operation is effectively a destructive,
-read-once operation. Once it has been performed, the $ctx object is
-automatically C<reset> and can be used to calculate another digest
-value.
-
-=item $ctx->hexdigest
-
-Same as $ctx->digest, but will return the digest in hexadecimal form.
-
-=item $ctx->b64digest
-
-Same as $ctx->digest, but will return the digest as a base64 encoded
-string.
-
-=back
-
-=head1 SEE ALSO
-
-L<Digest::MD5>, L<Digest::SHA1>, L<Digest::HMAC>, L<Digest::MD2>
-
-L<MIME::Base64>
-
-=head1 AUTHOR
-
-Gisle Aas <gisle@aas.no>
-
-The C<Digest::> interface is based on the interface originally
-developed by Neil Winton for his C<MD5> module.
-
-=cut
+++ /dev/null
-package Filter::Simple;
-
-use Text::Balanced ':ALL';
-
-use vars qw{ $VERSION @EXPORT };
-
-$VERSION = '0.77';
-
-use Filter::Util::Call;
-use Carp;
-
-@EXPORT = qw( FILTER FILTER_ONLY );
-
-
-sub import {
- if (@_>1) { shift; goto &FILTER }
- else { *{caller()."::$_"} = \&$_ foreach @EXPORT }
-}
-
-sub FILTER (&;$) {
- my $caller = caller;
- my ($filter, $terminator) = @_;
- no warnings 'redefine';
- *{"${caller}::import"} = gen_filter_import($caller,$filter,$terminator);
- *{"${caller}::unimport"} = gen_filter_unimport($caller);
-}
-
-sub fail {
- croak "FILTER_ONLY: ", @_;
-}
-
-my $exql = sub {
- my @bits = extract_quotelike $_[0], qr//;
- return unless $bits[0];
- return \@bits;
-};
-
-my $ws = qr/\s+/;
-my $id = qr/\b(?!([ysm]|q[rqxw]?|tr)\b)\w+/;
-my $EOP = qr/\n\n|\Z/;
-my $CUT = qr/\n=cut.*$EOP/;
-my $pod_or_DATA = qr/
- ^=(?:head[1-4]|item) .*? $CUT
- | ^=pod .*? $CUT
- | ^=for .*? $EOP
- | ^=begin \s* (\S+) .*? \n=end \s* \1 .*? $EOP
- | ^__(DATA|END)__\n.*
- /smx;
-
-my %extractor_for = (
- quotelike => [ $ws, $id, { MATCH => \&extract_quotelike } ],
- regex => [ $ws, $pod_or_DATA, $id, $exql ],
- string => [ $ws, $pod_or_DATA, $id, $exql ],
- code => [ $ws, { DONT_MATCH => $pod_or_DATA },
- $id, { DONT_MATCH => \&extract_quotelike } ],
- executable => [ $ws, { DONT_MATCH => $pod_or_DATA } ],
- all => [ { MATCH => qr/(?s:.*)/ } ],
-);
-
-my %selector_for = (
- all => sub { my ($t)=@_; sub{ $_=$$_; $t->(@_); $_} },
- executable=> sub { my ($t)=@_; sub{ref() ? $_=$$_ : $t->(@_); $_} },
- quotelike => sub { my ($t)=@_; sub{ref() && do{$_=$$_; $t->(@_)}; $_} },
- regex => sub { my ($t)=@_;
- sub{ref() or return $_;
- my ($ql,undef,$pre,$op,$ld,$pat) = @$_;
- return $_->[0] unless $op =~ /^(qr|m|s)/
- || !$op && ($ld eq '/' || $ld eq '?');
- $_ = $pat;
- $t->(@_);
- $ql =~ s/^(\s*\Q$op\E\s*\Q$ld\E)\Q$pat\E/$1$_/;
- return "$pre$ql";
- };
- },
- string => sub { my ($t)=@_;
- sub{ref() or return $_;
- local *args = \@_;
- my ($pre,$op,$ld1,$str1,$rd1,$ld2,$str2,$rd2,$flg) = @{$_}[2..10];
- return $_->[0] if $op =~ /^(qr|m)/
- || !$op && ($ld1 eq '/' || $ld1 eq '?');
- if (!$op || $op eq 'tr' || $op eq 'y') {
- local *_ = \$str1;
- $t->(@args);
- }
- if ($op =~ /^(tr|y|s)/) {
- local *_ = \$str2;
- $t->(@args);
- }
- my $result = "$pre$op$ld1$str1$rd1";
- $result .= $ld2 if $ld1 =~ m/[[({<]/; #])}>
- $result .= "$str2$rd2$flg";
- return $result;
- };
- },
-);
-
-
-sub gen_std_filter_for {
- my ($type, $transform) = @_;
- return sub { my (@pieces, $instr);
- for (extract_multiple($_,$extractor_for{$type})) {
- if (ref()) { push @pieces, $_; $instr=0 }
- elsif ($instr) { $pieces[-1] .= $_ }
- else { push @pieces, $_; $instr=1 }
- }
- if ($type eq 'code') {
- my $count = 0;
- local $placeholder = qr/\Q$;\E(?:\C{4})\Q$;\E/;
- my $extractor = qr/\Q$;\E(\C{4})\Q$;\E/;
- $_ = join "",
- map { ref $_ ? $;.pack('N',$count++).$; : $_ }
- @pieces;
- @pieces = grep { ref $_ } @pieces;
- $transform->(@_);
- s/$extractor/${$pieces[unpack('N',$1)]}/g;
- }
- else {
- my $selector = $selector_for{$type}->($transform);
- $_ = join "", map $selector->(@_), @pieces;
- }
- }
-};
-
-sub FILTER_ONLY {
- my $caller = caller;
- while (@_ > 1) {
- my ($what, $how) = splice(@_, 0, 2);
- fail "Unknown selector: $what"
- unless exists $extractor_for{$what};
- fail "Filter for $what is not a subroutine reference"
- unless ref $how eq 'CODE';
- push @transforms, gen_std_filter_for($what,$how);
- }
- my $terminator = shift;
-
- my $multitransform = sub {
- foreach my $transform ( @transforms ) {
- $transform->(@_);
- }
- };
- no warnings 'redefine';
- *{"${caller}::import"} =
- gen_filter_import($caller,$multitransform,$terminator);
- *{"${caller}::unimport"} = gen_filter_unimport($caller);
-}
-
-my $ows = qr/(?:[ \t]+|#[^\n]*)*/;
-
-sub gen_filter_import {
- my ($class, $filter, $terminator) = @_;
- my %terminator;
- my $prev_import = *{$class."::import"}{CODE};
- return sub {
- my ($imported_class, @args) = @_;
- my $def_terminator =
- qr/^(?:\s*no\s+$imported_class\s*;$ows|__(?:END|DATA)__)$/;
- if (!defined $terminator) {
- $terminator{terminator} = $def_terminator;
- }
- elsif (!ref $terminator || ref $terminator eq 'Regexp') {
- $terminator{terminator} = $terminator;
- }
- elsif (ref $terminator ne 'HASH') {
- croak "Terminator must be specified as scalar or hash ref"
- }
- elsif (!exists $terminator->{terminator}) {
- $terminator{terminator} = $def_terminator;
- }
- filter_add(
- sub {
- my ($status, $lastline);
- my $count = 0;
- my $data = "";
- while ($status = filter_read()) {
- return $status if $status < 0;
- if ($terminator{terminator} &&
- m/$terminator{terminator}/) {
- $lastline = $_;
- last;
- }
- $data .= $_;
- $count++;
- $_ = "";
- }
- $_ = $data;
- $filter->($imported_class, @args) unless $status < 0;
- if (defined $lastline) {
- if (defined $terminator{becomes}) {
- $_ .= $terminator{becomes};
- }
- elsif ($lastline =~ $def_terminator) {
- $_ .= $lastline;
- }
- }
- return $count;
- }
- );
- if ($prev_import) {
- goto &$prev_import;
- }
- elsif ($class->isa('Exporter')) {
- $class->export_to_level(1,@_);
- }
- }
-}
-
-sub gen_filter_unimport {
- my ($class) = @_;
- my $prev_unimport = *{$class."::unimport"}{CODE};
- return sub {
- filter_del();
- goto &$prev_unimport if $prev_unimport;
- }
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Filter::Simple - Simplified source filtering
-
-
-=head1 SYNOPSIS
-
- # in MyFilter.pm:
-
- package MyFilter;
-
- use Filter::Simple;
-
- FILTER { ... };
-
- # or just:
- #
- # use Filter::Simple sub { ... };
-
- # in user's code:
-
- use MyFilter;
-
- # this code is filtered
-
- no MyFilter;
-
- # this code is not
-
-
-=head1 DESCRIPTION
-
-=head2 The Problem
-
-Source filtering is an immensely powerful feature of recent versions of Perl.
-It allows one to extend the language itself (e.g. the Switch module), to
-simplify the language (e.g. Language::Pythonesque), or to completely recast the
-language (e.g. Lingua::Romana::Perligata). Effectively, it allows one to use
-the full power of Perl as its own, recursively applied, macro language.
-
-The excellent Filter::Util::Call module (by Paul Marquess) provides a
-usable Perl interface to source filtering, but it is often too powerful
-and not nearly as simple as it could be.
-
-To use the module it is necessary to do the following:
-
-=over 4
-
-=item 1.
-
-Download, build, and install the Filter::Util::Call module.
-(If you have Perl 5.7.1 or later, this is already done for you.)
-
-=item 2.
-
-Set up a module that does a C<use Filter::Util::Call>.
-
-=item 3.
-
-Within that module, create an C<import> subroutine.
-
-=item 4.
-
-Within the C<import> subroutine do a call to C<filter_add>, passing
-it either a subroutine reference.
-
-=item 5.
-
-Within the subroutine reference, call C<filter_read> or C<filter_read_exact>
-to "prime" $_ with source code data from the source file that will
-C<use> your module. Check the status value returned to see if any
-source code was actually read in.
-
-=item 6.
-
-Process the contents of $_ to change the source code in the desired manner.
-
-=item 7.
-
-Return the status value.
-
-=item 8.
-
-If the act of unimporting your module (via a C<no>) should cause source
-code filtering to cease, create an C<unimport> subroutine, and have it call
-C<filter_del>. Make sure that the call to C<filter_read> or
-C<filter_read_exact> in step 5 will not accidentally read past the
-C<no>. Effectively this limits source code filters to line-by-line
-operation, unless the C<import> subroutine does some fancy
-pre-pre-parsing of the source code it's filtering.
-
-=back
-
-For example, here is a minimal source code filter in a module named
-BANG.pm. It simply converts every occurrence of the sequence C<BANG\s+BANG>
-to the sequence C<die 'BANG' if $BANG> in any piece of code following a
-C<use BANG;> statement (until the next C<no BANG;> statement, if any):
-
- package BANG;
-
- use Filter::Util::Call ;
-
- sub import {
- filter_add( sub {
- my $caller = caller;
- my ($status, $no_seen, $data);
- while ($status = filter_read()) {
- if (/^\s*no\s+$caller\s*;\s*?$/) {
- $no_seen=1;
- last;
- }
- $data .= $_;
- $_ = "";
- }
- $_ = $data;
- s/BANG\s+BANG/die 'BANG' if \$BANG/g
- unless $status < 0;
- $_ .= "no $class;\n" if $no_seen;
- return 1;
- })
- }
-
- sub unimport {
- filter_del();
- }
-
- 1 ;
-
-This level of sophistication puts filtering out of the reach of
-many programmers.
-
-
-=head2 A Solution
-
-The Filter::Simple module provides a simplified interface to
-Filter::Util::Call; one that is sufficient for most common cases.
-
-Instead of the above process, with Filter::Simple the task of setting up
-a source code filter is reduced to:
-
-=over 4
-
-=item 1.
-
-Download and install the Filter::Simple module.
-(If you have Perl 5.7.1 or later, this is already done for you.)
-
-=item 2.
-
-Set up a module that does a C<use Filter::Simple> and then
-calls C<FILTER { ... }>.
-
-=item 3.
-
-Within the anonymous subroutine or block that is passed to
-C<FILTER>, process the contents of $_ to change the source code in
-the desired manner.
-
-=back
-
-In other words, the previous example, would become:
-
- package BANG;
- use Filter::Simple;
-
- FILTER {
- s/BANG\s+BANG/die 'BANG' if \$BANG/g;
- };
-
- 1 ;
-
-
-=head2 Disabling or changing <no> behaviour
-
-By default, the installed filter only filters up to a line consisting of one of
-the three standard source "terminators":
-
- no ModuleName; # optional comment
-
-or:
-
- __END__
-
-or:
-
- __DATA__
-
-but this can be altered by passing a second argument to C<use Filter::Simple>
-or C<FILTER> (just remember: there's I<no> comma after the initial block when
-you use C<FILTER>).
-
-That second argument may be either a C<qr>'d regular expression (which is then
-used to match the terminator line), or a defined false value (which indicates
-that no terminator line should be looked for), or a reference to a hash
-(in which case the terminator is the value associated with the key
-C<'terminator'>.
-
-For example, to cause the previous filter to filter only up to a line of the
-form:
-
- GNAB esu;
-
-you would write:
-
- package BANG;
- use Filter::Simple;
-
- FILTER {
- s/BANG\s+BANG/die 'BANG' if \$BANG/g;
- }
- qr/^\s*GNAB\s+esu\s*;\s*?$/;
-
-or:
-
- FILTER {
- s/BANG\s+BANG/die 'BANG' if \$BANG/g;
- }
- { terminator => qr/^\s*GNAB\s+esu\s*;\s*?$/ };
-
-and to prevent the filter's being turned off in any way:
-
- package BANG;
- use Filter::Simple;
-
- FILTER {
- s/BANG\s+BANG/die 'BANG' if \$BANG/g;
- }
- ""; # or: 0
-
-or:
-
- FILTER {
- s/BANG\s+BANG/die 'BANG' if \$BANG/g;
- }
- { terminator => "" };
-
-B<Note that, no matter what you set the terminator pattern too,
-the actual terminator itself I<must> be contained on a single source line.>
-
-
-=head2 All-in-one interface
-
-Separating the loading of Filter::Simple:
-
- use Filter::Simple;
-
-from the setting up of the filtering:
-
- FILTER { ... };
-
-is useful because it allows other code (typically parser support code
-or caching variables) to be defined before the filter is invoked.
-However, there is often no need for such a separation.
-
-In those cases, it is easier to just append the filtering subroutine and
-any terminator specification directly to the C<use> statement that loads
-Filter::Simple, like so:
-
- use Filter::Simple sub {
- s/BANG\s+BANG/die 'BANG' if \$BANG/g;
- };
-
-This is exactly the same as:
-
- use Filter::Simple;
- BEGIN {
- Filter::Simple::FILTER {
- s/BANG\s+BANG/die 'BANG' if \$BANG/g;
- };
- }
-
-except that the C<FILTER> subroutine is not exported by Filter::Simple.
-
-
-=head2 Filtering only specific components of source code
-
-One of the problems with a filter like:
-
- use Filter::Simple;
-
- FILTER { s/BANG\s+BANG/die 'BANG' if \$BANG/g };
-
-is that it indiscriminately applies the specified transformation to
-the entire text of your source program. So something like:
-
- warn 'BANG BANG, YOU'RE DEAD';
- BANG BANG;
-
-will become:
-
- warn 'die 'BANG' if $BANG, YOU'RE DEAD';
- die 'BANG' if $BANG;
-
-It is very common when filtering source to only want to apply the filter
-to the non-character-string parts of the code, or alternatively to I<only>
-the character strings.
-
-Filter::Simple supports this type of filtering by automatically
-exporting the C<FILTER_ONLY> subroutine.
-
-C<FILTER_ONLY> takes a sequence of specifiers that install separate
-(and possibly multiple) filters that act on only parts of the source code.
-For example:
-
- use Filter::Simple;
-
- FILTER_ONLY
- code => sub { s/BANG\s+BANG/die 'BANG' if \$BANG/g },
- quotelike => sub { s/BANG\s+BANG/CHITTY CHITYY/g };
-
-The C<"code"> subroutine will only be used to filter parts of the source
-code that are not quotelikes, POD, or C<__DATA__>. The C<quotelike>
-subroutine only filters Perl quotelikes (including here documents).
-
-The full list of alternatives is:
-
-=over
-
-=item C<"code">
-
-Filters only those sections of the source code that are not quotelikes, POD, or
-C<__DATA__>.
-
-=item C<"executable">
-
-Filters only those sections of the source code that are not POD or C<__DATA__>.
-
-=item C<"quotelike">
-
-Filters only Perl quotelikes (as interpreted by
-C<&Text::Balanced::extract_quotelike>).
-
-=item C<"string">
-
-Filters only the string literal parts of a Perl quotelike (i.e. the
-contents of a string literal, either half of a C<tr///>, the second
-half of an C<s///>).
-
-=item C<"regex">
-
-Filters only the pattern literal parts of a Perl quotelike (i.e. the
-contents of a C<qr//> or an C<m//>, the first half of an C<s///>).
-
-=item C<"all">
-
-Filters everything. Identical in effect to C<FILTER>.
-
-=back
-
-Except for C<< FILTER_ONLY code => sub {...} >>, each of
-the component filters is called repeatedly, once for each component
-found in the source code.
-
-Note that you can also apply two or more of the same type of filter in
-a single C<FILTER_ONLY>. For example, here's a simple
-macro-preprocessor that is only applied within regexes,
-with a final debugging pass that printd the resulting source code:
-
- use Regexp::Common;
- FILTER_ONLY
- regex => sub { s/!\[/[^/g },
- regex => sub { s/%d/$RE{num}{int}/g },
- regex => sub { s/%f/$RE{num}{real}/g },
- all => sub { print if $::DEBUG };
-
-
-
-=head2 Filtering only the code parts of source code
-
-Most source code ceases to be grammatically correct when it is broken up
-into the pieces between string literals and regexes. So the C<'code'>
-component filter behaves slightly differently from the other partial filters
-described in the previous section.
-
-Rather than calling the specified processor on each individual piece of
-code (i.e. on the bits between quotelikes), the C<'code'> partial filter
-operates on the entire source code, but with the quotelike bits
-"blanked out".
-
-That is, a C<'code'> filter I<replaces> each quoted string, quotelike,
-regex, POD, and __DATA__ section with a placeholder. The
-delimiters of this placeholder are the contents of the C<$;> variable
-at the time the filter is applied (normally C<"\034">). The remaining
-four bytes are a unique identifier for the component being replaced.
-
-This approach makes it comparatively easy to write code preprocessors
-without worrying about the form or contents of strings, regexes, etc.
-For convenience, during a C<'code'> filtering operation, Filter::Simple
-provides a package variable (C<$Filter::Simple::placeholder>) that contains
-a pre-compiled regex that matches any placeholder. Placeholders can be
-moved and re-ordered within the source code as needed.
-
-Once the filtering has been applied, the original strings, regexes,
-POD, etc. are re-inserted into the code, by replacing each
-placeholder with the corresponding original component.
-
-For example, the following filter detects concatentated pairs of
-strings/quotelikes and reverses the order in which they are
-concatenated:
-
- package DemoRevCat;
- use Filter::Simple;
-
- FILTER_ONLY code => sub { my $ph = $Filter::Simple::placeholder;
- s{ ($ph) \s* [.] \s* ($ph) }{ $2.$1 }gx
- };
-
-Thus, the following code:
-
- use DemoRevCat;
-
- my $str = "abc" . q(def);
-
- print "$str\n";
-
-would become:
-
- my $str = q(def)."abc";
-
- print "$str\n";
-
-and hence print:
-
- defabc
-
-
-=head2 Using Filter::Simple with an explicit C<import> subroutine
-
-Filter::Simple generates a special C<import> subroutine for
-your module (see L<"How it works">) which would normally replace any
-C<import> subroutine you might have explicitly declared.
-
-However, Filter::Simple is smart enough to notice your existing
-C<import> and Do The Right Thing with it.
-That is, if you explcitly define an C<import> subroutine in a package
-that's using Filter::Simple, that C<import> subroutine will still
-be invoked immediately after any filter you install.
-
-The only thing you have to remember is that the C<import> subroutine
-I<must> be declared I<before> the filter is installed. If you use C<FILTER>
-to install the filter:
-
- package Filter::TurnItUpTo11;
-
- use Filter::Simple;
-
- FILTER { s/(\w+)/\U$1/ };
-
-that will almost never be a problem, but if you install a filtering
-subroutine by passing it directly to the C<use Filter::Simple>
-statement:
-
- package Filter::TurnItUpTo11;
-
- use Filter::Simple sub{ s/(\w+)/\U$1/ };
-
-then you must make sure that your C<import> subroutine appears before
-that C<use> statement.
-
-
-=head2 Using Filter::Simple and Exporter together
-
-Likewise, Filter::Simple is also smart enough
-to Do The Right Thing if you use Exporter:
-
- package Switch;
- use base Exporter;
- use Filter::Simple;
-
- @EXPORT = qw(switch case);
- @EXPORT_OK = qw(given when);
-
- FILTER { $_ = magic_Perl_filter($_) }
-
-Immediately after the filter has been applied to the source,
-Filter::Simple will pass control to Exporter, so it can do its magic too.
-
-Of course, here too, Filter::Simple has to know you're using Exporter
-before it applies the filter. That's almost never a problem, but if you're
-nervous about it, you can guarantee that things will work correctly by
-ensuring that your C<use base Exporter> always precedes your
-C<use Filter::Simple>.
-
-
-=head2 How it works
-
-The Filter::Simple module exports into the package that calls C<FILTER>
-(or C<use>s it directly) -- such as package "BANG" in the above example --
-two automagically constructed
-subroutines -- C<import> and C<unimport> -- which take care of all the
-nasty details.
-
-In addition, the generated C<import> subroutine passes its own argument
-list to the filtering subroutine, so the BANG.pm filter could easily
-be made parametric:
-
- package BANG;
-
- use Filter::Simple;
-
- FILTER {
- my ($die_msg, $var_name) = @_;
- s/BANG\s+BANG/die '$die_msg' if \${$var_name}/g;
- };
-
- # and in some user code:
-
- use BANG "BOOM", "BAM"; # "BANG BANG" becomes: die 'BOOM' if $BAM
-
-
-The specified filtering subroutine is called every time a C<use BANG> is
-encountered, and passed all the source code following that call, up to
-either the next C<no BANG;> (or whatever terminator you've set) or the
-end of the source file, whichever occurs first. By default, any C<no
-BANG;> call must appear by itself on a separate line, or it is ignored.
-
-
-=head1 AUTHOR
-
-Damian Conway (damian@conway.org)
-
-=head1 COPYRIGHT
-
- Copyright (c) 2000-2001, Damian Conway. All Rights Reserved.
- This module is free software. It may be used, redistributed
- and/or modified under the same terms as Perl itself.
+++ /dev/null
-# -*- mode: perl; perl-indent-level: 2; -*-
-# Memoize.pm
-#
-# Transparent memoization of idempotent functions
-#
-# Copyright 1998, 1999, 2000, 2001 M-J. Dominus.
-# You may copy and distribute this program under the
-# same terms as Perl itself. If in doubt,
-# write to mjd-perl-memoize+@plover.com for a license.
-#
-# Version 0.66 $Revision: 1.18 $ $Date: 2001/06/24 17:16:47 $
-
-package Memoize;
-$VERSION = '0.66';
-
-# Compile-time constants
-sub SCALAR () { 0 }
-sub LIST () { 1 }
-
-
-#
-# Usage memoize(functionname/ref,
-# { NORMALIZER => coderef, INSTALL => name,
-# LIST_CACHE => descriptor, SCALAR_CACHE => descriptor }
-#
-
-use Carp;
-use Exporter;
-use vars qw($DEBUG);
-use Config; # Dammit.
-@ISA = qw(Exporter);
-@EXPORT = qw(memoize);
-@EXPORT_OK = qw(unmemoize flush_cache);
-use strict;
-
-my %memotable;
-my %revmemotable;
-my @CONTEXT_TAGS = qw(MERGE TIE MEMORY FAULT HASH);
-my %IS_CACHE_TAG = map {($_ => 1)} @CONTEXT_TAGS;
-
-# Raise an error if the user tries to specify one of thesepackage as a
-# tie for LIST_CACHE
-
-my %scalar_only = map {($_ => 1)} qw(DB_File GDBM_File SDBM_File ODBM_File NDBM_File);
-
-sub memoize {
- my $fn = shift;
- my %options = @_;
- my $options = \%options;
-
- unless (defined($fn) &&
- (ref $fn eq 'CODE' || ref $fn eq '')) {
- croak "Usage: memoize 'functionname'|coderef {OPTIONS}";
- }
-
- my $uppack = caller; # TCL me Elmo!
- my $cref; # Code reference to original function
- my $name = (ref $fn ? undef : $fn);
-
- # Convert function names to code references
- $cref = &_make_cref($fn, $uppack);
-
- # Locate function prototype, if any
- my $proto = prototype $cref;
- if (defined $proto) { $proto = "($proto)" }
- else { $proto = "" }
-
- # I would like to get rid of the eval, but there seems not to be any
- # other way to set the prototype properly. The switch here for
- # 'usethreads' works around a bug in threadperl having to do with
- # magic goto. It would be better to fix the bug and use the magic
- # goto version everywhere.
- my $wrapper =
- $Config{usethreads}
- ? eval "sub $proto { &_memoizer(\$cref, \@_); }"
- : eval "sub $proto { unshift \@_, \$cref; goto &_memoizer; }";
-
- my $normalizer = $options{NORMALIZER};
- if (defined $normalizer && ! ref $normalizer) {
- $normalizer = _make_cref($normalizer, $uppack);
- }
-
- my $install_name;
- if (defined $options->{INSTALL}) {
- # INSTALL => name
- $install_name = $options->{INSTALL};
- } elsif (! exists $options->{INSTALL}) {
- # No INSTALL option provided; use original name if possible
- $install_name = $name;
- } else {
- # INSTALL => undef means don't install
- }
-
- if (defined $install_name) {
- $install_name = $uppack . '::' . $install_name
- unless $install_name =~ /::/;
- no strict;
- local($^W) = 0; # ``Subroutine $install_name redefined at ...''
- *{$install_name} = $wrapper; # Install memoized version
- }
-
- $revmemotable{$wrapper} = "" . $cref; # Turn code ref into hash key
-
- # These will be the caches
- my %caches;
- for my $context (qw(SCALAR LIST)) {
- # suppress subsequent 'uninitialized value' warnings
- $options{"${context}_CACHE"} ||= '';
-
- my $cache_opt = $options{"${context}_CACHE"};
- my @cache_opt_args;
- if (ref $cache_opt) {
- @cache_opt_args = @$cache_opt;
- $cache_opt = shift @cache_opt_args;
- }
- if ($cache_opt eq 'FAULT') { # no cache
- $caches{$context} = undef;
- } elsif ($cache_opt eq 'HASH') { # user-supplied hash
- my $cache = $cache_opt_args[0];
- my $package = ref(tied %$cache);
- if ($context eq 'LIST' && $scalar_only{$package}) {
- croak("You can't use $package for LIST_CACHE because it can only store scalars");
- }
- $caches{$context} = $cache;
- } elsif ($cache_opt eq '' || $IS_CACHE_TAG{$cache_opt}) {
- # default is that we make up an in-memory hash
- $caches{$context} = {};
- # (this might get tied later, or MERGEd away)
- } else {
- croak "Unrecognized option to `${context}_CACHE': `$cache_opt' should be one of (@CONTEXT_TAGS); aborting";
- }
- }
-
- # Perhaps I should check here that you didn't supply *both* merge
- # options. But if you did, it does do something reasonable: They
- # both get merged to the same in-memory hash.
- if ($options{SCALAR_CACHE} eq 'MERGE') {
- $caches{SCALAR} = $caches{LIST};
- } elsif ($options{LIST_CACHE} eq 'MERGE') {
- $caches{LIST} = $caches{SCALAR};
- }
-
- # Now deal with the TIE options
- {
- my $context;
- foreach $context (qw(SCALAR LIST)) {
- # If the relevant option wasn't `TIE', this call does nothing.
- _my_tie($context, $caches{$context}, $options); # Croaks on failure
- }
- }
-
- # We should put some more stuff in here eventually.
- # We've been saying that for serveral versions now.
- # And you know what? More stuff keeps going in!
- $memotable{$cref} =
- {
- O => $options, # Short keys here for things we need to access frequently
- N => $normalizer,
- U => $cref,
- MEMOIZED => $wrapper,
- PACKAGE => $uppack,
- NAME => $install_name,
- S => $caches{SCALAR},
- L => $caches{LIST},
- };
-
- $wrapper # Return just memoized version
-}
-
-# This function tries to load a tied hash class and tie the hash to it.
-sub _my_tie {
- my ($context, $hash, $options) = @_;
- my $fullopt = $options->{"${context}_CACHE"};
-
- # We already checked to make sure that this works.
- my $shortopt = (ref $fullopt) ? $fullopt->[0] : $fullopt;
-
- return unless defined $shortopt && $shortopt eq 'TIE';
- carp("TIE option to memoize() is deprecated; use HASH instead") if $^W;
-
-
- my @args = ref $fullopt ? @$fullopt : ();
- shift @args;
- my $module = shift @args;
- if ($context eq 'LIST' && $scalar_only{$module}) {
- croak("You can't use $module for LIST_CACHE because it can only store scalars");
- }
- my $modulefile = $module . '.pm';
- $modulefile =~ s{::}{/}g;
- eval { require $modulefile };
- if ($@) {
- croak "Memoize: Couldn't load hash tie module `$module': $@; aborting";
- }
- my $rc = (tie %$hash => $module, @args);
- unless ($rc) {
- croak "Memoize: Couldn't tie hash to `$module': $!; aborting";
- }
- 1;
-}
-
-sub flush_cache {
- my $func = _make_cref($_[0], scalar caller);
- my $info = $memotable{$revmemotable{$func}};
- die "$func not memoized" unless defined $info;
- for my $context (qw(S L)) {
- my $cache = $info->{$context};
- if (tied %$cache && ! (tied %$cache)->can('CLEAR')) {
- my $funcname = defined($info->{NAME}) ?
- "function $info->{NAME}" : "anonymous function $func";
- my $context = {S => 'scalar', L => 'list'}->{$context};
- croak "Tied cache hash for $context-context $funcname does not support flushing";
- } else {
- %$cache = ();
- }
- }
-}
-
-# This is the function that manages the memo tables.
-sub _memoizer {
- my $orig = shift; # stringized version of ref to original func.
- my $info = $memotable{$orig};
- my $normalizer = $info->{N};
-
- my $argstr;
- my $context = (wantarray() ? LIST : SCALAR);
-
- if (defined $normalizer) {
- no strict;
- if ($context == SCALAR) {
- $argstr = &{$normalizer}(@_);
- } elsif ($context == LIST) {
- ($argstr) = &{$normalizer}(@_);
- } else {
- croak "Internal error \#41; context was neither LIST nor SCALAR\n";
- }
- } else { # Default normalizer
- local $^W = 0;
- $argstr = join chr(28),@_;
- }
-
- if ($context == SCALAR) {
- my $cache = $info->{S};
- _crap_out($info->{NAME}, 'scalar') unless $cache;
- if (exists $cache->{$argstr}) {
- return $cache->{$argstr};
- } else {
- my $val = &{$info->{U}}(@_);
- # Scalars are considered to be lists; store appropriately
- if ($info->{O}{SCALAR_CACHE} eq 'MERGE') {
- $cache->{$argstr} = [$val];
- } else {
- $cache->{$argstr} = $val;
- }
- $val;
- }
- } elsif ($context == LIST) {
- my $cache = $info->{L};
- _crap_out($info->{NAME}, 'list') unless $cache;
- if (exists $cache->{$argstr}) {
- my $val = $cache->{$argstr};
- # If LISTCONTEXT=>MERGE, then the function never returns lists,
- # so we have a scalar value cached, so just return it straightaway:
- return ($val) if $info->{O}{LIST_CACHE} eq 'MERGE';
- # Maybe in a later version we can use a faster test.
-
- # Otherwise, we cached an array containing the returned list:
- return @$val;
- } else {
- my $q = $cache->{$argstr} = [&{$info->{U}}(@_)];
- @$q;
- }
- } else {
- croak "Internal error \#42; context was neither LIST nor SCALAR\n";
- }
-}
-
-sub unmemoize {
- my $f = shift;
- my $uppack = caller;
- my $cref = _make_cref($f, $uppack);
-
- unless (exists $revmemotable{$cref}) {
- croak "Could not unmemoize function `$f', because it was not memoized to begin with";
- }
-
- my $tabent = $memotable{$revmemotable{$cref}};
- unless (defined $tabent) {
- croak "Could not figure out how to unmemoize function `$f'";
- }
- my $name = $tabent->{NAME};
- if (defined $name) {
- no strict;
- local($^W) = 0; # ``Subroutine $install_name redefined at ...''
- *{$name} = $tabent->{U}; # Replace with original function
- }
- undef $memotable{$revmemotable{$cref}};
- undef $revmemotable{$cref};
-
- # This removes the last reference to the (possibly tied) memo tables
- # my ($old_function, $memotabs) = @{$tabent}{'U','S','L'};
- # undef $tabent;
-
-# # Untie the memo tables if they were tied.
-# my $i;
-# for $i (0,1) {
-# if (tied %{$memotabs->[$i]}) {
-# warn "Untying hash #$i\n";
-# untie %{$memotabs->[$i]};
-# }
-# }
-
- $tabent->{U};
-}
-
-sub _make_cref {
- my $fn = shift;
- my $uppack = shift;
- my $cref;
- my $name;
-
- if (ref $fn eq 'CODE') {
- $cref = $fn;
- } elsif (! ref $fn) {
- if ($fn =~ /::/) {
- $name = $fn;
- } else {
- $name = $uppack . '::' . $fn;
- }
- no strict;
- if (defined $name and !defined(&$name)) {
- croak "Cannot operate on nonexistent function `$fn'";
- }
-# $cref = \&$name;
- $cref = *{$name}{CODE};
- } else {
- my $parent = (caller(1))[3]; # Function that called _make_cref
- croak "Usage: argument 1 to `$parent' must be a function name or reference.\n";
- }
- $DEBUG and warn "${name}($fn) => $cref in _make_cref\n";
- $cref;
-}
-
-sub _crap_out {
- my ($funcname, $context) = @_;
- if (defined $funcname) {
- croak "Function `$funcname' called in forbidden $context context; faulting";
- } else {
- croak "Anonymous function called in forbidden $context context; faulting";
- }
-}
-
-1;
-
-
-
-
-
-=head1 NAME
-
-Memoize - Make your functions faster by trading space for time
-
-=head1 SYNOPSIS
-
- use Memoize;
- memoize('slow_function');
- slow_function(arguments); # Is faster than it was before
-
-
-This is normally all you need to know. However, many options are available:
-
- memoize(function, options...);
-
-Options include:
-
- NORMALIZER => function
- INSTALL => new_name
-
- SCALAR_CACHE => 'MEMORY'
- SCALAR_CACHE => ['HASH', \%cache_hash ]
- SCALAR_CACHE => 'FAULT'
- SCALAR_CACHE => 'MERGE'
-
- LIST_CACHE => 'MEMORY'
- LIST_CACHE => ['HASH', \%cache_hash ]
- LIST_CACHE => 'FAULT'
- LIST_CACHE => 'MERGE'
-
-=head1 DESCRIPTION
-
-`Memoizing' a function makes it faster by trading space for time. It
-does this by caching the return values of the function in a table.
-If you call the function again with the same arguments, C<memoize>
-jumps in and gives you the value out of the table, instead of letting
-the function compute the value all over again.
-
-Here is an extreme example. Consider the Fibonacci sequence, defined
-by the following function:
-
- # Compute Fibonacci numbers
- sub fib {
- my $n = shift;
- return $n if $n < 2;
- fib($n-1) + fib($n-2);
- }
-
-This function is very slow. Why? To compute fib(14), it first wants
-to compute fib(13) and fib(12), and add the results. But to compute
-fib(13), it first has to compute fib(12) and fib(11), and then it
-comes back and computes fib(12) all over again even though the answer
-is the same. And both of the times that it wants to compute fib(12),
-it has to compute fib(11) from scratch, and then it has to do it
-again each time it wants to compute fib(13). This function does so
-much recomputing of old results that it takes a really long time to
-run---fib(14) makes 1,200 extra recursive calls to itself, to compute
-and recompute things that it already computed.
-
-This function is a good candidate for memoization. If you memoize the
-`fib' function above, it will compute fib(14) exactly once, the first
-time it needs to, and then save the result in a table. Then if you
-ask for fib(14) again, it gives you the result out of the table.
-While computing fib(14), instead of computing fib(12) twice, it does
-it once; the second time it needs the value it gets it from the table.
-It doesn't compute fib(11) four times; it computes it once, getting it
-from the table the next three times. Instead of making 1,200
-recursive calls to `fib', it makes 15. This makes the function about
-150 times faster.
-
-You could do the memoization yourself, by rewriting the function, like
-this:
-
- # Compute Fibonacci numbers, memoized version
- { my @fib;
- sub fib {
- my $n = shift;
- return $fib[$n] if defined $fib[$n];
- return $fib[$n] = $n if $n < 2;
- $fib[$n] = fib($n-1) + fib($n-2);
- }
- }
-
-Or you could use this module, like this:
-
- use Memoize;
- memoize('fib');
-
- # Rest of the fib function just like the original version.
-
-This makes it easy to turn memoizing on and off.
-
-Here's an even simpler example: I wrote a simple ray tracer; the
-program would look in a certain direction, figure out what it was
-looking at, and then convert the `color' value (typically a string
-like `red') of that object to a red, green, and blue pixel value, like
-this:
-
- for ($direction = 0; $direction < 300; $direction++) {
- # Figure out which object is in direction $direction
- $color = $object->{color};
- ($r, $g, $b) = @{&ColorToRGB($color)};
- ...
- }
-
-Since there are relatively few objects in a picture, there are only a
-few colors, which get looked up over and over again. Memoizing
-C<ColorToRGB> speeded up the program by several percent.
-
-=head1 DETAILS
-
-This module exports exactly one function, C<memoize>. The rest of the
-functions in this package are None of Your Business.
-
-You should say
-
- memoize(function)
-
-where C<function> is the name of the function you want to memoize, or
-a reference to it. C<memoize> returns a reference to the new,
-memoized version of the function, or C<undef> on a non-fatal error.
-At present, there are no non-fatal errors, but there might be some in
-the future.
-
-If C<function> was the name of a function, then C<memoize> hides the
-old version and installs the new memoized version under the old name,
-so that C<&function(...)> actually invokes the memoized version.
-
-=head1 OPTIONS
-
-There are some optional options you can pass to C<memoize> to change
-the way it behaves a little. To supply options, invoke C<memoize>
-like this:
-
- memoize(function, NORMALIZER => function,
- INSTALL => newname,
- SCALAR_CACHE => option,
- LIST_CACHE => option
- );
-
-Each of these options is optional; you can include some, all, or none
-of them.
-
-=head2 INSTALL
-
-If you supply a function name with C<INSTALL>, memoize will install
-the new, memoized version of the function under the name you give.
-For example,
-
- memoize('fib', INSTALL => 'fastfib')
-
-installs the memoized version of C<fib> as C<fastfib>; without the
-C<INSTALL> option it would have replaced the old C<fib> with the
-memoized version.
-
-To prevent C<memoize> from installing the memoized version anywhere, use
-C<INSTALL =E<gt> undef>.
-
-=head2 NORMALIZER
-
-Suppose your function looks like this:
-
- # Typical call: f('aha!', A => 11, B => 12);
- sub f {
- my $a = shift;
- my %hash = @_;
- $hash{B} ||= 2; # B defaults to 2
- $hash{C} ||= 7; # C defaults to 7
-
- # Do something with $a, %hash
- }
-
-Now, the following calls to your function are all completely equivalent:
-
- f(OUCH);
- f(OUCH, B => 2);
- f(OUCH, C => 7);
- f(OUCH, B => 2, C => 7);
- f(OUCH, C => 7, B => 2);
- (etc.)
-
-However, unless you tell C<Memoize> that these calls are equivalent,
-it will not know that, and it will compute the values for these
-invocations of your function separately, and store them separately.
-
-To prevent this, supply a C<NORMALIZER> function that turns the
-program arguments into a string in a way that equivalent arguments
-turn into the same string. A C<NORMALIZER> function for C<f> above
-might look like this:
-
- sub normalize_f {
- my $a = shift;
- my %hash = @_;
- $hash{B} ||= 2;
- $hash{C} ||= 7;
-
- join(',', $a, map ($_ => $hash{$_}) sort keys %hash);
- }
-
-Each of the argument lists above comes out of the C<normalize_f>
-function looking exactly the same, like this:
-
- OUCH,B,2,C,7
-
-You would tell C<Memoize> to use this normalizer this way:
-
- memoize('f', NORMALIZER => 'normalize_f');
-
-C<memoize> knows that if the normalized version of the arguments is
-the same for two argument lists, then it can safely look up the value
-that it computed for one argument list and return it as the result of
-calling the function with the other argument list, even if the
-argument lists look different.
-
-The default normalizer just concatenates the arguments with character
-28 in between. (In ASCII, this is called FS or control-\.) This
-always works correctly for functions with only one string argument,
-and also when the arguments never contain character 28. However, it
-can confuse certain argument lists:
-
- normalizer("a\034", "b")
- normalizer("a", "\034b")
- normalizer("a\034\034b")
-
-for example.
-
-Since hash keys are strings, the default normalizer will not
-distinguish between C<undef> and the empty string. It also won't work
-when the function's arguments are references. For example, consider a
-function C<g> which gets two arguments: A number, and a reference to
-an array of numbers:
-
- g(13, [1,2,3,4,5,6,7]);
-
-The default normalizer will turn this into something like
-C<"13\034ARRAY(0x436c1f)">. That would be all right, except that a
-subsequent array of numbers might be stored at a different location
-even though it contains the same data. If this happens, C<Memoize>
-will think that the arguments are different, even though they are
-equivalent. In this case, a normalizer like this is appropriate:
-
- sub normalize { join ' ', $_[0], @{$_[1]} }
-
-For the example above, this produces the key "13 1 2 3 4 5 6 7".
-
-Another use for normalizers is when the function depends on data other
-than those in its arguments. Suppose you have a function which
-returns a value which depends on the current hour of the day:
-
- sub on_duty {
- my ($problem_type) = @_;
- my $hour = (localtime)[2];
- open my $fh, "$DIR/$problem_type" or die...;
- my $line;
- while ($hour-- > 0)
- $line = <$fh>;
- }
- return $line;
- }
-
-At 10:23, this function generates the 10th line of a data file; at
-3:45 PM it generates the 15th line instead. By default, C<Memoize>
-will only see the $problem_type argument. To fix this, include the
-current hour in the normalizer:
-
- sub normalize { join ' ', (localtime)[2], @_ }
-
-The calling context of the function (scalar or list context) is
-propagated to the normalizer. This means that if the memoized
-function will treat its arguments differently in list context than it
-would in scalar context, you can have the normalizer function select
-its behavior based on the results of C<wantarray>. Even if called in
-a list context, a normalizer should still return a single string.
-
-=head2 C<SCALAR_CACHE>, C<LIST_CACHE>
-
-Normally, C<Memoize> caches your function's return values into an
-ordinary Perl hash variable. However, you might like to have the
-values cached on the disk, so that they persist from one run of your
-program to the next, or you might like to associate some other
-interesting semantics with the cached values.
-
-There's a slight complication under the hood of C<Memoize>: There are
-actually I<two> caches, one for scalar values and one for list values.
-When your function is called in scalar context, its return value is
-cached in one hash, and when your function is called in list context,
-its value is cached in the other hash. You can control the caching
-behavior of both contexts independently with these options.
-
-The argument to C<LIST_CACHE> or C<SCALAR_CACHE> must either be one of
-the following four strings:
-
- MEMORY
- FAULT
- MERGE
- HASH
-
-or else it must be a reference to a list whose first element is one of
-these four strings, such as C<[HASH, arguments...]>.
-
-=over 4
-
-=item C<MEMORY>
-
-C<MEMORY> means that return values from the function will be cached in
-an ordinary Perl hash variable. The hash variable will not persist
-after the program exits. This is the default.
-
-=item C<HASH>
-
-C<HASH> allows you to specify that a particular hash that you supply
-will be used as the cache. You can tie this hash beforehand to give
-it any behavior you want.
-
-A tied hash can have any semantics at all. It is typically tied to an
-on-disk database, so that cached values are stored in the database and
-retrieved from it again when needed, and the disk file typically
-persists after your program has exited. See C<perltie> for more
-complete details about C<tie>.
-
-A typical example is:
-
- use DB_File;
- tie my %cache => 'DB_File', $filename, O_RDWR|O_CREAT, 0666;
- memoize 'function', SCALAR_CACHE => [HASH => \%cache];
-
-This has the effect of storing the cache in a C<DB_File> database
-whose name is in C<$filename>. The cache will persist after the
-program has exited. Next time the program runs, it will find the
-cache already populated from the previous run of the program. Or you
-can forcibly populate the cache by constructing a batch program that
-runs in the background and populates the cache file. Then when you
-come to run your real program the memoized function will be fast
-because all its results have been precomputed.
-
-=item C<TIE>
-
-This option is B<strongly deprecated> and will be removed
-in the B<next> release of C<Memoize>. Use the C<HASH> option instead.
-
- memoize ... [TIE, PACKAGE, ARGS...]
-
-is merely a shortcut for
-
- require PACKAGE;
- tie my %cache, PACKAGE, ARGS...;
- memoize ... [HASH => \%cache];
-
-=item C<FAULT>
-
-C<FAULT> means that you never expect to call the function in scalar
-(or list) context, and that if C<Memoize> detects such a call, it
-should abort the program. The error message is one of
-
- `foo' function called in forbidden list context at line ...
- `foo' function called in forbidden scalar context at line ...
-
-=item C<MERGE>
-
-C<MERGE> normally means the function does not distinguish between list
-and sclar context, and that return values in both contexts should be
-stored together. C<LIST_CACHE =E<gt> MERGE> means that list context
-return values should be stored in the same hash that is used for
-scalar context returns, and C<SCALAR_CACHE =E<gt> MERGE> means the
-same, mutatis mutandis. It is an error to specify C<MERGE> for both,
-but it probably does something useful.
-
-Consider this function:
-
- sub pi { 3; }
-
-Normally, the following code will result in two calls to C<pi>:
-
- $x = pi();
- ($y) = pi();
- $z = pi();
-
-The first call caches the value C<3> in the scalar cache; the second
-caches the list C<(3)> in the list cache. The third call doesn't call
-the real C<pi> function; it gets the value from the scalar cache.
-
-Obviously, the second call to C<pi> is a waste of time, and storing
-its return value is a waste of space. Specifying C<LIST_CACHE =E<gt>
-MERGE> will make C<memoize> use the same cache for scalar and list
-context return values, so that the second call uses the scalar cache
-that was populated by the first call. C<pi> ends up being called only
-once, and both subsequent calls return C<3> from the cache, regardless
-of the calling context.
-
-Another use for C<MERGE> is when you want both kinds of return values
-stored in the same disk file; this saves you from having to deal with
-two disk files instead of one. You can use a normalizer function to
-keep the two sets of return values separate. For example:
-
- tie my %cache => 'MLDBM', 'DB_File', $filename, ...;
-
- memoize 'myfunc',
- NORMALIZER => 'n',
- SCALAR_CACHE => [HASH => \%cache],
- LIST_CACHE => MERGE,
- ;
-
- sub n {
- my $context = wantarray() ? 'L' : 'S';
- # ... now compute the hash key from the arguments ...
- $hashkey = "$context:$hashkey";
- }
-
-This normalizer function will store scalar context return values in
-the disk file under keys that begin with C<S:>, and list context
-return values under keys that begin with C<L:>.
-
-=back
-
-=head1 OTHER FACILITIES
-
-=head2 C<unmemoize>
-
-There's an C<unmemoize> function that you can import if you want to.
-Why would you want to? Here's an example: Suppose you have your cache
-tied to a DBM file, and you want to make sure that the cache is
-written out to disk if someone interrupts the program. If the program
-exits normally, this will happen anyway, but if someone types
-control-C or something then the program will terminate immediately
-without synchronizing the database. So what you can do instead is
-
- $SIG{INT} = sub { unmemoize 'function' };
-
-C<unmemoize> accepts a reference to, or the name of a previously
-memoized function, and undoes whatever it did to provide the memoized
-version in the first place, including making the name refer to the
-unmemoized version if appropriate. It returns a reference to the
-unmemoized version of the function.
-
-If you ask it to unmemoize a function that was never memoized, it
-croaks.
-
-=head2 C<flush_cache>
-
-C<flush_cache(function)> will flush out the caches, discarding I<all>
-the cached data. The argument may be a function name or a reference
-to a function. For finer control over when data is discarded or
-expired, see the documentation for C<Memoize::Expire>, included in
-this package.
-
-Note that if the cache is a tied hash, C<flush_cache> will attempt to
-invoke the C<CLEAR> method on the hash. If there is no C<CLEAR>
-method, this will cause a run-time error.
-
-An alternative approach to cache flushing is to use the C<HASH> option
-(see above) to request that C<Memoize> use a particular hash variable
-as its cache. Then you can examine or modify the hash at any time in
-any way you desire. You may flush the cache by using C<%hash = ()>.
-
-=head1 CAVEATS
-
-Memoization is not a cure-all:
-
-=over 4
-
-=item *
-
-Do not memoize a function whose behavior depends on program
-state other than its own arguments, such as global variables, the time
-of day, or file input. These functions will not produce correct
-results when memoized. For a particularly easy example:
-
- sub f {
- time;
- }
-
-This function takes no arguments, and as far as C<Memoize> is
-concerned, it always returns the same result. C<Memoize> is wrong, of
-course, and the memoized version of this function will call C<time> once
-to get the current time, and it will return that same time
-every time you call it after that.
-
-=item *
-
-Do not memoize a function with side effects.
-
- sub f {
- my ($a, $b) = @_;
- my $s = $a + $b;
- print "$a + $b = $s.\n";
- }
-
-This function accepts two arguments, adds them, and prints their sum.
-Its return value is the numuber of characters it printed, but you
-probably didn't care about that. But C<Memoize> doesn't understand
-that. If you memoize this function, you will get the result you
-expect the first time you ask it to print the sum of 2 and 3, but
-subsequent calls will return 1 (the return value of
-C<print>) without actually printing anything.
-
-=item *
-
-Do not memoize a function that returns a data structure that is
-modified by its caller.
-
-Consider these functions: C<getusers> returns a list of users somehow,
-and then C<main> throws away the first user on the list and prints the
-rest:
-
- sub main {
- my $userlist = getusers();
- shift @$userlist;
- foreach $u (@$userlist) {
- print "User $u\n";
- }
- }
-
- sub getusers {
- my @users;
- # Do something to get a list of users;
- \@users; # Return reference to list.
- }
-
-If you memoize C<getusers> here, it will work right exactly once. The
-reference to the users list will be stored in the memo table. C<main>
-will discard the first element from the referenced list. The next
-time you invoke C<main>, C<Memoize> will not call C<getusers>; it will
-just return the same reference to the same list it got last time. But
-this time the list has already had its head removed; C<main> will
-erroneously remove another element from it. The list will get shorter
-and shorter every time you call C<main>.
-
-Similarly, this:
-
- $u1 = getusers();
- $u2 = getusers();
- pop @$u1;
-
-will modify $u2 as well as $u1, because both variables are references
-to the same array. Had C<getusers> not been memoized, $u1 and $u2
-would have referred to different arrays.
-
-=item *
-
-Do not memoize a very simple function.
-
-Recently someone mentioned to me that the Memoize module made his
-program run slower instead of faster. It turned out that he was
-memoizing the following function:
-
- sub square {
- $_[0] * $_[0];
- }
-
-I pointed out that C<Memoize> uses a hash, and that looking up a
-number in the hash is necessarily going to take a lot longer than a
-single multiplication. There really is no way to speed up the
-C<square> function.
-
-Memoization is not magical.
-
-=back
-
-=head1 PERSISTENT CACHE SUPPORT
-
-You can tie the cache tables to any sort of tied hash that you want
-to, as long as it supports C<TIEHASH>, C<FETCH>, C<STORE>, and
-C<EXISTS>. For example,
-
- tie my %cache => 'GDBM_File', $filename, O_RDWR|O_CREAT, 0666;
- memoize 'function', SCALAR_CACHE => [HASH => \%cache];
-
-works just fine. For some storage methods, you need a little glue.
-
-C<SDBM_File> doesn't supply an C<EXISTS> method, so included in this
-package is a glue module called C<Memoize::SDBM_File> which does
-provide one. Use this instead of plain C<SDBM_File> to store your
-cache table on disk in an C<SDBM_File> database:
-
- tie my %cache => 'Memoize::SDBM_File', $filename, O_RDWR|O_CREAT, 0666;
- memoize 'function', SCALAR_CACHE => [HASH => \%cache];
-
-C<NDBM_File> has the same problem and the same solution. (Use
-C<Memoize::NDBM_File instead of plain NDBM_File.>)
-
-C<Storable> isn't a tied hash class at all. You can use it to store a
-hash to disk and retrieve it again, but you can't modify the hash while
-it's on the disk. So if you want to store your cache table in a
-C<Storable> database, use C<Memoize::Storable>, which puts a hashlike
-front-end onto C<Storable>. The hash table is actually kept in
-memory, and is loaded from your C<Storable> file at the time you
-memoize the function, and stored back at the time you unmemoize the
-function (or when your program exits):
-
- tie my %cache => 'Memoize::Storable', $filename;
- memoize 'function', SCALAR_CACHE => [HASH => \%cache];
-
- tie my %cache => 'Memoize::Storable', $filename, 'nstore';
- memoize 'function', SCALAR_CACHE => [HASH => \%cache];
-
-Include the `nstore' option to have the C<Storable> database written
-in `network order'. (See L<Storable> for more details about this.)
-
-The C<flush_cache()> function will raise a run-time error unless the
-tied package provides a C<CLEAR> method.
-
-=head1 EXPIRATION SUPPORT
-
-See Memoize::Expire, which is a plug-in module that adds expiration
-functionality to Memoize. If you don't like the kinds of policies
-that Memoize::Expire implements, it is easy to write your own plug-in
-module to implement whatever policy you desire. Memoize comes with
-several examples. An expiration manager that implements a LRU policy
-is available on CPAN as Memoize::ExpireLRU.
-
-=head1 BUGS
-
-The test suite is much better, but always needs improvement.
-
-There is some problem with the way C<goto &f> works under threaded
-Perl, perhaps because of the lexical scoping of C<@_>. This is a bug
-in Perl, and until it is resolved, memoized functions will see a
-slightly different C<caller()> and will perform a little more slowly
-on threaded perls than unthreaded perls.
-
-Here's a bug that isn't my fault: Some versions of C<DB_File> won't
-let you store data under a key of length 0. That means that if you
-have a function C<f> which you memoized and the cache is in a
-C<DB_File> database, then the value of C<f()> (C<f> called with no
-arguments) will not be memoized. Let us all breathe deeply and repeat
-this mantra: ``Gosh, Keith, that sure was a stupid thing to do.'' If
-this is a big problem, you can write a tied hash class which is a
-front-end to C<DB_File> that prepends <x> to every key before storing
-it.
-
-=head1 MAILING LIST
-
-To join a very low-traffic mailing list for announcements about
-C<Memoize>, send an empty note to C<mjd-perl-memoize-request@plover.com>.
-
-=head1 AUTHOR
-
-Mark-Jason Dominus (C<mjd-perl-memoize+@plover.com>), Plover Systems co.
-
-See the C<Memoize.pm> Page at http://www.plover.com/~mjd/perl/Memoize/
-for news and upgrades. Near this page, at
-http://www.plover.com/~mjd/perl/MiniMemoize/ there is an article about
-memoization and about the internals of Memoize that appeared in The
-Perl Journal, issue #13. (This article is also included in the
-Memoize distribution as `article.html'.)
-
-My upcoming book will discuss memoization (and many other fascinating
-topics) in tremendous detail. It will be published by Morgan Kaufmann
-in 2002, possibly under the title I<Perl Advanced Techniques
-Handbook>. It will also be available on-line for free. For more
-information, visit http://perl.plover.com/book/ .
-
-To join a mailing list for announcements about C<Memoize>, send an
-empty message to C<mjd-perl-memoize-request@plover.com>. This mailing
-list is for announcements only and has extremely low traffic---about
-two messages per year.
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 1998, 1999, 2000, 2001 by Mark Jason Dominus
-
-This library is free software; you may redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=head1 THANK YOU
-
-Many thanks to Jonathan Roy for bug reports and suggestions, to
-Michael Schwern for other bug reports and patches, to Mike Cariaso for
-helping me to figure out the Right Thing to Do About Expiration, to
-Joshua Gerth, Joshua Chamas, Jonathan Roy (again), Mark D. Anderson,
-and Andrew Johnson for more suggestions about expiration, to Brent
-Powers for the Memoize::ExpireLRU module, to Ariel Scolnicov for
-delightful messages about the Fibonacci function, to Dion Almaer for
-thought-provoking suggestions about the default normalizer, to Walt
-Mankowski and Kurt Starsinic for much help investigating problems
-under threaded Perl, to Alex Dudkevich for reporting the bug in
-prototyped functions and for checking my patch, to Tony Bass for many
-helpful suggestions, to Jonathan Roy (again) for finding a use for
-C<unmemoize()>, to Philippe Verdret for enlightening discussion of
-C<Hook::PrePostCall>, to Nat Torkington for advice I ignored, to Chris
-Nandor for portability advice, to Randal Schwartz for suggesting the
-'C<flush_cache> function, and to Jenda Krynicky for being a light in
-the world.
-
-Special thanks to Jarkko Hietaniemi, the 5.8.0 pumpking, for including
-this module in the core and for his patient and helpful guidance
-during the integration process.
-
-=cut
+++ /dev/null
-package Memoize::AnyDBM_File;
-
-=head1 NAME
-
-Memoize::AnyDBM_File - glue to provide EXISTS for AnyDBM_File for Storable use
-
-=head1 DESCRIPTION
-
-See L<Memoize>.
-
-=cut
-
-use vars qw(@ISA $VERSION);
-$VERSION = 0.65;
-@ISA = qw(DB_File GDBM_File Memoize::NDBM_File Memoize::SDBM_File ODBM_File) unless @ISA;
-
-my $verbose = 1;
-
-my $mod;
-for $mod (@ISA) {
-# (my $truemod = $mod) =~ s/^Memoize:://;
-# my $file = "$mod.pm";
-# $file =~ s{::}{/}g;
- if (eval "require $mod") {
- print STDERR "AnyDBM_File => Selected $mod.\n" if $Verbose;
- @ISA = ($mod); # if we leave @ISA alone, warnings abound
- return 1;
- }
-}
-
-die "No DBM package was successfully found or installed";
+++ /dev/null
-
-package Memoize::Expire;
-# require 5.00556;
-use Carp;
-$DEBUG = 0;
-$VERSION = '0.66';
-
-# This package will implement expiration by prepending a fixed-length header
-# to the font of the cached data. The format of the header will be:
-# (4-byte number of last-access-time) (For LRU when I implement it)
-# (4-byte expiration time: unsigned seconds-since-unix-epoch)
-# (2-byte number-of-uses-before-expire)
-
-sub _header_fmt () { "N N n" }
-sub _header_size () { length(_header_fmt) }
-
-# Usage: memoize func
-# TIE => [Memoize::Expire, LIFETIME => sec, NUM_USES => n,
-# TIE => [...] ]
-
-BEGIN {
- eval {require Time::HiRes};
- unless ($@) {
- Time::HiRes->import('time');
- }
-}
-
-sub TIEHASH {
- my ($package, %args) = @_;
- my %cache;
- if ($args{TIE}) {
- my ($module, @opts) = @{$args{TIE}};
- my $modulefile = $module . '.pm';
- $modulefile =~ s{::}{/}g;
- eval { require $modulefile };
- if ($@) {
- croak "Memoize::Expire: Couldn't load hash tie module `$module': $@; aborting";
- }
- my $rc = (tie %cache => $module, @opts);
- unless ($rc) {
- croak "Memoize::Expire: Couldn't tie hash to `$module': $@; aborting";
- }
- }
- $args{LIFETIME} ||= 0;
- $args{NUM_USES} ||= 0;
- $args{C} = \%cache;
- bless \%args => $package;
-}
-
-sub STORE {
- $DEBUG and print STDERR " >> Store $_[1] $_[2]\n";
- my ($self, $key, $value) = @_;
- my $expire_time = $self->{LIFETIME} > 0 ? $self->{LIFETIME} + time : 0;
- # The call that results in a value to store into the cache is the
- # first of the NUM_USES allowed calls.
- my $header = _make_header(time, $expire_time, $self->{NUM_USES}-1);
- $self->{C}{$key} = $header . $value;
- $value;
-}
-
-sub FETCH {
- $DEBUG and print STDERR " >> Fetch cached value for $_[1]\n";
- my ($data, $last_access, $expire_time, $num_uses_left) = _get_item($_[0]{C}{$_[1]});
- $DEBUG and print STDERR " >> (ttl: ", ($expire_time-time()), ", nuses: $num_uses_left)\n";
- $num_uses_left--;
- $last_access = time;
- _set_header(@_, $data, $last_access, $expire_time, $num_uses_left);
- $data;
-}
-
-sub EXISTS {
- $DEBUG and print STDERR " >> Exists $_[1]\n";
- unless (exists $_[0]{C}{$_[1]}) {
- $DEBUG and print STDERR " Not in underlying hash at all.\n";
- return 0;
- }
- my $item = $_[0]{C}{$_[1]};
- my ($last_access, $expire_time, $num_uses_left) = _get_header($item);
- my $ttl = $expire_time - time;
- if ($DEBUG) {
- $_[0]{LIFETIME} and print STDERR " Time to live for this item: $ttl\n";
- $_[0]{NUM_USES} and print STDERR " Uses remaining: $num_uses_left\n";
- }
- if ( (! $_[0]{LIFETIME} || $expire_time > time)
- && (! $_[0]{NUM_USES} || $num_uses_left > 0 )) {
- $DEBUG and print STDERR " (Still good)\n";
- return 1;
- } else {
- $DEBUG and print STDERR " (Expired)\n";
- return 0;
- }
-}
-
-# Arguments: last access time, expire time, number of uses remaining
-sub _make_header {
- pack "N N n", @_;
-}
-
-sub _strip_header {
- substr($_[0], 10);
-}
-
-# Arguments: last access time, expire time, number of uses remaining
-sub _set_header {
- my ($self, $key, $data, @header) = @_;
- $self->{C}{$key} = _make_header(@header) . $data;
-}
-
-sub _get_item {
- my $data = substr($_[0], 10);
- my @header = unpack "N N n", substr($_[0], 0, 10);
-# print STDERR " >> _get_item: $data => $data @header\n";
- ($data, @header);
-}
-
-# Return last access time, expire time, number of uses remaining
-sub _get_header {
- unpack "N N n", substr($_[0], 0, 10);
-}
-
-1;
-
-=head1 NAME
-
-Memoize::Expire - Plug-in module for automatic expiration of memoized values
-
-=head1 SYNOPSIS
-
- use Memoize;
- use Memoize::Expire;
- tie my %cache => 'Memoize::Expire',
- LIFETIME => $lifetime, # In seconds
- NUM_USES => $n_uses;
-
- memoize 'function', SCALAR_CACHE => [HASH => \%cache ];
-
-=head1 DESCRIPTION
-
-Memoize::Expire is a plug-in module for Memoize. It allows the cached
-values for memoized functions to expire automatically. This manual
-assumes you are already familiar with the Memoize module. If not, you
-should study that manual carefully first, paying particular attention
-to the HASH feature.
-
-Memoize::Expire is a layer of software that you can insert in between
-Memoize itself and whatever underlying package implements the cache.
-The layer presents a hash variable whose values expire whenever they
-get too old, have been used too often, or both. You tell C<Memoize> to
-use this forgetful hash as its cache instead of the default, which is
-an ordinary hash.
-
-To specify a real-time timeout, supply the C<LIFETIME> option with a
-numeric value. Cached data will expire after this many seconds, and
-will be looked up afresh when it expires. When a data item is looked
-up afresh, its lifetime is reset.
-
-If you specify C<NUM_USES> with an argument of I<n>, then each cached
-data item will be discarded and looked up afresh after the I<n>th time
-you access it. When a data item is looked up afresh, its number of
-uses is reset.
-
-If you specify both arguments, data will be discarded from the cache
-when either expiration condition holds.
-
-Memoize::Expire uses a real hash internally to store the cached data.
-You can use the C<HASH> option to Memoize::Expire to supply a tied
-hash in place of the ordinary hash that Memoize::Expire will normally
-use. You can use this feature to add Memoize::Expire as a layer in
-between a persistent disk hash and Memoize. If you do this, you get a
-persistent disk cache whose entries expire automatically. For
-example:
-
- # Memoize
- # |
- # Memoize::Expire enforces data expiration policy
- # |
- # DB_File implements persistence of data in a disk file
- # |
- # Disk file
-
- use Memoize;
- use Memoize::Expire;
- use DB_File;
-
- # Set up persistence
- tie my %disk_cache => 'DB_File', $filename, O_CREAT|O_RDWR, 0666];
-
- # Set up expiration policy, supplying persistent hash as a target
- tie my %cache => 'Memoize::Expire',
- LIFETIME => $lifetime, # In seconds
- NUM_USES => $n_uses,
- HASH => \%disk_cache;
-
- # Set up memoization, supplying expiring persistent hash for cache
- memoize 'function', SCALAR_CACHE => [ HASH => \%cache ];
-
-=head1 INTERFACE
-
-There is nothing special about Memoize::Expire. It is just an
-example. If you don't like the policy that it implements, you are
-free to write your own expiration policy module that implements
-whatever policy you desire. Here is how to do that. Let us suppose
-that your module will be named MyExpirePolicy.
-
-Short summary: You need to create a package that defines four methods:
-
-=over 4
-
-=item
-TIEHASH
-
-Construct and return cache object.
-
-=item
-EXISTS
-
-Given a function argument, is the corresponding function value in the
-cache, and if so, is it fresh enough to use?
-
-=item
-FETCH
-
-Given a function argument, look up the corresponding function value in
-the cache and return it.
-
-=item
-STORE
-
-Given a function argument and the corresponding function value, store
-them into the cache.
-
-=item
-CLEAR
-
-(Optional.) Flush the cache completely.
-
-=back
-
-The user who wants the memoization cache to be expired according to
-your policy will say so by writing
-
- tie my %cache => 'MyExpirePolicy', args...;
- memoize 'function', SCALAR_CACHE => [HASH => \%cache];
-
-This will invoke C<< MyExpirePolicy->TIEHASH(args) >>.
-MyExpirePolicy::TIEHASH should do whatever is appropriate to set up
-the cache, and it should return the cache object to the caller.
-
-For example, MyExpirePolicy::TIEHASH might create an object that
-contains a regular Perl hash (which it will to store the cached
-values) and some extra information about the arguments and how old the
-data is and things like that. Let us call this object `C'.
-
-When Memoize needs to check to see if an entry is in the cache
-already, it will invoke C<< C->EXISTS(key) >>. C<key> is the normalized
-function argument. MyExpirePolicy::EXISTS should return 0 if the key
-is not in the cache, or if it has expired, and 1 if an unexpired value
-is in the cache. It should I<not> return C<undef>, because there is a
-bug in some versions of Perl that will cause a spurious FETCH if the
-EXISTS method returns C<undef>.
-
-If your EXISTS function returns true, Memoize will try to fetch the
-cached value by invoking C<< C->FETCH(key) >>. MyExpirePolicy::FETCH should
-return the cached value. Otherwise, Memoize will call the memoized
-function to compute the appropriate value, and will store it into the
-cache by calling C<< C->STORE(key, value) >>.
-
-Here is a very brief example of a policy module that expires each
-cache item after ten seconds.
-
- package Memoize::TenSecondExpire;
-
- sub TIEHASH {
- my ($package, %args) = @_;
- my $cache = $args{HASH} || {};
- bless $cache => $package;
- }
-
- sub EXISTS {
- my ($cache, $key) = @_;
- if (exists $cache->{$key} &&
- $cache->{$key}{EXPIRE_TIME} > time) {
- return 1
- } else {
- return 0; # Do NOT return `undef' here.
- }
- }
-
- sub FETCH {
- my ($cache, $key) = @_;
- return $cache->{$key}{VALUE};
- }
-
- sub STORE {
- my ($cache, $key, $newvalue) = @_;
- $cache->{$key}{VALUE} = $newvalue;
- $cache->{$key}{EXPIRE_TIME} = time + 10;
- }
-
-To use this expiration policy, the user would say
-
- use Memoize;
- tie my %cache10sec => 'Memoize::TenSecondExpire';
- memoize 'function', SCALAR_CACHE => [HASH => \%cache10sec];
-
-Memoize would then call C<function> whenever a cached value was
-entirely absent or was older than ten seconds.
-
-You should always support a C<HASH> argument to C<TIEHASH> that ties
-the underlying cache so that the user can specify that the cache is
-also persistent or that it has some other interesting semantics. The
-example above demonstrates how to do this, as does C<Memoize::Expire>.
-
-Another sample module, C<Memoize::Saves>, is included with this
-package. It implements a policy that allows you to specify that
-certain function values whould always be looked up afresh. See the
-documentation for details.
-
-=head1 ALTERNATIVES
-
-Brent Powers has a C<Memoize::ExpireLRU> module that was designed to
-wotk with Memoize and provides expiration of least-recently-used data.
-The cache is held at a fixed number of entries, and when new data
-comes in, the least-recently used data is expired. See
-L<http://search.cpan.org/search?mode=module&query=ExpireLRU>.
-
-Joshua Chamas's Tie::Cache module may be useful as an expiration
-manager. (If you try this, let me know how it works out.)
-
-If you develop any useful expiration managers that you think should be
-distributed with Memoize, please let me know.
-
-=head1 CAVEATS
-
-This module is experimental, and may contain bugs. Please report bugs
-to the address below.
-
-Number-of-uses is stored as a 16-bit unsigned integer, so can't exceed
-65535.
-
-Because of clock granularity, expiration times may occur up to one
-second sooner than you expect. For example, suppose you store a value
-with a lifetime of ten seconds, and you store it at 12:00:00.998 on a
-certain day. Memoize will look at the clock and see 12:00:00. Then
-9.01 seconds later, at 12:00:10.008 you try to read it back. Memoize
-will look at the clock and see 12:00:10 and conclude that the value
-has expired. This will probably not occur if if you have
-C<Time::HiRes> installed.
-
-=head1 AUTHOR
-
-Mark-Jason Dominus (mjd-perl-memoize+@plover.com)
-
-Mike Cariaso provided valuable insight into the best way to solve this
-problem.
-
-=head1 SEE ALSO
-
-perl(1)
-
-The Memoize man page.
-
-http://www.plover.com/~mjd/perl/Memoize/ (for news and updates)
-
-I maintain a mailing list on which I occasionally announce new
-versions of Memoize. The list is for announcements only, not
-discussion. To join, send an empty message to
-mjd-perl-memoize-request@Plover.com.
-
-=cut
+++ /dev/null
-package Memoize::ExpireFile;
-
-=head1 NAME
-
-Memoize::ExpireFile - test for Memoize expiration semantics
-
-=head1 DESCRIPTION
-
-See L<Memoize::Expire>.
-
-=cut
-
-$VERSION = 0.65;
-use Carp;
-
-my $Zero = pack("N", 0);
-
-sub TIEHASH {
- my ($package, %args) = @_;
- my $cache = $args{HASH} || {};
- bless {ARGS => \%args, C => $cache} => $package;
-}
-
-
-sub STORE {
- my ($self, $key, $data) = @_;
- my $cache = $self->{C};
- my $cur_date = pack("N", (stat($key))[9]);
- $cache->{"C$key"} = $data;
- $cache->{"T$key"} = $cur_date;
-}
-
-sub FETCH {
- my ($self, $key) = @_;
- $self->{C}{"C$key"};
-}
-
-sub EXISTS {
- my ($self, $key) = @_;
- my $old_date = $self->{C}{"T$key"} || $Zero;
- my $cur_date = pack("N", (stat($key))[9]);
-# if ($self->{ARGS}{CHECK_DATE} && $old_date gt $cur_date) {
-# return $self->{ARGS}{CHECK_DATE}->($key, $old_date, $cur_date);
-# }
- return $old_date ge $cur_date;
-}
-
-1;
+++ /dev/null
-package Memoize::ExpireTest;
-
-=head1 NAME
-
-Memoize::ExpireTest - test for Memoize expiration semantics
-
-=head1 DESCRIPTION
-
-This module is just for testing expiration semantics. It's not a very
-good example of how to write an expiration module.
-
-If you are looking for an example, I recommend that you look at the
-simple example in the Memoize::Expire documentation, or at the code
-for Memoize::Expire itself.
-
-If you have questions, I will be happy to answer them if you send them
-to mjd-perl-memoize+@plover.com.
-
-=cut
-
-$VERSION = 0.65;
-my %cache;
-
-sub TIEHASH {
- my ($pack) = @_;
- bless \%cache => $pack;
-}
-
-sub EXISTS {
- my ($cache, $key) = @_;
- exists $cache->{$key} ? 1 : 0;
-}
-
-sub FETCH {
- my ($cache, $key) = @_;
- $cache->{$key};
-}
-
-sub STORE {
- my ($cache, $key, $val) = @_;
- $cache->{$key} = $val;
-}
-
-sub expire {
- my ($key) = @_;
- delete $cache{$key};
-}
-
-1;
+++ /dev/null
-package Memoize::NDBM_File;
-
-=head1 NAME
-
-Memoize::NDBM_File - glue to provide EXISTS for NDBM_File for Storable use
-
-=head1 DESCRIPTION
-
-See L<Memoize>.
-
-=cut
-
-use NDBM_File;
-@ISA = qw(NDBM_File);
-$VERSION = 0.65;
-
-$Verbose = 0;
-
-sub AUTOLOAD {
- warn "Nonexistent function $AUTOLOAD invoked in Memoize::NDBM_File\n";
-}
-
-sub import {
- warn "Importing Memoize::NDBM_File\n" if $Verbose;
-}
-
-
-my %keylist;
-
-# This is so ridiculous...
-sub _backhash {
- my $self = shift;
- my %fakehash;
- my $k;
- for ($k = $self->FIRSTKEY(); defined $k; $k = $self->NEXTKEY($k)) {
- $fakehash{$k} = undef;
- }
- $keylist{$self} = \%fakehash;
-}
-
-sub EXISTS {
- warn "Memoize::NDBM_File EXISTS (@_)\n" if $Verbose;
- my $self = shift;
- _backhash($self) unless exists $keylist{$self};
- my $r = exists $keylist{$self}{$_[0]};
- warn "Memoize::NDBM_File EXISTS (@_) ==> $r\n" if $Verbose;
- $r;
-}
-
-sub DEFINED {
- warn "Memoize::NDBM_File DEFINED (@_)\n" if $Verbose;
- my $self = shift;
- _backhash($self) unless exists $keylist{$self};
- defined $keylist{$self}{$_[0]};
-}
-
-sub DESTROY {
- warn "Memoize::NDBM_File DESTROY (@_)\n" if $Verbose;
- my $self = shift;
- delete $keylist{$self}; # So much for reference counting...
- $self->SUPER::DESTROY(@_);
-}
-
-# Maybe establish the keylist at TIEHASH time instead?
-
-sub STORE {
- warn "Memoize::NDBM_File STORE (@_)\n" if $VERBOSE;
- my $self = shift;
- $keylist{$self}{$_[0]} = undef;
- $self->SUPER::STORE(@_);
-}
-
-
-
-# Inherit FETCH and TIEHASH
-
-1;
+++ /dev/null
-package Memoize::SDBM_File;
-
-=head1 NAME
-
-Memoize::SDBM_File - glue to provide EXISTS for SDBM_File for Storable use
-
-=head1 DESCRIPTION
-
-See L<Memoize>.
-
-=cut
-
-use SDBM_File;
-@ISA = qw(SDBM_File);
-$VERSION = 0.65;
-
-$Verbose = 0;
-
-sub AUTOLOAD {
- warn "Nonexistent function $AUTOLOAD invoked in Memoize::SDBM_File\n";
-}
-
-sub import {
- warn "Importing Memoize::SDBM_File\n" if $Verbose;
-}
-
-
-my %keylist;
-
-# This is so ridiculous...
-sub _backhash {
- my $self = shift;
- my %fakehash;
- my $k;
- for ($k = $self->FIRSTKEY(); defined $k; $k = $self->NEXTKEY($k)) {
- $fakehash{$k} = undef;
- }
- $keylist{$self} = \%fakehash;
-}
-
-sub EXISTS {
- warn "Memoize::SDBM_File EXISTS (@_)\n" if $Verbose;
- my $self = shift;
- _backhash($self) unless exists $keylist{$self};
- my $r = exists $keylist{$self}{$_[0]};
- warn "Memoize::SDBM_File EXISTS (@_) ==> $r\n" if $Verbose;
- $r;
-}
-
-sub DEFINED {
- warn "Memoize::SDBM_File DEFINED (@_)\n" if $Verbose;
- my $self = shift;
- _backhash($self) unless exists $keylist{$self};
- defined $keylist{$self}{$_[0]};
-}
-
-sub DESTROY {
- warn "Memoize::SDBM_File DESTROY (@_)\n" if $Verbose;
- my $self = shift;
- delete $keylist{$self}; # So much for reference counting...
- $self->SUPER::DESTROY(@_);
-}
-
-# Maybe establish the keylist at TIEHASH time instead?
-
-sub STORE {
- warn "Memoize::SDBM_File STORE (@_)\n" if $VERBOSE;
- my $self = shift;
- $keylist{$self}{$_[0]} = undef;
- $self->SUPER::STORE(@_);
-}
-
-# Inherit FETCH and TIEHASH
-
-1;
+++ /dev/null
-package Memoize::Storable;
-
-=head1 NAME
-
-Memoize::Storable - store Memoized data in Storable database
-
-=head1 DESCRIPTION
-
-See L<Memoize>.
-
-=cut
-
-use Storable ();
-$VERSION = 0.65;
-$Verbose = 0;
-
-sub TIEHASH {
- require Carp if $Verbose;
- my $package = shift;
- my $filename = shift;
- my $truehash = (-e $filename) ? Storable::retrieve($filename) : {};
- my %options;
- print STDERR "Memoize::Storable::TIEHASH($filename, @_)\n" if $Verbose;
- @options{@_} = ();
- my $self =
- {FILENAME => $filename,
- H => $truehash,
- OPTIONS => \%options
- };
- bless $self => $package;
-}
-
-sub STORE {
- require Carp if $Verbose;
- my $self = shift;
- print STDERR "Memoize::Storable::STORE(@_)\n" if $Verbose;
- $self->{H}{$_[0]} = $_[1];
-}
-
-sub FETCH {
- require Carp if $Verbose;
- my $self = shift;
- print STDERR "Memoize::Storable::FETCH(@_)\n" if $Verbose;
- $self->{H}{$_[0]};
-}
-
-sub EXISTS {
- require Carp if $Verbose;
- my $self = shift;
- print STDERR "Memoize::Storable::EXISTS(@_)\n" if $Verbose;
- exists $self->{H}{$_[0]};
-}
-
-sub DESTROY {
- require Carp if $Verbose;
- my $self= shift;
- print STDERR "Memoize::Storable::DESTROY(@_)\n" if $Verbose;
- if ($self->{OPTIONS}{'nstore'}) {
- Storable::nstore($self->{H}, $self->{FILENAME});
- } else {
- Storable::store($self->{H}, $self->{FILENAME});
- }
-}
-
-sub FIRSTKEY {
- 'Fake hash from Memoize::Storable';
-}
-
-sub NEXTKEY {
- undef;
-}
-1;
+++ /dev/null
-package NEXT;
-$VERSION = '0.50';
-use Carp;
-use strict;
-
-sub ancestors
-{
- my @inlist = shift;
- my @outlist = ();
- while (my $next = shift @inlist) {
- push @outlist, $next;
- no strict 'refs';
- unshift @inlist, @{"$outlist[-1]::ISA"};
- }
- return @outlist;
-}
-
-sub AUTOLOAD
-{
- my ($self) = @_;
- my $caller = (caller(1))[3];
- my $wanted = $NEXT::AUTOLOAD || 'NEXT::AUTOLOAD';
- undef $NEXT::AUTOLOAD;
- my ($caller_class, $caller_method) = $caller =~ m{(.*)::(.*)}g;
- my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g;
- croak "Can't call $wanted from $caller"
- unless $caller_method eq $wanted_method;
-
- local ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN) =
- ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN);
-
-
- unless ($NEXT::NEXT{$self,$wanted_method}) {
- my @forebears =
- ancestors ref $self || $self, $wanted_class;
- while (@forebears) {
- last if shift @forebears eq $caller_class
- }
- no strict 'refs';
- @{$NEXT::NEXT{$self,$wanted_method}} =
- map { *{"${_}::$caller_method"}{CODE}||() } @forebears
- unless $wanted_method eq 'AUTOLOAD';
- @{$NEXT::NEXT{$self,$wanted_method}} =
- map { (*{"${_}::AUTOLOAD"}{CODE}) ? "${_}::AUTOLOAD" : ()} @forebears
- unless @{$NEXT::NEXT{$self,$wanted_method}||[]};
- }
- my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
- while ($wanted_class =~ /^NEXT:.*:UNSEEN/ && defined $call_method
- && $NEXT::SEEN->{$self,$call_method}++) {
- $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
- }
- unless (defined $call_method) {
- return unless $wanted_class =~ /^NEXT:.*:ACTUAL/;
- (local $Carp::CarpLevel)++;
- croak qq(Can't locate object method "$wanted_method" ),
- qq(via package "$caller_class");
- };
- return shift()->$call_method(@_) if ref $call_method eq 'CODE';
- no strict 'refs';
- ($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*:://
- if $wanted_method eq 'AUTOLOAD';
- $$call_method = $caller_class."::NEXT::".$wanted_method;
- return $call_method->(@_);
-}
-
-no strict 'vars';
-package NEXT::UNSEEN; @ISA = 'NEXT';
-package NEXT::ACTUAL; @ISA = 'NEXT';
-package NEXT::ACTUAL::UNSEEN; @ISA = 'NEXT';
-package NEXT::UNSEEN::ACTUAL; @ISA = 'NEXT';
-
-1;
-
-__END__
-
-=head1 NAME
-
-NEXT.pm - Provide a pseudo-class NEXT that allows method redispatch
-
-
-=head1 SYNOPSIS
-
- use NEXT;
-
- package A;
- sub A::method { print "$_[0]: A method\n"; $_[0]->NEXT::method() }
- sub A::DESTROY { print "$_[0]: A dtor\n"; $_[0]->NEXT::DESTROY() }
-
- package B;
- use base qw( A );
- sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
- sub B::DESTROY { print "$_[0]: B dtor\n"; $_[0]->NEXT::DESTROY() }
-
- package C;
- sub C::method { print "$_[0]: C method\n"; $_[0]->NEXT::method() }
- sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
- sub C::DESTROY { print "$_[0]: C dtor\n"; $_[0]->NEXT::DESTROY() }
-
- package D;
- use base qw( B C );
- sub D::method { print "$_[0]: D method\n"; $_[0]->NEXT::method() }
- sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
- sub D::DESTROY { print "$_[0]: D dtor\n"; $_[0]->NEXT::DESTROY() }
-
- package main;
-
- my $obj = bless {}, "D";
-
- $obj->method(); # Calls D::method, A::method, C::method
- $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
-
- # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
-
-
-=head1 DESCRIPTION
-
-NEXT.pm adds a pseudoclass named C<NEXT> to any program
-that uses it. If a method C<m> calls C<$self->NEXT::m()>, the call to
-C<m> is redispatched as if the calling method had not originally been found.
-
-In other words, a call to C<$self->NEXT::m()> resumes the depth-first,
-left-to-right search of C<$self>'s class hierarchy that resulted in the
-original call to C<m>.
-
-Note that this is not the same thing as C<$self->SUPER::m()>, which
-begins a new dispatch that is restricted to searching the ancestors
-of the current class. C<$self->NEXT::m()> can backtrack
-past the current class -- to look for a suitable method in other
-ancestors of C<$self> -- whereas C<$self->SUPER::m()> cannot.
-
-A typical use would be in the destructors of a class hierarchy,
-as illustrated in the synopsis above. Each class in the hierarchy
-has a DESTROY method that performs some class-specific action
-and then redispatches the call up the hierarchy. As a result,
-when an object of class D is destroyed, the destructors of I<all>
-its parent classes are called (in depth-first, left-to-right order).
-
-Another typical use of redispatch would be in C<AUTOLOAD>'ed methods.
-If such a method determined that it was not able to handle a
-particular call, it might choose to redispatch that call, in the
-hope that some other C<AUTOLOAD> (above it, or to its left) might
-do better.
-
-By default, if a redispatch attempt fails to find another method
-elsewhere in the objects class hierarchy, it quietly gives up and does
-nothing (but see L<"Enforcing redispatch">). This gracious acquiesence
-is also unlike the (generally annoying) behaviour of C<SUPER>, which
-throws an exception if it cannot redispatch.
-
-Note that it is a fatal error for any method (including C<AUTOLOAD>)
-to attempt to redispatch any method that does not have the
-same name. For example:
-
- sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
-
-
-=head2 Enforcing redispatch
-
-It is possible to make C<NEXT> redispatch more demandingly (i.e. like
-C<SUPER> does), so that the redispatch throws an exception if it cannot
-find a "next" method to call.
-
-To do this, simple invoke the redispatch as:
-
- $self->NEXT::ACTUAL::method();
-
-rather than:
-
- $self->NEXT::method();
-
-The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call,
-or it should throw an exception.
-
-C<NEXT::ACTUAL> is most commonly used in C<AUTOLOAD> methods, as a means to
-decline an C<AUTOLOAD> request, but preserve the normal exception-on-failure
-semantics:
-
- sub AUTOLOAD {
- if ($AUTOLOAD =~ /foo|bar/) {
- # handle here
- }
- else { # try elsewhere
- shift()->NEXT::ACTUAL::AUTOLOAD(@_);
- }
- }
-
-By using C<NEXT::ACTUAL>, if there is no other C<AUTOLOAD> to handle the
-method call, an exception will be thrown (as usually happens in the absence of
-a suitable C<AUTOLOAD>).
-
-
-=head2 Avoiding repetitions
-
-If C<NEXT> redispatching is used in the methods of a "diamond" class hierarchy:
-
- # A B
- # / \ /
- # C D
- # \ /
- # E
-
- use NEXT;
-
- package A;
- sub foo { print "called A::foo\n"; shift->NEXT::foo() }
-
- package B;
- sub foo { print "called B::foo\n"; shift->NEXT::foo() }
-
- package C; @ISA = qw( A );
- sub foo { print "called C::foo\n"; shift->NEXT::foo() }
-
- package D; @ISA = qw(A B);
- sub foo { print "called D::foo\n"; shift->NEXT::foo() }
-
- package E; @ISA = qw(C D);
- sub foo { print "called E::foo\n"; shift->NEXT::foo() }
-
- E->foo();
-
-then derived classes may (re-)inherit base-class methods through two or
-more distinct paths (e.g. in the way C<E> inherits C<A::foo> twice --
-through C<C> and C<D>). In such cases, a sequence of C<NEXT> redispatches
-will invoke the multiply inherited method as many times as it is
-inherited. For example, the above code prints:
-
- called E::foo
- called C::foo
- called A::foo
- called D::foo
- called A::foo
- called B::foo
-
-(i.e. C<A::foo> is called twice).
-
-In some cases this I<may> be the desired effect within a diamond hierarchy,
-but in others (e.g. for destructors) it may be more appropriate to
-call each method only once during a sequence of redispatches.
-
-To cover such cases, you can redispatch methods via:
-
- $self->NEXT::UNSEEN::method();
-
-rather than:
-
- $self->NEXT::method();
-
-This causes the redispatcher to skip any classes in the hierarchy that it has
-already visited in an earlier redispatch. So, for example, if the
-previous example were rewritten:
-
- package A;
- sub foo { print "called A::foo\n"; shift->NEXT::UNSEEN::foo() }
-
- package B;
- sub foo { print "called B::foo\n"; shift->NEXT::UNSEEN::foo() }
-
- package C; @ISA = qw( A );
- sub foo { print "called C::foo\n"; shift->NEXT::UNSEEN::foo() }
-
- package D; @ISA = qw(A B);
- sub foo { print "called D::foo\n"; shift->NEXT::UNSEEN::foo() }
-
- package E; @ISA = qw(C D);
- sub foo { print "called E::foo\n"; shift->NEXT::UNSEEN::foo() }
-
- E->foo();
-
-then it would print:
-
- called E::foo
- called C::foo
- called A::foo
- called D::foo
- called B::foo
-
-and omit the second call to C<A::foo>.
-
-Note that you can also use:
-
- $self->NEXT::UNSEEN::ACTUAL::method();
-
-or:
-
- $self->NEXT::ACTUAL::UNSEEN::method();
-
-to get both unique invocation I<and> exception-on-failure.
-
-
-=head1 AUTHOR
-
-Damian Conway (damian@conway.org)
-
-=head1 BUGS AND IRRITATIONS
-
-Because it's a module, not an integral part of the interpreter, NEXT.pm
-has to guess where the surrounding call was found in the method
-look-up sequence. In the presence of diamond inheritance patterns
-it occasionally guesses wrong.
-
-It's also too slow (despite caching).
-
-Comment, suggestions, and patches welcome.
-
-=head1 COPYRIGHT
-
- Copyright (c) 2000-2001, Damian Conway. All Rights Reserved.
- This module is free software. It may be used, redistributed
- and/or modified under the same terms as Perl itself.
+++ /dev/null
-# Net::Cmd.pm $Id: //depot/libnet/Net/Cmd.pm#26 $
-#
-# Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::Cmd;
-
-require 5.001;
-require Exporter;
-
-use strict;
-use vars qw(@ISA @EXPORT $VERSION);
-use Carp;
-
-BEGIN {
- if ($^O eq 'os390') {
- require Convert::EBCDIC;
-# Convert::EBCDIC->import;
- }
-}
-
-$VERSION = "2.20";
-@ISA = qw(Exporter);
-@EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING);
-
-sub CMD_INFO { 1 }
-sub CMD_OK { 2 }
-sub CMD_MORE { 3 }
-sub CMD_REJECT { 4 }
-sub CMD_ERROR { 5 }
-sub CMD_PENDING { 0 }
-
-my %debug = ();
-
-my $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef;
-
-sub toebcdic
-{
- my $cmd = shift;
-
- unless (exists ${*$cmd}{'net_cmd_asciipeer'})
- {
- my $string = $_[0];
- my $ebcdicstr = $tr->toebcdic($string);
- ${*$cmd}{'net_cmd_asciipeer'} = $string !~ /^\d+/ && $ebcdicstr =~ /^\d+/;
- }
-
- ${*$cmd}{'net_cmd_asciipeer'}
- ? $tr->toebcdic($_[0])
- : $_[0];
-}
-
-sub toascii
-{
- my $cmd = shift;
- ${*$cmd}{'net_cmd_asciipeer'}
- ? $tr->toascii($_[0])
- : $_[0];
-}
-
-sub _print_isa
-{
- no strict qw(refs);
-
- my $pkg = shift;
- my $cmd = $pkg;
-
- $debug{$pkg} ||= 0;
-
- my %done = ();
- my @do = ($pkg);
- my %spc = ( $pkg , "");
-
- print STDERR "\n";
- while ($pkg = shift @do)
- {
- next if defined $done{$pkg};
-
- $done{$pkg} = 1;
-
- my $v = defined ${"${pkg}::VERSION"}
- ? "(" . ${"${pkg}::VERSION"} . ")"
- : "";
-
- my $spc = $spc{$pkg};
- print STDERR "$cmd: ${spc}${pkg}${v}\n";
-
- if(@{"${pkg}::ISA"})
- {
- @spc{@{"${pkg}::ISA"}} = (" " . $spc{$pkg}) x @{"${pkg}::ISA"};
- unshift(@do, @{"${pkg}::ISA"});
- }
- }
-
- print STDERR "\n";
-}
-
-sub debug
-{
- @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])';
-
- my($cmd,$level) = @_;
- my $pkg = ref($cmd) || $cmd;
- my $oldval = 0;
-
- if(ref($cmd))
- {
- $oldval = ${*$cmd}{'net_cmd_debug'} || 0;
- }
- else
- {
- $oldval = $debug{$pkg} || 0;
- }
-
- return $oldval
- unless @_ == 2;
-
- $level = $debug{$pkg} || 0
- unless defined $level;
-
- _print_isa($pkg)
- if($level && !exists $debug{$pkg});
-
- if(ref($cmd))
- {
- ${*$cmd}{'net_cmd_debug'} = $level;
- }
- else
- {
- $debug{$pkg} = $level;
- }
-
- $oldval;
-}
-
-sub message
-{
- @_ == 1 or croak 'usage: $obj->message()';
-
- my $cmd = shift;
-
- wantarray ? @{${*$cmd}{'net_cmd_resp'}}
- : join("", @{${*$cmd}{'net_cmd_resp'}});
-}
-
-sub debug_text { $_[2] }
-
-sub debug_print
-{
- my($cmd,$out,$text) = @_;
- print STDERR $cmd,($out ? '>>> ' : '<<< '), $cmd->debug_text($out,$text);
-}
-
-sub code
-{
- @_ == 1 or croak 'usage: $obj->code()';
-
- my $cmd = shift;
-
- ${*$cmd}{'net_cmd_code'} = "000"
- unless exists ${*$cmd}{'net_cmd_code'};
-
- ${*$cmd}{'net_cmd_code'};
-}
-
-sub status
-{
- @_ == 1 or croak 'usage: $obj->status()';
-
- my $cmd = shift;
-
- substr(${*$cmd}{'net_cmd_code'},0,1);
-}
-
-sub set_status
-{
- @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)';
-
- my $cmd = shift;
- my($code,$resp) = @_;
-
- $resp = [ $resp ]
- unless ref($resp);
-
- (${*$cmd}{'net_cmd_code'},${*$cmd}{'net_cmd_resp'}) = ($code, $resp);
-
- 1;
-}
-
-sub command
-{
- my $cmd = shift;
-
- unless (defined fileno($cmd))
- {
- $cmd->set_status("599", "Connection closed");
- return $cmd;
- }
-
-
- $cmd->dataend()
- if(exists ${*$cmd}{'net_cmd_lastch'});
-
- if (scalar(@_))
- {
- local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
-
- my $str = join(" ", map { /\n/ ? do { my $n = $_; $n =~ tr/\n/ /; $n } : $_; } @_);
- $str = $cmd->toascii($str) if $tr;
- $str .= "\015\012";
-
- my $len = length $str;
- my $swlen;
-
- $cmd->close
- unless (defined($swlen = syswrite($cmd,$str,$len)) && $swlen == $len);
-
- $cmd->debug_print(1,$str)
- if($cmd->debug);
-
- ${*$cmd}{'net_cmd_resp'} = []; # the response
- ${*$cmd}{'net_cmd_code'} = "000"; # Made this one up :-)
- }
-
- $cmd;
-}
-
-sub ok
-{
- @_ == 1 or croak 'usage: $obj->ok()';
-
- my $code = $_[0]->code;
- 0 < $code && $code < 400;
-}
-
-sub unsupported
-{
- my $cmd = shift;
-
- ${*$cmd}{'net_cmd_resp'} = [ 'Unsupported command' ];
- ${*$cmd}{'net_cmd_code'} = 580;
- 0;
-}
-
-sub getline
-{
- my $cmd = shift;
-
- ${*$cmd}{'net_cmd_lines'} ||= [];
-
- return shift @{${*$cmd}{'net_cmd_lines'}}
- if scalar(@{${*$cmd}{'net_cmd_lines'}});
-
- my $partial = defined(${*$cmd}{'net_cmd_partial'})
- ? ${*$cmd}{'net_cmd_partial'} : "";
- my $fd = fileno($cmd);
-
- return undef
- unless defined $fd;
-
- my $rin = "";
- vec($rin,$fd,1) = 1;
-
- my $buf;
-
- until(scalar(@{${*$cmd}{'net_cmd_lines'}}))
- {
- my $timeout = $cmd->timeout || undef;
- my $rout;
- if (select($rout=$rin, undef, undef, $timeout))
- {
- unless (sysread($cmd, $buf="", 1024))
- {
- carp(ref($cmd) . ": Unexpected EOF on command channel")
- if $cmd->debug;
- $cmd->close;
- return undef;
- }
-
- substr($buf,0,0) = $partial; ## prepend from last sysread
-
- my @buf = split(/\015?\012/, $buf, -1); ## break into lines
-
- $partial = pop @buf;
-
- push(@{${*$cmd}{'net_cmd_lines'}}, map { "$_\n" } @buf);
-
- }
- else
- {
- carp("$cmd: Timeout") if($cmd->debug);
- return undef;
- }
- }
-
- ${*$cmd}{'net_cmd_partial'} = $partial;
-
- if ($tr)
- {
- foreach my $ln (@{${*$cmd}{'net_cmd_lines'}})
- {
- $ln = $cmd->toebcdic($ln);
- }
- }
-
- shift @{${*$cmd}{'net_cmd_lines'}};
-}
-
-sub ungetline
-{
- my($cmd,$str) = @_;
-
- ${*$cmd}{'net_cmd_lines'} ||= [];
- unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);
-}
-
-sub parse_response
-{
- return ()
- unless $_[1] =~ s/^(\d\d\d)(.?)//o;
- ($1, $2 eq "-");
-}
-
-sub response
-{
- my $cmd = shift;
- my($code,$more) = (undef) x 2;
-
- ${*$cmd}{'net_cmd_resp'} ||= [];
-
- while(1)
- {
- my $str = $cmd->getline();
-
- return CMD_ERROR
- unless defined($str);
-
- $cmd->debug_print(0,$str)
- if ($cmd->debug);
-
- ($code,$more) = $cmd->parse_response($str);
- unless(defined $code)
- {
- $cmd->ungetline($str);
- last;
- }
-
- ${*$cmd}{'net_cmd_code'} = $code;
-
- push(@{${*$cmd}{'net_cmd_resp'}},$str);
-
- last unless($more);
- }
-
- substr($code,0,1);
-}
-
-sub read_until_dot
-{
- my $cmd = shift;
- my $fh = shift;
- my $arr = [];
-
- while(1)
- {
- my $str = $cmd->getline() or return undef;
-
- $cmd->debug_print(0,$str)
- if ($cmd->debug & 4);
-
- last if($str =~ /^\.\r?\n/o);
-
- $str =~ s/^\.\././o;
-
- if (defined $fh)
- {
- print $fh $str;
- }
- else
- {
- push(@$arr,$str);
- }
- }
-
- $arr;
-}
-
-sub datasend
-{
- my $cmd = shift;
- my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
- my $line = join("" ,@$arr);
-
- return 0 unless defined(fileno($cmd));
-
- return 1
- unless length($line);
-
- if($cmd->debug)
- {
- my $b = "$cmd>>> ";
- print STDERR $b,join("\n$b",split(/\n/,$line)),"\n";
- }
-
- # Translate LF => CRLF, but not if the LF is
- # already preceeded by a CR
- $line =~ s/\G()\n|([^\r\n])\n/$+\015\012/sgo;
-
- ${*$cmd}{'net_cmd_lastch'} ||= " ";
- $line = ${*$cmd}{'net_cmd_lastch'} . $line;
-
- $line =~ s/(\012\.)/$1./sog;
-
- ${*$cmd}{'net_cmd_lastch'} = substr($line,-1,1);
-
- my $len = length($line) - 1;
- my $offset = 1;
- my $win = "";
- vec($win,fileno($cmd),1) = 1;
- my $timeout = $cmd->timeout || undef;
-
- while($len)
- {
- my $wout;
- if (select(undef,$wout=$win, undef, $timeout) > 0)
- {
- my $w = syswrite($cmd, $line, $len, $offset);
- unless (defined($w))
- {
- carp("$cmd: $!") if $cmd->debug;
- return undef;
- }
- $len -= $w;
- $offset += $w;
- }
- else
- {
- carp("$cmd: Timeout") if($cmd->debug);
- return undef;
- }
- }
-
- 1;
-}
-
-sub dataend
-{
- my $cmd = shift;
-
- return 0 unless defined(fileno($cmd));
-
- return 1
- unless(exists ${*$cmd}{'net_cmd_lastch'});
-
- if(${*$cmd}{'net_cmd_lastch'} eq "\015")
- {
- syswrite($cmd,"\012",1);
- print STDERR "\n"
- if($cmd->debug);
- }
- elsif(${*$cmd}{'net_cmd_lastch'} ne "\012")
- {
- syswrite($cmd,"\015\012",2);
- print STDERR "\n"
- if($cmd->debug);
- }
-
- print STDERR "$cmd>>> .\n"
- if($cmd->debug);
-
- syswrite($cmd,".\015\012",3);
-
- delete ${*$cmd}{'net_cmd_lastch'};
-
- $cmd->response() == CMD_OK;
-}
-
-1;
-
-__END__
-
-
-=head1 NAME
-
-Net::Cmd - Network Command class (as used by FTP, SMTP etc)
-
-=head1 SYNOPSIS
-
- use Net::Cmd;
-
- @ISA = qw(Net::Cmd);
-
-=head1 DESCRIPTION
-
-C<Net::Cmd> is a collection of methods that can be inherited by a sub class
-of C<IO::Handle>. These methods implement the functionality required for a
-command based protocol, for example FTP and SMTP.
-
-=head1 USER METHODS
-
-These methods provide a user interface to the C<Net::Cmd> object.
-
-=over 4
-
-=item debug ( VALUE )
-
-Set the level of debug information for this object. If C<VALUE> is not given
-then the current state is returned. Otherwise the state is changed to
-C<VALUE> and the previous state returned.
-
-Set the level of debug information for this object. If no argument is
-given then the current state is returned. Otherwise the state is
-changed to C<$value>and the previous state returned. Different packages
-may implement different levels of debug but, a non-zero value result in
-copies of all commands and responses also being sent to STDERR.
-
-If C<VALUE> is C<undef> then the debug level will be set to the default
-debug level for the class.
-
-This method can also be called as a I<static> method to set/get the default
-debug level for a given class.
-
-=item message ()
-
-Returns the text message returned from the last command
-
-=item code ()
-
-Returns the 3-digit code from the last command. If a command is pending
-then the value 0 is returned
-
-=item ok ()
-
-Returns non-zero if the last code value was greater than zero and
-less than 400. This holds true for most command servers. Servers
-where this does not hold may override this method.
-
-=item status ()
-
-Returns the most significant digit of the current status code. If a command
-is pending then C<CMD_PENDING> is returned.
-
-=item datasend ( DATA )
-
-Send data to the remote server, converting LF to CRLF. Any line starting
-with a '.' will be prefixed with another '.'.
-C<DATA> may be an array or a reference to an array.
-
-=item dataend ()
-
-End the sending of data to the remote server. This is done by ensuring that
-the data already sent ends with CRLF then sending '.CRLF' to end the
-transmission. Once this data has been sent C<dataend> calls C<response> and
-returns true if C<response> returns CMD_OK.
-
-=back
-
-=head1 CLASS METHODS
-
-These methods are not intended to be called by the user, but used or
-over-ridden by a sub-class of C<Net::Cmd>
-
-=over 4
-
-=item debug_print ( DIR, TEXT )
-
-Print debugging information. C<DIR> denotes the direction I<true> being
-data being sent to the server. Calls C<debug_text> before printing to
-STDERR.
-
-=item debug_text ( TEXT )
-
-This method is called to print debugging information. TEXT is
-the text being sent. The method should return the text to be printed
-
-This is primarily meant for the use of modules such as FTP where passwords
-are sent, but we do not want to display them in the debugging information.
-
-=item command ( CMD [, ARGS, ... ])
-
-Send a command to the command server. All arguments a first joined with
-a space character and CRLF is appended, this string is then sent to the
-command server.
-
-Returns undef upon failure
-
-=item unsupported ()
-
-Sets the status code to 580 and the response text to 'Unsupported command'.
-Returns zero.
-
-=item response ()
-
-Obtain a response from the server. Upon success the most significant digit
-of the status code is returned. Upon failure, timeout etc., I<undef> is
-returned.
-
-=item parse_response ( TEXT )
-
-This method is called by C<response> as a method with one argument. It should
-return an array of 2 values, the 3-digit status code and a flag which is true
-when this is part of a multi-line response and this line is not the list.
-
-=item getline ()
-
-Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef>
-upon failure.
-
-B<NOTE>: If you do use this method for any reason, please remember to add
-some C<debug_print> calls into your method.
-
-=item ungetline ( TEXT )
-
-Unget a line of text from the server.
-
-=item read_until_dot ()
-
-Read data from the remote server until a line consisting of a single '.'.
-Any lines starting with '..' will have one of the '.'s removed.
-
-Returns a reference to a list containing the lines, or I<undef> upon failure.
-
-=back
-
-=head1 EXPORTS
-
-C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
-C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR> ,correspond to possible results
-of C<response> and C<status>. The sixth is C<CMD_PENDING>.
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-1997 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=for html <hr>
-
-I<$Id: //depot/libnet/Net/Cmd.pm#26 $>
-
-=cut
+++ /dev/null
-# Net::Config.pm
-#
-# Copyright (c) 2000 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::Config;
-
-require Exporter;
-use vars qw(@ISA @EXPORT %NetConfig $VERSION $CONFIGURE $LIBNET_CFG);
-use Socket qw(inet_aton inet_ntoa);
-use strict;
-
-@EXPORT = qw(%NetConfig);
-@ISA = qw(Net::LocalCfg Exporter);
-$VERSION = "1.09"; # $Id: //depot/libnet/Net/Config.pm#16 $
-
-eval { local $SIG{__DIE__}; require Net::LocalCfg };
-
-%NetConfig = (
- nntp_hosts => [],
- snpp_hosts => [],
- pop3_hosts => [],
- smtp_hosts => [],
- ph_hosts => [],
- daytime_hosts => [],
- time_hosts => [],
- inet_domain => undef,
- ftp_firewall => undef,
- ftp_ext_passive => 0,
- ftp_int_passive => 0,
- test_hosts => 1,
- test_exist => 1,
-);
-
-#
-# Try to get as much configuration info as possible from InternetConfig
-#
-$^O eq 'MacOS' and eval <<TRY_INTERNET_CONFIG;
-use Mac::InternetConfig;
-
-{
-my %nc = (
- nntp_hosts => [ \$InternetConfig{ kICNNTPHost() } ],
- pop3_hosts => [ \$InternetConfig{ kICMailAccount() } =~ /\@(.*)/ ],
- smtp_hosts => [ \$InternetConfig{ kICSMTPHost() } ],
- ftp_testhost => \$InternetConfig{ kICFTPHost() } ? \$InternetConfig{ kICFTPHost()} : undef,
- ph_hosts => [ \$InternetConfig{ kICPhHost() } ],
- ftp_ext_passive => \$InternetConfig{"646F676F\xA5UsePassiveMode"} || 0,
- ftp_int_passive => \$InternetConfig{"646F676F\xA5UsePassiveMode"} || 0,
- socks_hosts =>
- \$InternetConfig{ kICUseSocks() } ? [ \$InternetConfig{ kICSocksHost() } ] : [],
- ftp_firewall =>
- \$InternetConfig{ kICUseFTPProxy() } ? [ \$InternetConfig{ kICFTPProxyHost() } ] : [],
-);
-\@NetConfig{keys %nc} = values %nc;
-}
-TRY_INTERNET_CONFIG
-
-my $file = __FILE__;
-my $ref;
-$file =~ s/Config.pm/libnet.cfg/;
-if ( -f $file ) {
- $ref = eval { local $SIG{__DIE__}; do $file };
- if (ref($ref) eq 'HASH') {
- %NetConfig = (%NetConfig, %{ $ref });
- $LIBNET_CFG = $file;
- }
-}
-if ($< == $> and !$CONFIGURE) {
- my $home = eval { local $SIG{__DIE__}; (getpwuid($>))[7] } || $ENV{HOME};
- $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH}||'') if defined $ENV{HOMEDRIVE};
- if (defined $home) {
- $file = $home . "/.libnetrc";
- $ref = eval { local $SIG{__DIE__}; do $file } if -f $file;
- %NetConfig = (%NetConfig, %{ $ref })
- if ref($ref) eq 'HASH';
- }
-}
-my ($k,$v);
-while(($k,$v) = each %NetConfig) {
- $NetConfig{$k} = [ $v ]
- if($k =~ /_hosts$/ and $k ne "test_hosts" and defined($v) and !ref($v));
-}
-
-# Take a hostname and determine if it is inside the firewall
-
-sub requires_firewall {
- shift; # ignore package
- my $host = shift;
-
- return 0 unless defined $NetConfig{'ftp_firewall'};
-
- $host = inet_aton($host) or return -1;
- $host = inet_ntoa($host);
-
- if(exists $NetConfig{'local_netmask'}) {
- my $quad = unpack("N",pack("C*",split(/\./,$host)));
- my $list = $NetConfig{'local_netmask'};
- $list = [$list] unless ref($list);
- foreach (@$list) {
- my($net,$bits) = (m#^(\d+\.\d+\.\d+\.\d+)/(\d+)$#) or next;
- my $mask = ~0 << (32 - $bits);
- my $addr = unpack("N",pack("C*",split(/\./,$net)));
-
- return 0 if (($addr & $mask) == ($quad & $mask));
- }
- return 1;
- }
-
- return 0;
-}
-
-use vars qw(*is_external);
-*is_external = \&requires_firewall;
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::Config - Local configuration data for libnet
-
-=head1 SYNOPSYS
-
- use Net::Config qw(%NetConfig);
-
-=head1 DESCRIPTION
-
-C<Net::Config> holds configuration data for the modules in the libnet
-distribuion. During installation you will be asked for these values.
-
-The configuration data is held globally in a file in the perl installation
-tree, but a user may override any of these values by providing their own. This
-can be done by having a C<.libnetrc> file in their home directory. This file
-should return a reference to a HASH containing the keys described below.
-For example
-
- # .libnetrc
- {
- nntp_hosts => [ "my_prefered_host" ],
- ph_hosts => [ "my_ph_server" ],
- }
- __END__
-
-=head1 METHODS
-
-C<Net::Config> defines the following methods. They are methods as they are
-invoked as class methods. This is because C<Net::Config> inherits from
-C<Net::LocalCfg> so you can override these methods if you want.
-
-=over 4
-
-=item requires_firewall HOST
-
-Attempts to determine if a given host is outside your firewall. Possible
-return values are.
-
- -1 Cannot lookup hostname
- 0 Host is inside firewall (or there is no ftp_firewall entry)
- 1 Host is outside the firewall
-
-This is done by using hostname lookup and the C<local_netmask> entry in
-the configuration data.
-
-=back
-
-=head1 NetConfig VALUES
-
-=over 4
-
-=item nntp_hosts
-
-=item snpp_hosts
-
-=item pop3_hosts
-
-=item smtp_hosts
-
-=item ph_hosts
-
-=item daytime_hosts
-
-=item time_hosts
-
-Each is a reference to an array of hostnames (in order of preference),
-which should be used for the given protocol
-
-=item inet_domain
-
-Your internet domain name
-
-=item ftp_firewall
-
-If you have an FTP proxy firewall (B<NOT> an HTTP or SOCKS firewall)
-then this value should be set to the firewall hostname. If your firewall
-does not listen to port 21, then this value should be set to
-C<"hostname:port"> (eg C<"hostname:99">)
-
-=item ftp_firewall_type
-
-There are many different ftp firewall products available. But unfortunately
-there is no standard for how to traverse a firewall. The list below shows the
-sequence of commands that Net::FTP will use
-
- user Username for remote host
- pass Password for remote host
- fwuser Username for firewall
- fwpass Password for firewall
- remote.host The hostname of the remote ftp server
-
-=over 4
-
-=item 0
-
-There is no firewall
-
-=item 1
-
- USER user@remote.host
- PASS pass
-
-=item 2
-
- USER fwuser
- PASS fwpass
- USER user@remote.host
- PASS pass
-
-=item 3
-
- USER fwuser
- PASS fwpass
- SITE remote.site
- USER user
- PASS pass
-
-=item 4
-
- USER fwuser
- PASS fwpass
- OPEN remote.site
- USER user
- PASS pass
-
-=item 5
-
- USER user@fwuser@remote.site
- PASS pass@fwpass
-
-=item 6
-
- USER fwuser@remote.site
- PASS fwpass
- USER user
- PASS pass
-
-=item 7
-
- USER user@remote.host
- PASS pass
- AUTH fwuser
- RESP fwpass
-
-=back
-
-=item ftp_ext_passive
-
-=item ftp_int_pasive
-
-FTP servers normally work on a non-passive mode. That is when you want to
-transfer data you have to tell the server the address and port to
-connect to.
-
-With some firewalls this does not work as the server cannot
-connect to your machine (because you are behind a firewall) and the firewall
-does not re-write the command. In this case you should set C<ftp_ext_passive>
-to a I<true> value.
-
-Some servers are configured to only work in passive mode. If you have
-one of these you can force C<Net::FTP> to always transfer in passive
-mode; when not going via a firewall, by setting C<ftp_int_passive> to
-a I<true> value.
-
-=item local_netmask
-
-A reference to a list of netmask strings in the form C<"134.99.4.0/24">.
-These are used by the C<requires_firewall> function to determine if a given
-host is inside or outside your firewall.
-
-=back
-
-The following entries are used during installation & testing on the
-libnet package
-
-=over 4
-
-=item test_hosts
-
-If true then C<make test> may attempt to connect to hosts given in the
-configuration.
-
-=item test_exists
-
-If true then C<Configure> will check each hostname given that it exists
-
-=back
-
-=for html <hr>
-
-I<$Id: //depot/libnet/Net/Config.pm#16 $>
-
-=cut
+++ /dev/null
-# Net::Domain.pm
-#
-# Copyright (c) 1995-1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::Domain;
-
-require Exporter;
-
-use Carp;
-use strict;
-use vars qw($VERSION @ISA @EXPORT_OK);
-use Net::Config;
-
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(hostname hostdomain hostfqdn domainname);
-
-$VERSION = "2.17"; # $Id: //depot/libnet/Net/Domain.pm#19 $
-
-my($host,$domain,$fqdn) = (undef,undef,undef);
-
-# Try every conceivable way to get hostname.
-
-sub _hostname {
-
- # we already know it
- return $host
- if(defined $host);
-
- if ($^O eq 'MSWin32') {
- require Socket;
- my ($name,$alias,$type,$len,@addr) = gethostbyname($ENV{'COMPUTERNAME'}||'localhost');
- while (@addr)
- {
- my $a = shift(@addr);
- $host = gethostbyaddr($a,Socket::AF_INET());
- last if defined $host;
- }
- if (defined($host) && index($host,'.') > 0) {
- $fqdn = $host;
- ($host,$domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
- }
- return $host;
- }
- elsif ($^O eq 'MacOS') {
- chomp ($host = `hostname`);
- }
- elsif ($^O eq 'VMS') { ## multiple varieties of net s/w makes this hard
- $host = $ENV{'UCX$INET_HOST'} if defined($ENV{'UCX$INET_HOST'});
- $host = $ENV{'MULTINET_HOST_NAME'} if defined($ENV{'MULTINET_HOST_NAME'});
- if (index($host,'.') > 0) {
- $fqdn = $host;
- ($host,$domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
- }
- return $host;
- }
- else {
- local $SIG{'__DIE__'};
-
- # syscall is preferred since it avoids tainting problems
- eval {
- my $tmp = "\0" x 256; ## preload scalar
- eval {
- package main;
- require "syscall.ph";
- defined(&main::SYS_gethostname);
- }
- || eval {
- package main;
- require "sys/syscall.ph";
- defined(&main::SYS_gethostname);
- }
- and $host = (syscall(&main::SYS_gethostname, $tmp, 256) == 0)
- ? $tmp
- : undef;
- }
-
- # POSIX
- || eval {
- require POSIX;
- $host = (POSIX::uname())[1];
- }
-
- # trusty old hostname command
- || eval {
- chop($host = `(hostname) 2>/dev/null`); # BSD'ish
- }
-
- # sysV/POSIX uname command (may truncate)
- || eval {
- chop($host = `uname -n 2>/dev/null`); ## SYSV'ish && POSIX'ish
- }
-
- # Apollo pre-SR10
- || eval {
- $host = (split(/[:\. ]/,`/com/host`,6))[0];
- }
-
- || eval {
- $host = "";
- };
- }
-
- # remove garbage
- $host =~ s/[\0\r\n]+//go;
- $host =~ s/(\A\.+|\.+\Z)//go;
- $host =~ s/\.\.+/\./go;
-
- $host;
-}
-
-sub _hostdomain {
-
- # we already know it
- return $domain
- if(defined $domain);
-
- local $SIG{'__DIE__'};
-
- return $domain = $NetConfig{'inet_domain'}
- if defined $NetConfig{'inet_domain'};
-
- # try looking in /etc/resolv.conf
- # putting this here and assuming that it is correct, eliminates
- # calls to gethostbyname, and therefore DNS lookups. This helps
- # those on dialup systems.
-
- local *RES;
- local($_);
-
- if(open(RES,"/etc/resolv.conf")) {
- while(<RES>) {
- $domain = $1
- if(/\A\s*(?:domain|search)\s+(\S+)/);
- }
- close(RES);
-
- return $domain
- if(defined $domain);
- }
-
- # just try hostname and system calls
-
- my $host = _hostname();
- my(@hosts);
-
- @hosts = ($host,"localhost");
-
- unless (defined($host) && $host =~ /\./) {
- my $dom = undef;
- eval {
- my $tmp = "\0" x 256; ## preload scalar
- eval {
- package main;
- require "syscall.ph";
- }
- || eval {
- package main;
- require "sys/syscall.ph";
- }
- and $dom = (syscall(&main::SYS_getdomainname, $tmp, 256) == 0)
- ? $tmp
- : undef;
- };
-
- chop($dom = `domainname 2>/dev/null`)
- unless(defined $dom || $^O =~ /^(?:cygwin|MSWin32)/);
-
- if(defined $dom) {
- my @h = ();
- while(length($dom)) {
- push(@h, "$host.$dom");
- $dom =~ s/^[^.]+.//;
- }
- unshift(@hosts,@h);
- }
- }
-
- # Attempt to locate FQDN
-
- foreach (grep {defined $_} @hosts) {
- my @info = gethostbyname($_);
-
- next unless @info;
-
- # look at real name & aliases
- my $site;
- foreach $site ($info[0], split(/ /,$info[1])) {
- if(rindex($site,".") > 0) {
-
- # Extract domain from FQDN
-
- ($domain = $site) =~ s/\A[^\.]+\.//;
- return $domain;
- }
- }
- }
-
- # Look for environment variable
-
- $domain ||= $ENV{LOCALDOMAIN} || $ENV{DOMAIN};
-
- if(defined $domain) {
- $domain =~ s/[\r\n\0]+//g;
- $domain =~ s/(\A\.+|\.+\Z)//g;
- $domain =~ s/\.\.+/\./g;
- }
-
- $domain;
-}
-
-sub domainname {
-
- return $fqdn
- if(defined $fqdn);
-
- _hostname();
- _hostdomain();
-
- # Assumption: If the host name does not contain a period
- # and the domain name does, then assume that they are correct
- # this helps to eliminate calls to gethostbyname, and therefore
- # eleminate DNS lookups
-
- return $fqdn = $host . "." . $domain
- if(defined $host and defined $domain
- and $host !~ /\./ and $domain =~ /\./);
-
- # For hosts that have no name, just an IP address
- return $fqdn = $host if defined $host and $host =~ /^\d+(\.\d+){3}$/;
-
- my @host = defined $host ? split(/\./, $host) : ('localhost');
- my @domain = defined $domain ? split(/\./, $domain) : ();
- my @fqdn = ();
-
- # Determine from @host & @domain the FQDN
-
- my @d = @domain;
-
-LOOP:
- while(1) {
- my @h = @host;
- while(@h) {
- my $tmp = join(".",@h,@d);
- if((gethostbyname($tmp))[0]) {
- @fqdn = (@h,@d);
- $fqdn = $tmp;
- last LOOP;
- }
- pop @h;
- }
- last unless shift @d;
- }
-
- if(@fqdn) {
- $host = shift @fqdn;
- until((gethostbyname($host))[0]) {
- $host .= "." . shift @fqdn;
- }
- $domain = join(".", @fqdn);
- }
- else {
- undef $host;
- undef $domain;
- undef $fqdn;
- }
-
- $fqdn;
-}
-
-sub hostfqdn { domainname() }
-
-sub hostname {
- domainname()
- unless(defined $host);
- return $host;
-}
-
-sub hostdomain {
- domainname()
- unless(defined $domain);
- return $domain;
-}
-
-1; # Keep require happy
-
-__END__
-
-=head1 NAME
-
-Net::Domain - Attempt to evaluate the current host's internet name and domain
-
-=head1 SYNOPSIS
-
- use Net::Domain qw(hostname hostfqdn hostdomain);
-
-=head1 DESCRIPTION
-
-Using various methods B<attempt> to find the Fully Qualified Domain Name (FQDN)
-of the current host. From this determine the host-name and the host-domain.
-
-Each of the functions will return I<undef> if the FQDN cannot be determined.
-
-=over 4
-
-=item hostfqdn ()
-
-Identify and return the FQDN of the current host.
-
-=item hostname ()
-
-Returns the smallest part of the FQDN which can be used to identify the host.
-
-=item hostdomain ()
-
-Returns the remainder of the FQDN after the I<hostname> has been removed.
-
-=back
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>.
-Adapted from Sys::Hostname by David Sundstrom <sunds@asictest.sc.ti.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-1998 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=for html <hr>
-
-I<$Id: //depot/libnet/Net/Domain.pm#19 $>
-
-=cut
+++ /dev/null
-# Net::FTP.pm
-#
-# Copyright (c) 1995-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-#
-# Documentation (at end) improved 1996 by Nathan Torkington <gnat@frii.com>.
-
-package Net::FTP;
-
-require 5.001;
-
-use strict;
-use vars qw(@ISA $VERSION);
-use Carp;
-
-use Socket 1.3;
-use IO::Socket;
-use Time::Local;
-use Net::Cmd;
-use Net::Config;
-use Fcntl qw(O_WRONLY O_RDONLY O_APPEND O_CREAT O_TRUNC);
-# use AutoLoader qw(AUTOLOAD);
-
-$VERSION = "2.62"; # $Id: //depot/libnet/Net/FTP.pm#64 $
-@ISA = qw(Exporter Net::Cmd IO::Socket::INET);
-
-# Someday I will "use constant", when I am not bothered to much about
-# compatability with older releases of perl
-
-use vars qw($TELNET_IAC $TELNET_IP $TELNET_DM);
-($TELNET_IAC,$TELNET_IP,$TELNET_DM) = (255,244,242);
-
-# Name is too long for AutoLoad, it clashes with pasv_xfer
-sub pasv_xfer_unique {
- my($sftp,$sfile,$dftp,$dfile) = @_;
- $sftp->pasv_xfer($sfile,$dftp,$dfile,1);
-}
-
-BEGIN {
- # make a constant so code is fast'ish
- my $is_os390 = $^O eq 'os390';
- *trEBCDIC = sub () { $is_os390 }
-}
-
-1;
-# Having problems with AutoLoader
-#__END__
-
-sub new
-{
- my $pkg = shift;
- my $peer = shift;
- my %arg = @_;
-
- my $host = $peer;
- my $fire = undef;
- my $fire_type = undef;
-
- if(exists($arg{Firewall}) || Net::Config->requires_firewall($peer))
- {
- $fire = $arg{Firewall}
- || $ENV{FTP_FIREWALL}
- || $NetConfig{ftp_firewall}
- || undef;
-
- if(defined $fire)
- {
- $peer = $fire;
- delete $arg{Port};
- $fire_type = $arg{FirewallType}
- || $ENV{FTP_FIREWALL_TYPE}
- || undef;
- }
- }
-
- my $ftp = $pkg->SUPER::new(PeerAddr => $peer,
- PeerPort => $arg{Port} || 'ftp(21)',
- Proto => 'tcp',
- Timeout => defined $arg{Timeout}
- ? $arg{Timeout}
- : 120
- ) or return undef;
-
- ${*$ftp}{'net_ftp_host'} = $host; # Remote hostname
- ${*$ftp}{'net_ftp_type'} = 'A'; # ASCII/binary/etc mode
- ${*$ftp}{'net_ftp_blksize'} = abs($arg{'BlockSize'} || 10240);
-
- ${*$ftp}{'net_ftp_firewall'} = $fire
- if(defined $fire);
- ${*$ftp}{'net_ftp_firewall_type'} = $fire_type
- if(defined $fire_type);
-
- ${*$ftp}{'net_ftp_passive'} = int
- exists $arg{Passive}
- ? $arg{Passive}
- : exists $ENV{FTP_PASSIVE}
- ? $ENV{FTP_PASSIVE}
- : defined $fire
- ? $NetConfig{ftp_ext_passive}
- : $NetConfig{ftp_int_passive}; # Whew! :-)
-
- $ftp->hash(exists $arg{Hash} ? $arg{Hash} : 0, 1024);
-
- $ftp->autoflush(1);
-
- $ftp->debug(exists $arg{Debug} ? $arg{Debug} : undef);
-
- unless ($ftp->response() == CMD_OK)
- {
- $ftp->close();
- $@ = $ftp->message;
- undef $ftp;
- }
-
- $ftp;
-}
-
-##
-## User interface methods
-##
-
-sub hash {
- my $ftp = shift; # self
-
- my($h,$b) = @_;
- unless($h) {
- delete ${*$ftp}{'net_ftp_hash'};
- return [\*STDERR,0];
- }
- ($h,$b) = (ref($h)? $h : \*STDERR, $b || 1024);
- select((select($h), $|=1)[0]);
- $b = 512 if $b < 512;
- ${*$ftp}{'net_ftp_hash'} = [$h, $b];
-}
-
-sub quit
-{
- my $ftp = shift;
-
- $ftp->_QUIT;
- $ftp->close;
-}
-
-sub DESTROY {}
-
-sub ascii { shift->type('A',@_); }
-sub binary { shift->type('I',@_); }
-
-sub ebcdic
-{
- carp "TYPE E is unsupported, shall default to I";
- shift->type('E',@_);
-}
-
-sub byte
-{
- carp "TYPE L is unsupported, shall default to I";
- shift->type('L',@_);
-}
-
-# Allow the user to send a command directly, BE CAREFUL !!
-
-sub quot
-{
- my $ftp = shift;
- my $cmd = shift;
-
- $ftp->command( uc $cmd, @_);
- $ftp->response();
-}
-
-sub site
-{
- my $ftp = shift;
-
- $ftp->command("SITE", @_);
- $ftp->response();
-}
-
-sub mdtm
-{
- my $ftp = shift;
- my $file = shift;
-
- # Server Y2K bug workaround
- #
- # sigh; some idiotic FTP servers use ("19%d",tm.tm_year) instead of
- # ("%d",tm.tm_year+1900). This results in an extra digit in the
- # string returned. To account for this we allow an optional extra
- # digit in the year. Then if the first two digits are 19 we use the
- # remainder, otherwise we subtract 1900 from the whole year.
-
- $ftp->_MDTM($file) && $ftp->message =~ /((\d\d)(\d\d\d?))(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/
- ? timegm($8,$7,$6,$5,$4-1,$2 eq '19' ? $3 : ($1-1900))
- : undef;
-}
-
-sub size {
- my $ftp = shift;
- my $file = shift;
- my $io;
- if($ftp->supported("SIZE")) {
- return $ftp->_SIZE($file)
- ? ($ftp->message =~ /(\d+)$/)[0]
- : undef;
- }
- elsif($ftp->supported("STAT")) {
- my @msg;
- return undef
- unless $ftp->_STAT($file) && (@msg = $ftp->message) == 3;
- my $line;
- foreach $line (@msg) {
- return (split(/\s+/,$line))[4]
- if $line =~ /^[-rwx]{10}/
- }
- }
- else {
- my @files = $ftp->dir($file);
- if(@files) {
- return (split(/\s+/,$1))[4]
- if $files[0] =~ /^([-rwx]{10}.*)$/;
- }
- }
- undef;
-}
-
-sub login {
- my($ftp,$user,$pass,$acct) = @_;
- my($ok,$ruser,$fwtype);
-
- unless (defined $user) {
- require Net::Netrc;
-
- my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'});
-
- ($user,$pass,$acct) = $rc->lpa()
- if ($rc);
- }
-
- $user ||= "anonymous";
- $ruser = $user;
-
- $fwtype = ${*$ftp}{'net_ftp_firewall_type'}
- || $NetConfig{'ftp_firewall_type'}
- || 0;
-
- if ($fwtype && defined ${*$ftp}{'net_ftp_firewall'}) {
- if ($fwtype == 1 || $fwtype == 7) {
- $user .= '@' . ${*$ftp}{'net_ftp_host'};
- }
- else {
- require Net::Netrc;
-
- my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});
-
- my($fwuser,$fwpass,$fwacct) = $rc ? $rc->lpa() : ();
-
- if ($fwtype == 5) {
- $user = join('@',$user,$fwuser,${*$ftp}{'net_ftp_host'});
- $pass = $pass . '@' . $fwpass;
- }
- else {
- if ($fwtype == 2) {
- $user .= '@' . ${*$ftp}{'net_ftp_host'};
- }
- elsif ($fwtype == 6) {
- $fwuser .= '@' . ${*$ftp}{'net_ftp_host'};
- }
-
- $ok = $ftp->_USER($fwuser);
-
- return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
-
- $ok = $ftp->_PASS($fwpass || "");
-
- return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
-
- $ok = $ftp->_ACCT($fwacct)
- if defined($fwacct);
-
- if ($fwtype == 3) {
- $ok = $ftp->command("SITE",${*$ftp}{'net_ftp_host'})->response;
- }
- elsif ($fwtype == 4) {
- $ok = $ftp->command("OPEN",${*$ftp}{'net_ftp_host'})->response;
- }
-
- return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
- }
- }
- }
-
- $ok = $ftp->_USER($user);
-
- # Some dumb firewalls don't prefix the connection messages
- $ok = $ftp->response()
- if ($ok == CMD_OK && $ftp->code == 220 && $user =~ /\@/);
-
- if ($ok == CMD_MORE) {
- unless(defined $pass) {
- require Net::Netrc;
-
- my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'}, $ruser);
-
- ($ruser,$pass,$acct) = $rc->lpa()
- if ($rc);
-
- $pass = '-anonymous@'
- if (!defined $pass && (!defined($ruser) || $ruser =~ /^anonymous/o));
- }
-
- $ok = $ftp->_PASS($pass || "");
- }
-
- $ok = $ftp->_ACCT($acct)
- if (defined($acct) && ($ok == CMD_MORE || $ok == CMD_OK));
-
- if ($fwtype == 7 && $ok == CMD_OK && defined ${*$ftp}{'net_ftp_firewall'}) {
- my($f,$auth,$resp) = _auth_id($ftp);
- $ftp->authorize($auth,$resp) if defined($resp);
- }
-
- $ok == CMD_OK;
-}
-
-sub account
-{
- @_ == 2 or croak 'usage: $ftp->account( ACCT )';
- my $ftp = shift;
- my $acct = shift;
- $ftp->_ACCT($acct) == CMD_OK;
-}
-
-sub _auth_id {
- my($ftp,$auth,$resp) = @_;
-
- unless(defined $resp)
- {
- require Net::Netrc;
-
- $auth ||= eval { (getpwuid($>))[0] } || $ENV{NAME};
-
- my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}, $auth)
- || Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});
-
- ($auth,$resp) = $rc->lpa()
- if ($rc);
- }
- ($ftp,$auth,$resp);
-}
-
-sub authorize
-{
- @_ >= 1 || @_ <= 3 or croak 'usage: $ftp->authorize( [AUTH [, RESP]])';
-
- my($ftp,$auth,$resp) = &_auth_id;
-
- my $ok = $ftp->_AUTH($auth || "");
-
- $ok = $ftp->_RESP($resp || "")
- if ($ok == CMD_MORE);
-
- $ok == CMD_OK;
-}
-
-sub rename
-{
- @_ == 3 or croak 'usage: $ftp->rename(FROM, TO)';
-
- my($ftp,$from,$to) = @_;
-
- $ftp->_RNFR($from)
- && $ftp->_RNTO($to);
-}
-
-sub type
-{
- my $ftp = shift;
- my $type = shift;
- my $oldval = ${*$ftp}{'net_ftp_type'};
-
- return $oldval
- unless (defined $type);
-
- return undef
- unless ($ftp->_TYPE($type,@_));
-
- ${*$ftp}{'net_ftp_type'} = join(" ",$type,@_);
-
- $oldval;
-}
-
-sub abort
-{
- my $ftp = shift;
-
- send($ftp,pack("CCC", $TELNET_IAC, $TELNET_IP, $TELNET_IAC),MSG_OOB);
-
- $ftp->command(pack("C",$TELNET_DM) . "ABOR");
-
- ${*$ftp}{'net_ftp_dataconn'}->close()
- if defined ${*$ftp}{'net_ftp_dataconn'};
-
- $ftp->response();
-
- $ftp->status == CMD_OK;
-}
-
-sub get
-{
- my($ftp,$remote,$local,$where) = @_;
-
- my($loc,$len,$buf,$resp,$localfd,$data);
- local *FD;
-
- $localfd = ref($local) || ref(\$local) eq "GLOB"
- ? fileno($local)
- : undef;
-
- ($local = $remote) =~ s#^.*/##
- unless(defined $local);
-
- croak("Bad remote filename '$remote'\n")
- if $remote =~ /[\r\n]/s;
-
- ${*$ftp}{'net_ftp_rest'} = $where
- if ($where);
-
- delete ${*$ftp}{'net_ftp_port'};
- delete ${*$ftp}{'net_ftp_pasv'};
-
- $data = $ftp->retr($remote) or
- return undef;
-
- if(defined $localfd)
- {
- $loc = $local;
- }
- else
- {
- $loc = \*FD;
-
- unless(sysopen($loc, $local, O_CREAT | O_WRONLY | ($where ? O_APPEND : O_TRUNC)))
- {
- carp "Cannot open Local file $local: $!\n";
- $data->abort;
- return undef;
- }
- }
-
- if($ftp->type eq 'I' && !binmode($loc))
- {
- carp "Cannot binmode Local file $local: $!\n";
- $data->abort;
- close($loc) unless $localfd;
- return undef;
- }
-
- $buf = '';
- my($count,$hashh,$hashb,$ref) = (0);
-
- ($hashh,$hashb) = @$ref
- if($ref = ${*$ftp}{'net_ftp_hash'});
-
- my $blksize = ${*$ftp}{'net_ftp_blksize'};
-
- while(1)
- {
- last unless $len = $data->read($buf,$blksize);
-
- if (trEBCDIC && $ftp->type ne 'I')
- {
- $buf = $ftp->toebcdic($buf);
- $len = length($buf);
- }
-
- if($hashh) {
- $count += $len;
- print $hashh "#" x (int($count / $hashb));
- $count %= $hashb;
- }
- my $written = syswrite($loc,$buf,$len);
- unless(defined($written) && $written == $len)
- {
- carp "Cannot write to Local file $local: $!\n";
- $data->abort;
- close($loc)
- unless defined $localfd;
- return undef;
- }
- }
-
- print $hashh "\n" if $hashh;
-
- unless (defined $localfd)
- {
- unless (close($loc))
- {
- carp "Cannot close file $local (perhaps disk space) $!\n";
- return undef;
- }
- }
-
- unless ($data->close()) # implied $ftp->response
- {
- carp "Unable to close datastream";
- return undef;
- }
-
- return $local;
-}
-
-sub cwd
-{
- @_ == 1 || @_ == 2 or croak 'usage: $ftp->cwd( [ DIR ] )';
-
- my($ftp,$dir) = @_;
-
- $dir = "/" unless defined($dir) && $dir =~ /\S/;
-
- $dir eq ".."
- ? $ftp->_CDUP()
- : $ftp->_CWD($dir);
-}
-
-sub cdup
-{
- @_ == 1 or croak 'usage: $ftp->cdup()';
- $_[0]->_CDUP;
-}
-
-sub pwd
-{
- @_ == 1 || croak 'usage: $ftp->pwd()';
- my $ftp = shift;
-
- $ftp->_PWD();
- $ftp->_extract_path;
-}
-
-# rmdir( $ftp, $dir, [ $recurse ] )
-#
-# Removes $dir on remote host via FTP.
-# $ftp is handle for remote host
-#
-# If $recurse is TRUE, the directory and deleted recursively.
-# This means all of its contents and subdirectories.
-#
-# Initial version contributed by Dinkum Software
-#
-sub rmdir
-{
- @_ == 2 || @_ == 3 or croak('usage: $ftp->rmdir( DIR [, RECURSE ] )');
-
- # Pick off the args
- my ($ftp, $dir, $recurse) = @_ ;
- my $ok;
-
- return $ok
- if $ok = $ftp->_RMD( $dir ) or !$recurse;
-
- # Try to delete the contents
- # Get a list of all the files in the directory
- my $filelist = $ftp->ls($dir);
-
- return undef
- unless $filelist && @$filelist; # failed, it is probably not a directory
-
- # Go thru and delete each file or the directory
- my $file;
- foreach $file (map { m,/, ? $_ : "$dir/$_" } @$filelist)
- {
- next # successfully deleted the file
- if $ftp->delete($file);
-
- # Failed to delete it, assume its a directory
- # Recurse and ignore errors, the final rmdir() will
- # fail on any errors here
- return $ok
- unless $ok = $ftp->rmdir($file, 1) ;
- }
-
- # Directory should be empty
- # Try to remove the directory again
- # Pass results directly to caller
- # If any of the prior deletes failed, this
- # rmdir() will fail because directory is not empty
- return $ftp->_RMD($dir) ;
-}
-
-sub restart
-{
- @_ == 2 || croak 'usage: $ftp->restart( BYTE_OFFSET )';
-
- my($ftp,$where) = @_;
-
- ${*$ftp}{'net_ftp_rest'} = $where;
-
- return undef;
-}
-
-
-sub mkdir
-{
- @_ == 2 || @_ == 3 or croak 'usage: $ftp->mkdir( DIR [, RECURSE ] )';
-
- my($ftp,$dir,$recurse) = @_;
-
- $ftp->_MKD($dir) || $recurse or
- return undef;
-
- my $path = $dir;
-
- unless($ftp->ok)
- {
- my @path = split(m#(?=/+)#, $dir);
-
- $path = "";
-
- while(@path)
- {
- $path .= shift @path;
-
- $ftp->_MKD($path);
-
- $path = $ftp->_extract_path($path);
- }
-
- # If the creation of the last element was not sucessful, see if we
- # can cd to it, if so then return path
-
- unless($ftp->ok)
- {
- my($status,$message) = ($ftp->status,$ftp->message);
- my $pwd = $ftp->pwd;
-
- if($pwd && $ftp->cwd($dir))
- {
- $path = $dir;
- $ftp->cwd($pwd);
- }
- else
- {
- undef $path;
- }
- $ftp->set_status($status,$message);
- }
- }
-
- $path;
-}
-
-sub delete
-{
- @_ == 2 || croak 'usage: $ftp->delete( FILENAME )';
-
- $_[0]->_DELE($_[1]);
-}
-
-sub put { shift->_store_cmd("stor",@_) }
-sub put_unique { shift->_store_cmd("stou",@_) }
-sub append { shift->_store_cmd("appe",@_) }
-
-sub nlst { shift->_data_cmd("NLST",@_) }
-sub list { shift->_data_cmd("LIST",@_) }
-sub retr { shift->_data_cmd("RETR",@_) }
-sub stor { shift->_data_cmd("STOR",@_) }
-sub stou { shift->_data_cmd("STOU",@_) }
-sub appe { shift->_data_cmd("APPE",@_) }
-
-sub _store_cmd
-{
- my($ftp,$cmd,$local,$remote) = @_;
- my($loc,$sock,$len,$buf,$localfd);
- local *FD;
-
- $localfd = ref($local) || ref(\$local) eq "GLOB"
- ? fileno($local)
- : undef;
-
- unless(defined $remote)
- {
- croak 'Must specify remote filename with stream input'
- if defined $localfd;
-
- require File::Basename;
- $remote = File::Basename::basename($local);
- }
-
- croak("Bad remote filename '$remote'\n")
- if $remote =~ /[\r\n]/s;
-
- if(defined $localfd)
- {
- $loc = $local;
- }
- else
- {
- $loc = \*FD;
-
- unless(sysopen($loc, $local, O_RDONLY))
- {
- carp "Cannot open Local file $local: $!\n";
- return undef;
- }
- }
-
- if($ftp->type eq 'I' && !binmode($loc))
- {
- carp "Cannot binmode Local file $local: $!\n";
- return undef;
- }
-
- delete ${*$ftp}{'net_ftp_port'};
- delete ${*$ftp}{'net_ftp_pasv'};
-
- $sock = $ftp->_data_cmd($cmd, $remote) or
- return undef;
-
- my $blksize = ${*$ftp}{'net_ftp_blksize'};
-
- my($count,$hashh,$hashb,$ref) = (0);
-
- ($hashh,$hashb) = @$ref
- if($ref = ${*$ftp}{'net_ftp_hash'});
-
- while(1)
- {
- last unless $len = sysread($loc,$buf="",$blksize);
-
- if (trEBCDIC)
- {
- $buf = $ftp->toascii($buf);
- $len = length($buf);
- }
-
- if($hashh) {
- $count += $len;
- print $hashh "#" x (int($count / $hashb));
- $count %= $hashb;
- }
-
- my $wlen;
- unless(defined($wlen = $sock->write($buf,$len)) && $wlen == $len)
- {
- $sock->abort;
- close($loc)
- unless defined $localfd;
- print $hashh "\n" if $hashh;
- return undef;
- }
- }
-
- print $hashh "\n" if $hashh;
-
- close($loc)
- unless defined $localfd;
-
- $sock->close() or
- return undef;
-
- if ('STOU' eq uc $cmd and $ftp->message =~ m/unique\ file\ name:(.*)\)|"(.*)"/)
- {
- require File::Basename;
- $remote = File::Basename::basename($+)
- }
-
- return $remote;
-}
-
-sub port
-{
- @_ == 1 || @_ == 2 or croak 'usage: $ftp->port([PORT])';
-
- my($ftp,$port) = @_;
- my $ok;
-
- delete ${*$ftp}{'net_ftp_intern_port'};
-
- unless(defined $port)
- {
- # create a Listen socket at same address as the command socket
-
- ${*$ftp}{'net_ftp_listen'} ||= IO::Socket::INET->new(Listen => 5,
- Proto => 'tcp',
- Timeout => $ftp->timeout,
- LocalAddr => $ftp->sockhost,
- );
-
- my $listen = ${*$ftp}{'net_ftp_listen'};
-
- my($myport, @myaddr) = ($listen->sockport, split(/\./,$listen->sockhost));
-
- $port = join(',', @myaddr, $myport >> 8, $myport & 0xff);
-
- ${*$ftp}{'net_ftp_intern_port'} = 1;
- }
-
- $ok = $ftp->_PORT($port);
-
- ${*$ftp}{'net_ftp_port'} = $port;
-
- $ok;
-}
-
-sub ls { shift->_list_cmd("NLST",@_); }
-sub dir { shift->_list_cmd("LIST",@_); }
-
-sub pasv
-{
- @_ == 1 or croak 'usage: $ftp->pasv()';
-
- my $ftp = shift;
-
- delete ${*$ftp}{'net_ftp_intern_port'};
-
- $ftp->_PASV && $ftp->message =~ /(\d+(,\d+)+)/
- ? ${*$ftp}{'net_ftp_pasv'} = $1
- : undef;
-}
-
-sub unique_name
-{
- my $ftp = shift;
- ${*$ftp}{'net_ftp_unique'} || undef;
-}
-
-sub supported {
- @_ == 2 or croak 'usage: $ftp->supported( CMD )';
- my $ftp = shift;
- my $cmd = uc shift;
- my $hash = ${*$ftp}{'net_ftp_supported'} ||= {};
-
- return $hash->{$cmd}
- if exists $hash->{$cmd};
-
- return $hash->{$cmd} = 0
- unless $ftp->_HELP($cmd);
-
- my $text = $ftp->message;
- if($text =~ /following\s+commands/i) {
- $text =~ s/^.*\n//;
- while($text =~ /(\*?)(\w+)(\*?)/sg) {
- $hash->{"\U$2"} = !length("$1$3");
- }
- }
- else {
- $hash->{$cmd} = $text !~ /unimplemented/i;
- }
-
- $hash->{$cmd} ||= 0;
-}
-
-##
-## Deprecated methods
-##
-
-sub lsl
-{
- carp "Use of Net::FTP::lsl deprecated, use 'dir'"
- if $^W;
- goto &dir;
-}
-
-sub authorise
-{
- carp "Use of Net::FTP::authorise deprecated, use 'authorize'"
- if $^W;
- goto &authorize;
-}
-
-
-##
-## Private methods
-##
-
-sub _extract_path
-{
- my($ftp, $path) = @_;
-
- # This tries to work both with and without the quote doubling
- # convention (RFC 959 requires it, but the first 3 servers I checked
- # didn't implement it). It will fail on a server which uses a quote in
- # the message which isn't a part of or surrounding the path.
- $ftp->ok &&
- $ftp->message =~ /(?:^|\s)\"(.*)\"(?:$|\s)/ &&
- ($path = $1) =~ s/\"\"/\"/g;
-
- $path;
-}
-
-##
-## Communication methods
-##
-
-sub _dataconn
-{
- my $ftp = shift;
- my $data = undef;
- my $pkg = "Net::FTP::" . $ftp->type;
-
- eval "require " . $pkg;
-
- $pkg =~ s/ /_/g;
-
- delete ${*$ftp}{'net_ftp_dataconn'};
-
- if(defined ${*$ftp}{'net_ftp_pasv'})
- {
- my @port = split(/,/,${*$ftp}{'net_ftp_pasv'});
-
- $data = $pkg->new(PeerAddr => join(".",@port[0..3]),
- PeerPort => $port[4] * 256 + $port[5],
- Proto => 'tcp'
- );
- }
- elsif(defined ${*$ftp}{'net_ftp_listen'})
- {
- $data = ${*$ftp}{'net_ftp_listen'}->accept($pkg);
- close(delete ${*$ftp}{'net_ftp_listen'});
- }
-
- if($data)
- {
- ${*$data} = "";
- $data->timeout($ftp->timeout);
- ${*$ftp}{'net_ftp_dataconn'} = $data;
- ${*$data}{'net_ftp_cmd'} = $ftp;
- ${*$data}{'net_ftp_blksize'} = ${*$ftp}{'net_ftp_blksize'};
- }
-
- $data;
-}
-
-sub _list_cmd
-{
- my $ftp = shift;
- my $cmd = uc shift;
-
- delete ${*$ftp}{'net_ftp_port'};
- delete ${*$ftp}{'net_ftp_pasv'};
-
- my $data = $ftp->_data_cmd($cmd,@_);
-
- return
- unless(defined $data);
-
- require Net::FTP::A;
- bless $data, "Net::FTP::A"; # Force ASCII mode
-
- my $databuf = '';
- my $buf = '';
- my $blksize = ${*$ftp}{'net_ftp_blksize'};
-
- while($data->read($databuf,$blksize)) {
- $buf .= $databuf;
- }
-
- my $list = [ split(/\n/,$buf) ];
-
- $data->close();
-
- if (trEBCDIC)
- {
- for (@$list) { $_ = $ftp->toebcdic($_) }
- }
-
- wantarray ? @{$list}
- : $list;
-}
-
-sub _data_cmd
-{
- my $ftp = shift;
- my $cmd = uc shift;
- my $ok = 1;
- my $where = delete ${*$ftp}{'net_ftp_rest'} || 0;
- my $arg;
-
- for $arg (@_) {
- croak("Bad argument '$arg'\n")
- if $arg =~ /[\r\n]/s;
- }
-
- if(${*$ftp}{'net_ftp_passive'} &&
- !defined ${*$ftp}{'net_ftp_pasv'} &&
- !defined ${*$ftp}{'net_ftp_port'})
- {
- my $data = undef;
-
- $ok = defined $ftp->pasv;
- $ok = $ftp->_REST($where)
- if $ok && $where;
-
- if($ok)
- {
- $ftp->command($cmd,@_);
- $data = $ftp->_dataconn();
- $ok = CMD_INFO == $ftp->response();
- if($ok)
- {
- $data->reading
- if $data && $cmd =~ /RETR|LIST|NLST/;
- return $data
- }
- $data->_close
- if $data;
- }
- return undef;
- }
-
- $ok = $ftp->port
- unless (defined ${*$ftp}{'net_ftp_port'} ||
- defined ${*$ftp}{'net_ftp_pasv'});
-
- $ok = $ftp->_REST($where)
- if $ok && $where;
-
- return undef
- unless $ok;
-
- $ftp->command($cmd,@_);
-
- return 1
- if(defined ${*$ftp}{'net_ftp_pasv'});
-
- $ok = CMD_INFO == $ftp->response();
-
- return $ok
- unless exists ${*$ftp}{'net_ftp_intern_port'};
-
- if($ok) {
- my $data = $ftp->_dataconn();
-
- $data->reading
- if $data && $cmd =~ /RETR|LIST|NLST/;
-
- return $data;
- }
-
-
- close(delete ${*$ftp}{'net_ftp_listen'});
-
- return undef;
-}
-
-##
-## Over-ride methods (Net::Cmd)
-##
-
-sub debug_text { $_[2] =~ /^(pass|resp|acct)/i ? "$1 ....\n" : $_[2]; }
-
-sub command
-{
- my $ftp = shift;
-
- delete ${*$ftp}{'net_ftp_port'};
- $ftp->SUPER::command(@_);
-}
-
-sub response
-{
- my $ftp = shift;
- my $code = $ftp->SUPER::response();
-
- delete ${*$ftp}{'net_ftp_pasv'}
- if ($code != CMD_MORE && $code != CMD_INFO);
-
- $code;
-}
-
-sub parse_response
-{
- return ($1, $2 eq "-")
- if $_[1] =~ s/^(\d\d\d)(.?)//o;
-
- my $ftp = shift;
-
- # Darn MS FTP server is a load of CRAP !!!!
- return ()
- unless ${*$ftp}{'net_cmd_code'} + 0;
-
- (${*$ftp}{'net_cmd_code'},1);
-}
-
-##
-## Allow 2 servers to talk directly
-##
-
-sub pasv_xfer {
- my($sftp,$sfile,$dftp,$dfile,$unique) = @_;
-
- ($dfile = $sfile) =~ s#.*/##
- unless(defined $dfile);
-
- my $port = $sftp->pasv or
- return undef;
-
- $dftp->port($port) or
- return undef;
-
- return undef
- unless($unique ? $dftp->stou($dfile) : $dftp->stor($dfile));
-
- unless($sftp->retr($sfile) && $sftp->response == CMD_INFO) {
- $sftp->retr($sfile);
- $dftp->abort;
- $dftp->response();
- return undef;
- }
-
- $dftp->pasv_wait($sftp);
-}
-
-sub pasv_wait
-{
- @_ == 2 or croak 'usage: $ftp->pasv_wait(NON_PASV_FTP)';
-
- my($ftp, $non_pasv) = @_;
- my($file,$rin,$rout);
-
- vec($rin='',fileno($ftp),1) = 1;
- select($rout=$rin, undef, undef, undef);
-
- $ftp->response();
- $non_pasv->response();
-
- return undef
- unless $ftp->ok() && $non_pasv->ok();
-
- return $1
- if $ftp->message =~ /unique file name:\s*(\S*)\s*\)/;
-
- return $1
- if $non_pasv->message =~ /unique file name:\s*(\S*)\s*\)/;
-
- return 1;
-}
-
-sub cmd { shift->command(@_)->response() }
-
-########################################
-#
-# RFC959 commands
-#
-
-sub _ABOR { shift->command("ABOR")->response() == CMD_OK }
-sub _CDUP { shift->command("CDUP")->response() == CMD_OK }
-sub _NOOP { shift->command("NOOP")->response() == CMD_OK }
-sub _PASV { shift->command("PASV")->response() == CMD_OK }
-sub _QUIT { shift->command("QUIT")->response() == CMD_OK }
-sub _DELE { shift->command("DELE",@_)->response() == CMD_OK }
-sub _CWD { shift->command("CWD", @_)->response() == CMD_OK }
-sub _PORT { shift->command("PORT",@_)->response() == CMD_OK }
-sub _RMD { shift->command("RMD", @_)->response() == CMD_OK }
-sub _MKD { shift->command("MKD", @_)->response() == CMD_OK }
-sub _PWD { shift->command("PWD", @_)->response() == CMD_OK }
-sub _TYPE { shift->command("TYPE",@_)->response() == CMD_OK }
-sub _RNTO { shift->command("RNTO",@_)->response() == CMD_OK }
-sub _RESP { shift->command("RESP",@_)->response() == CMD_OK }
-sub _MDTM { shift->command("MDTM",@_)->response() == CMD_OK }
-sub _SIZE { shift->command("SIZE",@_)->response() == CMD_OK }
-sub _HELP { shift->command("HELP",@_)->response() == CMD_OK }
-sub _STAT { shift->command("STAT",@_)->response() == CMD_OK }
-sub _APPE { shift->command("APPE",@_)->response() == CMD_INFO }
-sub _LIST { shift->command("LIST",@_)->response() == CMD_INFO }
-sub _NLST { shift->command("NLST",@_)->response() == CMD_INFO }
-sub _RETR { shift->command("RETR",@_)->response() == CMD_INFO }
-sub _STOR { shift->command("STOR",@_)->response() == CMD_INFO }
-sub _STOU { shift->command("STOU",@_)->response() == CMD_INFO }
-sub _RNFR { shift->command("RNFR",@_)->response() == CMD_MORE }
-sub _REST { shift->command("REST",@_)->response() == CMD_MORE }
-sub _USER { shift->command("user",@_)->response() } # A certain brain dead firewall :-)
-sub _PASS { shift->command("PASS",@_)->response() }
-sub _ACCT { shift->command("ACCT",@_)->response() }
-sub _AUTH { shift->command("AUTH",@_)->response() }
-
-sub _ALLO { shift->unsupported(@_) }
-sub _SMNT { shift->unsupported(@_) }
-sub _MODE { shift->unsupported(@_) }
-sub _SYST { shift->unsupported(@_) }
-sub _STRU { shift->unsupported(@_) }
-sub _REIN { shift->unsupported(@_) }
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::FTP - FTP Client class
-
-=head1 SYNOPSIS
-
- use Net::FTP;
-
- $ftp = Net::FTP->new("some.host.name", Debug => 0);
- $ftp->login("anonymous",'-anonymous@');
- $ftp->cwd("/pub");
- $ftp->get("that.file");
- $ftp->quit;
-
-=head1 DESCRIPTION
-
-C<Net::FTP> is a class implementing a simple FTP client in Perl as
-described in RFC959. It provides wrappers for a subset of the RFC959
-commands.
-
-=head1 OVERVIEW
-
-FTP stands for File Transfer Protocol. It is a way of transferring
-files between networked machines. The protocol defines a client
-(whose commands are provided by this module) and a server (not
-implemented in this module). Communication is always initiated by the
-client, and the server responds with a message and a status code (and
-sometimes with data).
-
-The FTP protocol allows files to be sent to or fetched from the
-server. Each transfer involves a B<local file> (on the client) and a
-B<remote file> (on the server). In this module, the same file name
-will be used for both local and remote if only one is specified. This
-means that transferring remote file C</path/to/file> will try to put
-that file in C</path/to/file> locally, unless you specify a local file
-name.
-
-The protocol also defines several standard B<translations> which the
-file can undergo during transfer. These are ASCII, EBCDIC, binary,
-and byte. ASCII is the default type, and indicates that the sender of
-files will translate the ends of lines to a standard representation
-which the receiver will then translate back into their local
-representation. EBCDIC indicates the file being transferred is in
-EBCDIC format. Binary (also known as image) format sends the data as
-a contiguous bit stream. Byte format transfers the data as bytes, the
-values of which remain the same regardless of differences in byte size
-between the two machines (in theory - in practice you should only use
-this if you really know what you're doing).
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new (HOST [,OPTIONS])
-
-This is the constructor for a new Net::FTP object. C<HOST> is the
-name of the remote host to which an FTP connection is required.
-
-C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
-Possible options are:
-
-B<Firewall> - The name of a machine which acts as an FTP firewall. This can be
-overridden by an environment variable C<FTP_FIREWALL>. If specified, and the
-given host cannot be directly connected to, then the
-connection is made to the firewall machine and the string C<@hostname> is
-appended to the login identifier. This kind of setup is also refered to
-as an ftp proxy.
-
-B<FirewallType> - The type of firewall running on the machine indicated by
-B<Firewall>. This can be overridden by an environment variable
-C<FTP_FIREWALL_TYPE>. For a list of permissible types, see the description of
-ftp_firewall_type in L<Net::Config>.
-
-B<BlockSize> - This is the block size that Net::FTP will use when doing
-transfers. (defaults to 10240)
-
-B<Port> - The port number to connect to on the remote machine for the
-FTP connection
-
-B<Timeout> - Set a timeout value (defaults to 120)
-
-B<Debug> - debug level (see the debug method in L<Net::Cmd>)
-
-B<Passive> - If set to a non-zero value then all data transfers will be done
-using passive mode. This is not usually required except for some I<dumb>
-servers, and some firewall configurations. This can also be set by the
-environment variable C<FTP_PASSIVE>.
-
-B<Hash> - If given a reference to a file handle (e.g., C<\*STDERR>),
-print hash marks (#) on that filehandle every 1024 bytes. This
-simply invokes the C<hash()> method for you, so that hash marks
-are displayed for all transfers. You can, of course, call C<hash()>
-explicitly whenever you'd like.
-
-If the constructor fails undef will be returned and an error message will
-be in $@
-
-=back
-
-=head1 METHODS
-
-Unless otherwise stated all methods return either a I<true> or I<false>
-value, with I<true> meaning that the operation was a success. When a method
-states that it returns a value, failure will be returned as I<undef> or an
-empty list.
-
-=over 4
-
-=item login ([LOGIN [,PASSWORD [, ACCOUNT] ] ])
-
-Log into the remote FTP server with the given login information. If
-no arguments are given then the C<Net::FTP> uses the C<Net::Netrc>
-package to lookup the login information for the connected host.
-If no information is found then a login of I<anonymous> is used.
-If no password is given and the login is I<anonymous> then the users
-Email address will be used for a password.
-
-If the connection is via a firewall then the C<authorize> method will
-be called with no arguments.
-
-=item authorize ( [AUTH [, RESP]])
-
-This is a protocol used by some firewall ftp proxies. It is used
-to authorise the user to send data out. If both arguments are not specified
-then C<authorize> uses C<Net::Netrc> to do a lookup.
-
-=item site (ARGS)
-
-Send a SITE command to the remote server and wait for a response.
-
-Returns most significant digit of the response code.
-
-=item type (TYPE [, ARGS])
-
-This method will send the TYPE command to the remote FTP server
-to change the type of data transfer. The return value is the previous
-value.
-
-=item ascii ([ARGS]) binary([ARGS]) ebcdic([ARGS]) byte([ARGS])
-
-Synonyms for C<type> with the first arguments set correctly
-
-B<NOTE> ebcdic and byte are not fully supported.
-
-=item rename ( OLDNAME, NEWNAME )
-
-Rename a file on the remote FTP server from C<OLDNAME> to C<NEWNAME>. This
-is done by sending the RNFR and RNTO commands.
-
-=item delete ( FILENAME )
-
-Send a request to the server to delete C<FILENAME>.
-
-=item cwd ( [ DIR ] )
-
-Attempt to change directory to the directory given in C<$dir>. If
-C<$dir> is C<"..">, the FTP C<CDUP> command is used to attempt to
-move up one directory. If no directory is given then an attempt is made
-to change the directory to the root directory.
-
-=item cdup ()
-
-Change directory to the parent of the current directory.
-
-=item pwd ()
-
-Returns the full pathname of the current directory.
-
-=item restart ( WHERE )
-
-Set the byte offset at which to begin the next data transfer. Net::FTP simply
-records this value and uses it when during the next data transfer. For this
-reason this method will not return an error, but setting it may cause
-a subsequent data transfer to fail.
-
-=item rmdir ( DIR )
-
-Remove the directory with the name C<DIR>.
-
-=item mkdir ( DIR [, RECURSE ])
-
-Create a new directory with the name C<DIR>. If C<RECURSE> is I<true> then
-C<mkdir> will attempt to create all the directories in the given path.
-
-Returns the full pathname to the new directory.
-
-=item ls ( [ DIR ] )
-
-Get a directory listing of C<DIR>, or the current directory.
-
-In an array context, returns a list of lines returned from the server. In
-a scalar context, returns a reference to a list.
-
-=item dir ( [ DIR ] )
-
-Get a directory listing of C<DIR>, or the current directory in long format.
-
-In an array context, returns a list of lines returned from the server. In
-a scalar context, returns a reference to a list.
-
-=item get ( REMOTE_FILE [, LOCAL_FILE [, WHERE]] )
-
-Get C<REMOTE_FILE> from the server and store locally. C<LOCAL_FILE> may be
-a filename or a filehandle. If not specified, the file will be stored in
-the current directory with the same leafname as the remote file.
-
-If C<WHERE> is given then the first C<WHERE> bytes of the file will
-not be transfered, and the remaining bytes will be appended to
-the local file if it already exists.
-
-Returns C<LOCAL_FILE>, or the generated local file name if C<LOCAL_FILE>
-is not given. If an error was encountered undef is returned.
-
-=item put ( LOCAL_FILE [, REMOTE_FILE ] )
-
-Put a file on the remote server. C<LOCAL_FILE> may be a name or a filehandle.
-If C<LOCAL_FILE> is a filehandle then C<REMOTE_FILE> must be specified. If
-C<REMOTE_FILE> is not specified then the file will be stored in the current
-directory with the same leafname as C<LOCAL_FILE>.
-
-Returns C<REMOTE_FILE>, or the generated remote filename if C<REMOTE_FILE>
-is not given.
-
-B<NOTE>: If for some reason the transfer does not complete and an error is
-returned then the contents that had been transfered will not be remove
-automatically.
-
-=item put_unique ( LOCAL_FILE [, REMOTE_FILE ] )
-
-Same as put but uses the C<STOU> command.
-
-Returns the name of the file on the server.
-
-=item append ( LOCAL_FILE [, REMOTE_FILE ] )
-
-Same as put but appends to the file on the remote server.
-
-Returns C<REMOTE_FILE>, or the generated remote filename if C<REMOTE_FILE>
-is not given.
-
-=item unique_name ()
-
-Returns the name of the last file stored on the server using the
-C<STOU> command.
-
-=item mdtm ( FILE )
-
-Returns the I<modification time> of the given file
-
-=item size ( FILE )
-
-Returns the size in bytes for the given file as stored on the remote server.
-
-B<NOTE>: The size reported is the size of the stored file on the remote server.
-If the file is subsequently transfered from the server in ASCII mode
-and the remote server and local machine have different ideas about
-"End Of Line" then the size of file on the local machine after transfer
-may be different.
-
-=item supported ( CMD )
-
-Returns TRUE if the remote server supports the given command.
-
-=item hash ( [FILEHANDLE_GLOB_REF],[ BYTES_PER_HASH_MARK] )
-
-Called without parameters, or with the first argument false, hash marks
-are suppressed. If the first argument is true but not a reference to a
-file handle glob, then \*STDERR is used. The second argument is the number
-of bytes per hash mark printed, and defaults to 1024. In all cases the
-return value is a reference to an array of two: the filehandle glob reference
-and the bytes per hash mark.
-
-=back
-
-The following methods can return different results depending on
-how they are called. If the user explicitly calls either
-of the C<pasv> or C<port> methods then these methods will
-return a I<true> or I<false> value. If the user does not
-call either of these methods then the result will be a
-reference to a C<Net::FTP::dataconn> based object.
-
-=over 4
-
-=item nlst ( [ DIR ] )
-
-Send an C<NLST> command to the server, with an optional parameter.
-
-=item list ( [ DIR ] )
-
-Same as C<nlst> but using the C<LIST> command
-
-=item retr ( FILE )
-
-Begin the retrieval of a file called C<FILE> from the remote server.
-
-=item stor ( FILE )
-
-Tell the server that you wish to store a file. C<FILE> is the
-name of the new file that should be created.
-
-=item stou ( FILE )
-
-Same as C<stor> but using the C<STOU> command. The name of the unique
-file which was created on the server will be available via the C<unique_name>
-method after the data connection has been closed.
-
-=item appe ( FILE )
-
-Tell the server that we want to append some data to the end of a file
-called C<FILE>. If this file does not exist then create it.
-
-=back
-
-If for some reason you want to have complete control over the data connection,
-this includes generating it and calling the C<response> method when required,
-then the user can use these methods to do so.
-
-However calling these methods only affects the use of the methods above that
-can return a data connection. They have no effect on methods C<get>, C<put>,
-C<put_unique> and those that do not require data connections.
-
-=over 4
-
-=item port ( [ PORT ] )
-
-Send a C<PORT> command to the server. If C<PORT> is specified then it is sent
-to the server. If not, then a listen socket is created and the correct information
-sent to the server.
-
-=item pasv ()
-
-Tell the server to go into passive mode. Returns the text that represents the
-port on which the server is listening, this text is in a suitable form to
-sent to another ftp server using the C<port> method.
-
-=back
-
-The following methods can be used to transfer files between two remote
-servers, providing that these two servers can connect directly to each other.
-
-=over 4
-
-=item pasv_xfer ( SRC_FILE, DEST_SERVER [, DEST_FILE ] )
-
-This method will do a file transfer between two remote ftp servers. If
-C<DEST_FILE> is omitted then the leaf name of C<SRC_FILE> will be used.
-
-=item pasv_xfer_unique ( SRC_FILE, DEST_SERVER [, DEST_FILE ] )
-
-Like C<pasv_xfer> but the file is stored on the remote server using
-the STOU command.
-
-=item pasv_wait ( NON_PASV_SERVER )
-
-This method can be used to wait for a transfer to complete between a passive
-server and a non-passive server. The method should be called on the passive
-server with the C<Net::FTP> object for the non-passive server passed as an
-argument.
-
-=item abort ()
-
-Abort the current data transfer.
-
-=item quit ()
-
-Send the QUIT command to the remote FTP server and close the socket connection.
-
-=back
-
-=head2 Methods for the adventurous
-
-C<Net::FTP> inherits from C<Net::Cmd> so methods defined in C<Net::Cmd> may
-be used to send commands to the remote FTP server.
-
-=over 4
-
-=item quot (CMD [,ARGS])
-
-Send a command, that Net::FTP does not directly support, to the remote
-server and wait for a response.
-
-Returns most significant digit of the response code.
-
-B<WARNING> This call should only be used on commands that do not require
-data connections. Misuse of this method can hang the connection.
-
-=back
-
-=head1 THE dataconn CLASS
-
-Some of the methods defined in C<Net::FTP> return an object which will
-be derived from this class.The dataconn class itself is derived from
-the C<IO::Socket::INET> class, so any normal IO operations can be performed.
-However the following methods are defined in the dataconn class and IO should
-be performed using these.
-
-=over 4
-
-=item read ( BUFFER, SIZE [, TIMEOUT ] )
-
-Read C<SIZE> bytes of data from the server and place it into C<BUFFER>, also
-performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not
-given, the timeout value from the command connection will be used.
-
-Returns the number of bytes read before any <CRLF> translation.
-
-=item write ( BUFFER, SIZE [, TIMEOUT ] )
-
-Write C<SIZE> bytes of data from C<BUFFER> to the server, also
-performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not
-given, the timeout value from the command connection will be used.
-
-Returns the number of bytes written before any <CRLF> translation.
-
-=item bytes_read ()
-
-Returns the number of bytes read so far.
-
-=item abort ()
-
-Abort the current data transfer.
-
-=item close ()
-
-Close the data connection and get a response from the FTP server. Returns
-I<true> if the connection was closed successfully and the first digit of
-the response from the server was a '2'.
-
-=back
-
-=head1 UNIMPLEMENTED
-
-The following RFC959 commands have not been implemented:
-
-=over 4
-
-=item B<ALLO>
-
-Allocates storage for the file to be transferred.
-
-=item B<SMNT>
-
-Mount a different file system structure without changing login or
-accounting information.
-
-=item B<HELP>
-
-Ask the server for "helpful information" (that's what the RFC says) on
-the commands it accepts.
-
-=item B<MODE>
-
-Specifies transfer mode (stream, block or compressed) for file to be
-transferred.
-
-=item B<SYST>
-
-Request remote server system identification.
-
-=item B<STAT>
-
-Request remote server status.
-
-=item B<STRU>
-
-Specifies file structure for file to be transferred.
-
-=item B<REIN>
-
-Reinitialize the connection, flushing all I/O and account information.
-
-=back
-
-=head1 REPORTING BUGS
-
-When reporting bugs/problems please include as much information as possible.
-It may be difficult for me to reproduce the problem as almost every setup
-is different.
-
-A small script which yields the problem will probably be of help. It would
-also be useful if this script was run with the extra options C<Debug => 1>
-passed to the constructor, and the output sent with the bug report. If you
-cannot include a small script then please include a Debug trace from a
-run of your program which does yield the problem.
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>
-
-=head1 SEE ALSO
-
-L<Net::Netrc>
-L<Net::Cmd>
-
-ftp(1), ftpd(8), RFC 959
-http://www.cis.ohio-state.edu/htbin/rfc/rfc959.html
-
-=head1 USE EXAMPLES
-
-For an example of the use of Net::FTP see
-
-=over 4
-
-=item http://www.csh.rit.edu/~adam/Progs/autoftp-2.0.tar.gz
-
-C<autoftp> is a program that can retrieve, send, or list files via
-the FTP protocol in a non-interactive manner.
-
-=back
-
-=head1 CREDITS
-
-Henry Gabryjelski <henryg@WPI.EDU> - for the suggestion of creating directories
-recursively.
-
-Nathan Torkington <gnat@frii.com> - for some input on the documentation.
-
-Roderick Schertler <roderick@gate.net> - for various inputs
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-1998 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify it
-under the same terms as Perl itself.
-
-=for html <hr>
-
-I<$Id: //depot/libnet/Net/FTP.pm#64 $>
-
-=cut
+++ /dev/null
-## $Id: //depot/libnet/Net/FTP/A.pm#16 $
-## Package to read/write on ASCII data connections
-##
-
-package Net::FTP::A;
-use strict;
-use vars qw(@ISA $buf $VERSION);
-use Carp;
-
-require Net::FTP::dataconn;
-
-@ISA = qw(Net::FTP::dataconn);
-$VERSION = "1.15";
-
-sub read {
- my $data = shift;
- local *buf = \$_[0]; shift;
- my $size = shift || croak 'read($buf,$size,[$offset])';
- my $timeout = @_ ? shift : $data->timeout;
-
- if (length(${*$data}) < $size && !${*$data}{'net_ftp_eof'}) {
- my $blksize = ${*$data}{'net_ftp_blksize'};
- $blksize = $size if $size > $blksize;
-
- my $l = 0;
- my $n;
-
- READ:
- {
- my $readbuf = defined(${*$data}{'net_ftp_cr'}) ? "\015" : '';
-
- $data->can_read($timeout) or
- croak "Timeout";
-
- if ($n = sysread($data, $readbuf, $blksize, length $readbuf)) {
- ${*$data}{'net_ftp_bytesread'} += $n;
- ${*$data}{'net_ftp_cr'} = substr($readbuf,-1) eq "\015"
- ? chop($readbuf)
- : undef;
- }
- else {
- return undef
- unless defined $n;
-
- ${*$data}{'net_ftp_eof'} = 1;
- }
-
- $readbuf =~ s/\015\012/\n/sgo;
- ${*$data} .= $readbuf;
-
- unless (length(${*$data})) {
-
- redo READ
- if($n > 0);
-
- $size = length(${*$data})
- if($n == 0);
- }
- }
- }
-
- $buf = substr(${*$data},0,$size);
- substr(${*$data},0,$size) = '';
-
- length $buf;
-}
-
-sub write {
- my $data = shift;
- local *buf = \$_[0]; shift;
- my $size = shift || croak 'write($buf,$size,[$timeout])';
- my $timeout = @_ ? shift : $data->timeout;
-
- (my $tmp = substr($buf,0,$size)) =~ s/\n/\015\012/sg;
-
- # If the remote server has closed the connection we will be signal'd
- # when we write. This can happen if the disk on the remote server fills up
-
- local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
-
- my $len = length($tmp);
- my $off = 0;
- my $wrote = 0;
-
- my $blksize = ${*$data}{'net_ftp_blksize'};
-
- while($len) {
- $data->can_write($timeout) or
- croak "Timeout";
-
- $off += $wrote;
- $wrote = syswrite($data, substr($tmp,$off), $len > $blksize ? $blksize : $len);
- return undef
- unless defined($wrote);
- $len -= $wrote;
- }
-
- $size;
-}
-
-1;
+++ /dev/null
-package Net::FTP::E;
-
-require Net::FTP::I;
-
-@ISA = qw(Net::FTP::I);
-$VERSION = "0.01";
-
-1;
+++ /dev/null
-## $Id: //depot/libnet/Net/FTP/I.pm#12 $
-## Package to read/write on BINARY data connections
-##
-
-package Net::FTP::I;
-
-use vars qw(@ISA $buf $VERSION);
-use Carp;
-
-require Net::FTP::dataconn;
-
-@ISA = qw(Net::FTP::dataconn);
-$VERSION = "1.11";
-
-sub read {
- my $data = shift;
- local *buf = \$_[0]; shift;
- my $size = shift || croak 'read($buf,$size,[$timeout])';
- my $timeout = @_ ? shift : $data->timeout;
-
- $data->can_read($timeout) or
- croak "Timeout";
-
- my($b,$n,$l);
- my $blksize = ${*$data}{'net_ftp_blksize'};
- $blksize = $size if $size > $blksize;
-
- while(($l = length(${*$data})) < $size) {
- $n += ($b = sysread($data, ${*$data}, $blksize, $l)) || 0;
- last unless $b;
- }
-
- $n = $size < ($l = length(${*$data})) ? $size : $l;
-
- $buf = substr(${*$data},0,$n);
- substr(${*$data},0,$n) = '';
-
- ${*$data}{'net_ftp_bytesread'} += $n if $n;
- ${*$data}{'net_ftp_eof'} = 1 unless $n;
-
- $n;
-}
-
-sub write {
- my $data = shift;
- local *buf = \$_[0]; shift;
- my $size = shift || croak 'write($buf,$size,[$timeout])';
- my $timeout = @_ ? shift : $data->timeout;
-
- # If the remote server has closed the connection we will be signal'd
- # when we write. This can happen if the disk on the remote server fills up
-
- local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
- my $sent = $size;
- my $off = 0;
-
- my $blksize = ${*$data}{'net_ftp_blksize'};
- while($sent > 0) {
- $data->can_write($timeout) or
- croak "Timeout";
-
- my $n = syswrite($data, $buf, $sent > $blksize ? $blksize : $sent ,$off);
- return undef unless defined($n);
- $sent -= $n;
- $off += $n;
- }
-
- $size;
-}
-
-1;
+++ /dev/null
-package Net::FTP::L;
-
-require Net::FTP::I;
-
-@ISA = qw(Net::FTP::I);
-$VERSION = "0.01";
-
-1;
+++ /dev/null
-##
-## Generic data connection package
-##
-
-package Net::FTP::dataconn;
-
-use Carp;
-use vars qw(@ISA $timeout $VERSION);
-use Net::Cmd;
-
-$VERSION = '0.10';
-@ISA = qw(IO::Socket::INET);
-
-sub reading
-{
- my $data = shift;
- ${*$data}{'net_ftp_bytesread'} = 0;
-}
-
-sub abort
-{
- my $data = shift;
- my $ftp = ${*$data}{'net_ftp_cmd'};
-
- # no need to abort if we have finished the xfer
- return $data->close
- if ${*$data}{'net_ftp_eof'};
-
- # for some reason if we continously open RETR connections and not
- # read a single byte, then abort them after a while the server will
- # close our connection, this prevents the unexpected EOF on the
- # command channel -- GMB
- if(exists ${*$data}{'net_ftp_bytesread'}
- && (${*$data}{'net_ftp_bytesread'} == 0)) {
- my $buf="";
- my $timeout = $data->timeout;
- $data->can_read($timeout) && sysread($data,$buf,1);
- }
-
- ${*$data}{'net_ftp_eof'} = 1; # fake
-
- $ftp->abort; # this will close me
-}
-
-sub _close
-{
- my $data = shift;
- my $ftp = ${*$data}{'net_ftp_cmd'};
-
- $data->SUPER::close();
-
- delete ${*$ftp}{'net_ftp_dataconn'}
- if exists ${*$ftp}{'net_ftp_dataconn'} &&
- $data == ${*$ftp}{'net_ftp_dataconn'};
-}
-
-sub close
-{
- my $data = shift;
- my $ftp = ${*$data}{'net_ftp_cmd'};
-
- if(exists ${*$data}{'net_ftp_bytesread'} && !${*$data}{'net_ftp_eof'}) {
- my $junk;
- $data->read($junk,1,0);
- return $data->abort unless ${*$data}{'net_ftp_eof'};
- }
-
- $data->_close;
-
- $ftp->response() == CMD_OK &&
- $ftp->message =~ /unique file name:\s*(\S*)\s*\)/ &&
- (${*$ftp}{'net_ftp_unique'} = $1);
-
- $ftp->status == CMD_OK;
-}
-
-sub _select
-{
- my $data = shift;
- local *timeout = \$_[0]; shift;
- my $rw = shift;
-
- my($rin,$win);
-
- return 1 unless $timeout;
-
- $rin = '';
- vec($rin,fileno($data),1) = 1;
-
- $win = $rw ? undef : $rin;
- $rin = undef unless $rw;
-
- my $nfound = select($rin, $win, undef, $timeout);
-
- croak "select: $!"
- if $nfound < 0;
-
- return $nfound;
-}
-
-sub can_read
-{
- my $data = shift;
- local *timeout = \$_[0];
-
- $data->_select($timeout,1);
-}
-
-sub can_write
-{
- my $data = shift;
- local *timeout = \$_[0];
-
- $data->_select($timeout,0);
-}
-
-sub cmd
-{
- my $ftp = shift;
-
- ${*$ftp}{'net_ftp_cmd'};
-}
-
-sub bytes_read {
- my $ftp = shift;
-
- ${*$ftp}{'net_ftp_bytesread'} || 0;
-}
-
-1;
+++ /dev/null
-package Net::HTTP::Methods;
-
-# $Id: Methods.pm,v 1.7 2001/12/05 16:58:05 gisle Exp $
-
-require 5.005; # 4-arg substr
-
-use strict;
-use vars qw($VERSION);
-
-$VERSION = "0.02";
-
-my $CRLF = "\015\012"; # "\r\n" is not portable
-
-sub new {
- my($class, %cnf) = @_;
- require Symbol;
- my $self = bless Symbol::gensym(), $class;
- return $self->http_configure(\%cnf);
-}
-
-sub http_configure {
- my($self, $cnf) = @_;
-
- die "Listen option not allowed" if $cnf->{Listen};
- my $host = delete $cnf->{Host};
- my $peer = $cnf->{PeerAddr} || $cnf->{PeerHost};
- if ($host) {
- $cnf->{PeerAddr} = $host unless $peer;
- }
- else {
- $host = $peer;
- $host =~ s/:.*//;
- }
- $cnf->{PeerPort} = $self->http_default_port unless $cnf->{PeerPort};
- $cnf->{Proto} = 'tcp';
-
- my $keep_alive = delete $cnf->{KeepAlive};
- my $http_version = delete $cnf->{HTTPVersion};
- $http_version = "1.1" unless defined $http_version;
- my $peer_http_version = delete $cnf->{PeerHTTPVersion};
- $peer_http_version = "1.0" unless defined $peer_http_version;
- my $send_te = delete $cnf->{SendTE};
- my $max_line_length = delete $cnf->{MaxLineLength};
- $max_line_length = 4*1024 unless defined $max_line_length;
- my $max_header_lines = delete $cnf->{MaxHeaderLines};
- $max_header_lines = 128 unless defined $max_header_lines;
-
- return undef unless $self->http_connect($cnf);
-
- unless ($host =~ /:/) {
- my $p = $self->peerport;
- $host .= ":$p";
- }
- $self->host($host);
- $self->keep_alive($keep_alive);
- $self->send_te($send_te);
- $self->http_version($http_version);
- $self->peer_http_version($peer_http_version);
- $self->max_line_length($max_line_length);
- $self->max_header_lines($max_header_lines);
-
- ${*$self}{'http_buf'} = "";
-
- return $self;
-}
-
-sub http_default_port {
- 80;
-}
-
-# set up property accessors
-for my $method (qw(host keep_alive send_te max_line_length max_header_lines peer_http_version)) {
- my $prop_name = "http_" . $method;
- no strict 'refs';
- *$method = sub {
- my $self = shift;
- my $old = ${*$self}{$prop_name};
- ${*$self}{$prop_name} = shift if @_;
- return $old;
- };
-}
-
-# we want this one to be a bit smarter
-sub http_version {
- my $self = shift;
- my $old = ${*$self}{'http_version'};
- if (@_) {
- my $v = shift;
- $v = "1.0" if $v eq "1"; # float
- unless ($v eq "1.0" or $v eq "1.1") {
- require Carp;
- Carp::croak("Unsupported HTTP version '$v'");
- }
- ${*$self}{'http_version'} = $v;
- }
- $old;
-}
-
-sub format_request {
- my $self = shift;
- my $method = shift;
- my $uri = shift;
-
- my $content = (@_ % 2) ? pop : "";
-
- for ($method, $uri) {
- require Carp;
- Carp::croak("Bad method or uri") if /\s/ || !length;
- }
-
- push(@{${*$self}{'http_request_method'}}, $method);
- my $ver = ${*$self}{'http_version'};
- my $peer_ver = ${*$self}{'http_peer_http_version'} || "1.0";
-
- my @h;
- my @connection;
- my %given = (host => 0, "content-length" => 0, "te" => 0);
- while (@_) {
- my($k, $v) = splice(@_, 0, 2);
- my $lc_k = lc($k);
- if ($lc_k eq "connection") {
- push(@connection, split(/\s*,\s*/, $v));
- next;
- }
- if (exists $given{$lc_k}) {
- $given{$lc_k}++;
- }
- push(@h, "$k: $v");
- }
-
- if (length($content) && !$given{'content-length'}) {
- push(@h, "Content-Length: " . length($content));
- }
-
- my @h2;
- if ($given{te}) {
- push(@connection, "TE") unless grep lc($_) eq "te", @connection;
- }
- elsif ($self->send_te && zlib_ok()) {
- # gzip is less wanted since the Compress::Zlib interface for
- # it does not really allow chunked decoding to take place easily.
- push(@h2, "TE: deflate,gzip;q=0.3");
- push(@connection, "TE");
- }
-
- unless (grep lc($_) eq "close", @connection) {
- if ($self->keep_alive) {
- if ($peer_ver eq "1.0") {
- # from looking at Netscape's headers
- push(@h2, "Keep-Alive: 300");
- unshift(@connection, "Keep-Alive");
- }
- }
- else {
- push(@connection, "close") if $ver ge "1.1";
- }
- }
- push(@h2, "Connection: " . join(", ", @connection)) if @connection;
- push(@h2, "Host: ${*$self}{'http_host'}") unless $given{host};
-
- return join($CRLF, "$method $uri HTTP/$ver", @h2, @h, "", $content);
-}
-
-
-sub write_request {
- my $self = shift;
- $self->print($self->format_request(@_));
-}
-
-sub format_chunk {
- my $self = shift;
- return $_[0] unless defined($_[0]) && length($_[0]);
- return hex(length($_[0])) . $CRLF . $_[0] . $CRLF;
-}
-
-sub write_chunk {
- my $self = shift;
- return 1 unless defined($_[0]) && length($_[0]);
- $self->print(hex(length($_[0])) . $CRLF . $_[0] . $CRLF);
-}
-
-sub format_chunk_eof {
- my $self = shift;
- my @h;
- while (@_) {
- push(@h, sprintf "%s: %s$CRLF", splice(@_, 0, 2));
- }
- return join("", "0$CRLF", @h, $CRLF);
-}
-
-sub write_chunk_eof {
- my $self = shift;
- $self->print($self->format_chunk_eof(@_));
-}
-
-
-sub my_read {
- die if @_ > 3;
- my $self = shift;
- my $len = $_[1];
- for (${*$self}{'http_buf'}) {
- if (length) {
- $_[0] = substr($_, 0, $len, "");
- return length($_[0]);
- }
- else {
- return $self->sysread($_[0], $len);
- }
- }
-}
-
-
-sub my_readline {
- my $self = shift;
- for (${*$self}{'http_buf'}) {
- my $max_line_length = ${*$self}{'http_max_line_length'};
- my $pos;
- while (1) {
- # find line ending
- $pos = index($_, "\012");
- last if $pos >= 0;
- die "Line too long (limit is $max_line_length)"
- if $max_line_length && length($_) > $max_line_length;
-
- # need to read more data to find a line ending
- my $n = $self->sysread($_, 1024, length);
- if (!$n) {
- return undef unless length;
- return substr($_, 0, length, "");
- }
- }
- die "Line too long ($pos; limit is $max_line_length)"
- if $max_line_length && $pos > $max_line_length;
-
- my $line = substr($_, 0, $pos+1, "");
- $line =~ s/(\015?\012)\z// || die "Assert";
- return wantarray ? ($line, $1) : $line;
- }
-}
-
-
-sub _rbuf {
- my $self = shift;
- if (@_) {
- for (${*$self}{'http_buf'}) {
- my $old;
- $old = $_ if defined wantarray;
- $_ = shift;
- return $old;
- }
- }
- else {
- return ${*$self}{'http_buf'};
- }
-}
-
-sub _rbuf_length {
- my $self = shift;
- return length ${*$self}{'http_buf'};
-}
-
-
-sub _read_header_lines {
- my $self = shift;
- my $junk_out = shift;
-
- my @headers;
- my $line_count = 0;
- my $max_header_lines = ${*$self}{'http_max_header_lines'};
- while (my $line = my_readline($self)) {
- if ($line =~ /^(\S+)\s*:\s*(.*)/s) {
- push(@headers, $1, $2);
- }
- elsif (@headers && $line =~ s/^\s+//) {
- $headers[-1] .= " " . $line;
- }
- elsif ($junk_out) {
- push(@$junk_out, $line);
- }
- else {
- die "Bad header: '$line'\n";
- }
- if ($max_header_lines) {
- $line_count++;
- if ($line_count >= $max_header_lines) {
- die "Too many header lines (limit is $max_header_lines)";
- }
- }
- }
- return @headers;
-}
-
-
-sub read_response_headers {
- my($self, %opt) = @_;
- my $laxed = $opt{laxed};
-
- my($status, $eol) = my_readline($self);
- die "EOF instead of reponse status line" unless defined $status;
-
- my($peer_ver, $code, $message) = split(/\s+/, $status, 3);
- if (!$peer_ver || $peer_ver !~ s,^HTTP/,,) {
- die "Bad response status line: '$status'" unless $laxed;
- # assume HTTP/0.9
- ${*$self}{'http_peer_http_version'} = "0.9";
- ${*$self}{'http_status'} = "200";
- substr(${*$self}{'http_buf'}, 0, 0) = $status . $eol;
- return (200, "Assumed OK");
- };
-
- ${*$self}{'http_peer_http_version'} = $peer_ver;
-
- unless ($code =~ /^[1-9]\d\d$/) {
- die "Bad response code: '$status'";
- }
- ${*$self}{'http_status'} = $code;
-
- my $junk_out;
- if ($laxed) {
- $junk_out = $opt{junk_out} || [];
- }
- my @headers = $self->_read_header_lines($junk_out);
-
- # pick out headers that read_entity_body might need
- my @te;
- my $content_length;
- for (my $i = 0; $i < @headers; $i += 2) {
- my $h = lc($headers[$i]);
- if ($h eq 'transfer-encoding') {
- push(@te, $headers[$i+1]);
- }
- elsif ($h eq 'content-length') {
- $content_length = $headers[$i+1];
- }
- }
- ${*$self}{'http_te'} = join(",", @te);
- ${*$self}{'http_content_length'} = $content_length;
- ${*$self}{'http_first_body'}++;
- delete ${*$self}{'http_trailers'};
- return $code unless wantarray;
- return ($code, $message, @headers);
-}
-
-
-sub read_entity_body {
- my $self = shift;
- my $buf_ref = \$_[0];
- my $size = $_[1];
- die "Offset not supported yet" if $_[2];
-
- my $chunked;
- my $bytes;
-
- if (${*$self}{'http_first_body'}) {
- ${*$self}{'http_first_body'} = 0;
- delete ${*$self}{'http_chunked'};
- delete ${*$self}{'http_bytes'};
- my $method = shift(@{${*$self}{'http_request_method'}});
- my $status = ${*$self}{'http_status'};
- if ($method eq "HEAD" || $status =~ /^(?:1|[23]04)/) {
- # these responses are always empty
- $bytes = 0;
- }
- elsif (my $te = ${*$self}{'http_te'}) {
- my @te = split(/\s*,\s*/, lc($te));
- die "Chunked must be last Transfer-Encoding '$te'"
- unless pop(@te) eq "chunked";
-
- for (@te) {
- if ($_ eq "deflate" && zlib_ok()) {
- #require Compress::Zlib;
- my $i = Compress::Zlib::inflateInit();
- die "Can't make inflator" unless $i;
- $_ = sub { scalar($i->inflate($_[0])) }
- }
- elsif ($_ eq "gzip" && zlib_ok()) {
- #require Compress::Zlib;
- my @buf;
- $_ = sub {
- push(@buf, $_[0]);
- return Compress::Zlib::memGunzip(join("", @buf)) if $_[1];
- return "";
- };
- }
- elsif ($_ eq "identity") {
- $_ = sub { $_[0] };
- }
- else {
- die "Can't handle transfer encoding '$te'";
- }
- }
-
- @te = reverse(@te);
-
- ${*$self}{'http_te2'} = @te ? \@te : "";
- $chunked = -1;
- }
- elsif (defined(my $content_length = ${*$self}{'http_content_length'})) {
- $bytes = $content_length;
- }
- else {
- # XXX Multi-Part types are self delimiting, but RFC 2616 says we
- # only has to deal with 'multipart/byteranges'
-
- # Read until EOF
- }
- }
- else {
- $chunked = ${*$self}{'http_chunked'};
- $bytes = ${*$self}{'http_bytes'};
- }
-
- if (defined $chunked) {
- # The state encoded in $chunked is:
- # $chunked == 0: read CRLF after chunk, then chunk header
- # $chunked == -1: read chunk header
- # $chunked > 0: bytes left in current chunk to read
-
- if ($chunked <= 0) {
- my $line = my_readline($self);
- if ($chunked == 0) {
- die "Not empty: '$line'" unless $line eq "";
- $line = my_readline($self);
- }
- $line =~ s/;.*//; # ignore potential chunk parameters
- $line =~ s/\s+$//; # avoid warnings from hex()
- $chunked = hex($line);
- if ($chunked == 0) {
- ${*$self}{'http_trailers'} = [$self->_read_header_lines];
- $$buf_ref = "";
-
- my $n = 0;
- if (my $transforms = delete ${*$self}{'http_te2'}) {
- for (@$transforms) {
- $$buf_ref = &$_($$buf_ref, 1);
- }
- $n = length($$buf_ref);
- }
-
- # in case somebody tries to read more, make sure we continue
- # to return EOF
- delete ${*$self}{'http_chunked'};
- ${*$self}{'http_bytes'} = 0;
-
- return $n;
- }
- }
-
- my $n = $chunked;
- $n = $size if $size && $size < $n;
- $n = my_read($self, $$buf_ref, $n);
- return undef unless defined $n;
-
- ${*$self}{'http_chunked'} = $chunked - $n;
-
- if ($n > 0) {
- if (my $transforms = ${*$self}{'http_te2'}) {
- for (@$transforms) {
- $$buf_ref = &$_($$buf_ref, 0);
- }
- $n = length($$buf_ref);
- $n = -1 if $n == 0;
- }
- }
- return $n;
- }
- elsif (defined $bytes) {
- unless ($bytes) {
- $$buf_ref = "";
- return 0;
- }
- my $n = $bytes;
- $n = $size if $size && $size < $n;
- $n = my_read($self, $$buf_ref, $n);
- return undef unless defined $n;
- ${*$self}{'http_bytes'} = $bytes - $n;
- return $n;
- }
- else {
- # read until eof
- $size ||= 8*1024;
- return my_read($self, $$buf_ref, $size);
- }
-}
-
-sub get_trailers {
- my $self = shift;
- @{${*$self}{'http_trailers'} || []};
-}
-
-BEGIN {
-my $zlib_ok;
-
-sub zlib_ok {
- return $zlib_ok if defined $zlib_ok;
-
- # Try to load Compress::Zlib.
- local $@;
- local $SIG{__DIE__};
- $zlib_ok = 0;
-
- eval {
- require Compress::Zlib;
- Compress::Zlib->VERSION(1.10);
- $zlib_ok++;
- };
-
- return $zlib_ok;
-}
-
-} # BEGIN
-
-1;
+++ /dev/null
-package Net::HTTP::NB;
-
-# $Id: NB.pm,v 1.5 2001/08/28 03:03:42 gisle Exp $
-
-use strict;
-use vars qw($VERSION @ISA);
-
-$VERSION = "0.02";
-require Net::HTTP;
-@ISA=qw(Net::HTTP);
-
-sub sysread {
- my $self = $_[0];
- if (${*$self}{'httpnb_read_count'}++) {
- ${*$self}{'http_buf'} = ${*$self}{'httpnb_save'};
- die "Multi-read\n";
- }
- my $buf;
- my $offset = $_[3] || 0;
- my $n = sysread($self, $_[1], $_[2], $offset);
- ${*$self}{'httpnb_save'} .= substr($_[1], $offset);
- return $n;
-}
-
-sub read_response_headers {
- my $self = shift;
- ${*$self}{'httpnb_read_count'} = 0;
- ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'};
- my @h = eval { $self->SUPER::read_response_headers(@_) };
- if ($@) {
- return if $@ eq "Multi-read\n";
- die;
- }
- return @h;
-}
-
-sub read_entity_body {
- my $self = shift;
- ${*$self}{'httpnb_read_count'} = 0;
- ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'};
- # XXX I'm not so sure this does the correct thing in case of
- # transfer-encoding tranforms
- my $n = eval { $self->SUPER::read_entity_body(@_); };
- if ($@) {
- $_[0] = "";
- return -1;
- }
- return $n;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::HTTP::NB - Non-blocking HTTP client
-
-=head1 SYNOPSIS
-
- use Net::HTTP::NB;
- my $s = Net::HTTP::NB->new(Host => "www.perl.com) || die $@;
- $s->write_request(GET => "/");
-
- use IO::Select;
- my $sel = IO::Select->new($s);
-
- READ_HEADER: {
- die "Header timeout" unless $sel->can_read(10);
- my($code, $mess, %h) = $s->read_response_headers;
- redo READ_HEADER unless $code;
- }
-
- while (1) {
- die "Body timeout" unless $sel->can_read(10);
- my $buf;
- my $n = $s->read_entity_body($buf, 1024);
- last unless $n;
- print $buf;
- }
-
-=head1 DESCRIPTION
-
-Same interface as C<Net::HTTP> but it will never try multiple reads
-when the read_response_headers() or read_entity_body() methods are
-invoked. This make it possible to multiplex multiple Net::HTTP::NB
-using select without risk blocking.
-
-If read_response_headers() did not see enough data to complete the
-headers an empty list is returned.
-
-If read_entity_body() did not see new entity data in its read
-the value -1 is returned.
-
-=head1 SEE ALSO
-
-L<Net::HTTP>
-
-=head1 COPYRIGHT
-
-Copyright 2001 Gisle Aas.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=cut
+++ /dev/null
-# Net::NNTP.pm
-#
-# Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::NNTP;
-
-use strict;
-use vars qw(@ISA $VERSION $debug);
-use IO::Socket;
-use Net::Cmd;
-use Carp;
-use Time::Local;
-use Net::Config;
-
-$VERSION = "2.20"; # $Id: //depot/libnet/Net/NNTP.pm#14 $
-@ISA = qw(Net::Cmd IO::Socket::INET);
-
-sub new
-{
- my $self = shift;
- my $type = ref($self) || $self;
- my $host = shift if @_ % 2;
- my %arg = @_;
- my $obj;
-
- $host ||= $ENV{NNTPSERVER} || $ENV{NEWSHOST};
-
- my $hosts = defined $host ? [ $host ] : $NetConfig{nntp_hosts};
-
- @{$hosts} = qw(news)
- unless @{$hosts};
-
- my $h;
- foreach $h (@{$hosts})
- {
- $obj = $type->SUPER::new(PeerAddr => ($host = $h),
- PeerPort => $arg{Port} || 'nntp(119)',
- Proto => 'tcp',
- Timeout => defined $arg{Timeout}
- ? $arg{Timeout}
- : 120
- ) and last;
- }
-
- return undef
- unless defined $obj;
-
- ${*$obj}{'net_nntp_host'} = $host;
-
- $obj->autoflush(1);
- $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
-
- unless ($obj->response() == CMD_OK)
- {
- $obj->close;
- return undef;
- }
-
- my $c = $obj->code;
- my @m = $obj->message;
-
- unless(exists $arg{Reader} && $arg{Reader} == 0) {
- # if server is INN and we have transfer rights the we are currently
- # talking to innd not nnrpd
- if($obj->reader)
- {
- # If reader suceeds the we need to consider this code to determine postok
- $c = $obj->code;
- }
- else
- {
- # I want to ignore this failure, so restore the previous status.
- $obj->set_status($c,\@m);
- }
- }
-
- ${*$obj}{'net_nntp_post'} = $c == 200 ? 1 : 0;
-
- $obj;
-}
-
-sub debug_text
-{
- my $nntp = shift;
- my $inout = shift;
- my $text = shift;
-
- if(($nntp->code == 350 && $text =~ /^(\S+)/)
- || ($text =~ /^(authinfo\s+pass)/io))
- {
- $text = "$1 ....\n"
- }
-
- $text;
-}
-
-sub postok
-{
- @_ == 1 or croak 'usage: $nntp->postok()';
- my $nntp = shift;
- ${*$nntp}{'net_nntp_post'} || 0;
-}
-
-sub article
-{
- @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->article( [ MSGID ], [ FH ] )';
- my $nntp = shift;
- my @fh;
-
- @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');
-
- $nntp->_ARTICLE(@_)
- ? $nntp->read_until_dot(@fh)
- : undef;
-}
-
-sub authinfo
-{
- @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )';
- my($nntp,$user,$pass) = @_;
-
- $nntp->_AUTHINFO("USER",$user) == CMD_MORE
- && $nntp->_AUTHINFO("PASS",$pass) == CMD_OK;
-}
-
-sub authinfo_simple
-{
- @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )';
- my($nntp,$user,$pass) = @_;
-
- $nntp->_AUTHINFO('SIMPLE') == CMD_MORE
- && $nntp->command($user,$pass)->response == CMD_OK;
-}
-
-sub body
-{
- @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->body( [ MSGID ], [ FH ] )';
- my $nntp = shift;
- my @fh;
-
- @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');
-
- $nntp->_BODY(@_)
- ? $nntp->read_until_dot(@fh)
- : undef;
-}
-
-sub head
-{
- @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->head( [ MSGID ], [ FH ] )';
- my $nntp = shift;
- my @fh;
-
- @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');
-
- $nntp->_HEAD(@_)
- ? $nntp->read_until_dot(@fh)
- : undef;
-}
-
-sub nntpstat
-{
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->nntpstat( [ MSGID ] )';
- my $nntp = shift;
-
- $nntp->_STAT(@_) && $nntp->message =~ /(<[^>]+>)/o
- ? $1
- : undef;
-}
-
-
-sub group
-{
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->group( [ GROUP ] )';
- my $nntp = shift;
- my $grp = ${*$nntp}{'net_nntp_group'} || undef;
-
- return $grp
- unless(@_ || wantarray);
-
- my $newgrp = shift;
-
- return wantarray ? () : undef
- unless $nntp->_GROUP($newgrp || $grp || "")
- && $nntp->message =~ /(\d+)\s+(\d+)\s+(\d+)\s+(\S+)/;
-
- my($count,$first,$last,$group) = ($1,$2,$3,$4);
-
- # group may be replied as '(current group)'
- $group = ${*$nntp}{'net_nntp_group'}
- if $group =~ /\(/;
-
- ${*$nntp}{'net_nntp_group'} = $group;
-
- wantarray
- ? ($count,$first,$last,$group)
- : $group;
-}
-
-sub help
-{
- @_ == 1 or croak 'usage: $nntp->help()';
- my $nntp = shift;
-
- $nntp->_HELP
- ? $nntp->read_until_dot
- : undef;
-}
-
-sub ihave
-{
- @_ >= 2 or croak 'usage: $nntp->ihave( MESSAGE-ID [, MESSAGE ])';
- my $nntp = shift;
- my $mid = shift;
-
- $nntp->_IHAVE($mid) && $nntp->datasend(@_)
- ? @_ == 0 || $nntp->dataend
- : undef;
-}
-
-sub last
-{
- @_ == 1 or croak 'usage: $nntp->last()';
- my $nntp = shift;
-
- $nntp->_LAST && $nntp->message =~ /(<[^>]+>)/o
- ? $1
- : undef;
-}
-
-sub list
-{
- @_ == 1 or croak 'usage: $nntp->list()';
- my $nntp = shift;
-
- $nntp->_LIST
- ? $nntp->_grouplist
- : undef;
-}
-
-sub newgroups
-{
- @_ >= 2 or croak 'usage: $nntp->newgroups( SINCE [, DISTRIBUTIONS ])';
- my $nntp = shift;
- my $time = _timestr(shift);
- my $dist = shift || "";
-
- $dist = join(",", @{$dist})
- if ref($dist);
-
- $nntp->_NEWGROUPS($time,$dist)
- ? $nntp->_grouplist
- : undef;
-}
-
-sub newnews
-{
- @_ >= 2 && @_ <= 4 or
- croak 'usage: $nntp->newnews( SINCE [, GROUPS [, DISTRIBUTIONS ]])';
- my $nntp = shift;
- my $time = _timestr(shift);
- my $grp = @_ ? shift : $nntp->group;
- my $dist = shift || "";
-
- $grp ||= "*";
- $grp = join(",", @{$grp})
- if ref($grp);
-
- $dist = join(",", @{$dist})
- if ref($dist);
-
- $nntp->_NEWNEWS($grp,$time,$dist)
- ? $nntp->_articlelist
- : undef;
-}
-
-sub next
-{
- @_ == 1 or croak 'usage: $nntp->next()';
- my $nntp = shift;
-
- $nntp->_NEXT && $nntp->message =~ /(<[^>]+>)/o
- ? $1
- : undef;
-}
-
-sub post
-{
- @_ >= 1 or croak 'usage: $nntp->post( [ MESSAGE ] )';
- my $nntp = shift;
-
- $nntp->_POST() && $nntp->datasend(@_)
- ? @_ == 0 || $nntp->dataend
- : undef;
-}
-
-sub quit
-{
- @_ == 1 or croak 'usage: $nntp->quit()';
- my $nntp = shift;
-
- $nntp->_QUIT;
- $nntp->close;
-}
-
-sub slave
-{
- @_ == 1 or croak 'usage: $nntp->slave()';
- my $nntp = shift;
-
- $nntp->_SLAVE;
-}
-
-##
-## The following methods are not implemented by all servers
-##
-
-sub active
-{
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->active( [ PATTERN ] )';
- my $nntp = shift;
-
- $nntp->_LIST('ACTIVE',@_)
- ? $nntp->_grouplist
- : undef;
-}
-
-sub active_times
-{
- @_ == 1 or croak 'usage: $nntp->active_times()';
- my $nntp = shift;
-
- $nntp->_LIST('ACTIVE.TIMES')
- ? $nntp->_grouplist
- : undef;
-}
-
-sub distributions
-{
- @_ == 1 or croak 'usage: $nntp->distributions()';
- my $nntp = shift;
-
- $nntp->_LIST('DISTRIBUTIONS')
- ? $nntp->_description
- : undef;
-}
-
-sub distribution_patterns
-{
- @_ == 1 or croak 'usage: $nntp->distributions()';
- my $nntp = shift;
-
- my $arr;
- local $_;
-
- $nntp->_LIST('DISTRIB.PATS') && ($arr = $nntp->read_until_dot)
- ? [grep { /^\d/ && (chomp, $_ = [ split /:/ ]) } @$arr]
- : undef;
-}
-
-sub newsgroups
-{
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->newsgroups( [ PATTERN ] )';
- my $nntp = shift;
-
- $nntp->_LIST('NEWSGROUPS',@_)
- ? $nntp->_description
- : undef;
-}
-
-sub overview_fmt
-{
- @_ == 1 or croak 'usage: $nntp->overview_fmt()';
- my $nntp = shift;
-
- $nntp->_LIST('OVERVIEW.FMT')
- ? $nntp->_articlelist
- : undef;
-}
-
-sub subscriptions
-{
- @_ == 1 or croak 'usage: $nntp->subscriptions()';
- my $nntp = shift;
-
- $nntp->_LIST('SUBSCRIPTIONS')
- ? $nntp->_articlelist
- : undef;
-}
-
-sub listgroup
-{
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->listgroup( [ GROUP ] )';
- my $nntp = shift;
-
- $nntp->_LISTGROUP(@_)
- ? $nntp->_articlelist
- : undef;
-}
-
-sub reader
-{
- @_ == 1 or croak 'usage: $nntp->reader()';
- my $nntp = shift;
-
- $nntp->_MODE('READER');
-}
-
-sub xgtitle
-{
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->xgtitle( [ PATTERN ] )';
- my $nntp = shift;
-
- $nntp->_XGTITLE(@_)
- ? $nntp->_description
- : undef;
-}
-
-sub xhdr
-{
- @_ >= 2 && @_ <= 4 or croak 'usage: $nntp->xhdr( HEADER, [ MESSAGE-SPEC ] )';
- my $nntp = shift;
- my $hdr = shift;
- my $arg = _msg_arg(@_);
-
- $nntp->_XHDR($hdr, $arg)
- ? $nntp->_description
- : undef;
-}
-
-sub xover
-{
- @_ == 2 || @_ == 3 or croak 'usage: $nntp->xover( MESSAGE-SPEC )';
- my $nntp = shift;
- my $arg = _msg_arg(@_);
-
- $nntp->_XOVER($arg)
- ? $nntp->_fieldlist
- : undef;
-}
-
-sub xpat
-{
- @_ == 4 || @_ == 5 or croak '$nntp->xpat( HEADER, PATTERN, MESSAGE-SPEC )';
- my $nntp = shift;
- my $hdr = shift;
- my $pat = shift;
- my $arg = _msg_arg(@_);
-
- $pat = join(" ", @$pat)
- if ref($pat);
-
- $nntp->_XPAT($hdr,$arg,$pat)
- ? $nntp->_description
- : undef;
-}
-
-sub xpath
-{
- @_ == 2 or croak 'usage: $nntp->xpath( MESSAGE-ID )';
- my($nntp,$mid) = @_;
-
- return undef
- unless $nntp->_XPATH($mid);
-
- my $m; ($m = $nntp->message) =~ s/^\d+\s+//o;
- my @p = split /\s+/, $m;
-
- wantarray ? @p : $p[0];
-}
-
-sub xrover
-{
- @_ == 2 || @_ == 3 or croak 'usage: $nntp->xrover( MESSAGE-SPEC )';
- my $nntp = shift;
- my $arg = _msg_arg(@_);
-
- $nntp->_XROVER($arg)
- ? $nntp->_description
- : undef;
-}
-
-sub date
-{
- @_ == 1 or croak 'usage: $nntp->date()';
- my $nntp = shift;
-
- $nntp->_DATE && $nntp->message =~ /(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/
- ? timegm($6,$5,$4,$3,$2-1,$1 - 1900)
- : undef;
-}
-
-
-##
-## Private subroutines
-##
-
-sub _msg_arg
-{
- my $spec = shift;
- my $arg = "";
-
- if(@_)
- {
- carp "Depriciated passing of two message numbers, "
- . "pass a reference"
- if $^W;
- $spec = [ $spec, $_[0] ];
- }
-
- if(defined $spec)
- {
- if(ref($spec))
- {
- $arg = $spec->[0];
- if(defined $spec->[1])
- {
- $arg .= "-"
- if $spec->[1] != $spec->[0];
- $arg .= $spec->[1]
- if $spec->[1] > $spec->[0];
- }
- }
- else
- {
- $arg = $spec;
- }
- }
-
- $arg;
-}
-
-sub _timestr
-{
- my $time = shift;
- my @g = reverse((gmtime($time))[0..5]);
- $g[1] += 1;
- $g[0] %= 100;
- sprintf "%02d%02d%02d %02d%02d%02d GMT", @g;
-}
-
-sub _grouplist
-{
- my $nntp = shift;
- my $arr = $nntp->read_until_dot or
- return undef;
-
- my $hash = {};
- my $ln;
-
- foreach $ln (@$arr)
- {
- my @a = split(/[\s\n]+/,$ln);
- $hash->{$a[0]} = [ @a[1,2,3] ];
- }
-
- $hash;
-}
-
-sub _fieldlist
-{
- my $nntp = shift;
- my $arr = $nntp->read_until_dot or
- return undef;
-
- my $hash = {};
- my $ln;
-
- foreach $ln (@$arr)
- {
- my @a = split(/[\t\n]/,$ln);
- my $m = shift @a;
- $hash->{$m} = [ @a ];
- }
-
- $hash;
-}
-
-sub _articlelist
-{
- my $nntp = shift;
- my $arr = $nntp->read_until_dot;
-
- chomp(@$arr)
- if $arr;
-
- $arr;
-}
-
-sub _description
-{
- my $nntp = shift;
- my $arr = $nntp->read_until_dot or
- return undef;
-
- my $hash = {};
- my $ln;
-
- foreach $ln (@$arr)
- {
- chomp($ln);
-
- $hash->{$1} = $ln
- if $ln =~ s/^\s*(\S+)\s*//o;
- }
-
- $hash;
-
-}
-
-##
-## The commands
-##
-
-sub _ARTICLE { shift->command('ARTICLE',@_)->response == CMD_OK }
-sub _AUTHINFO { shift->command('AUTHINFO',@_)->response }
-sub _BODY { shift->command('BODY',@_)->response == CMD_OK }
-sub _DATE { shift->command('DATE')->response == CMD_INFO }
-sub _GROUP { shift->command('GROUP',@_)->response == CMD_OK }
-sub _HEAD { shift->command('HEAD',@_)->response == CMD_OK }
-sub _HELP { shift->command('HELP',@_)->response == CMD_INFO }
-sub _IHAVE { shift->command('IHAVE',@_)->response == CMD_MORE }
-sub _LAST { shift->command('LAST')->response == CMD_OK }
-sub _LIST { shift->command('LIST',@_)->response == CMD_OK }
-sub _LISTGROUP { shift->command('LISTGROUP',@_)->response == CMD_OK }
-sub _NEWGROUPS { shift->command('NEWGROUPS',@_)->response == CMD_OK }
-sub _NEWNEWS { shift->command('NEWNEWS',@_)->response == CMD_OK }
-sub _NEXT { shift->command('NEXT')->response == CMD_OK }
-sub _POST { shift->command('POST',@_)->response == CMD_MORE }
-sub _QUIT { shift->command('QUIT',@_)->response == CMD_OK }
-sub _SLAVE { shift->command('SLAVE',@_)->response == CMD_OK }
-sub _STAT { shift->command('STAT',@_)->response == CMD_OK }
-sub _MODE { shift->command('MODE',@_)->response == CMD_OK }
-sub _XGTITLE { shift->command('XGTITLE',@_)->response == CMD_OK }
-sub _XHDR { shift->command('XHDR',@_)->response == CMD_OK }
-sub _XPAT { shift->command('XPAT',@_)->response == CMD_OK }
-sub _XPATH { shift->command('XPATH',@_)->response == CMD_OK }
-sub _XOVER { shift->command('XOVER',@_)->response == CMD_OK }
-sub _XROVER { shift->command('XROVER',@_)->response == CMD_OK }
-sub _XTHREAD { shift->unsupported }
-sub _XSEARCH { shift->unsupported }
-sub _XINDEX { shift->unsupported }
-
-##
-## IO/perl methods
-##
-
-sub DESTROY
-{
- my $nntp = shift;
- defined(fileno($nntp)) && $nntp->quit
-}
-
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::NNTP - NNTP Client class
-
-=head1 SYNOPSIS
-
- use Net::NNTP;
-
- $nntp = Net::NNTP->new("some.host.name");
- $nntp->quit;
-
-=head1 DESCRIPTION
-
-C<Net::NNTP> is a class implementing a simple NNTP client in Perl as described
-in RFC977. C<Net::NNTP> inherits its communication methods from C<Net::Cmd>
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( [ HOST ] [, OPTIONS ])
-
-This is the constructor for a new Net::NNTP object. C<HOST> is the
-name of the remote host to which a NNTP connection is required. If not
-given two environment variables are checked, first C<NNTPSERVER> then
-C<NEWSHOST>, then C<Net::Config> is checked, and if a host is not found
-then C<news> is used.
-
-C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
-Possible options are:
-
-B<Timeout> - Maximum time, in seconds, to wait for a response from the
-NNTP server, a value of zero will cause all IO operations to block.
-(default: 120)
-
-B<Debug> - Enable the printing of debugging information to STDERR
-
-B<Reader> - If the remote server is INN then initially the connection
-will be to nnrpd, by default C<Net::NNTP> will issue a C<MODE READER> command
-so that the remote server becomes innd. If the C<Reader> option is given
-with a value of zero, then this command will not be sent and the
-connection will be left talking to nnrpd.
-
-=back
-
-=head1 METHODS
-
-Unless otherwise stated all methods return either a I<true> or I<false>
-value, with I<true> meaning that the operation was a success. When a method
-states that it returns a value, failure will be returned as I<undef> or an
-empty list.
-
-=over 4
-
-=item article ( [ MSGID|MSGNUM ], [FH] )
-
-Retrieve the header, a blank line, then the body (text) of the
-specified article.
-
-If C<FH> is specified then it is expected to be a valid filehandle
-and the result will be printed to it, on sucess a true value will be
-returned. If C<FH> is not specified then the return value, on sucess,
-will be a reference to an array containg the article requested, each
-entry in the array will contain one line of the article.
-
-If no arguments are passed then the current article in the currently
-selected newsgroup is fetched.
-
-C<MSGNUM> is a numeric id of an article in the current newsgroup, and
-will change the current article pointer. C<MSGID> is the message id of
-an article as shown in that article's header. It is anticipated that the
-client will obtain the C<MSGID> from a list provided by the C<newnews>
-command, from references contained within another article, or from the
-message-id provided in the response to some other commands.
-
-If there is an error then C<undef> will be returned.
-
-=item body ( [ MSGID|MSGNUM ], [FH] )
-
-Like C<article> but only fetches the body of the article.
-
-=item head ( [ MSGID|MSGNUM ], [FH] )
-
-Like C<article> but only fetches the headers for the article.
-
-=item nntpstat ( [ MSGID|MSGNUM ] )
-
-The C<nntpstat> command is similar to the C<article> command except that no
-text is returned. When selecting by message number within a group,
-the C<nntpstat> command serves to set the "current article pointer" without
-sending text.
-
-Using the C<nntpstat> command to
-select by message-id is valid but of questionable value, since a
-selection by message-id does B<not> alter the "current article pointer".
-
-Returns the message-id of the "current article".
-
-=item group ( [ GROUP ] )
-
-Set and/or get the current group. If C<GROUP> is not given then information
-is returned on the current group.
-
-In a scalar context it returns the group name.
-
-In an array context the return value is a list containing, the number
-of articles in the group, the number of the first article, the number
-of the last article and the group name.
-
-=item ihave ( MSGID [, MESSAGE ])
-
-The C<ihave> command informs the server that the client has an article
-whose id is C<MSGID>. If the server desires a copy of that
-article, and C<MESSAGE> has been given the it will be sent.
-
-Returns I<true> if the server desires the article and C<MESSAGE> was
-successfully sent,if specified.
-
-If C<MESSAGE> is not specified then the message must be sent using the
-C<datasend> and C<dataend> methods from L<Net::Cmd>
-
-C<MESSAGE> can be either an array of lines or a reference to an array.
-
-=item last ()
-
-Set the "current article pointer" to the previous article in the current
-newsgroup.
-
-Returns the message-id of the article.
-
-=item date ()
-
-Returns the date on the remote server. This date will be in a UNIX time
-format (seconds since 1970)
-
-=item postok ()
-
-C<postok> will return I<true> if the servers initial response indicated
-that it will allow posting.
-
-=item authinfo ( USER, PASS )
-
-=item list ()
-
-Obtain information about all the active newsgroups. The results is a reference
-to a hash where the key is a group name and each value is a reference to an
-array. The elements in this array are:- the last article number in the group,
-the first article number in the group and any information flags about the group.
-
-=item newgroups ( SINCE [, DISTRIBUTIONS ])
-
-C<SINCE> is a time value and C<DISTRIBUTIONS> is either a distribution
-pattern or a reference to a list of distribution patterns.
-The result is the same as C<list>, but the
-groups return will be limited to those created after C<SINCE> and, if
-specified, in one of the distribution areas in C<DISTRIBUTIONS>.
-
-=item newnews ( SINCE [, GROUPS [, DISTRIBUTIONS ]])
-
-C<SINCE> is a time value. C<GROUPS> is either a group pattern or a reference
-to a list of group patterns. C<DISTRIBUTIONS> is either a distribution
-pattern or a reference to a list of distribution patterns.
-
-Returns a reference to a list which contains the message-ids of all news posted
-after C<SINCE>, that are in a groups which matched C<GROUPS> and a
-distribution which matches C<DISTRIBUTIONS>.
-
-=item next ()
-
-Set the "current article pointer" to the next article in the current
-newsgroup.
-
-Returns the message-id of the article.
-
-=item post ( [ MESSAGE ] )
-
-Post a new article to the news server. If C<MESSAGE> is specified and posting
-is allowed then the message will be sent.
-
-If C<MESSAGE> is not specified then the message must be sent using the
-C<datasend> and C<dataend> methods from L<Net::Cmd>
-
-C<MESSAGE> can be either an array of lines or a reference to an array.
-
-=item slave ()
-
-Tell the remote server that I am not a user client, but probably another
-news server.
-
-=item quit ()
-
-Quit the remote server and close the socket connection.
-
-=back
-
-=head2 Extension methods
-
-These methods use commands that are not part of the RFC977 documentation. Some
-servers may not support all of them.
-
-=over 4
-
-=item newsgroups ( [ PATTERN ] )
-
-Returns a reference to a hash where the keys are all the group names which
-match C<PATTERN>, or all of the groups if no pattern is specified, and
-each value contains the description text for the group.
-
-=item distributions ()
-
-Returns a reference to a hash where the keys are all the possible
-distribution names and the values are the distribution descriptions.
-
-=item subscriptions ()
-
-Returns a reference to a list which contains a list of groups which
-are recommended for a new user to subscribe to.
-
-=item overview_fmt ()
-
-Returns a reference to an array which contain the names of the fields returned
-by C<xover>.
-
-=item active_times ()
-
-Returns a reference to a hash where the keys are the group names and each
-value is a reference to an array containing the time the groups was created
-and an identifier, possibly an Email address, of the creator.
-
-=item active ( [ PATTERN ] )
-
-Similar to C<list> but only active groups that match the pattern are returned.
-C<PATTERN> can be a group pattern.
-
-=item xgtitle ( PATTERN )
-
-Returns a reference to a hash where the keys are all the group names which
-match C<PATTERN> and each value is the description text for the group.
-
-=item xhdr ( HEADER, MESSAGE-SPEC )
-
-Obtain the header field C<HEADER> for all the messages specified.
-
-The return value will be a reference
-to a hash where the keys are the message numbers and each value contains
-the text of the requested header for that message.
-
-=item xover ( MESSAGE-SPEC )
-
-The return value will be a reference
-to a hash where the keys are the message numbers and each value contains
-a reference to an array which contains the overview fields for that
-message.
-
-The names of the fields can be obtained by calling C<overview_fmt>.
-
-=item xpath ( MESSAGE-ID )
-
-Returns the path name to the file on the server which contains the specified
-message.
-
-=item xpat ( HEADER, PATTERN, MESSAGE-SPEC)
-
-The result is the same as C<xhdr> except the is will be restricted to
-headers where the text of the header matches C<PATTERN>
-
-=item xrover
-
-The XROVER command returns reference information for the article(s)
-specified.
-
-Returns a reference to a HASH where the keys are the message numbers and the
-values are the References: lines from the articles
-
-=item listgroup ( [ GROUP ] )
-
-Returns a reference to a list of all the active messages in C<GROUP>, or
-the current group if C<GROUP> is not specified.
-
-=item reader
-
-Tell the server that you are a reader and not another server.
-
-This is required by some servers. For example if you are connecting to
-an INN server and you have transfer permission your connection will
-be connected to the transfer daemon, not the NNTP daemon. Issuing
-this command will cause the transfer daemon to hand over control
-to the NNTP daemon.
-
-Some servers do not understand this command, but issuing it and ignoring
-the response is harmless.
-
-=back
-
-=head1 UNSUPPORTED
-
-The following NNTP command are unsupported by the package, and there are
-no plans to do so.
-
- AUTHINFO GENERIC
- XTHREAD
- XSEARCH
- XINDEX
-
-=head1 DEFINITIONS
-
-=over 4
-
-=item MESSAGE-SPEC
-
-C<MESSAGE-SPEC> is either a single message-id, a single message number, or
-a reference to a list of two message numbers.
-
-If C<MESSAGE-SPEC> is a reference to a list of two message numbers and the
-second number in a range is less than or equal to the first then the range
-represents all messages in the group after the first message number.
-
-B<NOTE> For compatibility reasons only with earlier versions of Net::NNTP
-a message spec can be passed as a list of two numbers, this is deprecated
-and a reference to the list should now be passed
-
-=item PATTERN
-
-The C<NNTP> protocol uses the C<WILDMAT> format for patterns.
-The WILDMAT format was first developed by Rich Salz based on
-the format used in the UNIX "find" command to articulate
-file names. It was developed to provide a uniform mechanism
-for matching patterns in the same manner that the UNIX shell
-matches filenames.
-
-Patterns are implicitly anchored at the
-beginning and end of each string when testing for a match.
-
-There are five pattern matching operations other than a strict
-one-to-one match between the pattern and the source to be
-checked for a match.
-
-The first is an asterisk C<*> to match any sequence of zero or more
-characters.
-
-The second is a question mark C<?> to match any single character. The
-third specifies a specific set of characters.
-
-The set is specified as a list of characters, or as a range of characters
-where the beginning and end of the range are separated by a minus (or dash)
-character, or as any combination of lists and ranges. The dash can
-also be included in the set as a character it if is the beginning
-or end of the set. This set is enclosed in square brackets. The
-close square bracket C<]> may be used in a set if it is the first
-character in the set.
-
-The fourth operation is the same as the
-logical not of the third operation and is specified the same
-way as the third with the addition of a caret character C<^> at
-the beginning of the test string just inside the open square
-bracket.
-
-The final operation uses the backslash character to
-invalidate the special meaning of an open square bracket C<[>,
-the asterisk, backslash or the question mark. Two backslashes in
-sequence will result in the evaluation of the backslash as a
-character with no special meaning.
-
-=over 4
-
-=item Examples
-
-=item C<[^]-]>
-
-matches any single character other than a close square
-bracket or a minus sign/dash.
-
-=item C<*bdc>
-
-matches any string that ends with the string "bdc"
-including the string "bdc" (without quotes).
-
-=item C<[0-9a-zA-Z]>
-
-matches any single printable alphanumeric ASCII character.
-
-=item C<a??d>
-
-matches any four character string which begins
-with a and ends with d.
-
-=back
-
-=back
-
-=head1 SEE ALSO
-
-L<Net::Cmd>
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-1997 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=for html <hr>
-
-I<$Id: //depot/libnet/Net/NNTP.pm#14 $>
-
-=cut
+++ /dev/null
-# Net::Netrc.pm
-#
-# Copyright (c) 1995-1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::Netrc;
-
-use Carp;
-use strict;
-use FileHandle;
-use vars qw($VERSION);
-
-$VERSION = "2.12"; # $Id: //depot/libnet/Net/Netrc.pm#12 $
-
-my %netrc = ();
-
-sub _readrc
-{
- my $host = shift;
- my($home,$file);
-
- if($^O eq "MacOS") {
- $home = $ENV{HOME} || `pwd`;
- chomp($home);
- $file = ($home =~ /:$/ ? $home . "netrc" : $home . ":netrc");
- } else {
- # Some OS's don't have `getpwuid', so we default to $ENV{HOME}
- $home = eval { (getpwuid($>))[7] } || $ENV{HOME};
- $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH}||'') if defined $ENV{HOMEDRIVE};
- $file = $home . "/.netrc";
- }
-
- my($login,$pass,$acct) = (undef,undef,undef);
- my $fh;
- local $_;
-
- $netrc{default} = undef;
-
- # OS/2 and Win32 do not handle stat in a way compatable with this check :-(
- unless($^O eq 'os2'
- || $^O eq 'MSWin32'
- || $^O eq 'MacOS'
- || $^O =~ /^cygwin/)
- {
- my @stat = stat($file);
-
- if(@stat)
- {
- if($stat[2] & 077)
- {
- carp "Bad permissions: $file";
- return;
- }
- if($stat[4] != $<)
- {
- carp "Not owner: $file";
- return;
- }
- }
- }
-
- if($fh = FileHandle->new($file,"r"))
- {
- my($mach,$macdef,$tok,@tok) = (0,0);
-
- while(<$fh>)
- {
- undef $macdef if /\A\n\Z/;
-
- if($macdef)
- {
- push(@$macdef,$_);
- next;
- }
-
- s/^\s*//;
- chomp;
- push(@tok, $+)
- while(length && s/^("([^"]*)"|(\S+))\s*//);
-
-TOKEN:
- while(@tok)
- {
- if($tok[0] eq "default")
- {
- shift(@tok);
- $mach = bless {};
- $netrc{default} = [$mach];
-
- next TOKEN;
- }
-
- last TOKEN
- unless @tok > 1;
-
- $tok = shift(@tok);
-
- if($tok eq "machine")
- {
- my $host = shift @tok;
- $mach = bless {machine => $host};
-
- $netrc{$host} = []
- unless exists($netrc{$host});
- push(@{$netrc{$host}}, $mach);
- }
- elsif($tok =~ /^(login|password|account)$/)
- {
- next TOKEN unless $mach;
- my $value = shift @tok;
- # Following line added by rmerrell to remove '/' escape char in .netrc
- $value =~ s/\/\\/\\/g;
- $mach->{$1} = $value;
- }
- elsif($tok eq "macdef")
- {
- next TOKEN unless $mach;
- my $value = shift @tok;
- $mach->{macdef} = {}
- unless exists $mach->{macdef};
- $macdef = $mach->{machdef}{$value} = [];
- }
- }
- }
- $fh->close();
- }
-}
-
-sub lookup
-{
- my($pkg,$mach,$login) = @_;
-
- _readrc()
- unless exists $netrc{default};
-
- $mach ||= 'default';
- undef $login
- if $mach eq 'default';
-
- if(exists $netrc{$mach})
- {
- if(defined $login)
- {
- my $m;
- foreach $m (@{$netrc{$mach}})
- {
- return $m
- if(exists $m->{login} && $m->{login} eq $login);
- }
- return undef;
- }
- return $netrc{$mach}->[0]
- }
-
- return $netrc{default}->[0]
- if defined $netrc{default};
-
- return undef;
-}
-
-sub login
-{
- my $me = shift;
-
- exists $me->{login}
- ? $me->{login}
- : undef;
-}
-
-sub account
-{
- my $me = shift;
-
- exists $me->{account}
- ? $me->{account}
- : undef;
-}
-
-sub password
-{
- my $me = shift;
-
- exists $me->{password}
- ? $me->{password}
- : undef;
-}
-
-sub lpa
-{
- my $me = shift;
- ($me->login, $me->password, $me->account);
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::Netrc - OO interface to users netrc file
-
-=head1 SYNOPSIS
-
- use Net::Netrc;
-
- $mach = Net::Netrc->lookup('some.machine');
- $login = $mach->login;
- ($login, $password, $account) = $mach->lpa;
-
-=head1 DESCRIPTION
-
-C<Net::Netrc> is a class implementing a simple interface to the .netrc file
-used as by the ftp program.
-
-C<Net::Netrc> also implements security checks just like the ftp program,
-these checks are, first that the .netrc file must be owned by the user and
-second the ownership permissions should be such that only the owner has
-read and write access. If these conditions are not met then a warning is
-output and the .netrc file is not read.
-
-=head1 THE .netrc FILE
-
-The .netrc file contains login and initialization information used by the
-auto-login process. It resides in the user's home directory. The following
-tokens are recognized; they may be separated by spaces, tabs, or new-lines:
-
-=over 4
-
-=item machine name
-
-Identify a remote machine name. The auto-login process searches
-the .netrc file for a machine token that matches the remote machine
-specified. Once a match is made, the subsequent .netrc tokens
-are processed, stopping when the end of file is reached or an-
-other machine or a default token is encountered.
-
-=item default
-
-This is the same as machine name except that default matches
-any name. There can be only one default token, and it must be
-after all machine tokens. This is normally used as:
-
- default login anonymous password user@site
-
-thereby giving the user automatic anonymous login to machines
-not specified in .netrc.
-
-=item login name
-
-Identify a user on the remote machine. If this token is present,
-the auto-login process will initiate a login using the
-specified name.
-
-=item password string
-
-Supply a password. If this token is present, the auto-login
-process will supply the specified string if the remote server
-requires a password as part of the login process.
-
-=item account string
-
-Supply an additional account password. If this token is present,
-the auto-login process will supply the specified string
-if the remote server requires an additional account password.
-
-=item macdef name
-
-Define a macro. C<Net::Netrc> only parses this field to be compatible
-with I<ftp>.
-
-=back
-
-=head1 CONSTRUCTOR
-
-The constructor for a C<Net::Netrc> object is not called new as it does not
-really create a new object. But instead is called C<lookup> as this is
-essentially what it does.
-
-=over 4
-
-=item lookup ( MACHINE [, LOGIN ])
-
-Lookup and return a reference to the entry for C<MACHINE>. If C<LOGIN> is given
-then the entry returned will have the given login. If C<LOGIN> is not given then
-the first entry in the .netrc file for C<MACHINE> will be returned.
-
-If a matching entry cannot be found, and a default entry exists, then a
-reference to the default entry is returned.
-
-If there is no matching entry found and there is no default defined, or
-no .netrc file is found, then C<undef> is returned.
-
-=back
-
-=head1 METHODS
-
-=over 4
-
-=item login ()
-
-Return the login id for the netrc entry
-
-=item password ()
-
-Return the password for the netrc entry
-
-=item account ()
-
-Return the account information for the netrc entry
-
-=item lpa ()
-
-Return a list of login, password and account information fir the netrc entry
-
-=back
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>
-
-=head1 SEE ALSO
-
-L<Net::Netrc>
-L<Net::Cmd>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-1998 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=for html <hr>
-
-$Id: //depot/libnet/Net/Netrc.pm#12 $
-
-=cut
+++ /dev/null
-# Net::POP3.pm
-#
-# Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::POP3;
-
-use strict;
-use IO::Socket;
-use vars qw(@ISA $VERSION $debug);
-use Net::Cmd;
-use Carp;
-use Net::Config;
-
-$VERSION = "2.22"; # $Id: //depot/libnet/Net/POP3.pm#20 $
-
-@ISA = qw(Net::Cmd IO::Socket::INET);
-
-sub new
-{
- my $self = shift;
- my $type = ref($self) || $self;
- my $host = shift if @_ % 2;
- my %arg = @_;
- my $hosts = defined $host ? [ $host ] : $NetConfig{pop3_hosts};
- my $obj;
- my @localport = exists $arg{ResvPort} ? ( LocalPort => $arg{ResvPort} ): ();
-
- my $h;
- foreach $h (@{$hosts})
- {
- $obj = $type->SUPER::new(PeerAddr => ($host = $h),
- PeerPort => $arg{Port} || 'pop3(110)',
- Proto => 'tcp',
- @localport,
- Timeout => defined $arg{Timeout}
- ? $arg{Timeout}
- : 120
- ) and last;
- }
-
- return undef
- unless defined $obj;
-
- ${*$obj}{'net_pop3_host'} = $host;
-
- $obj->autoflush(1);
- $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
-
- unless ($obj->response() == CMD_OK)
- {
- $obj->close();
- return undef;
- }
-
- ${*$obj}{'net_pop3_banner'} = $obj->message;
-
- $obj;
-}
-
-##
-## We don't want people sending me their passwords when they report problems
-## now do we :-)
-##
-
-sub debug_text { $_[2] =~ /^(pass|rpop)/i ? "$1 ....\n" : $_[2]; }
-
-sub login
-{
- @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )';
- my($me,$user,$pass) = @_;
-
- if(@_ <= 2)
- {
- require Net::Netrc;
-
- $user ||= eval { (getpwuid($>))[0] } || $ENV{NAME};
-
- my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'},$user);
-
- $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'});
-
- $pass = $m ? $m->password || ""
- : "";
- }
-
- $me->user($user) and
- $me->pass($pass);
-}
-
-sub apop
-{
- @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop( USER, PASS )';
- my($me,$user,$pass) = @_;
- my $banner;
-
- unless(eval { require MD5 })
- {
- carp "You need to install MD5 to use the APOP command";
- return undef;
- }
-
- return undef
- unless ( $banner = (${*$me}{'net_pop3_banner'} =~ /(<.*>)/)[0] );
-
- if(@_ <= 2)
- {
- require Net::Netrc;
-
- $user ||= eval { (getpwuid($>))[0] } || $ENV{NAME};
-
- my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'},$user);
-
- $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'});
-
- $pass = $m ? $m->password || ""
- : "";
- }
-
- my $md = MD5->new;
- $md->add($banner,$pass);
-
- return undef
- unless($me->_APOP($user,$md->hexdigest));
-
- my $ret = ${*$me}{'net_pop3_count'} = ($me->message =~ /(\d+)\s+message/io)
- ? $1 : ($me->popstat)[0];
-
- $ret ? $ret : "0E0";
-}
-
-sub user
-{
- @_ == 2 or croak 'usage: $pop3->user( USER )';
- $_[0]->_USER($_[1]) ? 1 : undef;
-}
-
-sub pass
-{
- @_ == 2 or croak 'usage: $pop3->pass( PASS )';
-
- my($me,$pass) = @_;
-
- return undef
- unless($me->_PASS($pass));
-
- my $ret = ${*$me}{'net_pop3_count'} = ($me->message =~ /(\d+)\s+message/io)
- ? $1 : ($me->popstat)[0];
-
- $ret ? $ret : "0E0";
-}
-
-sub reset
-{
- @_ == 1 or croak 'usage: $obj->reset()';
-
- my $me = shift;
-
- return 0
- unless($me->_RSET);
-
- if(defined ${*$me}{'net_pop3_mail'})
- {
- local $_;
- foreach (@{${*$me}{'net_pop3_mail'}})
- {
- delete $_->{'net_pop3_deleted'};
- }
- }
-}
-
-sub last
-{
- @_ == 1 or croak 'usage: $obj->last()';
-
- return undef
- unless $_[0]->_LAST && $_[0]->message =~ /(\d+)/;
-
- return $1;
-}
-
-sub top
-{
- @_ == 2 || @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])';
- my $me = shift;
-
- return undef
- unless $me->_TOP($_[0], $_[1] || 0);
-
- $me->read_until_dot;
-}
-
-sub popstat
-{
- @_ == 1 or croak 'usage: $pop3->popstat()';
- my $me = shift;
-
- return ()
- unless $me->_STAT && $me->message =~ /(\d+)\D+(\d+)/;
-
- ($1 || 0, $2 || 0);
-}
-
-sub list
-{
- @_ == 1 || @_ == 2 or croak 'usage: $pop3->list( [ MSGNUM ] )';
- my $me = shift;
-
- return undef
- unless $me->_LIST(@_);
-
- if(@_)
- {
- $me->message =~ /\d+\D+(\d+)/;
- return $1 || undef;
- }
-
- my $info = $me->read_until_dot
- or return undef;
-
- my %hash = map { (/(\d+)\D+(\d+)/) } @$info;
-
- return \%hash;
-}
-
-sub get
-{
- @_ == 2 or @_ == 3 or croak 'usage: $pop3->get( MSGNUM [, FH ])';
- my $me = shift;
-
- return undef
- unless $me->_RETR(shift);
-
- $me->read_until_dot(@_);
-}
-
-sub delete
-{
- @_ == 2 or croak 'usage: $pop3->delete( MSGNUM )';
- $_[0]->_DELE($_[1]);
-}
-
-sub uidl
-{
- @_ == 1 || @_ == 2 or croak 'usage: $pop3->uidl( [ MSGNUM ] )';
- my $me = shift;
- my $uidl;
-
- $me->_UIDL(@_) or
- return undef;
- if(@_)
- {
- $uidl = ($me->message =~ /\d+\s+([\041-\176]+)/)[0];
- }
- else
- {
- my $ref = $me->read_until_dot
- or return undef;
- my $ln;
- $uidl = {};
- foreach $ln (@$ref) {
- my($msg,$uid) = $ln =~ /^\s*(\d+)\s+([\041-\176]+)/;
- $uidl->{$msg} = $uid;
- }
- }
- return $uidl;
-}
-
-sub ping
-{
- @_ == 2 or croak 'usage: $pop3->ping( USER )';
- my $me = shift;
-
- return () unless $me->_PING(@_) && $me->message =~ /(\d+)\D+(\d+)/;
-
- ($1 || 0, $2 || 0);
-}
-
-
-sub _STAT { shift->command('STAT')->response() == CMD_OK }
-sub _LIST { shift->command('LIST',@_)->response() == CMD_OK }
-sub _RETR { shift->command('RETR',$_[0])->response() == CMD_OK }
-sub _DELE { shift->command('DELE',$_[0])->response() == CMD_OK }
-sub _NOOP { shift->command('NOOP')->response() == CMD_OK }
-sub _RSET { shift->command('RSET')->response() == CMD_OK }
-sub _QUIT { shift->command('QUIT')->response() == CMD_OK }
-sub _TOP { shift->command('TOP', @_)->response() == CMD_OK }
-sub _UIDL { shift->command('UIDL',@_)->response() == CMD_OK }
-sub _USER { shift->command('USER',$_[0])->response() == CMD_OK }
-sub _PASS { shift->command('PASS',$_[0])->response() == CMD_OK }
-sub _APOP { shift->command('APOP',@_)->response() == CMD_OK }
-sub _PING { shift->command('PING',$_[0])->response() == CMD_OK }
-
-sub _RPOP { shift->command('RPOP',$_[0])->response() == CMD_OK }
-sub _LAST { shift->command('LAST')->response() == CMD_OK }
-
-sub quit
-{
- my $me = shift;
-
- $me->_QUIT;
- $me->close;
-}
-
-sub DESTROY
-{
- my $me = shift;
-
- if(defined fileno($me))
- {
- $me->reset;
- $me->quit;
- }
-}
-
-##
-## POP3 has weird responses, so we emulate them to look the same :-)
-##
-
-sub response
-{
- my $cmd = shift;
- my $str = $cmd->getline() || return undef;
- my $code = "500";
-
- $cmd->debug_print(0,$str)
- if ($cmd->debug);
-
- if($str =~ s/^\+OK\s+//io)
- {
- $code = "200"
- }
- else
- {
- $str =~ s/^-ERR\s+//io;
- }
-
- ${*$cmd}{'net_cmd_resp'} = [ $str ];
- ${*$cmd}{'net_cmd_code'} = $code;
-
- substr($code,0,1);
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::POP3 - Post Office Protocol 3 Client class (RFC1081)
-
-=head1 SYNOPSIS
-
- use Net::POP3;
-
- # Constructors
- $pop = Net::POP3->new('pop3host');
- $pop = Net::POP3->new('pop3host', Timeout => 60);
-
-=head1 DESCRIPTION
-
-This module implements a client interface to the POP3 protocol, enabling
-a perl5 application to talk to POP3 servers. This documentation assumes
-that you are familiar with the POP3 protocol described in RFC1081.
-
-A new Net::POP3 object must be created with the I<new> method. Once
-this has been done, all POP3 commands are accessed via method calls
-on the object.
-
-=head1 EXAMPLES
-
- Need some small examples in here :-)
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( [ HOST, ] [ OPTIONS ] )
-
-This is the constructor for a new Net::POP3 object. C<HOST> is the
-name of the remote host to which a POP3 connection is required.
-
-If C<HOST> is not given, then the C<POP3_Host> specified in C<Net::Config>
-will be used.
-
-C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
-Possible options are:
-
-B<ResvPort> - If given then the socket for the C<Net::POP3> object
-will be bound to the local port given using C<bind> when the socket is
-created.
-
-B<Timeout> - Maximum time, in seconds, to wait for a response from the
-POP3 server (default: 120)
-
-B<Debug> - Enable debugging information
-
-=back
-
-=head1 METHODS
-
-Unless otherwise stated all methods return either a I<true> or I<false>
-value, with I<true> meaning that the operation was a success. When a method
-states that it returns a value, failure will be returned as I<undef> or an
-empty list.
-
-=over 4
-
-=item user ( USER )
-
-Send the USER command.
-
-=item pass ( PASS )
-
-Send the PASS command. Returns the number of messages in the mailbox.
-
-=item login ( [ USER [, PASS ]] )
-
-Send both the USER and PASS commands. If C<PASS> is not given the
-C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host
-and username. If the username is not specified then the current user name
-will be used.
-
-Returns the number of messages in the mailbox. However if there are no
-messages on the server the string C<"0E0"> will be returned. This is
-will give a true value in a boolean context, but zero in a numeric context.
-
-If there was an error authenticating the user then I<undef> will be returned.
-
-=item apop ( USER, PASS )
-
-Authenticate with the server identifying as C<USER> with password C<PASS>.
-Similar ti L<login>, but the password is not sent in clear text.
-
-To use this method you must have the MD5 package installed, if you do not
-this method will return I<undef>
-
-
-=item top ( MSGNUM [, NUMLINES ] )
-
-Get the header and the first C<NUMLINES> of the body for the message
-C<MSGNUM>. Returns a reference to an array which contains the lines of text
-read from the server.
-
-=item list ( [ MSGNUM ] )
-
-If called with an argument the C<list> returns the size of the message
-in octets.
-
-If called without arguments a reference to a hash is returned. The
-keys will be the C<MSGNUM>'s of all undeleted messages and the values will
-be their size in octets.
-
-=item get ( MSGNUM [, FH ] )
-
-Get the message C<MSGNUM> from the remote mailbox. If C<FH> is not given
-then get returns a reference to an array which contains the lines of
-text read from the server. If C<FH> is given then the lines returned
-from the server are printed to the filehandle C<FH>.
-
-=item last ()
-
-Returns the highest C<MSGNUM> of all the messages accessed.
-
-=item popstat ()
-
-Returns a list of two elements. These are the number of undeleted
-elements and the size of the mbox in octets.
-
-=item ping ( USER )
-
-Returns a list of two elements. These are the number of new messages
-and the total number of messages for C<USER>.
-
-=item uidl ( [ MSGNUM ] )
-
-Returns a unique identifier for C<MSGNUM> if given. If C<MSGNUM> is not
-given C<uidl> returns a reference to a hash where the keys are the
-message numbers and the values are the unique identifiers.
-
-=item delete ( MSGNUM )
-
-Mark message C<MSGNUM> to be deleted from the remote mailbox. All messages
-that are marked to be deleted will be removed from the remote mailbox
-when the server connection closed.
-
-=item reset ()
-
-Reset the status of the remote POP3 server. This includes reseting the
-status of all messages to not be deleted.
-
-=item quit ()
-
-Quit and close the connection to the remote POP3 server. Any messages marked
-as deleted will be deleted from the remote mailbox.
-
-=back
-
-=head1 NOTES
-
-If a C<Net::POP3> object goes out of scope before C<quit> method is called
-then the C<reset> method will called before the connection is closed. This
-means that any messages marked to be deleted will not be.
-
-=head1 SEE ALSO
-
-L<Net::Netrc>
-L<Net::Cmd>
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-1997 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=for html <hr>
-
-I<$Id: //depot/libnet/Net/POP3.pm#20 $>
-
-=cut
+++ /dev/null
-# Net::SMTP.pm
-#
-# Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::SMTP;
-
-require 5.001;
-
-use strict;
-use vars qw($VERSION @ISA);
-use Socket 1.3;
-use Carp;
-use IO::Socket;
-use Net::Cmd;
-use Net::Config;
-
-$VERSION = "2.19"; # $Id: //depot/libnet/Net/SMTP.pm#20 $
-
-@ISA = qw(Net::Cmd IO::Socket::INET);
-
-sub new
-{
- my $self = shift;
- my $type = ref($self) || $self;
- my $host = shift if @_ % 2;
- my %arg = @_;
- my $hosts = defined $host ? [ $host ] : $NetConfig{smtp_hosts};
- my $obj;
-
- my $h;
- foreach $h (@{$hosts})
- {
- $obj = $type->SUPER::new(PeerAddr => ($host = $h),
- PeerPort => $arg{Port} || 'smtp(25)',
- Proto => 'tcp',
- Timeout => defined $arg{Timeout}
- ? $arg{Timeout}
- : 120
- ) and last;
- }
-
- return undef
- unless defined $obj;
-
- $obj->autoflush(1);
-
- $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
-
- unless ($obj->response() == CMD_OK)
- {
- $obj->close();
- return undef;
- }
-
- ${*$obj}{'net_smtp_host'} = $host;
-
- (${*$obj}{'net_smtp_banner'}) = $obj->message;
- (${*$obj}{'net_smtp_domain'}) = $obj->message =~ /\A\s*(\S+)/;
-
- unless($obj->hello($arg{Hello} || ""))
- {
- $obj->close();
- return undef;
- }
-
- $obj;
-}
-
-##
-## User interface methods
-##
-
-sub banner
-{
- my $me = shift;
-
- return ${*$me}{'net_smtp_banner'} || undef;
-}
-
-sub domain
-{
- my $me = shift;
-
- return ${*$me}{'net_smtp_domain'} || undef;
-}
-
-sub etrn {
- my $self = shift;
- defined($self->supports('ETRN',500,["Command unknown: 'ETRN'"])) &&
- $self->_ETRN(@_);
-}
-
-sub auth { # auth(username, password) by mengwong 20011106. the only supported mechanism at this time is PLAIN.
- #
- # my $auth = $smtp->supports("AUTH");
- # $smtp->auth("username", "password") or die $smtp->message;
- #
-
- require MIME::Base64;
-
- my $self = shift;
- my ($username, $password) = @_;
- die "auth(username, password)" if not length $username;
-
- my $mechanisms = $self->supports('AUTH',500,["Command unknown: 'AUTH'"]);
- return unless defined $mechanisms;
-
- if (not grep { uc $_ eq "PLAIN" } split ' ', $mechanisms) {
- $self->set_status(500, ["PLAIN mechanism not supported; server supports $mechanisms"]);
- return;
- }
- my $authstring = MIME::Base64::encode_base64(join "\0", ($username)x2, $password);
- $authstring =~ s/\n//g; # wrap long lines
-
- $self->_AUTH("PLAIN $authstring");
-}
-
-sub hello
-{
- my $me = shift;
- my $domain = shift || "localhost.localdomain";
- my $ok = $me->_EHLO($domain);
- my @msg = $me->message;
-
- if($ok)
- {
- my $h = ${*$me}{'net_smtp_esmtp'} = {};
- my $ln;
- foreach $ln (@msg) {
- $h->{uc $1} = $2
- if $ln =~ /(\S+)\b[ \t]*([^\n]*)/;
- }
- }
- elsif($me->status == CMD_ERROR)
- {
- @msg = $me->message
- if $ok = $me->_HELO($domain);
- }
-
- $ok && $msg[0] =~ /\A\s*(\S+)/
- ? $1
- : undef;
-}
-
-sub supports {
- my $self = shift;
- my $cmd = uc shift;
- return ${*$self}{'net_smtp_esmtp'}->{$cmd}
- if exists ${*$self}{'net_smtp_esmtp'}->{$cmd};
- $self->set_status(@_)
- if @_;
- return;
-}
-
-sub _addr
-{
- my $addr = shift || "";
-
- return $1
- if $addr =~ /(<[^>]+>)/so;
-
- $addr =~ s/\n/ /sog;
- $addr =~ s/(\A\s+|\s+\Z)//sog;
-
- return "<" . $addr . ">";
-}
-
-
-sub mail
-{
- my $me = shift;
- my $addr = _addr(shift);
- my $opts = "";
-
- if(@_)
- {
- my %opt = @_;
- my($k,$v);
-
- if(exists ${*$me}{'net_smtp_esmtp'})
- {
- my $esmtp = ${*$me}{'net_smtp_esmtp'};
-
- if(defined($v = delete $opt{Size}))
- {
- if(exists $esmtp->{SIZE})
- {
- $opts .= sprintf " SIZE=%d", $v + 0
- }
- else
- {
- carp 'Net::SMTP::mail: SIZE option not supported by host';
- }
- }
-
- if(defined($v = delete $opt{Return}))
- {
- if(exists $esmtp->{DSN})
- {
- $opts .= " RET=" . uc $v
- }
- else
- {
- carp 'Net::SMTP::mail: DSN option not supported by host';
- }
- }
-
- if(defined($v = delete $opt{Bits}))
- {
- if(exists $esmtp->{'8BITMIME'})
- {
- $opts .= $v == 8 ? " BODY=8BITMIME" : " BODY=7BIT"
- }
- else
- {
- carp 'Net::SMTP::mail: 8BITMIME option not supported by host';
- }
- }
-
- if(defined($v = delete $opt{Transaction}))
- {
- if(exists $esmtp->{CHECKPOINT})
- {
- $opts .= " TRANSID=" . _addr($v);
- }
- else
- {
- carp 'Net::SMTP::mail: CHECKPOINT option not supported by host';
- }
- }
-
- if(defined($v = delete $opt{Envelope}))
- {
- if(exists $esmtp->{DSN})
- {
- $v =~ s/([^\041-\176]|=|\+)/sprintf "+%02x", ord($1)/sge;
- $opts .= " ENVID=$v"
- }
- else
- {
- carp 'Net::SMTP::mail: DSN option not supported by host';
- }
- }
-
- carp 'Net::SMTP::recipient: unknown option(s) '
- . join(" ", keys %opt)
- . ' - ignored'
- if scalar keys %opt;
- }
- else
- {
- carp 'Net::SMTP::mail: ESMTP not supported by host - options discarded :-(';
- }
- }
-
- $me->_MAIL("FROM:".$addr.$opts);
-}
-
-sub send { shift->_SEND("FROM:" . _addr($_[0])) }
-sub send_or_mail { shift->_SOML("FROM:" . _addr($_[0])) }
-sub send_and_mail { shift->_SAML("FROM:" . _addr($_[0])) }
-
-sub reset
-{
- my $me = shift;
-
- $me->dataend()
- if(exists ${*$me}{'net_smtp_lastch'});
-
- $me->_RSET();
-}
-
-
-sub recipient
-{
- my $smtp = shift;
- my $opts = "";
- my $skip_bad = 0;
-
- if(@_ && ref($_[-1]))
- {
- my %opt = %{pop(@_)};
- my $v;
-
- $skip_bad = delete $opt{'SkipBad'};
-
- if(exists ${*$smtp}{'net_smtp_esmtp'})
- {
- my $esmtp = ${*$smtp}{'net_smtp_esmtp'};
-
- if(defined($v = delete $opt{Notify}))
- {
- if(exists $esmtp->{DSN})
- {
- $opts .= " NOTIFY=" . join(",",map { uc $_ } @$v)
- }
- else
- {
- carp 'Net::SMTP::recipient: DSN option not supported by host';
- }
- }
-
- carp 'Net::SMTP::recipient: unknown option(s) '
- . join(" ", keys %opt)
- . ' - ignored'
- if scalar keys %opt;
- }
- elsif(%opt)
- {
- carp 'Net::SMTP::recipient: ESMTP not supported by host - options discarded :-(';
- }
- }
-
- my @ok;
- my $addr;
- foreach $addr (@_)
- {
- if($smtp->_RCPT("TO:" . _addr($addr) . $opts)) {
- push(@ok,$addr) if $skip_bad;
- }
- elsif(!$skip_bad) {
- return 0;
- }
- }
-
- return $skip_bad ? @ok : 1;
-}
-
-BEGIN {
- *to = \&recipient;
- *cc = \&recipient;
- *bcc = \&recipient;
-}
-
-sub data
-{
- my $me = shift;
-
- my $ok = $me->_DATA() && $me->datasend(@_);
-
- $ok && @_ ? $me->dataend
- : $ok;
-}
-
-sub expand
-{
- my $me = shift;
-
- $me->_EXPN(@_) ? ($me->message)
- : ();
-}
-
-
-sub verify { shift->_VRFY(@_) }
-
-sub help
-{
- my $me = shift;
-
- $me->_HELP(@_) ? scalar $me->message
- : undef;
-}
-
-sub quit
-{
- my $me = shift;
-
- $me->_QUIT;
- $me->close;
-}
-
-sub DESTROY
-{
-# ignore
-}
-
-##
-## RFC821 commands
-##
-
-sub _EHLO { shift->command("EHLO", @_)->response() == CMD_OK }
-sub _HELO { shift->command("HELO", @_)->response() == CMD_OK }
-sub _MAIL { shift->command("MAIL", @_)->response() == CMD_OK }
-sub _RCPT { shift->command("RCPT", @_)->response() == CMD_OK }
-sub _SEND { shift->command("SEND", @_)->response() == CMD_OK }
-sub _SAML { shift->command("SAML", @_)->response() == CMD_OK }
-sub _SOML { shift->command("SOML", @_)->response() == CMD_OK }
-sub _VRFY { shift->command("VRFY", @_)->response() == CMD_OK }
-sub _EXPN { shift->command("EXPN", @_)->response() == CMD_OK }
-sub _HELP { shift->command("HELP", @_)->response() == CMD_OK }
-sub _RSET { shift->command("RSET")->response() == CMD_OK }
-sub _NOOP { shift->command("NOOP")->response() == CMD_OK }
-sub _QUIT { shift->command("QUIT")->response() == CMD_OK }
-sub _DATA { shift->command("DATA")->response() == CMD_MORE }
-sub _TURN { shift->unsupported(@_); }
-sub _ETRN { shift->command("ETRN", @_)->response() == CMD_OK }
-sub _AUTH { shift->command("AUTH", @_)->response() == CMD_OK }
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::SMTP - Simple Mail Transfer Protocol Client
-
-=head1 SYNOPSIS
-
- use Net::SMTP;
-
- # Constructors
- $smtp = Net::SMTP->new('mailhost');
- $smtp = Net::SMTP->new('mailhost', Timeout => 60);
-
-=head1 DESCRIPTION
-
-This module implements a client interface to the SMTP and ESMTP
-protocol, enabling a perl5 application to talk to SMTP servers. This
-documentation assumes that you are familiar with the concepts of the
-SMTP protocol described in RFC821.
-
-A new Net::SMTP object must be created with the I<new> method. Once
-this has been done, all SMTP commands are accessed through this object.
-
-The Net::SMTP class is a subclass of Net::Cmd and IO::Socket::INET.
-
-=head1 EXAMPLES
-
-This example prints the mail domain name of the SMTP server known as mailhost:
-
- #!/usr/local/bin/perl -w
-
- use Net::SMTP;
-
- $smtp = Net::SMTP->new('mailhost');
- print $smtp->domain,"\n";
- $smtp->quit;
-
-This example sends a small message to the postmaster at the SMTP server
-known as mailhost:
-
- #!/usr/local/bin/perl -w
-
- use Net::SMTP;
-
- $smtp = Net::SMTP->new('mailhost');
-
- $smtp->mail($ENV{USER});
- $smtp->to('postmaster');
-
- $smtp->data();
- $smtp->datasend("To: postmaster\n");
- $smtp->datasend("\n");
- $smtp->datasend("A simple test message\n");
- $smtp->dataend();
-
- $smtp->quit;
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new Net::SMTP [ HOST, ] [ OPTIONS ]
-
-This is the constructor for a new Net::SMTP object. C<HOST> is the
-name of the remote host to which an SMTP connection is required.
-
-If C<HOST> is not given, then the C<SMTP_Host> specified in C<Net::Config>
-will be used.
-
-C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
-Possible options are:
-
-B<Hello> - SMTP requires that you identify yourself. This option
-specifies a string to pass as your mail domain. If not
-given a guess will be taken.
-
-B<Timeout> - Maximum time, in seconds, to wait for a response from the
-SMTP server (default: 120)
-
-B<Debug> - Enable debugging information
-
-
-Example:
-
-
- $smtp = Net::SMTP->new('mailhost',
- Hello => 'my.mail.domain'
- Timeout => 30,
- Debug => 1,
- );
-
-=back
-
-=head1 METHODS
-
-Unless otherwise stated all methods return either a I<true> or I<false>
-value, with I<true> meaning that the operation was a success. When a method
-states that it returns a value, failure will be returned as I<undef> or an
-empty list.
-
-=over 4
-
-=item banner ()
-
-Returns the banner message which the server replied with when the
-initial connection was made.
-
-=item domain ()
-
-Returns the domain that the remote SMTP server identified itself as during
-connection.
-
-=item hello ( DOMAIN )
-
-Tell the remote server the mail domain which you are in using the EHLO
-command (or HELO if EHLO fails). Since this method is invoked
-automatically when the Net::SMTP object is constructed the user should
-normally not have to call it manually.
-
-=item etrn ( DOMAIN )
-
-Request a queue run for the DOMAIN given.
-
-=item auth ( USERNAME, PASSWORD )
-
-Attempt SASL authentication. At this time only the PLAIN mechanism is supported.
-
-At some point in the future support for using Authen::SASL will be added
-
-=item mail ( ADDRESS [, OPTIONS] )
-
-=item send ( ADDRESS )
-
-=item send_or_mail ( ADDRESS )
-
-=item send_and_mail ( ADDRESS )
-
-Send the appropriate command to the server MAIL, SEND, SOML or SAML. C<ADDRESS>
-is the address of the sender. This initiates the sending of a message. The
-method C<recipient> should be called for each address that the message is to
-be sent to.
-
-The C<mail> method can some additional ESMTP OPTIONS which is passed
-in hash like fashion, using key and value pairs. Possible options are:
-
- Size => <bytes>
- Return => <???>
- Bits => "7" | "8"
- Transaction => <ADDRESS>
- Envelope => <ENVID>
-
-
-=item reset ()
-
-Reset the status of the server. This may be called after a message has been
-initiated, but before any data has been sent, to cancel the sending of the
-message.
-
-=item recipient ( ADDRESS [, ADDRESS [ ...]] [, OPTIONS ] )
-
-Notify the server that the current message should be sent to all of the
-addresses given. Each address is sent as a separate command to the server.
-Should the sending of any address result in a failure then the
-process is aborted and a I<false> value is returned. It is up to the
-user to call C<reset> if they so desire.
-
-The C<recipient> method can some additional OPTIONS which is passed
-in hash like fashion, using key and value pairs. Possible options are:
-
- Notify =>
- SkipBad => ignore bad addresses
-
-If C<SkipBad> is true the C<recipient> will not return an error when a
-bad address is encountered and it will return an array of addresses
-that did succeed.
-
- $smtp->recipient($recipient1,$recipient2); # Good
- $smtp->recipient($recipient1,$recipient2, { SkipBad => 1 }); # Good
- $smtp->recipient("$recipient,$recipient2"); # BAD
-
-=item to ( ADDRESS [, ADDRESS [...]] )
-
-=item cc ( ADDRESS [, ADDRESS [...]] )
-
-=item bcc ( ADDRESS [, ADDRESS [...]] )
-
-Synonyms for C<recipient>.
-
-=item data ( [ DATA ] )
-
-Initiate the sending of the data from the current message.
-
-C<DATA> may be a reference to a list or a list. If specified the contents
-of C<DATA> and a termination string C<".\r\n"> is sent to the server. And the
-result will be true if the data was accepted.
-
-If C<DATA> is not specified then the result will indicate that the server
-wishes the data to be sent. The data must then be sent using the C<datasend>
-and C<dataend> methods described in L<Net::Cmd>.
-
-=item expand ( ADDRESS )
-
-Request the server to expand the given address Returns an array
-which contains the text read from the server.
-
-=item verify ( ADDRESS )
-
-Verify that C<ADDRESS> is a legitimate mailing address.
-
-=item help ( [ $subject ] )
-
-Request help text from the server. Returns the text or undef upon failure
-
-=item quit ()
-
-Send the QUIT command to the remote SMTP server and close the socket connection.
-
-=back
-
-=head1 SEE ALSO
-
-L<Net::Cmd>
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-1997 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=for html <hr>
-
-I<$Id: //depot/libnet/Net/SMTP.pm#20 $>
-
-=cut
+++ /dev/null
-# Net::Time.pm
-#
-# Copyright (c) 1995-1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::Time;
-
-use strict;
-use vars qw($VERSION @ISA @EXPORT_OK $TIMEOUT);
-use Carp;
-use IO::Socket;
-require Exporter;
-use Net::Config;
-use IO::Select;
-
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(inet_time inet_daytime);
-
-$VERSION = "2.09"; # $Id: //depot/libnet/Net/Time.pm#9 $
-
-$TIMEOUT = 120;
-
-sub _socket
-{
- my($pname,$pnum,$host,$proto,$timeout) = @_;
-
- $proto ||= 'udp';
-
- my $port = (getservbyname($pname, $proto))[2] || $pnum;
-
- my $hosts = defined $host ? [ $host ] : $NetConfig{$pname . '_hosts'};
-
- my $me;
-
- foreach $host (@$hosts)
- {
- $me = IO::Socket::INET->new(PeerAddr => $host,
- PeerPort => $port,
- Proto => $proto
- ) and last;
- }
-
- return unless $me;
-
- $me->send("\n")
- if $proto eq 'udp';
-
- $timeout = $TIMEOUT
- unless defined $timeout;
-
- IO::Select->new($me)->can_read($timeout)
- ? $me
- : undef;
-}
-
-sub inet_time
-{
- my $s = _socket('time',37,@_) || return undef;
- my $buf = '';
- my $offset = 0 | 0;
-
- return undef
- unless $s->recv($buf, length(pack("N",0)));
-
- # unpack, we | 0 to ensure we have an unsigned
- my $time = (unpack("N",$buf))[0] | 0;
-
- # the time protocol return time in seconds since 1900, convert
- # it to a the required format
-
- if($^O eq "MacOS") {
- # MacOS return seconds since 1904, 1900 was not a leap year.
- $offset = (4 * 31536000) | 0;
- }
- else {
- # otherwise return seconds since 1972, there were 17 leap years between
- # 1900 and 1972
- $offset = (70 * 31536000 + 17 * 86400) | 0;
- }
-
- $time - $offset;
-}
-
-sub inet_daytime
-{
- my $s = _socket('daytime',13,@_) || return undef;
- my $buf = '';
-
- $s->recv($buf, 1024) ? $buf
- : undef;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::Time - time and daytime network client interface
-
-=head1 SYNOPSIS
-
- use Net::Time qw(inet_time inet_daytime);
-
- print inet_time(); # use default host from Net::Config
- print inet_time('localhost');
- print inet_time('localhost', 'tcp');
-
- print inet_daytime(); # use default host from Net::Config
- print inet_daytime('localhost');
- print inet_daytime('localhost', 'tcp');
-
-=head1 DESCRIPTION
-
-C<Net::Time> provides subroutines that obtain the time on a remote machine.
-
-=over 4
-
-=item inet_time ( [HOST [, PROTOCOL [, TIMEOUT]]])
-
-Obtain the time on C<HOST>, or some default host if C<HOST> is not given
-or not defined, using the protocol as defined in RFC868. The optional
-argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
-C<udp>. The result will be a time value in the same units as returned
-by time() or I<undef> upon failure.
-
-=item inet_daytime ( [HOST [, PROTOCOL [, TIMEOUT]]])
-
-Obtain the time on C<HOST>, or some default host if C<HOST> is not given
-or not defined, using the protocol as defined in RFC867. The optional
-argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
-C<udp>. The result will be an ASCII string or I<undef> upon failure.
-
-=back
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-1998 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=for html <hr>
-
-I<$Id: //depot/libnet/Net/Time.pm#9 $>
-
-=cut
+++ /dev/null
-=head1 NAME
-
-libnetFAQ - libnet Frequently Asked Questions
-
-=head1 DESCRIPTION
-
-=head2 Where to get this document
-
-This document is distributed with the libnet distribution, and is also
-available on the libnet web page at
-
- http://www.pobox.com/~gbarr/libnet/
-
-=head2 How to contribute to this document
-
-You may mail corrections, additions, and suggestions to me
-gbarr@pobox.com.
-
-=head1 Author and Copyright Information
-
-Copyright (c) 1997-1998 Graham Barr. All rights reserved.
-This document is free; you can redistribute it and/or modify it
-under the terms of the Artistic License.
-
-=head2 Disclaimer
-
-This information is offered in good faith and in the hope that it may
-be of use, but is not guaranteed to be correct, up to date, or suitable
-for any particular purpose whatsoever. The authors accept no liability
-in respect of this information or its use.
-
-
-=head1 Obtaining and installing libnet
-
-=head2 What is libnet ?
-
-libnet is a collection of perl5 modules which all related to network
-programming. The majority of the modules available provided the
-client side of popular server-client protocols that are used in
-the internet community.
-
-=head2 Which version of perl do I need ?
-
-libnet has been know to work with versions of perl from 5.002 onwards. However
-if your release of perl is prior to perl5.004 then you will need to
-obtain and install the IO distribution from CPAN. If you have perl5.004
-or later then you will have the IO modules in your installation already,
-but CPAN may contain updates.
-
-=head2 What other modules do I need ?
-
-The only modules you will need installed are the modules from the IO
-distribution. If you have perl5.004 or later you will already have
-these modules.
-
-=head2 What machines support libnet ?
-
-libnet itself is an entirely perl-code distribution so it should work
-on any machine that perl runs on. However IO may not work
-with some machines and earlier releases of perl. But this
-should not be the case with perl version 5.004 or later.
-
-=head2 Where can I get the latest libnet release
-
-The latest libnet release is always on CPAN, you will find it
-in
-
- http://www.cpan.org/modules/by-module/Net/
-
-The latest release and information is also available on the libnet web page
-at
-
- http://www.pobox.com/~gbarr/libnet/
-
-=head1 Using Net::FTP
-
-=head2 How do I download files from an FTP server ?
-
-An example taken from an article posted to comp.lang.perl.misc
-
- #!/your/path/to/perl
-
- # a module making life easier
-
- use Net::FTP;
-
- # for debuging: $ftp = Net::FTP->new('site','Debug',10);
- # open a connection and log in!
-
- $ftp = Net::FTP->new('target_site.somewhere.xxx');
- $ftp->login('username','password');
-
- # set transfer mode to binary
-
- $ftp->binary();
-
- # change the directory on the ftp site
-
- $ftp->cwd('/some/path/to/somewhere/');
-
- foreach $name ('file1', 'file2', 'file3') {
-
- # get's arguments are in the following order:
- # ftp server's filename
- # filename to save the transfer to on the local machine
- # can be simply used as get($name) if you want the same name
-
- $ftp->get($name,$name);
- }
-
- # ftp done!
-
- $ftp->quit;
-
-=head2 How do I transfer files in binary mode ?
-
-To transfer files without <LF><CR> translation Net::FTP provides
-the C<binary> method
-
- $ftp->binary;
-
-=head2 How can I get the size of a file on a remote FTP server ?
-
-=head2 How can I get the modification time of a file on a remote FTP server ?
-
-=head2 How can I change the permissions of a file on a remote server ?
-
-The FTP protocol does not have a command for changing the permissions
-of a file on the remote server. But some ftp servers may allow a chmod
-command to be issued via a SITE command, eg
-
- $ftp->quot('site chmod 0777',$filename);
-
-But this is not guaranteed to work.
-
-=head2 Can I do a reget operation like the ftp command ?
-
-=head2 How do I get a directory listing from an FTP server ?
-
-=head2 Changing directory to "" does not fail ?
-
-Passing an argument of "" to ->cwd() has the same affect of calling ->cwd()
-without any arguments. Turn on Debug (I<See below>) and you will see what is
-happening
-
- $ftp = Net::FTP->new($host, Debug => 1);
- $ftp->login;
- $ftp->cwd("");
-
-gives
-
- Net::FTP=GLOB(0x82196d8)>>> CWD /
- Net::FTP=GLOB(0x82196d8)<<< 250 CWD command successful.
-
-=head2 I am behind a SOCKS firewall, but the Firewall option does not work ?
-
-The Firewall option is only for support of one type of firewall. The type
-supported is an ftp proxy.
-
-To use Net::FTP, or any other module in the libnet distribution,
-through a SOCKS firewall you must create a socks-ified perl executable
-by compiling perl with the socks library.
-
-=head2 I am behind an FTP proxy firewall, but cannot access machines outside ?
-
-Net::FTP implements the most popular ftp proxy firewall approach. The scheme
-implemented is that where you log in to the firewall with C<user@hostname>
-
-I have heard of one other type of firewall which requires a login to the
-firewall with an account, then a second login with C<user@hostname>. You can
-still use Net::FTP to traverse these firewalls, but a more manual approach
-must be taken, eg
-
- $ftp = Net::FTP->new($firewall) or die $@;
- $ftp->login($firewall_user, $firewall_passwd) or die $ftp->message;
- $ftp->login($ext_user . '@' . $ext_host, $ext_passwd) or die $ftp->message.
-
-=head2 My ftp proxy firewall does not listen on port 21
-
-FTP servers usually listen on the same port number, port 21, as any other
-FTP server. But there is no reason why this has to be the case.
-
-If you pass a port number to Net::FTP then it assumes this is the port
-number of the final destination. By default Net::FTP will always try
-to connect to the firewall on port 21.
-
-Net::FTP uses IO::Socket to open the connection and IO::Socket allows
-the port number to be specified as part of the hostname. So this problem
-can be resolved by either passing a Firewall option like C<"hostname:1234">
-or by setting the C<ftp_firewall> option in Net::Config to be a string
-in in the same form.
-
-=head2 Is it possible to change the file permissions of a file on an FTP server ?
-
-The answer to this is "maybe". The FTP protocol does not specify a command to change
-file permissions on a remote host. However many servers do allow you to run the
-chmod command via the C<SITE> command. This can be done with
-
- $ftp->site('chmod','0775',$file);
-
-=head2 I have seen scripts call a method message, but cannot find it documented ?
-
-Net::FTP, like several other packages in libnet, inherits from Net::Cmd, so
-all the methods described in Net::Cmd are also available on Net::FTP
-objects.
-
-=head2 Why does Net::FTP not implement mput and mget methods
-
-The quick answer is because they are easy to implement yourself. The long
-answer is that to write these in such a way that multiple platforms are
-supported correctly would just require too much code. Below are
-some examples how you can implement these yourself.
-
-sub mput {
- my($ftp,$pattern) = @_;
- foreach my $file (glob($pattern)) {
- $ftp->put($file) or warn $ftp->message;
- }
-}
-
-sub mget {
- my($ftp,$pattern) = @_;
- foreach my $file ($ftp->ls($pattern)) {
- $ftp->get($file) or warn $ftp->message;
- }
-}
-
-
-=head1 Using Net::SMTP
-
-=head2 Why can't the part of an Email address after the @ be used as the hostname ?
-
-The part of an Email address which follows the @ is not necessarily a hostname,
-it is a mail domain. To find the name of a host to connect for a mail domain
-you need to do a DNS MX lookup
-
-=head2 Why does Net::SMTP not do DNS MX lookups ?
-
-Net::SMTP implements the SMTP protocol. The DNS MX lookup is not part
-of this protocol.
-
-=head2 The verify method always returns true ?
-
-Well it may seem that way, but it does not. The verify method returns true
-if the command succeeded. If you pass verify an address which the
-server would normally have to forward to another machine, the command
-will succeed with something like
-
- 252 Couldn't verify <someone@there> but will attempt delivery anyway
-
-This command will fail only if you pass it an address in a domain
-the server directly delivers for, and that address does not exist.
-
-=head1 Debugging scripts
-
-=head2 How can I debug my scripts that use Net::* modules ?
-
-Most of the libnet client classes allow options to be passed to the
-constructor, in most cases one option is called C<Debug>. Passing
-this option with a non-zero value will turn on a protocol trace, which
-will be sent to STDERR. This trace can be useful to see what commands
-are being sent to the remote server and what responses are being
-received back.
-
- #!/your/path/to/perl
-
- use Net::FTP;
-
- my $ftp = new Net::FTP($host, Debug => 1);
- $ftp->login('gbarr','password');
- $ftp->quit;
-
-this script would output something like
-
- Net::FTP: Net::FTP(2.22)
- Net::FTP: Exporter
- Net::FTP: Net::Cmd(2.0801)
- Net::FTP: IO::Socket::INET
- Net::FTP: IO::Socket(1.1603)
- Net::FTP: IO::Handle(1.1504)
-
- Net::FTP=GLOB(0x8152974)<<< 220 imagine FTP server (Version wu-2.4(5) Tue Jul 29 11:17:18 CDT 1997) ready.
- Net::FTP=GLOB(0x8152974)>>> user gbarr
- Net::FTP=GLOB(0x8152974)<<< 331 Password required for gbarr.
- Net::FTP=GLOB(0x8152974)>>> PASS ....
- Net::FTP=GLOB(0x8152974)<<< 230 User gbarr logged in. Access restrictions apply.
- Net::FTP=GLOB(0x8152974)>>> QUIT
- Net::FTP=GLOB(0x8152974)<<< 221 Goodbye.
-
-The first few lines tell you the modules that Net::FTP uses and their versions,
-this is useful data to me when a user reports a bug. The last seven lines
-show the communication with the server. Each line has three parts. The first
-part is the object itself, this is useful for separating the output
-if you are using multiple objects. The second part is either C<<<<<> to
-show data coming from the server or C<>>>>> to show data
-going to the server. The remainder of the line is the command
-being sent or response being received.
-
-=head1 AUTHOR AND COPYRIGHT
-
-Copyright (c) 1997 Graham Barr.
-All rights reserved.
-
-=for html <hr>
-
-I<$Id: //depot/libnet/Net/libnetFAQ.pod#5 $>
-
+++ /dev/null
-package Switch;
-
-use strict;
-use vars qw($VERSION);
-use Carp;
-
-$VERSION = '2.06';
-
-
-# LOAD FILTERING MODULE...
-use Filter::Util::Call;
-
-sub __();
-
-# CATCH ATTEMPTS TO CALL case OUTSIDE THE SCOPE OF ANY switch
-
-$::_S_W_I_T_C_H = sub { croak "case/when statement not in switch/given block" };
-
-my $offset;
-my $fallthrough;
-my ($Perl5, $Perl6) = (0,0);
-
-sub import
-{
- $DB::single = 1;
- $fallthrough = grep /\bfallthrough\b/, @_;
- $offset = (caller)[2]+1;
- filter_add({}) unless @_>1 && $_[1] eq 'noimport';
- my $pkg = caller;
- no strict 'refs';
- for ( qw( on_defined on_exists ) )
- {
- *{"${pkg}::$_"} = \&$_;
- }
- *{"${pkg}::__"} = \&__ if grep /__/, @_;
- $Perl6 = 1 if grep(/Perl\s*6/i, @_);
- $Perl5 = 1 if grep(/Perl\s*5/i, @_) || !grep(/Perl\s*6/i, @_);
- 1;
-}
-
-sub unimport
-{
- filter_del()
-}
-
-sub filter
-{
- my($self) = @_ ;
- local $Switch::file = (caller)[1];
-
- my $status = 1;
- $status = filter_read(10_000);
- return $status if $status<0;
- $_ = filter_blocks($_,$offset);
- $_ = "# line $offset\n" . $_ if $offset; undef $offset;
- # print STDERR $_;
- return $status;
-}
-
-use Text::Balanced ':ALL';
-
-sub line
-{
- my ($pretext,$offset) = @_;
- ($pretext=~tr/\n/\n/)+($offset||0);
-}
-
-sub is_block
-{
- local $SIG{__WARN__}=sub{die$@};
- local $^W=1;
- my $ishash = defined eval 'my $hr='.$_[0];
- undef $@;
- return !$ishash;
-}
-
-
-my $EOP = qr/\n\n|\Z/;
-my $CUT = qr/\n=cut.*$EOP/;
-my $pod_or_DATA = qr/ ^=(?:head[1-4]|item) .*? $CUT
- | ^=pod .*? $CUT
- | ^=for .*? $EOP
- | ^=begin \s* (\S+) .*? \n=end \s* \1 .*? $EOP
- | ^__(DATA|END)__\n.*
- /smx;
-
-my $casecounter = 1;
-sub filter_blocks
-{
- my ($source, $line) = @_;
- return $source unless $Perl5 && $source =~ /case|switch/
- || $Perl6 && $source =~ /when|given/;
- pos $source = 0;
- my $text = "";
- component: while (pos $source < length $source)
- {
- if ($source =~ m/(\G\s*use\s+Switch\b)/gc)
- {
- $text .= q{use Switch 'noimport'};
- next component;
- }
- my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0);
- if (defined $pos[0])
- {
- $text .= " " . substr($source,$pos[2],$pos[18]-$pos[2]);
- next component;
- }
- if ($source =~ m/\G\s*($pod_or_DATA)/gc) {
- next component;
- }
- @pos = Text::Balanced::_match_variable(\$source,qr/\s*/);
- if (defined $pos[0])
- {
- $text .= " " . substr($source,$pos[0],$pos[4]-$pos[0]);
- next component;
- }
-
- if ($Perl5 && $source =~ m/\G(\n*)(\s*)(switch)\b(?=\s*[(])/gc
- || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(?=\s*[(])/gc)
- {
- my $keyword = $3;
- $text .= $1.$2.'S_W_I_T_C_H: while (1) ';
- @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/[[{(<]/,qr/[]})>]/,undef)
- or do {
- die "Bad $keyword statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
- };
- my $arg = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
- $arg =~ s {^\s*[(]\s*%} { ( \\\%} ||
- $arg =~ s {^\s*[(]\s*m\b} { ( qr} ||
- $arg =~ s {^\s*[(]\s*/} { ( qr/} ||
- $arg =~ s {^\s*[(]\s*qw} { ( \\qw};
- @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
- or do {
- die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0, pos $source), $line), "\n";
- };
- my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
- $code =~ s/{/{ local \$::_S_W_I_T_C_H; Switch::switch $arg;/;
- $text .= $code . 'continue {last}';
- next component;
- }
- elsif ($Perl5 && $source =~ m/\G(\s*)(case\b)(?!\s*=>)/gc
- || $Perl6 && $source =~ m/\G(\s*)(when\b)(?!\s*=>)/gc)
- {
- my $keyword = $2;
- $text .= $1."if (Switch::case";
- if (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) {
- my $code = substr($source,$pos[0],$pos[4]-$pos[0]);
- $text .= " sub" if is_block $code;
- $text .= " " . filter_blocks($code,line(substr($source,0,$pos[0]),$line)) . ")";
- }
- elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/[[(]/,qr/[])]/,qr/[[({]/,qr/[])}]/,undef)) {
- my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
- $code =~ s {^\s*[(]\s*%} { ( \\\%} ||
- $code =~ s {^\s*[(]\s*m\b} { ( qr} ||
- $code =~ s {^\s*[(]\s*/} { ( qr/} ||
- $code =~ s {^\s*[(]\s*qw} { ( \\qw};
- $text .= " $code)";
- }
- elsif ($Perl6 && do{@pos = Text::Balanced::_match_variable(\$source,qr/\s*/)}) {
- my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
- $code =~ s {^\s*%} { \%} ||
- $code =~ s {^\s*@} { \@};
- $text .= " $code)";
- }
- elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0)) {
- my $code = substr($source,$pos[2],$pos[18]-$pos[2]);
- $code = filter_blocks($code,line(substr($source,0,$pos[2]),$line));
- $code =~ s {^\s*m} { qr} ||
- $code =~ s {^\s*/} { qr/} ||
- $code =~ s {^\s*qw} { \\qw};
- $text .= " $code)";
- }
- elsif ($Perl5 && $source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc
- || $Perl6 && $source =~ m/\G\s*([^:;]*)()/gc) {
- my $code = filter_blocks($1,line(substr($source,0,pos $source),$line));
- $text .= ' \\' if $2 eq '%';
- $text .= " $code)";
- }
- else {
- die "Bad $keyword statement (invalid $keyword value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n";
- }
-
- die "Missing colon or semi-colon after 'when' value near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n"
- unless !$Perl6 || $source =~ m/\G(\s*)(:|(?=;))/gc;
-
- do{@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)}
- or do {
- if ($source =~ m/\G\s*(?=([};]|\Z))/gc) {
- $casecounter++;
- next component;
- }
- die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
- };
- my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
- $code =~ s/}(?=\s*\Z)/;last S_W_I_T_C_H }/
- unless $fallthrough;
- $text .= "{ while (1) $code continue { goto C_A_S_E_$casecounter } last S_W_I_T_C_H; C_A_S_E_$casecounter: }";
- $casecounter++;
- next component;
- }
-
- $source =~ m/\G(\s*(-[sm]\s+|\w+|#.*\n|\W))/gc;
- $text .= $1;
- }
- $text;
-}
-
-
-
-sub in
-{
- my ($x,$y) = @_;
- my @numy;
- for my $nextx ( @$x )
- {
- my $numx = ref($nextx) || defined $nextx && (~$nextx&$nextx) eq 0;
- for my $j ( 0..$#$y )
- {
- my $nexty = $y->[$j];
- push @numy, ref($nexty) || defined $nexty && (~$nexty&$nexty) eq 0
- if @numy <= $j;
- return 1 if $numx && $numy[$j] && $nextx==$nexty
- || $nextx eq $nexty;
-
- }
- }
- return "";
-}
-
-sub on_exists
-{
- my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
- [ keys %$ref ]
-}
-
-sub on_defined
-{
- my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
- [ grep { defined $ref->{$_} } keys %$ref ]
-}
-
-sub switch(;$)
-{
- my ($s_val) = @_ ? $_[0] : $_;
- my $s_ref = ref $s_val;
-
- if ($s_ref eq 'CODE')
- {
- $::_S_W_I_T_C_H =
- sub { my $c_val = $_[0];
- return $s_val == $c_val if ref $c_val eq 'CODE';
- return $s_val->(@$c_val) if ref $c_val eq 'ARRAY';
- return $s_val->($c_val);
- };
- }
- elsif ($s_ref eq "" && defined $s_val && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR
- {
- $::_S_W_I_T_C_H =
- sub { my $c_val = $_[0];
- my $c_ref = ref $c_val;
- return $s_val == $c_val if $c_ref eq ""
- && defined $c_val
- && (~$c_val&$c_val) eq 0;
- return $s_val eq $c_val if $c_ref eq "";
- return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
- return $c_val->($s_val) if $c_ref eq 'CODE';
- return $c_val->call($s_val) if $c_ref eq 'Switch';
- return scalar $s_val=~/$c_val/
- if $c_ref eq 'Regexp';
- return scalar $c_val->{$s_val}
- if $c_ref eq 'HASH';
- return;
- };
- }
- elsif ($s_ref eq "") # STRING SCALAR
- {
- $::_S_W_I_T_C_H =
- sub { my $c_val = $_[0];
- my $c_ref = ref $c_val;
- return $s_val eq $c_val if $c_ref eq "";
- return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
- return $c_val->($s_val) if $c_ref eq 'CODE';
- return $c_val->call($s_val) if $c_ref eq 'Switch';
- return scalar $s_val=~/$c_val/
- if $c_ref eq 'Regexp';
- return scalar $c_val->{$s_val}
- if $c_ref eq 'HASH';
- return;
- };
- }
- elsif ($s_ref eq 'ARRAY')
- {
- $::_S_W_I_T_C_H =
- sub { my $c_val = $_[0];
- my $c_ref = ref $c_val;
- return in($s_val,[$c_val]) if $c_ref eq "";
- return in($s_val,$c_val) if $c_ref eq 'ARRAY';
- return $c_val->(@$s_val) if $c_ref eq 'CODE';
- return $c_val->call(@$s_val)
- if $c_ref eq 'Switch';
- return scalar grep {$_=~/$c_val/} @$s_val
- if $c_ref eq 'Regexp';
- return scalar grep {$c_val->{$_}} @$s_val
- if $c_ref eq 'HASH';
- return;
- };
- }
- elsif ($s_ref eq 'Regexp')
- {
- $::_S_W_I_T_C_H =
- sub { my $c_val = $_[0];
- my $c_ref = ref $c_val;
- return $c_val=~/s_val/ if $c_ref eq "";
- return scalar grep {$_=~/s_val/} @$c_val
- if $c_ref eq 'ARRAY';
- return $c_val->($s_val) if $c_ref eq 'CODE';
- return $c_val->call($s_val) if $c_ref eq 'Switch';
- return $s_val eq $c_val if $c_ref eq 'Regexp';
- return grep {$_=~/$s_val/ && $c_val->{$_}} keys %$c_val
- if $c_ref eq 'HASH';
- return;
- };
- }
- elsif ($s_ref eq 'HASH')
- {
- $::_S_W_I_T_C_H =
- sub { my $c_val = $_[0];
- my $c_ref = ref $c_val;
- return $s_val->{$c_val} if $c_ref eq "";
- return scalar grep {$s_val->{$_}} @$c_val
- if $c_ref eq 'ARRAY';
- return $c_val->($s_val) if $c_ref eq 'CODE';
- return $c_val->call($s_val) if $c_ref eq 'Switch';
- return grep {$_=~/$c_val/ && $s_val->{"$_"}} keys %$s_val
- if $c_ref eq 'Regexp';
- return $s_val==$c_val if $c_ref eq 'HASH';
- return;
- };
- }
- elsif ($s_ref eq 'Switch')
- {
- $::_S_W_I_T_C_H =
- sub { my $c_val = $_[0];
- return $s_val == $c_val if ref $c_val eq 'Switch';
- return $s_val->call(@$c_val)
- if ref $c_val eq 'ARRAY';
- return $s_val->call($c_val);
- };
- }
- else
- {
- croak "Cannot switch on $s_ref";
- }
- return 1;
-}
-
-sub case($) { local $SIG{__WARN__} = \&carp;
- $::_S_W_I_T_C_H->(@_); }
-
-# IMPLEMENT __
-
-my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} };
-
-sub __() { $placeholder }
-
-sub __arg($)
-{
- my $index = $_[0]+1;
- bless { arity=>0, impl=>sub{$_[$index]} };
-}
-
-sub hosub(&@)
-{
- # WRITE THIS
-}
-
-sub call
-{
- my ($self,@args) = @_;
- return $self->{impl}->(0,@args);
-}
-
-sub meta_bop(&)
-{
- my ($op) = @_;
- sub
- {
- my ($left, $right, $reversed) = @_;
- ($right,$left) = @_ if $reversed;
-
- my $rop = ref $right eq 'Switch'
- ? $right
- : bless { arity=>0, impl=>sub{$right} };
-
- my $lop = ref $left eq 'Switch'
- ? $left
- : bless { arity=>0, impl=>sub{$left} };
-
- my $arity = $lop->{arity} + $rop->{arity};
-
- return bless {
- arity => $arity,
- impl => sub { my $start = shift;
- return $op->($lop->{impl}->($start,@_),
- $rop->{impl}->($start+$lop->{arity},@_));
- }
- };
- };
-}
-
-sub meta_uop(&)
-{
- my ($op) = @_;
- sub
- {
- my ($left) = @_;
-
- my $lop = ref $left eq 'Switch'
- ? $left
- : bless { arity=>0, impl=>sub{$left} };
-
- my $arity = $lop->{arity};
-
- return bless {
- arity => $arity,
- impl => sub { $op->($lop->{impl}->(@_)) }
- };
- };
-}
-
-
-use overload
- "+" => meta_bop {$_[0] + $_[1]},
- "-" => meta_bop {$_[0] - $_[1]},
- "*" => meta_bop {$_[0] * $_[1]},
- "/" => meta_bop {$_[0] / $_[1]},
- "%" => meta_bop {$_[0] % $_[1]},
- "**" => meta_bop {$_[0] ** $_[1]},
- "<<" => meta_bop {$_[0] << $_[1]},
- ">>" => meta_bop {$_[0] >> $_[1]},
- "x" => meta_bop {$_[0] x $_[1]},
- "." => meta_bop {$_[0] . $_[1]},
- "<" => meta_bop {$_[0] < $_[1]},
- "<=" => meta_bop {$_[0] <= $_[1]},
- ">" => meta_bop {$_[0] > $_[1]},
- ">=" => meta_bop {$_[0] >= $_[1]},
- "==" => meta_bop {$_[0] == $_[1]},
- "!=" => meta_bop {$_[0] != $_[1]},
- "<=>" => meta_bop {$_[0] <=> $_[1]},
- "lt" => meta_bop {$_[0] lt $_[1]},
- "le" => meta_bop {$_[0] le $_[1]},
- "gt" => meta_bop {$_[0] gt $_[1]},
- "ge" => meta_bop {$_[0] ge $_[1]},
- "eq" => meta_bop {$_[0] eq $_[1]},
- "ne" => meta_bop {$_[0] ne $_[1]},
- "cmp" => meta_bop {$_[0] cmp $_[1]},
- "\&" => meta_bop {$_[0] & $_[1]},
- "^" => meta_bop {$_[0] ^ $_[1]},
- "|" => meta_bop {$_[0] | $_[1]},
- "atan2" => meta_bop {atan2 $_[0], $_[1]},
-
- "neg" => meta_uop {-$_[0]},
- "!" => meta_uop {!$_[0]},
- "~" => meta_uop {~$_[0]},
- "cos" => meta_uop {cos $_[0]},
- "sin" => meta_uop {sin $_[0]},
- "exp" => meta_uop {exp $_[0]},
- "abs" => meta_uop {abs $_[0]},
- "log" => meta_uop {log $_[0]},
- "sqrt" => meta_uop {sqrt $_[0]},
- "bool" => sub { croak "Can't use && or || in expression containing __" },
-
- # "&()" => sub { $_[0]->{impl} },
-
- # "||" => meta_bop {$_[0] || $_[1]},
- # "&&" => meta_bop {$_[0] && $_[1]},
- # fallback => 1,
- ;
-1;
-
-__END__
-
-
-=head1 NAME
-
-Switch - A switch statement for Perl
-
-=head1 VERSION
-
-This document describes version 2.06 of Switch,
-released November 14, 2001.
-
-=head1 SYNOPSIS
-
- use Switch;
-
- switch ($val) {
-
- case 1 { print "number 1" }
- case "a" { print "string a" }
- case [1..10,42] { print "number in list" }
- case (@array) { print "number in list" }
- case /\w+/ { print "pattern" }
- case qr/\w+/ { print "pattern" }
- case (%hash) { print "entry in hash" }
- case (\%hash) { print "entry in hash" }
- case (\&sub) { print "arg to subroutine" }
- else { print "previous case not true" }
- }
-
-=head1 BACKGROUND
-
-[Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
-and wherefores of this control structure]
-
-In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
-it is useful to generalize this notion of distributed conditional
-testing as far as possible. Specifically, the concept of "matching"
-between the switch value and the various case values need not be
-restricted to numeric (or string or referential) equality, as it is in other
-languages. Indeed, as Table 1 illustrates, Perl
-offers at least eighteen different ways in which two values could
-generate a match.
-
- Table 1: Matching a switch value ($s) with a case value ($c)
-
- Switch Case Type of Match Implied Matching Code
- Value Value
- ====== ===== ===================== =============
-
- number same numeric or referential match if $s == $c;
- or ref equality
-
- object method result of method call match if $s->$c();
- ref name match if defined $s->$c();
- or ref
-
- other other string equality match if $s eq $c;
- non-ref non-ref
- scalar scalar
-
- string regexp pattern match match if $s =~ /$c/;
-
- array scalar array entry existence match if 0<=$c && $c<@$s;
- ref array entry definition match if defined $s->[$c];
- array entry truth match if $s->[$c];
-
- array array array intersection match if intersects(@$s, @$c);
- ref ref (apply this table to
- all pairs of elements
- $s->[$i] and
- $c->[$j])
-
- array regexp array grep match if grep /$c/, @$s;
- ref
-
- hash scalar hash entry existence match if exists $s->{$c};
- ref hash entry definition match if defined $s->{$c};
- hash entry truth match if $s->{$c};
-
- hash regexp hash grep match if grep /$c/, keys %$s;
- ref
-
- sub scalar return value defn match if defined $s->($c);
- ref return value truth match if $s->($c);
-
- sub array return value defn match if defined $s->(@$c);
- ref ref return value truth match if $s->(@$c);
-
-
-In reality, Table 1 covers 31 alternatives, because only the equality and
-intersection tests are commutative; in all other cases, the roles of
-the C<$s> and C<$c> variables could be reversed to produce a
-different test. For example, instead of testing a single hash for
-the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
-one could test for the existence of a single key in a series of hashes
-(C<match if exists $c-E<gt>{$s}>).
-
-As L<perltodo> observes, a Perl case mechanism must support all these
-"ways to do it".
-
-
-=head1 DESCRIPTION
-
-The Switch.pm module implements a generalized case mechanism that covers
-the numerous possible combinations of switch and case values described above.
-
-The module augments the standard Perl syntax with two new control
-statements: C<switch> and C<case>. The C<switch> statement takes a
-single scalar argument of any type, specified in parentheses.
-C<switch> stores this value as the
-current switch value in a (localized) control variable.
-The value is followed by a block which may contain one or more
-Perl statements (including the C<case> statement described below).
-The block is unconditionally executed once the switch value has
-been cached.
-
-A C<case> statement takes a single scalar argument (in mandatory
-parentheses if it's a variable; otherwise the parens are optional) and
-selects the appropriate type of matching between that argument and the
-current switch value. The type of matching used is determined by the
-respective types of the switch value and the C<case> argument, as
-specified in Table 1. If the match is successful, the mandatory
-block associated with the C<case> statement is executed.
-
-In most other respects, the C<case> statement is semantically identical
-to an C<if> statement. For example, it can be followed by an C<else>
-clause, and can be used as a postfix statement qualifier.
-
-However, when a C<case> block has been executed control is automatically
-transferred to the statement after the immediately enclosing C<switch>
-block, rather than to the next statement within the block. In other
-words, the success of any C<case> statement prevents other cases in the
-same scope from executing. But see L<"Allowing fall-through"> below.
-
-Together these two new statements provide a fully generalized case
-mechanism:
-
- use Switch;
-
- # AND LATER...
-
- %special = ( woohoo => 1, d'oh => 1 );
-
- while (<>) {
- switch ($_) {
-
- case (%special) { print "homer\n"; } # if $special{$_}
- case /a-z/i { print "alpha\n"; } # if $_ =~ /a-z/i
- case [1..9] { print "small num\n"; } # if $_ in [1..9]
-
- case { $_[0] >= 10 } { # if $_ >= 10
- my $age = <>;
- switch (sub{ $_[0] < $age } ) {
-
- case 20 { print "teens\n"; } # if 20 < $age
- case 30 { print "twenties\n"; } # if 30 < $age
- else { print "history\n"; }
- }
- }
-
- print "must be punctuation\n" case /\W/; # if $_ ~= /\W/
- }
-
-Note that C<switch>es can be nested within C<case> (or any other) blocks,
-and a series of C<case> statements can try different types of matches
--- hash membership, pattern match, array intersection, simple equality,
-etc. -- against the same switch value.
-
-The use of intersection tests against an array reference is particularly
-useful for aggregating integral cases:
-
- sub classify_digit
- {
- switch ($_[0]) { case 0 { return 'zero' }
- case [2,4,6,8] { return 'even' }
- case [1,3,4,7,9] { return 'odd' }
- case /[A-F]/i { return 'hex' }
- }
- }
-
-
-=head2 Allowing fall-through
-
-Fall-though (trying another case after one has already succeeded)
-is usually a Bad Idea in a switch statement. However, this
-is Perl, not a police state, so there I<is> a way to do it, if you must.
-
-If a C<case> block executes an untargetted C<next>, control is
-immediately transferred to the statement I<after> the C<case> statement
-(i.e. usually another case), rather than out of the surrounding
-C<switch> block.
-
-For example:
-
- switch ($val) {
- case 1 { handle_num_1(); next } # and try next case...
- case "1" { handle_str_1(); next } # and try next case...
- case [0..9] { handle_num_any(); } # and we're done
- case /\d/ { handle_dig_any(); next } # and try next case...
- case /.*/ { handle_str_any(); next } # and try next case...
- }
-
-If $val held the number C<1>, the above C<switch> block would call the
-first three C<handle_...> subroutines, jumping to the next case test
-each time it encountered a C<next>. After the thrid C<case> block
-was executed, control would jump to the end of the enclosing
-C<switch> block.
-
-On the other hand, if $val held C<10>, then only the last two C<handle_...>
-subroutines would be called.
-
-Note that this mechanism allows the notion of I<conditional fall-through>.
-For example:
-
- switch ($val) {
- case [0..9] { handle_num_any(); next if $val < 7; }
- case /\d/ { handle_dig_any(); }
- }
-
-If an untargetted C<last> statement is executed in a case block, this
-immediately transfers control out of the enclosing C<switch> block
-(in other words, there is an implicit C<last> at the end of each
-normal C<case> block). Thus the previous example could also have been
-written:
-
- switch ($val) {
- case [0..9] { handle_num_any(); last if $val >= 7; next; }
- case /\d/ { handle_dig_any(); }
- }
-
-
-=head2 Automating fall-through
-
-In situations where case fall-through should be the norm, rather than an
-exception, an endless succession of terminal C<next>s is tedious and ugly.
-Hence, it is possible to reverse the default behaviour by specifying
-the string "fallthrough" when importing the module. For example, the
-following code is equivalent to the first example in L<"Allowing fall-through">:
-
- use Switch 'fallthrough';
-
- switch ($val) {
- case 1 { handle_num_1(); }
- case "1" { handle_str_1(); }
- case [0..9] { handle_num_any(); last }
- case /\d/ { handle_dig_any(); }
- case /.*/ { handle_str_any(); }
- }
-
-Note the explicit use of a C<last> to preserve the non-fall-through
-behaviour of the third case.
-
-
-
-=head2 Alternative syntax
-
-Perl 6 will provide a built-in switch statement with essentially the
-same semantics as those offered by Switch.pm, but with a different
-pair of keywords. In Perl 6 C<switch> with be spelled C<given>, and
-C<case> will be pronounced C<when>. In addition, the C<when> statement
-will use a colon between its case value and its block (removing the
-need to parenthesize variables.
-
-This future syntax is also available via the Switch.pm module, by
-importing it with the argument C<"Perl6">. For example:
-
- use Switch 'Perl6';
-
- given ($val) {
- when 1 : { handle_num_1(); }
- when $str1 : { handle_str_1(); }
- when [0..9] : { handle_num_any(); last }
- when /\d/ : { handle_dig_any(); }
- when /.*/ : { handle_str_any(); }
- }
-
-Note that you can mix and match both syntaxes by importing the module
-with:
-
- use Switch 'Perl5', 'Perl6';
-
-
-=head2 Higher-order Operations
-
-One situation in which C<switch> and C<case> do not provide a good
-substitute for a cascaded C<if>, is where a switch value needs to
-be tested against a series of conditions. For example:
-
- sub beverage {
- switch (shift) {
-
- case sub { $_[0] < 10 } { return 'milk' }
- case sub { $_[0] < 20 } { return 'coke' }
- case sub { $_[0] < 30 } { return 'beer' }
- case sub { $_[0] < 40 } { return 'wine' }
- case sub { $_[0] < 50 } { return 'malt' }
- case sub { $_[0] < 60 } { return 'Moet' }
- else { return 'milk' }
- }
- }
-
-The need to specify each condition as a subroutine block is tiresome. To
-overcome this, when importing Switch.pm, a special "placeholder"
-subroutine named C<__> [sic] may also be imported. This subroutine
-converts (almost) any expression in which it appears to a reference to a
-higher-order function. That is, the expression:
-
- use Switch '__';
-
- __ < 2 + __
-
-is equivalent to:
-
- sub { $_[0] < 2 + $_[1] }
-
-With C<__>, the previous ugly case statements can be rewritten:
-
- case __ < 10 { return 'milk' }
- case __ < 20 { return 'coke' }
- case __ < 30 { return 'beer' }
- case __ < 40 { return 'wine' }
- case __ < 50 { return 'malt' }
- case __ < 60 { return 'Moet' }
- else { return 'milk' }
-
-The C<__> subroutine makes extensive use of operator overloading to
-perform its magic. All operations involving __ are overloaded to
-produce an anonymous subroutine that implements a lazy version
-of the original operation.
-
-The only problem is that operator overloading does not allow the
-boolean operators C<&&> and C<||> to be overloaded. So a case statement
-like this:
-
- case 0 <= __ && __ < 10 { return 'digit' }
-
-doesn't act as expected, because when it is
-executed, it constructs two higher order subroutines
-and then treats the two resulting references as arguments to C<&&>:
-
- sub { 0 <= $_[0] } && sub { $_[0] < 10 }
-
-This boolean expression is inevitably true, since both references are
-non-false. Fortunately, the overloaded C<'bool'> operator catches this
-situation and flags it as a error.
-
-=head1 DEPENDENCIES
-
-The module is implemented using Filter::Util::Call and Text::Balanced
-and requires both these modules to be installed.
-
-=head1 AUTHOR
-
-Damian Conway (damian@conway.org)
-
-=head1 BUGS
-
-There are undoubtedly serious bugs lurking somewhere in code this funky :-)
-Bug reports and other feedback are most welcome.
-
-=head1 LIMITATION
-
-Due to the heuristic nature of Switch.pm's source parsing, the presence
-of regexes specified with raw C<?...?> delimiters may cause mysterious
-errors. The workaround is to use C<m?...?> instead.
-
-=head1 COPYRIGHT
-
- Copyright (c) 1997-2001, Damian Conway. All Rights Reserved.
- This module is free software. It may be used, redistributed
- and/or modified under the same terms as Perl itself.
+++ /dev/null
-BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
-}
-
-# Before `make install' is performed this script should be runnable with
-# `make test'. After `make install' it should work as `perl test.pl'
-
-######################### We start with some black magic to print on failure.
-
-# Change 1..1 below to 1..last_test_to_print .
-# (It may become useful if the test is moved to ./t subdirectory.)
-
-BEGIN { $| = 1; print "1..2\n"; }
-END {print "not ok 1\n" unless $loaded;}
-use Class::ISA;
-$loaded = 1;
-print "ok 1\n";
-
-######################### End of black magic.
-
-# Insert your test code below (better if it prints "ok 13"
-# (correspondingly "not ok 13") depending on the success of chunk 13
-# of the test code):
-
- @Food::Fishstick::ISA = qw(Food::Fish Life::Fungus Chemicals);
- @Food::Fish::ISA = qw(Food);
- @Food::ISA = qw(Matter);
- @Life::Fungus::ISA = qw(Life);
- @Chemicals::ISA = qw(Matter);
- @Life::ISA = qw(Matter);
- @Matter::ISA = qw();
-
- use Class::ISA;
- my @path = Class::ISA::super_path('Food::Fishstick');
- my $flat_path = join ' ', @path;
- print "# Food::Fishstick path is:\n# $flat_path\n";
- print "not " unless
- "Food::Fish Food Matter Life::Fungus Life Chemicals" eq $flat_path;
- print "ok 2\n";
+++ /dev/null
-print "1..3\n";
-
-BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
-}
-
-use Digest;
-
-my $hexdigest = "900150983cd24fb0d6963f7d28e17f72";
-if (ord('A') == 193) { # EBCDIC
- $hexdigest = "fe4ea0d98f9cd8d1d27f102a93cb0bb0"; # IBM-1047
-}
-
-print "not " unless Digest->MD5->add("abc")->hexdigest eq $hexdigest;
-print "ok 1\n";
-
-print "not " unless Digest->MD5->add("abc")->hexdigest eq $hexdigest;
-print "ok 2\n";
-
-eval {
- print "not " unless Digest->new("HMAC-MD5" => "Jefe")->add("what do ya want for nothing?")->hexdigest eq "750c783e6ab0b503eaa86e310a5db738";
- print "ok 3\n";
-};
-print "ok 3\n" if $@ && $@ =~ /^Can't locate/;
-
+++ /dev/null
-package ExportTest;
-
-use Filter::Simple;
-use base Exporter;
-
-@EXPORT_OK = qw(ok);
-
-FILTER { s/not// };
-
-sub ok { print "ok @_\n" }
-
-1;
+++ /dev/null
-package FilterOnlyTest;
-
-use Filter::Simple;
-
-FILTER_ONLY
- string => sub {
- my $class = shift;
- while (my($pat, $str) = splice @_, 0, 2) {
- s/$pat/$str/g;
- }
- };
+++ /dev/null
-package FilterTest;
-
-use Filter::Simple;
-
-FILTER {
- my $class = shift;
- while (my($pat, $str) = splice @_, 0, 2) {
- s/$pat/$str/g;
- }
-};
-
-1;
+++ /dev/null
-package ImportTest;
-
-use base 'Exporter';
-@EXPORT = qw(say);
-
-sub say { print @_ }
-
-use Filter::Simple;
-
-sub import {
- my $class = shift;
- print "ok $_\n" foreach @_;
- __PACKAGE__->export_to_level(1,$class);
-}
-
-FILTER { s/not // };
-
-
-1;
+++ /dev/null
-BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir('t') if -d 't';
- @INC = qw(lib ../lib);
- }
-}
-
-use FilterOnlyTest qr/ok/ => "not ok", "bad" => "ok";
-print "1..6\n";
-
-print "bad 1\n";
-print "bad 2\n";
-print "bad 3\n";
-print <DATA>;
-
-__DATA__
-ok 4
-ok 5
-ok 6
+++ /dev/null
-BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir('t') if -d 't';
- @INC = qw(lib ../lib);
- }
-}
-
-BEGIN { print "1..1\n" }
-
-use ExportTest 'ok';
-
-notok 1;
+++ /dev/null
-BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir('t') if -d 't';
- @INC = qw(lib ../lib);
- }
-}
-
-use FilterTest qr/not ok/ => "ok", fail => "ok";
-
-print "1..6\n";
-
-sub fail { print "fail ", $_[0], "\n" }
-
-print "not ok 1\n";
-print "fail 2\n";
-
-fail(3);
-&fail(4);
-
-print "not " unless "whatnot okapi" eq "whatokapi";
-print "ok 5\n";
-
-no FilterTest;
-
-print "not " unless "not ok" =~ /^not /;
-print "ok 6\n";
-
+++ /dev/null
-BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir('t') if -d 't';
- @INC = qw(lib ../lib);
- }
-}
-
-use FilterOnlyTest qr/not ok/ => "ok", "bad" => "ok", fail => "die";
-print "1..9\n";
-
-sub fail { print "ok ", $_[0], "\n" }
-sub ok { print "ok ", $_[0], "\n" }
-
-print "not ok 1\n";
-print "bad 2\n";
-
-fail(3);
-&fail(4);
-
-print "not " unless "whatnot okapi" eq "whatokapi";
-print "ok 5\n";
-
-ok 7 unless not ok 6;
-
-no FilterOnlyTest; # THE FUN STOPS HERE
-
-print "not " unless "not ok" =~ /^not /;
-print "ok 8\n";
-
-print "not " unless "bad" =~ /bad/;
-print "ok 9\n";
+++ /dev/null
-BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir('t') if -d 't';
- @INC = qw(lib ../lib);
- }
-}
-
-BEGIN { print "1..4\n" }
-
-use ImportTest (1..3);
-
-say "not ok 4\n";
+++ /dev/null
-#!/usr/bin/perl
-
-use lib '..';
-use Memoize;
-
-
-print "1..11\n";
-
-sub timelist {
- return (time) x $_[0];
-}
-
-memoize('timelist');
-
-@t1 = &timelist(1);
-sleep 2;
-@u1 = &timelist(1);
-print ((("@t1" eq "@u1") ? '' : 'not '), "ok 1\n");
-
-@t7 = &timelist(7);
-print (((@t7 == 7) ? '' : 'not '), "ok 2\n");
-$BAD = 0;
-for ($i = 1; $i < 7; $i++) {
- $BAD++ unless $t7[$i-1] == $t7[$i];
-}
-print (($BAD ? 'not ' : ''), "ok 3\n");
-
-sleep 2;
-@u7 = &timelist(7);
-print (((@u7 == 7) ? '' : 'not '), "ok 4\n");
-$BAD = 0;
-for ($i = 1; $i < 7; $i++) {
- $BAD++ unless $u7[$i-1] == $u7[$i];
-}
-print (($BAD ? 'not ' : ''), "ok 5\n");
-# Properly memoized?
-print ((("@t7" eq "@u7") ? '' : 'not '), "ok 6\n");
-
-sub con {
- return wantarray()
-}
-
-# Same arguments yield different results in different contexts?
-memoize('con');
-$s = con(1);
-@a = con(1);
-print ((($s == $a[0]) ? 'not ' : ''), "ok 7\n");
-
-# Context propagated correctly?
-print ((($s eq '') ? '' : 'not '), "ok 8\n"); # Scalar context
-print ((("@a" eq '1' && @a == 1) ? '' : 'not '), "ok 9\n"); # List context
-
-# Context propagated correctly to normalizer?
-sub n {
- my $arg = shift;
- my $test = shift;
- if (wantarray) {
- print ((($arg eq ARRAY) ? '' : 'not '), "ok $test\n"); # List context
- } else {
- print ((($arg eq SCALAR) ? '' : 'not '), "ok $test\n"); # Scalar context
- }
-}
-
-sub f { 1 }
-memoize('f', NORMALIZER => 'n');
-$s = f('SCALAR', 10); # Test 10
-@a = f('ARRAY' , 11); # Test 11
-
+++ /dev/null
-#!/usr/bin/perl
-
-use lib '..';
-use Memoize 'memoize', 'unmemoize';
-
-sub reff {
- return [1,2,3];
-
-}
-
-sub listf {
- return (1,2,3);
-}
-
-print "1..6\n";
-
-memoize 'reff', LIST_CACHE => 'MERGE';
-print "ok 1\n";
-memoize 'listf';
-print "ok 2\n";
-
-$s = reff();
-@a = reff();
-print @a == 1 ? "ok 3\n" : "not ok 3\n";
-
-$s = listf();
-@a = listf();
-print @a == 3 ? "ok 4\n" : "not ok 4\n";
-
-unmemoize 'reff';
-memoize 'reff', LIST_CACHE => 'MERGE';
-unmemoize 'listf';
-memoize 'listf';
-
-@a = reff();
-$s = reff();
-print @a == 1 ? "ok 5\n" : "not ok 5\n";
-
-@a = listf();
-$s = listf();
-print @a == 3 ? "ok 6\n" : "not ok 6\n";
-
-
+++ /dev/null
-#!/usr/bin/perl
-
-use lib '..';
-use Memoize;
-
-print "1..25\n";
-
-print "# Basic\n";
-
-# A function that should only be called once.
-{ my $COUNT = 0;
- sub no_args {
- $FAIL++ if $COUNT++;
- 11;
- }
-}
-
-#
-memoize('no_args');
-
-$c1 = &no_args();
-print (($c1 == 11) ? "ok 1\n" : "not ok 1\n");
-$c2 = &no_args();
-print (($c2 == 11) ? "ok 2\n" : "not ok 2\n");
-print $FAIL ? "not ok 3\n" : "ok 3\n"; # Was it really memoized?
-
-$FAIL = 0;
-$f = do { my $COUNT = 0; sub { $FAIL++ if $COUNT++; 12 } };
-$fm = memoize($f);
-
-$c1 = &$fm();
-print (($c1 == 12) ? "ok 4\n" : "not ok 4\n");
-$c2 = &$fm();
-print (($c2 == 12) ? "ok 5\n" : "not ok 5\n");
-print $FAIL ? "not ok 6\n" : "ok 6\n"; # Was it really memoized?
-
-$f = do { my $COUNT = 0; sub { $FAIL++ if $COUNT++; 13 } };
-$fm = memoize($f, INSTALL => 'another');
-
-$c1 = &another(); # Was it really installed?
-print (($c1 == 13) ? "ok 7\n" : "not ok 7\n");
-$c2 = &another();
-print (($c2 == 13) ? "ok 8\n" : "not ok 8\n");
-print $FAIL ? "not ok 9\n" : "ok 9\n"; # Was it really memoized?
-$c3 = &$fm(); # Call memoized version through returned ref
-print (($c3 == 13) ? "ok 10\n" : "not ok 10\n");
-print $FAIL ? "not ok 11\n" : "ok 11\n"; # Was it really memoized?
-$c4 = &$f(); # Call original version again
-print (($c4 == 13) ? "ok 12\n" : "not ok 12\n");
-print $FAIL ? "ok 13\n" : "not ok 13\n"; # Did we get the original?
-
-print "# Fibonacci\n";
-
-sub mt1 { # Fibonacci
- my $n = shift;
- return $n if $n < 2;
- mt1($n-1) + mt2($n-2);
-}
-sub mt2 {
- my $n = shift;
- return $n if $n < 2;
- mt1($n-1) + mt2($n-2);
-}
-
-@f1 = map { mt1($_) } (0 .. 15);
-@f2 = map { mt2($_) } (0 .. 15);
-memoize('mt1');
-@f3 = map { mt1($_) } (0 .. 15);
-@f4 = map { mt1($_) } (0 .. 15);
-@arrays = (\@f1, \@f2, \@f3, \@f4);
-$n = 13;
-for ($i=0; $i<3; $i++) {
- for ($j=$i+1; $j<3; $j++) {
- $n++;
- print ((@{$arrays[$i]} == @{$arrays[$j]}) ? "ok $n\n" : "not ok $n\n");
- $n++;
- for ($k=0; $k < @{$arrays[$i]}; $k++) {
- (print "not ok $n\n", next) if $arrays[$i][$k] != $arrays[$j][$k];
- }
- print "ok $n\n";
- }
-}
-
-
-
-print "# Normalizers\n";
-
-sub fake_normalize {
- return '';
-}
-
-sub f1 {
- return shift;
-}
-sub f2 {
- return shift;
-}
-sub f3 {
- return shift;
-}
-&memoize('f1');
-&memoize('f2', NORMALIZER => 'fake_normalize');
-&memoize('f3', NORMALIZER => \&fake_normalize);
-@f1r = map { f1($_) } (1 .. 10);
-@f2r = map { f2($_) } (1 .. 10);
-@f3r = map { f3($_) } (1 .. 10);
-$n++;
-print (("@f1r" eq "1 2 3 4 5 6 7 8 9 10") ? "ok $n\n" : "not ok $n\n");
-$n++;
-print (("@f2r" eq "1 1 1 1 1 1 1 1 1 1") ? "ok $n\n" : "not ok $n\n");
-$n++;
-print (("@f3r" eq "1 1 1 1 1 1 1 1 1 1") ? "ok $n\n" : "not ok $n\n");
-
-print "# INSTALL => undef option.\n";
-{ my $i = 1;
- sub u1 { $i++ }
-}
-my $um = memoize('u1', INSTALL => undef);
-@umr = (&$um, &$um, &$um);
-@u1r = (&u1, &u1, &u1 ); # Did *not* clobber &u1
-$n++;
-print (("@umr" eq "1 1 1") ? "ok $n\n" : "not ok $n\n"); # Increment once
-$n++;
-print (("@u1r" eq "2 3 4") ? "ok $n\n" : "not ok $n\n"); # Increment thrice
-$n++;
-print ((defined &{"undef"}) ? "not ok $n\n" : "ok $n\n"); # Just in case
-
-print "# $n tests in all.\n";
-
+++ /dev/null
-#!/usr/bin/perl
-
-use lib '..';
-use Memoize;
-use Config;
-
-print "1..11\n";
-
-eval { memoize({}) };
-print $@ ? "ok 1\n" : "not ok 1 # $@\n";
-
-eval { memoize([]) };
-print $@ ? "ok 2\n" : "not ok 2 # $@\n";
-
-eval { my $x; memoize(\$x) };
-print $@ ? "ok 3\n" : "not ok 3 # $@\n";
-
-# 4--8
-$n = 4;
-my $dummyfile = './dummydb';
-use Fcntl;
-my %args = ( DB_File => [],
- GDBM_File => [$dummyfile, 2, 0666],
- ODBM_File => [$dummyfile, O_RDWR|O_CREAT, 0666],
- NDBM_File => [$dummyfile, O_RDWR|O_CREAT, 0666],
- SDBM_File => [$dummyfile, O_RDWR|O_CREAT, 0666],
- );
-for $mod (qw(DB_File GDBM_File SDBM_File ODBM_File NDBM_File)) {
- eval {
- require "$mod.pm";
- tie my %cache => $mod, @{$args{$mod}};
- memoize(sub {}, LIST_CACHE => [HASH => \%cache ]);
- };
- print $@ =~ /can only store scalars/
- || $@ =~ /Can't locate.*in \@INC/ ? "ok $n\n" : "not ok $n # $@\n";
- 1 while unlink $dummyfile;
- $n++;
-}
-
-# 9
-eval { local $^W = 0;
- memoize(sub {}, LIST_CACHE => ['TIE', 'WuggaWugga'])
- };
-print $@ ? "ok 9\n" : "not ok 9 # $@\n";
-
-# 10
-eval { memoize(sub {}, LIST_CACHE => 'YOB GORGLE') };
-print $@ ? "ok 10\n" : "not ok 10 # $@\n";
-
-# 11
-eval { memoize(sub {}, SCALAR_CACHE => ['YOB GORGLE']) };
-print $@ ? "ok 11\n" : "not ok 11 # $@\n";
-
+++ /dev/null
-#!/usr/bin/perl
-
-use lib '..';
-use Memoize;
-use Memoize::ExpireTest;
-
-my $n = 0;
-
-print "1..17\n";
-
-$n++; print "ok $n\n";
-
-my %CALLS;
-sub id {
- my($arg) = @_;
- ++$CALLS{$arg};
- $arg;
-}
-
-tie my %cache => 'Memoize::ExpireTest';
-memoize 'id',
- SCALAR_CACHE => [HASH => \%cache],
- LIST_CACHE => 'FAULT';
-$n++; print "ok $n\n";
-
-for $i (1, 2, 3, 1, 2, 1) {
- $n++;
- unless ($i == id($i)) {
- print "not ";
- }
- print "ok $n\n";
-}
-
-for $i (1, 2, 3) {
- $n++;
- unless ($CALLS{$i} == 1) {
- print "not ";
- }
- print "ok $n\n";
-}
-
-Memoize::ExpireTest::expire(1);
-
-for $i (1, 2, 3) {
- my $v = id($i);
-}
-
-for $i (1, 2, 3) {
- $n++;
- unless ($CALLS{$i} == 1 + ($i == 1)) {
- print "not ";
- }
- print "ok $n\n";
-}
-
-Memoize::ExpireTest::expire(1);
-Memoize::ExpireTest::expire(2);
-
-for $i (1, 2, 3) {
- my $v = id($i);
-}
-
-for $i (1, 2, 3) {
- $n++;
- unless ($CALLS{$i} == 4 - $i) {
- print "not ";
- }
- print "ok $n\n";
-}
-
-exit 0;
-
+++ /dev/null
-#!/usr/bin/perl
-
-use lib '..';
-use Memoize;
-
-my $n = 0;
-
-
-if (-e '.fast') {
- print "1..0\n";
- exit 0;
-}
-
-print "1..12\n";
-
-++$n; print "ok $n\n";
-
-my $READFILE_CALLS = 0;
-my $FILE = './TESTFILE';
-
-sub writefile {
- my $FILE = shift;
- open F, "> $FILE" or die "Couldn't write temporary file $FILE: $!";
- print F scalar(localtime), "\n";
- close F;
-}
-
-sub readfile {
- $READFILE_CALLS++;
- my $FILE = shift;
- open F, "< $FILE" or die "Couldn't write temporary file $FILE: $!";
- my $data = <F>;
- close F;
- $data;
-}
-
-require Memoize::ExpireFile;
-++$n; print "ok $n\n";
-
-tie my %cache => 'Memoize::ExpireFile';
-memoize 'readfile',
- SCALAR_CACHE => [HASH => \%cache],
- LIST_CACHE => 'FAULT'
- ;
-
-++$n; print "ok $n\n";
-
-writefile($FILE);
-++$n; print "ok $n\n";
-sleep 1;
-
-my $t1 = readfile($FILE);
-++$n; print "ok $n\n";
-++$n; print ((($READFILE_CALLS == 1) ? '' : 'not '), "ok $n\n");
-
-my $t2 = readfile($FILE);
-++$n; print "ok $n\n";
-++$n; print ((($READFILE_CALLS == 1) ? '' : 'not '), "ok $n\n");
-++$n; print ((($t1 eq $t2) ? '' : 'not '), "ok $n\n");
-
-sleep 2;
-writefile($FILE);
-my $t3 = readfile($FILE);
-++$n; print "ok $n\n";
-++$n; print ((($READFILE_CALLS == 2) ? '' : 'not '), "ok $n\n");
-++$n; print ((($t1 ne $t3) ? '' : 'not '), "ok $n\n");
-
-END { 1 while unlink $FILE }
+++ /dev/null
-#!/usr/bin/perl
-
-use lib '..';
-use Memoize;
-
-my $n = 0;
-
-
-print "1..22\n";
-
-++$n; print "ok $n\n";
-
-$RETURN = 1;
-
-%CALLS = ();
-sub call {
-# print "CALL $_[0] => $RETURN\n";
- ++$CALLS{$_[0]};
- $RETURN;
-}
-
-require Memoize::Expire;
-++$n; print "ok $n\n";
-
-tie my %cache => 'Memoize::Expire', NUM_USES => 2;
-memoize 'call',
- SCALAR_CACHE => [HASH => \%cache],
- LIST_CACHE => 'FAULT';
-
-# $Memoize::Expire::DEBUG = 1;
-++$n; print "ok $n\n";
-
-# 3--6
-for (0,1,2,3) {
- print "not " unless call($_) == 1;
- ++$n; print "ok $n\n";
-}
-
-# 7--10
-for (keys %CALLS) {
- print "not " unless $CALLS{$_} == (1,1,1,1)[$_];
- ++$n; print "ok $n\n";
-}
-
-# 11--13
-$RETURN = 2;
-++$n; print ((call(1) == 1 ? '' : 'not '), "ok $n\n"); # 1 expires
-++$n; print ((call(1) == 2 ? '' : 'not '), "ok $n\n"); # 1 gets new val
-++$n; print ((call(2) == 1 ? '' : 'not '), "ok $n\n"); # 2 expires
-
-# 14--17
-$RETURN = 3;
-for (0,1,2,3) {
- # 0 expires, 1 expires, 2 gets new val, 3 expires
- print "not " unless call($_) == (1,2,3,1)[$_];
- ++$n; print "ok $n\n";
-}
-
-for (0,1,2,3) {
- print "not " unless $CALLS{$_} == (1,2,2,1)[$_];
- ++$n; print "ok $n\n";
-}
+++ /dev/null
-#!/usr/bin/perl
-
-use lib '..';
-use Memoize;
-BEGIN {
- eval {require Time::HiRes};
- if ($@ || $ENV{SLOW}) {
-# $SLOW_TESTS = 1;
- } else {
- 'Time::HiRes'->import('time');
- }
-}
-
-my $DEBUG = 0;
-
-my $n = 0;
-$| = 1;
-
-if (-e '.fast') {
- print "1..0\n";
- exit 0;
-}
-
-# Perhaps nobody will notice if we don't say anything
-# print "# Warning: I'm testing the timed expiration policy.\n# This will take about thirty seconds.\n";
-
-print "1..15\n";
-$| = 1;
-
-++$n; print "ok $n\n";
-
-require Memoize::Expire;
-++$n; print "ok $n\n";
-
-sub close_enough {
-# print "Close enough? @_[0,1]\n";
- abs($_[0] - $_[1]) <= 1;
-}
-
-my $t0;
-sub start_timer {
- $t0 = time;
- $DEBUG and print "# $t0\n";
-}
-
-sub wait_until {
- my $until = shift();
- my $diff = $until - (time() - $t0);
- $DEBUG and print "# until $until; diff = $diff\n";
- return if $diff <= 0;
- select undef, undef, undef, $diff;
-}
-
-sub now {
-# print "NOW: @_ ", time(), "\n";
- time;
-}
-
-tie my %cache => 'Memoize::Expire', LIFETIME => 10;
-memoize 'now',
- SCALAR_CACHE => [HASH => \%cache ],
- LIST_CACHE => 'FAULT'
- ;
-
-++$n; print "ok $n\n";
-
-
-# T
-start_timer();
-for (1,2,3) {
- $when{$_} = now($_);
- ++$n;
- print "not " unless close_enough($when{$_}, time());
- print "ok $n\n";
- sleep 4 if $_ < 3;
- $DEBUG and print "# ", time()-$t0, "\n";
-}
-# values will now expire at T=10, 14, 18
-# it is now T=8
-
-# T+8
-for (1,2,3) {
- $again{$_} = now($_); # Should be the same as before, because of memoization
-}
-
-# T+8
-foreach (1,2,3) {
- ++$n;
- print "not " unless close_enough($when{$_}, $again{$_});
- print "ok $n\n";
-}
-
-wait_until(12); # now(1) expires
-print "not " unless close_enough(time, $again{1} = now(1));
-++$n; print "ok $n\n";
-
-# T+12
-foreach (2,3) { # Should not have expired yet.
- ++$n;
- print "not " unless close_enough(scalar(now($_)), $again{$_});
- print "ok $n\n";
-}
-
-wait_until(16); # now(2) expires
-
-# T+16
-print "not " unless close_enough(time, $again{2} = now(2));
-++$n; print "ok $n\n";
-
-# T+16
-foreach (1,3) { # 1 is good again because it was recomputed after it expired
- ++$n;
- print "not " unless close_enough(scalar(now($_)), $again{$_});
- print "ok $n\n";
-}
-
+++ /dev/null
-#!/usr/bin/perl
-
-use lib '..';
-use Memoize 'flush_cache', 'memoize';
-print "1..8\n";
-print "ok 1\n";
-
-
-
-my $V = 100;
-sub VAL { $V }
-
-memoize 'VAL';
-print "ok 2\n";
-
-my $c1 = VAL();
-print (($c1 == 100) ? "ok 3\n" : "not ok 3\n");
-
-$V = 200;
-$c1 = VAL();
-print (($c1 == 100) ? "ok 4\n" : "not ok 4\n");
-
-flush_cache('VAL');
-$c1 = VAL();
-print (($c1 == 200) ? "ok 5\n" : "not ok 5\n");
-
-$V = 300;
-$c1 = VAL();
-print (($c1 == 200) ? "ok 6\n" : "not ok 6\n");
-
-flush_cache(\&VAL);
-$c1 = VAL();
-print (($c1 == 300) ? "ok 7\n" : "not ok 7\n");
-
-$V = 400;
-$c1 = VAL();
-print (($c1 == 300) ? "ok 8\n" : "not ok 8\n");
-
-
-
-
-
+++ /dev/null
-#!/usr/bin/perl
-
-use lib '..';
-use Memoize;
-
-print "1..7\n";
-
-
-sub n_null { '' }
-
-{ my $I = 0;
- sub n_diff { $I++ }
-}
-
-{ my $I = 0;
- sub a1 { $I++; "$_[0]-$I" }
- my $J = 0;
- sub a2 { $J++; "$_[0]-$J" }
- my $K = 0;
- sub a3 { $K++; "$_[0]-$K" }
-}
-
-my $a_normal = memoize('a1', INSTALL => undef);
-my $a_nomemo = memoize('a2', INSTALL => undef, NORMALIZER => 'n_diff');
-my $a_allmemo = memoize('a3', INSTALL => undef, NORMALIZER => 'n_null');
-
-@ARGS = (1, 2, 3, 2, 1);
-
-@res = map { &$a_normal($_) } @ARGS;
-print ((("@res" eq "1-1 2-2 3-3 2-2 1-1") ? '' : 'not '), "ok 1\n");
-
-@res = map { &$a_nomemo($_) } @ARGS;
-print ((("@res" eq "1-1 2-2 3-3 2-4 1-5") ? '' : 'not '), "ok 2\n");
-
-@res = map { &$a_allmemo($_) } @ARGS;
-print ((("@res" eq "1-1 1-1 1-1 1-1 1-1") ? '' : 'not '), "ok 3\n");
-
-
-
-# Test fully-qualified name and installation
-$COUNT = 0;
-sub parity { $COUNT++; $_[0] % 2 }
-sub parnorm { $_[0] % 2 }
-memoize('parity', NORMALIZER => 'main::parnorm');
-@res = map { &parity($_) } @ARGS;
-print ((("@res" eq "1 0 1 0 1") ? '' : 'not '), "ok 4\n");
-print (( ($COUNT == 2) ? '' : 'not '), "ok 5\n");
-
-# Test normalization with reference to normalizer function
-$COUNT = 0;
-sub par2 { $COUNT++; $_[0] % 2 }
-memoize('par2', NORMALIZER => \&parnorm);
-@res = map { &par2($_) } @ARGS;
-print ((("@res" eq "1 0 1 0 1") ? '' : 'not '), "ok 6\n");
-print (( ($COUNT == 2) ? '' : 'not '), "ok 7\n");
-
-
+++ /dev/null
-#!/usr/bin/perl
-
-use lib '..';
-use Memoize;
-$EXPECTED_WARNING = '(no warning expected)';
-
-
-print "1..4\n";
-
-sub q1 ($) { $_[0] + 1 }
-sub q2 () { time }
-sub q3 { join "--", @_ }
-
-$SIG{__WARN__} = \&handle_warnings;
-
-$RES = 'ok';
-memoize 'q1';
-print "$RES 1\n";
-
-$RES = 'ok';
-memoize 'q2';
-print "$RES 2\n";
-
-$RES = 'ok';
-memoize 'q3';
-print "$RES 3\n";
-
-# Let's see if the prototype is actually honored
-@q = (1..5);
-$r = q1(@q);
-print (($r == 6) ? '' : 'not ', "ok 4\n");
-
-sub handle_warnings {
- print $_[0];
- $RES = 'not ok' unless $_[0] eq $EXPECTED_WARNING;
-}
+++ /dev/null
-#!/usr/bin/perl
-
-use lib '..';
-use Memoize;
-
-if (-e '.fast') {
- print "1..0\n";
- exit 0;
-}
-$| = 1;
-
-# If we don't say anything, maybe nobody will notice.
-# print STDERR "\nWarning: I'm testing the speedup. This might take up to thirty seconds.\n ";
-
-my $COARSE_TIME = 1;
-
-sub times_to_time { my ($u) = times; $u; }
-if ($^O eq 'riscos') {
- eval {require Time::HiRes; *my_time = \&Time::HiRes::time };
- if ($@) { *my_time = sub { time }; $COARSE_TIME = 1 }
-} else {
- *my_time = \×_to_time;
-}
-
-
-print "1..6\n";
-
-
-
-# This next test finds an example that takes a long time to run, then
-# checks to make sure that the run is actually speeded up by memoization.
-# In some sense, this is the most essential correctness test in the package.
-#
-# We do this by running the fib() function with successfily larger
-# arguments until we find one that tales at least $LONG_RUN seconds
-# to execute. Then we memoize fib() and run the same call cagain. If
-# it doesn't produce the same test in less than one-tenth the time,
-# something is seriously wrong.
-#
-# $LONG_RUN is the number of seconds that the function call must last
-# in order for the call to be considered sufficiently long.
-
-
-sub fib {
- my $n = shift;
- $COUNT++;
- return $n if $n < 2;
- fib($n-1) + fib($n-2);
-}
-
-sub max { $_[0] > $_[1] ?
- $_[0] : $_[1]
- }
-
-$N = 1;
-
-$ELAPSED = 0;
-
-my $LONG_RUN = 10;
-
-while (1) {
- my $start = time;
- $COUNT=0;
- $RESULT = fib($N);
- $ELAPSED = time - $start;
- last if $ELAPSED >= $LONG_RUN;
- if ($ELAPSED > 1) {
- print "# fib($N) took $ELAPSED seconds.\n" if $N % 1 == 0;
- # we'd expect that fib(n+1) takes about 1.618 times as long as fib(n)
- # so now that we have a longish run, let's estimate the value of $N
- # that will get us a sufficiently long run.
- $N += 1 + int(log($LONG_RUN/$ELAPSED)/log(1.618));
- print "# OK, N=$N ought to do it.\n";
- # It's important not to overshoot here because the running time
- # is exponential in $N. If we increase $N too aggressively,
- # the user will be forced to wait a very long time.
- } else {
- $N++;
- }
-}
-
-print "# OK, fib($N) was slow enough; it took $ELAPSED seconds.\n";
-print "# Total calls: $COUNT.\n";
-
-&memoize('fib');
-
-$COUNT=0;
-$start = time;
-$RESULT2 = fib($N);
-$ELAPSED2 = time - $start + .001; # prevent division by 0 errors
-
-print (($RESULT == $RESULT2) ? "ok 1\n" : "not ok 1\n");
-# If it's not ten times as fast, something is seriously wrong.
-print (($ELAPSED/$ELAPSED2 > 10) ? "ok 2\n" : "not ok 2\n");
-# If it called the function more than $N times, it wasn't memoized properly
-print (($COUNT > $N) ? "ok 3\n" : "not ok 3\n");
-
-# Do it again. Should be even faster this time.
-$COUNT = 0;
-$start = time;
-$RESULT2 = fib($N);
-$ELAPSED2 = time - $start + .001; # prevent division by 0 errors
-
-print (($RESULT == $RESULT2) ? "ok 4\n" : "not ok 4\n");
-print (($ELAPSED/$ELAPSED2 > 10) ? "ok 5\n" : "not ok 5\n");
-# This time it shouldn't have called the function at all.
-print ($COUNT == 0 ? "ok 6\n" : "not ok 6\n");
+++ /dev/null
-#!/usr/bin/perl
-
-use lib qw(. ..);
-use Memoize 0.52 qw(memoize unmemoize);
-use Fcntl;
-eval {require Memoize::AnyDBM_File};
-if ($@) {
- print "1..0\n";
- exit 0;
-}
-
-
-
-print "1..4\n";
-
-sub i {
- $_[0];
-}
-
-$ARG = 'Keith Bostic is a pinhead';
-
-sub c119 { 119 }
-sub c7 { 7 }
-sub c43 { 43 }
-sub c23 { 23 }
-sub c5 { 5 }
-
-sub n {
- $_[0]+1;
-}
-
-if (eval {require File::Spec::Functions}) {
- File::Spec::Functions->import('tmpdir', 'catfile');
- $tmpdir = tmpdir();
-} else {
- *catfile = sub { join '/', @_ };
- $tmpdir = $ENV{TMP} || $ENV{TMPDIR} || '/tmp';
-}
-$file = catfile($tmpdir, "md$$");
-@files = ($file, "$file.db", "$file.dir", "$file.pag");
-1 while unlink @files;
-
-
-tryout('Memoize::AnyDBM_File', $file, 1); # Test 1..4
-# tryout('DB_File', $file, 1); # Test 1..4
-1 while unlink $file, "$file.dir", "$file.pag";
-
-sub tryout {
- my ($tiepack, $file, $testno) = @_;
-
- tie my %cache => $tiepack, $file, O_RDWR | O_CREAT, 0666
- or die $!;
-
- memoize 'c5',
- SCALAR_CACHE => [HASH => \%cache],
- LIST_CACHE => 'FAULT'
- ;
-
- my $t1 = c5($ARG);
- my $t2 = c5($ARG);
- print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n");
- $testno++;
- print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n");
- unmemoize 'c5';
-
- # Now something tricky---we'll memoize c23 with the wrong table that
- # has the 5 already cached.
- memoize 'c23',
- SCALAR_CACHE => ['HASH', \%cache],
- LIST_CACHE => 'FAULT'
- ;
-
- my $t3 = c23($ARG);
- my $t4 = c23($ARG);
- $testno++;
- print (($t3 == 5) ? "ok $testno\n" : "not ok $testno # Result $t3\n");
- $testno++;
- print (($t4 == 5) ? "ok $testno\n" : "not ok $testno # Result $t4\n");
- unmemoize 'c23';
-}
-
-{
- my @present = grep -e, @files;
- if (@present && (@failed = grep { not unlink } @present)) {
- warn "Can't unlink @failed! ($!)";
- }
-}
+++ /dev/null
-#!/usr/bin/perl
-
-use lib qw(. ..);
-use Memoize 0.45 qw(memoize unmemoize);
-use Fcntl;
-
-sub i {
- $_[0];
-}
-
-sub c119 { 119 }
-sub c7 { 7 }
-sub c43 { 43 }
-sub c23 { 23 }
-sub c5 { 5 }
-
-sub n {
- $_[0]+1;
-}
-
-eval {require GDBM_File};
-if ($@) {
- print "1..0\n";
- exit 0;
-}
-
-print "1..4\n";
-
-if (eval {require File::Spec::Functions}) {
- File::Spec::Functions->import();
-} else {
- *catfile = sub { join '/', @_ };
-}
-$tmpdir = $ENV{TMP} || $ENV{TMPDIR} || '/tmp';
-$file = catfile($tmpdir, "md$$");
-1 while unlink $file, "$file.dir", "$file.pag";
-tryout('GDBM_File', $file, 1); # Test 1..4
-1 while unlink $file, "$file.dir", "$file.pag";
-
-sub tryout {
- require GDBM_File;
- my ($tiepack, $file, $testno) = @_;
-
- tie my %cache => $tiepack, $file, O_RDWR | O_CREAT, 0666
- or die $!;
-
- memoize 'c5',
- SCALAR_CACHE => [HASH => \%cache],
- LIST_CACHE => 'FAULT'
- ;
-
- my $t1 = c5();
- my $t2 = c5();
- print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n");
- $testno++;
- print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n");
- unmemoize 'c5';
-
- # Now something tricky---we'll memoize c23 with the wrong table that
- # has the 5 already cached.
- memoize 'c23',
- SCALAR_CACHE => [HASH => \%cache],
- LIST_CACHE => 'FAULT'
- ;
-
- my $t3 = c23();
- my $t4 = c23();
- $testno++;
- print (($t3 == 5) ? "ok $testno\n" : "not ok $testno\n");
- $testno++;
- print (($t4 == 5) ? "ok $testno\n" : "not ok $testno\n");
- unmemoize 'c23';
-}
-
+++ /dev/null
-#!/usr/bin/perl
-
-use lib qw(. ..);
-use Memoize 0.45 qw(memoize unmemoize);
-use Fcntl;
-# use Memoize::NDBM_File;
-# $Memoize::NDBM_File::Verbose = 0;
-
-sub i {
- $_[0];
-}
-
-sub c119 { 119 }
-sub c7 { 7 }
-sub c43 { 43 }
-sub c23 { 23 }
-sub c5 { 5 }
-
-sub n {
- $_[0]+1;
-}
-
-eval {require Memoize::NDBM_File};
-if ($@) {
- print "1..0\n";
- exit 0;
-}
-
-print "1..4\n";
-
-
-if (eval {require File::Spec::Functions}) {
- File::Spec::Functions->import();
-} else {
- *catfile = sub { join '/', @_ };
-}
-$tmpdir = $ENV{TMP} || $ENV{TMPDIR} || '/tmp';
-$file = catfile($tmpdir, "md$$");
-1 while unlink $file, "$file.dir", "$file.pag";
-tryout('Memoize::NDBM_File', $file, 1); # Test 1..4
-1 while unlink $file, "$file.dir", "$file.pag";
-
-sub tryout {
- my ($tiepack, $file, $testno) = @_;
-
-
- tie my %cache => $tiepack, $file, O_RDWR | O_CREAT, 0666
- or die $!;
-
- memoize 'c5',
- SCALAR_CACHE => [HASH => \%cache],
- LIST_CACHE => 'FAULT'
- ;
-
- my $t1 = c5();
- my $t2 = c5();
- print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n");
- $testno++;
- print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n");
- unmemoize 'c5';
-
- # Now something tricky---we'll memoize c23 with the wrong table that
- # has the 5 already cached.
- memoize 'c23',
- SCALAR_CACHE => [HASH => \%cache],
- LIST_CACHE => 'FAULT'
- ;
-
- my $t3 = c23();
- my $t4 = c23();
- $testno++;
- print (($t3 == 5) ? "ok $testno\n" : "not ok $testno\n");
- $testno++;
- print (($t4 == 5) ? "ok $testno\n" : "not ok $testno\n");
- unmemoize 'c23';
-}
-
+++ /dev/null
-#!/usr/bin/perl
-
-use lib qw(. ..);
-use Memoize 0.45 qw(memoize unmemoize);
-use Fcntl;
-# use Memoize::SDBM_File;
-# $Memoize::GDBM_File::Verbose = 0;
-
-sub i {
- $_[0];
-}
-
-sub c119 { 119 }
-sub c7 { 7 }
-sub c43 { 43 }
-sub c23 { 23 }
-sub c5 { 5 }
-
-sub n {
- $_[0]+1;
-}
-
-eval {require Memoize::SDBM_File};
-if ($@) {
- print "1..0\n";
- exit 0;
-}
-
-print "1..4\n";
-
-if (eval {require File::Spec::Functions}) {
- File::Spec::Functions->import('tmpdir', 'catfile');
- $tmpdir = tmpdir();
-} else {
- *catfile = sub { join '/', @_ };
- $tmpdir = $ENV{TMP} || $ENV{TMPDIR} || '/tmp';
-}
-$file = catfile($tmpdir, "md$$");
-1 while unlink $file, "$file.dir", "$file.pag";
-tryout('Memoize::SDBM_File', $file, 1); # Test 1..4
-1 while unlink $file, "$file.dir", "$file.pag";
-
-sub tryout {
- my ($tiepack, $file, $testno) = @_;
-
- tie my %cache => $tiepack, $file, O_RDWR | O_CREAT, 0666
- or die $!;
-
- memoize 'c5',
- SCALAR_CACHE => [HASH => \%cache],
- LIST_CACHE => 'FAULT'
- ;
-
- my $t1 = c5();
- my $t2 = c5();
- print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n");
- $testno++;
- print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n");
- unmemoize 'c5';
-
- # Now something tricky---we'll memoize c23 with the wrong table that
- # has the 5 already cached.
- memoize 'c23',
- SCALAR_CACHE => [HASH => \%cache],
- LIST_CACHE => 'FAULT'
- ;
-
- my $t3 = c23();
- my $t4 = c23();
- $testno++;
- print (($t3 == 5) ? "ok $testno\n" : "not ok $testno\n");
- $testno++;
- print (($t4 == 5) ? "ok $testno\n" : "not ok $testno\n");
- unmemoize 'c23';
-}
-
+++ /dev/null
-#!/usr/bin/perl
-# -*- mode: perl; perl-indent-level: 2 -*-
-
-use lib qw(. ..);
-use Memoize 0.45 qw(memoize unmemoize);
-# $Memoize::Storable::Verbose = 0;
-
-eval {require Memoize::Storable};
-if ($@) {
- print "1..0\n";
- exit 0;
-}
-
-sub i {
- $_[0];
-}
-
-sub c119 { 119 }
-sub c7 { 7 }
-sub c43 { 43 }
-sub c23 { 23 }
-sub c5 { 5 }
-
-sub n {
- $_[0]+1;
-}
-
-eval {require Storable};
-if ($@) {
- print "1..0\n";
- exit 0;
-}
-
-print "1..4\n";
-
-
-if (eval {require File::Spec::Functions}) {
- File::Spec::Functions->import();
-} else {
- *catfile = sub { join '/', @_ };
-}
-$tmpdir = $ENV{TMP} || $ENV{TMPDIR} || '/tmp';
-$file = catfile($tmpdir, "storable$$");
-1 while unlink $file;
-tryout('Memoize::Storable', $file, 1); # Test 1..4
-1 while unlink $file;
-
-sub tryout {
- my ($tiepack, $file, $testno) = @_;
-
- tie my %cache => $tiepack, $file
- or die $!;
-
- memoize 'c5',
- SCALAR_CACHE => [HASH => \%cache],
- LIST_CACHE => 'FAULT'
- ;
-
- my $t1 = c5();
- my $t2 = c5();
- print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n");
- $testno++;
- print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n");
- unmemoize 'c5';
- 1;
- 1;
-
- # Now something tricky---we'll memoize c23 with the wrong table that
- # has the 5 already cached.
- memoize 'c23',
- SCALAR_CACHE => [HASH => \%cache],
- LIST_CACHE => 'FAULT'
- ;
-
- my $t3 = c23();
- my $t4 = c23();
- $testno++;
- print (($t3 == 5) ? "ok $testno\n" : "not ok $testno\n");
- $testno++;
- print (($t4 == 5) ? "ok $testno\n" : "not ok $testno\n");
- unmemoize 'c23';
-}
-
+++ /dev/null
-#!/usr/bin/perl
-
-use lib 'blib/lib';
-use Memoize 0.45 qw(memoize unmemoize);
-use Fcntl;
-
-# print STDERR $INC{'Memoize.pm'}, "\n";
-
-print "1..10\n";
-
-# Test MERGE
-sub xx {
- wantarray();
-}
-
-my $s = xx();
-print ((!$s) ? "ok 1\n" : "not ok 1\n");
-my ($a) = xx();
-print (($a) ? "ok 2\n" : "not ok 2\n");
-memoize 'xx', LIST_CACHE => MERGE;
-$s = xx();
-print ((!$s) ? "ok 3\n" : "not ok 3\n");
-($a) = xx(); # Should return cached false value from previous invocation
-print ((!$a) ? "ok 4\n" : "not ok 4\n");
-
-
-# Test FAULT
-sub ns {}
-sub na {}
-memoize 'ns', SCALAR_CACHE => FAULT;
-memoize 'na', LIST_CACHE => FAULT;
-eval { my $s = ns() }; # Should fault
-print (($@) ? "ok 5\n" : "not ok 5\n");
-eval { my ($a) = na() }; # Should fault
-print (($@) ? "ok 6\n" : "not ok 6\n");
-
-
-# Test HASH
-my (%s, %l);
-sub nul {}
-memoize 'nul', SCALAR_CACHE => [HASH => \%s], LIST_CACHE => [HASH => \%l];
-nul('x');
-nul('y');
-print ((join '', sort keys %s) eq 'xy' ? "ok 7\n" : "not ok 7\n");
-print ((join '', sort keys %l) eq '' ? "ok 8\n" : "not ok 8\n");
-() = nul('p');
-() = nul('q');
-print ((join '', sort keys %s) eq 'xy' ? "ok 9\n" : "not ok 9\n");
-print ((join '', sort keys %l) eq 'pq' ? "ok 10\n" : "not ok 10\n");
-
+++ /dev/null
-#!/usr/bin/perl
-
-use lib '..';
-use Memoize qw(memoize unmemoize);
-
-print "1..5\n";
-
-eval { unmemoize('f') }; # Should fail
-print (($@ ? '' : 'not '), "ok 1\n");
-
-{ my $I = 0;
- sub u { $I++ }
-}
-memoize('u');
-my @ur = (&u, &u, &u);
-print (("@ur" eq "0 0 0") ? "ok 2\n" : "not ok 2\n");
-
-eval { unmemoize('u') }; # Should succeed
-print ($@ ? "not ok 3\n" : "ok 3\n");
-
-@ur = (&u, &u, &u);
-print (("@ur" eq "1 2 3") ? "ok 4\n" : "not ok 4\n");
-
-eval { unmemoize('u') }; # Should fail
-print ($@ ? "ok 5\n" : "not ok 5\n");
-
+++ /dev/null
-BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir('t') if -d 't';
- @INC = qw(../lib);
- }
-}
-
-BEGIN { print "1..9\n"; }
-use NEXT;
-
-my $count=1;
-
-package A;
-@ISA = qw/B C D/;
-
-sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::test;}
-
-package B;
-@ISA = qw/C D/;
-sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::test;}
-
-package C;
-@ISA = qw/D/;
-sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::test;}
-
-package D;
-
-sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::test;}
-
-package main;
-
-my $foo = {};
-
-bless($foo,"A");
-
-eval { $foo->test } and print "not ";
-print "ok 9\n";
+++ /dev/null
-BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir('t') if -d 't';
- @INC = qw(../lib);
- }
-}
-
-BEGIN { print "1..5\n"; }
-use NEXT;
-
-my $count=1;
-
-package A;
-@ISA = qw/B C D/;
-
-sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::ACTUAL::test;}
-
-package B;
-@ISA = qw/C D/;
-sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::UNSEEN::test;}
-
-package C;
-@ISA = qw/D/;
-sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::ACTUAL::test;}
-
-package D;
-
-sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::UNSEEN::test;}
-
-package main;
-
-my $foo = {};
-
-bless($foo,"A");
-
-eval { $foo->test } and print "not ";
-print "ok 5\n";
+++ /dev/null
-BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir('t') if -d 't';
- @INC = qw(../lib);
- }
-}
-
-BEGIN { print "1..25\n"; }
-
-use NEXT;
-
-print "ok 1\n";
-
-package A;
-sub A::method { return ( 3, $_[0]->NEXT::method() ) }
-sub A::DESTROY { $_[0]->NEXT::DESTROY() }
-
-package B;
-use base qw( A );
-sub B::AUTOLOAD { return ( 9, $_[0]->NEXT::AUTOLOAD() )
- if $AUTOLOAD =~ /.*(missing_method|secondary)/ }
-sub B::DESTROY { $_[0]->NEXT::DESTROY() }
-
-package C;
-sub C::DESTROY { print "ok 23\n"; $_[0]->NEXT::DESTROY() }
-
-package D;
-@D::ISA = qw( B C E );
-sub D::method { return ( 2, $_[0]->NEXT::method() ) }
-sub D::AUTOLOAD { return ( 8, $_[0]->NEXT::AUTOLOAD() ) }
-sub D::DESTROY { print "ok 22\n"; $_[0]->NEXT::DESTROY() }
-sub D::oops { $_[0]->NEXT::method() }
-sub D::secondary { return ( 17, 18, map { $_+10 } $_[0]->NEXT::secondary() ) }
-
-package E;
-@E::ISA = qw( F G );
-sub E::method { return ( 4, $_[0]->NEXT::method(), $_[0]->NEXT::method() ) }
-sub E::AUTOLOAD { return ( 10, $_[0]->NEXT::AUTOLOAD() )
- if $AUTOLOAD =~ /.*(missing_method|secondary)/ }
-sub E::DESTROY { print "ok 24\n"; $_[0]->NEXT::DESTROY() }
-
-package F;
-sub F::method { return ( 5 ) }
-sub F::AUTOLOAD { return ( 11 ) if $AUTOLOAD =~ /.*(missing_method|secondary)/ }
-sub F::DESTROY { print "ok 25\n" }
-
-package G;
-sub G::method { return ( 6 ) }
-sub G::AUTOLOAD { print "not "; return }
-sub G::DESTROY { print "not ok 21"; return }
-
-package main;
-
-my $obj = bless {}, "D";
-
-my @vals;
-
-# TEST NORMAL REDISPATCH (ok 2..6)
-@vals = $obj->method();
-print map "ok $_\n", @vals;
-
-# RETEST NORMAL REDISPATCH SHOULD BE THE SAME (ok 7)
-@vals = $obj->method();
-print "not " unless join("", @vals) == "23456";
-print "ok 7\n";
-
-# TEST AUTOLOAD REDISPATCH (ok 8..11)
-@vals = $obj->missing_method();
-print map "ok $_\n", @vals;
-
-# NAMED METHOD CAN'T REDISPATCH TO NAMED METHOD OF DIFFERENT NAME (ok 12)
-eval { $obj->oops() } && print "not ";
-print "ok 12\n";
-
-# AUTOLOAD'ED METHOD CAN'T REDISPATCH TO NAMED METHOD (ok 13)
-
-eval {
- local *C::AUTOLOAD = sub { $_[0]->NEXT::method() };
- *C::AUTOLOAD = *C::AUTOLOAD;
- eval { $obj->missing_method(); } && print "not ";
-};
-print "ok 13\n";
-
-# NAMED METHOD CAN'T REDISPATCH TO AUTOLOAD'ED METHOD (ok 14)
-eval {
- *C::method = sub{ $_[0]->NEXT::AUTOLOAD() };
- *C::method = *C::method;
- eval { $obj->method(); } && print "not ";
-};
-print "ok 14\n";
-
-# BASE CLASS METHODS ONLY REDISPATCHED WITHIN HIERARCHY (ok 15..16)
-my $ob2 = bless {}, "B";
-@val = $ob2->method();
-print "not " unless @val==1 && $val[0]==3;
-print "ok 15\n";
-
-@val = $ob2->missing_method();
-print "not " unless @val==1 && $val[0]==9;
-print "ok 16\n";
-
-# TEST SECONDARY AUTOLOAD REDISPATCH (ok 17..21)
-@vals = $obj->secondary();
-print map "ok $_\n", @vals;
-
-# CAN REDISPATCH DESTRUCTORS (ok 22..25)
+++ /dev/null
-BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir('t') if -d 't';
- @INC = qw(../lib);
- }
-}
-
-BEGIN { print "1..4\n"; }
-use NEXT;
-
-my $count=1;
-
-package A;
-@ISA = qw/B C D/;
-
-sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::test;}
-
-package B;
-@ISA = qw/C D/;
-sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::test;}
-
-package C;
-@ISA = qw/D/;
-sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::test;}
-
-package D;
-
-sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::test;}
-
-package main;
-
-my $foo = {};
-
-bless($foo,"A");
-
-$foo->test;
+++ /dev/null
-#! /usr/local/bin/perl -w
-
-use Carp;
-use Switch qw(Perl6 __ fallthrough);
-
-my($C,$M);sub ok{$C++;$M.=$_[0]?"ok $C\n":"not ok $C (line ".(caller)[2].")\n"}
-END{print"1..$C\n$M"}
-
-# NON-when THINGS;
-
-$when->{when} = { when => "when" };
-
-*when = \&when;
-
-# PREMATURE when
-
-eval { when 1: { ok(0) }; ok(0) } || ok(1);
-
-# H.O. FUNCS
-
-given (__ > 2) {
-
- when 1: { ok(0) } else { ok(1) }
- when 2: { ok(0) } else { ok(1) }
- when 3: { ok(1) } else { ok(0) }
-}
-
-given (3) {
-
- eval { when __ <= 1 || __ > 2: { ok(0) } } || ok(1);
- when __ <= 2: { ok(0) };
- when __ <= 3: { ok(1) };
-}
-
-# POSSIBLE ARGS: NUMERIC, STRING, ARRAY, HASH, REGEX, CODE
-
-# 1. NUMERIC SWITCH
-
-for (1..3)
-{
- given ($_) {
- # SELF
- when $_: { ok(1) } else { ok(0) }
-
- # NUMERIC
- when 1: { ok ($_==1) } else { ok($_!=1) }
- when (1): { ok ($_==1) } else { ok($_!=1) }
- when 3: { ok ($_==3) } else { ok($_!=3) }
- when (4): { ok (0) } else { ok(1) }
- when (2): { ok ($_==2) } else { ok($_!=2) }
-
- # STRING
- when ('a'): { ok (0) } else { ok(1) }
- when 'a' : { ok (0) } else { ok(1) }
- when ('3'): { ok ($_ == 3) } else { ok($_ != 3) }
- when ('3.0'): { ok (0) } else { ok(1) }
-
- # ARRAY
- when ([10,5,1]): { ok ($_==1) } else { ok($_!=1) }
- when [10,5,1]: { ok ($_==1) } else { ok($_!=1) }
- when (['a','b']): { ok (0) } else { ok(1) }
- when (['a','b',3]): { ok ($_==3) } else { ok ($_!=3) }
- when (['a','b',2.0]) : { ok ($_==2) } else { ok ($_!=2) }
- when ([]) : { ok (0) } else { ok(1) }
-
- # HASH
- when ({}) : { ok (0) } else { ok (1) }
- when {} : { ok (0) } else { ok (1) }
- when {1,1} : { ok ($_==1) } else { ok($_!=1) }
- when ({1=>1, 2=>0}) : { ok ($_==1) } else { ok($_!=1) }
-
- # SUB/BLOCK
- when (sub {$_[0]==2}) : { ok ($_==2) } else { ok($_!=2) }
- when {$_[0]==2} : { ok ($_==2) } else { ok($_!=2) }
- when {0} : { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
- when {1} : { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH
- }
-}
-
-
-# 2. STRING SWITCH
-
-for ('a'..'c','1')
-{
- given ($_) {
- # SELF
- when ($_) : { ok(1) } else { ok(0) }
-
- # NUMERIC
- when (1) : { ok ($_ !~ /[a-c]/) } else { ok ($_ =~ /[a-c]/) }
- when (1.0) : { ok ($_ !~ /[a-c]/) } else { ok ($_ =~ /[a-c]/) }
-
- # STRING
- when ('a') : { ok ($_ eq 'a') } else { ok($_ ne 'a') }
- when ('b') : { ok ($_ eq 'b') } else { ok($_ ne 'b') }
- when ('c') : { ok ($_ eq 'c') } else { ok($_ ne 'c') }
- when ('1') : { ok ($_ eq '1') } else { ok($_ ne '1') }
- when ('d') : { ok (0) } else { ok (1) }
-
- # ARRAY
- when (['a','1']) : { ok ($_ eq 'a' || $_ eq '1') }
- else { ok ($_ ne 'a' && $_ ne '1') }
- when (['z','2']) : { ok (0) } else { ok(1) }
- when ([]) : { ok (0) } else { ok(1) }
-
- # HASH
- when ({}) : { ok (0) } else { ok (1) }
- when ({a=>'a', 1=>1, 2=>0}) : { ok ($_ eq 'a' || $_ eq '1') }
- else { ok ($_ ne 'a' && $_ ne '1') }
-
- # SUB/BLOCK
- when (sub{$_[0] eq 'a' }) : { ok ($_ eq 'a') }
- else { ok($_ ne 'a') }
- when {$_[0] eq 'a'} : { ok ($_ eq 'a') } else { ok($_ ne 'a') }
- when {0} : { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
- when {1} : { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH
- }
-}
-
-
-# 3. ARRAY SWITCH
-
-my $iteration = 0;
-for ([],[1,'a'],[2,'b'])
-{
- given ($_) {
- $iteration++;
- # SELF
- when ($_) : { ok(1) }
-
- # NUMERIC
- when (1) : { ok ($iteration==2) } else { ok ($iteration!=2) }
- when (1.0) : { ok ($iteration==2) } else { ok ($iteration!=2) }
-
- # STRING
- when ('a') : { ok ($iteration==2) } else { ok ($iteration!=2) }
- when ('b') : { ok ($iteration==3) } else { ok ($iteration!=3) }
- when ('1') : { ok ($iteration==2) } else { ok ($iteration!=2) }
-
- # ARRAY
- when (['a',2]) : { ok ($iteration>=2) } else { ok ($iteration<2) }
- when ([1,'a']) : { ok ($iteration==2) } else { ok($iteration!=2) }
- when ([]) : { ok (0) } else { ok(1) }
- when ([7..100]) : { ok (0) } else { ok(1) }
-
- # HASH
- when ({}) : { ok (0) } else { ok (1) }
- when ({a=>'a', 1=>1, 2=>0}) : { ok ($iteration==2) }
- else { ok ($iteration!=2) }
-
- # SUB/BLOCK
- when {scalar grep /a/, @_} : { ok ($iteration==2) }
- else { ok ($iteration!=2) }
- when (sub {scalar grep /a/, @_ }) : { ok ($iteration==2) }
- else { ok ($iteration!=2) }
- when {0} : { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
- when {1} : { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH
- }
-}
-
-
-# 4. HASH SWITCH
-
-$iteration = 0;
-for ({},{a=>1,b=>0})
-{
- given ($_) {
- $iteration++;
-
- # SELF
- when ($_) : { ok(1) } else { ok(0) }
-
- # NUMERIC
- when (1) : { ok (0) } else { ok (1) }
- when (1.0) : { ok (0) } else { ok (1) }
-
- # STRING
- when ('a') : { ok ($iteration==2) } else { ok ($iteration!=2) }
- when ('b') : { ok (0) } else { ok (1) }
- when ('c') : { ok (0) } else { ok (1) }
-
- # ARRAY
- when (['a',2]) : { ok ($iteration==2) }
- else { ok ($iteration!=2) }
- when (['b','a']) : { ok ($iteration==2) }
- else { ok ($iteration!=2) }
- when (['b','c']) : { ok (0) } else { ok (1) }
- when ([]) : { ok (0) } else { ok(1) }
- when ([7..100]) : { ok (0) } else { ok(1) }
-
- # HASH
- when ({}) : { ok (0) } else { ok (1) }
- when ({a=>'a', 1=>1, 2=>0}) : { ok (0) } else { ok (1) }
-
- # SUB/BLOCK
- when {$_[0]{a}} : { ok ($iteration==2) }
- else { ok ($iteration!=2) }
- when (sub {$_[0]{a}}) : { ok ($iteration==2) }
- else { ok ($iteration!=2) }
- when {0} : { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
- when {1} : { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH
- }
-}
-
-
-# 5. CODE SWITCH
-
-$iteration = 0;
-for ( sub {1},
- sub { return 0 unless @_;
- my ($data) = @_;
- my $type = ref $data;
- return $type eq 'HASH' && $data->{a}
- || $type eq 'Regexp' && 'a' =~ /$data/
- || $type eq "" && $data eq '1';
- },
- sub {0} )
-{
- given ($_) {
- $iteration++;
- # SELF
- when ($_) : { ok(1) } else { ok(0) }
-
- # NUMERIC
- when (1) : { ok ($iteration<=2) } else { ok ($iteration>2) }
- when (1.0) : { ok ($iteration<=2) } else { ok ($iteration>2) }
- when (1.1) : { ok ($iteration==1) } else { ok ($iteration!=1) }
-
- # STRING
- when ('a') : { ok ($iteration==1) } else { ok ($iteration!=1) }
- when ('b') : { ok ($iteration==1) } else { ok ($iteration!=1) }
- when ('c') : { ok ($iteration==1) } else { ok ($iteration!=1) }
- when ('1') : { ok ($iteration<=2) } else { ok ($iteration>2) }
-
- # ARRAY
- when ([1, 'a']) : { ok ($iteration<=2) }
- else { ok ($iteration>2) }
- when (['b','a']) : { ok ($iteration==1) }
- else { ok ($iteration!=1) }
- when (['b','c']) : { ok ($iteration==1) }
- else { ok ($iteration!=1) }
- when ([]) : { ok ($iteration==1) } else { ok($iteration!=1) }
- when ([7..100]) : { ok ($iteration==1) }
- else { ok($iteration!=1) }
-
- # HASH
- when ({}) : { ok ($iteration==1) } else { ok ($iteration!=1) }
- when ({a=>'a', 1=>1, 2=>0}) : { ok ($iteration<=2) }
- else { ok ($iteration>2) }
-
- # SUB/BLOCK
- when {$_[0]->{a}} : { ok (0) } else { ok (1) }
- when (sub {$_[0]{a}}) : { ok (0) } else { ok (1) }
- when {0} : { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
- when {1} : { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
- }
-}
-
-
-# NESTED SWITCHES
-
-for my $count (1..3)
-{
- given ([9,"a",11]) {
- when (qr/\d/) : {
- given ($count) {
- when (1) : { ok($count==1) }
- else { ok($count!=1) }
- when ([5,6]) : { ok(0) } else { ok(1) }
- }
- }
- ok(1) when 11;
- }
-}
+++ /dev/null
-use Switch;
-
-print "1..4\n";
-
-my $count = 1;
-for my $count (1..3, 'four')
-{
- switch ([$count])
- {
-
-=pod
-
-=head1 Test
-
-We also test if Switch is POD-friendly here
-
-=cut
-
- case qr/\d/ {
- switch ($count) {
- case 1 { print "ok 1\n" }
- case [2,3] { print "ok $count\n" }
- }
- }
- case 'four' { print "ok 4\n" }
- }
-}
-
-__END__
-
-=head1 Another test
-
-Still friendly???
-
-=cut
+++ /dev/null
-#! /usr/local/bin/perl -w
-
-use Carp;
-use Switch qw(__ fallthrough);
-
-my($C,$M);sub ok{$C++;$M.=$_[0]?"ok $C\n":"not ok $C (line ".(caller)[2].")\n"}
-END{print"1..$C\n$M"}
-
-# NON-case THINGS;
-
-$case->{case} = { case => "case" };
-
-*case = \&case;
-
-# PREMATURE case
-
-eval { case 1 { ok(0) }; ok(0) } || ok(1);
-
-# H.O. FUNCS
-
-switch (__ > 2) {
-
- case 1 { ok(0) } else { ok(1) }
- case 2 { ok(0) } else { ok(1) }
- case 3 { ok(1) } else { ok(0) }
-}
-
-switch (3) {
-
- eval { case __ <= 1 || __ > 2 { ok(0) } } || ok(1);
- case __ <= 2 { ok(0) };
- case __ <= 3 { ok(1) };
-}
-
-# POSSIBLE ARGS: NUMERIC, STRING, ARRAY, HASH, REGEX, CODE
-
-# 1. NUMERIC SWITCH
-
-for (1..3)
-{
- switch ($_) {
- # SELF
- case ($_) { ok(1) } else { ok(0) }
-
- # NUMERIC
- case (1) { ok ($_==1) } else { ok($_!=1) }
- case 1 { ok ($_==1) } else { ok($_!=1) }
- case (3) { ok ($_==3) } else { ok($_!=3) }
- case (4) { ok (0) } else { ok(1) }
- case (2) { ok ($_==2) } else { ok($_!=2) }
-
- # STRING
- case ('a') { ok (0) } else { ok(1) }
- case 'a' { ok (0) } else { ok(1) }
- case ('3') { ok ($_ == 3) } else { ok($_ != 3) }
- case ('3.0') { ok (0) } else { ok(1) }
-
- # ARRAY
- case ([10,5,1]) { ok ($_==1) } else { ok($_!=1) }
- case [10,5,1] { ok ($_==1) } else { ok($_!=1) }
- case (['a','b']) { ok (0) } else { ok(1) }
- case (['a','b',3]) { ok ($_==3) } else { ok ($_!=3) }
- case (['a','b',2.0]) { ok ($_==2) } else { ok ($_!=2) }
- case ([]) { ok (0) } else { ok(1) }
-
- # HASH
- case ({}) { ok (0) } else { ok (1) }
- case {} { ok (0) } else { ok (1) }
- case {1,1} { ok ($_==1) } else { ok($_!=1) }
- case ({1=>1, 2=>0}) { ok ($_==1) } else { ok($_!=1) }
-
- # SUB/BLOCK
- case (sub {$_[0]==2}) { ok ($_==2) } else { ok($_!=2) }
- case {$_[0]==2} { ok ($_==2) } else { ok($_!=2) }
- case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
- case {1} { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH
- }
-}
-
-
-# 2. STRING SWITCH
-
-for ('a'..'c','1')
-{
- switch ($_) {
- # SELF
- case ($_) { ok(1) } else { ok(0) }
-
- # NUMERIC
- case (1) { ok ($_ !~ /[a-c]/) } else { ok ($_ =~ /[a-c]/) }
- case (1.0) { ok ($_ !~ /[a-c]/) } else { ok ($_ =~ /[a-c]/) }
-
- # STRING
- case ('a') { ok ($_ eq 'a') } else { ok($_ ne 'a') }
- case ('b') { ok ($_ eq 'b') } else { ok($_ ne 'b') }
- case ('c') { ok ($_ eq 'c') } else { ok($_ ne 'c') }
- case ('1') { ok ($_ eq '1') } else { ok($_ ne '1') }
- case ('d') { ok (0) } else { ok (1) }
-
- # ARRAY
- case (['a','1']) { ok ($_ eq 'a' || $_ eq '1') }
- else { ok ($_ ne 'a' && $_ ne '1') }
- case (['z','2']) { ok (0) } else { ok(1) }
- case ([]) { ok (0) } else { ok(1) }
-
- # HASH
- case ({}) { ok (0) } else { ok (1) }
- case ({a=>'a', 1=>1, 2=>0}) { ok ($_ eq 'a' || $_ eq '1') }
- else { ok ($_ ne 'a' && $_ ne '1') }
-
- # SUB/BLOCK
- case (sub{$_[0] eq 'a' }) { ok ($_ eq 'a') }
- else { ok($_ ne 'a') }
- case {$_[0] eq 'a'} { ok ($_ eq 'a') } else { ok($_ ne 'a') }
- case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
- case {1} { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH
- }
-}
-
-
-# 3. ARRAY SWITCH
-
-my $iteration = 0;
-for ([],[1,'a'],[2,'b'])
-{
- switch ($_) {
- $iteration++;
- # SELF
- case ($_) { ok(1) }
-
- # NUMERIC
- case (1) { ok ($iteration==2) } else { ok ($iteration!=2) }
- case (1.0) { ok ($iteration==2) } else { ok ($iteration!=2) }
-
- # STRING
- case ('a') { ok ($iteration==2) } else { ok ($iteration!=2) }
- case ('b') { ok ($iteration==3) } else { ok ($iteration!=3) }
- case ('1') { ok ($iteration==2) } else { ok ($iteration!=2) }
-
- # ARRAY
- case (['a',2]) { ok ($iteration>=2) } else { ok ($iteration<2) }
- case ([1,'a']) { ok ($iteration==2) } else { ok($iteration!=2) }
- case ([]) { ok (0) } else { ok(1) }
- case ([7..100]) { ok (0) } else { ok(1) }
-
- # HASH
- case ({}) { ok (0) } else { ok (1) }
- case ({a=>'a', 1=>1, 2=>0}) { ok ($iteration==2) }
- else { ok ($iteration!=2) }
-
- # SUB/BLOCK
- case {scalar grep /a/, @_} { ok ($iteration==2) }
- else { ok ($iteration!=2) }
- case (sub {scalar grep /a/, @_ }) { ok ($iteration==2) }
- else { ok ($iteration!=2) }
- case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
- case {1} { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH
- }
-}
-
-
-# 4. HASH SWITCH
-
-$iteration = 0;
-for ({},{a=>1,b=>0})
-{
- switch ($_) {
- $iteration++;
-
- # SELF
- case ($_) { ok(1) } else { ok(0) }
-
- # NUMERIC
- case (1) { ok (0) } else { ok (1) }
- case (1.0) { ok (0) } else { ok (1) }
-
- # STRING
- case ('a') { ok ($iteration==2) } else { ok ($iteration!=2) }
- case ('b') { ok (0) } else { ok (1) }
- case ('c') { ok (0) } else { ok (1) }
-
- # ARRAY
- case (['a',2]) { ok ($iteration==2) }
- else { ok ($iteration!=2) }
- case (['b','a']) { ok ($iteration==2) }
- else { ok ($iteration!=2) }
- case (['b','c']) { ok (0) } else { ok (1) }
- case ([]) { ok (0) } else { ok(1) }
- case ([7..100]) { ok (0) } else { ok(1) }
-
- # HASH
- case ({}) { ok (0) } else { ok (1) }
- case ({a=>'a', 1=>1, 2=>0}) { ok (0) } else { ok (1) }
-
- # SUB/BLOCK
- case {$_[0]{a}} { ok ($iteration==2) }
- else { ok ($iteration!=2) }
- case (sub {$_[0]{a}}) { ok ($iteration==2) }
- else { ok ($iteration!=2) }
- case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
- case {1} { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH
- }
-}
-
-
-# 5. CODE SWITCH
-
-$iteration = 0;
-for ( sub {1},
- sub { return 0 unless @_;
- my ($data) = @_;
- my $type = ref $data;
- return $type eq 'HASH' && $data->{a}
- || $type eq 'Regexp' && 'a' =~ /$data/
- || $type eq "" && $data eq '1';
- },
- sub {0} )
-{
- switch ($_) {
- $iteration++;
- # SELF
- case ($_) { ok(1) } else { ok(0) }
-
- # NUMERIC
- case (1) { ok ($iteration<=2) } else { ok ($iteration>2) }
- case (1.0) { ok ($iteration<=2) } else { ok ($iteration>2) }
- case (1.1) { ok ($iteration==1) } else { ok ($iteration!=1) }
-
- # STRING
- case ('a') { ok ($iteration==1) } else { ok ($iteration!=1) }
- case ('b') { ok ($iteration==1) } else { ok ($iteration!=1) }
- case ('c') { ok ($iteration==1) } else { ok ($iteration!=1) }
- case ('1') { ok ($iteration<=2) } else { ok ($iteration>2) }
-
- # ARRAY
- case ([1, 'a']) { ok ($iteration<=2) }
- else { ok ($iteration>2) }
- case (['b','a']) { ok ($iteration==1) }
- else { ok ($iteration!=1) }
- case (['b','c']) { ok ($iteration==1) }
- else { ok ($iteration!=1) }
- case ([]) { ok ($iteration==1) } else { ok($iteration!=1) }
- case ([7..100]) { ok ($iteration==1) }
- else { ok($iteration!=1) }
-
- # HASH
- case ({}) { ok ($iteration==1) } else { ok ($iteration!=1) }
- case ({a=>'a', 1=>1, 2=>0}) { ok ($iteration<=2) }
- else { ok ($iteration>2) }
-
- # SUB/BLOCK
- case {$_[0]->{a}} { ok (0) } else { ok (1) }
- case (sub {$_[0]{a}}) { ok (0) } else { ok (1) }
- case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
- case {1} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
- }
-}
-
-
-# NESTED SWITCHES
-
-for my $count (1..3)
-{
- switch ([9,"a",11]) {
- case (qr/\d/) {
- switch ($count) {
- case (1) { ok($count==1) }
- else { ok($count!=1) }
- case ([5,6]) { ok(0) } else { ok(1) }
- }
- }
- ok(1) case (11);
- }
-}
+++ /dev/null
-#!./perl -w
-
-BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir 't' if -d 't';
- @INC = '../lib';
- }
- undef *{Socket::inet_aton};
- undef *{Socket::inet_ntoa};
- if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
- print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
- }
- $INC{'Socket.pm'} = 1;
-}
-
-package Socket;
-
-sub import {
- my $pkg = caller();
- no strict 'refs';
- *{ $pkg . '::inet_aton' } = \&inet_aton;
- *{ $pkg . '::inet_ntoa' } = \&inet_ntoa;
-}
-
-my $fail = 0;
-my %names;
-
-sub set_fail {
- $fail = shift;
-}
-
-sub inet_aton {
- return if $fail;
- my $num = unpack('N', pack('C*', split(/\./, $_[0])));
- $names{$num} = $_[0];
- return $num;
-}
-
-sub inet_ntoa {
- return if $fail;
- return $names{$_[0]};
-}
-
-package main;
-
-
-(my $libnet_t = __FILE__) =~ s/config.t/libnet_t.pl/;
-require $libnet_t;
-
-print "1..10\n";
-
-use Net::Config;
-ok( exists $INC{'Net/Config.pm'}, 'Net::Config should have been used' );
-ok( keys %NetConfig, '%NetConfig should be imported' );
-
-Socket::set_fail(1);
-undef $NetConfig{'ftp_firewall'};
-is( Net::Config->requires_firewall(), 0,
- 'requires_firewall() should return 0 without ftp_firewall defined' );
-
-$NetConfig{'ftp_firewall'} = 1;
-is( Net::Config->requires_firewall('a.host.not.there'), -1,
- '... should return -1 without a valid hostname' );
-
-Socket::set_fail(0);
-delete $NetConfig{'local_netmask'};
-is( Net::Config->requires_firewall('127.0.0.1'), 0,
- '... should return 0 without local_netmask defined' );
-
-$NetConfig{'local_netmask'} = '127.0.0.1/24';
-is( Net::Config->requires_firewall('127.0.0.1'), 0,
- '... should return false if host is within netmask' );
-is( Net::Config->requires_firewall('192.168.10.0'), 1,
- '... should return true if host is outside netmask' );
-
-# now try more netmasks
-$NetConfig{'local_netmask'} = [ '127.0.0.1/24', '10.0.0.0/8' ];
-is( Net::Config->requires_firewall('10.10.255.254'), 0,
- '... should find success with mutiple local netmasks' );
-is( Net::Config->requires_firewall('192.168.10.0'), 1,
- '... should handle failure with multiple local netmasks' );
-
-is( \&Net::Config::is_external, \&Net::Config::requires_firewall,
- 'is_external() should be an alias for requires_firewall()' );
+++ /dev/null
-#!./perl -w
-
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- }
- if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
- print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
- }
-}
-
-use Net::Config;
-use Net::FTP;
-
-unless(defined($NetConfig{ftp_testhost}) && $NetConfig{test_hosts}) {
- print "1..0\n";
- exit 0;
-}
-
-my $t = 1;
-print "1..7\n";
-
-$ftp = Net::FTP->new($NetConfig{ftp_testhost})
- or (print("not ok 1\n"), exit);
-
-printf "ok %d\n",$t++;
-
-$ftp->login('anonymous') or die($ftp->message . "\n");
-printf "ok %d\n",$t++;
-
-$ftp->pwd or do {
- print STDERR $ftp->message,"\n";
- print "not ";
-};
-
-printf "ok %d\n",$t++;
-
-$ftp->cwd('/pub') or do {
- print STDERR $ftp->message,"\n";
- print "not ";
-};
-
-if ($data = $ftp->stor('libnet.tst')) {
- my $text = "abc\ndef\nqwe\n";
- printf "ok %d\n",$t++;
- $data->write($text,length $text);
- $data->close;
- $data = $ftp->retr('libnet.tst');
- $data->read($buf,length $text);
- $data->close;
- print "not " unless $text eq $buf;
- printf "ok %d\n",$t++;
- $ftp->delete('libnet.tst') or print "not ";
- printf "ok %d\n",$t++;
-
-}
-else {
- print "# ",$ftp->message,"\n";
- printf "ok %d\n",$t++;
- printf "ok %d\n",$t++;
- printf "ok %d\n",$t++;
-}
-
-$ftp->quit or do {
- print STDERR $ftp->message,"\n";
- print "not ";
-};
-
-printf "ok %d\n",$t++;
+++ /dev/null
-#!./perl -w
-
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- }
- if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
- print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
- }
-}
-
-use Net::Domain qw(hostname domainname hostdomain);
-use Net::Config;
-
-unless($NetConfig{test_hosts}) {
- print "1..0\n";
- exit 0;
-}
-
-print "1..2\n";
-
-$domain = domainname();
-
-if(defined $domain && $domain ne "") {
- print "ok 1\n";
-}
-else {
- print "not ok 1\n";
-}
-
-# This check thats hostanme does not overwrite $_
-my @domain = qw(foo.example.com bar.example.jp);
-my @copy = @domain;
-
-my @dummy = grep { hostname eq $_ } @domain;
-
-($domain[0] && $domain[0] eq $copy[0])
- ? print "ok 2\n"
- : print "not ok 2\n";
+++ /dev/null
-
-my $number = 0;
-sub ok {
- my ($condition, $name) = @_;
-
- my $message = $condition ? "ok " : "not ok ";
- $message .= ++$number;
- $message .= " # $name" if defined $name;
- print $message, "\n";
- return $condition;
-}
-
-sub is {
- my ($got, $expected, $name) = @_;
-
- for ($got, $expected) {
- $_ = 'undef' unless defined $_;
- }
-
- unless (ok($got eq $expected, $name)) {
- warn "Got: '$got'\nExpected: '$expected'\n" . join(' ', caller) . "\n";
- }
-}
-
-sub skip {
- my ($reason, $num) = @_;
- $reason ||= '';
- $number ||= 1;
-
- for (1 .. $num) {
- $number++;
- print "ok $number # skip $reason\n";
- }
-}
-
-1;
-
+++ /dev/null
-#!./perl
-
-BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir 't' if -d 't';
- @INC = '../lib';
- }
- if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
- print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
- }
-}
-
-use strict;
-
-use Cwd;
-print "1..20\n";
-
-# for testing _readrc
-$ENV{HOME} = Cwd::cwd();
-
-# avoid "used only once" warning
-local (*CORE::GLOBAL::getpwuid, *CORE::GLOBAL::stat);
-
-*CORE::GLOBAL::getpwuid = sub ($) {
- ((undef) x 7, Cwd::cwd());
-};
-
-# for testing _readrc
-my @stat;
-*CORE::GLOBAL::stat = sub (*) {
- return @stat;
-};
-
-# for testing _readrc
-$INC{'FileHandle.pm'} = 1;
-
-(my $libnet_t = __FILE__) =~ s/\w+.t$/libnet_t.pl/;
-require $libnet_t;
-
-# now that the tricks are out of the way...
-eval { require Net::Netrc; };
-ok( !$@, 'should be able to require() Net::Netrc safely' );
-ok( exists $INC{'Net/Netrc.pm'}, 'should be able to use Net::Netrc' );
-
-SKIP: {
- skip('incompatible stat() handling for OS', 4), next SKIP
- if ($^O =~ /os2|win32|macos|cygwin/i or $] < 5.005);
-
- my $warn;
- local $SIG{__WARN__} = sub {
- $warn = shift;
- };
-
- # add write access for group/other
- $stat[2] = 077;
- ok( !defined(Net::Netrc::_readrc()),
- '_readrc() should not read world-writable file' );
- ok( $warn =~ /^Bad permissions:/, '... and should warn about it' );
-
- # the owner field should still not match
- $stat[2] = 0;
-
- if ($<) {
- ok( !defined(Net::Netrc::_readrc()),
- '_readrc() should not read file owned by someone else' );
- ok( $warn =~ /^Not owner:/, '... and should warn about it' );
- } else {
- skip("testing as root",2);
- }
-}
-
-# this field must now match, to avoid the last-tested warning
-$stat[4] = $<;
-
-# this curious mix of spaces and quotes tests a regex at line 79 (version 2.11)
-FileHandle::set_lines(split(/\n/, <<LINES));
-macdef bar
-login baz
- machine "foo"
-login nigol "password" drowssap
-machine foo "login" l2
- password p2
-account tnuocca
-default login "baz" password p2
-default "login" baz password p3
-macdef
-LINES
-
-# having set several lines and the uid, this should succeed
-is( Net::Netrc::_readrc(), 1, '_readrc() should succeed now' );
-
-# on 'foo', the login is 'nigol'
-is( Net::Netrc->lookup('foo')->{login}, 'nigol',
- 'lookup() should find value by host name' );
-
-# on 'foo' with login 'l2', the password is 'p2'
-is( Net::Netrc->lookup('foo', 'l2')->{password}, 'p2',
- 'lookup() should find value by hostname and login name' );
-
-# the default password is 'p3', as later declarations have priority
-is( Net::Netrc->lookup()->{password}, 'p3',
- 'lookup() should find default value' );
-
-# lookup() ignores the login parameter when using default data
-is( Net::Netrc->lookup('default', 'baz')->{password}, 'p3',
- 'lookup() should ignore passed login when searching default' );
-
-# lookup() goes to default data if hostname cannot be found in config data
-is( Net::Netrc->lookup('abadname')->{login}, 'baz',
- 'lookup() should use default for unknown machine name' );
-
-# now test these accessors
-my $instance = bless({}, 'Net::Netrc');
-for my $accessor (qw( login account password )) {
- is( $instance->$accessor(), undef,
- "$accessor() should return undef if $accessor is not set" );
- $instance->{$accessor} = $accessor;
- is( $instance->$accessor(), $accessor,
- "$accessor() should return value when $accessor is set" );
-}
-
-# and the three-for-one accessor
-is( scalar( () = $instance->lpa()), 3,
- 'lpa() should return login, password, account');
-is( join(' ', $instance->lpa), 'login password account',
- 'lpa() should return appropriate values for l, p, and a' );
-
-package FileHandle;
-
-sub new {
- tie *FH, 'FileHandle', @_;
- bless \*FH, $_[0];
-}
-
-sub TIEHANDLE {
- my ($class, $file, $mode) = @_[0,2,3];
- bless({ file => $file, mode => $mode }, $class);
-}
-
-my @lines;
-sub set_lines {
- @lines = @_;
-}
-
-sub READLINE {
- shift @lines;
-}
-
-sub close { 1 }
-
+++ /dev/null
-#!./perl -w
-
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- }
- if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
- print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
- }
-}
-
-use Net::Config;
-use Net::NNTP;
-use Net::Cmd qw(CMD_REJECT);
-
-unless(@{$NetConfig{nntp_hosts}} && $NetConfig{test_hosts}) {
- print "1..0\n";
- exit;
-}
-
-print "1..4\n";
-
-my $i = 1;
-
-$nntp = Net::NNTP->new(Debug => 0)
- or (print("not ok 1\n"), exit);
-
-print "ok 1\n";
-
-my $grp;
-foreach $grp (qw(test alt.test control news.announce.newusers)) {
- @grp = $nntp->group($grp);
- last if @grp;
-}
-
-if($nntp->status == CMD_REJECT) {
- # Command was rejected, probably because we need authinfo
- map { print "ok ",$_,"\n" } 2,3,4;
- exit;
-}
-
-print "not " unless @grp;
-print "ok 2\n";
-
-
-if(@grp && $grp[2] > $grp[1]) {
- $nntp->head($grp[1]) or print "not ";
-}
-print "ok 3\n";
-
-if(@grp) {
- $nntp->quit or print "not ";
-}
-print "ok 4\n";
-
+++ /dev/null
-#!./perl -w
-
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- }
- if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
- print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
- }
-}
-
-print "1..9\n";
-my $i = 1;
-eval { require Net::Config; } || print "not "; print "ok ",$i++,"\n";
-eval { require Net::Domain; } || print "not "; print "ok ",$i++,"\n";
-eval { require Net::Cmd; } || print "not "; print "ok ",$i++,"\n";
-eval { require Net::Netrc; } || print "not "; print "ok ",$i++,"\n";
-eval { require Net::FTP; } || print "not "; print "ok ",$i++,"\n";
-eval { require Net::SMTP; } || print "not "; print "ok ",$i++,"\n";
-eval { require Net::NNTP; } || print "not "; print "ok ",$i++,"\n";
-eval { require Net::POP3; } || print "not "; print "ok ",$i++,"\n";
-eval { require Net::Time; } || print "not "; print "ok ",$i++,"\n";
-
-
+++ /dev/null
-#!./perl -w
-
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- }
- if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
- print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
- }
-}
-
-use Net::Config;
-use Net::SMTP;
-
-unless(@{$NetConfig{smtp_hosts}} && $NetConfig{test_hosts}) {
- print "1..0\n";
- exit 0;
-}
-
-print "1..3\n";
-
-my $i = 1;
-
-$smtp = Net::SMTP->new(Debug => 0)
- or (print("not ok 1\n"), exit);
-
-print "ok 1\n";
-
-$smtp->domain or print "not ";
-print "ok 2\n";
-
-$smtp->quit or print "not ";
-print "ok 3\n";
-
https://perl5.git.perl.org / perl5.git / commitdiff