Version v5.7.2 Development release working toward v5.8
--------------
____________________________________________________________________________
+[ 14680] By: jhi on 2002/02/13 13:41:50
+ Log: Integrate perlio;
+
+ Do not lc() the file names before doing dirname() or they don't match.
+ Branch: perl
+ !> lib/ExtUtils/t/Installed.t
+____________________________________________________________________________
+[ 14679] By: sky on 2002/02/13 12:56:13
+ Log: rename mutex to make a bit more sense
+ Branch: perl
+ ! ext/threads/threads.xs
+____________________________________________________________________________
+[ 14678] By: sky on 2002/02/13 12:46:11
+ Log: Track active threads....
+ Branch: perl
+ ! ext/threads/threads.pm ext/threads/threads.xs
+____________________________________________________________________________
+[ 14676] By: sky on 2002/02/13 09:03:37
+ Log: Subject: [PATCH] Re: File/Spec/t/rel2abs2rel2whatever broken again
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: ons feb 13, 2002 11:00:17 Europe/Stockholm
+ Message-Id: <20020213100017.GA6288@blackrider>
+ Branch: perl
+ ! lib/File/Spec/t/rel2abs2rel.t
+____________________________________________________________________________
+[ 14675] By: sky on 2002/02/13 09:00:24
+ Log: Do not propagate END blocks to child threads, test.
+ Branch: perl
+ + ext/threads/t/end.t
+ ! MANIFEST ext/threads/threads.xs
+____________________________________________________________________________
+[ 14672] By: jhi on 2002/02/13 05:17:07
+ Log: $ln is supposed to be already set to $ln + executable suffix
+ on platforms that need it, from Paul Green.
+ Branch: perl
+ ! Configure
+____________________________________________________________________________
+[ 14671] By: jhi on 2002/02/13 05:12:28
+ Log: Subject: New command syntax for 'x' command
+ From: Mark-Jason Dominus <mjd@plover.com>
+ Date: Tue, 12 Feb 2002 20:54:01 -0500
+ Message-ID: <20020213015401.25685.qmail@plover.com>
+ Branch: perl
+ ! lib/perl5db.pl pod/perldebug.pod
+____________________________________________________________________________
+[ 14670] By: jhi on 2002/02/13 05:11:12
+ Log: Subject: New debugger option 'dumpDepth' controls recursion depth of 'x' command
+ From: Mark-Jason Dominus <mjd@plover.com>
+ Date: Tue, 12 Feb 2002 20:20:42 -0500
+ Message-ID: <20020213012042.25245.qmail@plover.com>
+ Branch: perl
+ ! lib/dumpvar.pl lib/perl5db.pl pod/perldebug.pod
+____________________________________________________________________________
+[ 14669] By: jhi on 2002/02/13 04:43:43
+ Log: Iteration continues.
+ Branch: perl
+ ! utf8.c
+____________________________________________________________________________
+[ 14668] By: jhi on 2002/02/13 02:37:31
+ Log: Duh.
+ Branch: perl
+ ! pp_pack.c t/op/length.t
+____________________________________________________________________________
+[ 14667] By: jhi on 2002/02/13 01:33:01
+ Log: Retract #14666.
+ Branch: perl
+ ! t/op/lc.t
+____________________________________________________________________________
+[ 14666] By: jhi on 2002/02/13 01:22:13
+ Log: (retracted by #14667)
+ Branch: perl
+ ! t/op/lc.t
+____________________________________________________________________________
+[ 14665] By: jhi on 2002/02/13 00:45:02
+ Log: Tiny test script tweaks.
+ Branch: perl
+ ! t/uni/fold.t
+____________________________________________________________________________
+[ 14664] By: jhi on 2002/02/13 00:24:37
+ Log: Rewrite the "special mapping" part of to_utf8_case(),
+ this time with fewer bugs. (See: The Law of Cybernetic
+ Entymology.)
+ Branch: perl
+ ! utf8.c
+____________________________________________________________________________
+[ 14663] By: sky on 2002/02/12 18:26:16
+ Log: Stop failures if you pass an object, sv_dup might not be the right
+ thing to use since I have a feeling we end up cloning far too much.
+ (Like the stash for example).... Maybe we need a lightweight sv_dup
+ that searches the target for things....
+ Real fix is another option to perl_clone which controls if you should
+ save stashes.
+ Branch: perl
+ ! ext/threads/threads.xs
+____________________________________________________________________________
+[ 14662] By: jhi on 2002/02/12 17:19:49
+ Log: Retract #14661.
+ Branch: perl
+ ! hints/solaris_2.sh
+____________________________________________________________________________
+[ 14661] By: jhi on 2002/02/12 17:16:20
+ Log: (retracted by #14662)
+ Branch: perl
+ ! hints/solaris_2.sh
+____________________________________________________________________________
+[ 14660] By: jhi on 2002/02/12 15:03:58
+ Log: EBCDIC: another "can't happen".
+ Branch: perl
+ ! utf8.c
+____________________________________________________________________________
+[ 14659] By: sky on 2002/02/12 14:38:21
+ Log: Join support, however something wierd seems to happen with filehandles that are passed along threads...
+ Branch: perl
+ + ext/threads/t/join.t
+ ! MANIFEST ext/threads/threads.xs
+____________________________________________________________________________
+[ 14657] By: jhi on 2002/02/12 13:44:34
+ Log: Subject: Re: [PATCH 5.6.1] Win32: Give user control over window creation behavior of system() function
+ From: Jan Dubois <JanD@ActiveState.com>
+ Date: Tue, 12 Feb 2002 00:56:31 -0800
+ Message-ID: <4llh6uc4gnqtk3csmfoqed3t6q85436bb1@4ax.com>
+ Branch: perl
+ ! lib/Win32.pod win32/win32.c win32/win32.h
+____________________________________________________________________________
+[ 14656] By: jhi on 2002/02/12 13:39:18
+ Log: Subject: [PATCH] Re: 14654 introduced a bug
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Tue, 12 Feb 2002 05:37:36 -0500
+ Message-ID: <20020212103736.GC14327@blackrider>
+ Branch: perl
+ ! lib/File/Spec/t/rel2abs2rel.t
+____________________________________________________________________________
+[ 14655] By: jhi on 2002/02/12 04:50:58
+ Log: More unset installman[13]dir tweaks from chromatic.
+ Branch: perl
+ ! lib/ExtUtils/Installed.pm
+____________________________________________________________________________
+[ 14654] By: jhi on 2002/02/12 04:31:44
+ Log: Subject: Re: [PATCH] Re: Change 14566: Re: File::Spec::rel2abs2rel (?)
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Mon, 11 Feb 2002 12:23:02 -0500
+ Message-ID: <20020211172302.GD9556@blackrider>
+ Branch: perl
+ ! lib/File/Spec/t/rel2abs2rel.t
+____________________________________________________________________________
+[ 14653] By: jhi on 2002/02/12 04:29:10
+ Log: Use `` instead of -| to be a little bit more portable,
+ from Michael Schwern.
+ Branch: perl
+ ! lib/ExtUtils/t/Embed.t
+____________________________________________________________________________
+[ 14652] By: jhi on 2002/02/12 03:17:44
+ Log: EBCDIC: this change for \N{} in particular is now
+ unnecessary because of the recent more general
+ pack U change.
+ Branch: perl
+ ! toke.c
+____________________________________________________________________________
+[ 14651] By: jhi on 2002/02/12 02:15:05
+ Log: Subject: [PATCH @14647] t/test.pl fix for VMS
+ From: "Craig A. Berry" <craigberry@mac.com>
+ Date: Mon, 11 Feb 2002 17:13:47 -0600
+ Message-Id: <5.1.0.14.2.20020211170332.01b94e88@exchi01>
+ Branch: perl
+ ! t/test.pl
+____________________________________________________________________________
+[ 14650] By: jhi on 2002/02/11 23:44:09
+ Log: EBCDIC: pack U bytes change.
+ Branch: perl
+ ! t/op/length.t
+____________________________________________________________________________
+[ 14649] By: jhi on 2002/02/11 23:38:28
+ Log: EBCDIC: pack U is no more equal to concat of \xHHs.
+ Branch: perl
+ ! t/op/each.t
+____________________________________________________________________________
+[ 14647] By: jhi on 2002/02/11 15:11:14
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+____________________________________________________________________________
[ 14646] By: jhi on 2002/02/11 15:07:28
Log: Regen toc.
Branch: perl
ext/threads/shared/t/sv_simple.t thread shared variables
ext/threads/shared/typemap thread::shared types
ext/threads/t/basic.t ithreads
+ext/threads/t/end.t Test end functions
ext/threads/t/libc.t testing libc functions for threadsafetyness
ext/threads/t/join.t Testing the join function
ext/threads/t/stress_cv.t Test with multiple threads, coderef cv argument.
lib/Tie/Handle.pm Base class for tied handles
lib/Tie/Handle/stdhandle.t Test for Tie::StdHandle
lib/Tie/Hash.pm Base class for tied hashes
+lib/Tie/Memoize.pm Base class for memoized tied hashes
+lib/Tie/Memoize.t Test for Memoize.t
lib/Tie/RefHash.pm Base class for tied hashes with references as keys
lib/Tie/RefHash.t Test for Tie::RefHash and Tie::RefHash::Nestable
lib/Tie/Scalar.pm Base class for tied scalars
# Can't depend on lib/Config.pm because that might be where miniperl
# is crashing.
minitest: miniperl$(EXE_EXT) lib/re.pm
+ -@test -f lib/lib.pm && test -f lib/Config.pm || \
+ $(MAKE) lib/Config.pm lib/lib.pm
+ @echo " "
@echo "You may see some irrelevant test failures if you have been unable"
- @echo "to build lib/Config.pm."
+ @echo "to build lib/Config.pm or lib/lib.pm."
+ @echo " "
- cd t && (rm -f perl$(EXE_EXT); $(LNS) ../miniperl$(EXE_EXT) perl$(EXE_EXT)) \
- && $(LDLIBPTH) ./perl TEST base/*.t comp/*.t cmd/*.t run/*.t io/*.t op/*.t </dev/tty
+ && $(LDLIBPTH) ./perl TEST base/*.t comp/*.t cmd/*.t run/*.t io/*.t op/*.t uni/*.t </dev/tty
# Test via harness
--- /dev/null
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ unless ($Config{'useithreads'}) {
+ print "1..0 # Skip: no useithreads\n";
+ exit 0;
+ }
+}
+
+use ExtUtils::testlib;
+use strict;
+BEGIN { print "1..6\n" };
+use threads;
+use threads::shared;
+
+my $test_id = 1;
+share($test_id);
+use Devel::Peek qw(Dump);
+
+sub ok {
+ my ($ok, $name) = @_;
+
+ # You have to do it this way or VMS will get confused.
+ print $ok ? "ok $test_id - $name\n" : "not ok $test_id - $name\n";
+
+ printf "# Failed test at line %d\n", (caller)[2] unless $ok;
+ $test_id++;
+ return $ok;
+}
+ok(1);
+END { ok(1,"End block run once") }
+threads->create(sub { eval "END { ok(1,'') }"})->join();
+threads->create(sub { eval "END { ok(1,'') }"})->join();
+threads->create(\&thread)->join();
+
+sub thread {
+ eval "END { ok(1,'') }";
+ threads->create(sub { eval "END { ok(1,'') }"})->join();
+}
#define ithread_detach(thread) Perl_ithread_detach(aTHX_ thread)
#define ithread_tid(thread) ((thread)->tid)
-static perl_mutex create_mutex; /* protects the creation of threads ??? */
+static perl_mutex create_destruct_mutex; /* protects the creation and destruction of threads*/
I32 tid_counter = 0;
-
+I32 active_threads = 0;
perl_key self_key;
/*
MUTEX_UNLOCK(&thread->mutex);
return;
}
- MUTEX_LOCK(&create_mutex);
+ MUTEX_LOCK(&create_destruct_mutex);
/* Remove from circular list of threads */
if (thread->next == thread) {
/* last one should never get here ? */
threads = thread->next;
}
}
- MUTEX_UNLOCK(&create_mutex);
+ active_threads--;
+ MUTEX_UNLOCK(&create_destruct_mutex);
/* Thread is now disowned */
#if 0
Perl_warn(aTHX_ "destruct %d @ %p by %p",
ithread* thread;
CLONE_PARAMS clone_param;
- MUTEX_LOCK(&create_mutex);
+ MUTEX_LOCK(&create_destruct_mutex);
thread = PerlMemShared_malloc(sizeof(ithread));
Zero(thread,1,ithread);
thread->next = threads;
*/
{
dTHXa(thread->interp);
-
+ /* Here we remove END blocks since they should only run
+ in the thread they are created
+ */
+ SvREFCNT_dec(PL_endav);
+ PL_endav = newAV();
clone_param.flags = 0;
thread->init_function = sv_dup(init_function, &clone_param);
if (SvREFCNT(thread->init_function) == 0) {
#endif
}
#endif
- MUTEX_UNLOCK(&create_mutex);
+ active_threads++;
+ MUTEX_UNLOCK(&create_destruct_mutex);
return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
}
ithread* thread;
PL_perl_destruct_level = 2;
PERL_THREAD_ALLOC_SPECIFIC(self_key);
- MUTEX_INIT(&create_mutex);
- MUTEX_LOCK(&create_mutex);
+ MUTEX_INIT(&create_destruct_mutex);
+ MUTEX_LOCK(&create_destruct_mutex);
thread = PerlMemShared_malloc(sizeof(ithread));
Zero(thread,1,ithread);
PL_perl_destruct_level = 2;
thread->interp = aTHX;
thread->count = 1; /* imortal */
thread->tid = tid_counter++;
+ active_threads++;
thread->detached = 1;
#ifdef WIN32
thread->thr = GetCurrentThreadId();
thread->thr = pthread_self();
#endif
PERL_THREAD_SETSPECIFIC(self_key,thread);
- MUTEX_UNLOCK(&create_mutex);
+ MUTEX_UNLOCK(&create_destruct_mutex);
}
return(0);
}
+sub _is_doc($$)
+{
+my ($self, $path) = @_;
+my $man1dir = $Config{man1direxp};
+my $man3dir = $Config{man3direxp};
+return(($man1dir && $self->_is_prefix($path, $man1dir))
+ ||
+ ($man3dir && $self->_is_prefix($path, $man3dir))
+ ? 1 : 0)
+}
+
sub _is_type($$$)
{
my ($self, $path, $type) = @_;
return(1) if ($type eq "all");
+
if ($type eq "doc")
{
- return($self->_is_prefix($path, $Config{installman1dir})
- ||
- $self->_is_prefix($path, $Config{installman3dir})
- ? 1 : 0)
+ return($self->_is_doc($path))
}
if ($type eq "prog")
{
- return($self->_is_prefix($path, $Config{prefix})
- &&
- !($Config{installman1dir} &&
- $self->_is_prefix($path, $Config{installman1dir}))
+ return($self->_is_prefix($path, $Config{prefixexp})
&&
- !($Config{installman3dir} &&
- $self->_is_prefix($path, $Config{installman3dir}))
+ !($self->_is_doc($path))
? 1 : 0);
}
return(0);
$class = ref($class) || $class;
my $self = {};
-my $installarchlib = $Config{installarchlib};
-my $archlib = $Config{archlib};
-my $sitearch = $Config{sitearch};
+my $archlib = $Config{archlibexp};
+my $sitearch = $Config{sitearchexp};
if ($DOSISH)
{
- $installarchlib =~ s|\\|/|g;
$archlib =~ s|\\|/|g;
$sitearch =~ s|\\|/|g;
}
# Read the core packlist
$self->{Perl}{packlist} =
- ExtUtils::Packlist->new( File::Spec->catfile($installarchlib, '.packlist') );
+ ExtUtils::Packlist->new( File::Spec->catfile($archlib, '.packlist') );
$self->{Perl}{version} = $Config{version};
# Read the module packlists
my $sub = sub
{
# Only process module .packlists
- return if ($_) ne ".packlist" || $File::Find::dir eq $installarchlib;
+ return if ($_) ne ".packlist" || $File::Find::dir eq $archlib;
# Hack of the leading bits of the paths & convert to a module name
my $module = $File::Find::name;
This takes one mandatory parameter, the name of a module. It returns a list of
all the filenames from the package. To obtain a list of core perl files, use
the module name 'Perl'. Additional parameters are allowed. The first is one
-of the strings "prog", "man" or "all", to select either just program files,
+of the strings "prog", "doc" or "all", to select either just program files,
just manual files or all files. The remaining parameters are a list of
directories. The filenames returned will be restricted to those under the
specified directories.
This takes one mandatory parameter, the name of a module. It returns a list of
all the directories from the package. Additional parameters are allowed. The
-first is one of the strings "prog", "man" or "all", to select either just
+first is one of the strings "prog", "doc" or "all", to select either just
program directories, just manual directories or all directories. The remaining
parameters are a list of directories. The directories returned will be
restricted to those under the specified directories. This method returns only
=item directory_tree()
-This is identical in operation to directory(), except that it includes all the
+This is identical in operation to directories(), except that it includes all the
intermediate directories back up to the specified directories.
=item validate()
BEGIN { use_ok( 'ExtUtils::Installed' ) }
-my $noman = ! ($Config{installman1dir} && $Config{installman3dir});
+my $mandirs = !!$Config{man1direxp} + !!$Config{man3direxp};
# saves having to qualify package name for class methods
my $ei = bless( {}, 'ExtUtils::Installed' );
# _is_type
is( $ei->_is_type(0, 'all'), 1, '_is_type() should be true for type of "all"' );
-foreach my $path (qw( installman1dir installman3dir )) {
- my $file = $Config{$path} . '/foo';
+foreach my $path (qw( man1dir man3dir )) {
+SKIP: {
+ my $dir = $Config{$path.'exp'};
+ skip("no man directory $path on this system", 2 ) unless $dir;
+
+ my $file = $dir . '/foo';
is( $ei->_is_type($file, 'doc'), 1, "... should find doc file in $path" );
is( $ei->_is_type($file, 'prog'), 0, "... but not prog file in $path" );
+ }
}
-is( $ei->_is_type($Config{prefix} . '/bar', 'prog'), 1,
- "... should find prog file under $Config{prefix}" );
+is( $ei->_is_type($Config{prefixexp} . '/bar', 'prog'), 1,
+ "... should find prog file under $Config{prefixexp}" );
SKIP: {
- skip('no man directories on this system', 1) if $noman;
+ skip('no man directories on this system', 1) unless $mandirs;
is( $ei->_is_type('bar', 'doc'), 0,
'... should not find doc file outside path' );
}
SKIP: {
- skip( "could not write packlist: $!", 3 ) unless $wrotelist;
+ skip("could not write packlist: $!", 3 ) unless $wrotelist;
# avoid warning and death by localizing glob
local *ExtUtils::Installed::Config;
- my $fake_mod_dir = File::Spec->catdir(cwd(), 'auto', 'FakeMod');
+ my $fake_mod_dir = File::Spec->catdir(cwd(), 'auto', 'FakeMod');
%ExtUtils::Installed::Config = (
- archlib => cwd(),
- installarchlib => cwd(),
- sitearch => $fake_mod_dir,
+ archlibexp => cwd(),
+ sitearchexp => $fake_mod_dir,
);
# necessary to fool new()
# files
$ei->{goodmod} = {
packlist => {
- File::Spec->catdir($Config{installman1dir}, 'foo') => 1,
- File::Spec->catdir($Config{installman3dir}, 'bar') => 1,
- File::Spec->catdir($Config{prefix}, 'foobar') => 1,
+ ($Config{man1direxp} ?
+ (File::Spec->catdir($Config{man1direxp}, 'foo') => 1) :
+ ()),
+ ($Config{man3direxp} ?
+ (File::Spec->catdir($Config{man3direxp}, 'bar') => 1) :
+ ()),
+ File::Spec->catdir($Config{prefixexp}, 'foobar') => 1,
foobaz => 1,
},
};
my @files;
SKIP: {
- skip('no man directories on this system', 3) if $noman;
-
- @files = $ei->files('goodmod', 'doc', $Config{installman1dir});
- is( scalar @files, 1, '... should find doc file under given dir' );
- is( grep({ /foo$/ } @files), 1, '... checking file name' );
- @files = $ei->files('goodmod', 'doc');
- is( scalar @files, 2, '... should find all doc files with no dir' );
+ skip('no man directory man1dir on this system', 2) unless $Config{man1direxp};
+ @files = $ei->files('goodmod', 'doc', $Config{man1direxp});
+ is( scalar @files, 1, '... should find doc file under given dir' );
+ is( grep({ /foo$/ } @files), 1, '... checking file name' );
+}
+SKIP: {
+ skip('no man directories on this system', 1) unless $mandirs;
+ @files = $ei->files('goodmod', 'doc');
+ is( scalar @files, $mandirs, '... should find all doc files with no dir' );
}
@files = $ei->files('goodmod', 'prog', 'fake', 'fake2');
is( scalar @files, 1, '... should find doc file in correct dir' );
like( $files[0], qr/foobar$/, '... checking file name' );
@files = $ei->files('goodmod');
-is( scalar @files, 4, '... should find all files with no type specified' );
+is( scalar @files, 2 + $mandirs, '... should find all files with no type specified' );
my %dirnames = map { lc($_) => dirname($_) } @files;
# directories
is( scalar @dirs, 0, 'directories() should return no dirs if no files found' );
SKIP: {
- skip('no man directories on this system', 4) if $noman;
-
- @dirs = $ei->directories('goodmod', 'doc');
- is( scalar @dirs, 2, '... should find all files files() would' );
- @dirs = $ei->directories('goodmod');
- is( scalar @dirs, 4, '... should find all files files() would, again' );
- @files = sort map { exists $dirnames{lc($_)} ? $dirnames{lc($_)} : '' }
- @files;
- is( join(' ', @files), join(' ', @dirs), '... should sort output' );
-
- # directory_tree
- my $expectdirs = dirname($Config{installman1dir}) eq
- dirname($Config{installman3dir}) ? 3 :2;
-
- @dirs = $ei->directory_tree('goodmod', 'doc',
- dirname($Config{installman1dir}));
- is( scalar @dirs, $expectdirs,
- 'directory_tree() should report intermediate dirs to those requested' );
+ skip('no man directories on this system', 1) unless $mandirs;
+ @dirs = $ei->directories('goodmod', 'doc');
+ is( scalar @dirs, $mandirs, '... should find all files files() would' );
+}
+@dirs = $ei->directories('goodmod');
+is( scalar @dirs, 2 + $mandirs, '... should find all files files() would, again' );
+@files = sort map { exists $dirnames{lc($_)} ? $dirnames{lc($_)} : '' } @files;
+is( join(' ', @files), join(' ', @dirs), '... should sort output' );
+
+# directory_tree
+my $expectdirs =
+ ($mandirs == 2) &&
+ (dirname($Config{man1direxp}) eq dirname($Config{man3direxp}))
+ ? 3 : 2;
+
+SKIP: {
+ skip('no man directories on this system', 1) unless $mandirs;
+ @dirs = $ei->directory_tree('goodmod', 'doc', $Config{man1direxp} ?
+ dirname($Config{man1direxp}) : dirname($Config{man3direxp}));
+ is( scalar @dirs, $expectdirs,
+ 'directory_tree() should report intermediate dirs to those requested' );
}
my $fakepak = Fakepak->new(102);
# Change 'perl' to './perl' so the shell doesn't go looking through PATH.
sub safe_rel {
- return File::Spec->catfile(File::Spec->curdir, $_[0]);
+ my($perl) = shift;
+ $perl = File::Spec->catfile(File::Spec->curdir, $perl) unless
+ File::Spec->file_name_is_absolute($perl);
+
+ return $perl;
}
# Here we make sure File::Spec can properly deal with executables.
# VMS has some trouble with these.
-my $perl = File::Spec->rel2abs($^X);
-is( `$^X -le "print 'ok'"`, "ok\n", '`` works' );
+my $perl = safe_rel($^X);
+is( `$perl -le "print 'ok'"`, "ok\n", '`` works' );
+
+$perl = File::Spec->rel2abs($^X);
is( `$perl -le "print 'ok'"`, "ok\n", 'rel2abs($^X)' );
$perl = File::Spec->canonpath($perl);
$perl = safe_rel(File::Spec->abs2rel($perl));
is( `$perl -le "print 'ok'"`, "ok\n", 'abs2rel()' );
-$perl = File::Spec->canonpath($^X);
+$perl = safe_rel(File::Spec->canonpath($^X));
is( `$perl -le "print 'ok'"`, "ok\n", 'canonpath on rel executable' );
=head1 NAME
-Tie::Hash, Tie::StdHash - base class definitions for tied hashes
+Tie::Hash, Tie::StdHash, Tie::ExtraHash - base class definitions for tied hashes
=head1 SYNOPSIS
@ISA = (Tie::StdHash);
# All methods provided by default, define only those needing overrides
+ # Accessors access the storage in %{$_[0]};
+ # TIEHANDLE should return a reference to the actual storage
sub DELETE { ... }
+ package NewExtraHash;
+ require Tie::Hash;
+
+ @ISA = (Tie::ExtraHash);
+
+ # All methods provided by default, define only those needing overrides
+ # Accessors access the storage in %{$_[0][0]};
+ # TIEHANDLE should return an array reference with the first element being
+ # the reference to the actual storage
+ sub DELETE {
+ $_[0][1]->('del', $_[0][0], $_[1]); # Call the report writer
+ delete $_[0][0]->{$_[1]}; # $_[0]->SUPER::DELETE($_[1]) }
+
package main;
tie %new_hash, 'NewHash';
tie %new_std_hash, 'NewStdHash';
+ tie %new_extra_hash, 'NewExtraHash',
+ sub {warn "Doing \U$_[1]\E of $_[2].\n"};
=head1 DESCRIPTION
This module provides some skeletal methods for hash-tying classes. See
L<perltie> for a list of the functions required in order to tie a hash
to a package. The basic B<Tie::Hash> package provides a C<new> method, as well
-as methods C<TIEHASH>, C<EXISTS> and C<CLEAR>. The B<Tie::StdHash> package
-provides most methods required for hashes in L<perltie>. It inherits from
-B<Tie::Hash>, and causes tied hashes to behave exactly like standard hashes,
-allowing for selective overloading of methods. The C<new> method is provided
-as grandfathering in the case a class forgets to include a C<TIEHASH> method.
+as methods C<TIEHASH>, C<EXISTS> and C<CLEAR>. The B<Tie::StdHash> and
+B<Tie::ExtraHash> packages
+provide most methods for hashes described in L<perltie> (the exceptions
+are C<UNTIE> and C<DESTROY>). They cause tied hashes to behave exactly like standard hashes,
+and allow for selective overwriting of methods. B<Tie::Hash> grandfathers the
+C<new> method: it is used if C<TIEHASH> is not defined
+in the case a class forgets to include a C<TIEHASH> method.
For developers wishing to write their own tied hashes, the required methods
are briefly defined below. See the L<perltie> section for more detailed
=back
-=head1 CAVEATS
+=head1 Inheriting from B<Tie::StdHash>
+
+The accessor methods assume that the actual storage for the data in the tied
+hash is in the hash referenced by C<tied(%tiedhash)>. Thus overwritten
+C<TIEHANDLE> method should return a hash reference, and the remaining methods
+should operate on the hash referenced by the first argument:
+
+ package ReportHash;
+ our @ISA = 'Tie::StdHash';
+
+ sub TIEHASH {
+ my $storage = bless {}, shift;
+ warn "New ReportHash created, stored in $storage.\n";
+ $storage
+ }
+ sub STORE {
+ warn "Storing data with key $_[1] at $_[0].\n";
+ $_[0]{$_[1]} = $_[2]
+ }
+
-The L<perltie> documentation includes a method called C<DESTROY> as
-a necessary method for tied hashes. Neither B<Tie::Hash> nor B<Tie::StdHash>
-define a default for this method. This is a standard for class packages,
-but may be omitted in favor of a simple default.
+=head1 Inheriting from B<Tie::ExtraHash>
+
+The accessor methods assume that the actual storage for the data in the tied
+hash is in the hash referenced by C<(tied(%tiedhash))[0]>. Thus overwritten
+C<TIEHANDLE> method should return an array reference with the first
+element being a hash reference, and the remaining methods should operate on the
+hash C<< %{ $_[0]->[0] }>>:
+
+ package ReportHash;
+ our @ISA = 'Tie::StdHash';
+
+ sub TIEHASH {
+ my $storage = bless {}, shift;
+ warn "New ReportHash created, stored in $storage.\n";
+ [$storage, @_]
+ }
+ sub STORE {
+ warn "Storing data with key $_[1] at $_[0].\n";
+ $_[0][0]{$_[1]} = $_[2]
+ }
+
+The default C<TIEHANDLE> method stores "extra" arguments to tie() starting
+from offset 1 in the array referenced by C<tied(%tiedhash)>; this is the
+same storage algorithm as in TIEHASH subroutine above. Hence, a typical
+package inheriting from B<Tie::ExtraHash> does not need to overwrite this
+method.
+
+=head1 C<UNTIE> and C<DESTROY>
+
+The methods C<UNTIE> and C<DESTROY> are not defined in B<Tie::Hash>,
+B<Tie::StdHash>, or B<Tie::ExtraHash>. Tied hashes do not require
+presense of these methods, but if defined, the methods will be called in
+proper time, see L<perltie>.
+
+If needed, these methods should be defined by the package inheriting from
+B<Tie::Hash>, B<Tie::StdHash>, or B<Tie::ExtraHash>.
=head1 MORE INFORMATION
# alter some parts of their behaviour.
package Tie::StdHash;
-@ISA = qw(Tie::Hash);
+# @ISA = qw(Tie::Hash); # would inherit new() only
sub TIEHASH { bless {}, $_[0] }
sub STORE { $_[0]->{$_[1]} = $_[2] }
sub DELETE { delete $_[0]->{$_[1]} }
sub CLEAR { %{$_[0]} = () }
+package Tie::ExtraHash;
+
+sub TIEHASH { my $p = shift; bless [{}, @_], $p }
+sub STORE { $_[0][0]{$_[1]} = $_[2] }
+sub FETCH { $_[0][0]{$_[1]} }
+sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} }
+sub NEXTKEY { each %{$_[0][0]} }
+sub EXISTS { exists $_[0][0]->{$_[1]} }
+sub DELETE { delete $_[0][0]->{$_[1]} }
+sub CLEAR { %{$_[0][0]} = () }
+
1;
--- /dev/null
+use strict;
+package Tie::Memoize;
+use Tie::Hash;
+our @ISA = 'Tie::ExtraHash';
+
+our $exists_token = \undef;
+
+sub croak {require Carp; goto &Carp::croak}
+
+# Format: [0: STORAGE, 1: EXISTS-CACHE, 2: FETCH_function;
+# 3: EXISTS_function, 4: DATA, 5: EXISTS_different ]
+
+sub FETCH {
+ my ($h,$key) = ($_[0][0], $_[1]);
+ my $res = $h->{$key};
+ return $res if defined $res; # Shortcut if accessible
+ return $res if exists $h->{$key}; # Accessible, but undef
+ my $cache = $_[0][1]{$key};
+ return if defined $cache and not $cache; # Known to not exist
+ my @res = $_[0][2]->($key, $_[0][4]); # Autoload
+ $_[0][1]{$key} = 0, return unless @res; # Cache non-existence
+ delete $_[0][1]{$key}; # Clear existence cache, not needed any more
+ $_[0][0]{$key} = $res[0]; # Store data and return
+}
+
+sub EXISTS {
+ my ($a,$key) = (shift, shift);
+ return 1 if exists $a->[0]{$key}; # Have data
+ my $cache = $a->[1]{$key};
+ return $cache if defined $cache; # Existence cache
+ my @res = $a->[3]($key,$a->[4]);
+ $_[0][1]{$key} = 0, return unless @res; # Cache non-existence
+ # Now we know it exists
+ return ($_[0][1]{$key} = 1) if $a->[5]; # Only existence reported
+ # Now know the value
+ $_[0][0]{$key} = $res[0]; # Store data
+ return 1
+}
+
+sub TIEHASH {
+ croak 'syntax: tie %hash, \'Tie::AutoLoad\', \&fetch_subr' if @_ < 2;
+ croak 'syntax: tie %hash, \'Tie::AutoLoad\', \&fetch_subr, $data, \&exists_subr, \%data_cache, \%existence_cache' if @_ > 6;
+ push @_, undef if @_ < 3; # Data
+ push @_, $_[1] if @_ < 4; # exists
+ push @_, {} while @_ < 6; # initial value and caches
+ bless [ @_[4,5,1,3,2], $_[1] ne $_[3]], $_[0]
+}
+
+1;
+
+=head1 NAME
+
+Tiel::Memoize - add data to hash when needed
+
+=head1 SYNOPSIS
+
+ require Tie::Memoize;
+ tie %hash, 'Tie::Memoize',
+ \&fetch, # The rest is optional
+ $DATA, \&exists,
+ {%ini_value}, {%ini_existence};
+
+=head1 DESCRIPTION
+
+This package allows a tied hash to autoload its values on the first access,
+and to use the cached value on the following accesses.
+
+Only read-accesses (via fetching the value or C<exists>) result in calls to
+the functions; the modify-accesses are performed as on a normal hash.
+
+The required arguments during C<tie> are the hash, the package, and
+the reference to the C<FETCH>ing function. The optional arguments are
+an arbitrary scalar $data, the reference to the C<EXISTS> function,
+and initial values of the hash and of the existence cache.
+
+Both the C<FETCH>ing function and the C<EXISTS> functions have the
+same signature: the arguments are C<$key, $data>; $data is the same
+value as given as argument during tie()ing. Both functions should
+return an empty list if the value does not exist. If C<EXISTS>
+function is different from the C<FETCH>ing function, it should return
+a TRUE value on success. The C<FETCH>ing function should return the
+intended value if the key is valid.
+
+=head1 Inheriting from B<Tie::Memoize>
+
+The structure of the tied() data is an array reference with elements
+
+ 0: cache of known values
+ 1: cache of known existence of keys
+ 2: FETCH function
+ 3: EXISTS function
+ 4: $data
+
+The rest is for internal usage of this package. In particular, if
+TIEHASH is overwritten, it should call SUPER::TIEHASH.
+
+=head1 EXAMPLE
+
+ sub slurp {
+ my ($key, $dir) = shift;
+ open my $h, '<', "$dir/$key" or return;
+ local $/; <$h> # slurp it all
+ }
+ sub exists { my ($key, $dir) = shift; return -f "$dir/$key" }
+
+ tie %hash, 'Tie::Memoize', \&slurp, $directory, \&exists,
+ { fake_file1 => $content1, fake_file2 => $content2 },
+ { pretend_does_not_exists => 0, known_to_exist => 1 };
+
+This example treats the slightly modified contents of $directory as a
+hash. The modifications are that the keys F<fake_file1> and
+F<fake_file2> fetch values $content1 and $content2, and
+F<pretend_does_not_exists> will never be accessed. Additionally, the
+existence of F<known_to_exist> is never checked (so if it does not
+exists when its content is needed, the user of %hash may be confused).
+
+=head1 BUGS
+
+FIRSTKEY and NEXTKEY methods go through the keys which were already read,
+not all the possible keys of the hash.
+
+=head1 AUTHOR
+
+Ilya Zakharevich L<mailto:perl-module-hash-memoize@ilyaz.org>.
+
+=cut
+
--- /dev/null
+#!./perl -w
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use strict;
+use Tie::Memoize;
+use Test::More tests => 28;
+use File::Spec;
+
+sub slurp {
+ my ($key, $dir) = @_;
+ open my $h, '<', File::Spec->catfile($dir, $key) or return;
+ local $/;
+ <$h> # slurp it all
+}
+sub exists { my ($key, $dir) = @_; return -f File::Spec->catfile($dir, $key) }
+
+my $directory = File::Spec->catdir(File::Spec->updir, 'lib');
+
+tie my %hash, 'Tie::Memoize', \&slurp, $directory, \&exists,
+ { fake_file1 => 123, fake_file2 => 45678 },
+ { 'strict.pm' => 0, known_to_exist => 1 };
+
+ok(not exists $hash{'strict.pm'});
+ok(exists $hash{known_to_exist});
+ok($hash{fake_file2} eq 45678);
+ok($hash{fake_file1} eq 123);
+ok(exists $hash{known_to_exist});
+ok(not exists $hash{'strict.pm'});
+ok(not defined $hash{fake_file3});
+ok(not defined $hash{known_to_exist});
+ok(not exists $hash{known_to_exist});
+ok(not exists $hash{'strict.pm'});
+my $c = slurp('constant.pm', $directory);
+ok($c);
+ok($hash{'constant.pm'} eq $c);
+ok($hash{'constant.pm'} eq $c);
+ok(not exists $hash{'strict.pm'});
+ok(exists $hash{'blib.pm'});
+
+untie %hash;
+
+tie %hash, 'Tie::Memoize', \&slurp, $directory;
+
+ok(exists $hash{'strict.pm'}, 'existing file');
+ok(not exists $hash{fake_file2});
+ok(not exists $hash{fake_file1});
+ok(not exists $hash{known_to_exist});
+ok(exists $hash{'strict.pm'}, 'existing file again');
+ok(not defined $hash{fake_file3});
+ok(not defined $hash{known_to_exist});
+ok(not exists $hash{known_to_exist});
+ok(exists $hash{'strict.pm'}, 'existing file again');
+ok($hash{'constant.pm'} eq $c);
+ok($hash{'constant.pm'} eq $c);
+ok(exists $hash{'strict.pm'}, 'existing file again');
+ok(exists $hash{'blib.pm'}, 'another existing file');
+
#if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT)
static char *local_patches[] = {
NULL
- ,"DEVEL14646"
+ ,"DEVEL14680"
,NULL
};
This method will be triggered when the C<untie> occurs. This can be useful
if the class needs to know when no further calls will be made. (Except DESTROY
-of course.) See below for more details.
+of course.) See L<The C<untie> Gotcha> below for more details.
=item DESTROY this
=item UNTIE this
-Will be called when C<untie> happens. (See below.)
+Will be called when C<untie> happens. (See L<The C<untie> Gotcha> below.)
=item DESTROY this
the tied variable is garbage collected.
If this seems like a lot, then feel free to inherit from merely the
-standard Tie::Hash module for most of your methods, redefining only the
+standard Tie::StdHash module for most of your methods, redefining only the
interesting ones. See L<Tie::Hash> for details.
Remember that Perl distinguishes between a key not existing in the hash,
=item UNTIE this
-This is called when C<untie> occurs.
+This is called when C<untie> occurs. See L<The C<untie> Gotcha> below.
=item DESTROY this
=item UNTIE this
As with the other types of ties, this method will be called when C<untie> happens.
-It may be appropriate to "auto CLOSE" when this occurs.
+It may be appropriate to "auto CLOSE" when this occurs. See
+L<The C<untie> Gotcha> below.
=item DESTROY this
=head2 UNTIE this
You can define for all tie types an UNTIE method that will be called
-at untie().
+at untie(). See L<The C<untie> Gotcha> below.
=head2 The C<untie> Gotcha
$pwgid = $( + 0;
($pwgnam) = getgrgid($pwgid);
-if ($Config{myuname} =~ /^cygwin_nt/i) { # basegroup on CYGWIN_NT has id = 0.
- @basegroup{$pwgid,$pwgnam} = (0,0);
-} else {
- @basegroup{$pwgid,$pwgnam} = (1,1);
-}
$seen{$pwgid}++;
print "# pwgid = $pwgid, pwgnam = $pwgnam\n";
$gr1 = join(' ', sort @gr);
}
+if ($Config{myuname} =~ /^cygwin_nt/i) { # basegroup on CYGWIN_NT has id = 0.
+ @basegroup{$pwgid,$pwgnam} = (0,0);
+} else {
+ @basegroup{$pwgid,$pwgnam} = (1,1);
+}
$gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',$groups)));
+my $ok1 = 0;
if ($gr1 eq $gr2 || ($gr1 eq '' && $gr2 eq $pwgid)) {
print "ok 1\n";
+ $ok1++;
}
-else {
+elsif ($Config{myuname} =~ /^cygwin_nt/i) { # basegroup on CYGWIN_NT has id = 0.
+ # Retry in default unix mode
+ %basegroup = ( $pwgid => 1, $pwgnam => 1 );
+ $gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',$groups)));
+ if ($gr1 eq $gr2 || ($gr1 eq '' && $gr2 eq $pwgid)) {
+ print "ok 1 # This Cygwin behaves like Unix (Win2k?)\n";
+ $ok1++;
+ }
+}
+unless ($ok1) {
print "#gr1 is <$gr1>\n";
print "#gr2 is <$gr2>\n";
print "not ok 1\n";
* (usually, but not always multicharacter)
* mapping, since any characters in the low 256
* are in Unicode code points, not EBCDIC.
- * If we either had a bit in the "special"
- * mappings indicating "contains lower 256",
- * or if we on EBCDIC platforms regenerate the
- * lib/unicore/To/Foo.pl, we could do without
- * this, but for now, let's do it this way.
* --jhi */
U8 tmpbuf[UTF8_MAXLEN_FOLD+1];
projects / p5sagit/p5-mst-13.2.git / commitdiff