print 64-bit decimal numbers.

=item C<d_PRIo64>

From F<quadfio.U>:

This variable conditionally defines the PERL_PRIo64 symbol, which
indiciates that stdio has a symbol to print 64-bit octal numbers.

=item C<d_PRIu64>

From F<quadfio.U>:

This variable conditionally defines the PERL_PRIu64 symbol, which
indiciates that stdio has a symbol to print 64-bit unsigned decimal
numbers.

=item C<d_PRIx64>

From F<quadfio.U>:

This variable conditionally defines the PERL_PRIx64 symbol, which
indiciates that stdio has a symbol to print 64-bit hexadecimal numbers.

=item C<d_PRIXU64>

From F<quadfio.U>:

This variable conditionally defines the PERL_PRIXU64 symbol, which
indiciates that stdio has a symbol to print 64-bit hExADECimAl numbers.
The C<U> in the name is to separate this from d_PRIx64 so that even
case-blind systems can see the difference.

=item C<d_pthread_yield>

From F<d_pthread_y.U>:

This variable conditionally defines the C<HAS_PTHREAD_YIELD>
symbol if the pthread_yield routine is available to yield
the execution of the current thread.

=item C<d_pwage>

From F<i_pwd.U>:

This variable conditionally defines C<PWAGE>, which indicates
that struct passwd contains pw_age.

=item C<d_pwchange>

From F<i_pwd.U>:

This variable conditionally defines C<PWCHANGE>, which indicates
that struct passwd contains pw_change.

=item C<d_pwclass>

From F<i_pwd.U>:

This variable conditionally defines C<PWCLASS>, which indicates
that struct passwd contains pw_class.

=item C<d_pwcomment>

From F<i_pwd.U>:

This variable conditionally defines C<PWCOMMENT>, which indicates
that struct passwd contains pw_comment.

=item C<d_pwexpire>

From F<i_pwd.U>:

This variable conditionally defines C<PWEXPIRE>, which indicates
that struct passwd contains pw_expire.

=item C<d_pwgecos>

From F<i_pwd.U>:

This variable conditionally defines C<PWGECOS>, which indicates
that struct passwd contains pw_gecos.

=item C<d_pwpasswd>

From F<i_pwd.U>:

This variable conditionally defines C<PWPASSWD>, which indicates
that struct passwd contains pw_passwd.

=item C<d_pwquota>

From F<i_pwd.U>:

This variable conditionally defines C<PWQUOTA>, which indicates
that struct passwd contains pw_quota.

=item C<d_qgcvt>

From F<d_qgcvt.U>:

This variable conditionally defines the C<HAS_QGCVT> symbol, which
indicates to the C program that the qgcvt() routine is available.

=item C<d_quad>

From F<quadtype.U>:

This variable, if defined, tells that there's a 64-bit integer type,
quadtype.

=item C<d_readdir>

From F<d_readdir.U>:

This variable conditionally defines C<HAS_READDIR> if readdir() is
available to read directory entries.

=item C<d_readlink>

From F<d_readlink.U>:

This variable conditionally defines the C<HAS_READLINK> symbol, which
indicates to the C program that the readlink() routine is available
to read the value of a symbolic link.

=item C<d_rename>

From F<d_rename.U>:

This variable conditionally defines the C<HAS_RENAME> symbol, which
indicates to the C program that the rename() routine is available
to rename files.

=item C<d_rewinddir>

From F<d_readdir.U>:

This variable conditionally defines C<HAS_REWINDDIR> if rewinddir() is
available.

=item C<d_rmdir>

From F<d_rmdir.U>:

This variable conditionally defines C<HAS_RMDIR> if rmdir() is
available to remove directories.

=item C<d_safebcpy>

From F<d_safebcpy.U>:

This variable conditionally defines the C<HAS_SAFE_BCOPY> symbol if
the bcopy() routine can do overlapping copies.

=item C<d_safemcpy>

From F<d_safemcpy.U>:

This variable conditionally defines the C<HAS_SAFE_MEMCPY> symbol if
the memcpy() routine can do overlapping copies.

=item C<d_sanemcmp>

From F<d_sanemcmp.U>:

This variable conditionally defines the C<HAS_SANE_MEMCMP> symbol if
the memcpy() routine is available and can be used to compare relative
magnitudes of chars with their high bits set.

=item C<d_sbrkproto>

From F<d_sbrkproto.U>:

This variable conditionally defines the C<HAS_SBRK_PROTO> symbol,
which indicates to the C program that the system provides
a prototype for the sbrk() function.  Otherwise, it is
up to the program to supply one.

=item C<d_sched_yield>

From F<d_pthread_y.U>:

This variable conditionally defines the C<HAS_SCHED_YIELD>
symbol if the sched_yield routine is available to yield
the execution of the current thread.

=item C<d_scm_rights>

From F<d_socket.U>:

This variable conditionally defines the C<HAS_SCM_RIGHTS> symbol,
which indicates that the C<SCM_RIGHTS> is available.  #ifdef is
not enough because it may be an enum, glibc has been known to do this.

=item C<d_SCNfldbl>

From F<longdblfio.U>:

This variable conditionally defines the PERL_PRIfldbl symbol, which
indiciates that stdio has a symbol to scan long doubles.

=item C<d_seekdir>

From F<d_readdir.U>:

This variable conditionally defines C<HAS_SEEKDIR> if seekdir() is
available.

=item C<d_select>

From F<d_select.U>:

This variable conditionally defines C<HAS_SELECT> if select() is
available to select active file descriptors. A <sys/time.h>
inclusion may be necessary for the timeout field.

=item C<d_sem>

From F<d_sem.U>:

This variable conditionally defines the C<HAS_SEM> symbol, which
indicates that the entire sem*(2) library is present.

=item C<d_semctl>

From F<d_semctl.U>:

This variable conditionally defines the C<HAS_SEMCTL> symbol, which
indicates to the C program that the semctl() routine is available.

=item C<d_semctl_semid_ds>

From F<d_union_semun.U>:

This variable conditionally defines C<USE_SEMCTL_SEMID_DS>, which
indicates that struct semid_ds * is to be used for semctl C<IPC_STAT>.

=item C<d_semctl_semun>

From F<d_union_semun.U>:

This variable conditionally defines C<USE_SEMCTL_SEMUN>, which
indicates that union semun is to be used for semctl C<IPC_STAT>.

=item C<d_semget>

From F<d_semget.U>:

This variable conditionally defines the C<HAS_SEMGET> symbol, which
indicates to the C program that the semget() routine is available.

=item C<d_semop>

From F<d_semop.U>:

This variable conditionally defines the C<HAS_SEMOP> symbol, which
indicates to the C program that the semop() routine is available.

=item C<d_setegid>

From F<d_setegid.U>:

This variable conditionally defines the C<HAS_SETEGID> symbol, which
indicates to the C program that the setegid() routine is available
to change the effective gid of the current program.

=item C<d_seteuid>

From F<d_seteuid.U>:

This variable conditionally defines the C<HAS_SETEUID> symbol, which
indicates to the C program that the seteuid() routine is available
to change the effective uid of the current program.

=item C<d_setgrent>

From F<d_setgrent.U>:

This variable conditionally defines the C<HAS_SETGRENT> symbol, which
indicates to the C program that the setgrent() routine is available
for initializing sequential access to the group database.

=item C<d_setgrps>

From F<d_setgrps.U>:

This variable conditionally defines the C<HAS_SETGROUPS> symbol, which
indicates to the C program that the setgroups() routine is available
to set the list of process groups.

=item C<d_sethent>

From F<d_sethent.U>:

This variable conditionally defines C<HAS_SETHOSTENT> if sethostent() is
available.

=item C<d_setlinebuf>

From F<d_setlnbuf.U>:

This variable conditionally defines the C<HAS_SETLINEBUF> symbol, which
indicates to the C program that the setlinebuf() routine is available
to change stderr or stdout from block-buffered or unbuffered to a
line-buffered mode.

=item C<d_setlocale>

From F<d_setlocale.U>:

This variable conditionally defines C<HAS_SETLOCALE> if setlocale() is
available to handle locale-specific ctype implementations.

=item C<d_setnent>

From F<d_setnent.U>:

This variable conditionally defines C<HAS_SETNETENT> if setnetent() is
available.

=item C<d_setpent>

From F<d_setpent.U>:

This variable conditionally defines C<HAS_SETPROTOENT> if setprotoent() is
available.

=item C<d_setpgid>

From F<d_setpgid.U>:

This variable conditionally defines the C<HAS_SETPGID> symbol if the
setpgid(pid, gpid) function is available to set process group C<ID>.

=item C<d_setpgrp2>

From F<d_setpgrp2.U>:

This variable conditionally defines the HAS_SETPGRP2 symbol, which
indicates to the C program that the setpgrp2() (as in F<DG/C<UX>>) routine
is available to set the current process group.

=item C<d_setpgrp>

From F<d_setpgrp.U>:

This variable conditionally defines C<HAS_SETPGRP> if setpgrp() is
available to set the current process group.

=item C<d_setprior>

From F<d_setprior.U>:

This variable conditionally defines C<HAS_SETPRIORITY> if setpriority()
is available to set a process's priority.

=item C<d_setproctitle>

From F<d_setproctitle.U>:

This variable conditionally defines the C<HAS_SETPROCTITLE> symbol,
which indicates to the C program that the setproctitle() routine
is available.

=item C<d_setpwent>

From F<d_setpwent.U>:

This variable conditionally defines the C<HAS_SETPWENT> symbol, which
indicates to the C program that the setpwent() routine is available
for initializing sequential access to the passwd database.

=item C<d_setregid>

From F<d_setregid.U>:

This variable conditionally defines C<HAS_SETREGID> if setregid() is
available to change the real and effective gid of the current
process.

=item C<d_setresgid>

From F<d_setregid.U>:

This variable conditionally defines C<HAS_SETRESGID> if setresgid() is
available to change the real, effective and saved gid of the current
process.

=item C<d_setresuid>

From F<d_setreuid.U>:

This variable conditionally defines C<HAS_SETREUID> if setresuid() is
available to change the real, effective and saved uid of the current
process.

=item C<d_setreuid>

From F<d_setreuid.U>:

This variable conditionally defines C<HAS_SETREUID> if setreuid() is
available to change the real and effective uid of the current
process.

=item C<d_setrgid>

From F<d_setrgid.U>:

This variable conditionally defines the C<HAS_SETRGID> symbol, which
indicates to the C program that the setrgid() routine is available
to change the real gid of the current program.

=item C<d_setruid>

From F<d_setruid.U>:

This variable conditionally defines the C<HAS_SETRUID> symbol, which
indicates to the C program that the setruid() routine is available
to change the real uid of the current program.

=item C<d_setsent>

From F<d_setsent.U>:

This variable conditionally defines C<HAS_SETSERVENT> if setservent() is
available.

=item C<d_setsid>

From F<d_setsid.U>:

This variable conditionally defines C<HAS_SETSID> if setsid() is
available to set the process group C<ID>.

=item C<d_setvbuf>

From F<d_setvbuf.U>:

This variable conditionally defines the C<HAS_SETVBUF> symbol, which
indicates to the C program that the setvbuf() routine is available
to change buffering on an open stdio stream.

=item C<d_sfio>

From F<d_sfio.U>:

This variable conditionally defines the C<USE_SFIO> symbol,
and indicates whether sfio is available (and should be used).

=item C<d_shm>

From F<d_shm.U>:

This variable conditionally defines the C<HAS_SHM> symbol, which
indicates that the entire shm*(2) library is present.

=item C<d_shmat>

From F<d_shmat.U>:

This variable conditionally defines the C<HAS_SHMAT> symbol, which
indicates to the C program that the shmat() routine is available.

=item C<d_shmatprototype>

From F<d_shmat.U>:

This variable conditionally defines the C<HAS_SHMAT_PROTOTYPE> 
symbol, which indicates that F<sys/shm.h> has a prototype for
shmat.

=item C<d_shmctl>

From F<d_shmctl.U>:

This variable conditionally defines the C<HAS_SHMCTL> symbol, which
indicates to the C program that the shmctl() routine is available.

=item C<d_shmdt>

From F<d_shmdt.U>:

This variable conditionally defines the C<HAS_SHMDT> symbol, which
indicates to the C program that the shmdt() routine is available.

=item C<d_shmget>

From F<d_shmget.U>:

This variable conditionally defines the C<HAS_SHMGET> symbol, which
indicates to the C program that the shmget() routine is available.

=item C<d_sigaction>

From F<d_sigaction.U>:

This variable conditionally defines the C<HAS_SIGACTION> symbol, which
indicates that the Vr4 sigaction() routine is available.

=item C<d_sigprocmask>

From F<d_sigprocmask.U>:

This variable conditionally defines C<HAS_SIGPROCMASK>
if sigprocmask() is available to examine or change the signal mask
of the calling process.

=item C<d_sigsetjmp>

From F<d_sigsetjmp.U>:

This variable conditionally defines the C<HAS_SIGSETJMP> symbol,
which indicates that the sigsetjmp() routine is available to
call setjmp() and optionally save the process's signal mask.

=item C<d_socket>

From F<d_socket.U>:

This variable conditionally defines C<HAS_SOCKET>, which indicates
that the C<BSD> socket interface is supported.

=item C<d_socklen_t>

From F<d_socklen_t.U>:

This symbol will be defined if the C compiler supports socklen_t.

=item C<d_sockpair>

From F<d_socket.U>:

This variable conditionally defines the C<HAS_SOCKETPAIR> symbol, which
indicates that the C<BSD> socketpair() is supported.

=item C<d_socks5_init>

From F<d_socks5_init.U>:

This variable conditionally defines the HAS_SOCKS5_INIT symbol, which
indicates to the C program that the socks5_init() routine is available.

=item C<d_sqrtl>

From F<d_sqrtl.U>:

This variable conditionally defines the C<HAS_SQRTL> symbol, which
indicates to the C program that the sqrtl() routine is available.

=item C<d_statblks>

From F<d_statblks.U>:

This variable conditionally defines C<USE_STAT_BLOCKS>
if this system has a stat structure declaring
st_blksize and st_blocks.

=item C<d_statfs_f_flags>

From F<d_statfs_f_flags.U>:

This variable conditionally defines the C<HAS_STRUCT_STATFS_F_FLAGS>
symbol, which indicates to struct statfs from has f_flags member.
This kind of struct statfs is coming from F<sys/mount.h> (C<BSD>),
not from F<sys/statfs.h> (C<SYSV>).

=item C<d_statfs_s>

From F<d_statfs_s.U>:

This variable conditionally defines the C<HAS_STRUCT_STATFS> symbol,
which indicates that the struct statfs is supported.

=item C<d_statvfs>

From F<d_statvfs.U>:

This variable conditionally defines the C<HAS_STATVFS> symbol, which
indicates to the C program that the statvfs() routine is available.

=item C<d_stdio_cnt_lval>

From F<d_stdstdio.U>:

This variable conditionally defines C<STDIO_CNT_LVALUE> if the
C<FILE_cnt> macro can be used as an lvalue.

=item C<d_stdio_ptr_lval>

From F<d_stdstdio.U>:

This variable conditionally defines C<STDIO_PTR_LVALUE> if the
C<FILE_ptr> macro can be used as an lvalue.

=item C<d_stdio_ptr_lval_nochange_cnt>

From F<d_stdstdio.U>:

This symbol is defined if using the C<FILE_ptr> macro as an lvalue
to increase the pointer by n leaves File_cnt(fp) unchanged.

=item C<d_stdio_ptr_lval_sets_cnt>

From F<d_stdstdio.U>:

This symbol is defined if using the C<FILE_ptr> macro as an lvalue
to increase the pointer by n has the side effect of decreasing the
value of File_cnt(fp) by n.

=item C<d_stdio_stream_array>

From F<stdio_streams.U>:

This variable tells whether there is an array holding
the stdio streams.

=item C<d_stdiobase>

From F<d_stdstdio.U>:

This variable conditionally defines C<USE_STDIO_BASE> if this system
has a C<FILE> structure declaring a usable _base field (or equivalent)
in F<stdio.h>.

=item C<d_stdstdio>

From F<d_stdstdio.U>:

This variable conditionally defines C<USE_STDIO_PTR> if this system
has a C<FILE> structure declaring usable _ptr and _cnt fields (or
equivalent) in F<stdio.h>.

=item C<d_strchr>

From F<d_strchr.U>:

This variable conditionally defines C<HAS_STRCHR> if strchr() and
strrchr() are available for string searching.

=item C<d_strcoll>

From F<d_strcoll.U>:

This variable conditionally defines C<HAS_STRCOLL> if strcoll() is
available to compare strings using collating information.

=item C<d_strctcpy>

From F<d_strctcpy.U>:

This variable conditionally defines the C<USE_STRUCT_COPY> symbol, which
indicates to the C program that this C compiler knows how to copy
structures.

=item C<d_strerrm>

From F<d_strerror.U>:

This variable holds what Strerrr is defined as to translate an error
code condition into an error message string. It could be C<strerror>
or a more C<complex> macro emulating strrror with sys_errlist[], or the
C<unknown> string when both strerror and sys_errlist are missing.

=item C<d_strerror>

From F<d_strerror.U>:

This variable conditionally defines C<HAS_STRERROR> if strerror() is
available to translate error numbers to strings.

=item C<d_strtod>

From F<d_strtod.U>:

This variable conditionally defines the C<HAS_STRTOD> symbol, which
indicates to the C program that the strtod() routine is available
to provide better numeric string conversion than atof().

=item C<d_strtol>

From F<d_strtol.U>:

This variable conditionally defines the C<HAS_STRTOL> symbol, which
indicates to the C program that the strtol() routine is available
to provide better numeric string conversion than atoi() and friends.

=item C<d_strtold>

From F<d_strtold.U>:

This variable conditionally defines the C<HAS_STRTOLD> symbol, which
indicates to the C program that the strtold() routine is available.

=item C<d_strtoll>

From F<d_strtoll.U>:

This variable conditionally defines the C<HAS_STRTOLL> symbol, which
indicates to the C program that the strtoll() routine is available.

=item C<d_strtoq>

From F<d_strtoq.U>:

This variable conditionally defines the C<HAS_STRTOQ> symbol, which
indicates to the C program that the strtoq() routine is available.

=item C<d_strtoul>

From F<d_strtoul.U>:

This variable conditionally defines the C<HAS_STRTOUL> symbol, which
indicates to the C program that the strtoul() routine is available
to provide conversion of strings to unsigned long.

=item C<d_strtoull>

From F<d_strtoull.U>:

This variable conditionally defines the C<HAS_STRTOULL> symbol, which
indicates to the C program that the strtoull() routine is available.

=item C<d_strtouq>

From F<d_strtouq.U>:

This variable conditionally defines the C<HAS_STRTOUQ> symbol, which
indicates to the C program that the strtouq() routine is available.

=item C<d_strxfrm>

From F<d_strxfrm.U>:

This variable conditionally defines C<HAS_STRXFRM> if strxfrm() is
available to transform strings.

=item C<d_suidsafe>

From F<d_dosuid.U>:

This variable conditionally defines C<SETUID_SCRIPTS_ARE_SECURE_NOW>
if setuid scripts can be secure.  This test looks in F</dev/fd/>.

=item C<d_symlink>

From F<d_symlink.U>:

This variable conditionally defines the C<HAS_SYMLINK> symbol, which
indicates to the C program that the symlink() routine is available
to create symbolic links.

=item C<d_syscall>

From F<d_syscall.U>:

This variable conditionally defines C<HAS_SYSCALL> if syscall() is
available call arbitrary system calls.

=item C<d_sysconf>

From F<d_sysconf.U>:

This variable conditionally defines the C<HAS_SYSCONF> symbol, which
indicates to the C program that the sysconf() routine is available
to determine system related limits and options.

=item C<d_sysernlst>

From F<d_strerror.U>:

This variable conditionally defines C<HAS_SYS_ERRNOLIST> if sys_errnolist[]
is available to translate error numbers to the symbolic name.

=item C<d_syserrlst>

From F<d_strerror.U>:

This variable conditionally defines C<HAS_SYS_ERRLIST> if sys_errlist[] is
available to translate error numbers to strings.

=item C<d_system>

From F<d_system.U>:

This variable conditionally defines C<HAS_SYSTEM> if system() is
available to issue a shell command.

=item C<d_tcgetpgrp>

From F<d_tcgtpgrp.U>:

This variable conditionally defines the C<HAS_TCGETPGRP> symbol, which
indicates to the C program that the tcgetpgrp() routine is available.
to get foreground process group C<ID>.

=item C<d_tcsetpgrp>

From F<d_tcstpgrp.U>:

This variable conditionally defines the C<HAS_TCSETPGRP> symbol, which
indicates to the C program that the tcsetpgrp() routine is available
to set foreground process group C<ID>.

=item C<d_telldir>

From F<d_readdir.U>:

This variable conditionally defines C<HAS_TELLDIR> if telldir() is
available.

=item C<d_telldirproto>

From F<d_telldirproto.U>:

This variable conditionally defines the C<HAS_TELLDIR_PROTO> symbol,
which indicates to the C program that the system provides
a prototype for the telldir() function.  Otherwise, it is
up to the program to supply one.

=item C<d_time>

From F<d_time.U>:

This variable conditionally defines the C<HAS_TIME> symbol, which indicates
that the time() routine exists.  The time() routine is normaly
provided on C<UNIX> systems.

=item C<d_times>

From F<d_times.U>:

This variable conditionally defines the C<HAS_TIMES> symbol, which indicates
that the times() routine exists.  The times() routine is normaly
provided on C<UNIX> systems. You may have to include <sys/times.h>.

=item C<d_truncate>

From F<d_truncate.U>:

This variable conditionally defines C<HAS_TRUNCATE> if truncate() is
available to truncate files.

=item C<d_tzname>

From F<d_tzname.U>:

This variable conditionally defines C<HAS_TZNAME> if tzname[] is
available to access timezone names.

=item C<d_umask>

From F<d_umask.U>:

This variable conditionally defines the C<HAS_UMASK> symbol, which
indicates to the C program that the umask() routine is available.
to set and get the value of the file creation mask.

=item C<d_uname>

From F<d_gethname.U>:

This variable conditionally defines the C<HAS_UNAME> symbol, which
indicates to the C program that the uname() routine may be
used to derive the host name.

=item C<d_union_semun>

From F<d_union_semun.U>:

This variable conditionally defines C<HAS_UNION_SEMUN> if the
union semun is defined by including <sys/sem.h>.

=item C<d_ustat>

From F<d_ustat.U>:

This variable conditionally defines C<HAS_USTAT> if ustat() is
available to query file system statistics by dev_t.

=item C<d_vendorarch>

From F<vendorarch.U>:

This variable conditionally defined C<PERL_VENDORARCH>.

=item C<d_vendorbin>

From F<vendorbin.U>:

This variable conditionally defines C<PERL_VENDORBIN>.

=item C<d_vendorlib>

From F<vendorlib.U>:

This variable conditionally defines C<PERL_VENDORLIB>.

=item C<d_vfork>

From F<d_vfork.U>:

This variable conditionally defines the C<HAS_VFORK> symbol, which
indicates the vfork() routine is available.

=item C<d_void_closedir>

From F<d_closedir.U>:

This variable conditionally defines C<VOID_CLOSEDIR> if closedir()
does not return a value.

=item C<d_voidsig>

From F<d_voidsig.U>:

This variable conditionally defines C<VOIDSIG> if this system
declares "void (*signal(...))()" in F<signal.h>.  The old way was to
declare it as "int (*signal(...))()".

=item C<d_voidtty>

From F<i_sysioctl.U>:

This variable conditionally defines C<USE_IOCNOTTY> to indicate that the
ioctl() call with C<TIOCNOTTY> should be used to void tty association.
Otherwise (on C<USG> probably), it is enough to close the standard file
decriptors and do a setpgrp().

=item C<d_volatile>

From F<d_volatile.U>:

This variable conditionally defines the C<HASVOLATILE> symbol, which
indicates to the C program that this C compiler knows about the
volatile declaration.

=item C<d_vprintf>

From F<d_vprintf.U>:

This variable conditionally defines the C<HAS_VPRINTF> symbol, which
indicates to the C program that the vprintf() routine is available
to printf with a pointer to an argument list.

=item C<d_wait4>

From F<d_wait4.U>:

This variable conditionally defines the HAS_WAIT4 symbol, which
indicates the wait4() routine is available.

=item C<d_waitpid>

From F<d_waitpid.U>:

This variable conditionally defines C<HAS_WAITPID> if waitpid() is
available to wait for child process.

=item C<d_wcstombs>

From F<d_wcstombs.U>:

This variable conditionally defines the C<HAS_WCSTOMBS> symbol, which
indicates to the C program that the wcstombs() routine is available
to convert wide character strings to multibyte strings.

=item C<d_wctomb>

From F<d_wctomb.U>:

This variable conditionally defines the C<HAS_WCTOMB> symbol, which
indicates to the C program that the wctomb() routine is available
to convert a wide character to a multibyte.

=item C<d_xenix>

From F<Guess.U>:

This variable conditionally defines the symbol C<XENIX>, which alerts
the C program that it runs under Xenix.

=item C<date>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the date program.  After Configure runs,
the value is reset to a plain C<date> and is not useful.

=item C<db_hashtype>

From F<i_db.U>:

This variable contains the type of the hash structure element
in the <db.h> header file.  In older versions of C<DB>, it was
int, while in newer ones it is u_int32_t.

=item C<db_prefixtype>

From F<i_db.U>:

This variable contains the type of the prefix structure element
in the <db.h> header file.  In older versions of C<DB>, it was
int, while in newer ones it is size_t.

=item C<defvoidused>

From F<voidflags.U>:

This variable contains the default value of the C<VOIDUSED> symbol (15).

=item C<direntrytype>

From F<i_dirent.U>:

This symbol is set to C<struct direct> or C<struct dirent> depending on
whether dirent is available or not. You should use this pseudo type to
portably declare your directory entries.

=item C<dlext>

From F<dlext.U>:

This variable contains the extension that is to be used for the
dynamically loaded modules that perl generaties.

=item C<dlsrc>

From F<dlsrc.U>:

This variable contains the name of the dynamic loading file that
will be used with the package.

=item C<doublesize>

From F<doublesize.U>:

This variable contains the value of the C<DOUBLESIZE> symbol, which
indicates to the C program how many bytes there are in a double.

=item C<drand01>

From F<randfunc.U>:

Indicates the macro to be used to generate normalized
random numbers.  Uses randfunc, often divided by
(double) (((unsigned long) 1 << randbits)) in order to
normalize the result.
In C programs, the macro C<Drand01> is mapped to drand01.

=item C<dynamic_ext>

From F<Extensions.U>:

This variable holds a list of C<XS> extension files we want to
link dynamically into the package.  It is used by Makefile.

=back

=head2 e

=over

=item C<eagain>

From F<nblock_io.U>:

This variable bears the symbolic errno code set by read() when no
data is present on the file and non-blocking F<I/O> was enabled (otherwise,
read() blocks naturally).

=item C<ebcdic>

From F<ebcdic.U>:

This variable conditionally defines C<EBCDIC> if this
system uses C<EBCDIC> encoding.  Among other things, this
means that the character ranges are not contiguous.
See F<trnl.U>

=item C<echo>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the echo program.  After Configure runs,
the value is reset to a plain C<echo> and is not useful.

=item C<egrep>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the egrep program.  After Configure runs,
the value is reset to a plain C<egrep> and is not useful.

=item C<emacs>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<eunicefix>

From F<Init.U>:

When running under Eunice this variable contains a command which will
convert a shell script to the proper form of text file for it to be
executable by the shell.  On other systems it is a no-op.

=item C<exe_ext>

From F<Unix.U>:

This is an old synonym for _exe.

=item C<expr>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the expr program.  After Configure runs,
the value is reset to a plain C<expr> and is not useful.

=item C<extensions>

From F<Extensions.U>:

This variable holds a list of all extension files (both C<XS> and
non-xs linked into the package.  It is propagated to F<Config.pm>
and is typically used to test whether a particular extesion 
is available.

=back

=head2 f

=over

=item C<fflushall>

From F<fflushall.U>:

This symbol, if defined, tells that to flush
all pending stdio output one must loop through all
the stdio file handles stored in an array and fflush them.
Note that if fflushNULL is defined, fflushall will not
even be probed for and will be left undefined.

=item C<fflushNULL>

From F<fflushall.U>:

This symbol, if defined, tells that fflush(C<NULL>) does flush
all pending stdio output.

=item C<find>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<firstmakefile>

From F<Unix.U>:

This variable defines the first file searched by make.  On unix,
it is makefile (then Makefile).  On case-insensitive systems,
it might be something else.  This is only used to deal with
convoluted make depend tricks.

=item C<flex>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<fpossize>

From F<fpossize.U>:

This variable contains the size of a fpostype in bytes.

=item C<fpostype>

From F<fpostype.U>:

This variable defines Fpos_t to be something like fpos_t, long, 
uint, or whatever type is used to declare file positions in libc.

=item C<freetype>

From F<mallocsrc.U>:

This variable contains the return type of free().  It is usually
void, but occasionally int.

=item C<full_ar>

From F<Loc_ar.U>:

This variable contains the full pathname to C<ar>, whether or
not the user has specified C<portability>.  This is only used
in the F<Makefile.SH>.

=item C<full_csh>

From F<d_csh.U>:

This variable contains the full pathname to C<csh>, whether or
not the user has specified C<portability>.  This is only used
in the compiled C program, and we assume that all systems which
can share this executable will have the same full pathname to
F<csh.>

=item C<full_sed>

From F<Loc_sed.U>:

This variable contains the full pathname to C<sed>, whether or
not the user has specified C<portability>.  This is only used
in the compiled C program, and we assume that all systems which
can share this executable will have the same full pathname to
F<sed.>

=back

=head2 g

=over

=item C<gccosandvers>

From F<gccvers.U>:

If C<GNU> cc (gcc) is used, this variable the operating system and
version used to compile the gcc.  It is set to '' if not gcc,
or if nothing useful can be parsed as the os version.

=item C<gccversion>

From F<gccvers.U>:

If C<GNU> cc (gcc) is used, this variable holds C<1> or C<2> to 
indicate whether the compiler is version 1 or 2.  This is used in
setting some of the default cflags.  It is set to '' if not gcc.

=item C<gidformat>

From F<gidf.U>:

This variable contains the format string used for printing a Gid_t.

=item C<gidsign>

From F<gidsign.U>:

This variable contains the signedness of a gidtype.
1 for unsigned, -1 for signed.

=item C<gidsize>

From F<gidsize.U>:

This variable contains the size of a gidtype in bytes.

=item C<gidtype>

From F<gidtype.U>:

This variable defines Gid_t to be something like gid_t, int,
ushort, or whatever type is used to declare the return type
of getgid().  Typically, it is the type of group ids in the kernel.

=item C<glibpth>

From F<libpth.U>:

This variable holds the general path (space-separated) used to
find libraries.  It may contain directories that do not exist on
this platform, libpth is the cleaned-up version.

=item C<grep>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the grep program.  After Configure runs,
the value is reset to a plain C<grep> and is not useful.

=item C<groupcat>

From F<nis.U>:

This variable contains a command that produces the text of the
F</etc/group> file.  This is normally "cat F</etc/group>", but can be
"ypcat group" when C<NIS> is used.
On some systems, such as os390, there may be no equivalent
command, in which case this variable is unset.

=item C<groupstype>

From F<groupstype.U>:

This variable defines Groups_t to be something like gid_t, int, 
ushort, or whatever type is used for the second argument to
getgroups() and setgroups().  Usually, this is the same as
gidtype (gid_t), but sometimes it isn't.

=item C<gzip>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the gzip program.  After Configure runs,
the value is reset to a plain C<gzip> and is not useful.

=back

=head2 h

=over

=item C<h_fcntl>

From F<h_fcntl.U>:

This is variable gets set in various places to tell i_fcntl that
<fcntl.h> should be included.

=item C<h_sysfile>

From F<h_sysfile.U>:

This is variable gets set in various places to tell i_sys_file that
<sys/file.h> should be included.

=item C<hint>

From F<Oldconfig.U>:

Gives the type of hints used for previous answers. May be one of
C<default>, C<recommended> or C<previous>.

=item C<hostcat>

From F<nis.U>:

This variable contains a command that produces the text of the
F</etc/hosts> file.  This is normally "cat F</etc/hosts>", but can be
"ypcat hosts" when C<NIS> is used.
On some systems, such as os390, there may be no equivalent
command, in which case this variable is unset.

=back

=head2 i

=over

=item C<i16size>

From F<perlxv.U>:

This variable is the size of an I16 in bytes.

=item C<i16type>

From F<perlxv.U>:

This variable contains the C type used for Perl's I16.

=item C<i32size>

From F<perlxv.U>:

This variable is the size of an I32 in bytes.

=item C<i32type>

From F<perlxv.U>:

This variable contains the C type used for Perl's I32.

=item C<i64size>

From F<perlxv.U>:

This variable is the size of an I64 in bytes.

=item C<i64type>

From F<perlxv.U>:

This variable contains the C type used for Perl's I64.

=item C<i8size>

From F<perlxv.U>:

This variable is the size of an I8 in bytes.

=item C<i8type>

From F<perlxv.U>:

This variable contains the C type used for Perl's I8.

=item C<i_arpainet>

From F<i_arpainet.U>:

This variable conditionally defines the C<I_ARPA_INET> symbol,
and indicates whether a C program should include <arpa/inet.h>.

=item C<i_bsdioctl>

From F<i_sysioctl.U>:

This variable conditionally defines the C<I_SYS_BSDIOCTL> symbol, which
indicates to the C program that <sys/bsdioctl.h> exists and should
be included.

=item C<i_db>

From F<i_db.U>:

This variable conditionally defines the C<I_DB> symbol, and indicates
whether a C program may include Berkeley's C<DB> include file <db.h>.

=item C<i_dbm>

From F<i_dbm.U>:

This variable conditionally defines the C<I_DBM> symbol, which
indicates to the C program that <dbm.h> exists and should
be included.

=item C<i_dirent>

From F<i_dirent.U>:

This variable conditionally defines C<I_DIRENT>, which indicates
to the C program that it should include <dirent.h>.

=item C<i_dld>

From F<i_dld.U>:

This variable conditionally defines the C<I_DLD> symbol, which
indicates to the C program that <dld.h> (C<GNU> dynamic loading)
exists and should be included.

=item C<i_dlfcn>

From F<i_dlfcn.U>:

This variable conditionally defines the C<I_DLFCN> symbol, which
indicates to the C program that <dlfcn.h> exists and should
be included.

=item C<i_fcntl>

From F<i_fcntl.U>:

This variable controls the value of C<I_FCNTL> (which tells
the C program to include <fcntl.h>).

=item C<i_float>

From F<i_float.U>:

This variable conditionally defines the C<I_FLOAT> symbol, and indicates
whether a C program may include <float.h> to get symbols like C<DBL_MAX>
or C<DBL_MIN>, F<i.e>. machine dependent floating point values.

=item C<i_gdbm>

From F<i_gdbm.U>:

This variable conditionally defines the C<I_GDBM> symbol, which
indicates to the C program that <gdbm.h> exists and should
be included.

=item C<i_grp>

From F<i_grp.U>:

This variable conditionally defines the C<I_GRP> symbol, and indicates
whether a C program should include <grp.h>.

=item C<i_iconv>

From F<i_iconv.U>:

This variable conditionally defines the C<I_ICONV> symbol, and indicates
whether a C program should include <iconv.h>.

=item C<i_ieeefp>

From F<i_ieeefp.U>:

This variable conditionally defines the C<I_IEEEFP> symbol, and indicates
whether a C program should include <ieeefp.h>.

=item C<i_inttypes>

From F<i_inttypes.U>:

This variable conditionally defines the C<I_INTTYPES> symbol,
and indicates whether a C program should include <inttypes.h>.

=item C<i_libutil>

From F<i_libutil.U>:

This variable conditionally defines the C<I_LIBUTIL> symbol, and indicates
whether a C program should include <libutil.h>.

=item C<i_limits>

From F<i_limits.U>:

This variable conditionally defines the C<I_LIMITS> symbol, and indicates
whether a C program may include <limits.h> to get symbols like C<WORD_BIT>
and friends.

=item C<i_locale>

From F<i_locale.U>:

This variable conditionally defines the C<I_LOCALE> symbol,
and indicates whether a C program should include <locale.h>.

=item C<i_machcthr>

From F<i_machcthr.U>:

This variable conditionally defines the C<I_MACH_CTHREADS> symbol,
and indicates whether a C program should include <mach/cthreads.h>.

=item C<i_malloc>

From F<i_malloc.U>:

This variable conditionally defines the C<I_MALLOC> symbol, and indicates
whether a C program should include <malloc.h>.

=item C<i_math>

From F<i_math.U>:

This variable conditionally defines the C<I_MATH> symbol, and indicates
whether a C program may include <math.h>.

=item C<i_memory>

From F<i_memory.U>:

This variable conditionally defines the C<I_MEMORY> symbol, and indicates
whether a C program should include <memory.h>.

=item C<i_mntent>

From F<i_mntent.U>:

This variable conditionally defines the C<I_MNTENT> symbol, and indicates
whether a C program should include <mntent.h>.

=item C<i_ndbm>

From F<i_ndbm.U>:

This variable conditionally defines the C<I_NDBM> symbol, which
indicates to the C program that <ndbm.h> exists and should
be included.

=item C<i_netdb>

From F<i_netdb.U>:

This variable conditionally defines the C<I_NETDB> symbol, and indicates
whether a C program should include <netdb.h>.

=item C<i_neterrno>

From F<i_neterrno.U>:

This variable conditionally defines the C<I_NET_ERRNO> symbol, which
indicates to the C program that <net/errno.h> exists and should
be included.

=item C<i_netinettcp>

From F<i_netinettcp.U>:

This variable conditionally defines the C<I_NETINET_TCP> symbol,
and indicates whether a C program should include <netinet/tcp.h>.

=item C<i_niin>

From F<i_niin.U>:

This variable conditionally defines C<I_NETINET_IN>, which indicates
to the C program that it should include <netinet/in.h>. Otherwise,
you may try <sys/in.h>.

=item C<i_poll>

From F<i_poll.U>:

This variable conditionally defines the C<I_POLL> symbol, and indicates
whether a C program should include <poll.h>.

=item C<i_prot>

From F<i_prot.U>:

This variable conditionally defines the C<I_PROT> symbol, and indicates
whether a C program should include <prot.h>.

=item C<i_pthread>

From F<i_pthread.U>:

This variable conditionally defines the C<I_PTHREAD> symbol,
and indicates whether a C program should include <pthread.h>.

=item C<i_pwd>

From F<i_pwd.U>:

This variable conditionally defines C<I_PWD>, which indicates
to the C program that it should include <pwd.h>.

=item C<i_rpcsvcdbm>

From F<i_dbm.U>:

This variable conditionally defines the C<I_RPCSVC_DBM> symbol, which
indicates to the C program that <rpcsvc/dbm.h> exists and should
be included.  Some System V systems might need this instead of <dbm.h>.

=item C<i_sfio>

From F<i_sfio.U>:

This variable conditionally defines the C<I_SFIO> symbol,
and indicates whether a C program should include <sfio.h>.

=item C<i_sgtty>

From F<i_termio.U>:

This variable conditionally defines the C<I_SGTTY> symbol, which
indicates to the C program that it should include <sgtty.h> rather
than <termio.h>.

=item C<i_shadow>

From F<i_shadow.U>:

This variable conditionally defines the C<I_SHADOW> symbol, and indicates
whether a C program should include <shadow.h>.

=item C<i_socks>

From F<i_socks.U>:

This variable conditionally defines the C<I_SOCKS> symbol, and indicates
whether a C program should include <socks.h>.

=item C<i_stdarg>

From F<i_varhdr.U>:

This variable conditionally defines the C<I_STDARG> symbol, which
indicates to the C program that <stdarg.h> exists and should
be included.

=item C<i_stddef>

From F<i_stddef.U>:

This variable conditionally defines the C<I_STDDEF> symbol, which
indicates to the C program that <stddef.h> exists and should
be included.

=item C<i_stdlib>

From F<i_stdlib.U>:

This variable conditionally defines the C<I_STDLIB> symbol, which
indicates to the C program that <stdlib.h> exists and should
be included.

=item C<i_string>

From F<i_string.U>:

This variable conditionally defines the C<I_STRING> symbol, which
indicates that <string.h> should be included rather than <strings.h>.

=item C<i_sunmath>

From F<i_sunmath.U>:

This variable conditionally defines the C<I_SUNMATH> symbol, and indicates
whether a C program should include <sunmath.h>.

=item C<i_sysaccess>

From F<i_sysaccess.U>:

This variable conditionally defines the C<I_SYS_ACCESS> symbol,
and indicates whether a C program should include <sys/access.h>.

=item C<i_sysdir>

From F<i_sysdir.U>:

This variable conditionally defines the C<I_SYS_DIR> symbol, and indicates
whether a C program should include <sys/dir.h>.

=item C<i_sysfile>

From F<i_sysfile.U>:

This variable conditionally defines the C<I_SYS_FILE> symbol, and indicates
whether a C program should include <sys/file.h> to get C<R_OK> and friends.

=item C<i_sysfilio>

From F<i_sysioctl.U>:

This variable conditionally defines the C<I_SYS_FILIO> symbol, which
indicates to the C program that <sys/filio.h> exists and should
be included in preference to <sys/ioctl.h>.

=item C<i_sysin>

From F<i_niin.U>:

This variable conditionally defines C<I_SYS_IN>, which indicates
to the C program that it should include <sys/in.h> instead of
<netinet/in.h>.

=item C<i_sysioctl>

From F<i_sysioctl.U>:

This variable conditionally defines the C<I_SYS_IOCTL> symbol, which
indicates to the C program that <sys/ioctl.h> exists and should
be included.

=item C<i_syslog>

From F<i_syslog.U>:

This variable conditionally defines the C<I_SYSLOG> symbol,
and indicates whether a C program should include <syslog.h>.

=item C<i_sysmman>

From F<i_sysmman.U>:

This variable conditionally defines the C<I_SYS_MMAN> symbol, and
indicates whether a C program should include <sys/mman.h>.

=item C<i_sysmode>

From F<i_sysmode.U>:

This variable conditionally defines the C<I_SYSMODE> symbol,
and indicates whether a C program should include <sys/mode.h>.

=item C<i_sysmount>

From F<i_sysmount.U>:

This variable conditionally defines the C<I_SYSMOUNT> symbol,
and indicates whether a C program should include <sys/mount.h>.

=item C<i_sysndir>

From F<i_sysndir.U>:

This variable conditionally defines the C<I_SYS_NDIR> symbol, and indicates
whether a C program should include <sys/ndir.h>.

=item C<i_sysparam>

From F<i_sysparam.U>:

This variable conditionally defines the C<I_SYS_PARAM> symbol, and indicates
whether a C program should include <sys/param.h>.

=item C<i_sysresrc>

From F<i_sysresrc.U>:

This variable conditionally defines the C<I_SYS_RESOURCE> symbol,
and indicates whether a C program should include <sys/resource.h>.

=item C<i_syssecrt>

From F<i_syssecrt.U>:

This variable conditionally defines the C<I_SYS_SECURITY> symbol,
and indicates whether a C program should include <sys/security.h>.

=item C<i_sysselct>

From F<i_sysselct.U>:

This variable conditionally defines C<I_SYS_SELECT>, which indicates
to the C program that it should include <sys/select.h> in order to
get the definition of struct timeval.

=item C<i_syssockio>

From F<i_sysioctl.U>:

This variable conditionally defines C<I_SYS_SOCKIO> to indicate to the
C program that socket ioctl codes may be found in <sys/sockio.h>
instead of <sys/ioctl.h>.

=item C<i_sysstat>

From F<i_sysstat.U>:

This variable conditionally defines the C<I_SYS_STAT> symbol,
and indicates whether a C program should include <sys/stat.h>.

=item C<i_sysstatfs>

From F<i_sysstatfs.U>:

This variable conditionally defines the C<I_SYSSTATFS> symbol,
and indicates whether a C program should include <sys/statfs.h>.

=item C<i_sysstatvfs>

From F<i_sysstatvfs.U>:

This variable conditionally defines the C<I_SYSSTATVFS> symbol,
and indicates whether a C program should include <sys/statvfs.h>.

=item C<i_systime>

From F<i_time.U>:

This variable conditionally defines C<I_SYS_TIME>, which indicates
to the C program that it should include <sys/time.h>.

=item C<i_systimek>

From F<i_time.U>:

This variable conditionally defines C<I_SYS_TIME_KERNEL>, which
indicates to the C program that it should include <sys/time.h>
with C<KERNEL> defined.

=item C<i_systimes>

From F<i_systimes.U>:

This variable conditionally defines the C<I_SYS_TIMES> symbol, and indicates
whether a C program should include <sys/times.h>.

=item C<i_systypes>

From F<i_systypes.U>:

This variable conditionally defines the C<I_SYS_TYPES> symbol,
and indicates whether a C program should include <sys/types.h>.

=item C<i_sysuio>

From F<i_sysuio.U>:

This variable conditionally defines the C<I_SYSUIO> symbol, and indicates
whether a C program should include <sys/uio.h>.

=item C<i_sysun>

From F<i_sysun.U>:

This variable conditionally defines C<I_SYS_UN>, which indicates
to the C program that it should include <sys/un.h> to get C<UNIX>
domain socket definitions.

=item C<i_sysutsname>

From F<i_sysutsname.U>:

This variable conditionally defines the C<I_SYSUTSNAME> symbol,
and indicates whether a C program should include <sys/utsname.h>.

=item C<i_sysvfs>

From F<i_sysvfs.U>:

This variable conditionally defines the C<I_SYSVFS> symbol,
and indicates whether a C program should include <sys/vfs.h>.

=item C<i_syswait>

From F<i_syswait.U>:

This variable conditionally defines C<I_SYS_WAIT>, which indicates
to the C program that it should include <sys/wait.h>.

=item C<i_termio>

From F<i_termio.U>:

This variable conditionally defines the C<I_TERMIO> symbol, which
indicates to the C program that it should include <termio.h> rather
than <sgtty.h>.

=item C<i_termios>

From F<i_termio.U>:

This variable conditionally defines the C<I_TERMIOS> symbol, which
indicates to the C program that the C<POSIX> <termios.h> file is
to be included.

=item C<i_time>

From F<i_time.U>:

This variable conditionally defines C<I_TIME>, which indicates
to the C program that it should include <time.h>.

=item C<i_unistd>

From F<i_unistd.U>:

This variable conditionally defines the C<I_UNISTD> symbol, and indicates
whether a C program should include <unistd.h>.

=item C<i_ustat>

From F<i_ustat.U>:

This variable conditionally defines the C<I_USTAT> symbol, and indicates
whether a C program should include <ustat.h>.

=item C<i_utime>

From F<i_utime.U>:

This variable conditionally defines the C<I_UTIME> symbol, and indicates
whether a C program should include <utime.h>.

=item C<i_values>

From F<i_values.U>:

This variable conditionally defines the C<I_VALUES> symbol, and indicates
whether a C program may include <values.h> to get symbols like C<MAXLONG>
and friends.

=item C<i_varargs>

From F<i_varhdr.U>:

This variable conditionally defines C<I_VARARGS>, which indicates
to the C program that it should include <varargs.h>.

=item C<i_varhdr>

From F<i_varhdr.U>:

Contains the name of the header to be included to get va_dcl definition.
Typically one of F<varargs.h> or F<stdarg.h>.

=item C<i_vfork>

From F<i_vfork.U>:

This variable conditionally defines the C<I_VFORK> symbol, and indicates
whether a C program should include F<vfork.h>.

=item C<ignore_versioned_solibs>

From F<libs.U>:

This variable should be non-empty if non-versioned shared
libraries (F<libfoo.so.x.y>) are to be ignored (because they
cannot be linked against).

=item C<inc_version_list>

From F<inc_version_list.U>:

This variable specifies the list of subdirectories in over
which F<perl.c>:incpush() and F<lib/lib.pm> will automatically
search when adding directories to @C<INC>.  The elements in
the list are separated by spaces.  This is only useful
if you have a perl library directory tree structured like the
default one.  See C<INSTALL> for how this works.  The versioned
site_perl directory was introduced in 5.005, so that is the
lowest possible value.

=item C<inc_version_list_init>

From F<inc_version_list.U>:

This variable holds the same list as inc_version_list, but
each item is enclosed in double quotes and separated by commas, 
suitable for use in the C<PERL_INC_VERSION_LIST> initialization.

=item C<incpath>

From F<usrinc.U>:

This variable must preceed the normal include path to get hte
right one, as in F<$F<incpath/usr/include>> or F<$F<incpath/usr/lib>>.
Value can be "" or F</bsd43> on mips.

=item C<inews>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<installarchlib>

From F<archlib.U>:

This variable is really the same as archlibexp but may differ on
those systems using C<AFS>. For extra portability, only this variable
should be used in makefiles.

=item C<installbin>

From F<bin.U>:

This variable is the same as binexp unless C<AFS> is running in which case
the user is explicitely prompted for it. This variable should always
be used in your makefiles for maximum portability.

=item C<installman1dir>

From F<man1dir.U>:

This variable is really the same as man1direxp, unless you are using
C<AFS> in which case it points to the F<read/write> location whereas
man1direxp only points to the read-only access location. For extra
portability, you should only use this variable within your makefiles.

=item C<installman3dir>

From F<man3dir.U>:

This variable is really the same as man3direxp, unless you are using
C<AFS> in which case it points to the F<read/write> location whereas
man3direxp only points to the read-only access location. For extra
portability, you should only use this variable within your makefiles.

=item C<installprefix>

From F<installprefix.U>:

This variable holds the name of the directory below which 
"make install" will install the package.  For most users, this
is the same as prefix.  However, it is useful for
installing the software into a different (usually temporary)
location after which it can be bundled up and moved somehow
to the final location specified by prefix.

=item C<installprefixexp>

From F<installprefix.U>:

This variable holds the full absolute path of installprefix
with all F<~>-expansion done.

=item C<installprivlib>

From F<privlib.U>:

This variable is really the same as privlibexp but may differ on
those systems using C<AFS>. For extra portability, only this variable
should be used in makefiles.

=item C<installscript>

From F<scriptdir.U>:

This variable is usually the same as scriptdirexp, unless you are on
a system running C<AFS>, in which case they may differ slightly. You
should always use this variable within your makefiles for portability.

=item C<installsitearch>

From F<sitearch.U>:

This variable is really the same as sitearchexp but may differ on
those systems using C<AFS>. For extra portability, only this variable
should be used in makefiles.

=item C<installsitebin>

From F<sitebin.U>:

This variable is usually the same as sitebinexp, unless you are on
a system running C<AFS>, in which case they may differ slightly. You
should always use this variable within your makefiles for portability.

=item C<installsitelib>

From F<sitelib.U>:

This variable is really the same as sitelibexp but may differ on
those systems using C<AFS>. For extra portability, only this variable
should be used in makefiles.

=item C<installstyle>

From F<installstyle.U>:

This variable describes the C<style> of the perl installation.
This is intended to be useful for tools that need to
manipulate entire perl distributions.  Perl itself doesn't use
this to find its libraries -- the library directories are
stored directly in F<Config.pm>.  Currently, there are only two
styles:  C<lib> and F<lib/perl5>.  The default library locations
(e.g. privlib, sitelib) are either $F<prefix/lib> or
$F<prefix/lib/perl5>.  The former is useful if $prefix is a
directory dedicated to perl (e.g. F</opt/perl>), while the latter
is useful if $prefix is shared by many packages, e.g. if
$prefix=F</usr/local>.

	This may later be extended to include other information, so

	be careful with pattern-matching on the results.

	For compatibility with F<perl5.005> and earlier, the default

	setting is based on whether or not $prefix contains the string
C<perl>.

=item C<installusrbinperl>

From F<instubperl.U>:

This variable tells whether Perl should be installed also as
F</usr/bin/perl> in addition to
$F<installbin/perl>

=item C<installvendorarch>

From F<vendorarch.U>:

This variable is really the same as vendorarchexp but may differ on
those systems using C<AFS>. For extra portability, only this variable
should be used in makefiles.

=item C<installvendorbin>

From F<vendorbin.U>:

This variable is really the same as vendorbinexp but may differ on
those systems using C<AFS>. For extra portability, only this variable
should be used in makefiles.

=item C<installvendorlib>

From F<vendorlib.U>:

This variable is really the same as vendorlibexp but may differ on
those systems using C<AFS>. For extra portability, only this variable
should be used in makefiles.

=item C<intsize>

From F<intsize.U>:

This variable contains the value of the C<INTSIZE> symbol, which
indicates to the C program how many bytes there are in an int.

=item C<issymlink>

From F<issymlink.U>:

This variable holds the test command to test for a symbolic link
(if they are supported).  Typical values include C<test -h> and
C<test -L>.

=item C<ivdformat>

From F<perlxvf.U>:

This variable contains the format string used for printing
a Perl C<IV> as a signed decimal integer. 

=item C<ivsize>

From F<perlxv.U>:

This variable is the size of an C<IV> in bytes.

=item C<ivtype>

From F<perlxv.U>:

This variable contains the C type used for Perl's C<IV>.

=back

=head2 k

=over

=item C<known_extensions>

From F<Extensions.U>:

This variable holds a list of all C<XS> extensions included in 
the package.

=item C<ksh>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=back

=head2 l

=over

=item C<ld>

From F<dlsrc.U>:

This variable indicates the program to be used to link
libraries for dynamic loading.  On some systems, it is C<ld>.
On C<ELF> systems, it should be $cc.  Mostly, we'll try to respect
the hint file setting.

=item C<lddlflags>

From F<dlsrc.U>:

This variable contains any special flags that might need to be
passed to $ld to create a shared library suitable for dynamic
loading.  It is up to the makefile to use it.  For hpux, it
should be C<-b>.  For sunos 4.1, it is empty.

=item C<ldflags>

From F<ccflags.U>:

This variable contains any additional C loader flags desired by
the user.  It is up to the Makefile to use this.

=item C<ldflags_uselargefiles>

From F<uselfs.U>:

This variable contains the loader flags needed by large file builds
and added to ldflags by hints files.

=item C<ldlibpthname>

From F<libperl.U>:

This variable holds the name of the shared library
search path, often C<LD_LIBRARY_PATH>.  To get an empty
string, the hints file must set this to C<none>.

=item C<less>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the less program.  After Configure runs,
the value is reset to a plain C<less> and is not useful.

=item C<lib_ext>

From F<Unix.U>:

This is an old synonym for _a.

=item C<libc>

From F<libc.U>:

This variable contains the location of the C library.

=item C<libperl>

From F<libperl.U>:

The perl executable is obtained by linking F<perlmain.c> with
libperl, any static extensions (usually just DynaLoader),
and any other libraries needed on this system.  libperl
is usually F<libperl.a>, but can also be F<libperl.so.xxx> if
the user wishes to build a perl executable with a shared
library.

=item C<libpth>

From F<libpth.U>:

This variable holds the general path (space-separated) used to find
libraries. It is intended to be used by other units.

=item C<libs>

From F<libs.U>:

This variable holds the additional libraries we want to use.
It is up to the Makefile to deal with it.

=item C<libsdirs>

From F<libs.U>:

This variable holds the directory names aka dirnames of the libraries
we found and accepted, duplicates are removed.

=item C<libsfiles>

From F<libs.U>:

This variable holds the filenames aka basenames of the libraries
we found and accepted.

=item C<libsfound>

From F<libs.U>:

This variable holds the full pathnames of the libraries
we found and accepted.

=item C<libspath>

From F<libs.U>:

This variable holds the directory names probed for libraries.

=item C<libswanted>

From F<Myinit.U>:

This variable holds a list of all the libraries we want to
search.  The order is chosen to pick up the c library
ahead of ucb or bsd libraries for SVR4.

=item C<libswanted_uselargefiles>

From F<uselfs.U>:

This variable contains the libraries needed by large file builds
and added to ldflags by hints files.  It is a space separated list
of the library names without the C<lib> prefix or any suffix, just
like F<libswanted.>.

=item C<line>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<lint>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<lkflags>

From F<ccflags.U>:

This variable contains any additional C partial linker flags desired by
the user.  It is up to the Makefile to use this.

=item C<ln>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the ln program.  After Configure runs,
the value is reset to a plain C<ln> and is not useful.

=item C<lns>

From F<lns.U>:

This variable holds the name of the command to make 
symbolic links (if they are supported).  It can be used
in the Makefile. It is either C<ln -s> or C<ln>

=item C<locincpth>

From F<ccflags.U>:

This variable contains a list of additional directories to be
searched by the compiler.  The appropriate C<-I> directives will
be added to ccflags.  This is intended to simplify setting
local directories from the Configure command line.
It's not much, but it parallels the loclibpth stuff in F<libpth.U>.

=item C<loclibpth>

From F<libpth.U>:

This variable holds the paths (space-separated) used to find local
libraries.  It is prepended to libpth, and is intended to be easily
set from the command line.

=item C<longdblsize>

From F<d_longdbl.U>:

This variable contains the value of the C<LONG_DOUBLESIZE> symbol, which
indicates to the C program how many bytes there are in a long double,
if this system supports long doubles.

=item C<longlongsize>

From F<d_longlong.U>:

This variable contains the value of the C<LONGLONGSIZE> symbol, which
indicates to the C program how many bytes there are in a long long,
if this system supports long long.

=item C<longsize>

From F<intsize.U>:

This variable contains the value of the C<LONGSIZE> symbol, which
indicates to the C program how many bytes there are in a long.

=item C<lp>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<lpr>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<ls>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the ls program.  After Configure runs,
the value is reset to a plain C<ls> and is not useful.

=item C<lseeksize>

From F<lseektype.U>:

This variable defines lseektype to be something like off_t, long, 
or whatever type is used to declare lseek offset's type in the
kernel (which also appears to be lseek's return type).

=item C<lseektype>

From F<lseektype.U>:

This variable defines lseektype to be something like off_t, long, 
or whatever type is used to declare lseek offset's type in the
kernel (which also appears to be lseek's return type).

=back

=head2 m

=over

=item C<mail>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<mailx>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<make>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the make program.  After Configure runs,
the value is reset to a plain C<make> and is not useful.

=item C<make_set_make>

From F<make.U>:

Some versions of C<make> set the variable C<MAKE>.  Others do not.
This variable contains the string to be included in F<Makefile.SH>
so that C<MAKE> is set if needed, and not if not needed.
Possible values are:
make_set_make=C<#>		# If your make program handles this for you,
make_set_make=C<MAKE=$make>	# if it doesn't.
I used a comment character so that we can distinguish a
C<set> value (from a previous F<config.sh> or Configure C<-D> option)
from an uncomputed value.

=item C<mallocobj>

From F<mallocsrc.U>:

This variable contains the name of the F<malloc.o> that this package
generates, if that F<malloc.o> is preferred over the system malloc.
Otherwise the value is null.  This variable is intended for generating
Makefiles.  See mallocsrc.

=item C<mallocsrc>

From F<mallocsrc.U>:

This variable contains the name of the F<malloc.c> that comes with
the package, if that F<malloc.c> is preferred over the system malloc.
Otherwise the value is null.  This variable is intended for generating
Makefiles.

=item C<malloctype>

From F<mallocsrc.U>:

This variable contains the kind of ptr returned by malloc and realloc.

=item C<man1dir>

From F<man1dir.U>:

This variable contains the name of the directory in which manual
source pages are to be put.  It is the responsibility of the
F<Makefile.SH> to get the value of this into the proper command.
You must be prepared to do the F<~name> expansion yourself.

=item C<man1direxp>

From F<man1dir.U>:

This variable is the same as the man1dir variable, but is filename
expanded at configuration time, for convenient use in makefiles.

=item C<man1ext>

From F<man1dir.U>:

This variable contains the extension that the manual page should
have: one of C<n>, C<l>, or C<1>.  The Makefile must supply the F<.>.
See man1dir.

=item C<man3dir>

From F<man3dir.U>:

This variable contains the name of the directory in which manual
source pages are to be put.  It is the responsibility of the
F<Makefile.SH> to get the value of this into the proper command.
You must be prepared to do the F<~name> expansion yourself.

=item C<man3direxp>

From F<man3dir.U>:

This variable is the same as the man3dir variable, but is filename
expanded at configuration time, for convenient use in makefiles.

=item C<man3ext>

From F<man3dir.U>:

This variable contains the extension that the manual page should
have: one of C<n>, C<l>, or C<3>.  The Makefile must supply the F<.>.
See man3dir.

=back

=head2 M

=over

=item C<Mcc>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the Mcc program.  After Configure runs,
the value is reset to a plain C<Mcc> and is not useful.

=item C<mips_type>

From F<usrinc.U>:

This variable holds the environment type for the mips system.
Possible values are "BSD 4.3" and "System V".

=item C<mkdir>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the mkdir program.  After Configure runs,
the value is reset to a plain C<mkdir> and is not useful.

=item C<mmaptype>

From F<d_mmap.U>:

This symbol contains the type of pointer returned by mmap()
(and simultaneously the type of the first argument).
It can be C<void *> or C<caddr_t>.

=item C<modetype>

From F<modetype.U>:

This variable defines modetype to be something like mode_t, 
int, unsigned short, or whatever type is used to declare file 
modes for system calls.

=item C<more>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the more program.  After Configure runs,
the value is reset to a plain C<more> and is not useful.

=item C<multiarch>

From F<multiarch.U>:

This variable conditionally defines the C<MULTIARCH> symbol
which signifies the presence of multiplatform files.
This is normally set by hints files.

=item C<mv>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<myarchname>

From F<archname.U>:

This variable holds the architecture name computed by Configure in
a previous run. It is not intended to be perused by any user and
should never be set in a hint file.

=item C<mydomain>

From F<myhostname.U>:

This variable contains the eventual value of the C<MYDOMAIN> symbol,
which is the domain of the host the program is going to run on.
The domain must be appended to myhostname to form a complete host name.
The dot comes with mydomain, and need not be supplied by the program.

=item C<myhostname>

From F<myhostname.U>:

This variable contains the eventual value of the C<MYHOSTNAME> symbol,
which is the name of the host the program is going to run on.
The domain is not kept with hostname, but must be gotten from mydomain.
The dot comes with mydomain, and need not be supplied by the program.

=item C<myuname>

From F<Oldconfig.U>:

The output of C<uname -a> if available, otherwise the hostname. On Xenix,
pseudo variables assignments in the output are stripped, thank you. The
whole thing is then lower-cased.

=back

=head2 n

=over

=item C<n>

From F<n.U>:

This variable contains the C<-n> flag if that is what causes the echo
command to suppress newline.  Otherwise it is null.  Correct usage is
$echo $n "prompt for a question: $c".

=item C<need_va_copy>

From F<need_va_copy.U>:

This symbol, if defined, indicates that the system stores
the variable argument list datatype, va_list, in a format
that cannot be copied by simple assignment, so that some
other means must be used when copying is required.
As such systems vary in their provision (or non-provision)
of copying mechanisms, F<handy.h> defines a platform-
C<independent> macro, Perl_va_copy(src, dst), to do the job.

=item C<netdb_hlen_type>

From F<netdbtype.U>:

This variable holds the type used for the 2nd argument to
gethostbyaddr().  Usually, this is int or size_t or unsigned.
This is only useful if you have gethostbyaddr(), naturally.

=item C<netdb_host_type>

From F<netdbtype.U>:

This variable holds the type used for the 1st argument to
gethostbyaddr().  Usually, this is char * or void *,  possibly
with or without a const prefix.
This is only useful if you have gethostbyaddr(), naturally.

=item C<netdb_name_type>

From F<netdbtype.U>:

This variable holds the type used for the argument to
gethostbyname().  Usually, this is char * or const char *.
This is only useful if you have gethostbyname(), naturally.

=item C<netdb_net_type>

From F<netdbtype.U>:

This variable holds the type used for the 1st argument to
getnetbyaddr().  Usually, this is int or long.
This is only useful if you have getnetbyaddr(), naturally.

=item C<nm>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the nm program.  After Configure runs,
the value is reset to a plain C<nm> and is not useful.

=item C<nm_opt>

From F<usenm.U>:

This variable holds the options that may be necessary for nm.

=item C<nm_so_opt>

From F<usenm.U>:

This variable holds the options that may be necessary for nm
to work on a shared library but that can not be used on an
archive library.  Currently, this is only used by Linux, where
nm --dynamic is *required* to get symbols from an C<ELF> library which
has been stripped, but nm --dynamic is *fatal* on an archive library.
Maybe Linux should just always set usenm=false.

=item C<nonxs_ext>

From F<Extensions.U>:

This variable holds a list of all non-xs extensions included
in the package.  All of them will be built.

=item C<nroff>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the nroff program.  After Configure runs,
the value is reset to a plain C<nroff> and is not useful.

=item C<nveformat>

From F<perlxvf.U>:

This variable contains the format string used for printing
a Perl C<NV> using %e-ish floating point format.

=item C<nvEUformat>

From F<perlxvf.U>:

This variable contains the format string used for printing
a Perl C<NV> using %E-ish floating point format.

=item C<nvfformat>

From F<perlxvf.U>:

This variable confains the format string used for printing
a Perl C<NV> using %f-ish floating point format.

=item C<nvFUformat>

From F<perlxvf.U>:

This variable confains the format string used for printing
a Perl C<NV> using %F-ish floating point format.

=item C<nvgformat>

From F<perlxvf.U>:

This variable contains the format string used for printing
a Perl C<NV> using %g-ish floating point format.

=item C<nvGUformat>

From F<perlxvf.U>:

This variable contains the format string used for printing
a Perl C<NV> using %G-ish floating point format.

=item C<nvsize>

From F<perlxv.U>:

This variable is the size of an C<NV> in bytes.

=item C<nvtype>

From F<perlxv.U>:

This variable contains the C type used for Perl's C<NV>.

=back

=head2 o

=over

=item C<o_nonblock>

From F<nblock_io.U>:

This variable bears the symbol value to be used during open() or fcntl()
to turn on non-blocking F<I/O> for a file descriptor. If you wish to switch
between blocking and non-blocking, you may try ioctl(C<FIOSNBIO>) instead,
but that is only supported by some devices.

=item C<obj_ext>

From F<Unix.U>:

This is an old synonym for _o.

=item C<old_pthread_create_joinable>

From F<d_pthrattrj.U>:

This variable defines the constant to use for creating joinable
(aka undetached) pthreads.  Unused if F<pthread.h> defines
C<PTHREAD_CREATE_JOINABLE>.  If used, possible values are
C<PTHREAD_CREATE_UNDETACHED> and C<__UNDETACHED>.

=item C<optimize>

From F<ccflags.U>:

This variable contains any F<optimizer/debugger> flag that should be used.
It is up to the Makefile to use it.

=item C<orderlib>

From F<orderlib.U>:

This variable is C<true> if the components of libraries must be ordered
(with `lorder $* | tsort`) before placing them in an archive.  Set to
C<false> if ranlib or ar can generate random libraries.

=item C<osname>

From F<Oldconfig.U>:

This variable contains the operating system name (e.g. sunos,
solaris, hpux, F<etc.>).  It can be useful later on for setting
defaults.  Any spaces are replaced with underscores.  It is set
to a null string if we can't figure it out.

=item C<osvers>

From F<Oldconfig.U>:

This variable contains the operating system version (e.g.
4.1.3, 5.2, F<etc.>).  It is primarily used for helping select
an appropriate hints file, but might be useful elsewhere for
setting defaults.  It is set to '' if we can't figure it out.
We try to be flexible about how much of the version number
to keep, e.g. if 4.1.1, 4.1.2, and 4.1.3 are essentially the
same for this package, hints files might just be F<os_4.0> or
F<os_4.1>, F<etc.>, not keeping separate files for each little release.

=item C<otherlibdirs>

From F<otherlibdirs.U>:

This variable contains a colon-separated set of paths for the perl
binary to search for additional library files or modules.
These directories will be tacked to the end of @C<INC>.
Perl will automatically search below each path for version-
and architecture-specific directories.  See inc_version_list
for more details.
A value of C< > means C<none> and is used to preserve this value
for the next run through Configure.

=back

=head2 p

=over

=item C<package>

From F<package.U>:

This variable contains the name of the package being constructed.
It is primarily intended for the use of later Configure units.

=item C<pager>

From F<pager.U>:

This variable contains the name of the preferred pager on the system.
Usual values are (the full pathnames of) more, less, pg, or cat.

=item C<passcat>

From F<nis.U>:

This variable contains a command that produces the text of the
F</etc/passwd> file.  This is normally "cat F</etc/passwd>", but can be
"ypcat passwd" when C<NIS> is used.
On some systems, such as os390, there may be no equivalent
command, in which case this variable is unset.

=item C<patchlevel>

From F<patchlevel.U>:

The patchlevel level of this package.
The value of patchlevel comes from the F<patchlevel.h> file.
In a version number such as 5.6.1, this is the C<6>.
In F<patchlevel.h>, this is referred to as C<PERL_VERSION>.

=item C<path_sep>

From F<Unix.U>:

This is an old synonym for p_ in F<Head.U>, the character
used to separate elements in the command shell search C<PATH>.

=item C<perl5>

From F<perl5.U>:

This variable contains the full path (if any) to a previously
installed F<perl5.005> or later suitable for running the script
to determine inc_version_list.

=item C<perl>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=back

=head2 P

=over

=item C<PERL_REVISION>

From F<Oldsyms.U>:

In a Perl version number such as 5.6.2, this is the 5.
This value is manually set in F<patchlevel.h>

=item C<PERL_SUBVERSION>

From F<Oldsyms.U>:

In a Perl version number such as 5.6.2, this is the 2.
Values greater than 50 represent potentially unstable
development subversions.
This value is manually set in F<patchlevel.h>

=item C<PERL_VERSION>

From F<Oldsyms.U>:

In a Perl version number such as 5.6.2, this is the 6.
This value is manually set in F<patchlevel.h>

=item C<perladmin>

From F<perladmin.U>:

Electronic mail address of the perl5 administrator.

=item C<perllibs>

From F<End.U>:

The list of libraries needed by Perl only (any libraries needed
by extensions only will by dropped, if using dynamic loading).

=item C<perlpath>

From F<perlpath.U>:

This variable contains the eventual value of the C<PERLPATH> symbol,
which contains the name of the perl interpreter to be used in
shell scripts and in the "eval C<exec>" idiom.

=item C<pg>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the pg program.  After Configure runs,
the value is reset to a plain C<pg> and is not useful.

=item C<phostname>

From F<myhostname.U>:

This variable contains the eventual value of the C<PHOSTNAME> symbol,
which is a command that can be fed to popen() to get the host name.
The program should probably not presume that the domain is or isn't
there already.

=item C<pidtype>

From F<pidtype.U>:

This variable defines C<PIDTYPE> to be something like pid_t, int, 
ushort, or whatever type is used to declare process ids in the kernel.

=item C<plibpth>

From F<libpth.U>:

Holds the private path used by Configure to find out the libraries.
Its value is prepend to libpth. This variable takes care of special
machines, like the mips.  Usually, it should be empty.

=item C<pm_apiversion>

From F<xs_apiversion.U>:

This variable contains the version of the oldest perl
compatible with the present perl.  (That is, pure perl modules
written for $pm_apiversion will still work for the current
version).  F<perl.c>:incpush() and F<lib/lib.pm> will automatically
search in $sitelib for older directories across major versions
back to pm_apiversion.  This is only useful if you have a perl
library directory tree structured like the default one.  The
versioned site_perl library was introduced in 5.005, so that's
the default setting for this variable.  It's hard to imagine
it changing before Perl6.  It is included here for symmetry
with xs_apiveprsion -- the searching algorithms will
(presumably) be similar.
See the C<INSTALL> file for how this works.

=item C<pmake>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<pr>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<prefix>

From F<prefix.U>:

This variable holds the name of the directory below which the
user will install the package.  Usually, this is F</usr/local>, and
executables go in F</usr/local/bin>, library stuff in F</usr/local/lib>,
man pages in F</usr/local/man>, etc.  It is only used to set defaults
for things in F<bin.U>, F<mansrc.U>, F<privlib.U>, or F<scriptdir.U>.

=item C<prefixexp>

From F<prefix.U>:

This variable holds the full absolute path of the directory below
which the user will install the package.  Derived from prefix.

=item C<privlib>

From F<privlib.U>:

This variable contains the eventual value of the C<PRIVLIB> symbol,
which is the name of the private library for this package.  It may
have a F<~> on the front. It is up to the makefile to eventually create
this directory while performing installation (with F<~> substitution).

=item C<privlibexp>

From F<privlib.U>:

This variable is the F<~name> expanded version of privlib, so that you
may use it directly in Makefiles or shell scripts.

=item C<prototype>

From F<prototype.U>:

This variable holds the eventual value of C<CAN_PROTOTYPE>, which
indicates the C compiler can handle funciton prototypes.

=item C<ptrsize>

From F<ptrsize.U>:

This variable contains the value of the C<PTRSIZE> symbol, which
indicates to the C program how many bytes there are in a pointer.

=back

=head2 q

=over

=item C<quadkind>

From F<quadtype.U>:

This variable, if defined, encodes the type of a quad:
1 = int, 2 = long, 3 = long long, 4 = int64_t.

=item C<quadtype>

From F<quadtype.U>:

This variable defines Quad_t to be something like long, int, 
long long, int64_t, or whatever type is used for 64-bit integers.

=back

=head2 r

=over

=item C<randbits>

From F<randfunc.U>:

Indicates how many bits are produced by the function used to
generate normalized random numbers.

=item C<randfunc>

From F<randfunc.U>:

Indicates the name of the random number function to use.
Values include drand48, random, and rand. In C programs,
the C<Drand01> macro is defined to generate uniformly distributed
random numbers over the range [0., 1.[ (see drand01 and nrand).

=item C<randseedtype>

From F<randfunc.U>:

Indicates the type of the argument of the seedfunc.

=item C<ranlib>

From F<orderlib.U>:

This variable is set to the pathname of the ranlib program, if it is
needed to generate random libraries.  Set to C<:> if ar can generate
random libraries or if random libraries are not supported

=item C<rd_nodata>

From F<nblock_io.U>:

This variable holds the return code from read() when no data is
present. It should be -1, but some systems return 0 when C<O_NDELAY> is
used, which is a shame because you cannot make the difference between
no data and an F<EOF.>. Sigh!

=item C<revision>

From F<patchlevel.U>:

The value of revision comes from the F<patchlevel.h> file.
In a version number such as 5.6.1, this is the C<5>.
In F<patchlevel.h>, this is referred to as C<PERL_REVISION>.

=item C<rm>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the rm program.  After Configure runs,
the value is reset to a plain C<rm> and is not useful.

=item C<rmail>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<runnm>

From F<usenm.U>:

This variable contains C<true> or C<false> depending whether the
nm extraction should be performed or not, according to the value
of usenm and the flags on the Configure command line.

=back

=head2 s

=over

=item C<sched_yield>

From F<d_pthread_y.U>:

This variable defines the way to yield the execution
of the current thread.

=item C<scriptdir>

From F<scriptdir.U>:

This variable holds the name of the directory in which the user wants
to put publicly scripts for the package in question.  It is either
the same directory as for binaries, or a special one that can be
mounted across different architectures, like F</usr/share>. Programs
must be prepared to deal with F<~name> expansion.

=item C<scriptdirexp>

From F<scriptdir.U>:

This variable is the same as scriptdir, but is filename expanded
at configuration time, for programs not wanting to bother with it.

=item C<sed>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the sed program.  After Configure runs,
the value is reset to a plain C<sed> and is not useful.

=item C<seedfunc>

From F<randfunc.U>:

Indicates the random number generating seed function.
Values include srand48, srandom, and srand.

=item C<selectminbits>

From F<selectminbits.U>:

This variable holds the minimum number of bits operated by select.
That is, if you do select(n, ...), how many bits at least will be
cleared in the masks if some activity is detected.  Usually this
is either n or 32*ceil(F<n/32>), especially many little-endians do
the latter.  This is only useful if you have select(), naturally.

=item C<selecttype>

From F<selecttype.U>:

This variable holds the type used for the 2nd, 3rd, and 4th
arguments to select.  Usually, this is C<fd_set *>, if C<HAS_FD_SET>
is defined, and C<int *> otherwise.  This is only useful if you 
have select(), naturally.

=item C<sendmail>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<sh>

From F<sh.U>:

This variable contains the full pathname of the shell used
on this system to execute Bourne shell scripts.  Usually, this will be
F</bin/sh>, though it's possible that some systems will have F</bin/ksh>,
F</bin/pdksh>, F</bin/ash>, F</bin/bash>, or even something such as
D:F</bin/sh.exe>.
This unit comes before F<Options.U>, so you can't set sh with a C<-D>
option, though you can override this (and startsh)
with C<-O -Dsh=F</bin/whatever> -Dstartsh=whatever>

=item C<shar>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<sharpbang>

From F<spitshell.U>:

This variable contains the string #! if this system supports that
construct.

=item C<shmattype>

From F<d_shmat.U>:

This symbol contains the type of pointer returned by shmat().
It can be C<void *> or C<char *>.

=item C<shortsize>

From F<intsize.U>:

This variable contains the value of the C<SHORTSIZE> symbol which
indicates to the C program how many bytes there are in a short.

=item C<shrpenv>

From F<libperl.U>:

If the user builds a shared F<libperl.so>, then we need to tell the
C<perl> executable where it will be able to find the installed F<libperl.so>. 
One way to do this on some systems is to set the environment variable
C<LD_RUN_PATH> to the directory that will be the final location of the
shared F<libperl.so>.  The makefile can use this with something like
$shrpenv $(C<CC>) -o perl F<perlmain.o> $libperl $libs
Typical values are
shrpenv="env C<LD_RUN_PATH>=$F<archlibexp/C<CORE>>"
or
shrpenv=''
See the main perl F<Makefile.SH> for actual working usage.
Alternatively, we might be able to use a command line option such
as -R $F<archlibexp/C<CORE>> (Solaris, NetBSD) or -Wl,-rpath
$F<archlibexp/C<CORE>> (Linux).

=item C<shsharp>

From F<spitshell.U>:

This variable tells further Configure units whether your sh can
handle # comments.

=item C<sig_count>

From F<sig_name.U>:

This variable holds a number larger than the largest valid
signal number.  This is usually the same as the C<NSIG> macro.

=item C<sig_name>

From F<sig_name.U>:

This variable holds the signal names, space separated. The leading
C<SIG> in signal name is removed.  A C<ZERO> is prepended to the
list.  This is currently not used.

=item C<sig_name_init>

From F<sig_name.U>:

This variable holds the signal names, enclosed in double quotes and
separated by commas, suitable for use in the C<SIG_NAME> definition 
below.  A C<ZERO> is prepended to the list, and the list is 
terminated with a plain 0.  The leading C<SIG> in signal names
is removed. See sig_num.

=item C<sig_num>

From F<sig_name.U>:

This variable holds the signal numbers, space separated. A C<ZERO> is
prepended to the list (corresponding to the fake C<SIGZERO>), and 
the list is terminated with a 0.  Those numbers correspond to 
the value of the signal listed in the same place within the
sig_name list.

=item C<sig_num_init>

From F<sig_name.U>:

This variable holds the signal numbers, enclosed in double quotes and
separated by commas, suitable for use in the C<SIG_NUM> definition 
below.  A C<ZERO> is prepended to the list, and the list is 
terminated with a plain 0.

=item C<sig_size>

From F<sig_name.U>:

This variable contains the number of elements of the sig_name
and sig_num arrays, excluding the final C<NULL> entry.

=item C<signal_t>

From F<d_voidsig.U>:

This variable holds the type of the signal handler (void or int).

=item C<sitearch>

From F<sitearch.U>:

This variable contains the eventual value of the C<SITEARCH> symbol,
which is the name of the private library for this package.  It may
have a F<~> on the front. It is up to the makefile to eventually create
this directory while performing installation (with F<~> substitution).
The standard distribution will put nothing in this directory.
After perl has been installed, users may install their own local
architecture-dependent modules in this directory with
MakeMaker F<Makefile.PL>
or equivalent.  See C<INSTALL> for details.

=item C<sitearchexp>

From F<sitearch.U>:

This variable is the F<~name> expanded version of sitearch, so that you
may use it directly in Makefiles or shell scripts.

=item C<sitebin>

From F<sitebin.U>:

This variable holds the name of the directory in which the user wants
to put add-on publicly executable files for the package in question.  It
is most often a local directory such as F</usr/local/bin>. Programs using
this variable must be prepared to deal with F<~name> substitution.
The standard distribution will put nothing in this directory.
After perl has been installed, users may install their own local
executables in this directory with
MakeMaker F<Makefile.PL>
or equivalent.  See C<INSTALL> for details.

=item C<sitebinexp>

From F<sitebin.U>:

This is the same as the sitebin variable, but is filename expanded at
configuration time, for use in your makefiles.

=item C<sitelib>

From F<sitelib.U>:

This variable contains the eventual value of the C<SITELIB> symbol,
which is the name of the private library for this package.  It may
have a F<~> on the front. It is up to the makefile to eventually create
this directory while performing installation (with F<~> substitution).
The standard distribution will put nothing in this directory.
After perl has been installed, users may install their own local
architecture-independent modules in this directory with
MakeMaker F<Makefile.PL>
or equivalent.  See C<INSTALL> for details.

=item C<sitelib_stem>

From F<sitelib.U>:

This variable is $sitelibexp with any trailing version-specific component
removed.  The elements in inc_version_list (F<inc_version_list.U>) can
be tacked onto this variable to generate a list of directories to search.

=item C<sitelibexp>

From F<sitelib.U>:

This variable is the F<~name> expanded version of sitelib, so that you
may use it directly in Makefiles or shell scripts.

=item C<siteprefix>

From F<siteprefix.U>:

This variable holds the full absolute path of the directory below
which the user will install add-on packages.
See C<INSTALL> for usage and examples.

=item C<siteprefixexp>

From F<siteprefix.U>:

This variable holds the full absolute path of the directory below
which the user will install add-on packages.  Derived from siteprefix.

=item C<sizesize>

From F<sizesize.U>:

This variable contains the size of a sizetype in bytes.

=item C<sizetype>

From F<sizetype.U>:

This variable defines sizetype to be something like size_t, 
unsigned long, or whatever type is used to declare length 
parameters for string functions.

=item C<sleep>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<smail>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<so>

From F<so.U>:

This variable holds the extension used to identify shared libraries
(also known as shared objects) on the system. Usually set to C<so>.

=item C<sockethdr>

From F<d_socket.U>:

This variable has any cpp C<-I> flags needed for socket support.

=item C<socketlib>

From F<d_socket.U>:

This variable has the names of any libraries needed for socket support.

=item C<socksizetype>

From F<socksizetype.U>:

This variable holds the type used for the size argument
for various socket calls like accept.  Usual values include
socklen_t, size_t, and int.

=item C<sort>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the sort program.  After Configure runs,
the value is reset to a plain C<sort> and is not useful.

=item C<spackage>

From F<package.U>:

This variable contains the name of the package being constructed,
with the first letter uppercased, F<i.e>. suitable for starting
sentences.

=item C<spitshell>

From F<spitshell.U>:

This variable contains the command necessary to spit out a runnable
shell on this system.  It is either cat or a grep C<-v> for # comments.

=item C<sPRId64>

From F<quadfio.U>:

This variable, if defined, contains the string used by stdio to
format 64-bit decimal numbers (format C<d>) for output.

=item C<sPRIeldbl>

From F<longdblfio.U>:

This variable, if defined, contains the string used by stdio to
format long doubles (format C<e>) for output.

=item C<sPRIEUldbl>

From F<longdblfio.U>:

This variable, if defined, contains the string used by stdio to
format long doubles (format C<E>) for output.
The C<U> in the name is to separate this from sPRIeldbl so that even
case-blind systems can see the difference.

=item C<sPRIfldbl>

From F<longdblfio.U>:

This variable, if defined, contains the string used by stdio to
format long doubles (format C<f>) for output.

=item C<sPRIFUldbl>

From F<longdblfio.U>:

This variable, if defined, contains the string used by stdio to
format long doubles (format C<F>) for output.
The C<U> in the name is to separate this from sPRIfldbl so that even
case-blind systems can see the difference.

=item C<sPRIgldbl>

From F<longdblfio.U>:

This variable, if defined, contains the string used by stdio to
format long doubles (format C<g>) for output.

=item C<sPRIGUldbl>

From F<longdblfio.U>:

This variable, if defined, contains the string used by stdio to
format long doubles (format C<G>) for output.
The C<U> in the name is to separate this from sPRIgldbl so that even
case-blind systems can see the difference.

=item C<sPRIi64>

From F<quadfio.U>:

This variable, if defined, contains the string used by stdio to
format 64-bit decimal numbers (format C<i>) for output.

=item C<sPRIo64>

From F<quadfio.U>:

This variable, if defined, contains the string used by stdio to
format 64-bit octal numbers (format C<o>) for output.

=item C<sPRIu64>

From F<quadfio.U>:

This variable, if defined, contains the string used by stdio to
format 64-bit unsigned decimal numbers (format C<u>) for output.

=item C<sPRIx64>

From F<quadfio.U>:

This variable, if defined, contains the string used by stdio to
format 64-bit hexadecimal numbers (format C<x>) for output.

=item C<sPRIXU64>

From F<quadfio.U>:

This variable, if defined, contains the string used by stdio to
format 64-bit hExADECimAl numbers (format C<X>) for output.
The C<U> in the name is to separate this from sPRIx64 so that even
case-blind systems can see the difference.

=item C<src>

From F<src.U>:

This variable holds the path to the package source. It is up to
the Makefile to use this variable and set C<VPATH> accordingly to
find the sources remotely.

=item C<sSCNfldbl>

From F<longdblfio.U>:

This variable, if defined, contains the string used by stdio to
format long doubles (format C<f>) for input.

=item C<ssizetype>

From F<ssizetype.U>:

This variable defines ssizetype to be something like ssize_t, 
long or int.  It is used by functions that return a count 
of bytes or an error condition.  It must be a signed type.
We will pick a type such that sizeof(SSize_t) == sizeof(Size_t).

=item C<startperl>

From F<startperl.U>:

This variable contains the string to put on the front of a perl
script to make sure (hopefully) that it runs with perl and not some
shell. Of course, that leading line must be followed by the classical
perl idiom:
eval 'exec perl -S $0 ${1+C<$@>}'
if $running_under_some_shell;
to guarantee perl startup should the shell execute the script. Note
that this magic incatation is not understood by csh.

=item C<startsh>

From F<startsh.U>:

This variable contains the string to put on the front of a shell
script to make sure (hopefully) that it runs with sh and not some
other shell.

=item C<static_ext>

From F<Extensions.U>:

This variable holds a list of C<XS> extension files we want to
link statically into the package.  It is used by Makefile.

=item C<stdchar>

From F<stdchar.U>:

This variable conditionally defines C<STDCHAR> to be the type of char
used in F<stdio.h>.  It has the values "unsigned char" or C<char>.

=item C<stdio_base>

From F<d_stdstdio.U>:

This variable defines how, given a C<FILE> pointer, fp, to access the
_base field (or equivalent) of F<stdio.h>'s C<FILE> structure.  This will
be used to define the macro FILE_base(fp).

=item C<stdio_bufsiz>

From F<d_stdstdio.U>:

This variable defines how, given a C<FILE> pointer, fp, to determine
the number of bytes store in the F<I/O> buffer pointer to by the
_base field (or equivalent) of F<stdio.h>'s C<FILE> structure.  This will
be used to define the macro FILE_bufsiz(fp).

=item C<stdio_cnt>

From F<d_stdstdio.U>:

This variable defines how, given a C<FILE> pointer, fp, to access the
_cnt field (or equivalent) of F<stdio.h>'s C<FILE> structure.  This will
be used to define the macro FILE_cnt(fp).

=item C<stdio_filbuf>

From F<d_stdstdio.U>:

This variable defines how, given a C<FILE> pointer, fp, to tell
stdio to refill it's internal buffers (?).  This will
be used to define the macro FILE_filbuf(fp).

=item C<stdio_ptr>

From F<d_stdstdio.U>:

This variable defines how, given a C<FILE> pointer, fp, to access the
_ptr field (or equivalent) of F<stdio.h>'s C<FILE> structure.  This will
be used to define the macro FILE_ptr(fp).

=item C<stdio_stream_array>

From F<stdio_streams.U>:

This variable tells the name of the array holding the stdio streams.
Usual values include _iob, __iob, and __sF.

=item C<strings>

From F<i_string.U>:

This variable holds the full path of the string header that will be
used. Typically F</usr/include/string.h> or F</usr/include/strings.h>.

=item C<submit>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<subversion>

From F<patchlevel.U>:

The subversion level of this package.
The value of subversion comes from the F<patchlevel.h> file.
In a version number such as 5.6.1, this is the C<1>.
In F<patchlevel.h>, this is referred to as C<PERL_SUBVERSION>.
This is unique to perl.

=item C<sysman>

From F<sysman.U>:

This variable holds the place where the manual is located on this
system. It is not the place where the user wants to put his manual
pages. Rather it is the place where Configure may look to find manual
for unix commands (section 1 of the manual usually). See mansrc.

=back

=head2 t

=over

=item C<tail>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<tar>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<tbl>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<tee>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<test>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the test program.  After Configure runs,
the value is reset to a plain C<test> and is not useful.

=item C<timeincl>

From F<i_time.U>:

This variable holds the full path of the included time header(s).

=item C<timetype>

From F<d_time.U>:

This variable holds the type returned by time(). It can be long,
or time_t on C<BSD> sites (in which case <sys/types.h> should be
included). Anyway, the type Time_t should be used.

=item C<touch>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the touch program.  After Configure runs,
the value is reset to a plain C<touch> and is not useful.

=item C<tr>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the tr program.  After Configure runs,
the value is reset to a plain C<tr> and is not useful.

=item C<trnl>

From F<trnl.U>:

This variable contains the value to be passed to the tr(1)
command to transliterate a newline.  Typical values are
C<\012> and C<\n>.  This is needed for C<EBCDIC> systems where
newline is not necessarily C<\012>.

=item C<troff>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=back

=head2 u

=over

=item C<u16size>

From F<perlxv.U>:

This variable is the size of an U16 in bytes.

=item C<u16type>

From F<perlxv.U>:

This variable contains the C type used for Perl's U16.

=item C<u32size>

From F<perlxv.U>:

This variable is the size of an U32 in bytes.

=item C<u32type>

From F<perlxv.U>:

This variable contains the C type used for Perl's U32.

=item C<u64size>

From F<perlxv.U>:

This variable is the size of an U64 in bytes.

=item C<u64type>

From F<perlxv.U>:

This variable contains the C type used for Perl's U64.

=item C<u8size>

From F<perlxv.U>:

This variable is the size of an U8 in bytes.

=item C<u8type>

From F<perlxv.U>:

This variable contains the C type used for Perl's U8.

=item C<uidformat>

From F<uidf.U>:

This variable contains the format string used for printing a Uid_t.

=item C<uidsign>

From F<uidsign.U>:

This variable contains the signedness of a uidtype.
1 for unsigned, -1 for signed.

=item C<uidsize>

From F<uidsize.U>:

This variable contains the size of a uidtype in bytes.

=item C<uidtype>

From F<uidtype.U>:

This variable defines Uid_t to be something like uid_t, int, 
ushort, or whatever type is used to declare user ids in the kernel.

=item C<uname>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the uname program.  After Configure runs,
the value is reset to a plain C<uname> and is not useful.

=item C<uniq>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the uniq program.  After Configure runs,
the value is reset to a plain C<uniq> and is not useful.

=item C<uquadtype>

From F<quadtype.U>:

This variable defines Uquad_t to be something like unsigned long,
unsigned int, unsigned long long, uint64_t, or whatever type is
used for 64-bit integers.

=item C<use5005threads>

From F<usethreads.U>:

This variable conditionally defines the USE_5005THREADS symbol,
and indicates that Perl should be built to use the 5.005-based
threading implementation.

=item C<use64bitall>

From F<use64bits.U>:

This variable conditionally defines the USE_64_BIT_ALL symbol,
and indicates that 64-bit integer types should be used
when available.  The maximal possible
64-bitness is employed: LP64 or ILP64, meaning that you will
be able to use more than 2 gigabytes of memory.  This mode is
even more binary incompatible than USE_64_BIT_INT. You may not
be able to run the resulting executable in a 32-bit C<CPU> at all or
you may need at least to reboot your C<OS> to 64-bit mode.

=item C<use64bitint>

From F<use64bits.U>:

This variable conditionally defines the USE_64_BIT_INT symbol,
and indicates that 64-bit integer types should be used
when available.  The minimal possible 64-bitness
is employed, just enough to get 64-bit integers into Perl.
This may mean using for example "long longs", while your memory
may still be limited to 2 gigabytes.

=item C<usedl>

From F<dlsrc.U>:

This variable indicates if the system supports dynamic
loading of some sort.  See also dlsrc and dlobj.

=item C<useithreads>

From F<usethreads.U>:

This variable conditionally defines the C<USE_ITHREADS> symbol,
and indicates that Perl should be built to use the interpreter-based
threading implementation.

=item C<uselargefiles>

From F<uselfs.U>:

This variable conditionally defines the C<USE_LARGE_FILES> symbol,
and indicates that large file interfaces should be used when
available.

=item C<uselongdouble>

From F<uselongdbl.U>:

This variable conditionally defines the C<USE_LONG_DOUBLE> symbol,
and indicates that long doubles should be used when available.

=item C<usemorebits>

From F<usemorebits.U>:

This variable conditionally defines the C<USE_MORE_BITS> symbol,
and indicates that explicit 64-bit interfaces and long doubles
should be used when available.

=item C<usemultiplicity>

From F<usemultiplicity.U>:

This variable conditionally defines the C<MULTIPLICITY> symbol,
and indicates that Perl should be built to use multiplicity.

=item C<usemymalloc>

From F<mallocsrc.U>:

This variable contains y if the malloc that comes with this package
is desired over the system's version of malloc.  People often include
special versions of malloc for effiency, but such versions are often
less portable.  See also mallocsrc and mallocobj.
If this is C<y>, then -lmalloc is removed from $libs.

=item C<usenm>

From F<usenm.U>:

This variable contains C<true> or C<false> depending whether the
nm extraction is wanted or not.

=item C<useopcode>

From F<Extensions.U>:

This variable holds either C<true> or C<false> to indicate
whether the Opcode extension should be used.  The sole
use for this currently is to allow an easy mechanism
for users to skip the Opcode extension from the Configure
command line.

=item C<useperlio>

From F<useperlio.U>:

This variable conditionally defines the C<USE_PERLIO> symbol,
and indicates that the PerlIO abstraction should be
used throughout.

=item C<useposix>

From F<Extensions.U>:

This variable holds either C<true> or C<false> to indicate
whether the C<POSIX> extension should be used.  The sole
use for this currently is to allow an easy mechanism
for hints files to indicate that C<POSIX> will not compile
on a particular system.

=item C<usesfio>

From F<d_sfio.U>:

This variable is set to true when the user agrees to use sfio.
It is set to false when sfio is not available or when the user
explicitely requests not to use sfio.  It is here primarily so
that command-line settings can override the auto-detection of
d_sfio without running into a "WHOA THERE".

=item C<useshrplib>

From F<libperl.U>:

This variable is set to C<yes> if the user wishes
to build a shared libperl, and C<no> otherwise.

=item C<usesocks>

From F<usesocks.U>:

This variable conditionally defines the C<USE_SOCKS> symbol,
and indicates that Perl should be built to use C<SOCKS>.

=item C<usethreads>

From F<usethreads.U>:

This variable conditionally defines the C<USE_THREADS> symbol,
and indicates that Perl should be built to use threads.

=item C<usevendorprefix>

From F<vendorprefix.U>:

This variable tells whether the vendorprefix
and consequently other vendor* paths are in use.

=item C<usevfork>

From F<d_vfork.U>:

This variable is set to true when the user accepts to use vfork.
It is set to false when no vfork is available or when the user
explicitely requests not to use vfork.

=item C<usrinc>

From F<usrinc.U>:

This variable holds the path of the include files, which is
usually F</usr/include>. It is mainly used by other Configure units.

=item C<uuname>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<uvoformat>

From F<perlxvf.U>:

This variable contains the format string used for printing
a Perl C<UV> as an unsigned octal integer. 

=item C<uvsize>

From F<perlxv.U>:

This variable is the size of a C<UV> in bytes.

=item C<uvtype>

From F<perlxv.U>:

This variable contains the C type used for Perl's C<UV>.

=item C<uvuformat>

From F<perlxvf.U>:

This variable contains the format string used for printing
a Perl C<UV> as an unsigned decimal integer. 

=item C<uvxformat>

From F<perlxvf.U>:

This variable contains the format string used for printing
a Perl C<UV> as an unsigned hexadecimal integer in lowercase abcdef.

=item C<uvXUformat>

From F<perlxvf.U>:

This variable contains the format string used for printing
a Perl C<UV> as an unsigned hexadecimal integer in uppercase C<ABCDEF>.

=back

=head2 v

=over

=item C<vendorarch>

From F<vendorarch.U>:

This variable contains the value of the C<PERL_VENDORARCH> symbol.
It may have a F<~> on the front. 
The standard distribution will put nothing in this directory.
Vendors who distribute perl may wish to place their own
architecture-dependent modules and extensions in this directory with
MakeMaker F<Makefile.PL> C<INSTALLDIRS>=vendor 
or equivalent.  See C<INSTALL> for details.

=item C<vendorarchexp>

From F<vendorarch.U>:

This variable is the F<~name> expanded version of vendorarch, so that you
may use it directly in Makefiles or shell scripts.

=item C<vendorbin>

From F<vendorbin.U>:

This variable contains the eventual value of the C<VENDORBIN> symbol.
It may have a F<~> on the front.
The standard distribution will put nothing in this directory.
Vendors who distribute perl may wish to place additional
binaries in this directory with
MakeMaker F<Makefile.PL> C<INSTALLDIRS>=vendor 
or equivalent.  See C<INSTALL> for details.

=item C<vendorbinexp>

From F<vendorbin.U>:

This variable is the F<~name> expanded version of vendorbin, so that you
may use it directly in Makefiles or shell scripts.

=item C<vendorlib>

From F<vendorlib.U>:

This variable contains the eventual value of the C<VENDORLIB> symbol,
which is the name of the private library for this package.
The standard distribution will put nothing in this directory.
Vendors who distribute perl may wish to place their own
modules in this directory with
MakeMaker F<Makefile.PL> C<INSTALLDIRS>=vendor 
or equivalent.  See C<INSTALL> for details.

=item C<vendorlib_stem>

From F<vendorlib.U>:

This variable is $vendorlibexp with any trailing version-specific component
removed.  The elements in inc_version_list (F<inc_version_list.U>) can
be tacked onto this variable to generate a list of directories to search.

=item C<vendorlibexp>

From F<vendorlib.U>:

This variable is the F<~name> expanded version of vendorlib, so that you
may use it directly in Makefiles or shell scripts.

=item C<vendorprefix>

From F<vendorprefix.U>:

This variable holds the full absolute path of the directory below
which the vendor will install add-on packages.
See C<INSTALL> for usage and examples.

=item C<vendorprefixexp>

From F<vendorprefix.U>:

This variable holds the full absolute path of the directory below
which the vendor will install add-on packages.  Derived from vendorprefix.

=item C<version>

From F<patchlevel.U>:

The full version number of this package, such as 5.6.1 (or 5_6_1).
This combines revision, patchlevel, and subversion to get the
full version number, including any possible subversions.
This is suitable for use as a directory name, and hence is
filesystem dependent.

=item C<versiononly>

From F<versiononly.U>:

If set, this symbol indicates that only the version-specific
components of a perl installation should be installed.
This may be useful for making a test installation of a new
version without disturbing the existing installation.
Setting versiononly is equivalent to setting installperl's -v option.
In particular, the non-versioned scripts and programs such as
a2p, c2ph, h2xs, pod2*, and perldoc are not installed
(see C<INSTALL> for a more complete list).  Nor are the man
pages installed.
Usually, this is undef.

=item C<vi>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<voidflags>

From F<voidflags.U>:

This variable contains the eventual value of the C<VOIDFLAGS> symbol,
which indicates how much support of the void type is given by this
compiler.  See C<VOIDFLAGS> for more info.

=back

=head2 x

=over

=item C<xlibpth>

From F<libpth.U>:

This variable holds extra path (space-separated) used to find
libraries on this platform, for example C<CPU>-specific libraries
(on multi-C<CPU> platforms) may be listed here.

=item C<xs_apiversion>

From F<xs_apiversion.U>:

This variable contains the version of the oldest perl binary
compatible with the present perl.  F<perl.c>:incpush() and
F<lib/lib.pm> will automatically search in $sitearch for older
directories across major versions back to xs_apiversion.
This is only useful if you have a perl library directory tree
structured like the default one.
See C<INSTALL> for how this works.
The versioned site_perl directory was introduced in 5.005,
so that is the lowest possible value.
Since this can depend on compile time options (such as
bincompat) it is set by Configure.  Other non-default sources
of potential incompatibility, such as multiplicity, threads,
debugging, 64bits, sfio, F<etc.>, are not checked for currently,
though in principle we could go snooping around in old
F<Config.pm> files.

=back

=head2 z

=over

=item C<zcat>

From F<Loc.U>:

This variable is defined but not used by Configure.
The value is a plain '' and is not useful.

=item C<zip>

From F<Loc.U>:

This variable is used internally by Configure to determine the
full pathname (if any) of the zip program.  After Configure runs,
the value is reset to a plain C<zip> and is not useful.


=back

=head1 NOTE

This module contains a good example of how to use tie to implement a
cache and an example of how to make a tied variable readonly to those
outside of it.

=cut

messages to the HTTP server error log.

For exampl                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                package constant;

use strict;
use 5.005_64;
use warnings::register;

our($VERSION, %declared);
$VERSION = '1.02';

#=======================================================================

# Some names are evil choices.
my %keywords = map +($_, 1), qw{ BEGIN INIT CHECK END DESTROY AUTOLOAD };

my %forced_into_main = map +($_, 1),
    qw{ STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG };

my %forbidden = (%keywords, %forced_into_main);

#=======================================================================
# import() - import symbols into user's namespace
#
# What we actually do is define a function in the caller's namespace
# which returns the value. The function we create will normally
# be inlined as a constant, thereby avoiding further sub calling 
# overhead.
#=======================================================================
sub import {
    my $class = shift;
    return unless @_;			# Ignore 'use constant;'
    my $name = shift;
    unless (defined $name) {
        require Carp;
	Carp::croak("Can't use undef as constant name");
    }
    my $pkg = caller;

    # Normal constant name
    if ($name =~ /^_?[^\W_0-9]\w*\z/ and !$forbidden{$name}) {
        # Everything is okay

    # Name forced into main, but we're not in main. Fatal.
    } elsif ($forced_into_main{$name} and $pkg ne 'main') {
	require Carp;
	Carp::croak("Constant name '$name' is forced into main::");

    # Starts with double underscore. Fatal.
    } elsif ($name =~ /^__/) {
	require Carp;
	Carp::croak("Constant name '$name' begins with '__'");

    # Maybe the name is tolerable
    } elsif ($name =~ /^[A-Za-z_]\w*\z/) {
	# Then we'll warn only if you've asked for warnings
	if (warnings::enabled()) {
	    if ($keywords{$name}) {
		warnings::warn("Constant name '$name' is a Perl keyword");
	    } elsif ($forced_into_main{$name}) {
		warnings::warn("Constant name '$name' is " .
		    "forced into package main::");
	    } else {
		# Catch-all - what did I miss? If you get this error,
		# please let me know what your constant's name was.
		# Write to <rootbeer@redcat.com>. Thanks!
		warnings::warn("Constant name '$name' has unknown problems");
	    }
	}

    # Looks like a boolean
    # 		use constant FRED == fred;
    } elsif ($name =~ /^[01]?\z/) {
        require Carp;
	if (@_) {
	    Carp::croak("Constant name '$name' is invalid");
	} else {
	    Carp::croak("Constant name looks like boolean value");
	}

    } else {
	# Must have bad characters
        require Carp;
	Carp::croak("Constant name '$name' has invalid characters");
    }

    {
	no strict 'refs';
	my $full_name = "${pkg}::$name";
	$declared{$full_name}++;
	if (@_ == 1) {
	    my $scalar = $_[0];
	    *$full_name = sub () { $scalar };
	} elsif (@_) {
	    my @list = @_;
	    *$full_name = sub () { @list };
	} else {
	    *$full_name = sub () { };
	}
    }

}

1;

__END__

=head1 NAME

constant - Perl pragma to declare constants

=head1 SYNOPSIS

    use constant BUFFER_SIZE	=> 4096;
    use constant ONE_YEAR	=> 365.2425 * 24 * 60 * 60;
    use constant PI		=> 4 * atan2 1, 1;
    use constant DEBUGGING	=> 0;
    use constant ORACLE		=> 'oracle@cs.indiana.edu';
    use constant USERNAME	=> scalar getpwuid($<);
    use constant USERINFO	=> getpwuid($<);

    sub deg2rad { PI * $_[0] / 180 }

    print "This line does nothing"		unless DEBUGGING;

    # references can be constants
    use constant CHASH		=> { foo => 42 };
    use constant CARRAY		=> [ 1,2,3,4 ];
    use constant CPSEUDOHASH	=> [ { foo => 1}, 42 ];
    use constant CCODE		=> sub { "bite $_[0]\n" };

    print CHASH->{foo};
    print CARRAY->[$i];
    print CPSEUDOHASH->{foo};
    print CCODE->("me");
    print CHASH->[10];			# compile-time error

=head1 DESCRIPTION

This will declare a symbol to be a constant with the given scalar
or list value.

When you declare a constant such as C<PI> using the method shown
above, each machine your script runs upon can have as many digits
of accuracy as it can use. Also, your program will be easier to
read, more likely to be maintained (and maintained correctly), and
far less likely to send a space probe to the wrong planet because
nobody noticed the one equation in which you wrote C<3.14195>.

=head1 NOTES

The value or values are evaluated in a list context. You may override
this with C<scalar> as shown above.

These constants do not directly interpolate into double-quotish
strings, although you may do so indirectly. (See L<perlref> for
details about how this works.)

    print "The value of PI is @{[ PI ]}.\n";

List constants are returned as lists, not as arrays.

    $homedir = USERINFO[7];		# WRONG
    $homedir = (USERINFO)[7];		# Right

The use of all caps for constant names is merely a convention,
although it is recommended in order to make constants stand out
and to help avoid collisions with other barewords, keywords, and
subroutine names. Constant names must begin with a letter or
underscore. Names beginning with a double underscore are reserved. Some
poor choices for names will generate warnings, if warnings are enabled at
compile time.

Constant symbols are package scoped (rather than block scoped, as
C<use strict> is). That is, you can refer to a constant from package
Other as C<Other::CONST>.

As with all C<use> directives, defining a constant happens at
compile time. Thus, it's probably not correct to put a constant
declaration inside of a conditional statement (like C<if ($foo)
{ use constant ... }>).

Omitting the value for a symbol gives it the value of C<undef> in
a scalar context or the empty list, C<()>, in a list context. This
isn't so nice as it may sound, though, because in this case you
must either quote the symbol name, or use a big arrow, (C<=E<gt>>),
with nothing to point to. It is probably best to declare these
explicitly.

    use constant UNICORNS	=> ();
    use constant LOGFILE	=> undef;

The result from evaluating a list constant in a scalar context is
not documented, and is B<not> guaranteed to be any particular value
in the future. In particular, you should not rely upon it being
the number of elements in the list, especially since it is not
B<necessarily> that value in the current implementation.

Magical values, tied values, and references can be made into
constants at compile time, allowing for way cool stuff like this.
(These error numbers aren't totally portable, alas.)

    use constant E2BIG => ($! = 7);
    print   E2BIG, "\n";	# something like "Arg list too long"
    print 0+E2BIG, "\n";	# "7"

Dereferencing constant references incorrectly (such as using an array
subscript on a constant hash reference, or vice versa) will be trapped at
compile time.

In the rare case in which you need to discover at run time whether a
particular constant has been declared via this module, you may use
this function to examine the hash C<%constant::declared>. If the given
constant name does not include a package name, the current package is
used.

    sub declared ($) {
	use constant 1.01;		# don't omit this!
	my $name = shift;
	$name =~ s/^::/main::/;
	my $pkg = caller;
	my $full_name = $name =~ /::/ ? $name : "${pkg}::$name";
	$constant::declared{$full_name};
    }

=head1 TECHNICAL NOTE

In the current implementation, scalar constants are actually
inlinable subroutines. As of version 5.004 of Perl, the appropriate
scalar constant is inserted directly in place of some subroutine
calls, thereby saving the overhead of a subroutine call. See
L<perlsub/"Constant Functions"> for details about how and when this
happens.

=head1 BUGS

In the current version of Perl, list constants are not inlined
and some symbols may be redefined without generating a warning.

It is not possible to have a subroutine or keyword with the same
name as a constant in the same package. This is probably a Good Thing.

A constant with a name in the list C<STDIN STDOUT STDERR ARGV ARGVOUT
ENV INC SIG> is not allowed anywhere but in package C<main::>, for
technical reasons. 

Even though a reference may be declared as a constant, the reference may
point to data which may be changed, as this code shows.

    use constant CARRAY		=> [ 1,2,3,4 ];
    print CARRAY->[1];
    CARRAY->[1] = " be changed";
    print CARRAY->[1];

Unlike constants in some languages, these cannot be overridden
on the command line or via environment variables.

You can get into trouble if you use constants in a context which
automatically quotes barewords (as is true for any subroutine call).
For example, you can't say C<$hash{CONSTANT}> because C<CONSTANT> will
be interpreted as a string.  Use C<$hash{CONSTANT()}> or
C<$hash{+CONSTANT}> to prevent the bareword quoting mechanism from
kicking in.  Similarly, since the C<=E<gt>> operator quotes a bareword
immediately to its left, you have to say C<CONSTANT() =E<gt> 'value'>
(or simply use a comma in place of the big arrow) instead of
C<CONSTANT =E<gt> 'value'>.

=head1 AUTHOR

Tom Phoenix, E<lt>F<rootbeer@redcat.com>E<gt>, with help from
many other folks.

=head1 COPYRIGHT

Copyright (C) 1997, 1999 Tom Phoenix

This module is free software; you can redistribute it or modify it
under the same terms as Perl itself.

=cut
 @_;
    my($no) = fileno(to_filehandle($in));
    realdie("Invalid fileh                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                package Convert::BinHex;


=head1 NAME

Convert::BinHex - extract data from Macintosh BinHex files

I<ALPHA WARNING: this code is currently in its Alpha release.
Things may change drastically until the interface is hammered out:
if you have suggestions or objections, please speak up now!>


=head1 SYNOPSIS

B<Simple functions:>

    use Convert::BinHex qw(binhex_crc macbinary_crc);

    # Compute HQX7-style CRC for data, pumping in old CRC if desired:
    $crc = binhex_crc($data, $crc);

    # Compute the MacBinary-II-style CRC for the data:
    $crc = macbinary_crc($data, $crc);

B<Hex to bin, low-level interface.>
Conversion is actually done via an object (L<"Convert::BinHex::Hex2Bin">)
which keeps internal conversion state:

    # Create and use a "translator" object:
    my $H2B = Convert::BinHex->hex2bin;    # get a converter object
    while (<STDIN>) {
	print $STDOUT $H2B->next($_);        # convert some more input
    }
    print $STDOUT $H2B->done;              # no more input: finish up

B<Hex to bin, OO interface.>
The following operations I<must> be done in the order shown!

    # Read data in piecemeal:
    $HQX = Convert::BinHex->open(FH=>\*STDIN) || die "open: $!";
    $HQX->read_header;                  # read header info
    @data = $HQX->read_data;            # read in all the data
    @rsrc = $HQX->read_resource;        # read in all the resource

B<Bin to hex, low-level interface.>
Conversion is actually done via an object (L<"Convert::BinHex::Bin2Hex">)
which keeps internal conversion state:

    # Create and use a "translator" object:
    my $B2H = Convert::BinHex->bin2hex;    # get a converter object
    while (<STDIN>) {
	print $STDOUT $B2H->next($_);        # convert some more input
    }
    print $STDOUT $B2H->done;              # no more input: finish up

B<Bin to hex, file interface.>  Yes, you can convert I<to> BinHex
as well as from it!

    # Create new, empty object:
    my $HQX = Convert::BinHex->new;

    # Set header attributes:
    $HQX->filename("logo.gif");
    $HQX->type("GIFA");
    $HQX->creator("CNVS");

    # Give it the data and resource forks (either can be absent):
    $HQX->data(Path => "/path/to/data");       # here, data is on disk
    $HQX->resource(Data => $resourcefork);     # here, resource is in core

    # Output as a BinHex stream, complete with leading comment:
    $HQX->encode(\*STDOUT);

B<PLANNED!!!! Bin to hex, "CAP" interface.>
I<Thanks to Ken Lunde for suggesting this>.

    # Create new, empty object from CAP tree:
    my $HQX = Convert::BinHex->from_cap("/path/to/root/file");
    $HQX->encode(\*STDOUT);


=head1 DESCRIPTION

B<BinHex> is a format used by Macintosh for transporting Mac files
safely through electronic mail, as short-lined, 7-bit, semi-compressed
data streams.  Ths module provides a means of converting those
data streams back into into binary data.


=head1 FORMAT

I<(Some text taken from RFC-1741.)>
Files on the Macintosh consist of two parts, called I<forks>:

=over 4

=item Data fork

The actual data included in the file.  The Data fork is typically the
only meaningful part of a Macintosh file on a non-Macintosh computer system.
For example, if a Macintosh user wants to send a file of data to a
user on an IBM-PC, she would only send the Data fork.

=item Resource fork

Contains a collection of arbitrary attribute/value pairs, including
program segments, icon bitmaps, and parametric values.

=back

Additional information regarding Macintosh files is stored by the
Finder in a hidden file, called the "Desktop Database".

Because of the complications in storing different parts of a
Macintosh file in a non-Macintosh filesystem that only handles
consecutive data in one part, it is common to convert the Macintosh
file into some other format before transferring it over the network.
The BinHex format squashes that data into transmittable ASCII as follows:

=over 4

=item 1.

The file is output as a B<byte stream> consisting of some basic header
information (filename, type, creator), then the data fork, then the
resource fork.

=item 2.

The byte stream is B<compressed> by looking for series of duplicated
bytes and representing them using a special binary escape sequence
(of course, any occurences of the escape character must also be escaped).

=item 3.

The compressed stream is B<encoded> via the "6/8 hemiola" common
to I<base64> and I<uuencode>: each group of three 8-bit bytes (24 bits)
is chopped into four 6-bit numbers, which are used as indexes into
an ASCII "alphabet".
(I assume that leftover bytes are zero-padded; documentation is thin).

=back

=cut

use strict;
use vars qw(@ISA @EXPORT_OK $VERSION $QUIET);
use integer;

use Carp;
use Exporter;
use FileHandle;

@ISA = qw(Exporter);
@EXPORT_OK = qw(
		macbinary_crc
		binhex_crc
		);



# The package version, both in 1.23 style *and* usable by MakeMaker:
$VERSION = substr q$Revision: 1.119 $, 10;

# My identity:
my $I = 'binhex:';

# Utility function:
sub min {
    my ($a, $b) = @_;
    ($a < $b) ? $a : $b;
}

# An array useful for CRC calculations that use 0x1021 as the "seed":
my @MAGIC = (
    0x0000, 0x1021, 0x2042, 0x3063, 0x4084, 0x50a5, 0x60c6, 0x70e7,
    0x8108, 0x9129, 0xa14a, 0xb16b, 0xc18c, 0xd1ad, 0xe1ce, 0xf1ef,
    0x1231, 0x0210, 0x3273, 0x2252, 0x52b5, 0x4294, 0x72f7, 0x62d6,
    0x9339, 0x8318, 0xb37b, 0xa35a, 0xd3bd, 0xc39c, 0xf3ff, 0xe3de,
    0x2462, 0x3443, 0x0420, 0x1401, 0x64e6, 0x74c7, 0x44a4, 0x5485,
    0xa56a, 0xb54b, 0x8528, 0x9509, 0xe5ee, 0xf5cf, 0xc5ac, 0xd58d,
    0x3653, 0x2672, 0x1611, 0x0630, 0x76d7, 0x66f6, 0x5695, 0x46b4,
    0xb75b, 0xa77a, 0x9719, 0x8738, 0xf7df, 0xe7fe, 0xd79d, 0xc7bc,
    0x48c4, 0x58e5, 0x6886, 0x78a7, 0x0840, 0x1861, 0x2802, 0x3823,
    0xc9cc, 0xd9ed, 0xe98e, 0xf9af, 0x8948, 0x9969, 0xa90a, 0xb92b,
    0x5af5, 0x4ad4, 0x7ab7, 0x6a96, 0x1a71, 0x0a50, 0x3a33, 0x2a12,
    0xdbfd, 0xcbdc, 0xfbbf, 0xeb9e, 0x9b79, 0x8b58, 0xbb3b, 0xab1a,
    0x6ca6, 0x7c87, 0x4ce4, 0x5cc5, 0x2c22, 0x3c03, 0x0c60, 0x1c41,
    0xedae, 0xfd8f, 0xcdec, 0xddcd, 0xad2a, 0xbd0b, 0x8d68, 0x9d49,
    0x7e97, 0x6eb6, 0x5ed5, 0x4ef4, 0x3e13, 0x2e32, 0x1e51, 0x0e70,
    0xff9f, 0xefbe, 0xdfdd, 0xcffc, 0xbf1b, 0xaf3a, 0x9f59, 0x8f78,
    0x9188, 0x81a9, 0xb1ca, 0xa1eb, 0xd10c, 0xc12d, 0xf14e, 0xe16f,
    0x1080, 0x00a1, 0x30c2, 0x20e3, 0x5004, 0x4025, 0x7046, 0x6067,
    0x83b9, 0x9398, 0xa3fb, 0xb3da, 0xc33d, 0xd31c, 0xe37f, 0xf35e,
    0x02b1, 0x1290, 0x22f3, 0x32d2, 0x4235, 0x5214, 0x6277, 0x7256,
    0xb5ea, 0xa5cb, 0x95a8, 0x8589, 0xf56e, 0xe54f, 0xd52c, 0xc50d,
    0x34e2, 0x24c3, 0x14a0, 0x0481, 0x7466, 0x6447, 0x5424, 0x4405,
    0xa7db, 0xb7fa, 0x8799, 0x97b8, 0xe75f, 0xf77e, 0xc71d, 0xd73c,
    0x26d3, 0x36f2, 0x0691, 0x16b0, 0x6657, 0x7676, 0x4615, 0x5634,
    0xd94c, 0xc96d, 0xf90e, 0xe92f, 0x99c8, 0x89e9, 0xb98a, 0xa9ab,
    0x5844, 0x4865, 0x7806, 0x6827, 0x18c0, 0x08e1, 0x3882, 0x28a3,
    0xcb7d, 0xdb5c, 0xeb3f, 0xfb1e, 0x8bf9, 0x9bd8, 0xabbb, 0xbb9a,
    0x4a75, 0x5a54, 0x6a37, 0x7a16, 0x0af1, 0x1ad0, 0x2ab3, 0x3a92,
    0xfd2e, 0xed0f, 0xdd6c, 0xcd4d, 0xbdaa, 0xad8b, 0x9de8, 0x8dc9,
    0x7c26, 0x6c07, 0x5c64, 0x4c45, 0x3ca2, 0x2c83, 0x1ce0, 0x0cc1,
    0xef1f, 0xff3e, 0xcf5d, 0xdf7c, 0xaf9b, 0xbfba, 0x8fd9, 0x9ff8,
    0x6e17, 0x7e36, 0x4e55, 0x5e74, 0x2e93, 0x3eb2, 0x0ed1, 0x1ef0
);

# Ssssssssssshhhhhhhhhh:
$QUIET = 0;



#==============================

=head1 FUNCTIONS

=head2 CRC computation

=over 4

=cut

#------------------------------------------------------------

=item macbinary_crc DATA, SEED

Compute the MacBinary-II-style CRC for the given DATA, with the CRC
seeded to SEED.  Normally, you start with a SEED of 0, and you pump in
the previous CRC as the SEED if you're handling a lot of data one chunk
at a time.  That is:

    $crc = 0;
    while (<STDIN>) {
        $crc = macbinary_crc($_, $crc);
    }

I<Note:> Extracted from the I<mcvert> utility (Doug Moore, April '87),
using a "magic array" algorithm by Jim Van Verth for efficiency.
Converted to Perl5 by Eryq.  B<Untested.>

=cut

sub macbinary_crc {
    my $len = length($_[0]);
    my $crc = $_[1];
    my $i;
    for ($i = 0; $i < $len; $i++) {
	($crc ^= (vec($_[0], $i, 8) << 8)) &= 0xFFFF;
	$crc = ($crc << 8) ^ $MAGIC[$crc >> 8];
    }
    $crc;
}

#------------------------------------------------------------

=item binhex_crc DATA, SEED

Compute the HQX-style CRC for the given DATA, with the CRC seeded to SEED.
Normally, you start with a SEED of 0, and you pump in the previous CRC as
the SEED if you're handling a lot of data one chunk at a time.  That is:

    $crc = 0;
    while (<STDIN>) {
        $crc = binhex_crc($_, $crc);
    }

I<Note:> Extracted from the I<mcvert> utility (Doug Moore, April '87),
using a "magic array" algorithm by Jim Van Verth for efficiency.
Converted to Perl5 by Eryq.

=cut

sub binhex_crc {
    my $len = length($_[0]);
    my $crc = $_[1];
    my $i;
    for ($i = 0; $i < $len; $i++) {
	my $ocrc = $crc;
	$crc = (((($crc & 0xFF) << 8) | vec($_[0], $i, 8))
		^ $MAGIC[$crc >> 8]) & 0xFFFF;
	## printf "CRCin = %04x, char = %02x (%c), CRCout = %04x\n",
	##        $ocrc, vec($_[0], $i, 8), ord(substr($_[0], $i, 1)), $crc;
    }
    $crc;
}


=back

=cut



#==============================

=head1 OO INTERFACE

=head2 Conversion

=over 4

=cut

#------------------------------------------------------------

=item bin2hex

I<Class method, constructor.>
Return a converter object.  Just creates a new instance of
L<"Convert::BinHex::Bin2Hex">; see that class for details.

=cut

sub bin2hex {
    return Convert::BinHex::Bin2Hex->new;
}

#------------------------------------------------------------

=item hex2bin

I<Class method, constructor.>
Return a converter object.  Just creates a new instance of
L<"Convert::BinHex::Hex2Bin">; see that class for details.

=cut

sub hex2bin {
    return Convert::BinHex::Hex2Bin->new;
}

=back

=cut



#==============================

=head2 Construction

=over 4

=cut

#------------------------------------------------------------

=item new PARAMHASH

I<Class method, constructor.>
Return a handle on a BinHex'able entity.  In general, the data and resource
forks for such an entity are stored in native format (binary) format.

Parameters in the PARAMHASH are the same as header-oriented method names,
and may be used to set attributes:

    $HQX = new Convert::BinHex filename => "icon.gif",
                               type    => "GIFB",
                               creator => "CNVS";

=cut

sub new {
    my ($class, %params) = @_;

    # Create object:
    my $self = bless {
	Data => new Convert::BinHex::Fork,      # data fork
	Rsrc => new Convert::BinHex::Fork,      # resource fork
    }, $class;   # basic object

    # Process params:
    my $method;
    foreach $method (qw(creator	filename flags requires type version
			software_version)){
	$self->$method($params{$method}) if exists($params{$method});
    }
    $self;
}

#------------------------------------------------------------

=item open PARAMHASH

I<Class method, constructor.>
Return a handle on a new BinHex'ed stream, for parsing.
Params are:

=over 4

=item Data

Input a HEX stream from the given data.  This can be a scalar, or a
reference to an array of scalars.

=item Expr

Input a HEX stream from any open()able expression.  It will be opened and
binmode'd, and the filehandle will be closed either on a C<close()>
or when the object is destructed.

=item FH

Input a HEX stream from the given filehandle.

=item NoComment

If true, the parser should not attempt to skip a leading "(This file...)"
comment.  That means that the first nonwhite characters encountered
must be the binhex'ed data.

=back

=cut

sub open {
    my $self = shift;
    my %params = @_;

    # Create object:
    ref($self) or $self = $self->new;

    # Set up input:
    my $data;
    if ($params{FH}) {
	$self->{FH} = Convert::BinHex::IO_Handle->wrap($params{FH});
    }
    elsif ($params{Expr}) {
	$self->{FH} = FileHandle->new($params{Expr}) or
	    croak "$I can't open $params{Expr}: $!\n";
	$self->{FH} = Convert::BinHex::IO_Handle->wrap($self->{FH});
    }
    elsif ($params{Data}) {
	if (!ref($data = $params{Data})) {   # scalar
	    $self->{FH} = Convert::BinHex::IO_Scalar->wrap(\$data);
	}
	elsif (ref($data) eq 'ARRAY') {
	    $data = join('', @$data);
	    $self->{FH} = Convert::BinHex::IO_Scalar->wrap(\$data);
	}
    }
    $self->{FH} or croak "$I missing a valid input source\n";

    # Comments?
    $self->{CommentRead} = $params{NoComment};

    # Reset the converter!
    $self->{H2B} = Convert::BinHex::Hex2Bin->new;
    $self;
}


=back

=cut




#==============================

=head2 Get/set header information

=over 4

=cut

#------------------------------

=item creator [VALUE]

I<Instance method.>
Get/set the creator of the file.  This is a four-character
string (though I don't know if it's guaranteed to be printable ASCII!)
that serves as part of the Macintosh's version of a MIME "content-type".

For example, a document created by "Canvas" might have
creator C<"CNVS">.

=cut

sub creator  { (@_ > 1) ? ($_[0]->{Creator}  = $_[1]) : $_[0]->{Creator} }

#------------------------------

=item data [PARAMHASH]

I<Instance method.>
Get/set the data fork.  Any arguments are passed into the
new() method of L<"Convert::BinHex::Fork">.

=cut

sub data {
    my $self = shift;
    @_ ? $self->{Data} = Convert::BinHex::Fork->new(@_) : $self->{Data};
}

#------------------------------

=item filename [VALUE]

I<Instance method.>
Get/set the name of the file.

=cut

sub filename { (@_ > 1) ? ($_[0]->{Filename} = $_[1]) : $_[0]->{Filename} }

#------------------------------

=item flags [VALUE]

I<Instance method.>
Return the flags, as an integer.  Use bitmasking to get as the values
you need.

=cut

sub flags    { (@_ > 1) ? ($_[0]->{Flags}    = $_[1]) : $_[0]->{Flags} }

#------------------------------

=item header_as_string

Return a stringified version of the header that you might
use for logging/debugging purposes.  It looks like this:

    X-HQX-Software: BinHex 4.0 (Convert::BinHex 1.102)
    X-HQX-Filename: Something_new.eps
    X-HQX-Version: 0
    X-HQX-Type: EPSF
    X-HQX-Creator: ART5
    X-HQX-Data-Length: 49731
    X-HQX-Rsrc-Length: 23096

As some of you might have guessed, this is RFC-822-style, and
may be easily plunked down into the middle of a mail header, or
split into lines, etc.

=cut

sub header_as_string {
    my $self = shift;
    my @h;
    push @h, "X-HQX-Software: " .
	     "BinHex " . ($self->requires || '4.0') .
	     " (Convert::BinHex $VERSION)";
    push @h, "X-HQX-Filename: " . $self->filename;
    push @h, "X-HQX-Version: "  . $self->version;
    push @h, "X-HQX-Type: "     . $self->type;
    push @h, "X-HQX-Creator: "  . $self->creator;
    push @h, "X-HQX-Flags: "    . sprintf("%x", $self->flags);
    push @h, "X-HQX-Data-Length: " . $self->data->length;
    push @h, "X-HQX-Rsrc-Length: " . $self->resource->length;
    push @h, "X-HQX-CRC: "      . sprintf("%x", $self->{HdrCRC});
    return join("\n", @h) . "\n";
}

#------------------------------

=item requires [VALUE]

I<Instance method.>
Get/set the software version required to convert this file, as
extracted from the comment that preceded the actual binhex'ed
data; e.g.:

    (This file must be converted with BinHex 4.0)

In this case, after parsing in the comment, the code:

    $HQX->requires;

would get back "4.0".

=cut

sub requires  {
    (@_ > 1) ? ($_[0]->{Requires}  = $_[1]) : $_[0]->{Requires}
}
*software_version = \&requires;

#------------------------------

=item resource [PARAMHASH]

I<Instance method.>
Get/set the resource fork.  Any arguments are passed into the
new() method of L<"Convert::BinHex::Fork">.

=cut

sub resource {
    my $self = shift;
    @_ ? $self->{Rsrc} = Convert::BinHex::Fork->new(@_) : $self->{Rsrc};
}

#------------------------------

=item type [VALUE]

I<Instance method.>
Get/set the type of the file.  This is a four-character
string (though I don't know if it's guaranteed to be printable ASCII!)
that serves as part of the Macintosh's version of a MIME "content-type".

For example, a GIF89a file might have type C<"GF89">.

=cut

sub type  { (@_ > 1) ? ($_[0]->{Type}  = $_[1]) : $_[0]->{Type} }

#------------------------------

=item version [VALUE]

I<Instance method.>
Get/set the version, as an integer.

=cut

sub version  { (@_ > 1) ? ($_[0]->{Version}  = $_[1]) : $_[0]->{Version} }


=back

=cut

### OBSOLETE!!!
sub data_length     { shift->data->length(@_) }
sub resource_length { shift->resource->length(@_) }




#==============================

=head2 Decode, high-level

=over 4

=cut

#------------------------------------------------------------

=item read_comment

I<Instance method.>
Skip past the opening comment in the file, which is of the form:

   (This file must be converted with BinHex 4.0)

As per RFC-1741, I<this comment must immediately precede the BinHex data,>
and any text before it will be ignored.

I<You don't need to invoke this method yourself;> C<read_header()> will
do it for you.  After the call, the version number in the comment is
accessible via the C<requires()> method.

=cut

sub read_comment {
    my $self = shift;
    return 1 if ($self->{CommentRead});   # prevent accidents
    local($_);
    while (defined($_ = $self->{FH}->getline)) {
	chomp;
	if (/^\(This file must be converted with BinHex ([\d\.]+).*\)\s*$/i) {
	    $self->requires($1);
	    return $self->{CommentRead} = 1;
	}
    }
    croak "$I comment line (This file must be converted with BinHex...) ".
	  "not found\n";
}

#------------------------------------------------------------

=item read_header

I<Instance method.>
Read in the BinHex file header.  You must do this first!

=cut

sub read_header {
    my $self = shift;
    return 1 if ($self->{HeaderRead});   # prevent accidents

    # Skip comment:
    $self->read_comment;

    # Get header info:
    $self->filename ($self->read_str($self->read_byte));
    $self->version  ($self->read_byte);
    $self->type     ($self->read_str(4));
    $self->creator  ($self->read_str(4));
    $self->flags    ($self->read_short);
    $self->data_length     ($self->read_long);
    $self->resource_length ($self->read_long);
    $self->{HdrCRC}   = $self->read_short;
    $self->{HeaderRead} = 1;
}

#------------------------------------------------------------
#
# _read_fork
#
# I<Instance method, private.>
# Read in a fork.
#

sub _read_fork {
    my $self = shift;

    # Pass in call if array context:
    if (wantarray) {
	local($_);
	my @all;
	push @all, $_ while (defined($_ = $self->_read_fork(@_)));
	return @all;
    }

    # Get args:
    my ($fork, $n) = @_;
    if($self->{$fork}->length == 0) {
    	$self->{$fork}->crc($self->read_short);
    	return undef;
    }
    defined($n) or $n = 2048;

    # Reset pointer into fork if necessary:
    if (!defined($self->{$fork}{Ptr})) {
	$self->{$fork}{Ptr} = 0;
	$self->{CompCRC} = 0;
    }

    # Check for EOF:
    return undef if ($self->{$fork}{Ptr} >= $self->{$fork}->length);

    # Read up to, but not exceeding, the number of bytes left in the fork:
    my $n2read = min($n, ($self->{$fork}->length - $self->{$fork}{Ptr}));
    my $data = $self->read_str($n2read);
    $self->{$fork}{Ptr} += length($data);

    # If we just read the last byte, read the CRC also:
    if (($self->{$fork}{Ptr} == $self->{$fork}->length) &&    # last byte
	!defined($self->{$fork}->crc)) {                   # no CRC
	my $comp_CRC;

	# Move computed CRC forward by two zero bytes, and grab the value:
	if ($self->{CheckCRC}) {
	    $self->{CompCRC} = binhex_crc("\000\000", $self->{CompCRC});
	}

	# Get CRC as stored in file:
	$self->{$fork}->crc($self->read_short);          # get stored CRC

	# Compare, and note corruption if detected:
	if ($self->{CheckCRC} and ($self->{$fork}->crc != $comp_CRC)) {
	    &Carp::carp("CRCs do not match: corrupted data?") unless $QUIET;
	    $self->{Corrupted} = 1;
	}
    }

    # Return the bytes:
    $data;
}

#------------------------------------------------------------

=item read_data [NBYTES]

I<Instance method.>
Read information from the data fork.  Use it in an array context to
slurp all the data into an array of scalars:

    @data = $HQX->read_data;

Or use it in a scalar context to get the data piecemeal:

    while (defined($data = $HQX->read_data)) {
       # do stuff with $data
    }

The NBYTES to read defaults to 2048.

=cut

sub read_data {
    shift->_read_fork('Data',@_);
}

#------------------------------------------------------------

=item read_resource [NBYTES]

I<Instance method.>
Read in all/some of the resource fork.
See C<read_data()> for usage.

=cut

sub read_resource {
    shift->_read_fork('Rsrc',@_);
}

=back

=cut



#------------------------------------------------------------
#
# read BUFFER, NBYTES
#
# Read the next NBYTES (decompressed) bytes from the input stream
# into BUFFER.  Returns the number of bytes actually read, and
# undef on end of file.
#
# I<Note:> the calling style mirrors the IO::Handle read() function.

my $READBUF = '';
sub read {
    my ($self, $n) = ($_[0], $_[2]);
    $_[1] = '';            # just in case
    my $FH = $self->{FH};
    local($^W) = 0;

    # Get more BIN bytes until enough or EOF:
    my $bin;
    while (length($self->{BIN_QUEUE}) < $n) {
	$FH->read($READBUF, 4096) or last;
	$self->{BIN_QUEUE} .= $self->{H2B}->next($READBUF);   # save BIN
    }

    # We've got as many bytes as we're gonna get:
    $_[1] = substr($self->{BIN_QUEUE}, 0, $n);
    $self->{BIN_QUEUE} = substr($self->{BIN_QUEUE}, $n);

    # Advance the CRC:
    if ($self->{CheckCRC}) {
	$self->{CompCRC} = binhex_crc($_[1], $self->{CompCRC});
    }
    return length($_[1]);
}

#------------------------------------------------------------
#
# read_str NBYTES
#
# Read and return the next NBYTES bytes, or die with "unexpected end of file"

sub read_str {
    my ($self, $n) = @_;
    my $buf = '';
    $self->read($buf, $n);
    croak "$I unexpected end of file (wanted $n, got " . length($buf) . ")\n"
	if ($n and (length($buf) < $n));
    return $buf;
}

#------------------------------------------------------------
#
# read_byte
# read_short
# read_long
#
# Read 1, 2, or 4 bytes, and return the value read as an unsigned integer.
# If not that many bytes remain, die with "unexpected end of file";

sub read_byte {
    ord($_[0]->read_str(1));
}

sub read_short {
    unpack("n", $_[0]->read_str(2));
}

sub read_long {
    unpack("N", $_[0]->read_str(4));
}









#==============================

=head2 Encode, high-level

=over 4

=cut

#------------------------------------------------------------

=item encode OUT

Encode the object as a BinHex stream to the given output handle OUT.
OUT can be a filehandle, or any blessed object that responds to a
C<print()> message.

The leading comment is output, using the C<requires()> attribute.

=cut

sub encode {
    my $self = shift;

    # Get output handle:
    my $OUT = shift; $OUT = wrap Convert::BinHex::IO_Handle $OUT;

    # Get a new converter:
    my $B2H = $self->bin2hex;

    # Comment:
    $OUT->print("(This file must be converted with BinHex ",
		($self->requires || '4.0'),
		")\n");

    # Build header in core:
    my @hdrs;
    my $flen = length($self->filename);
    push @hdrs, pack("C", $flen);
    push @hdrs, pack("a$flen", $self->filename);
    push @hdrs, pack('C', $self->version);
    push @hdrs, pack('a4', $self->type    || '????');
    push @hdrs, pack('a4', $self->creator || '????');
    push @hdrs, pack('n',  $self->flags   || 0);
    push @hdrs, pack('N',  $self->data->length        || 0);
    push @hdrs, pack('N',  $self->resource->length    || 0);
    my $hdr = join '', @hdrs;

    # Compute the header CRC:
    my $crc = binhex_crc("\000\000", binhex_crc($hdr, 0));

    # Output the header (plus its CRC):
    $OUT->print($B2H->next($hdr . pack('n', $crc)));

    # Output the data fork:
    $self->data->encode($OUT, $B2H);

    # Output the resource fork:
    $self->resource->encode($OUT, $B2H);

    # Finish:
    $OUT->print($B2H->done);
    1;
}

=back

=cut



#==============================

=head1 SUBMODULES

=cut

#============================================================
#
package Convert::BinHex::Bin2Hex;
#
#============================================================

=head2 Convert::BinHex::Bin2Hex

A BINary-to-HEX converter.  This kind of conversion requires
a certain amount of state information; it cannot be done by
just calling a simple function repeatedly.  Use it like this:

    # Create and use a "translator" object:
    my $B2H = Convert::BinHex->bin2hex;    # get a converter object
    while (<STDIN>) {
	print STDOUT $B2H->next($_);          # convert some more input
    }
    print STDOUT $B2H->done;               # no more input: finish up

    # Re-use the object:
    $B2H->rewind;                 # ready for more action!
    while (<MOREIN>) { ...

On each iteration, C<next()> (and C<done()>) may return either
a decent-sized non-empty string (indicating that more converted data
is ready for you) or an empty string (indicating that the converter
is waiting to amass more input in its private buffers before handing
you more stuff to output.

Note that C<done()> I<always> converts and hands you whatever is left.

This may have been a good approach.  It may not.  Someday, the converter
may also allow you give it an object that responds to read(), or
a FileHandle, and it will do all the nasty buffer-filling on its own,
serving you stuff line by line:

    # Someday, maybe...
    my $B2H = Convert::BinHex->bin2hex(\*STDIN);
    while (defined($_ = $B2H->getline)) {
	print STDOUT $_;
    }

Someday, maybe.  Feel free to voice your opinions.

=cut

#------------------------------
#
# new

sub new {
    my $self = bless {}, shift;
    return $self->rewind;
}

#------------------------------
#
# rewind

sub rewind {
    my $self = shift;
    $self->{CBIN} = ' ' x 2048; $self->{CBIN} = ''; # BIN waiting for xlation
    $self->{HEX}  = ' ' x 2048; $self->{HEX}  = ''; # HEX waiting for output
    $self->{LINE} = 0;       # current line of output
    $self->{EOL} = "\n";
    $self;
}

#------------------------------
#
# next MOREDATA

sub next { shift->_next(0, @_) }

#------------------------------
#
# done

sub done { shift->_next(1) }

#------------------------------
#
# _next ATEOF, [MOREDATA]
#
# Instance method, private.  Supply more data, and get any more output.
# Returns the empty string often, if not enough output has accumulated.

sub _next {
    my $self = shift;
    my $eof = shift;

    # Get the BINary data to process this time round, re-queueing the rest:
    # Handle EOF and non-EOF conditions separately:
    my $new_bin;
    if ($eof) {                      # No more BINary input...
	# Pad the queue with nuls to exactly 3n characters:
	$self->{CBIN} .= ("\x00" x ((3 - length($self->{CBIN}) % 3) % 3))
    }
    else {                           # More BINary input...
	# "Compress" new stuff, and add it to the queue:
	($new_bin = $_[0]) =~ s/\x90/\x90\x00/g;
	$self->{CBIN} .= $new_bin;

	# Return if not enough to bother with:
	return '' if (length($self->{CBIN}) < 2048);
    }

    # ...At this point, QUEUE holds compressed binary which we will attempt
    # to convert to some HEX characters...

    # Trim QUEUE to exactly 3n characters, saving the excess:
    my $requeue = '';
    $requeue .= chop($self->{CBIN}) while (length($self->{CBIN}) % 3);

    # Uuencode, adding stuff to hex:
    my $hex = ' ' x 2048; $hex = '';
    pos($self->{CBIN}) = 0;
    while ($self->{CBIN} =~ /(.{1,45})/gs) {
	$hex .= substr(pack('u', $1), 1);
	chop($hex);
    }
    $self->{CBIN} = reverse($requeue);     # put the excess back on the queue

    # Switch to BinHex alphabet:
    $hex =~ tr
        {` -_}
        {!!"#$%&'()*+,\x2D012345689@ABCDEFGHIJKLMNPQRSTUVXYZ[`abcdefhijklmpqr};

    # Prepend any HEX we have queued from the last time:
    $hex = (($self->{LINE}++ ? '' : ':') .   # start with ":" pad?
	    $self->{HEX} .              # any output in the queue?
	    $hex);

    # Break off largest chunk of 64n characters, put remainder back in queue:
    my $rem = length($hex) % 64;
    $self->{HEX} = ($rem ? substr($hex, -$rem) : '');
    $hex = substr($hex, 0, (length($hex)-$rem));

    # Put in an EOL every 64'th character:
    $hex =~ s{(.{64})}{$1$self->{EOL}}sg;

    # No more input?  Then tack on the remainder now:
    if ($eof) {
        $hex .= $self->{HEX} . ":" . ($self->{EOL} ? $self->{EOL} : '');
    }

    # Done!
    $hex;
}




#============================================================
#
package Convert::BinHex::Hex2Bin;
#
#============================================================

=head2 Convert::BinHex::Hex2Bin

A HEX-to-BINary converter. This kind of conversion requires
a certain amount of state information; it cannot be done by
just calling a simple function repeatedly.  Use it like this:

    # Create and use a "translator" object:
    my $H2B = Convert::BinHex->hex2bin;    # get a converter object
    while (<STDIN>) {
	print STDOUT $H2B->next($_);          # convert some more input
    }
    print STDOUT $H2B->done;               # no more input: finish up

    # Re-use the object:
    $H2B->rewind;                 # ready for more action!
    while (<MOREIN>) { ...

On each iteration, C<next()> (and C<done()>) may return either
a decent-sized non-empty string (indicating that more converted data
is ready for you) or an empty string (indicating that the converter
is waiting to amass more input in its private buffers before handing
you more stuff to output.

Note that C<done()> I<always> converts and hands you whatever is left.

Note that this converter does I<not> find the initial
"BinHex version" comment.  You have to skip that yourself.  It
only handles data between the opening and closing C<":">.

=cut

#------------------------------
#
# new

sub new {
    my $self = bless {}, shift;
    return $self->rewind;
}

#------------------------------
#
# rewind

sub rewind {
    my $self = shift;
    $self->hex2comp_rewind;
    $self->comp2bin_rewind;
    $self;
}

#------------------------------
#
# next MOREDATA

sub next {
    my $self = shift;
    $_[0] =~ s/\s//g if (defined($_[0]));      # more input
    return $self->comp2bin_next($self->hex2comp_next($_[0]));
}

#------------------------------
#
# done

sub done {
    return "";
}

#------------------------------
#
# hex2comp_rewind

sub hex2comp_rewind {
    my $self = shift;
    $self->{HEX} = '';
}

#------------------------------
#
# hex2comp_next HEX
#
# WARNING: argument is modified destructively for efficiency!!!!

sub hex2comp_next {
    my $self = shift;
    ### print "hex2comp: newhex = $newhex\n";

    # Concat new with queue, and kill any padding:
    my $hex = $self->{HEX} . (defined($_[0]) ? $_[0] : '');
    if (index($hex, ':') >= 0) {
	$hex =~ s/^://;                                 # start of input
	if ($hex =~ s/:\s*\Z//) {                       # end of input
	    my $leftover = (length($hex) % 4);                # need to pad!
	    $hex .= "\000" x (4 - $leftover)  if $leftover;   # zero pad
	}
    }

    # Get longest substring of length 4n possible; put rest back on queue:
    my $rem = length($hex) % 4;
    $self->{HEX} = ($rem ? substr($hex, -$rem) : '');
    for (; $rem; --$rem) { chop $hex };
    return undef if ($hex eq '');            # nothing to do!

    # Convert to uuencoded format:
    $hex =~ tr
        {!"#$%&'()*+,\x2D012345689@ABCDEFGHIJKLMNPQRSTUVXYZ[`abcdefhijklmpqr}
        { -_};

    # Now, uudecode:
    my $comp = '';
    my $len;
    my $up;
    local($^W) = 0;       ### KLUDGE
    while ($hex =~ /\G(.{1,60})/gs) {
	$len = chr(32 + ((length($1)*3)>>2));  # compute length byte
	$comp .= unpack("u", $len . $1 );      # uudecode
    }

    # We now have the compressed binary... expand it:
    ### print "hex2comp: comp = $comp\n";
    $comp;
}

#------------------------------
#
# comp2bin_rewind

sub comp2bin_rewind {
    my $self = shift;
    $self->{COMP} = '';
    $self->{LASTC} = '';
}

#------------------------------
#
# comp2bin_next COMP
#
# WARNING: argument is modified destructively for efficiency!!!!

sub comp2bin_next {
    my $self = shift;

    # Concat new with queue... anything to do?
    my $comp = $self->{COMP} . (defined($_[0]) ? $_[0] : '');
    return undef if ($comp eq '');

    # For each character in compressed string...
    $self->{COMP} = '';
    my $lastc = $self->{LASTC};      # speed hack
    my $exp = '';       # expanded string
    my $i;
    my ($c, $n);
    for ($i = 0; $i < length($comp); $i++) {
	if (($c = substr($comp, $i, 1)) eq "\x90") {    # MARK
	    ### print "c = MARK\n";
	    unless (length($n = substr($comp, ++$i, 1))) {
		$self->{COMP} = "\x90";
		last;
	    }
	    ### print "n = ", ord($n), "; lastc = ", ord($lastc), "\n";
	    $exp .= ((ord($n) ? ($lastc x (ord($n)-1))  # repeat last char
		              : ($lastc = "\x90")));    # literal MARK
	}
	else {                                          # other CHAR
	    ### print "c = ", ord($c), "\n";
	    $exp .= ($lastc = $c);
	}
	### print "exp is now $exp\n";
    }

    # Either hit EOS, or there's a MARK char at the very end:
    $self->{LASTC} = $lastc;
    ### print "leaving with lastc=$lastc and comp=$self->{COMP}\n";
    ### print "comp2bin: exp = $exp\n";
    $exp;
}






#============================================================
#
package Convert::BinHex::Fork;
#
#============================================================

=head2 Convert::BinHex::Fork

A fork in a Macintosh file.

    # How to get them...
    $data_fork = $HQX->data;      # get the data fork
    $rsrc_fork = $HQX->resource;  # get the resource fork

    # Make a new fork:
    $FORK = Convert::BinHex::Fork->new(Path => "/tmp/file.data");
    $FORK = Convert::BinHex::Fork->new(Data => $scalar);
    $FORK = Convert::BinHex::Fork->new(Data => \@array_of_scalars);

    # Get/set the length of the data fork:
    $len = $FORK->length;
    $FORK->length(170);        # this overrides the REAL value: be careful!

    # Get/set the path to the underlying data (if in a disk file):
    $path = $FORK->path;
    $FORK->path("/tmp/file.data");

    # Get/set the in-core data itself, which may be a scalar or an arrayref:
    $data = $FORK->data;
    $FORK->data($scalar);
    $FORK->data(\@array_of_scalars);

    # Get/set the CRC:
    $crc = $FORK->crc;
    $FORK->crc($crc);

=cut


# Import some stuff into our namespace:
*binhex_crc = \&Convert::BinHex::binhex_crc;

#------------------------------
#
# new PARAMHASH

sub new {
    my ($class, %params) = @_;
    bless \%params, $class;
}

#------------------------------
#
# length [VALUE]

sub length {
    my $self = shift;

    # Set length?
    $self->{Length} = shift if @_;

    # Return explicit length, if any
    return $self->{Length} if defined($self->{Length});

    # Compute it:
    if (defined($self->{Path})) {
	return (-s $self->{Path});
    }
    elsif (!ref($self->{Data})) {
	return length($self->{Data});
    }
    elsif (ref($self->{Data} eq 'ARRAY')) {
	my $n = 0;
	foreach (@{$self->{Data}}) { $n += length($_) }
	return $n;
    }
    return undef;          # unknown!
}

#------------------------------
#
# path [VALUE]

sub path {
    my $self = shift;
    if (@_) { $self->{Path} = shift; delete $self->{Data} }
    $self->{Path};
}

#------------------------------
#
# data [VALUE]

sub data {
    my $self = shift;
    if (@_) { $self->{Data} = shift; delete $self->{Path} }
    $self->{Data};
}

#------------------------------
#
# crc [VALUE]

sub crc {
    my $self = shift;
    @_ ? $self->{CRC} = shift : $self->{CRC};
}

#------------------------------
#
# encode OUT, B2H
#
# Instance method, private.  Encode this fork as part of a BinHex stream.
# It will be printed to handle OUT using the binhexer B2H.

sub encode {
    my ($self, $OUT, $B2H) = @_;
    my $buf = '';
    require POSIX if $^O||'' eq "MacOS";
    require Fcntl if $^O||'' eq "MacOS";
    my $fd;

    # Reset the CRC:
    $self->{CRC} = 0;

    # Output the data, calculating the CRC as we go:
    if (defined($self->{Path})) { # path to fork file
        if ($^O||'' eq "MacOS" and $self->{Fork} eq "RSRC") {
    	    $fd = POSIX::open($self->{Path},&POSIX::O_RDONLY | &Fcntl::O_RSRC);
	    while (POSIX::read($fd, $buf, 2048) > 0) {
		$self->{CRC} = binhex_crc($buf, $self->{CRC});
		$OUT->print($B2H->next($buf));
	    }
	    POSIX::close($fd);
        }
	else {
	    open FORK, $self->{Path} or die "$self->{Path}: $!";
	    while (read(\*FORK, $buf, 2048)) {
		$self->{CRC} = binhex_crc($buf, $self->{CRC});
		$OUT->print($B2H->next($buf));
	    }
	    close FORK;
	}
    }
    elsif (!defined($self->{Data})) {        # nothing!
	&Carp::carp("no data in fork!") unless $Convert::BinHex::QUIET;
    }
    elsif (!ref($self->{Data})) {            # scalar
	$self->{CRC} = binhex_crc($self->{Data}, $self->{CRC});
	$OUT->print($B2H->next($self->{Data}));
    }
    elsif (ref($self->{Data}) eq 'ARRAY') {  # array of scalars
	foreach $buf (@{$self->{Data}}) {
	    $self->{CRC} = binhex_crc($buf, $self->{CRC});
	    $OUT->print($B2H->next($buf));
	}
    }
    else {
	&Carp::croak("bad/unsupported data in fork");
    }

    # Finish the CRC, and output it:
    $self->{CRC} = binhex_crc("\000\000", $self->{CRC});
    $OUT->print($B2H->next(pack("n", $self->{CRC})));
    1;
}




#============================================================
#
package Convert::BinHex::IO_Handle;
#
#============================================================

# Wrap a non-object filehandle inside a blessed, printable interface:
# Does nothing if the given $fh is already a blessed object.
sub wrap {
    my ($class, $fh) = @_;
    no strict 'refs';
    $fh or $fh = select;        # no filehandle means selected one
    ref($fh) or $fh = \*$fh;    # scalar becomes a globref
    return $fh if (ref($fh) and (ref($fh) !~ /^(GLOB|FileHandle)$/));
    bless \$fh, $class;         # wrap it in a printable interface
}
sub print {
    my $FH = ${shift(@_)};
    print $FH @_;
}
sub getline {
    my $FH = ${shift(@_)};
    scalar(<$FH>);
}
sub read {
    read ${$_[0]}, $_[1], $_[2];
}



#============================================================
#
package Convert::BinHex::IO_Scalar;
#
#============================================================

# Wrap a scalar inside a blessed, printable interface:
sub wrap {
    my ($class, $scalarref) = @_;
    defined($scalarref) or $scalarref = \"";
    pos($$scalarref) = 0;
    bless $scalarref, $class;
}
sub print {
    my $self = shift;
    $$self .= join('', @_);
    1;
}
sub getline {
    my $self = shift;
    ($$self =~ /\G(.*?\n?)/g) or return undef;
    return $1;
}
sub read {
    my $self = shift;
    $_[0] = substr($$self, pos($$self), $_[1]);
    pos($$self) += $_[1];
    return length($_[0]);
}



#==============================

=head1 UNDER THE HOOD

=head2 Design issues

=over 4

=item BinHex needs a stateful parser

Unlike its cousins I<base64> and I<uuencode>, BinHex format is not
amenable to being parsed line-by-line.  There appears to be no
guarantee that lines contain 4n encoded characters... and even if there
is one, the BinHex compression algorithm interferes: even when you
can I<decode> one line at a time, you can't necessarily
I<decompress> a line at a time.

For example: a decoded line ending with the byte C<\x90> (the escape
or "mark" character) is ambiguous: depending on the next decoded byte,
it could mean a literal C<\x90> (if the next byte is a C<\x00>), or
it could mean n-1 more repetitions of the previous character (if
the next byte is some nonzero C<n>).

For this reason, a BinHex parser has to be somewhat stateful: you
cannot have code like this:

    #### NO! #### NO! #### NO! #### NO! #### NO! ####
    while (<STDIN>) {            # read HEX
        print hexbin($_);          # convert and write BIN
    }

unless something is happening "behind the scenes" to keep track of
what was last done.  I<The dangerous thing, however, is that this
approach will B<seem> to work, if you only test it on BinHex files
which do not use compression and which have 4n HEX characters
on each line.>

Since we have to be stateful anyway, we use the parser object to
keep our state.


=item We need to be handle large input files

Solutions that demand reading everything into core don't cut
it in my book.  The first MPEG file that comes along can louse
up your whole day.  So, there are no size limitations in this
module: the data is read on-demand, and filehandles are always
an option.


=item Boy, is this slow!

A lot of the byte-level manipulation that has to go on, particularly
the CRC computing (which involves intensive bit-shifting and masking)
slows this module down significantly.  What is needed perhaps is an
I<optional> extension library where the slow pieces can be done more
quickly... a Convert::BinHex::CRC, if you will.  Volunteers, anyone?

Even considering that, however, it's slower than I'd like.  I'm
sure many improvements can be made in the HEX-to-BIN end of things.
No doubt I'll attempt some as time goes on...

=back



=head2 How it works

Since BinHex is a layered format, consisting of...

      A Macintosh file [the "BIN"]...
         Encoded as a structured 8-bit bytestream, then...
            Compressed to reduce duplicate bytes, then...
               Encoded as 7-bit ASCII [the "HEX"]

...there is a layered parsing algorithm to reverse the process.
Basically, it works in a similar fashion to stdio's fread():

       0. There is an internal buffer of decompressed (BIN) data,
          initially empty.
       1. Application asks to read() n bytes of data from object
       2. If the buffer is not full enough to accomodate the request:
            2a. The read() method grabs the next available chunk of input
                data (the HEX).
            2b. HEX data is converted and decompressed into as many BIN
                bytes as possible.
            2c. BIN bytes are added to the read() buffer.
            2d. Go back to step 2a. until the buffer is full enough
                or we hit end-of-input.

The conversion-and-decompression algorithms need their own internal
buffers and state (since the next input chunk may not contain all the
data needed for a complete conversion/decompression operation).
These are maintained in the object, so parsing two different
input streams simultaneously is possible.


=head1 WARNINGS

Only handles C<Hqx7> files, as per RFC-1741.

Remember that Macintosh text files use C<"\r"> as end-of-line:
this means that if you want a textual file to look normal on
a non-Mac system, you probably want to do this to the data:

    # Get the data, and output it according to normal conventions:
    foreach ($HQX->read_data) { s/\r/\n/g; print }


=head1 CHANGE LOG

Current version: $Id: BinHex.pm,v 1.119 1997/06/28 05:12:42 eryq Exp $

=over 4

=item Version 1.118

Ready to go public (with Paul's version, patched for native Mac support)!
Warnings have been suppressed in a few places where undefined values
appear.

=item Version 1.115

Fixed another bug in comp2bin, related to the MARK falling on a
boundary between inputs.  Added testing code.

=item Version 1.114

Added BIN-to-HEX conversion.  Eh.  It's a start.
Also, a lot of documentation additions and cleanups.
Some methods were also renamed.

=item Version 1.103

Fixed bug in decompression (wasn't saving last character).
Fixed "NoComment" bug.

=item Version 1.102

Initial release.

=back


=head1 AUTHOR AND CREDITS

Written by Eryq, F<http://www.enteract.com/~eryq> / F<eryq@enteract.com>

Support for native-Mac conversion, I<plus> invaluable contributions in 
Alpha Testing, I<plus> a few patches, I<plus> the baseline binhex/debinhex
programs, were provided by Paul J. Schinder (NASA/GSFC).

Ken Lunde (Adobe) suggested incorporating the CAP file representation.


=head1 TERMS AND CONDITIONS

Copyright (c) 1997 by Eryq.  All rights reserved.  This program is free
software; you can redistribute it and/or modify it under the same terms as
Perl itself.

This software comes with B<NO WARRANTY> of any kind.
See the COPYING file in the distribution for details.

=cut

1;

__END__

my $HQX = new Convert::BinHex
    version => 0,
    filename=>"s.gif",
    type    => "GIF8",
    creator => "PCBH",
    flags => 0xFFFF
    ;

$HQX->data(Path=>"/home/eryq/s.gif");
$HQX->resource(Path=>"/etc/issue");

#$HQX->data(Data=>"123456789");
#$HQX->resource(Data=>'');

$HQX->encode(\*STDOUT);

1;









escape ? simple_escape($attr->{$_}) : $attr->{$_};
	push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/);
    }
    return @att;
}

sub simple_escape {
  return unless defined(my $toencode = shift);
  $toencode =~ s{&}{&amp;}gso;
  $toencode =~ s{<}{&lt;}gso;
  $toencode =~ s{>}{&gt;}gso;
  $toencode =~ s{\"}{&quot;}gso;
# Doesn't work.  Can't w                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
package CPAN::Mirrored::By;

sub new { 
    my($self,@arg) = @_;
    bless [@arg], $self;
}
sub continent { shift->[0] }
sub country { shift->[1] }
sub url { shift->[2] }

package CPAN::FirstTime;

use strict;
use ExtUtils::MakeMaker qw(prompt);
use FileHandle ();
use File::Basename ();
use File::Path ();
use vars qw($VERSION);
$VERSION = substr q$Revision: 1.53 $, 10;

=head1 NAME

CPAN::FirstTime - Utility for CPAN::Config file Initialization

=head1 SYNOPSIS

CPAN::FirstTime::init()

=head1 DESCRIPTION

The init routine asks a few questions and writes a CPAN::Config
file. Nothing special.

=cut


sub init {
    my($configpm) = @_;
    use Config;
    unless ($CPAN::VERSION) {
	require CPAN::Nox;
    }
    eval {require CPAN::Config;};
    $CPAN::Config ||= {};
    local($/) = "\n";
    local($\) = "";
    local($|) = 1;

    my($ans,$default,$local,$cont,$url,$expected_size);

    #
    # Files, directories
    #

    print qq[

CPAN is the world-wide archive of perl resources. It consists of about
100 sites that all replicate the same contents all around the globe.
Many countries have at least one CPAN site already. The resources
found on CPAN are easily accessible with the CPAN.pm module. If you
want to use CPAN.pm, you have to configure it properly.

If you do not want to enter a dialog now, you can answer 'no' to this
question and I\'ll try to autoconfigure. (Note: you can revisit this
dialog anytime later by typing 'o conf init' at the cpan prompt.)

];

    my $manual_conf =
	ExtUtils::MakeMaker::prompt("Are you ready for manual configuration?",
				    "yes");
    my $fastread;
    {
      local $^W;
      if ($manual_conf =~ /^\s*y/i) {
	$fastread = 0;
	*prompt = \&ExtUtils::MakeMaker::prompt;
      } else {
	$fastread = 1;
	$CPAN::Config->{urllist} ||= [];
	# prototype should match that of &MakeMaker::prompt
	*prompt = sub ($;$) {
	  my($q,$a) = @_;
	  my($ret) = defined $a ? $a : "";
	  printf qq{%s [%s]\n\n}, $q, $ret;
	  $ret;
	};
      }
    }
    print qq{

The following questions are intended to help you with the
configuration. The CPAN module needs a directory of its own to cache
important index files and maybe keep a temporary mirror of CPAN files.
This may be a site-wide directory or a personal directory.

};

    my $cpan_home = $CPAN::Config->{cpan_home} || MM->catdir($ENV{HOME}, ".cpan");
    if (-d $cpan_home) {
	print qq{

I see you already have a  directory
    $cpan_home
Shall we use it as the general CPAN build and cache directory?

};
    } else {
	print qq{

First of all, I\'d like to create this directory. Where?

};
    }

    $default = $cpan_home;
    while ($ans = prompt("CPAN build and cache directory?",$default)) {
      eval { File::Path::mkpath($ans); }; # dies if it can't
      if ($@) {
	warn "Couldn't create directory $ans.
Please retry.\n";
	next;
      }
      if (-d $ans && -w _) {
	last;
      } else {
	warn "Couldn't find directory $ans
  or directory is not writable. Please retry.\n";
      }
    }
    $CPAN::Config->{cpan_home} = $ans;

    print qq{

If you want, I can keep the source files after a build in the cpan
home directory. If you choose so then future builds will take the
files from there. If you don\'t want to keep them, answer 0 to the
next question.

};

    $CPAN::Config->{keep_source_where} = MM->catdir($CPAN::Config->{cpan_home},"sources");
    $CPAN::Config->{build_dir} = MM->catdir($CPAN::Config->{cpan_home},"build");

    #
    # Cache size, Index expire
    #

    print qq{

How big should the disk cache be for keeping the build directories
with all the intermediate files\?

};

    $default = $CPAN::Config->{build_cache} || 10;
    $ans = prompt("Cache size for build directory (in MB)?", $default);
    $CPAN::Config->{build_cache} = $ans;

    # XXX This the time when we refetch the index files (in days)
    $CPAN::Config->{'index_expire'} = 1;

    print qq{

By default, each time the CPAN module is started, cache scanning
is performed to keep the cache size in sync. To prevent from this,
disable the cache scanning with 'never'.

};

    $default = $CPAN::Config->{scan_cache} || 'atstart';
    do {
        $ans = prompt("Perform cache scanning (atstart or never)?", $default);
    } while ($ans ne 'atstart' && $ans ne 'never');
    $CPAN::Config->{scan_cache} = $ans;

    #
    # cache_metadata
    #
    print qq{

To considerably speed up the initial CPAN shell startup, it is
possible to use Storable to create a cache of metadata. If Storable
is not available, the normal index mechanism will be used.

};

    defined($default = $CPAN::Config->{cache_metadata}) or $default = 1;
    do {
        $ans = prompt("Cache metadata (yes/no)?", ($default ? 'yes' : 'no'));
    } while ($ans !~ /^\s*[yn]/i);
    $CPAN::Config->{cache_metadata} = ($ans =~ /^\s*y/i ? 1 : 0);

    #
    # term_is_latin
    #
    print qq{

The next option deals with the charset your terminal supports. In
general CPAN is English speaking territory, thus the charset does not
matter much, but some of the aliens out there who upload their
software to CPAN bear names that are outside the ASCII range. If your
terminal supports UTF-8, you say no to the next question, if it
supports ISO-8859-1 (also known as LATIN1) then you say yes, and if it
supports neither nor, your answer does not matter, you will not be
able to read the names of some authors anyway. If you answer no, names
will be output in UTF-8.

};

    defined($default = $CPAN::Config->{term_is_latin}) or $default = 1;
    do {
        $ans = prompt("Your terminal expects ISO-8859-1 (yes/no)?",
                      ($default ? 'yes' : 'no'));
    } while ($ans !~ /^\s*[yn]/i);
    $CPAN::Config->{term_is_latin} = ($ans =~ /^\s*y/i ? 1 : 0);

    #
    # prerequisites_policy
    # Do we follow PREREQ_PM?
    #
    print qq{

The CPAN module can detect when a module that which you are trying to
build depends on prerequisites. If this happens, it can build the
prerequisites for you automatically ('follow'), ask you for
confirmation ('ask'), or just ignore them ('ignore'). Please set your
policy to one of the three values.

};

    $default = $CPAN::Config->{prerequisites_policy} || 'ask';
    do {
      $ans =
	  prompt("Policy on building prerequisites (follow, ask or ignore)?",
		 $default);
    } while ($ans ne 'follow' && $ans ne 'ask' && $ans ne 'ignore');
    $CPAN::Config->{prerequisites_policy} = $ans;

    #
    # External programs
    #

    print qq{

The CPAN module will need a few external programs to work properly.
Please correct me, if I guess the wrong path for a program. Don\'t
panic if you do not have some of them, just press ENTER for those. To
disable the use of a download program, you can type a space followed
by ENTER.

};

    my $old_warn = $^W;
    local $^W if $^O eq 'MacOS';
    my(@path) = split /$Config{'path_sep'}/, $ENV{'PATH'};
    local $^W = $old_warn;
    my $progname;
    for $progname (qw/gzip tar unzip make lynx wget ncftpget ncftp ftp/){
      if ($^O eq 'MacOS') {
          $CPAN::Config->{$progname} = 'not_here';
          next;
      }
      my $progcall = $progname;
      # we don't need ncftp if we have ncftpget
      next if $progname eq "ncftp" && $CPAN::Config->{ncftpget} gt " ";
      my $path = $CPAN::Config->{$progname} 
	  || $Config::Config{$progname}
	      || "";
      if (MM->file_name_is_absolute($path)) {
	# testing existence is not good enough, some have these exe
	# extensions

	# warn "Warning: configured $path does not exist\n" unless -e $path;
	# $path = "";
      } else {
	$path = '';
      }
      unless ($path) {
	# e.g. make -> nmake
	$progcall = $Config::Config{$progname} if $Config::Config{$progname};
      }

      $path ||= find_exe($progcall,[@path]);
      warn "Warning: $progcall not found in PATH\n" unless
	  $path; # not -e $path, because find_exe already checked that
      $ans = prompt("Where is your $progname program?",$path) || $path;
      $CPAN::Config->{$progname} = $ans;
    }
    my $path = $CPAN::Config->{'pager'} || 
	$ENV{PAGER} || find_exe("less",[@path]) || 
	    find_exe("more",[@path]) || ($^O eq 'MacOS' ? $ENV{EDITOR} : 0 )
	    || "more";
    $ans = prompt("What is your favorite pager program?",$path);
    $CPAN::Config->{'pager'} = $ans;
    $path = $CPAN::Config->{'shell'};
    if (MM->file_name_is_absolute($path)) {
	warn "Warning: configured $path does not exist\n" unless -e $path;
	$path = "";
    }
    $path ||= $ENV{SHELL};
    if ($^O eq 'MacOS') {
        $CPAN::Config->{'shell'} = 'not_here';
    } else {
        $path =~ s,\\,/,g if $^O eq 'os2';	# Cosmetic only
        $ans = prompt("What is your favorite shell?",$path);
        $CPAN::Config->{'shell'} = $ans;
    }

    #
    # Arguments to make etc.
    #

    print qq{

Every Makefile.PL is run by perl in a separate process. Likewise we
run \'make\' and \'make install\' in processes. If you have any
parameters \(e.g. PREFIX, LIB, UNINST or the like\) you want to pass
to the calls, please specify them here.

If you don\'t understand this question, just press ENTER.

};

    $default = $CPAN::Config->{makepl_arg} || "";
    $CPAN::Config->{makepl_arg} =
	prompt("Parameters for the 'perl Makefile.PL' command?
Typical frequently used settings:

    POLLUTE=1        increasing backwards compatibility
    LIB=~/perl       non-root users (please see manual for more hints)

Your choice: ",$default);
    $default = $CPAN::Config->{make_arg} || "";
    $CPAN::Config->{make_arg} = prompt("Parameters for the 'make' command?
Typical frequently used setting:

    -j3              dual processor system

Your choice: ",$default);

    $default = $CPAN::Config->{make_install_arg} || $CPAN::Config->{make_arg} || "";
    $CPAN::Config->{make_install_arg} =
	prompt("Parameters for the 'make install' command?
Typical frequently used setting:

    UNINST=1         to always uninstall potentially conflicting files

Your choice: ",$default);

    #
    # Alarm period
    #

    print qq{

Sometimes you may wish to leave the processes run by CPAN alone
without caring about them. As sometimes the Makefile.PL contains
question you\'re expected to answer, you can set a timer that will
kill a 'perl Makefile.PL' process after the specified time in seconds.

If you set this value to 0, these processes will wait forever. This is
the default and recommended setting.

};

    $default = $CPAN::Config->{inactivity_timeout} || 0;
    $CPAN::Config->{inactivity_timeout} =
	prompt("Timeout for inactivity during Makefile.PL?",$default);

    # Proxies

    print qq{

If you\'re accessing the net via proxies, you can specify them in the
CPAN configuration or via environment variables. The variable in
the \$CPAN::Config takes precedence.

};

    for (qw/ftp_proxy http_proxy no_proxy/) {
	$default = $CPAN::Config->{$_} || $ENV{$_};
	$CPAN::Config->{$_} = prompt("Your $_?",$default);
    }

    if ($CPAN::Config->{ftp_proxy} ||
        $CPAN::Config->{http_proxy}) {
        $default = $CPAN::Config->{proxy_user} || $CPAN::LWP::UserAgent::USER;
        print qq{

If your proxy is an authenticating proxy, you can store your username
permanently. If you do not want that, just press RETURN. You will then
be asked for your username in every future session.

};
        if ($CPAN::Config->{proxy_user} = prompt("Your proxy user id?",$default)) {
            print qq{

Your password for the authenticating proxy can also be stored
permanently on disk. If this violates your security policy, just press
RETURN. You will then be asked for the password in every future
session.

};

            if ($CPAN::META->has_inst("Term::ReadKey")) {
                Term::ReadKey::ReadMode("noecho");
            } else {
                print qq{

Warning: Term::ReadKey seems not to be available, your password will
be echoed to the terminal!

};
            }
            $CPAN::Config->{proxy_pass} = prompt("Your proxy password?");
            if ($CPAN::META->has_inst("Term::ReadKey")) {
                Term::ReadKey::ReadMode("restore");
            }
            $CPAN::Frontend->myprint("\n\n");
        }
    }

    #
    # MIRRORED.BY
    #

    conf_sites() unless $fastread;

    unless (@{$CPAN::Config->{'wait_list'}||[]}) {
	print qq{

WAIT support is available as a Plugin. You need the CPAN::WAIT module
to actually use it.  But we need to know your favorite WAIT server. If
you don\'t know a WAIT server near you, just press ENTER.

};
	$default = "wait://ls6.informatik.uni-dortmund.de:1404";
	$ans = prompt("Your favorite WAIT server?\n  ",$default);
	push @{$CPAN::Config->{'wait_list'}}, $ans;
    }

    # We don't ask that now, it will be noticed in time, won't it?
    $CPAN::Config->{'inhibit_startup_message'} = 0;
    $CPAN::Config->{'getcwd'} = 'cwd';

    print "\n\n";
    CPAN::Config->commit($configpm);
}

sub conf_sites {
  my $m = 'MIRRORED.BY';
  my $mby = MM->catfile($CPAN::Config->{keep_source_where},$m);
  File::Path::mkpath(File::Basename::dirname($mby));
  if (-f $mby && -f $m && -M $m < -M $mby) {
    require File::Copy;
    File::Copy::copy($m,$mby) or die "Could not update $mby: $!";
  }
  my $loopcount = 0;
  local $^T = time;
  my $overwrite_local = 0;
  if ($mby && -f $mby && -M _ <= 60 && -s _ > 0) {
      my $mtime = localtime((stat _)[9]);
      my $prompt = qq{Found $mby as of $mtime

I\'d use that as a database of CPAN sites. If that is OK for you,
please answer 'y', but if you want me to get a new database now,
please answer 'n' to the following question.

Shall I use the local database in $mby?};
      my $ans = prompt($prompt,"y");
      $overwrite_local = 1 unless $ans =~ /^y/i;
  }
  while ($mby) {
    if ($overwrite_local) {
      print qq{Trying to overwrite $mby
};
      $mby = CPAN::FTP->localize($m,$mby,3);
      $overwrite_local = 0;
    } elsif ( ! -f $mby ){
      print qq{You have no $mby
  I\'m trying to fetch one
};
      $mby = CPAN::FTP->localize($m,$mby,3);
    } elsif (-M $mby > 60 && $loopcount == 0) {
      print qq{Your $mby is older than 60 days,
  I\'m trying to fetch one
};
      $mby = CPAN::FTP->localize($m,$mby,3);
      $loopcount++;
    } elsif (-s $mby == 0) {
      print qq{You have an empty $mby,
  I\'m trying to fetch one
};
      $mby = CPAN::FTP->localize($m,$mby,3);
    } else {
      last;
    }
  }
  read_mirrored_by($mby);
  bring_your_own();
}

sub find_exe {
    my($exe,$path) = @_;
    my($dir);
    #warn "in find_exe exe[$exe] path[@$path]";
    for $dir (@$path) {
	my $abs = MM->catfile($dir,$exe);
	if (($abs = MM->maybe_command($abs))) {
	    return $abs;
	}
    }
}

sub picklist {
    my($items,$prompt,$default,$require_nonempty,$empty_warning)=@_;
    $default ||= '';

    my ($item, $i);
    for $item (@$items) {
	printf "(%d) %s\n", ++$i, $item;
    }

    my @nums;
    while (1) {
	my $num = prompt($prompt,$default);
	@nums = split (' ', $num);
	(warn "invalid items entered, try again\n"), next
	    if grep (/\D/ || $_ < 1 || $_ > $i, @nums);
	if ($require_nonempty) {
	    (warn "$empty_warning\n"), next
		unless @nums;
	}
	last;
    }
    print "\n";
    for (@nums) { $_-- }
    @{$items}[@nums];
}

sub read_mirrored_by {
    my $local = shift or return;
    my(%all,$url,$expected_size,$default,$ans,$host,$dst,$country,$continent,@location);
    my $fh = FileHandle->new;
    $fh->open($local) or die "Couldn't open $local: $!";
    local $/ = "\012";
    while (<$fh>) {
	($host) = /^([\w\.\-]+)/ unless defined $host;
	next unless defined $host;
	next unless /\s+dst_(dst|location)/;
	/location\s+=\s+\"([^\"]+)/ and @location = (split /\s*,\s*/, $1) and
	    ($continent, $country) = @location[-1,-2];
	$continent =~ s/\s\(.*//;
	$continent =~ s/\W+$//; # if Jarkko doesn't know latitude/longitude
	/dst_dst\s+=\s+\"([^\"]+)/  and $dst = $1;
	next unless $host && $dst && $continent && $country;
	$all{$continent}{$country}{$dst} = CPAN::Mirrored::By->new($continent,$country,$dst);
	undef $host;
	$dst=$continent=$country="";
    }
    $fh->close;
    $CPAN::Config->{urllist} ||= [];
    my(@previous_urls);
    if (@previous_urls = @{$CPAN::Config->{urllist}}) {
	$CPAN::Config->{urllist} = [];
    }

    print qq{

Now we need to know where your favorite CPAN sites are located. Push
a few sites onto the array (just in case the first on the array won\'t
work). If you are mirroring CPAN to your local workstation, specify a
file: URL.

First, pick a nearby continent and country (you can pick several of
each, separated by spaces, or none if you just want to keep your
existing selections). Then, you will be presented with a list of URLs
of CPAN mirrors in the countries you selected, along with previously
selected URLs. Select some of those URLs, or just keep the old list.
Finally, you will be prompted for any extra URLs -- file:, ftp:, or
http: -- that host a CPAN mirror.

};

    my (@cont, $cont, %cont, @countries, @urls, %seen);
    my $no_previous_warn = 
       "Sorry! since you don't have any existing picks, you must make a\n" .
       "geographic selection.";
    @cont = picklist([sort keys %all],
                     "Select your continent (or several nearby continents)",
                     '',
                     ! @previous_urls,
                     $no_previous_warn);


    foreach $cont (@cont) {
        my @c = sort keys %{$all{$cont}};
        @cont{@c} = map ($cont, 0..$#c);
        @c = map ("$_ ($cont)", @c) if @cont > 1;
        push (@countries, @c);
    }

    if (@countries) {
        @countries = picklist (\@countries,
                               "Select your country (or several nearby countries)",
                               '',
                               ! @previous_urls,
                               $no_previous_warn);
        %seen = map (($_ => 1), @previous_urls);
        # hmmm, should take list of defaults from CPAN::Config->{'urllist'}...
        foreach $country (@countries) {
            (my $bare_country = $country) =~ s/ \(.*\)//;
            my @u = sort keys %{$all{$cont{$bare_country}}{$bare_country}};
            @u = grep (! $seen{$_}, @u);
            @u = map ("$_ ($bare_country)", @u)
               if @countries > 1;
            push (@urls, @u);
        }
    }
    push (@urls, map ("$_ (previous pick)", @previous_urls));
    my $prompt = "Select as many URLs as you like,
put them on one line, separated by blanks";
    if (@previous_urls) {
       $default = join (' ', ((scalar @urls) - (scalar @previous_urls) + 1) ..
                             (scalar @urls));
       $prompt .= "\n(or just hit RETURN to keep your previous picks)";
    }

    @urls = picklist (\@urls, $prompt, $default);
    foreach (@urls) { s/ \(.*\)//; }
    push @{$CPAN::Config->{urllist}}, @urls;
}

sub bring_your_own {
    my %seen = map (($_ => 1), @{$CPAN::Config->{urllist}});
    my($ans,@urls);
    do {
	my $prompt = "Enter another URL or RETURN to quit:";
	unless (%seen) {
	    $prompt = qq{CPAN.pm needs at least one URL where it can fetch CPAN files from.

Please enter your CPAN site:};
	}
        $ans = prompt ($prompt, "");

        if ($ans) {
            $ans =~ s|/?\z|/|; # has to end with one slash
            $ans = "file:$ans" unless $ans =~ /:/; # without a scheme is a file:
            if ($ans =~ /^\w+:\/./) {
                push @urls, $ans unless $seen{$ans}++;
            } else {
                printf(qq{"%s" doesn\'t look like an URL at first sight.
I\'ll ignore it for now.
You can add it to your %s
later if you\'re sure it\'s right.\n},
                       $ans,
                       $INC{'CPAN/MyConfig.pm'} || $INC{'CPAN/Config.pm'} || "configuration file",
                      );
            }
        }
    } while $ans || !%seen;

    push @{$CPAN::Config->{urllist}}, @urls;
    # xxx delete or comment these out when you're happy that it works
    print "New set of picks:\n";
    map { print "  $_\n" } @{$CPAN::Config->{urllist}};
}

1;
lobals now so that if we get called
    # again, we initialize ourselves in exactly the same way.  This allows
    # us to have several of these objects.
    @QUERY_PARAM = $self->param; # save list of parameters
    foreach (@QUERY_PARAM) {
      next unless defined $_;
      $QUERY_PARAM{$_}=$self->{$_};
    }
    $QUERY_CHARSET = $self->charset;
    %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
}

sub parse_params {
    my($self,$tosplit) = @_;
    my(@pairs) = split(/[&;]/                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                package CPAN::Nox;
use strict;
use vars qw($VERSION @EXPORT);

BEGIN{
  $CPAN::Suppress_readline=1 unless defined $CPAN::term;
}

use base 'Exporter';
use CPAN;

$VERSION = "1.00";
$CPAN::META->has_inst('MD5','no');
$CPAN::META->has_inst('LWP','no');
$CPAN::META->has_inst('Compress::Zlib','no');
@EXPORT = @CPAN::EXPORT;

*AUTOLOAD = \&CPAN::AUTOLOAD;

__END__

=head1 NAME

CPAN::Nox - Wrapper around CPAN.pm without using any XS module

=head1 SYNOPSIS

Interactive mode:

  perl -MCPAN::Nox -e shell;

=head1 DESCRIPTION

This package has the same functionality as CPAN.pm, but tries to
prevent the usage of compiled extensions during it's own
execution. It's primary purpose is a rescue in case you upgraded perl
and broke binary compatibility somehow.

=head1  SEE ALSO

CPAN(3)

=cut

      shift if \$_[0] && 
                    (ref(\$_[0]) &&
                     (substr(ref(\$_[0]),0,3) eq 'CGI' ||
                    UNIVERSAL::isa(\$_[0],'CGI')));
	    my(\$attr) = '';
	    if (ref(\$_[0]) && ref(\$_[0]) eq                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
package CPAN;
$VERSION = '1.59_54';
# $Id: CPAN.pm,v 1.385 2001/02/09 21:37:57 k Exp $

# only used during development:
$Revision = "";
# $Revision = "[".substr(q$Revision: 1.385 $, 10)."]";

use Carp ();
use Config ();
use Cwd ();
use DirHandle;
use Exporter ();
use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1;
use File::Basename ();
use File::Copy ();
use File::Find;
use File::Path ();
use FileHandle ();
use Safe ();
use Text::ParseWords ();
use Text::Wrap;
use File::Spec;
no lib "."; # we need to run chdir all over and we would get at wrong
            # libraries there

require Mac::BuildTools if $^O eq 'MacOS';

END { $End++; &cleanup; }

%CPAN::DEBUG = qw[
		  CPAN              1
		  Index             2
		  InfoObj           4
		  Author            8
		  Distribution     16
		  Bundle           32
		  Module           64
		  CacheMgr        128
		  Complete        256
		  FTP             512
		  Shell          1024
		  Eval           2048
		  Config         4096
		  Tarzip         8192
		  Version       16384
		  Queue         32768
];

$CPAN::DEBUG ||= 0;
$CPAN::Signal ||= 0;
$CPAN::Frontend ||= "CPAN::Shell";
$CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";

package CPAN;
use strict qw(vars);

use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
            $Revision $Signal $End $Suppress_readline $Frontend
            $Defaultsite $Have_warned);

@CPAN::ISA = qw(CPAN::Debug Exporter);

@EXPORT = qw(
	     autobundle bundle expand force get cvs_import
	     install make readme recompile shell test clean
	    );

#-> sub CPAN::AUTOLOAD ;
sub AUTOLOAD {
    my($l) = $AUTOLOAD;
    $l =~ s/.*:://;
    my(%EXPORT);
    @EXPORT{@EXPORT} = '';
    CPAN::Config->load unless $CPAN::Config_loaded++;
    if (exists $EXPORT{$l}){
	CPAN::Shell->$l(@_);
    } else {
	$CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
				qq{Type ? for help.
});
    }
}

#-> sub CPAN::shell ;
sub shell {
    my($self) = @_;
    $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
    CPAN::Config->load unless $CPAN::Config_loaded++;

    my $oprompt = shift || "cpan> ";
    my $prompt = $oprompt;
    my $commandline = shift || "";

    local($^W) = 1;
    unless ($Suppress_readline) {
	require Term::ReadLine;
        if (! $term
            or
            $term->ReadLine eq "Term::ReadLine::Stub"
           ) {
            $term = Term::ReadLine->new('CPAN Monitor');
        }
	if ($term->ReadLine eq "Term::ReadLine::Gnu") {
	    my $attribs = $term->Attribs;
	     $attribs->{attempted_completion_function} = sub {
		 &CPAN::Complete::gnu_cpl;
	     }
	} else {
	    $readline::rl_completion_function =
		$readline::rl_completion_function = 'CPAN::Complete::cpl';
	}
	# $term->OUT is autoflushed anyway
	my $odef = select STDERR;
	$| = 1;
	select STDOUT;
	$| = 1;
	select $odef;
    }

    # no strict; # I do not recall why no strict was here (2000-09-03)
    $META->checklock();
    my $cwd = CPAN::anycwd();
    my $try_detect_readline;
    $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
    my $rl_avail = $Suppress_readline ? "suppressed" :
	($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
	    "available (try 'install Bundle::CPAN')";

    $CPAN::Frontend->myprint(
			     sprintf qq{
cpan shell -- CPAN exploration and modules installation (v%s%s)
ReadLine support %s

},
                             $CPAN::VERSION,
                             $CPAN::Revision,
                             $rl_avail
                            )
        unless $CPAN::Config->{'inhibit_startup_message'} ;
    my($continuation) = "";
  SHELLCOMMAND: while () {
	if ($Suppress_readline) {
	    print $prompt;
	    last SHELLCOMMAND unless defined ($_ = <> );
	    chomp;
	} else {
	    last SHELLCOMMAND unless
                defined ($_ = $term->readline($prompt, $commandline));
	}
	$_ = "$continuation$_" if $continuation;
	s/^\s+//;
	next SHELLCOMMAND if /^$/;
	$_ = 'h' if /^\s*\?/;
	if (/^(?:q(?:uit)?|bye|exit)$/i) {
	    last SHELLCOMMAND;
	} elsif (s/\\$//s) {
	    chomp;
	    $continuation = $_;
	    $prompt = "    > ";
	} elsif (/^\!/) {
	    s/^\!//;
	    my($eval) = $_;
	    package CPAN::Eval;
	    use vars qw($import_done);
	    CPAN->import(':DEFAULT') unless $import_done++;
	    CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
	    eval($eval);
	    warn $@ if $@;
	    $continuation = "";
	    $prompt = $oprompt;
	} elsif (/./) {
	    my(@line);
	    if ($] < 5.00322) { # parsewords had a bug until recently
		@line = split;
	    } else {
		eval { @line = Text::ParseWords::shellwords($_) };
		warn($@), next SHELLCOMMAND if $@;
                warn("Text::Parsewords could not parse the line [$_]"),
                    next SHELLCOMMAND unless @line;
	    }
	    $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
	    my $command = shift @line;
	    eval { CPAN::Shell->$command(@line) };
	    warn $@ if $@;
	    chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
	    $CPAN::Frontend->myprint("\n");
	    $continuation = "";
	    $prompt = $oprompt;
	}
    } continue {
      $commandline = ""; # I do want to be able to pass a default to
                         # shell, but on the second command I see no
                         # use in that
      $Signal=0;
      CPAN::Queue->nullify_queue;
      if ($try_detect_readline) {
	if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
	    ||
	    $CPAN::META->has_inst("Term::ReadLine::Perl")
	   ) {
	    delete $INC{"Term/ReadLine.pm"};
	    my $redef = 0;
	    local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
	    require Term::ReadLine;
	    $CPAN::Frontend->myprint("\n$redef subroutines in ".
				     "Term::ReadLine redefined\n");
            @_ = ($oprompt,"");
	    goto &shell;
	}
      }
    }
    chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
}

package CPAN::CacheMgr;
@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
use File::Find;

package CPAN::Config;
use vars qw(%can $dot_cpan);

%can = (
  'commit' => "Commit changes to disk",
  'defaults' => "Reload defaults from disk",
  'init'   => "Interactive setting of all options",
);

package CPAN::FTP;
use vars qw($Ua $Thesite $Themethod);
@CPAN::FTP::ISA = qw(CPAN::Debug);

package CPAN::LWP::UserAgent;
use vars qw(@ISA $USER $PASSWD $SETUPDONE);
# we delay requiring LWP::UserAgent and setting up inheritence until we need it

package CPAN::Complete;
@CPAN::Complete::ISA = qw(CPAN::Debug);
@CPAN::Complete::COMMANDS = sort qw(
		       ! a b d h i m o q r u autobundle clean dump
		       make test install force readme reload look
                       cvs_import ls
) unless @CPAN::Complete::COMMANDS;

package CPAN::Index;
use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
@CPAN::Index::ISA = qw(CPAN::Debug);
$LAST_TIME ||= 0;
$DATE_OF_03 ||= 0;
# use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
sub PROTOCOL { 2.0 }

package CPAN::InfoObj;
@CPAN::InfoObj::ISA = qw(CPAN::Debug);

package CPAN::Author;
@CPAN::Author::ISA = qw(CPAN::InfoObj);

package CPAN::Distribution;
@CPAN::Distribution::ISA = qw(CPAN::InfoObj);

package CPAN::Bundle;
@CPAN::Bundle::ISA = qw(CPAN::Module);

package CPAN::Module;
@CPAN::Module::ISA = qw(CPAN::InfoObj);

package CPAN::Shell;
use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
@CPAN::Shell::ISA = qw(CPAN::Debug);
$COLOR_REGISTERED ||= 0;
$PRINT_ORNAMENTING ||= 0;

#-> sub CPAN::Shell::AUTOLOAD ;
sub AUTOLOAD {
    my($autoload) = $AUTOLOAD;
    my $class = shift(@_);
    # warn "autoload[$autoload] class[$class]";
    $autoload =~ s/.*:://;
    if ($autoload =~ /^w/) {
	if ($CPAN::META->has_inst('CPAN::WAIT')) {
	    CPAN::WAIT->$autoload(@_);
	} else {
	    $CPAN::Frontend->mywarn(qq{
Commands starting with "w" require CPAN::WAIT to be installed.
Please consider installing CPAN::WAIT to use the fulltext index.
For this you just need to type
    install CPAN::WAIT
});
	}
    } else {
	$CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
				qq{Type ? for help.
});
    }
}

package CPAN::Tarzip;
use vars qw($AUTOLOAD @ISA $BUGHUNTING);
@CPAN::Tarzip::ISA = qw(CPAN::Debug);
$BUGHUNTING = 0; # released code must have turned off

package CPAN::Queue;

# One use of the queue is to determine if we should or shouldn't
# announce the availability of a new CPAN module

# Now we try to use it for dependency tracking. For that to happen
# we need to draw a dependency tree and do the leaves first. This can
# easily be reached by running CPAN.pm recursively, but we don't want
# to waste memory and run into deep recursion. So what we can do is
# this:

# CPAN::Queue is the package where the queue is maintained. Dependencies
# often have high priority and must be brought to the head of the queue,
# possibly by jumping the queue if they are already there. My first code
# attempt tried to be extremely correct. Whenever a module needed
# immediate treatment, I either unshifted it to the front of the queue,
# or, if it was already in the queue, I spliced and let it bypass the
# others. This became a too correct model that made it impossible to put
# an item more than once into the queue. Why would you need that? Well,
# you need temporary duplicates as the manager of the queue is a loop
# that
#
#  (1) looks at the first item in the queue without shifting it off
#
#  (2) cares for the item
#
#  (3) removes the item from the queue, *even if its agenda failed and
#      even if the item isn't the first in the queue anymore* (that way
#      protecting against never ending queues)
#
# So if an item has prerequisites, the installation fails now, but we
# want to retry later. That's easy if we have it twice in the queue.
#
# I also expect insane dependency situations where an item gets more
# than two lives in the queue. Simplest example is triggered by 'install
# Foo Foo Foo'. People make this kind of mistakes and I don't want to
# get in the way. I wanted the queue manager to be a dumb servant, not
# one that knows everything.
#
# Who would I tell in this model that the user wants to be asked before
# processing? I can't attach that information to the module object,
# because not modules are installed but distributions. So I'd have to
# tell the distribution object that it should ask the user before
# processing. Where would the question be triggered then? Most probably
# in CPAN::Distribution::rematein.
# Hope that makes sense, my head is a bit off:-) -- AK

use vars qw{ @All };

# CPAN::Queue::new ;
sub new {
  my($class,$s) = @_;
  my $self = bless { qmod => $s }, $class;
  push @All, $self;
  return $self;
}

# CPAN::Queue::first ;
sub first {
  my $obj = $All[0];
  $obj->{qmod};
}

# CPAN::Queue::delete_first ;
sub delete_first {
  my($class,$what) = @_;
  my $i;
  for my $i (0..$#All) {
    if (  $All[$i]->{qmod} eq $what ) {
      splice @All, $i, 1;
      return;
    }
  }
}

# CPAN::Queue::jumpqueue ;
sub jumpqueue {
    my $class = shift;
    my @what = @_;
    CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
                        join(",",map {$_->{qmod}} @All),
                        join(",",@what)
                       )) if $CPAN::DEBUG;
  WHAT: for my $what (reverse @what) {
        my $jumped = 0;
        for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
            CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG;
            if ($All[$i]->{qmod} eq $what){
                $jumped++;
                if ($jumped > 100) { # one's OK if e.g. just
                                     # processing now; more are OK if
                                     # user typed it several times
                    $CPAN::Frontend->mywarn(
qq{Object [$what] queued more than 100 times, ignoring}
				 );
                    next WHAT;
                }
            }
        }
        my $obj = bless { qmod => $what }, $class;
        unshift @All, $obj;
    }
    CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]",
                        join(",",map {$_->{qmod}} @All),
                        join(",",@what)
                       )) if $CPAN::DEBUG;
}

# CPAN::Queue::exists ;
sub exists {
  my($self,$what) = @_;
  my @all = map { $_->{qmod} } @All;
  my $exists = grep { $_->{qmod} eq $what } @All;
  # warn "in exists what[$what] all[@all] exists[$exists]";
  $exists;
}

# CPAN::Queue::delete ;
sub delete {
  my($self,$mod) = @_;
  @All = grep { $_->{qmod} ne $mod } @All;
}

# CPAN::Queue::nullify_queue ;
sub nullify_queue {
  @All = ();
}



package CPAN;

$META ||= CPAN->new; # In case we re-eval ourselves we need the ||

# from here on only subs.
################################################################################

#-> sub CPAN::all_objects ;
sub all_objects {
    my($mgr,$class) = @_;
    CPAN::Config->load unless $CPAN::Config_loaded++;
    CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
    CPAN::Index->reload;
    values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
}
*all = \&all_objects;

# Called by shell, not in batch mode. In batch mode I see no risk in
# having many processes updating something as installations are
# continually checked at runtime. In shell mode I suspect it is
# unintentional to open more than one shell at a time

#-> sub CPAN::checklock ;
sub checklock {
    my($self) = @_;
    my $lockfile = MM->catfile($CPAN::Config->{cpan_home},".lock");
    if (-f $lockfile && -M _ > 0) {
	my $fh = FileHandle->new($lockfile) or
            $CPAN::Frontend->mydie("Could not open $lockfile: $!");
	my $other = <$fh>;
	$fh->close;
	if (defined $other && $other) {
	    chomp $other;
	    return if $$==$other; # should never happen
	    $CPAN::Frontend->mywarn(
				    qq{
There seems to be running another CPAN process ($other). Contacting...
});
	    if (kill 0, $other) {
		$CPAN::Frontend->mydie(qq{Other job is running.
You may want to kill it and delete the lockfile, maybe. On UNIX try:
    kill $other
    rm $lockfile
});
	    } elsif (-w $lockfile) {
		my($ans) =
		    ExtUtils::MakeMaker::prompt
			(qq{Other job not responding. Shall I overwrite }.
			 qq{the lockfile? (Y/N)},"y");
		$CPAN::Frontend->myexit("Ok, bye\n")
		    unless $ans =~ /^y/i;
	    } else {
		Carp::croak(
			    qq{Lockfile $lockfile not writeable by you. }.
			    qq{Cannot proceed.\n}.
			    qq{    On UNIX try:\n}.
			    qq{    rm $lockfile\n}.
			    qq{  and then rerun us.\n}
			   );
	    }
	} else {
            $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile ".
                                           "reports other process with ID ".
                                           "$other. Cannot proceed.\n"));
        }
    }
    my $dotcpan = $CPAN::Config->{cpan_home};
    eval { File::Path::mkpath($dotcpan);};
    if ($@) {
      # A special case at least for Jarkko.
      my $firsterror = $@;
      my $seconderror;
      my $symlinkcpan;
      if (-l $dotcpan) {
	$symlinkcpan = readlink $dotcpan;
	die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
	eval { File::Path::mkpath($symlinkcpan); };
	if ($@) {
	  $seconderror = $@;
	} else {
	  $CPAN::Frontend->mywarn(qq{
Working directory $symlinkcpan created.
});
	}
      }
      unless (-d $dotcpan) {
	my $diemess = qq{
Your configuration suggests "$dotcpan" as your
CPAN.pm working directory. I could not create this directory due
to this error: $firsterror\n};
	$diemess .= qq{
As "$dotcpan" is a symlink to "$symlinkcpan",
I tried to create that, but I failed with this error: $seconderror
} if $seconderror;
	$diemess .= qq{
Please make sure the directory exists and is writable.
};
	$CPAN::Frontend->mydie($diemess);
      }
    }
    my $fh;
    unless ($fh = FileHandle->new(">$lockfile")) {
	if ($! =~ /Permission/) {
	    my $incc = $INC{'CPAN/Config.pm'};
	    my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
	    $CPAN::Frontend->myprint(qq{

Your configuration suggests that CPAN.pm should use a working
directory of
    $CPAN::Config->{cpan_home}
Unfortunately we could not create the lock file
    $lockfile
due to permission problems.

Please make sure that the configuration variable
    \$CPAN::Config->{cpan_home}
points to a directory where you can write a .lock file. You can set
this variable in either
    $incc
or
    $myincc

});
	}
	$CPAN::Frontend->mydie("Could not open >$lockfile: $!");
    }
    $fh->print($$, "\n");
    $self->{LOCK} = $lockfile;
    $fh->close;
    $SIG{TERM} = sub {
      &cleanup;
      $CPAN::Frontend->mydie("Got SIGTERM, leaving");
    };
    $SIG{INT} = sub {
      # no blocks!!!
      &cleanup if $Signal;
      $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
      print "Caught SIGINT\n";
      $Signal++;
    };

#       From: Larry Wall <larry@wall.org>
#       Subject: Re: deprecating SIGDIE
#       To: perl5-porters@perl.org
#       Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
#
#       The original intent of __DIE__ was only to allow you to substitute one
#       kind of death for another on an application-wide basis without respect
#       to whether you were in an eval or not.  As a global backstop, it should
#       not be used any more lightly (or any more heavily :-) than class
#       UNIVERSAL.  Any attempt to build a general exception model on it should
#       be politely squashed.  Any bug that causes every eval {} to have to be
#       modified should be not so politely squashed.
#
#       Those are my current opinions.  It is also my optinion that polite
#       arguments degenerate to personal arguments far too frequently, and that
#       when they do, it's because both people wanted it to, or at least didn't
#       sufficiently want it not to.
#
#       Larry

    # global backstop to cleanup if we should really die
    $SIG{__DIE__} = \&cleanup;
    $self->debug("Signal handler set.") if $CPAN::DEBUG;
}

#-> sub CPAN::DESTROY ;
sub DESTROY {
    &cleanup; # need an eval?
}

#-> sub CPAN::anycwd ;
sub anycwd () {
    my $getcwd;
    $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
    CPAN->$getcwd();
}

#-> sub CPAN::cwd ;
sub cwd {Cwd::cwd();}

#-> sub CPAN::getcwd ;
sub getcwd {Cwd::getcwd();}

#-> sub CPAN::exists ;
sub exists {
    my($mgr,$class,$id) = @_;
    CPAN::Config->load unless $CPAN::Config_loaded++;
    CPAN::Index->reload;
    ### Carp::croak "exists called without class argument" unless $class;
    $id ||= "";
    exists $META->{readonly}{$class}{$id} or
        exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
}

#-> sub CPAN::delete ;
sub delete {
  my($mgr,$class,$id) = @_;
  delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
  delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
}

#-> sub CPAN::has_usable
# has_inst is sometimes too optimistic, we should replace it with this
# has_usable whenever a case is given
sub has_usable {
    my($self,$mod,$message) = @_;
    return 1 if $HAS_USABLE->{$mod};
    my $has_inst = $self->has_inst($mod,$message);
    return unless $has_inst;
    my $usable;
    $usable = {
               LWP => [ # we frequently had "Can't locate object
                        # method "new" via package "LWP::UserAgent" at
                        # (eval 69) line 2006
                       sub {require LWP},
                       sub {require LWP::UserAgent},
                       sub {require HTTP::Request},
                       sub {require URI::URL},
                      ],
               Net::FTP => [
                            sub {require Net::FTP},
                            sub {require Net::Config},
                           ]
              };
    if ($usable->{$mod}) {
      for my $c (0..$#{$usable->{$mod}}) {
        my $code = $usable->{$mod}[$c];
        my $ret = eval { &$code() };
        if ($@) {
          warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
          return;
        }
      }
    }
    return $HAS_USABLE->{$mod} = 1;
}

#-> sub CPAN::has_inst
sub has_inst {
    my($self,$mod,$message) = @_;
    Carp::croak("CPAN->has_inst() called without an argument")
	unless defined $mod;
    if (defined $message && $message eq "no"
        ||
        exists $CPAN::META->{dontload_hash}{$mod} # unsafe meta access, ok
        ||
        exists $CPAN::Config->{dontload_hash}{$mod}
       ) {
      $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
      return 0;
    }
    my $file = $mod;
    my $obj;
    $file =~ s|::|/|g;
    $file =~ s|/|\\|g if $^O eq 'MSWin32';
    $file .= ".pm";
    if ($INC{$file}) {
	# checking %INC is wrong, because $INC{LWP} may be true
	# although $INC{"URI/URL.pm"} may have failed. But as
	# I really want to say "bla loaded OK", I have to somehow
	# cache results.
	### warn "$file in %INC"; #debug
	return 1;
    } elsif (eval { require $file }) {
	# eval is good: if we haven't yet read the database it's
	# perfect and if we have installed the module in the meantime,
	# it tries again. The second require is only a NOOP returning
	# 1 if we had success, otherwise it's retrying

	$CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
	if ($mod eq "CPAN::WAIT") {
	    push @CPAN::Shell::ISA, CPAN::WAIT;
	}
	return 1;
    } elsif ($mod eq "Net::FTP") {
	$CPAN::Frontend->mywarn(qq{
  Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
  if you just type
      install Bundle::libnet

}) unless $Have_warned->{"Net::FTP"}++;
	sleep 3;
    } elsif ($mod eq "MD5"){
	$CPAN::Frontend->myprint(qq{
  CPAN: MD5 security checks disabled because MD5 not installed.
  Please consider installing the MD5 module.

});
	sleep 2;
    } else {
	delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
    }
    return 0;
}

#-> sub CPAN::instance ;
sub instance {
    my($mgr,$class,$id) = @_;
    CPAN::Index->reload;
    $id ||= "";
    # unsafe meta access, ok?
    return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
    $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
}

#-> sub CPAN::new ;
sub new {
    bless {}, shift;
}

#-> sub CPAN::cleanup ;
sub cleanup {
  # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
  local $SIG{__DIE__} = '';
  my($message) = @_;
  my $i = 0;
  my $ineval = 0;
  if (
      0 &&           # disabled, try reload cpan with it
      $] > 5.004_60  # thereabouts
     ) {
    $ineval = $^S;
  } else {
    my($subroutine);
    while ((undef,undef,undef,$subroutine) = caller(++$i)) {
      $ineval = 1, last if
	  $subroutine eq '(eval)';
    }
  }
  return if $ineval && !$End;
  return unless defined $META->{LOCK}; # unsafe meta access, ok
  return unless -f $META->{LOCK}; # unsafe meta access, ok
  unlink $META->{LOCK}; # unsafe meta access, ok
  # require Carp;
  # Carp::cluck("DEBUGGING");
  $CPAN::Frontend->mywarn("Lockfile removed.\n");
}

package CPAN::CacheMgr;

#-> sub CPAN::CacheMgr::as_string ;
sub as_string {
    eval { require Data::Dumper };
    if ($@) {
	return shift->SUPER::as_string;
    } else {
	return Data::Dumper::Dumper(shift);
    }
}

#-> sub CPAN::CacheMgr::cachesize ;
sub cachesize {
    shift->{DU};
}

#-> sub CPAN::CacheMgr::tidyup ;
sub tidyup {
  my($self) = @_;
  return unless -d $self->{ID};
  while ($self->{DU} > $self->{'MAX'} ) {
    my($toremove) = shift @{$self->{FIFO}};
    $CPAN::Frontend->myprint(sprintf(
				     "Deleting from cache".
				     ": $toremove (%.1f>%.1f MB)\n",
				     $self->{DU}, $self->{'MAX'})
			    );
    return if $CPAN::Signal;
    $self->force_clean_cache($toremove);
    return if $CPAN::Signal;
  }
}

#-> sub CPAN::CacheMgr::dir ;
sub dir {
    shift->{ID};
}

#-> sub CPAN::CacheMgr::entries ;
sub entries {
    my($self,$dir) = @_;
    return unless defined $dir;
    $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
    $dir ||= $self->{ID};
    my($cwd) = CPAN::anycwd();
    chdir $dir or Carp::croak("Can't chdir to $dir: $!");
    my $dh = DirHandle->new(File::Spec->curdir)
        or Carp::croak("Couldn't opendir $dir: $!");
    my(@entries);
    for ($dh->read) {
	next if $_ eq "." || $_ eq "..";
	if (-f $_) {
	    push @entries, MM->catfile($dir,$_);
	} elsif (-d _) {
	    push @entries, MM->catdir($dir,$_);
	} else {
	    $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
	}
    }
    chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
    sort { -M $b <=> -M $a} @entries;
}

#-> sub CPAN::CacheMgr::disk_usage ;
sub disk_usage {
    my($self,$dir) = @_;
    return if exists $self->{SIZE}{$dir};
    return if $CPAN::Signal;
    my($Du) = 0;
    find(
	 sub {
	   $File::Find::prune++ if $CPAN::Signal;
	   return if -l $_;
	   if ($^O eq 'MacOS') {
	     require Mac::Files;
	     my $cat  = Mac::Files::FSpGetCatInfo($_);
	     $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
	   } else {
	     $Du += (-s _);
	   }
	 },
	 $dir
	);
    return if $CPAN::Signal;
    $self->{SIZE}{$dir} = $Du/1024/1024;
    push @{$self->{FIFO}}, $dir;
    $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
    $self->{DU} += $Du/1024/1024;
    $self->{DU};
}

#-> sub CPAN::CacheMgr::force_clean_cache ;
sub force_clean_cache {
    my($self,$dir) = @_;
    return unless -e $dir;
    $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
	if $CPAN::DEBUG;
    File::Path::rmtree($dir);
    $self->{DU} -= $self->{SIZE}{$dir};
    delete $self->{SIZE}{$dir};
}

#-> sub CPAN::CacheMgr::new ;
sub new {
    my $class = shift;
    my $time = time;
    my($debug,$t2);
    $debug = "";
    my $self = {
		ID => $CPAN::Config->{'build_dir'},
		MAX => $CPAN::Config->{'build_cache'},
		SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
		DU => 0
	       };
    File::Path::mkpath($self->{ID});
    my $dh = DirHandle->new($self->{ID});
    bless $self, $class;
    $self->scan_cache;
    $t2 = time;
    $debug .= "timing of CacheMgr->new: ".($t2 - $time);
    $time = $t2;
    CPAN->debug($debug) if $CPAN::DEBUG;
    $self;
}

#-> sub CPAN::CacheMgr::scan_cache ;
sub scan_cache {
    my $self = shift;
    return if $self->{SCAN} eq 'never';
    $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
	unless $self->{SCAN} eq 'atstart';
    $CPAN::Frontend->myprint(
			     sprintf("Scanning cache %s for sizes\n",
				     $self->{ID}));
    my $e;
    for $e ($self->entries($self->{ID})) {
	next if $e eq ".." || $e eq ".";
	$self->disk_usage($e);
	return if $CPAN::Signal;
    }
    $self->tidyup;
}

package CPAN::Debug;

#-> sub CPAN::Debug::debug ;
sub debug {
    my($self,$arg) = @_;
    my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
                                               # Complete, caller(1)
                                               # eg readline
    ($caller) = caller(0);
    $caller =~ s/.*:://;
    $arg = "" unless defined $arg;
    my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
    if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
	if ($arg and ref $arg) {
	    eval { require Data::Dumper };
	    if ($@) {
		$CPAN::Frontend->myprint($arg->as_string);
	    } else {
		$CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
	    }
	} else {
	    $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
	}
    }
}

package CPAN::Config;

#-> sub CPAN::Config::edit ;
# returns true on successful action
sub edit {
    my($self,@args) = @_;
    return unless @args;
    CPAN->debug("self[$self]args[".join(" | ",@args)."]");
    my($o,$str,$func,$args,$key_exists);
    $o = shift @args;
    if($can{$o}) {
	$self->$o(@args);
	return 1;
    } else {
        CPAN->debug("o[$o]") if $CPAN::DEBUG;
	if ($o =~ /list$/) {
	    $func = shift @args;
	    $func ||= "";
            CPAN->debug("func[$func]") if $CPAN::DEBUG;
            my $changed;
	    # Let's avoid eval, it's easier to comprehend without.
	    if ($func eq "push") {
		push @{$CPAN::Config->{$o}}, @args;
                $changed = 1;
	    } elsif ($func eq "pop") {
		pop @{$CPAN::Config->{$o}};
                $changed = 1;
	    } elsif ($func eq "shift") {
		shift @{$CPAN::Config->{$o}};
                $changed = 1;
	    } elsif ($func eq "unshift") {
		unshift @{$CPAN::Config->{$o}}, @args;
                $changed = 1;
	    } elsif ($func eq "splice") {
		splice @{$CPAN::Config->{$o}}, @args;
                $changed = 1;
	    } elsif (@args) {
		$CPAN::Config->{$o} = [@args];
                $changed = 1;
	    } else {
                $self->prettyprint($o);
	    }
            if ($o eq "urllist" && $changed) {
                # reset the cached values
                undef $CPAN::FTP::Thesite;
                undef $CPAN::FTP::Themethod;
            }
            return $changed;
	} else {
	    $CPAN::Config->{$o} = $args[0] if defined $args[0];
	    $self->prettyprint($o);
	}
    }
}

sub prettyprint {
  my($self,$k) = @_;
  my $v = $CPAN::Config->{$k};
  if (ref $v) {
    my(@report) = ref $v eq "ARRAY" ?
        @$v :
            map { sprintf("   %-18s => %s\n",
                          $_,
                          defined $v->{$_} ? $v->{$_} : "UNDEFINED"
                         )} keys %$v;
    $CPAN::Frontend->myprint(
                             join(
                                  "",
                                  sprintf(
                                          "    %-18s\n",
                                          $k
                                         ),
                                  map {"\t$_\n"} @report
                                 )
                            );
  } elsif (defined $v) {
    $CPAN::Frontend->myprint(sprintf "    %-18s %s\n", $k, $v);
  } else {
    $CPAN::Frontend->myprint(sprintf "    %-18s %s\n", $k, "UNDEFINED");
  }
}

#-> sub CPAN::Config::commit ;
sub commit {
    my($self,$configpm) = @_;
    unless (defined $configpm){
	$configpm ||= $INC{"CPAN/MyConfig.pm"};
	$configpm ||= $INC{"CPAN/Config.pm"};
	$configpm || Carp::confess(q{
CPAN::Config::commit called without an argument.
Please specify a filename where to save the configuration or try
"o conf init" to have an interactive course through configing.
});
    }
    my($mode);
    if (-f $configpm) {
	$mode = (stat $configpm)[2];
	if ($mode && ! -w _) {
	    Carp::confess("$configpm is not writable");
	}
    }

    my $msg;
    $msg = <<EOF unless $configpm =~ /MyConfig/;

# This is CPAN.pm's systemwide configuration file. This file provides
# defaults for users, and the values can be changed in a per-user
# configuration file. The user-config file is being looked for as
# ~/.cpan/CPAN/MyConfig.pm.

EOF
    $msg ||= "\n";
    my($fh) = FileHandle->new;
    rename $configpm, "$configpm~" if -f $configpm;
    open $fh, ">$configpm" or
        $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
    $fh->print(qq[$msg\$CPAN::Config = \{\n]);
    foreach (sort keys %$CPAN::Config) {
	$fh->print(
		   "  '$_' => ",
		   ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
		   ",\n"
		  );
    }

    $fh->print("};\n1;\n__END__\n");
    close $fh;

    #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
    #chmod $mode, $configpm;
###why was that so?    $self->defaults;
    $CPAN::Frontend->myprint("commit: wrote $configpm\n");
    1;
}

*default = \&defaults;
#-> sub CPAN::Config::defaults ;
sub defaults {
    my($self) = @_;
    $self->unload;
    $self->load;
    1;
}

sub init {
    my($self) = @_;
    undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
                                                      # have the least
                                                      # important
                                                      # variable
                                                      # undefined
    $self->load;
    1;
}

#-> sub CPAN::Config::load ;
sub load {
    my($self) = shift;
    my(@miss);
    use Carp;
    eval {require CPAN::Config;};       # We eval because of some
                                        # MakeMaker problems
    unless ($dot_cpan++){
      unshift @INC, MM->catdir($ENV{HOME},".cpan");
      eval {require CPAN::MyConfig;};   # where you can override
                                        # system wide settings
      shift @INC;
    }
    return unless @miss = $self->missing_config_data;

    require CPAN::FirstTime;
    my($configpm,$fh,$redo,$theycalled);
    $redo ||= "";
    $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
    if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
	$configpm = $INC{"CPAN/Config.pm"};
	$redo++;
    } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
	$configpm = $INC{"CPAN/MyConfig.pm"};
	$redo++;
    } else {
	my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
	my($configpmdir) = MM->catdir($path_to_cpan,"CPAN");
	my($configpmtest) = MM->catfile($configpmdir,"Config.pm");
	if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
	    if (-w $configpmtest) {
		$configpm = $configpmtest;
	    } elsif (-w $configpmdir) {
		#_#_# following code dumped core on me with 5.003_11, a.k.
		unlink "$configpmtest.bak" if -f "$configpmtest.bak";
		rename $configpmtest, "$configpmtest.bak" if -f $configpmtest;
		my $fh = FileHandle->new;
		if ($fh->open(">$configpmtest")) {
		    $fh->print("1;\n");
		    $configpm = $configpmtest;
		} else {
		    # Should never happen
		    Carp::confess("Cannot open >$configpmtest");
		}
	    }
	}
	unless ($configpm) {
	    $configpmdir = MM->catdir($ENV{HOME},".cpan","CPAN");
	    File::Path::mkpath($configpmdir);
	    $configpmtest = MM->catfile($configpmdir,"MyConfig.pm");
	    if (-w $configpmtest) {
		$configpm = $configpmtest;
	    } elsif (-w $configpmdir) {
		#_#_# following code dumped core on me with 5.003_11, a.k.
		my $fh = FileHandle->new;
		if ($fh->open(">$configpmtest")) {
		    $fh->print("1;\n");
		    $configpm = $configpmtest;
		} else {
		    # Should never happen
		    Carp::confess("Cannot open >$configpmtest");
		}
	    } else {
		Carp::confess(qq{WARNING: CPAN.pm is unable to }.
			      qq{create a configuration file.});
	    }
	}
    }
    local($") = ", ";
    $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
We have to reconfigure CPAN.pm due to following uninitialized parameters:

@miss
END
    $CPAN::Frontend->myprint(qq{
$configpm initialized.
});
    sleep 2;
    CPAN::FirstTime::init($configpm);
}

#-> sub CPAN::Config::missing_config_data ;
sub missing_config_data {
    my(@miss);
    for (
         "cpan_home", "keep_source_where", "build_dir", "build_cache",
         "scan_cache", "index_expire", "gzip", "tar", "unzip", "make",
         "pager",
         "makepl_arg", "make_arg", "make_install_arg", "urllist",
         "inhibit_startup_message", "ftp_proxy", "http_proxy", "no_proxy",
         "prerequisites_policy",
         "cache_metadata",
        ) {
	push @miss, $_ unless defined $CPAN::Config->{$_};
    }
    return @miss;
}

#-> sub CPAN::Config::unload ;
sub unload {
    delete $INC{'CPAN/MyConfig.pm'};
    delete $INC{'CPAN/Config.pm'};
}

#-> sub CPAN::Config::help ;
sub help {
    $CPAN::Frontend->myprint(q[
Known options:
  defaults  reload default config values from disk
  commit    commit session changes to disk
  init      go through a dialog to set all parameters

You may edit key values in the follow fashion (the "o" is a literal
letter o):

  o conf build_cache 15

  o conf build_dir "/foo/bar"

  o conf urllist shift

  o conf urllist unshift ftp://ftp.foo.bar/

]);
    undef; #don't reprint CPAN::Config
}

#-> sub CPAN::Config::cpl ;
sub cpl {
    my($word,$line,$pos) = @_;
    $word ||= "";
    CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
    my(@words) = split " ", substr($line,0,$pos+1);
    if (
	defined($words[2])
	and
	(
	 $words[2] =~ /list$/ && @words == 3
	 ||
	 $words[2] =~ /list$/ && @words == 4 && length($word)
	)
       ) {
	return grep /^\Q$word\E/, qw(splice shift unshift pop push);
    } elsif (@words >= 4) {
	return ();
    }
    my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
    return grep /^\Q$word\E/, @o_conf;
}

package CPAN::Shell;

#-> sub CPAN::Shell::h ;
sub h {
    my($class,$about) = @_;
    if (defined $about) {
	$CPAN::Frontend->myprint("Detailed help not yet implemented\n");
    } else {
	$CPAN::Frontend->myprint(q{
Display Information
 command  argument          description
 a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
 i        WORD or /REGEXP/  about anything of above
 r        NONE              reinstall recommendations
 ls       AUTHOR            about files in the author's directory

Download, Test, Make, Install...
 get                        download
 make                       make (implies get)
 test      MODULES,         make test (implies make)
 install   DISTS, BUNDLES   make install (implies test)
 clean                      make clean
 look                       open subshell in these dists' directories
 readme                     display these dists' README files

Other
 h,?           display this menu       ! perl-code   eval a perl command
 o conf [opt]  set and query options   q             quit the cpan shell
 reload cpan   load CPAN.pm again      reload index  load newer indices
 autobundle    Snapshot                force cmd     unconditionally do cmd});
    }
}

*help = \&h;

#-> sub CPAN::Shell::a ;
sub a {
  my($self,@arg) = @_;
  # authors are always UPPERCASE
  for (@arg) {
    $_ = uc $_ unless /=/;
  }
  $CPAN::Frontend->myprint($self->format_result('Author',@arg));
}

#-> sub CPAN::Shell::ls ;
sub ls      {
    my($self,@arg) = @_;
    my @accept;
    for (@arg) {
        unless (/^[A-Z\-]+$/i) {
            $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author");
            next;
        }
        push @accept, uc $_;
    }
    for my $a (@accept){
        my $author = $self->expand('Author',$a) or die "No author found for $a";
        $author->ls;
    }
}

#-> sub CPAN::Shell::local_bundles ;
sub local_bundles {
    my($self,@which) = @_;
    my($incdir,$bdir,$dh);
    foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
        my @bbase = "Bundle";
        while (my $bbase = shift @bbase) {
            $bdir = MM->catdir($incdir,split /::/, $bbase);
            CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
            if ($dh = DirHandle->new($bdir)) { # may fail
                my($entry);
                for $entry ($dh->read) {
                    next if $entry =~ /^\./;
                    if (-d MM->catdir($bdir,$entry)){
                        push @bbase, "$bbase\::$entry";
                    } else {
                        next unless $entry =~ s/\.pm(?!\n)\Z//;
                        $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
                    }
                }
            }
        }
    }
}

#-> sub CPAN::Shell::b ;
sub b {
    my($self,@which) = @_;
    CPAN->debug("which[@which]") if $CPAN::DEBUG;
    $self->local_bundles;
    $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
}

#-> sub CPAN::Shell::d ;
sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}

#-> sub CPAN::Shell::m ;
sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
    $CPAN::Frontend->myprint(shift->format_result('Module',@_));
}

#-> sub CPAN::Shell::i ;
sub i {
    my($self) = shift;
    my(@args) = @_;
    my(@type,$type,@m);
    @type = qw/Author Bundle Distribution Module/;
    @args = '/./' unless @args;
    my(@result);
    for $type (@type) {
	push @result, $self->expand($type,@args);
    }
    my $result = @result == 1 ?
	$result[0]->as_string :
            @result == 0 ?
                "No objects found of any type for argument @args\n" :
                    join("",
                         (map {$_->as_glimpse} @result),
                         scalar @result, " items found\n",
                        );
    $CPAN::Frontend->myprint($result);
}

#-> sub CPAN::Shell::o ;

# CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
# should have been called set and 'o debug' maybe 'set debug'
sub o {
    my($self,$o_type,@o_what) = @_;
    $o_type ||= "";
    CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
    if ($o_type eq 'conf') {
	shift @o_what if @o_what && $o_what[0] eq 'help';
	if (!@o_what) { # print all things, "o conf"
	    my($k,$v);
	    $CPAN::Frontend->myprint("CPAN::Config options");
	    if (exists $INC{'CPAN/Config.pm'}) {
	      $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
	    }
	    if (exists $INC{'CPAN/MyConfig.pm'}) {
	      $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
	    }
	    $CPAN::Frontend->myprint(":\n");
	    for $k (sort keys %CPAN::Config::can) {
		$v = $CPAN::Config::can{$k};
		$CPAN::Frontend->myprint(sprintf "    %-18s %s\n", $k, $v);
	    }
	    $CPAN::Frontend->myprint("\n");
	    for $k (sort keys %$CPAN::Config) {
                CPAN::Config->prettyprint($k);
	    }
	    $CPAN::Frontend->myprint("\n");
	} elsif (!CPAN::Config->edit(@o_what)) {
	    $CPAN::Frontend->myprint(qq{Type 'o conf' to view configuration }.
                                     qq{edit options\n\n});
	}
    } elsif ($o_type eq 'debug') {
	my(%valid);
	@o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
	if (@o_what) {
	    while (@o_what) {
		my($what) = shift @o_what;
                if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
                    $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
                    next;
                }
		if ( exists $CPAN::DEBUG{$what} ) {
		    $CPAN::DEBUG |= $CPAN::DEBUG{$what};
		} elsif ($what =~ /^\d/) {
		    $CPAN::DEBUG = $what;
		} elsif (lc $what eq 'all') {
		    my($max) = 0;
		    for (values %CPAN::DEBUG) {
			$max += $_;
		    }
		    $CPAN::DEBUG = $max;
		} else {
		    my($known) = 0;
		    for (keys %CPAN::DEBUG) {
			next unless lc($_) eq lc($what);
			$CPAN::DEBUG |= $CPAN::DEBUG{$_};
			$known = 1;
		    }
		    $CPAN::Frontend->myprint("unknown argument [$what]\n")
			unless $known;
		}
	    }
	} else {
	  my $raw = "Valid options for debug are ".
	      join(", ",sort(keys %CPAN::DEBUG), 'all').
		  qq{ or a number. Completion works on the options. }.
		      qq{Case is ignored.};
	  require Text::Wrap;
	  $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
	  $CPAN::Frontend->myprint("\n\n");
	}
	if ($CPAN::DEBUG) {
	    $CPAN::Frontend->myprint("Options set for debugging:\n");
	    my($k,$v);
	    for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
		$v = $CPAN::DEBUG{$k};
		$CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
                    if $v & $CPAN::DEBUG;
	    }
	} else {
	    $CPAN::Frontend->myprint("Debugging turned off completely.\n");
	}
    } else {
	$CPAN::Frontend->myprint(qq{
Known options:
  conf    set or get configuration variables
  debug   set or get debugging options
});
    }
}

sub paintdots_onreload {
    my($ref) = shift;
    sub {
	if ( $_[0] =~ /[Ss]ubroutine (\w+) redefined/ ) {
	    my($subr) = $1;
	    ++$$ref;
	    local($|) = 1;
	    # $CPAN::Frontend->myprint(".($subr)");
	    $CPAN::Frontend->myprint(".");
	    return;
	}
	warn @_;
    };
}

#-> sub CPAN::Shell::reload ;
sub reload {
    my($self,$command,@arg) = @_;
    $command ||= "";
    $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
    if ($command =~ /cpan/i) {
	CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
	my $fh = FileHandle->new($INC{'CPAN.pm'});
	local($/);
	my $redef = 0;
	local($SIG{__WARN__}) = paintdots_onreload(\$redef);
	eval <$fh>;
	warn $@ if $@;
	$CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
    } elsif ($command =~ /index/) {
      CPAN::Index->force_reload;
    } else {
      $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN.pm file
index    re-reads the index files\n});
    }
}

#-> sub CPAN::Shell::_binary_extensions ;
sub _binary_extensions {
    my($self) = shift @_;
    my(@result,$module,%seen,%need,$headerdone);
    for $module ($self->expand('Module','/./')) {
	my $file  = $module->cpan_file;
	next if $file eq "N/A";
	next if $file =~ /^Contact Author/;
        my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
	next if $dist->isa_perl;
	next unless $module->xs_file;
	local($|) = 1;
	$CPAN::Frontend->myprint(".");
	push @result, $module;
    }
#    print join " | ", @result;
    $CPAN::Frontend->myprint("\n");
    return @result;
}

#-> sub CPAN::Shell::recompile ;
sub recompile {
    my($self) = shift @_;
    my($module,@module,$cpan_file,%dist);
    @module = $self->_binary_extensions();
    for $module (@module){  # we force now and compile later, so we
                            # don't do it twice
	$cpan_file = $module->cpan_file;
	my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
	$pack->force;
	$dist{$cpan_file}++;
    }
    for $cpan_file (sort keys %dist) {
	$CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
	my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
	$pack->install;
	$CPAN::Signal = 0; # it's tempting to reset Signal, so we can
                           # stop a package from recompiling,
                           # e.g. IO-1.12 when we have perl5.003_10
    }
}

#-> sub CPAN::Shell::_u_r_common ;
sub _u_r_common {
    my($self) = shift @_;
    my($what) = shift @_;
    CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
    Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
          $what && $what =~ /^[aru]$/;
    my(@args) = @_;
    @args = '/./' unless @args;
    my(@result,$module,%seen,%need,$headerdone,
       $version_undefs,$version_zeroes);
    $version_undefs = $version_zeroes = 0;
    my $sprintf = "%s%-25s%s %9s %9s  %s\n";
    my @expand = $self->expand('Module',@args);
    my $expand = scalar @expand;
    if (0) { # Looks like noise to me, was very useful for debugging
             # for metadata cache
        $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
    }
    for $module (@expand) {
	my $file  = $module->cpan_file;
	next unless defined $file; # ??
	my($latest) = $module->cpan_version;
	my($inst_file) = $module->inst_file;
	my($have);
	return if $CPAN::Signal;
	if ($inst_file){
	    if ($what eq "a") {
		$have = $module->inst_version;
	    } elsif ($what eq "r") {
		$have = $module->inst_version;
		local($^W) = 0;
		if ($have eq "undef"){
		    $version_undefs++;
		} elsif ($have == 0){
		    $version_zeroes++;
		}
		next unless CPAN::Version->vgt($latest, $have);
# to be pedantic we should probably say:
#    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
# to catch the case where CPAN has a version 0 and we have a version undef
	    } elsif ($what eq "u") {
		next;
	    }
	} else {
	    if ($what eq "a") {
		next;
	    } elsif ($what eq "r") {
		next;
	    } elsif ($what eq "u") {
		$have = "-";
	    }
	}
	return if $CPAN::Signal; # this is sometimes lengthy
	$seen{$file} ||= 0;
	if ($what eq "a") {
	    push @result, sprintf "%s %s\n", $module->id, $have;
	} elsif ($what eq "r") {
	    push @result, $module->id;
	    next if $seen{$file}++;
	} elsif ($what eq "u") {
	    push @result, $module->id;
	    next if $seen{$file}++;
	    next if $file =~ /^Contact/;
	}
	unless ($headerdone++){
	    $CPAN::Frontend->myprint("\n");
	    $CPAN::Frontend->myprint(sprintf(
                                             $sprintf,
                                             "",
                                             "Package namespace",
                                             "",
                                             "installed",
                                             "latest",
                                             "in CPAN file"
                                            ));
	}
        my $color_on = "";
        my $color_off = "";
        if (
            $COLOR_REGISTERED
            &&
            $CPAN::META->has_inst("Term::ANSIColor")
            &&
            $module->{RO}{description}
           ) {
            $color_on = Term::ANSIColor::color("green");
            $color_off = Term::ANSIColor::color("reset");
        }
	$CPAN::Frontend->myprint(sprintf $sprintf,
                                 $color_on,
                                 $module->id,
                                 $color_off,
                                 $have,
                                 $latest,
                                 $file);
	$need{$module->id}++;
    }
    unless (%need) {
	if ($what eq "u") {
	    $CPAN::Frontend->myprint("No modules found for @args\n");
	} elsif ($what eq "r") {
	    $CPAN::Frontend->myprint("All modules are up to date for @args\n");
	}
    }
    if ($what eq "r") {
	if ($version_zeroes) {
	    my $s_has = $version_zeroes > 1 ? "s have" : " has";
	    $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
		qq{a version number of 0\n});
	}
	if ($version_undefs) {
	    my $s_has = $version_undefs > 1 ? "s have" : " has";
	    $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
		qq{parseable version number\n});
	}
    }
    @result;
}

#-> sub CPAN::Shell::r ;
sub r {
    shift->_u_r_common("r",@_);
}

#-> sub CPAN::Shell::u ;
sub u {
    shift->_u_r_common("u",@_);
}

#-> sub CPAN::Shell::autobundle ;
sub autobundle {
    my($self) = shift;
    CPAN::Config->load unless $CPAN::Config_loaded++;
    my(@bundle) = $self->_u_r_common("a",@_);
    my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle");
    File::Path::mkpath($todir);
    unless (-d $todir) {
	$CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
	return;
    }
    my($y,$m,$d) =  (localtime)[5,4,3];
    $y+=1900;
    $m++;
    my($c) = 0;
    my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
    my($to) = MM->catfile($todir,"$me.pm");
    while (-f $to) {
	$me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
	$to = MM->catfile($todir,"$me.pm");
    }
    my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
    $fh->print(
	       "package Bundle::$me;\n\n",
	       "\$VERSION = '0.01';\n\n",
	       "1;\n\n",
	       "__END__\n\n",
	       "=head1 NAME\n\n",
	       "Bundle::$me - Snapshot of installation on ",
	       $Config::Config{'myhostname'},
	       " on ",
	       scalar(localtime),
	       "\n\n=head1 SYNOPSIS\n\n",
	       "perl -MCPAN -e 'install Bundle::$me'\n\n",
	       "=head1 CONTENTS\n\n",
	       join("\n", @bundle),
	       "\n\n=head1 CONFIGURATION\n\n",
	       Config->myconfig,
	       "\n\n=head1 AUTHOR\n\n",
	       "This Bundle has been generated automatically ",
	       "by the autobundle routine in CPAN.pm.\n",
	      );
    $fh->close;
    $CPAN::Frontend->myprint("\nWrote bundle file
    $to\n\n");
}

#-> sub CPAN::Shell::expandany ;
sub expandany {
    my($self,$s) = @_;
    CPAN->debug("s[$s]") if $CPAN::DEBUG;
    if ($s =~ m|/|) { # looks like a file
        $s = CPAN::Distribution->normalize($s);
        return $CPAN::META->instance('CPAN::Distribution',$s);
        # Distributions spring into existence, not expand
    } elsif ($s =~ m|^Bundle::|) {
        $self->local_bundles; # scanning so late for bundles seems
                              # both attractive and crumpy: always
                              # current state but easy to forget
                              # somewhere
        return $self->expand('Bundle',$s);
    } else {
        return $self->expand('Module',$s)
            if $CPAN::META->exists('CPAN::Module',$s);
    }
    return;
}

#-> sub CPAN::Shell::expand ;
sub expand {
    shift;
    my($type,@args) = @_;
    my($arg,@m);
    CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
    for $arg (@args) {
	my($regex,$command);
	if ($arg =~ m|^/(.*)/$|) {
	    $regex = $1;
	} elsif ($arg =~ m/=/) {
            $command = 1;
        }
	my $class = "CPAN::$type";
	my $obj;
        CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
                    $class,
                    defined $regex ? $regex : "UNDEFINED",
                    $command || "UNDEFINED",
                   ) if $CPAN::DEBUG;
	if (defined $regex) {
            for $obj (
                      sort
                      {$a->id cmp $b->id}
                      $CPAN::META->all_objects($class)
                     ) {
                unless ($obj->id){
                    # BUG, we got an empty object somewhere
                    require Data::Dumper;
                    CPAN->debug(sprintf(
                                        "Bug in CPAN: Empty id on obj[%s][%s]",
                                        $obj,
                                        Data::Dumper::Dumper($obj)
                                       )) if $CPAN::DEBUG;
                    next;
                }
                push @m, $obj
                    if $obj->id =~ /$regex/i
                        or
                            (
                             (
                              $] < 5.00303 ### provide sort of
                              ### compatibility with 5.003
                              ||
                              $obj->can('name')
                             )
                             &&
                             $obj->name  =~ /$regex/i
                            );
            }
        } elsif ($command) {
            die "equal sign in command disabled (immature interface), ".
                "you can set
 ! \$CPAN::Shell::ADVANCED_QUERY=1
to enable it. But please note, this is HIGHLY EXPERIMENTAL code
that may go away anytime.\n"
                    unless $ADVANCED_QUERY;
            my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
            my($matchcrit) = $criterion =~ m/^~(.+)/;
            for my $self (
                          sort
                          {$a->id cmp $b->id}
                          $CPAN::META->all_objects($class)
                         ) {
                my $lhs = $self->$method() or next; # () for 5.00503
                if ($matchcrit) {
                    push @m, $self if $lhs =~ m/$matchcrit/;
                } else {
                    push @m, $self if $lhs eq $criterion;
                }
            }
	} else {
	    my($xarg) = $arg;
	    if ( $type eq 'Bundle' ) {
		$xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
	    } elsif ($type eq "Distribution") {
                $xarg = CPAN::Distribution->normalize($arg);
            }
	    if ($CPAN::META->exists($class,$xarg)) {
		$obj = $CPAN::META->instance($class,$xarg);
	    } elsif ($CPAN::META->exists($class,$arg)) {
		$obj = $CPAN::META->instance($class,$arg);
	    } else {
		next;
	    }
	    push @m, $obj;
	}
    }
    return wantarray ? @m : $m[0];
}

#-> sub CPAN::Shell::format_result ;
sub format_result {
    my($self) = shift;
    my($type,@args) = @_;
    @args = '/./' unless @args;
    my(@result) = $self->expand($type,@args);
    my $result = @result == 1 ?
	$result[0]->as_string :
            @result == 0 ?
                "No objects of type $type found for argument @args\n" :
                    join("",
                         (map {$_->as_glimpse} @result),
                         scalar @result, " items found\n",
                        );
    $result;
}

# The only reason for this method is currently to have a reliable
# debugging utility that reveals which output is going through which
# channel. No, I don't like the colors ;-)

#-> sub CPAN::Shell::print_ornameted ;
sub print_ornamented {
    my($self,$what,$ornament) = @_;
    my $longest = 0;
    return unless defined $what;

    if ($CPAN::Config->{term_is_latin}){
        # courtesy jhi:
        $what
            =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
    }
    if ($PRINT_ORNAMENTING) {
	unless (defined &color) {
	    if ($CPAN::META->has_inst("Term::ANSIColor")) {
		import Term::ANSIColor "color";
	    } else {
		*color = sub { return "" };
	    }
	}
	my $line;
	for $line (split /\n/, $what) {
	    $longest = length($line) if length($line) > $longest;
	}
	my $sprintf = "%-" . $longest . "s";
	while ($what){
	    $what =~ s/(.*\n?)//m;
	    my $line = $1;
	    last unless $line;
	    my($nl) = chomp $line ? "\n" : "";
	    #	print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
	    print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
	}
    } else {
	print $what;
    }
}

sub myprint {
    my($self,$what) = @_;

    $self->print_ornamented($what, 'bold blue on_yellow');
}

sub myexit {
    my($self,$what) = @_;
    $self->myprint($what);
    exit;
}

sub mywarn {
    my($self,$what) = @_;
    $self->print_ornamented($what, 'bold red on_yellow');
}

sub myconfess {
    my($self,$what) = @_;
    $self->print_ornamented($what, 'bold red on_white');
    Carp::confess "died";
}

sub mydie {
    my($self,$what) = @_;
    $self->print_ornamented($what, 'bold red on_white');
    die "\n";
}

sub setup_output {
    return if -t STDOUT;
    my $odef = select STDERR;
    $| = 1;
    select STDOUT;
    $| = 1;
    select $odef;
}

#-> sub CPAN::Shell::rematein ;
# RE-adme||MA-ke||TE-st||IN-stall
sub rematein {
    shift;
    my($meth,@some) = @_;
    my $pragma = "";
    if ($meth eq 'force') {
	$pragma = $meth;
	$meth = shift @some;
    }
    setup_output();
    CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;

    # Here is the place to set "test_count" on all involved parties to
    # 0. We then can pass this counter on to the involved
    # distributions and those can refuse to test if test_count > X. In
    # the first stab at it we could use a 1 for "X".

    # But when do I reset the distributions to start with 0 again?
    # Jost suggested to have a random or cycling interaction ID that
    # we pass through. But the ID is something that is just left lying
    # around in addition to the counter, so I'd prefer to set the
    # counter to 0 now, and repeat at the end of the loop. But what
    # about dependencies? They appear later and are not reset, they
    # enter the queue but not its copy. How do they get a sensible
    # test_count?

    # construct the queue
    my($s,@s,@qcopy);
    foreach $s (@some) {
	my $obj;
	if (ref $s) {
            CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
	    $obj = $s;
	} elsif ($s =~ m|^/|) { # looks like a regexp
            $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
                                    "not supported\n");
            sleep 2;
            next;
	} else {
            CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
	    $obj = CPAN::Shell->expandany($s);
	}
	if (ref $obj) {
            $obj->color_cmd_tmps(0,1);
            CPAN::Queue->new($obj->id);
            push @qcopy, $obj;
	} elsif ($CPAN::META->exists('CPAN::Author',$s)) {
	    $obj = $CPAN::META->instance('CPAN::Author',$s);
            if ($meth eq "dump") {
                $obj->dump;
            } else {
                $CPAN::Frontend->myprint(
                                         join "",
                                         "Don't be silly, you can't $meth ",
                                         $obj->fullname,
                                         " ;-)\n"
                                        );
                sleep 2;
            }
	} else {
	    $CPAN::Frontend
		->myprint(qq{Warning: Cannot $meth $s, }.
			  qq{don\'t know what it is.
Try the command

    i /$s/

to find objects with matching identifiers.
});
            sleep 2;
	}
    }

    # queuerunner (please be warned: when I started to change the
    # queue to hold objects instead of names, I made one or two
    # mistakes and never found which. I reverted back instead)
    while ($s = CPAN::Queue->first) {
        my $obj;
	if (ref $s) {
	    $obj = $s; # I do not believe, we would survive if this happened
	} else {
	    $obj = CPAN::Shell->expandany($s);
	}
        if ($pragma
            &&
            ($] < 5.00303 || $obj->can($pragma))){
            ### compatibility with 5.003
            $obj->$pragma($meth); # the pragma "force" in
                                  # "CPAN::Distribution" must know
                                  # what we are intending
        }
        if ($]>=5.00303 && $obj->can('called_for')) {
            $obj->called_for($s);
        }
        CPAN->debug(
                    qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
                    $obj->as_string.
                    qq{\]}
                   ) if $CPAN::DEBUG;

        if ($obj->$meth()){
            CPAN::Queue->delete($s);
        } else {
            CPAN->debug("failed");
        }

        $obj->undelay;
	CPAN::Queue->delete_first($s);
    }
    for my $obj (@qcopy) {
        $obj->color_cmd_tmps(0,0);
    }
}

#-> sub CPAN::Shell::dump ;
sub dump    { shift->rematein('dump',@_); }
#-> sub CPAN::Shell::force ;
sub force   { shift->rematein('force',@_); }
#-> sub CPAN::Shell::get ;
sub get     { shift->rematein('get',@_); }
#-> sub CPAN::Shell::readme ;
sub readme  { shift->rematein('readme',@_); }
#-> sub CPAN::Shell::make ;
sub make    { shift->rematein('make',@_); }
#-> sub CPAN::Shell::test ;
sub test    { shift->rematein('test',@_); }
#-> sub CPAN::Shell::install ;
sub install { shift->rematein('install',@_); }
#-> sub CPAN::Shell::clean ;
sub clean   { shift->rematein('clean',@_); }
#-> sub CPAN::Shell::look ;
sub look   { shift->rematein('look',@_); }
#-> sub CPAN::Shell::cvs_import ;
sub cvs_import   { shift->rematein('cvs_import',@_); }

package CPAN::LWP::UserAgent;

sub config {
    return if $SETUPDONE;
    if ($CPAN::META->has_usable('LWP::UserAgent')) {
        require LWP::UserAgent;
        @ISA = qw(Exporter LWP::UserAgent);
        $SETUPDONE++;
    } else {
        $CPAN::Frontent->mywarn("LWP::UserAgent not available\n");
    }
}

sub get_basic_credentials {
    my($self, $realm, $uri, $proxy) = @_;
    return unless $proxy;
    if ($USER && $PASSWD) {
    } elsif (defined $CPAN::Config->{proxy_user} &&
        defined $CPAN::Config->{proxy_pass}) {
        $USER = $CPAN::Config->{proxy_user};
        $PASSWD = $CPAN::Config->{proxy_pass};
    } else {
        require ExtUtils::MakeMaker;
        ExtUtils::MakeMaker->import(qw(prompt));
        $USER = prompt("Proxy authentication needed!
 (Note: to permanently configure username and password run
   o conf proxy_user your_username
   o conf proxy_pass your_password
 )\nUsername:");
        if ($CPAN::META->has_inst("Term::ReadKey")) {
            Term::ReadKey::ReadMode("noecho");
        } else {
            $CPAN::Frontend->mywarn("Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n");
        }
        $PASSWD = prompt("Password:");
        if ($CPAN::META->has_inst("Term::ReadKey")) {
            Term::ReadKey::ReadMode("restore");
        }
        $CPAN::Frontend->myprint("\n\n");
    }
    return($USER,$PASSWD);
}

sub mirror {
    my($self,$url,$aslocal) = @_;
    my $result = $self->SUPER::mirror($url,$aslocal);
    if ($result->code == 407) {
        undef $USER;
        undef $PASSWD;
        $result = $self->SUPER::mirror($url,$aslocal);
    }
    $result;
}

package CPAN::FTP;

#-> sub CPAN::FTP::ftp_get ;
sub ftp_get {
  my($class,$host,$dir,$file,$target) = @_;
  $class->debug(
		qq[Going to fetch file [$file] from dir [$dir]
	on host [$host] as local [$target]\n]
		      ) if $CPAN::DEBUG;
  my $ftp = Net::FTP->new($host);
  return 0 unless defined $ftp;
  $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
  $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
  unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
    warn "Couldn't login on $host";
    return;
  }
  unless ( $ftp->cwd($dir) ){
    warn "Couldn't cwd $dir";
    return;
  }
  $ftp->binary;
  $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
  unless ( $ftp->get($file,$target) ){
    warn "Couldn't fetch $file from $host\n";
    return;
  }
  $ftp->quit; # it's ok if this fails
  return 1;
}

# If more accuracy is wanted/needed, Chris Leach sent me this patch...

 # > *** /install/perl/live/lib/CPAN.pm-	Wed Sep 24 13:08:48 1997
 # > --- /tmp/cp	Wed Sep 24 13:26:40 1997
 # > ***************
 # > *** 1562,1567 ****
 # > --- 1562,1580 ----
 # >       return 1 if substr($url,0,4) eq "file";
 # >       return 1 unless $url =~ m|://([^/]+)|;
 # >       my $host = $1;
 # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
 # > +     if ($proxy) {
 # > +         $proxy =~ m|://([^/:]+)|;
 # > +         $proxy = $1;
 # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
 # > +         if ($noproxy) {
 # > +             if ($host !~ /$noproxy$/) {
 # > +                 $host = $proxy;
 # > +             }
 # > +         } else {
 # > +             $host = $proxy;
 # > +         }
 # > +     }
 # >       require Net::Ping;
 # >       return 1 unless $Net::Ping::VERSION >= 2;
 # >       my $p;


#-> sub CPAN::FTP::localize ;
sub localize {
    my($self,$file,$aslocal,$force) = @_;
    $force ||= 0;
    Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
	unless defined $aslocal;
    $self->debug("file[$file] aslocal[$aslocal] force[$force]")
	if $CPAN::DEBUG;

    if ($^O eq 'MacOS') {
        # Comment by AK on 2000-09-03: Uniq short filenames would be
        # available in CHECKSUMS file
        my($name, $path) = File::Basename::fileparse($aslocal, '');
        if (length($name) > 31) {
            $name =~ s/(
                        \.(
                           readme(\.(gz|Z))? |
                           (tar\.)?(gz|Z) |
                           tgz |
                           zip |
                           pm\.(gz|Z)
                          )
                       )$//x;
            my $suf = $1;
            my $size = 31 - length($suf);
            while (length($name) > $size) {
                chop $name;
            }
            $name .= $suf;
            $aslocal = File::Spec->catfile($path, $name);
        }
    }

    return $aslocal if -f $aslocal && -r _ && !($force & 1);
    my($restore) = 0;
    if (-f $aslocal){
	rename $aslocal, "$aslocal.bak";
	$restore++;
    }

    my($aslocal_dir) = File::Basename::dirname($aslocal);
    File::Path::mkpath($aslocal_dir);
    $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
	qq{directory "$aslocal_dir".
    I\'ll continue, but if you encounter problems, they may be due
    to insufficient permissions.\n}) unless -w $aslocal_dir;

    # Inheritance is not easier to manage than a few if/else branches
    if ($CPAN::META->has_usable('LWP::UserAgent')) {
 	unless ($Ua) {
            CPAN::LWP::UserAgent->config;
	    eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
            if ($@) {
                $CPAN::Frontent->mywarn("CPAN::LWP::UserAgent->new dies with $@")
                    if $CPAN::DEBUG;
            } else {
                my($var);
                $Ua->proxy('ftp',  $var)
                    if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
                $Ua->proxy('http', $var)
                    if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};


# >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
# 
#  > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
#  > use ones that require basic autorization.
#  
#  > Example of when I use it manually in my own stuff:
#  
#  > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
#  > $req->proxy_authorization_basic("username","password");
#  > $res = $ua->request($req);
# 

                $Ua->no_proxy($var)
                    if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
            }
	}
    }
    $ENV{ftp_proxy} = $CPAN::Config->{ftp_proxy} if $CPAN::Config->{ftp_proxy};
    $ENV{http_proxy} = $CPAN::Config->{http_proxy}
        if $CPAN::Config->{http_proxy};
    $ENV{no_proxy} = $CPAN::Config->{no_proxy} if $CPAN::Config->{no_proxy};

    # Try the list of urls for each single object. We keep a record
    # where we did get a file from
    my(@reordered,$last);
    $CPAN::Config->{urllist} ||= [];
    $last = $#{$CPAN::Config->{urllist}};
    if ($force & 2) { # local cpans probably out of date, don't reorder
	@reordered = (0..$last);
    } else {
	@reordered =
	    sort {
		(substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
		    <=>
		(substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
		    or
		defined($Thesite)
		    and
		($b == $Thesite)
		    <=>
		($a == $Thesite)
	    } 0..$last;
    }
    my(@levels);
    if ($Themethod) {
	@levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
    } else {
	@levels = qw/easy hard hardest/;
    }
    @levels = qw/easy/ if $^O eq 'MacOS';
    my($levelno);
    for $levelno (0..$#levels) {
        my $level = $levels[$levelno];
	my $method = "host$level";
	my @host_seq = $level eq "easy" ?
	    @reordered : 0..$last;  # reordered has CDROM up front
	@host_seq = (0) unless @host_seq;
	my $ret = $self->$method(\@host_seq,$file,$aslocal);
	if ($ret) {
	  $Themethod = $level;
	  my $now = time;
	  # utime $now, $now, $aslocal; # too bad, if we do that, we
                                      # might alter a local mirror
	  $self->debug("level[$level]") if $CPAN::DEBUG;
	  return $ret;
	} else {
	  unlink $aslocal;
          last if $CPAN::Signal; # need to cleanup
	}
    }
    unless ($CPAN::Signal) {
        my(@mess);
        push @mess,
            qq{Please check, if the URLs I found in your configuration file \(}.
                join(", ", @{$CPAN::Config->{urllist}}).
                    qq{\) are valid. The urllist can be edited.},
                        qq{E.g. with 'o conf urllist push ftp://myurl/'};
        $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
        sleep 2;
        $CPAN::Frontend->myprint("Could not fetch $file\n");
    }
    if ($restore) {
	rename "$aslocal.bak", $aslocal;
	$CPAN::Frontend->myprint("Trying to get away with old file:\n" .
				 $self->ls($aslocal));
	return $aslocal;
    }
    return;
}

sub hosteasy {
    my($self,$host_seq,$file,$aslocal) = @_;
    my($i);
  HOSTEASY: for $i (@$host_seq) {
        my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
	$url .= "/" unless substr($url,-1) eq "/";
	$url .= $file;
	$self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
	if ($url =~ /^file:/) {
	    my $l;
	    if ($CPAN::META->has_inst('URI::URL')) {
		my $u =  URI::URL->new($url);
		$l = $u->path;
	    } else { # works only on Unix, is poorly constructed, but
		# hopefully better than nothing.
		# RFC 1738 says fileurl BNF is
		# fileurl = "file://" [ host | "localhost" ] "/" fpath
		# Thanks to "Mark D. Baushke" <mdb@cisco.com> for
		# the code
		($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
		$l =~ s|^file:||;                   # assume they
                                                    # meant
                                                    # file://localhost
		$l =~ s|^/||s unless -f $l;         # e.g. /P:
		$self->debug("without URI::URL we try local file $l") if $CPAN::DEBUG;
	    }
	    if ( -f $l && -r _) {
		$Thesite = $i;
		return $l;
	    }
	    # Maybe mirror has compressed it?
	    if (-f "$l.gz") {
		$self->debug("found compressed $l.gz") if $CPAN::DEBUG;
		CPAN::Tarzip->gunzip("$l.gz", $aslocal);
		if ( -f $aslocal) {
		    $Thesite = $i;
		    return $aslocal;
		}
	    }
	}
        if ($CPAN::META->has_usable('LWP')) {
	  $CPAN::Frontend->myprint("Fetching with LWP:
  $url
");
	  unless ($Ua) {
              CPAN::LWP::UserAgent->config;
              eval { $Ua = CPAN::LWP::UserAgent->new; };
              if ($@) {
                  $CPAN::Frontent->mywarn("CPAN::LWP::UserAgent->new dies with $@");
              }
	  }
	  my $res = $Ua->mirror($url, $aslocal);
	  if ($res->is_success) {
	    $Thesite = $i;
	    my $now = time;
	    utime $now, $now, $aslocal; # download time is more
                                        # important than upload time
	    return $aslocal;
	  } elsif ($url !~ /\.gz(?!\n)\Z/) {
	    my $gzurl = "$url.gz";
	    $CPAN::Frontend->myprint("Fetching with LWP:
  $gzurl
");
	    $res = $Ua->mirror($gzurl, "$aslocal.gz");
	    if ($res->is_success &&
		CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
	       ) {
	      $Thesite = $i;
	      return $aslocal;
	    }
	  } else {
              $CPAN::Frontend->myprint(sprintf(
                                               "LWP failed with code[%s] message[%s]\n",
                                               $res->code,
                                               $res->message,
                                              ));
	    # Alan Burlison informed me that in firewall environments
	    # Net::FTP can still succeed where LWP fails. So we do not
	    # skip Net::FTP anymore when LWP is available.
	  }
	} else {
            $CPAN::Frontend->myprint("LWP not available\n");
	}
        return if $CPAN::Signal;
	if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
	    # that's the nice and easy way thanks to Graham
	    my($host,$dir,$getfile) = ($1,$2,$3);
	    if ($CPAN::META->has_usable('Net::FTP')) {
		$dir =~ s|/+|/|g;
		$CPAN::Frontend->myprint("Fetching with Net::FTP:
  $url
");
		$self->debug("getfile[$getfile]dir[$dir]host[$host]" .
			     "aslocal[$aslocal]") if $CPAN::DEBUG;
		if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
		    $Thesite = $i;
		    return $aslocal;
		}
		if ($aslocal !~ /\.gz(?!\n)\Z/) {
		    my $gz = "$aslocal.gz";
		    $CPAN::Frontend->myprint("Fetching with Net::FTP
  $url.gz
");
		   if (CPAN::FTP->ftp_get($host,
					   $dir,
					   "$getfile.gz",
					   $gz) &&
			CPAN::Tarzip->gunzip($gz,$aslocal)
		       ){
			$Thesite = $i;
			return $aslocal;
		    }
		}
		# next HOSTEASY;
	    }
	}
        return if $CPAN::Signal;
    }
}

sub hosthard {
  my($self,$host_seq,$file,$aslocal) = @_;

  # Came back if Net::FTP couldn't establish connection (or
  # failed otherwise) Maybe they are behind a firewall, but they
  # gave us a socksified (or other) ftp program...

  my($i);
  my($devnull) = $CPAN::Config->{devnull} || "";
  # < /dev/null ";
  my($aslocal_dir) = File::Basename::dirname($aslocal);
  File::Path::mkpath($aslocal_dir);
  HOSTHARD: for $i (@$host_seq) {
	my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
	$url .= "/" unless substr($url,-1) eq "/";
	$url .= $file;
	my($proto,$host,$dir,$getfile);

	# Courtesy Mark Conty mark_conty@cargill.com change from
	# if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
	# to
	if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
	  # proto not yet used
	  ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
	} else {
	  next HOSTHARD; # who said, we could ftp anything except ftp?
	}
        next HOSTHARD if $proto eq "file"; # file URLs would have had
                                           # success above. Likely a bogus URL

	$self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
	my($f,$funkyftp);
	for $f ('lynx','ncftpget','ncftp','wget') {
	  next unless exists $CPAN::Config->{$f};
	  $funkyftp = $CPAN::Config->{$f};
	  next unless defined $funkyftp;
	  next if $funkyftp =~ /^\s*$/;
	  my($asl_ungz, $asl_gz);
	  ($asl_ungz = $aslocal) =~ s/\.gz//;
          $asl_gz = "$asl_ungz.gz";
	  my($src_switch) = "";
	  if ($f eq "lynx"){
	    $src_switch = " -source";
	  } elsif ($f eq "ncftp"){
	    $src_switch = " -c";
          } elsif ($f eq "wget"){
              $src_switch = " -O -";
	  }
	  my($chdir) = "";
	  my($stdout_redir) = " > $asl_ungz";
	  if ($f eq "ncftpget"){
	    $chdir = "cd $aslocal_dir && ";
	    $stdout_redir = "";
	  }
	  $CPAN::Frontend->myprint(
				   qq[
Trying with "$funkyftp$src_switch" to get
    $url
]);
	  my($system) =
	      "$chdir$funkyftp$src_switch '$url' $devnull$stdout_redir";
	  $self->debug("system[$system]") if $CPAN::DEBUG;
	  my($wstatus);
	  if (($wstatus = system($system)) == 0
	      &&
	      ($f eq "lynx" ?
	       -s $asl_ungz # lynx returns 0 when it fails somewhere
	       : 1
	      )
	     ) {
	    if (-s $aslocal) {
	      # Looks good
	    } elsif ($asl_ungz ne $aslocal) {
	      # test gzip integrity
	      if (CPAN::Tarzip->gtest($asl_ungz)) {
                  # e.g. foo.tar is gzipped --> foo.tar.gz
                  rename $asl_ungz, $aslocal;
	      } else {
                  CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
	      }
	    }
	    $Thesite = $i;
	    return $aslocal;
	  } elsif ($url !~ /\.gz(?!\n)\Z/) {
	    unlink $asl_ungz if
		-f $asl_ungz && -s _ == 0;
	    my $gz = "$aslocal.gz";
	    my $gzurl = "$url.gz";
	    $CPAN::Frontend->myprint(
				     qq[
Trying with "$funkyftp$src_switch" to get
  $url.gz
]);
	    my($system) = "$funkyftp$src_switch '$url.gz' $devnull > $asl_gz";
	    $self->debug("system[$system]") if $CPAN::DEBUG;
	    my($wstatus);
	    if (($wstatus = system($system)) == 0
		&&
		-s $asl_gz
	       ) {
	      # test gzip integrity
	      if (CPAN::Tarzip->gtest($asl_gz)) {
                  CPAN::Tarzip->gunzip($asl_gz,$aslocal);
	      } else {
                  # somebody uncompressed file for us?
                  rename $asl_ungz, $aslocal;
	      }
	      $Thesite = $i;
	      return $aslocal;
	    } else {
	      unlink $asl_gz if -f $asl_gz;
	    }
	  } else {
	    my $estatus = $wstatus >> 8;
	    my $size = -f $aslocal ?
		", left\n$aslocal with size ".-s _ :
		    "\nWarning: expected file [$aslocal] doesn't exist";
	    $CPAN::Frontend->myprint(qq{
System call "$system"
returned status $estatus (wstat $wstatus)$size
});
	  }
          return if $CPAN::Signal;
	} # lynx,ncftpget,ncftp
    } # host
}

sub hosthardest {
    my($self,$host_seq,$file,$aslocal) = @_;

    my($i);
    my($aslocal_dir) = File::Basename::dirname($aslocal);
    File::Path::mkpath($aslocal_dir);
  HOSTHARDEST: for $i (@$host_seq) {
	unless (length $CPAN::Config->{'ftp'}) {
	    $CPAN::Frontend->myprint("No external ftp command available\n\n");
	    last HOSTHARDEST;
	}
	my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
	$url .= "/" unless substr($url,-1) eq "/";
	$url .= $file;
	$self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
	unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
	    next;
	}
	my($host,$dir,$getfile) = ($1,$2,$3);
	my $timestamp = 0;
	my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
	   $ctime,$blksize,$blocks) = stat($aslocal);
	$timestamp = $mtime ||= 0;
	my($netrc) = CPAN::FTP::netrc->new;
	my($netrcfile) = $netrc->netrc;
	my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
	my $targetfile = File::Basename::basename($aslocal);
	my(@dialog);
	push(
	     @dialog,
	     "lcd $aslocal_dir",
	     "cd /",
	     map("cd $_", split "/", $dir), # RFC 1738
	     "bin",
	     "get $getfile $targetfile",
	     "quit"
	    );
	if (! $netrcfile) {
	    CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
	} elsif ($netrc->hasdefault || $netrc->contains($host)) {
	    CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
				$netrc->hasdefault,
				$netrc->contains($host))) if $CPAN::DEBUG;
	    if ($netrc->protected) {
		$CPAN::Frontend->myprint(qq{
  Trying with external ftp to get
    $url
  As this requires some features that are not thoroughly tested, we\'re
  not sure, that we get it right....

}
		     );
		$self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
				@dialog);
		($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
		 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
		$mtime ||= 0;
		if ($mtime > $timestamp) {
		    $CPAN::Frontend->myprint("GOT $aslocal\n");
		    $Thesite = $i;
		    return $aslocal;
		} else {
		    $CPAN::Frontend->myprint("Hmm... Still failed!\n");
		}
                return if $CPAN::Signal;
	    } else {
		$CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
					qq{correctly protected.\n});
	    }
	} else {
	    $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
  nor does it have a default entry\n");
	}

	# OK, they don't have a valid ~/.netrc. Use 'ftp -n'
	# then and login manually to host, using e-mail as
	# password.
	$CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
	unshift(
		@dialog,
		"open $host",
		"user anonymous $Config::Config{'cf_email'}"
	       );
	$self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
	($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
	 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
	$mtime ||= 0;
	if ($mtime > $timestamp) {
	    $CPAN::Frontend->myprint("GOT $aslocal\n");
	    $Thesite = $i;
	    return $aslocal;
	} else {
	    $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
	}
        return if $CPAN::Signal;
	$CPAN::Frontend->myprint("Can't access URL $url.\n\n");
	sleep 2;
    } # host
}

sub talk_ftp {
    my($self,$command,@dialog) = @_;
    my $fh = FileHandle->new;
    $fh->open("|$command") or die "Couldn't open ftp: $!";
    foreach (@dialog) { $fh->print("$_\n") }
    $fh->close;		# Wait for process to complete
    my $wstatus = $?;
    my $estatus = $wstatus >> 8;
    $CPAN::Frontend->myprint(qq{
Subprocess "|$command"
  returned status $estatus (wstat $wstatus)
}) if $wstatus;
}

# find2perl needs modularization, too, all the following is stolen
# from there
# CPAN::FTP::ls
sub ls {
    my($self,$name) = @_;
    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
     $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);

    my($perms,%user,%group);
    my $pname = $name;

    if ($blocks) {
	$blocks = int(($blocks + 1) / 2);
    }
    else {
	$blocks = int(($sizemm + 1023) / 1024);
    }

    if    (-f _) { $perms = '-'; }
    elsif (-d _) { $perms = 'd'; }
    elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
    elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
    elsif (-p _) { $perms = 'p'; }
    elsif (-S _) { $perms = 's'; }
    else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }

    my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
    my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
    my $tmpmode = $mode;
    my $tmp = $rwx[$tmpmode & 7];
    $tmpmode >>= 3;
    $tmp = $rwx[$tmpmode & 7] . $tmp;
    $tmpmode >>= 3;
    $tmp = $rwx[$tmpmode & 7] . $tmp;
    substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
    substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
    substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
    $perms .= $tmp;

    my $user = $user{$uid} || $uid;   # too lazy to implement lookup
    my $group = $group{$gid} || $gid;

    my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
    my($timeyear);
    my($moname) = $moname[$mon];
    if (-M _ > 365.25 / 2) {
	$timeyear = $year + 1900;
    }
    else {
	$timeyear = sprintf("%02d:%02d", $hour, $min);
    }

    sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
	    $ino,
		 $blocks,
		      $perms,
			    $nlink,
				$user,
				     $group,
					  $sizemm,
					      $moname,
						 $mday,
						     $timeyear,
							 $pname;
}

package CPAN::FTP::netrc;

sub new {
    my($class) = @_;
    my $file = MM->catfile($ENV{HOME},".netrc");

    my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
       $atime,$mtime,$ctime,$blksize,$blocks)
	= stat($file);
    $mode ||= 0;
    my $protected = 0;

    my($fh,@machines,$hasdefault);
    $hasdefault = 0;
    $fh = FileHandle->new or die "Could not create a filehandle";

    if($fh->open($file)){
	$protected = ($mode & 077) == 0;
	local($/) = "";
      NETRC: while (<$fh>) {
	    my(@tokens) = split " ", $_;
	  TOKEN: while (@tokens) {
		my($t) = shift @tokens;
		if ($t eq "default"){
		    $hasdefault++;
		    last NETRC;
		}
		last TOKEN if $t eq "macdef";
		if ($t eq "machine") {
		    push @machines, shift @tokens;
		}
	    }
	}
    } else {
	$file = $hasdefault = $protected = "";
    }

    bless {
	   'mach' => [@machines],
	   'netrc' => $file,
	   'hasdefault' => $hasdefault,
	   'protected' => $protected,
	  }, $class;
}

# CPAN::FTP::hasdefault;
sub hasdefault { shift->{'hasdefault'} }
sub netrc      { shift->{'netrc'}      }
sub protected  { shift->{'protected'}  }
sub contains {
    my($self,$mach) = @_;
    for ( @{$self->{'mach'}} ) {
	return 1 if $_ eq $mach;
    }
    return 0;
}

package CPAN::Complete;

sub gnu_cpl {
    my($text, $line, $start, $end) = @_;
    my(@perlret) = cpl($text, $line, $start);
    # find longest common match. Can anybody show me how to peruse
    # T::R::Gnu to have this done automatically? Seems expensive.
    return () unless @perlret;
    my($newtext) = $text;
    for (my $i = length($text)+1;;$i++) {
	last unless length($perlret[0]) && length($perlret[0]) >= $i;
	my $try = substr($perlret[0],0,$i);
	my @tries = grep {substr($_,0,$i) eq $try} @perlret;
	# warn "try[$try]tries[@tries]";
	if (@tries == @perlret) {
	    $newtext = $try;
	} else {
	    last;
	}
    }
    ($newtext,@perlret);
}

#-> sub CPAN::Complete::cpl ;
sub cpl {
    my($word,$line,$pos) = @_;
    $word ||= "";
    $line ||= "";
    $pos ||= 0;
    CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
    $line =~ s/^\s*//;
    if ($line =~ s/^(force\s*)//) {
	$pos -= length($1);
    }
    my @return;
    if ($pos == 0) {
	@return = grep /^$word/, @CPAN::Complete::COMMANDS;
    } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
	@return = ();
    } elsif ($line =~ /^(a|ls)\s/) {
	@return = cplx('CPAN::Author',uc($word));
    } elsif ($line =~ /^b\s/) {
        CPAN::Shell->local_bundles;
	@return = cplx('CPAN::Bundle',$word);
    } elsif ($line =~ /^d\s/) {
	@return = cplx('CPAN::Distribution',$word);
    } elsif ($line =~ m/^(
                          [mru]|make|clean|dump|get|test|install|readme|look|cvs_import
                         )\s/x ) {
        if ($word =~ /^Bundle::/) {
            CPAN::Shell->local_bundles;
        }
	@return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
    } elsif ($line =~ /^i\s/) {
	@return = cpl_any($word);
    } elsif ($line =~ /^reload\s/) {
	@return = cpl_reload($word,$line,$pos);
    } elsif ($line =~ /^o\s/) {
	@return = cpl_option($word,$line,$pos);
    } elsif ($line =~ m/^\S+\s/ ) {
        # fallback for future commands and what we have forgotten above
	@return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
    } else {
	@return = ();
    }
    return @return;
}

#-> sub CPAN::Complete::cplx ;
sub cplx {
    my($class, $word) = @_;
    # I believed for many years that this was sorted, today I
    # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
    # make it sorted again. Maybe sort was dropped when GNU-readline
    # support came in? The RCS file is difficult to read on that:-(
    sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
}

#-> sub CPAN::Complete::cpl_any ;
sub cpl_any {
    my($word) = shift;
    return (
	    cplx('CPAN::Author',$word),
	    cplx('CPAN::Bundle',$word),
	    cplx('CPAN::Distribution',$word),
	    cplx('CPAN::Module',$word),
	   );
}

#-> sub CPAN::Complete::cpl_reload ;
sub cpl_reload {
    my($word,$line,$pos) = @_;
    $word ||= "";
    my(@words) = split " ", $line;
    CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
    my(@ok) = qw(cpan index);
    return @ok if @words == 1;
    return grep /^\Q$word\E/, @ok if @words == 2 && $word;
}

#-> sub CPAN::Complete::cpl_option ;
sub cpl_option {
    my($word,$line,$pos) = @_;
    $word ||= "";
    my(@words) = split " ", $line;
    CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
    my(@ok) = qw(conf debug);
    return @ok if @words == 1;
    return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
    if (0) {
    } elsif ($words[1] eq 'index') {
	return ();
    } elsif ($words[1] eq 'conf') {
	return CPAN::Config::cpl(@_);
    } elsif ($words[1] eq 'debug') {
	return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
    }
}

package CPAN::Index;

#-> sub CPAN::Index::force_reload ;
sub force_reload {
    my($class) = @_;
    $CPAN::Index::LAST_TIME = 0;
    $class->reload(1);
}

#-> sub CPAN::Index::reload ;
sub reload {
    my($cl,$force) = @_;
    my $time = time;

    # XXX check if a newer one is available. (We currently read it
    # from time to time)
    for ($CPAN::Config->{index_expire}) {
	$_ = 0.001 unless $_ && $_ > 0.001;
    }
    unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
        # debug here when CPAN doesn't seem to read the Metadata
        require Carp;
        Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
    }
    unless ($CPAN::META->{PROTOCOL}) {
        $cl->read_metadata_cache;
        $CPAN::META->{PROTOCOL} ||= "1.0";
    }
    if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
        # warn "Setting last_time to 0";
        $LAST_TIME = 0; # No warning necessary
    }
    return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
	and ! $force;
    if (0) {
        # IFF we are developing, it helps to wipe out the memory
        # between reloads, otherwise it is not what a user expects.
        undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
        $CPAN::META = CPAN->new;
    }
    {
        my($debug,$t2);
        local $LAST_TIME = $time;
        local $CPAN::META->{PROTOCOL} = PROTOCOL;

        my $needshort = $^O eq "dos";

        $cl->rd_authindex($cl
                          ->reload_x(
                                     "authors/01mailrc.txt.gz",
                                     $needshort ?
                                     File::Spec->catfile('authors', '01mailrc.gz') :
                                     File::Spec->catfile('authors', '01mailrc.txt.gz'),
                                     $force));
        $t2 = time;
        $debug = "timing reading 01[".($t2 - $time)."]";
        $time = $t2;
        return if $CPAN::Signal; # this is sometimes lengthy
        $cl->rd_modpacks($cl
                         ->reload_x(
                                    "modules/02packages.details.txt.gz",
                                    $needshort ?
                                    File::Spec->catfile('modules', '02packag.gz') :
                                    File::Spec->catfile('modules', '02packages.details.txt.gz'),
                                    $force));
        $t2 = time;
        $debug .= "02[".($t2 - $time)."]";
        $time = $t2;
        return if $CPAN::Signal; # this is sometimes lengthy
        $cl->rd_modlist($cl
                        ->reload_x(
                                   "modules/03modlist.data.gz",
                                   $needshort ?
                                   File::Spec->catfile('modules', '03mlist.gz') :
                                   File::Spec->catfile('modules', '03modlist.data.gz'),
                                   $force));
        $cl->write_metadata_cache;
        $t2 = time;
        $debug .= "03[".($t2 - $time)."]";
        $time = $t2;
        CPAN->debug($debug) if $CPAN::DEBUG;
    }
    $LAST_TIME = $time;
    $CPAN::META->{PROTOCOL} = PROTOCOL;
}

#-> sub CPAN::Index::reload_x ;
sub reload_x {
    my($cl,$wanted,$localname,$force) = @_;
    $force |= 2; # means we're dealing with an index here
    CPAN::Config->load; # we should guarantee loading wherever we rely
                        # on Config XXX
    $localname ||= $wanted;
    my $abs_wanted = MM->catfile($CPAN::Config->{'keep_source_where'},
				   $localname);
    if (
	-f $abs_wanted &&
	-M $abs_wanted < $CPAN::Config->{'index_expire'} &&
	!($force & 1)
       ) {
	my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
	$cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
		   qq{day$s. I\'ll use that.});
	return $abs_wanted;
    } else {
	$force |= 1; # means we're quite serious about it.
    }
    return CPAN::FTP->localize($wanted,$abs_wanted,$force);
}

#-> sub CPAN::Index::rd_authindex ;
sub rd_authindex {
    my($cl, $index_target) = @_;
    my @lines;
    return unless defined $index_target;
    $CPAN::Frontend->myprint("Going to read $index_target\n");
    local(*FH);
    tie *FH, CPAN::Tarzip, $index_target;
    local($/) = "\n";
    push @lines, split /\012/ while <FH>;
    foreach (@lines) {
	my($userid,$fullname,$email) =
	    m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
	next unless $userid && $fullname && $email;

	# instantiate an author object
 	my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
	$userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
	return if $CPAN::Signal;
    }
}

sub userid {
  my($self,$dist) = @_;
  $dist = $self->{'id'} unless defined $dist;
  my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
  $ret;
}

#-> sub CPAN::Index::rd_modpacks ;
sub rd_modpacks {
    my($self, $index_target) = @_;
    my @lines;
    return unless defined $index_target;
    $CPAN::Frontend->myprint("Going to read $index_target\n");
    my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
    local($/) = "\n";
    while ($_ = $fh->READLINE) {
	s/\012/\n/g;
	my @ls = map {"$_\n"} split /\n/, $_;
	unshift @ls, "\n" x length($1) if /^(\n+)/;
	push @lines, @ls;
    }
    # read header
    my($line_count,$last_updated);
    while (@lines) {
	my $shift = shift(@lines);
	last if $shift =~ /^\s*$/;
	$shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
        $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
    }
    if (not defined $line_count) {

	warn qq{Warning: Your $index_target does not contain a Line-Count header.
Please check the validity of the index file by comparing it to more
than one CPAN mirror. I'll continue but problems seem likely to
happen.\a
};

	sleep 5;
    } elsif ($line_count != scalar @lines) {

	warn sprintf qq{Warning: Your %s
contains a Line-Count header of %d but I see %d lines there. Please
check the validity of the index file by comparing it to more than one
CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
$index_target, $line_count, scalar(@lines);

    }
    if (not defined $last_updated) {

	warn qq{Warning: Your $index_target does not contain a Last-Updated header.
Please check the validity of the index file by comparing it to more
than one CPAN mirror. I'll continue but problems seem likely to
happen.\a
};

	sleep 5;
    } else {

	$CPAN::Frontend
            ->myprint(sprintf qq{  Database was generated on %s\n},
                      $last_updated);
        $DATE_OF_02 = $last_updated;

        if ($CPAN::META->has_inst(HTTP::Date)) {
            require HTTP::Date;
            my($age) = (time - HTTP::Date::str2time($last_updated))/3600/24;
            if ($age > 30) {

                $CPAN::Frontend
                    ->mywarn(sprintf
                             qq{Warning: This index file is %d days old.
  Please check the host you chose as your CPAN mirror for staleness.
  I'll continue but problems seem likely to happen.\a\n},
                             $age);

            }
        } else {
            $CPAN::Frontend->myprint("  HTTP::Date not available\n");
        }
    }


    # A necessity since we have metadata_cache: delete what isn't
    # there anymore
    my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
    CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
    my(%exists);
    foreach (@lines) {
	chomp;
        # before 1.56 we split into 3 and discarded the rest. From
        # 1.57 we assign remaining text to $comment thus allowing to
        # influence isa_perl
	my($mod,$version,$dist,$comment) = split " ", $_, 4;
	my($bundle,$id,$userid);

	if ($mod eq 'CPAN' &&
	    ! (
	       CPAN::Queue->exists('Bundle::CPAN') ||
	       CPAN::Queue->exists('CPAN')
	      )
	   ) {
            local($^W)= 0;
            if ($version > $CPAN::VERSION){
                $CPAN::Frontend->myprint(qq{
  There's a new CPAN.pm version (v$version) available!
  [Current version is v$CPAN::VERSION]
  You might want to try
    install Bundle::CPAN
    reload cpan
  without quitting the current session. It should be a seamless upgrade
  while we are running...
}); #});
                sleep 2;
		$CPAN::Frontend->myprint(qq{\n});
	    }
	    last if $CPAN::Signal;
	} elsif ($mod =~ /^Bundle::(.*)/) {
	    $bundle = $1;
	}

	if ($bundle){
	    $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
	    # Let's make it a module too, because bundles have so much
	    # in common with modules.

            # Changed in 1.57_63: seems like memory bloat now without
            # any value, so commented out

	    # $CPAN::META->instance('CPAN::Module',$mod);

	} else {

	    # instantiate a module object
	    $id = $CPAN::META->instance('CPAN::Module',$mod);

	}

	if ($id->cpan_file ne $dist){ # update only if file is
                                      # different. CPAN prohibits same
                                      # name with different version
	    $userid = $self->userid($dist);
	    $id->set(
		     'CPAN_USERID' => $userid,
		     'CPAN_VERSION' => $version,
		     'CPAN_FILE' => $dist,
		    );
	}

	# instantiate a distribution object
	if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
	  # we do not need CONTAINSMODS unless we do something with
	  # this dist, so we better produce it on demand.

	  ## my $obj = $CPAN::META->instance(
	  ## 				  'CPAN::Distribution' => $dist
	  ## 				 );
	  ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
	} else {
	  $CPAN::META->instance(
				'CPAN::Distribution' => $dist
			       )->set(
				      'CPAN_USERID' => $userid,
                                      'CPAN_COMMENT' => $comment,
				     );
	}
        if ($secondtime) {
            for my $name ($mod,$dist) {
                CPAN->debug("exists name[$name]") if $CPAN::DEBUG;
                $exists{$name} = undef;
            }
        }
	return if $CPAN::Signal;
    }
    undef $fh;
    if ($secondtime) {
        for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
            for my $o ($CPAN::META->all_objects($class)) {
                next if exists $exists{$o->{ID}};
                $CPAN::META->delete($class,$o->{ID});
                CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
                    if $CPAN::DEBUG;
            }
        }
    }
}

#-> sub CPAN::Index::rd_modlist ;
sub rd_modlist {
    my($cl,$index_target) = @_;
    return unless defined $index_target;
    $CPAN::Frontend->myprint("Going to read $index_target\n");
    my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
    my @eval;
    local($/) = "\n";
    while ($_ = $fh->READLINE) {
	s/\012/\n/g;
	my @ls = map {"$_\n"} split /\n/, $_;
	unshift @ls, "\n" x length($1) if /^(\n+)/;
	push @eval, @ls;
    }
    while (@eval) {
	my $shift = shift(@eval);
	if ($shift =~ /^Date:\s+(.*)/){
	    return if $DATE_OF_03 eq $1;
	    ($DATE_OF_03) = $1;
	}
	last if $shift =~ /^\s*$/;
    }
    undef $fh;
    push @eval, q{CPAN::Modulelist->data;};
    local($^W) = 0;
    my($comp) = Safe->new("CPAN::Safe1");
    my($eval) = join("", @eval);
    my $ret = $comp->reval($eval);
    Carp::confess($@) if $@;
    return if $CPAN::Signal;
    for (keys %$ret) {
	my $obj = $CPAN::META->instance("CPAN::Module",$_);
        delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
	$obj->set(%{$ret->{$_}});
	return if $CPAN::Signal;
    }
}

#-> sub CPAN::Index::write_metadata_cache ;
sub write_metadata_cache {
    my($self) = @_;
    return unless $CPAN::Config->{'cache_metadata'};
    return unless $CPAN::META->has_usable("Storable");
    my $cache;
    foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
		      CPAN::Distribution)) {
	$cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
    }
    my $metadata_file = MM->catfile($CPAN::Config->{cpan_home},"Metadata");
    $cache->{last_time} = $LAST_TIME;
    $cache->{DATE_OF_02} = $DATE_OF_02;
    $cache->{PROTOCOL} = PROTOCOL;
    $CPAN::Frontend->myprint("Going to write $metadata_file\n");
    eval { Storable::nstore($cache, $metadata_file) };
    $CPAN::Frontend->mywarn($@) if $@;
}

#-> sub CPAN::Index::read_metadata_cache ;
sub read_metadata_cache {
    my($self) = @_;
    return unless $CPAN::Config->{'cache_metadata'};
    return unless $CPAN::META->has_usable("Storable");
    my $metadata_file = MM->catfile($CPAN::Config->{cpan_home},"Metadata");
    return unless -r $metadata_file and -f $metadata_file;
    $CPAN::Frontend->myprint("Going to read $metadata_file\n");
    my $cache;
    eval { $cache = Storable::retrieve($metadata_file) };
    $CPAN::Frontend->mywarn($@) if $@;
    if (!$cache || ref $cache ne 'HASH'){
        $LAST_TIME = 0;
        return;
    }
    if (exists $cache->{PROTOCOL}) {
        if (PROTOCOL > $cache->{PROTOCOL}) {
            $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
                                            "with protocol v%s, requiring v%s",
                                            $cache->{PROTOCOL},
                                            PROTOCOL)
                                   );
            return;
        }
    } else {
        $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
                                "with protocol v1.0");
        return;
    }
    my $clcnt = 0;
    my $idcnt = 0;
    while(my($class,$v) = each %$cache) {
	next unless $class =~ /^CPAN::/;
	$CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
        while (my($id,$ro) = each %$v) {
            $CPAN::META->{readwrite}{$class}{$id} ||=
                $class->new(ID=>$id, RO=>$ro);
            $idcnt++;
        }
        $clcnt++;
    }
    unless ($clcnt) { # sanity check
        $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
        return;
    }
    if ($idcnt < 1000) {
        $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
                                 "in $metadata_file\n");
        return;
    }
    $CPAN::META->{PROTOCOL} ||=
        $cache->{PROTOCOL}; # reading does not up or downgrade, but it
                            # does initialize to some protocol
    $LAST_TIME = $cache->{last_time};
    $DATE_OF_02 = $cache->{DATE_OF_02};
    $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
	if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
    return;
}

package CPAN::InfoObj;

# Accessors
sub cpan_userid { shift->{RO}{CPAN_USERID} }
sub id { shift->{ID}; }

#-> sub CPAN::InfoObj::new ;
sub new {
    my $this = bless {}, shift;
    %$this = @_;
    $this
}

# The set method may only be used by code that reads index data or
# otherwise "objective" data from the outside world. All session
# related material may do anything else with instance variables but
# must not touch the hash under the RO attribute. The reason is that
# the RO hash gets written to Metadata file and is thus persistent.

#-> sub CPAN::InfoObj::set ;
sub set {
    my($self,%att) = @_;
    my $class = ref $self;

    # This must be ||=, not ||, because only if we write an empty
    # reference, only then the set method will write into the readonly
    # area. But for Distributions that spring into existence, maybe
    # because of a typo, we do not like it that they are written into
    # the readonly area and made permanent (at least for a while) and
    # that is why we do not "allow" other places to call ->set.
    unless ($self->id) {
        CPAN->debug("Bug? Empty ID, rejecting");
        return;
    }
    my $ro = $self->{RO} =
        $CPAN::META->{readonly}{$class}{$self->id} ||= {};

    while (my($k,$v) = each %att) {
        $ro->{$k} = $v;
    }
}

#-> sub CPAN::InfoObj::as_glimpse ;
sub as_glimpse {
    my($self) = @_;
    my(@m);
    my $class = ref($self);
    $class =~ s/^CPAN:://;
    push @m, sprintf "%-15s %s\n", $class, $self->{ID};
    join "", @m;
}

#-> sub CPAN::InfoObj::as_string ;
sub as_string {
    my($self) = @_;
    my(@m);
    my $class = ref($self);
    $class =~ s/^CPAN:://;
    push @m, $class, " id = $self->{ID}\n";
    for (sort keys %{$self->{RO}}) {
	# next if m/^(ID|RO)$/;
	my $extra = "";
	if ($_ eq "CPAN_USERID") {
            $extra .= " (".$self->author;
            my $email; # old perls!
            if ($email = $CPAN::META->instance("CPAN::Author",
                                               $self->cpan_userid
                                              )->email) {
                $extra .= " <$email>";
            } else {
                $extra .= " <no email>";
            }
            $extra .= ")";
        } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
            push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
            next;
        }
        next unless defined $self->{RO}{$_};
        push @m, sprintf "    %-12s %s%s\n", $_, $self->{RO}{$_}, $extra;
    }
    for (sort keys %$self) {
	next if m/^(ID|RO)$/;
	if (ref($self->{$_}) eq "ARRAY") {
	  push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
	} elsif (ref($self->{$_}) eq "HASH") {
	  push @m, sprintf(
			   "    %-12s %s\n",
			   $_,
			   join(" ",keys %{$self->{$_}}),
                          );
	} else {
	  push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
	}
    }
    join "", @m, "\n";
}

#-> sub CPAN::InfoObj::author ;
sub author {
    my($self) = @_;
    $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
}

#-> sub CPAN::InfoObj::dump ;
sub dump {
  my($self) = @_;
  require Data::Dumper;
  print Data::Dumper::Dumper($self);
}

package CPAN::Author;

#-> sub CPAN::Author::id
sub id {
    my $self = shift;
    my $id = $self->{ID};
    $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
    $id;
}

#-> sub CPAN::Author::as_glimpse ;
sub as_glimpse {
    my($self) = @_;
    my(@m);
    my $class = ref($self);
    $class =~ s/^CPAN:://;
    push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
                     $class,
                     $self->{ID},
                     $self->fullname,
                     $self->email);
    join "", @m;
}

#-> sub CPAN::Author::fullname ;
sub fullname {
    shift->{RO}{FULLNAME};
}
*name = \&fullname;

#-> sub CPAN::Author::email ;
sub email    { shift->{RO}{EMAIL}; }

#-> sub CPAN::Author::ls ;
sub ls {
    my $self = shift;
    my $id = $self->id;

    # adapted from CPAN::Distribution::verifyMD5 ;
    my(@csf); # chksumfile
    @csf = $self->id =~ /(.)(.)(.*)/;
    $csf[1] = join "", @csf[0,1];
    $csf[2] = join "", @csf[1,2];
    my(@dl);
    @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0);
    unless (grep {$_->[2] eq $csf[1]} @dl) {
        $CPAN::Frontend->myprint("No files in the directory of $id\n");
        return;
    }
    @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0);
    unless (grep {$_->[2] eq $csf[2]} @dl) {
        $CPAN::Frontend->myprint("No files in the directory of $id\n");
        return;
    }
    @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1);
    $CPAN::Frontend->myprint(join "", map {
        sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
    } sort { $a->[2] cmp $b->[2] } @dl);
}

# returns an array of arrays, the latter contain (size,mtime,filename)
#-> sub CPAN::Author::dir_listing ;
sub dir_listing {
    my $self = shift;
    my $chksumfile = shift;
    my $recursive = shift;
    my $lc_want =
	MM->catfile($CPAN::Config->{keep_source_where},
                    "authors", "id", @$chksumfile);
    local($") = "/";
    # connect "force" argument with "index_expire".
    my $force = 0;
    if (my @stat = stat $lc_want) {
        $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
    }
    my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
                                      $lc_want,$force);
    unless ($lc_file) {
        $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
	$chksumfile->[-1] .= ".gz";
	$lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
                                       "$lc_want.gz",1);
	if ($lc_file) {
	    $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
	    CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
	} else {
	    return;
	}
    }

    # adapted from CPAN::Distribution::MD5_check_file ;
    my $fh = FileHandle->new;
    my($cksum);
    if (open $fh, $lc_file){
	local($/);
	my $eval = <$fh>;
	$eval =~ s/\015?\012/\n/g;
	close $fh;
	my($comp) = Safe->new();
	$cksum = $comp->reval($eval);
	if ($@) {
	    rename $lc_file, "$lc_file.bad";
	    Carp::confess($@) if $@;
	}
    } else {
	Carp::carp "Could not open $lc_file for reading";
    }
    my(@result,$f);
    for $f (sort keys %$cksum) {
        if (exists $cksum->{$f}{isdir}) {
            if ($recursive) {
                my(@dir) = @$chksumfile;
                pop @dir;
                push @dir, $f, "CHECKSUMS";
                push @result, map {
                    [$_->[0], $_->[1], "$f/$_->[2]"]
                } $self->dir_listing(\@dir,1);
            } else {
                push @result, [ 0, "-", $f ];
            }
        } else {
            push @result, [
                           ($cksum->{$f}{"size"}||0),
                           $cksum->{$f}{"mtime"}||"---",
                           $f
                          ];
        }
    }
    @result;
}

package CPAN::Distribution;

# Accessors
sub cpan_comment { shift->{RO}{CPAN_COMMENT} }

sub undelay {
    my $self = shift;
    delete $self->{later};
}

# CPAN::Distribution::normalize
sub normalize {
    my($self,$s) = @_;
    $s = $self->id unless defined $s;
    if (
        $s =~ tr|/|| == 1
        or
        $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
       ) {
        return $s if $s =~ m:^N/A|^Contact Author: ;
        $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
            $CPAN::Frontend->mywarn("Strange distribution name [$s]");
        CPAN->debug("s[$s]") if $CPAN::DEBUG;
    }
    $s;
}

#-> sub CPAN::Distribution::color_cmd_tmps ;
sub color_cmd_tmps {
    my($self) = shift;
    my($depth) = shift || 0;
    my($color) = shift || 0;
    # a distribution needs to recurse into its prereq_pms

    return if exists $self->{incommandcolor}
        && $self->{incommandcolor}==$color;
    $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
                                   "color_cmd_tmps depth[%s] self[%s] id[%s]",
                                   $depth,
                                   $self,
                                   $self->id
                                  )) if $depth>=100;
    ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
    my $prereq_pm = $self->prereq_pm;
    if (defined $prereq_pm) {
        for my $pre (keys %$prereq_pm) {
            my $premo = CPAN::Shell->expand("Module",$pre);
            $premo->color_cmd_tmps($depth+1,$color);
        }
    }
    if ($color==0) {
        delete $self->{sponsored_mods};
        delete $self->{badtestcnt};
    }
    $self->{incommandcolor} = $color;
}

#-> sub CPAN::Distribution::as_string ;
sub as_string {
  my $self = shift;
  $self->containsmods;
  $self->SUPER::as_string(@_);
}

#-> sub CPAN::Distribution::containsmods ;
sub containsmods {
  my $self = shift;
  return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
  my $dist_id = $self->{ID};
  for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
    my $mod_file = $mod->cpan_file or next;
    my $mod_id = $mod->{ID} or next;
    # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
    # sleep 1;
    $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
  }
  keys %{$self->{CONTAINSMODS}};
}

#-> sub CPAN::Distribution::uptodate ;
sub uptodate {
    my($self) = @_;
    my $c;
    foreach $c ($self->containsmods) {
        my $obj = CPAN::Shell->expandany($c);
        return 0 unless $obj->uptodate;
    }
    return 1;
}

#-> sub CPAN::Distribution::called_for ;
sub called_for {
    my($self,$id) = @_;
    $self->{CALLED_FOR} = $id if defined $id;
    return $self->{CALLED_FOR};
}

#-> sub CPAN::Distribution::safe_chdir ;
sub safe_chdir {
    my($self,$todir) = @_;
    # we die if we cannot chdir and we are debuggable
    Carp::confess("safe_chdir called without todir argument")
          unless defined $todir and length $todir;
    if (chdir $todir) {
        $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
            if $CPAN::DEBUG;
    } else {
        my $cwd = CPAN::anycwd();
        $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
                               qq{to todir[$todir]: $!});
    }
}

#-> sub CPAN::Distribution::get ;
sub get {
    my($self) = @_;
  EXCUSE: {
	my @e;
	exists $self->{'build_dir'} and push @e,
	    "Is already unwrapped into directory $self->{'build_dir'}";
	$CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
    }
    my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible

    #
    # Get the file on local disk
    #

    my($local_file);
    my($local_wanted) =
        MM->catfile(
                    $CPAN::Config->{keep_source_where},
                    "authors",
                    "id",
                    split("/",$self->id)
                   );

    $self->debug("Doing localize") if $CPAN::DEBUG;
    unless ($local_file =
            CPAN::FTP->localize("authors/id/$self->{ID}",
                                $local_wanted)) {
        my $note = "";
        if ($CPAN::Index::DATE_OF_02) {
            $note = "Note: Current database in memory was generated ".
                "on $CPAN::Index::DATE_OF_02\n";
        }
        $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
    }
    $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
    $self->{localfile} = $local_file;
    return if $CPAN::Signal;

    #
    # Check integrity
    #
    if ($CPAN::META->has_inst("MD5")) {
	$self->debug("MD5 is installed, verifying");
	$self->verifyMD5;
    } else {
	$self->debug("MD5 is NOT installed");
    }
    return if $CPAN::Signal;

    #
    # Create a clean room and go there
    #
    $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
    my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
    $self->safe_chdir($builddir);
    $self->debug("Removing tmp") if $CPAN::DEBUG;
    File::Path::rmtree("tmp");
    mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
    if ($CPAN::Signal){
        $self->safe_chdir($sub_wd);
        return;
    }
    $self->safe_chdir("tmp");

    #
    # Unpack the goods
    #
    if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
        $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
	$self->untar_me($local_file);
    } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
	$self->unzip_me($local_file);
    } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
        $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
	$self->pm2dir_me($local_file);
    } else {
	$self->{archived} = "NO";
        $self->safe_chdir($sub_wd);
        return;
    }

    # we are still in the tmp directory!
    # Let's check if the package has its own directory.
    my $dh = DirHandle->new(File::Spec->curdir)
        or Carp::croak("Couldn't opendir .: $!");
    my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
    $dh->close;
    my ($distdir,$packagedir);
    if (@readdir == 1 && -d $readdir[0]) {
        $distdir = $readdir[0];
        $packagedir = MM->catdir($builddir,$distdir);
        $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
            if $CPAN::DEBUG;
        -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
                                                    "$packagedir\n");
        File::Path::rmtree($packagedir);
        rename($distdir,$packagedir) or
            Carp::confess("Couldn't rename $distdir to $packagedir: $!");
        $self->debug(sprintf("renamed distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
                             $distdir,
                             $packagedir,
                             -e $packagedir,
                             -d $packagedir,
                            )) if $CPAN::DEBUG;
    } else {
        my $userid = $self->cpan_userid;
        unless ($userid) {
            CPAN->debug("no userid? self[$self]");
            $userid = "anon";
        }
        my $pragmatic_dir = $userid . '000';
        $pragmatic_dir =~ s/\W_//g;
        $pragmatic_dir++ while -d "../$pragmatic_dir";
        $packagedir = MM->catdir($builddir,$pragmatic_dir);
        $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
        File::Path::mkpath($packagedir);
        my($f);
        for $f (@readdir) { # is already without "." and ".."
            my $to = MM->catdir($packagedir,$f);
            rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
        }
    }
    if ($CPAN::Signal){
        $self->safe_chdir($sub_wd);
        return;
    }

    $self->{'build_dir'} = $packagedir;
    $self->safe_chdir(File::Spec->updir);
    File::Path::rmtree("tmp");

    my($mpl) = MM->catfile($packagedir,"Makefile.PL");
    my($mpl_exists) = -f $mpl;
    unless ($mpl_exists) {
        # NFS has been reported to have racing problems after the
        # renaming of a directory in some environments.
        # This trick helps.
        sleep 1;
        my $mpldh = DirHandle->new($packagedir)
            or Carp::croak("Couldn't opendir $packagedir: $!");
        $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
        $mpldh->close;
    }
    unless ($mpl_exists) {
        $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
                             $mpl,
                             CPAN::anycwd(),
                            )) if $CPAN::DEBUG;
        my($configure) = MM->catfile($packagedir,"Configure");
        if (-f $configure) {
            # do we have anything to do?
            $self->{'configure'} = $configure;
        } elsif (-f MM->catfile($packagedir,"Makefile")) {
            $CPAN::Frontend->myprint(qq{
Package comes with a Makefile and without a Makefile.PL.
We\'ll try to build it with that Makefile then.
});
            $self->{writemakefile} = "YES";
            sleep 2;
        } else {
            my $cf = $self->called_for || "unknown";
            if ($cf =~ m|/|) {
                $cf =~ s|.*/||;
                $cf =~ s|\W.*||;
            }
            $cf =~ s|[/\\:]||g; # risk of filesystem damage
            $cf = "unknown" unless length($cf);
            $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
  (The test -f "$mpl" returned false.)
  Writing one on our own (setting NAME to $cf)\a\n});
            $self->{had_no_makefile_pl}++;
            sleep 3;

            # Writing our own Makefile.PL

            my $fh = FileHandle->new;
            $fh->open(">$mpl")
                or Carp::croak("Could not open >$mpl: $!");
            $fh->print(
qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
# because there was no Makefile.PL supplied.
# Autogenerated on: }.scalar localtime().qq{

use ExtUtils::MakeMaker;
WriteMakefile(NAME => q[$cf]);

});
            $fh->close;
        }
    }

    return $self;
}

# CPAN::Distribution::untar_me ;
sub untar_me {
    my($self,$local_file) = @_;
    $self->{archived} = "tar";
    if (CPAN::Tarzip->untar($local_file)) {
	$self->{unwrapped} = "YES";
    } else {
	$self->{unwrapped} = "NO";
    }
}

# CPAN::Distribution::unzip_me ;
sub unzip_me {
    my($self,$local_file) = @_;
    $self->{archived} = "zip";
    if (CPAN::Tarzip->unzip($local_file)) {
	$self->{unwrapped} = "YES";
    } else {
	$self->{unwrapped} = "NO";
    }
    return;
}

sub pm2dir_me {
    my($self,$local_file) = @_;
    $self->{archived} = "pm";
    my $to = File::Basename::basename($local_file);
    $to =~ s/\.(gz|Z)(?!\n)\Z//;
    if (CPAN::Tarzip->gunzip($local_file,$to)) {
	$self->{unwrapped} = "YES";
    } else {
	$self->{unwrapped} = "NO";
    }
}

#-> sub CPAN::Distribution::new ;
sub new {
    my($class,%att) = @_;

    # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();

    my $this = { %att };
    return bless $this, $class;
}

#-> sub CPAN::Distribution::look ;
sub look {
    my($self) = @_;

    if ($^O eq 'MacOS') {
      $self->Mac::BuildTools::look;
      return;
    }

    if (  $CPAN::Config->{'shell'} ) {
	$CPAN::Frontend->myprint(qq{
Trying to open a subshell in the build directory...
});
    } else {
	$CPAN::Frontend->myprint(qq{
Your configuration does not define a value for subshells.
Please define it with "o conf shell <your shell>"
});
	return;
    }
    my $dist = $self->id;
    my $dir;
    unless ($dir = $self->dir) {
        $self->get;
    }
    unless ($dir ||= $self->dir) {
	$CPAN::Frontend->mywarn(qq{
Could not determine which directory to use for looking at $dist.
});
	return;
    }
    my $pwd  = CPAN::anycwd();
    $self->safe_chdir($dir);
    $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
    system($CPAN::Config->{'shell'}) == 0
	or $CPAN::Frontend->mydie("Subprocess shell error");
    $self->safe_chdir($pwd);
}

# CPAN::Distribution::cvs_import ;
sub cvs_import {
    my($self) = @_;
    $self->get;
    my $dir = $self->dir;

    my $package = $self->called_for;
    my $module = $CPAN::META->instance('CPAN::Module', $package);
    my $version = $module->cpan_version;

    my $userid = $self->cpan_userid;

    my $cvs_dir = (split '/', $dir)[-1];
    $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
    my $cvs_root = 
      $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
    my $cvs_site_perl = 
      $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
    if ($cvs_site_perl) {
	$cvs_dir = "$cvs_site_perl/$cvs_dir";
    }
    my $cvs_log = qq{"imported $package $version sources"};
    $version =~ s/\./_/g;
    my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
	       "$cvs_dir", $userid, "v$version");

    my $pwd  = CPAN::anycwd();
    chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});

    $CPAN::Frontend->myprint(qq{Working directory is $dir\n});

    $CPAN::Frontend->myprint(qq{@cmd\n});
    system(@cmd) == 0 or
	$CPAN::Frontend->mydie("cvs import failed");
    chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
}

#-> sub CPAN::Distribution::readme ;
sub readme {
    my($self) = @_;
    my($dist) = $self->id;
    my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
    $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
    my($local_file);
    my($local_wanted) =
	 MM->catfile(
			$CPAN::Config->{keep_source_where},
			"authors",
			"id",
			split("/","$sans.readme"),
		       );
    $self->debug("Doing localize") if $CPAN::DEBUG;
    $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
				      $local_wanted)
	or $CPAN::Frontend->mydie(qq{No $sans.readme found});;

    if ($^O eq 'MacOS') {
        Mac::BuildTools::launch_file($local_file);
        return;
    }

    my $fh_pager = FileHandle->new;
    local($SIG{PIPE}) = "IGNORE";
    $fh_pager->open("|$CPAN::Config->{'pager'}")
	or die "Could not open pager $CPAN::Config->{'pager'}: $!";
    my $fh_readme = FileHandle->new;
    $fh_readme->open($local_file)
	or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
    $CPAN::Frontend->myprint(qq{
Displaying file
  $local_file
with pager "$CPAN::Config->{'pager'}"
});
    sleep 2;
    $fh_pager->print(<$fh_readme>);
}

#-> sub CPAN::Distribution::verifyMD5 ;
sub verifyMD5 {
    my($self) = @_;
  EXCUSE: {
	my @e;
	$self->{MD5_STATUS} ||= "";
	$self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
	$CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
    }
    my($lc_want,$lc_file,@local,$basename);
    @local = split("/",$self->id);
    pop @local;
    push @local, "CHECKSUMS";
    $lc_want =
	MM->catfile($CPAN::Config->{keep_source_where},
		      "authors", "id", @local);
    local($") = "/";
    if (
	-s $lc_want
	&&
	$self->MD5_check_file($lc_want)
       ) {
	return $self->{MD5_STATUS} = "OK";
    }
    $lc_file = CPAN::FTP->localize("authors/id/@local",
				   $lc_want,1);
    unless ($lc_file) {
        $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
	$local[-1] .= ".gz";
	$lc_file = CPAN::FTP->localize("authors/id/@local",
				       "$lc_want.gz",1);
	if ($lc_file) {
	    $lc_file =~ s/\.gz(?!\n)\Z//;
	    CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
	} else {
	    return;
	}
    }
    $self->MD5_check_file($lc_file);
}

#-> sub CPAN::Distribution::MD5_check_file ;
sub MD5_check_file {
    my($self,$chk_file) = @_;
    my($cksum,$file,$basename);
    $file = $self->{localfile};
    $basename = File::Basename::basename($file);
    my $fh = FileHandle->new;
    if (open $fh, $chk_file){
	local($/);
	my $eval = <$fh>;
	$eval =~ s/\015?\012/\n/g;
	close $fh;
	my($comp) = Safe->new();
	$cksum = $comp->reval($eval);
	if ($@) {
	    rename $chk_file, "$chk_file.bad";
	    Carp::confess($@) if $@;
	}
    } else {
	Carp::carp "Could not open $chk_file for reading";
    }

    if (exists $cksum->{$basename}{md5}) {
	$self->debug("Found checksum for $basename:" .
		     "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;

	open($fh, $file);
	binmode $fh;
	my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
	$fh->close;
	$fh = CPAN::Tarzip->TIEHANDLE($file);

	unless ($eq) {
	  # had to inline it, when I tied it, the tiedness got lost on
	  # the call to eq_MD5. (Jan 1998)
	  my $md5 = MD5->new;
	  my($data,$ref);
	  $ref = \$data;
	  while ($fh->READ($ref, 4096) > 0){
	    $md5->add($data);
	  }
	  my $hexdigest = $md5->hexdigest;
	  $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
	}

	if ($eq) {
	  $CPAN::Frontend->myprint("Checksum for $file ok\n");
	  return $self->{MD5_STATUS} = "OK";
	} else {
	    $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
				     qq{distribution file. }.
				     qq{Please investigate.\n\n}.
				     $self->as_string,
				     $CPAN::META->instance(
							   'CPAN::Author',
							   $self->cpan_userid
							  )->as_string);

	    my $wrap = qq{I\'d recommend removing $file. Its MD5
checksum is incorrect. Maybe you have configured your 'urllist' with
a bad URL. Please check this array with 'o conf urllist', and
retry.};

            $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));

            # former versions just returned here but this seems a
            # serious threat that deserves a die

	    # $CPAN::Frontend->myprint("\n\n");
	    # sleep 3;
	    # return;
	}
	# close $fh if fileno($fh);
    } else {
	$self->{MD5_STATUS} ||= "";
	if ($self->{MD5_STATUS} eq "NIL") {
	    $CPAN::Frontend->mywarn(qq{
Warning: No md5 checksum for $basename in $chk_file.

The cause for this may be that the file is very new and the checksum
has not yet been calculated, but it may also be that something is
going awry right now.
});
            my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
            $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
	}
	$self->{MD5_STATUS} = "NIL";
	return;
    }
}

#-> sub CPAN::Distribution::eq_MD5 ;
sub eq_MD5 {
    my($self,$fh,$expectMD5) = @_;
    my $md5 = MD5->new;
    my($data);
    while (read($fh, $data, 4096)){
      $md5->add($data);
    }
    # $md5->addfile($fh);
    my $hexdigest = $md5->hexdigest;
    # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
    $hexdigest eq $expectMD5;
}

#-> sub CPAN::Distribution::force ;

# Both modules and distributions know if "force" is in effect by
# autoinspection, not by inspecting a global variable. One of the
# reason why this was chosen to work that way was the treatment of
# dependencies. They should not autpomatically inherit the force
# status. But this has the downside that ^C and die() will return to
# the prompt but will not be able to reset the force_update
# attributes. We try to correct for it currently in the read_metadata
# routine, and immediately before we check for a Signal. I hope this
# works out in one of v1.57_53ff

sub force {
  my($self, $method) = @_;
  for my $att (qw(
  MD5_STATUS archived build_dir localfile make install unwrapped
  writemakefile
 )) {
    delete $self->{$att};
  }
  if ($method && $method eq "install") {
    $self->{"force_update"}++; # name should probably have been force_install
  }
}

#-> sub CPAN::Distribution::unforce ;
sub unforce {
  my($self) = @_;
  delete $self->{'force_update'};
}

#-> sub CPAN::Distribution::isa_perl ;
sub isa_perl {
  my($self) = @_;
  my $file = File::Basename::basename($self->id);
  if ($file =~ m{ ^ perl
                  -?
		  (5)
		  ([._-])
		  (
                   \d{3}(_[0-4][0-9])?
                   |
                   \d*[24680]\.\d+
                  )
		  \.tar[._-]gz
		  (?!\n)\Z
		}xs){
    return "$1.$3";
  } elsif ($self->cpan_comment
           &&
           $self->cpan_comment =~ /isa_perl\(.+?\)/){
    return $1;
  }
}

#-> sub CPAN::Distribution::perl ;
sub perl {
    my($self) = @_;
    my($perl) = MM->file_name_is_absolute($^X) ? $^X : "";
    my $pwd  = CPAN::anycwd();
    my $candidate = MM->catfile($pwd,$^X);
    $perl ||= $candidate if MM->maybe_command($candidate);
    unless ($perl) {
	my ($component,$perl_name);
      DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
	    PATH_COMPONENT: foreach $component (MM->path(),
						$Config::Config{'binexp'}) {
		  next unless defined($component) && $component;
		  my($abs) = MM->catfile($component,$perl_name);
		  if (MM->maybe_command($abs)) {
		      $perl = $abs;
		      last DIST_PERLNAME;
		  }
	      }
	  }
    }
    $perl;
}

#-> sub CPAN::Distribution::make ;
sub make {
    my($self) = @_;
    $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
    # Emergency brake if they said install Pippi and get newest perl
    if ($self->isa_perl) {
      if (
	  $self->called_for ne $self->id &&
          ! $self->{force_update}
	 ) {
        # if we die here, we break bundles
	$CPAN::Frontend->mywarn(sprintf qq{
The most recent version "%s" of the module "%s"
comes with the current version of perl (%s).
I\'ll build that only if you ask for something like
    force install %s
or
    install %s
},
			       $CPAN::META->instance(
						     'CPAN::Module',
						     $self->called_for
						    )->cpan_version,
			       $self->called_for,
			       $self->isa_perl,
			       $self->called_for,
			       $self->id);
        sleep 5; return;
      }
    }
    $self->get;
  EXCUSE: {
	my @e;
	$self->{archived} eq "NO" and push @e,
	"Is neither a tar nor a zip archive.";

	$self->{unwrapped} eq "NO" and push @e,
	"had problems unarchiving. Please build manually";

	exists $self->{writemakefile} &&
	    $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
		$1 || "Had some problem writing Makefile";

	defined $self->{'make'} and push @e,
            "Has already been processed within this session";

        exists $self->{later} and length($self->{later}) and
            push @e, $self->{later};

	$CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
    }
    $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
    my $builddir = $self->dir;
    chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
    $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;

    if ($^O eq 'MacOS') {
        Mac::BuildTools::make($self);
        return;
    }

    my $system;
    if ($self->{'configure'}) {
      $system = $self->{'configure'};
    } else {
	my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
	my $switch = "";
# This needs a handler that can be turned on or off:
#	$switch = "-MExtUtils::MakeMaker ".
#	    "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
#	    if $] > 5.00310;
	$system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
    }
    unless (exists $self->{writemakefile}) {
	local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
	my($ret,$pid);
	$@ = "";
	if ($CPAN::Config->{inactivity_timeout}) {
	    eval {
		alarm $CPAN::Config->{inactivity_timeout};
		local $SIG{CHLD}; # = sub { wait };
		if (defined($pid = fork)) {
		    if ($pid) { #parent
			# wait;
			waitpid $pid, 0;
		    } else {    #child
		      # note, this exec isn't necessary if
		      # inactivity_timeout is 0. On the Mac I'd
		      # suggest, we set it always to 0.
		      exec $system;
		    }
		} else {
		    $CPAN::Frontend->myprint("Cannot fork: $!");
		    return;
		}
	    };
	    alarm 0;
	    if ($@){
		kill 9, $pid;
		waitpid $pid, 0;
		$CPAN::Frontend->myprint($@);
		$self->{writemakefile} = "NO $@";
		$@ = "";
		return;
	    }
	} else {
	  $ret = system($system);
	  if ($ret != 0) {
	    $self->{writemakefile} = "NO Makefile.PL returned status $ret";
	    return;
	  }
	}
	if (-f "Makefile") {
	  $self->{writemakefile} = "YES";
          delete $self->{make_clean}; # if cleaned before, enable next
	} else {
	  $self->{writemakefile} =
	      qq{NO Makefile.PL refused to write a Makefile.};
	  # It's probably worth it to record the reason, so let's retry
	  # local $/;
	  # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
	  # $self->{writemakefile} .= <$fh>;
	}
    }
    if ($CPAN::Signal){
      delete $self->{force_update};
      return;
    }
    if (my @prereq = $self->unsat_prereq){
      return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
    }
    $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
    if (system($system) == 0) {
	 $CPAN::Frontend->myprint("  $system -- OK\n");
	 $self->{'make'} = "YES";
    } else {
	 $self->{writemakefile} ||= "YES";
	 $self->{'make'} = "NO";
	 $CPAN::Frontend->myprint("  $system -- NOT OK\n");
    }
}

sub follow_prereqs {
    my($self) = shift;
    my(@prereq) = @_;
    my $id = $self->id;
    $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
                             "during [$id] -----\n");

    for my $p (@prereq) {
	$CPAN::Frontend->myprint("    $p\n");
    }
    my $follow = 0;
    if ($CPAN::Config->{prerequisites_policy} eq "follow") {
	$follow = 1;
    } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
	require ExtUtils::MakeMaker;
	my $answer = ExtUtils::MakeMaker::prompt(
"Shall I follow them and prepend them to the queue
of modules we are processing right now?", "yes");
	$follow = $answer =~ /^\s*y/i;
    } else {
	local($") = ", ";
	$CPAN::Frontend->
            myprint("  Ignoring dependencies on modules @prereq\n");
    }
    if ($follow) {
        # color them as dirty
        for my $p (@prereq) {
            CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
        }
        CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
        $self->{later} = "Delayed until after prerequisites";
        return 1; # signal success to the queuerunner
    }
}

#-> sub CPAN::Distribution::unsat_prereq ;
sub unsat_prereq {
    my($self) = @_;
    my $prereq_pm = $self->prereq_pm or return;
    my(@need);
  NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
        my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
        # we were too demanding:
        next if $nmo->uptodate;

        # if they have not specified a version, we accept any installed one
        if (not defined $need_version or
           $need_version == 0 or
           $need_version eq "undef") {
            next if defined $nmo->inst_file;
        }

        # We only want to install prereqs if either they're not installed
        # or if the installed version is too old. We cannot omit this
        # check, because if 'force' is in effect, nobody else will check.
        {
            local($^W) = 0;
            if (
                defined $nmo->inst_file &&
                ! CPAN::Version->vgt($need_version, $nmo->inst_version)
               ){
                CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]need_version[%s]",
                            $nmo->id,
                            $nmo->inst_file,
                            $nmo->inst_version,
                            CPAN::Version->readable($need_version)
                           );
                next NEED;
            }
        }

        if ($self->{sponsored_mods}{$need_module}++){
            # We have already sponsored it and for some reason it's still
            # not available. So we do nothing. Or what should we do?
            # if we push it again, we have a potential infinite loop
            next;
        }
        push @need, $need_module;
    }
    @need;
}

#-> sub CPAN::Distribution::prereq_pm ;
sub prereq_pm {
  my($self) = @_;
  return $self->{prereq_pm} if
      exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
  return unless $self->{writemakefile}; # no need to have succeeded
                                        # but we must have run it
  my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
  my $makefile = File::Spec->catfile($build_dir,"Makefile");
  my(%p) = ();
  my $fh;
  if (-f $makefile
      and
      $fh = FileHandle->new("<$makefile\0")) {

      local($/) = "\n";

      #  A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
      while (<$fh>) {
          last if /MakeMaker post_initialize section/;
          my($p) = m{^[\#]
		 \s+PREREQ_PM\s+=>\s+(.+)
		 }x;
          next unless $p;
          # warn "Found prereq expr[$p]";

          #  Regexp modified by A.Speer to remember actual version of file
          #  PREREQ_PM hash key wants, then add to
          while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
              # In case a prereq is mentioned twice, complain.
              if ( defined $p{$1} ) {
                  warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
              }
              $p{$1} = $2;
          }
          last;
      }
  }
  $self->{prereq_pm_detected}++;
  return $self->{prereq_pm} = \%p;
}

#-> sub CPAN::Distribution::test ;
sub test {
    my($self) = @_;
    $self->make;
    if ($CPAN::Signal){
      delete $self->{force_update};
      return;
    }
    $CPAN::Frontend->myprint("Running make test\n");
    if (my @prereq = $self->unsat_prereq){
      return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
    }
  EXCUSE: {
	my @e;
	exists $self->{make} or exists $self->{later} or push @e,
	"Make had some problems, maybe interrupted? Won't test";

	exists $self->{'make'} and
	    $self->{'make'} eq 'NO' and
		push @e, "Can't test without successful make";

	exists $self->{build_dir} or push @e, "Has no own directory";
        $self->{badtestcnt} ||= 0;
        $self->{badtestcnt} > 0 and
            push @e, "Won't repeat unsuccessful test during this command";

        exists $self->{later} and length($self->{later}) and
            push @e, $self->{later};

	$CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
    }
    chdir $self->{'build_dir'} or
	Carp::croak("Couldn't chdir to $self->{'build_dir'}");
    $self->debug("Changed directory to $self->{'build_dir'}")
	if $CPAN::DEBUG;

    if ($^O eq 'MacOS') {
        Mac::BuildTools::make_test($self);
        return;
    }

    my $system = join " ", $CPAN::Config->{'make'}, "test";
    if (system($system) == 0) {
	 $CPAN::Frontend->myprint("  $system -- OK\n");
	 $self->{make_test} = "YES";
    } else {
	 $self->{make_test} = "NO";
         $self->{badtestcnt}++;
	 $CPAN::Frontend->myprint("  $system -- NOT OK\n");
    }
}

#-> sub CPAN::Distribution::clean ;
sub clean {
    my($self) = @_;
    $CPAN::Frontend->myprint("Running make clean\n");
  EXCUSE: {
	my @e;
        exists $self->{make_clean} and $self->{make_clean} eq "YES" and
            push @e, "make clean already called once";
	exists $self->{build_dir} or push @e, "Has no own directory";
	$CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
    }
    chdir $self->{'build_dir'} or
	Carp::croak("Couldn't chdir to $self->{'build_dir'}");
    $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;

    if ($^O eq 'MacOS') {
        Mac::BuildTools::make_clean($self);
        return;
    }

    my $system = join " ", $CPAN::Config->{'make'}, "clean";
    if (system($system) == 0) {
      $CPAN::Frontend->myprint("  $system -- OK\n");

      # $self->force;

      # Jost Krieger pointed out that this "force" was wrong because
      # it has the effect that the next "install" on this distribution
      # will untar everything again. Instead we should bring the
      # object's state back to where it is after untarring.

      delete $self->{force_update};
      delete $self->{install};
      delete $self->{writemakefile};
      delete $self->{make};
      delete $self->{make_test}; # no matter if yes or no, tests must be redone
      $self->{make_clean} = "YES";

    } else {
      # Hmmm, what to do if make clean failed?

      $CPAN::Frontend->myprint(qq{  $system -- NOT OK

make clean did not succeed, marking directory as unusable for further work.
});
      $self->force("make"); # so that this directory won't be used again

    }
}

#-> sub CPAN::Distribution::install ;
sub install {
    my($self) = @_;
    $self->test;
    if ($CPAN::Signal){
      delete $self->{force_update};
      return;
    }
    $CPAN::Frontend->myprint("Running make install\n");
  EXCUSE: {
	my @e;
	exists $self->{build_dir} or push @e, "Has no own directory";

	exists $self->{make} or exists $self->{later} or push @e,
	"Make had some problems, maybe interrupted? Won't install";

	exists $self->{'make'} and
	    $self->{'make'} eq 'NO' and
		push @e, "make had returned bad status, install seems impossible";

	push @e, "make test had returned bad status, ".
	    "won't install without force"
	    if exists $self->{'make_test'} and
	    $self->{'make_test'} eq 'NO' and
	    ! $self->{'force_update'};

	exists $self->{'install'} and push @e,
	$self->{'install'} eq "YES" ?
	    "Already done" : "Already tried without success";

        exists $self->{later} and length($self->{later}) and
            push @e, $self->{later};

	$CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
    }
    chdir $self->{'build_dir'} or
	Carp::croak("Couldn't chdir to $self->{'build_dir'}");
    $self->debug("Changed directory to $self->{'build_dir'}")
	if $CPAN::DEBUG;

    if ($^O eq 'MacOS') {
        Mac::BuildTools::make_install($self);
        return;
    }

    my $system = join(" ", $CPAN::Config->{'make'},
		      "install", $CPAN::Config->{make_install_arg});
    my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
    my($pipe) = FileHandle->new("$system $stderr |");
    my($makeout) = "";
    while (<$pipe>){
	$CPAN::Frontend->myprint($_);
	$makeout .= $_;
    }
    $pipe->close;
    if ($?==0) {
	 $CPAN::Frontend->myprint("  $system -- OK\n");
	 return $self->{'install'} = "YES";
    } else {
	 $self->{'install'} = "NO";
	 $CPAN::Frontend->myprint("  $system -- NOT OK\n");
	 if ($makeout =~ /permission/s && $> > 0) {
	     $CPAN::Frontend->myprint(qq{    You may have to su }.
				      qq{to root to install the package\n});
	 }
    }
    delete $self->{force_update};
}

#-> sub CPAN::Distribution::dir ;
sub dir {
    shift->{'build_dir'};
}

package CPAN::Bundle;

sub undelay {
    my $self = shift;
    delete $self->{later};
    for my $c ( $self->contains ) {
        my $obj = CPAN::Shell->expandany($c) or next;
        $obj->undelay;
    }
}

#-> sub CPAN::Bundle::color_cmd_tmps ;
sub color_cmd_tmps {
    my($self) = shift;
    my($depth) = shift || 0;
    my($color) = shift || 0;
    # a module needs to recurse to its cpan_file, a distribution needs
    # to recurse into its prereq_pms, a bundle needs to recurse into its modules

    return if exists $self->{incommandcolor}
        && $self->{incommandcolor}==$color;
    $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
                                   "color_cmd_tmps depth[%s] self[%s] id[%s]",
                                   $depth,
                                   $self,
                                   $self->id
                                  )) if $depth>=100;
    ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;

    for my $c ( $self->contains ) {
        my $obj = CPAN::Shell->expandany($c) or next;
        CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
        $obj->color_cmd_tmps($depth+1,$color);
    }
    if ($color==0) {
        delete $self->{badtestcnt};
    }
    $self->{incommandcolor} = $color;
}

#-> sub CPAN::Bundle::as_string ;
sub as_string {
    my($self) = @_;
    $self->contains;
    # following line must be "=", not "||=" because we have a moving target
    $self->{INST_VERSION} = $self->inst_version;
    return $self->SUPER::as_string;
}

#-> sub CPAN::Bundle::contains ;
sub contains {
    my($self) = @_;
    my($inst_file) = $self->inst_file || "";
    my($id) = $self->id;
    $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
    unless ($inst_file) {
        # Try to get at it in the cpan directory
        $self->debug("no inst_file") if $CPAN::DEBUG;
        my $cpan_file;
        $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
              $cpan_file = $self->cpan_file;
        if ($cpan_file eq "N/A") {
            $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
  Maybe stale symlink? Maybe removed during session? Giving up.\n");
        }
        my $dist = $CPAN::META->instance('CPAN::Distribution',
                                         $self->cpan_file);
        $dist->get;
        $self->debug($dist->as_string) if $CPAN::DEBUG;
        my($todir) = $CPAN::Config->{'cpan_home'};
        my(@me,$from,$to,$me);
        @me = split /::/, $self->id;
        $me[-1] .= ".pm";
        $me = MM->catfile(@me);
        $from = $self->find_bundle_file($dist->{'build_dir'},$me);
        $to = MM->catfile($todir,$me);
        File::Path::mkpath(File::Basename::dirname($to));
        File::Copy::copy($from, $to)
              or Carp::confess("Couldn't copy $from to $to: $!");
        $inst_file = $to;
    }
    my @result;
    my $fh = FileHandle->new;
    local $/ = "\n";
    open($fh,$inst_file) or die "Could not open '$inst_file': $!";
    my $in_cont = 0;
    $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
    while (<$fh>) {
        $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
            m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
        next unless $in_cont;
        next if /^=/;
        s/\#.*//;
        next if /^\s+$/;
        chomp;
        push @result, (split " ", $_, 2)[0];
    }
    close $fh;
    delete $self->{STATUS};
    $self->{CONTAINS} = \@result;
    $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
    unless (@result) {
        $CPAN::Frontend->mywarn(qq{
The bundle file "$inst_file" may be a broken
bundlefile. It seems not to contain any bundle definition.
Please check the file and if it is bogus, please delete it.
Sorry for the inconvenience.
});
    }
    @result;
}

#-> sub CPAN::Bundle::find_bundle_file
sub find_bundle_file {
    my($self,$where,$what) = @_;
    $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
###    my $bu = MM->catfile($where,$what);
###    return $bu if -f $bu;
    my $manifest = MM->catfile($where,"MANIFEST");
    unless (-f $manifest) {
	require ExtUtils::Manifest;
	my $cwd = CPAN::anycwd();
	chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
	ExtUtils::Manifest::mkmanifest();
	chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
    }
    my $fh = FileHandle->new($manifest)
	or Carp::croak("Couldn't open $manifest: $!");
    local($/) = "\n";
    my $what2 = $what;
    if ($^O eq 'MacOS') {
      $what =~ s/^://;
      $what =~ tr|:|/|;
      $what2 =~ s/:Bundle://;
      $what2 =~ tr|:|/|;
    } else {
	$what2 =~ s|Bundle[/\\]||;
    }
    my $bu;
    while (<$fh>) {
	next if /^\s*\#/;
	my($file) = /(\S+)/;
	if ($file =~ m|\Q$what\E$|) {
	    $bu = $file;
	    # return MM->catfile($where,$bu); # bad
	    last;
	}
	# retry if she managed to
	# have no Bundle directory
	$bu = $file if $file =~ m|\Q$what2\E$|;
    }
    $bu =~ tr|/|:| if $^O eq 'MacOS';
    return MM->catfile($where, $bu) if $bu;
    Carp::croak("Couldn't find a Bundle file in $where");
}

# needs to work quite differently from Module::inst_file because of
# cpan_home/Bundle/ directory and the possibility that we have
# shadowing effect. As it makes no sense to take the first in @INC for
# Bundles, we parse them all for $VERSION and take the newest.

#-> sub CPAN::Bundle::inst_file ;
sub inst_file {
    my($self) = @_;
    my($inst_file);
    my(@me);
    @me = split /::/, $self->id;
    $me[-1] .= ".pm";
    my($incdir,$bestv);
    foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
        my $bfile = MM->catfile($incdir, @me);
        CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
        next unless -f $bfile;
        my $foundv = MM->parse_version($bfile);
        if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
            $self->{INST_FILE} = $bfile;
            $self->{INST_VERSION} = $bestv = $foundv;
        }
    }
    $self->{INST_FILE};
}

#-> sub CPAN::Bundle::inst_version ;
sub inst_version {
    my($self) = @_;
    $self->inst_file; # finds INST_VERSION as side effect
    $self->{INST_VERSION};
}

#-> sub CPAN::Bundle::rematein ;
sub rematein {
    my($self,$meth) = @_;
    $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
    my($id) = $self->id;
    Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
	unless $self->inst_file || $self->cpan_file;
    my($s,%fail);
    for $s ($self->contains) {
	my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
	    $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
	if ($type eq 'CPAN::Distribution') {
	    $CPAN::Frontend->mywarn(qq{
The Bundle }.$self->id.qq{ contains
explicitly a file $s.
});
	    sleep 3;
	}
	# possibly noisy action:
        $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
	my $obj = $CPAN::META->instance($type,$s);
	$obj->$meth();
        if ($obj->isa(CPAN::Bundle)
            &&
            exists $obj->{install_failed}
            &&
            ref($obj->{install_failed}) eq "HASH"
           ) {
          for (keys %{$obj->{install_failed}}) {
            $self->{install_failed}{$_} = undef; # propagate faiure up
                                                 # to me in a
                                                 # recursive call
            $fail{$s} = 1; # the bundle itself may have succeeded but
                           # not all children
          }
        } else {
          my $success;
          $success = $obj->can("uptodate") ? $obj->uptodate : 0;
          $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
          if ($success) {
            delete $self->{install_failed}{$s};
          } else {
            $fail{$s} = 1;
          }
        }
    }

    # recap with less noise
    if ( $meth eq "install" ) {
	if (%fail) {
	    require Text::Wrap;
	    my $raw = sprintf(qq{Bundle summary:
The following items in bundle %s had installation problems:},
			      $self->id
			     );
	    $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
	    $CPAN::Frontend->myprint("\n");
	    my $paragraph = "";
            my %reported;
	    for $s ($self->contains) {
              if ($fail{$s}){
		$paragraph .= "$s ";
                $self->{install_failed}{$s} = undef;
                $reported{$s} = undef;
              }
	    }
            my $report_propagated;
            for $s (sort keys %{$self->{install_failed}}) {
              next if exists $reported{$s};
              $paragraph .= "and the following items had problems
during recursive bundle calls: " unless $report_propagated++;
              $paragraph .= "$s ";
            }
	    $CPAN::Frontend->myprint(Text::Wrap::fill("  ","  ",$paragraph));
	    $CPAN::Frontend->myprint("\n");
	} else {
	    $self->{'install'} = 'YES';
	}
    }
}

#sub CPAN::Bundle::xs_file
sub xs_file {
    # If a bundle contains another that contains an xs_file we have
    # here, we just don't bother I suppose
    return 0;
}

#-> sub CPAN::Bundle::force ;
sub force   { shift->rematein('force',@_); }
#-> sub CPAN::Bundle::get ;
sub get     { shift->rematein('get',@_); }
#-> sub CPAN::Bundle::make ;
sub make    { shift->rematein('make',@_); }
#-> sub CPAN::Bundle::test ;
sub test    {
    my $self = shift;
    $self->{badtestcnt} ||= 0;
    $self->rematein('test',@_);
}
#-> sub CPAN::Bundle::install ;
sub install {
  my $self = shift;
  $self->rematein('install',@_);
}
#-> sub CPAN::Bundle::clean ;
sub clean   { shift->rematein('clean',@_); }

#-> sub CPAN::Bundle::uptodate ;
sub uptodate {
    my($self) = @_;
    return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
    my $c;
    foreach $c ($self->contains) {
        my $obj = CPAN::Shell->expandany($c);
        return 0 unless $obj->uptodate;
    }
    return 1;
}

#-> sub CPAN::Bundle::readme ;
sub readme  {
    my($self) = @_;
    my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
No File found for bundle } . $self->id . qq{\n}), return;
    $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
    $CPAN::META->instance('CPAN::Distribution',$file)->readme;
}

package CPAN::Module;

# Accessors
# sub cpan_userid { shift->{RO}{CPAN_USERID} }
sub userid {
    my $self = shift;
    return unless exists $self->{RO}; # should never happen
    return $self->{RO}{CPAN_USERID} || $self->{RO}{userid};
}
sub description { shift->{RO}{description} }

sub undelay {
    my $self = shift;
    delete $self->{later};
    if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
        $dist->undelay;
    }
}

#-> sub CPAN::Module::color_cmd_tmps ;
sub color_cmd_tmps {
    my($self) = shift;
    my($depth) = shift || 0;
    my($color) = shift || 0;
    # a module needs to recurse to its cpan_file

    return if exists $self->{incommandcolor}
        && $self->{incommandcolor}==$color;
    $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
                                   "color_cmd_tmps depth[%s] self[%s] id[%s]",
                                   $depth,
                                   $self,
                                   $self->id
                                  )) if $depth>=100;
    ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;

    if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
        $dist->color_cmd_tmps($depth+1,$color);
    }
    if ($color==0) {
        delete $self->{badtestcnt};
    }
    $self->{incommandcolor} = $color;
}

#-> sub CPAN::Module::as_glimpse ;
sub as_glimpse {
    my($self) = @_;
    my(@m);
    my $class = ref($self);
    $class =~ s/^CPAN:://;
    my $color_on = "";
    my $color_off = "";
    if (
        $CPAN::Shell::COLOR_REGISTERED
        &&
        $CPAN::META->has_inst("Term::ANSIColor")
        &&
        $self->{RO}{description}
       ) {
        $color_on = Term::ANSIColor::color("green");
        $color_off = Term::ANSIColor::color("reset");
    }
    push @m, sprintf("%-15s %s%-15s%s (%s)\n",
                     $class,
                     $color_on,
                     $self->id,
                     $color_off,
		     $self->cpan_file);
    join "", @m;
}

#-> sub CPAN::Module::as_string ;
sub as_string {
    my($self) = @_;
    my(@m);
    CPAN->debug($self) if $CPAN::DEBUG;
    my $class = ref($self);
    $class =~ s/^CPAN:://;
    local($^W) = 0;
    push @m, $class, " id = $self->{ID}\n";
    my $sprintf = "    %-12s %s\n";
    push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
	if $self->description;
    my $sprintf2 = "    %-12s %s (%s)\n";
    my($userid);
    if ($userid = $self->cpan_userid || $self->userid){
	my $author;
	if ($author = CPAN::Shell->expand('Author',$userid)) {
	  my $email = "";
	  my $m; # old perls
	  if ($m = $author->email) {
            $email = " <$m>";
          }
	  push @m, sprintf(
			   $sprintf2,
			   'CPAN_USERID',
			   $userid,
			   $author->fullname . $email
			  );
	}
    }
    push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
	if $self->cpan_version;
    push @m, sprintf($sprintf, 'CPAN_FILE', $self->cpan_file)
	if $self->cpan_file;
    my $sprintf3 = "    %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
    my(%statd,%stats,%statl,%stati);
    @statd{qw,? i c a b R M S,} = qw,unknown idea
	pre-alpha alpha beta released mature standard,;
    @stats{qw,? m d u n,}       = qw,unknown mailing-list
	developer comp.lang.perl.* none,;
    @statl{qw,? p c + o h,}       = qw,unknown perl C C++ other hybrid,;
    @stati{qw,? f r O h,}         = qw,unknown functions
	references+ties object-oriented hybrid,;
    $statd{' '} = 'unknown';
    $stats{' '} = 'unknown';
    $statl{' '} = 'unknown';
    $stati{' '} = 'unknown';
    push @m, sprintf(
		     $sprintf3,
		     'DSLI_STATUS',
		     $self->{RO}{statd},
		     $self->{RO}{stats},
		     $self->{RO}{statl},
		     $self->{RO}{stati},
		     $statd{$self->{RO}{statd}},
		     $stats{$self->{RO}{stats}},
		     $statl{$self->{RO}{statl}},
		     $stati{$self->{RO}{stati}}
		    ) if $self->{RO}{statd};
    my $local_file = $self->inst_file;
    unless ($self->{MANPAGE}) {
        if ($local_file) {
            $self->{MANPAGE} = $self->manpage_headline($local_file);
        } else {
            # If we have already untarred it, we should look there
            my $dist = $CPAN::META->instance('CPAN::Distribution',
                                             $self->cpan_file);
            # warn "dist[$dist]";
            # mff=manifest file; mfh=manifest handle
            my($mff,$mfh);
            if (
                $dist->{build_dir}
                and
                (-f  ($mff = MM->catfile($dist->{build_dir}, "MANIFEST")))
                and
                $mfh = FileHandle->new($mff)
               ) {
                CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
                my $lfre = $self->id; # local file RE
                $lfre =~ s/::/./g;
                $lfre .= "\\.pm\$";
                my($lfl); # local file file
                local $/ = "\n";
                my(@mflines) = <$mfh>;
                for (@mflines) {
                    s/^\s+//;
                    s/\s.*//s;
                }
                while (length($lfre)>5 and !$lfl) {
                    ($lfl) = grep /$lfre/, @mflines;
                    CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
                    $lfre =~ s/.+?\.//;
                }
                $lfl =~ s/\s.*//; # remove comments
                $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
                my $lfl_abs = MM->catfile($dist->{build_dir},$lfl);
                # warn "lfl_abs[$lfl_abs]";
                if (-f $lfl_abs) {
                    $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
                }
            }
        }
    }
    my($item);
    for $item (qw/MANPAGE/) {
	push @m, sprintf($sprintf, $item, $self->{$item})
	    if exists $self->{$item};
    }
    for $item (qw/CONTAINS/) {
	push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
	    if exists $self->{$item} && @{$self->{$item}};
    }
    push @m, sprintf($sprintf, 'INST_FILE',
		     $local_file || "(not installed)");
    push @m, sprintf($sprintf, 'INST_VERSION',
		     $self->inst_version) if $local_file;
    join "", @m, "\n";
}

sub manpage_headline {
  my($self,$local_file) = @_;
  my(@local_file) = $local_file;
  $local_file =~ s/\.pm(?!\n)\Z/.pod/;
  push @local_file, $local_file;
  my(@result,$locf);
  for $locf (@local_file) {
    next unless -f $locf;
    my $fh = FileHandle->new($locf)
	or $Carp::Frontend->mydie("Couldn't open $locf: $!");
    my $inpod = 0;
    local $/ = "\n";
    while (<$fh>) {
      $inpod = m/^=(?!head1\s+NAME)/ ? 0 :
	  m/^=head1\s+NAME/ ? 1 : $inpod;
      next unless $inpod;
      next if /^=/;
      next if /^\s+$/;
      chomp;
      push @result, $_;
    }
    close $fh;
    last if @result;
  }
  join " ", @result;
}

#-> sub CPAN::Module::cpan_file ;
# Note: also inherited by CPAN::Bundle
sub cpan_file {
    my $self = shift;
    CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
    unless (defined $self->{RO}{CPAN_FILE}) {
	CPAN::Index->reload;
    }
    if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
	return $self->{RO}{CPAN_FILE};
    } else {
        my $userid = $self->userid;
        if ( $userid ) {
            if ($CPAN::META->exists("CPAN::Author",$userid)) {
                my $author = $CPAN::META->instance("CPAN::Author",
                                                   $userid);
                my $fullname = $author->fullname;
                my $email = $author->email;
                unless (defined $fullname && defined $email) {
                    return sprintf("Contact Author %s",
                                   $userid,
                                  );
                }
                return "Contact Author $fullname <$email>";
            } else {
                return "UserID $userid";
            }
        } else {
            return "N/A";
        }
    }
}

#-> sub CPAN::Module::cpan_version ;
sub cpan_version {
    my $self = shift;

    $self->{RO}{CPAN_VERSION} = 'undef'
	unless defined $self->{RO}{CPAN_VERSION};
    # I believe this is always a bug in the index and should be reported
    # as such, but usually I find out such an error and do not want to
    # provoke too many bugreports

    $self->{RO}{CPAN_VERSION};
}

#-> sub CPAN::Module::force ;
sub force {
    my($self) = @_;
    $self->{'force_update'}++;
}

#-> sub CPAN::Module::rematein ;
sub rematein {
    my($self,$meth) = @_;
    $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
                                     $meth,
                                     $self->id));
    my $cpan_file = $self->cpan_file;
    if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
      $CPAN::Frontend->mywarn(sprintf qq{
  The module %s isn\'t available on CPAN.

  Either the module has not yet been uploaded to CPAN, or it is
  temporary unavailable. Please contact the author to find out
  more about the status. Try 'i %s'.
},
			      $self->id,
			      $self->id,
			     );
      return;
    }
    my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
    $pack->called_for($self->id);
    $pack->force($meth) if exists $self->{'force_update'};
    $pack->$meth();
    $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
    delete $self->{'force_update'};
}

#-> sub CPAN::Module::readme ;
sub readme { shift->rematein('readme') }
#-> sub CPAN::Module::look ;
sub look { shift->rematein('look') }
#-> sub CPAN::Module::cvs_import ;
sub cvs_import { shift->rematein('cvs_import') }
#-> sub CPAN::Module::get ;
sub get    { shift->rematein('get',@_); }
#-> sub CPAN::Module::make ;
sub make   {
    my $self = shift;
    $self->rematein('make');
}
#-> sub CPAN::Module::test ;
sub test   {
    my $self = shift;
    $self->{badtestcnt} ||= 0;
    $self->rematein('test',@_);
}
#-> sub CPAN::Module::uptodate ;
sub uptodate {
    my($self) = @_;
    my($latest) = $self->cpan_version;
    $latest ||= 0;
    my($inst_file) = $self->inst_file;
    my($have) = 0;
    if (defined $inst_file) {
	$have = $self->inst_version;
    }
    local($^W)=0;
    if ($inst_file
	&&
	! CPAN::Version->vgt($latest, $have)
       ) {
        CPAN->debug("returning uptodate. inst_file[$inst_file] ".
                    "latest[$latest] have[$have]") if $CPAN::DEBUG;
        return 1;
    }
    return;
}
#-> sub CPAN::Module::install ;
sub install {
    my($self) = @_;
    my($doit) = 0;
    if ($self->uptodate
	&&
	not exists $self->{'force_update'}
       ) {
	$CPAN::Frontend->myprint( $self->id. " is up to date.\n");
    } else {
	$doit = 1;
    }
    $self->rematein('install') if $doit;
}
#-> sub CPAN::Module::clean ;
sub clean  { shift->rematein('clean') }

#-> sub CPAN::Module::inst_file ;
sub inst_file {
    my($self) = @_;
    my($dir,@packpath);
    @packpath = split /::/, $self->{ID};
    $packpath[-1] .= ".pm";
    foreach $dir (@INC) {
	my $pmfile = MM->catfile($dir,@packpath);
	if (-f $pmfile){
	    return $pmfile;
	}
    }
    return;
}

#-> sub CPAN::Module::xs_file ;
sub xs_file {
    my($self) = @_;
    my($dir,@packpath);
    @packpath = split /::/, $self->{ID};
    push @packpath, $packpath[-1];
    $packpath[-1] .= "." . $Config::Config{'dlext'};
    foreach $dir (@INC) {
	my $xsfile = MM->catfile($dir,'auto',@packpath);
	if (-f $xsfile){
	    return $xsfile;
	}
    }
    return;
}

#-> sub CPAN::Module::inst_version ;
sub inst_version {
    my($self) = @_;
    my $parsefile = $self->inst_file or return;
    local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
    my $have;

    # there was a bug in 5.6.0 that let lots of unini warnings out of
    # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
    # the following workaround after 5.6.1 is out.
    local($SIG{__WARN__}) =  sub { my $w = shift;
                                   return if $w =~ /uninitialized/i;
                                   warn $w;
                                 };

    $have = MM->parse_version($parsefile) || "undef";
    $have =~ s/^ //; # since the %vd hack these two lines here are needed
    $have =~ s/ $//; # trailing whitespace happens all the time

    # My thoughts about why %vd processing should happen here

    # Alt1 maintain it as string with leading v:
    # read index files     do nothing
    # compare it           use utility for compare
    # print it             do nothing

    # Alt2 maintain it as what is is
    # read index files     convert
    # compare it           use utility because there's still a ">" vs "gt" issue
    # print it             use CPAN::Version for print

    # Seems cleaner to hold it in memory as a string starting with a "v"

    # If the author of this module made a mistake and wrote a quoted
    # "v1.13" instead of v1.13, we simply leave it at that with the
    # effect that *we* will treat it like a v-tring while the rest of
    # perl won't. Seems sensible when we consider that any action we
    # could take now would just add complexity.

    $have = CPAN::Version->readable($have);

    $have =~ s/\s*//g; # stringify to float around floating point issues
    $have; # no stringify needed, \s* above matches always
}

package CPAN::Tarzip;

# CPAN::Tarzip::gzip
sub gzip {
  my($class,$read,$write) = @_;
  if ($CPAN::META->has_inst("Compress::Zlib")) {
    my($buffer,$fhw);
    $fhw = FileHandle->new($read)
	or $CPAN::Frontend->mydie("Could not open $read: $!");
    my $gz = Compress::Zlib::gzopen($write, "wb")
	or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
    $gz->gzwrite($buffer)
	while read($fhw,$buffer,4096) > 0 ;
    $gz->gzclose() ;
    $fhw->close;
    return 1;
  } else {
    system("$CPAN::Config->{gzip} -c $read > $write")==0;
  }
}


# CPAN::Tarzip::gunzip
sub gunzip {
  my($class,$read,$write) = @_;
  if ($CPAN::META->has_inst("Compress::Zlib")) {
    my($buffer,$fhw);
    $fhw = FileHandle->new(">$write")
	or $CPAN::Frontend->mydie("Could not open >$write: $!");
    my $gz = Compress::Zlib::gzopen($read, "rb")
	or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
    $fhw->print($buffer)
	while $gz->gzread($buffer) > 0 ;
    $CPAN::Frontend->mydie("Error reading from $read: $!\n")
	if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
    $gz->gzclose() ;
    $fhw->close;
    return 1;
  } else {
    system("$CPAN::Config->{gzip} -dc $read > $write")==0;
  }
}


# CPAN::Tarzip::gtest
sub gtest {
  my($class,$read) = @_;
  # After I had reread the documentation in zlib.h, I discovered that
  # uncompressed files do not lead to an gzerror (anymore?).
  if ( $CPAN::META->has_inst("Compress::Zlib") ) {
    my($buffer,$len);
    $len = 0;
    my $gz = Compress::Zlib::gzopen($read, "rb")
	or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
                                          $read,
                                          $Compress::Zlib::gzerrno));
    while ($gz->gzread($buffer) > 0 ){
        $len += length($buffer);
        $buffer = "";
    }
    my $err = $gz->gzerror;
    my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
    if ($len == -s $read){
        $success = 0;
        CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
    }
    $gz->gzclose();
    CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
    return $success;
  } else {
      return system("$CPAN::Config->{gzip} -dt $read")==0;
  }
}


# CPAN::Tarzip::TIEHANDLE
sub TIEHANDLE {
  my($class,$file) = @_;
  my $ret;
  $class->debug("file[$file]");
  if ($CPAN::META->has_inst("Compress::Zlib")) {
    my $gz = Compress::Zlib::gzopen($file,"rb") or
	die "Could not gzopen $file";
    $ret = bless {GZ => $gz}, $class;
  } else {
    my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |";
    my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
    binmode $fh;
    $ret = bless {FH => $fh}, $class;
  }
  $ret;
}


# CPAN::Tarzip::READLINE
sub READLINE {
  my($self) = @_;
  if (exists $self->{GZ}) {
    my $gz = $self->{GZ};
    my($line,$bytesread);
    $bytesread = $gz->gzreadline($line);
    return undef if $bytesread <= 0;
    return $line;
  } else {
    my $fh = $self->{FH};
    return scalar <$fh>;
  }
}


# CPAN::Tarzip::READ
sub READ {
  my($self,$ref,$length,$offset) = @_;
  die "read with offset not implemented" if defined $offset;
  if (exists $self->{GZ}) {
    my $gz = $self->{GZ};
    my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
    return $byteread;
  } else {
    my $fh = $self->{FH};
    return read($fh,$$ref,$length);
  }
}


# CPAN::Tarzip::DESTROY
sub DESTROY {
    my($self) = @_;
    if (exists $self->{GZ}) {
        my $gz = $self->{GZ};
        $gz->gzclose() if defined $gz; # hard to say if it is allowed
                                       # to be undef ever. AK, 2000-09
    } else {
        my $fh = $self->{FH};
        $fh->close if defined $fh;
    }
    undef $self;
}


# CPAN::Tarzip::untar
sub untar {
  my($class,$file) = @_;
  my($prefer) = 0;

  if (0) { # makes changing order easier
  } elsif ($BUGHUNTING){
      $prefer=2;
  } elsif (MM->maybe_command($CPAN::Config->{gzip})
           &&
           MM->maybe_command($CPAN::Config->{'tar'})) {
      # should be default until Archive::Tar is fixed
      $prefer = 1;
  } elsif (
           $CPAN::META->has_inst("Archive::Tar")
           &&
           $CPAN::META->has_inst("Compress::Zlib") ) {
      $prefer = 2;
  } else {
    $CPAN::Frontend->mydie(qq{
CPAN.pm needs either both external programs tar and gzip installed or
both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
is available. Can\'t continue.
});
  }
  if ($prefer==1) { # 1 => external gzip+tar
    my($system);
    my $is_compressed = $class->gtest($file);
    if ($is_compressed) {
        $system = "$CPAN::Config->{gzip} --decompress --stdout " .
            "< $file | $CPAN::Config->{tar} xvf -";
    } else {
        $system = "$CPAN::Config->{tar} xvf $file";
    }
    if (system($system) != 0) {
        # people find the most curious tar binaries that cannot handle
        # pipes
        if ($is_compressed) {
            (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
            if (CPAN::Tarzip->gunzip($file, $ungzf)) {
                $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
            } else {
                $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
            }
            $file = $ungzf;
        }
        $system = "$CPAN::Config->{tar} xvf $file";
        $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
        if (system($system)==0) {
            $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
        } else {
            $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
        }
        return 1;
    } else {
        return 1;
    }
  } elsif ($prefer==2) { # 2 => modules
    my $tar = Archive::Tar->new($file,1);
    my $af; # archive file
    my @af;
    if ($BUGHUNTING) {
        # RCS 1.337 had this code, it turned out unacceptable slow but
        # it revealed a bug in Archive::Tar. Code is only here to hunt
        # the bug again. It should never be enabled in published code.
        # GDGraph3d-0.53 was an interesting case according to Larry
        # Virden.
        warn(">>>Bughunting code enabled<<< " x 20);
        for $af ($tar->list_files) {
            if ($af =~ m!^(/|\.\./)!) {
                $CPAN::Frontend->mydie("ALERT: Archive contains ".
                                       "illegal member [$af]");
            }
            $CPAN::Frontend->myprint("$af\n");
            $tar->extract($af); # slow but effective for finding the bug
            return if $CPAN::Signal;
        }
    } else {
        for $af ($tar->list_files) {
            if ($af =~ m!^(/|\.\./)!) {
                $CPAN::Frontend->mydie("ALERT: Archive contains ".
                                       "illegal member [$af]");
            }
            $CPAN::Frontend->myprint("$af\n");
            push @af, $af;
            return if $CPAN::Signal;
        }
        $tar->extract(@af);
    }

    Mac::BuildTools::convert_files([$tar->list_files], 1)
        if ($^O eq 'MacOS');

    return 1;
  }
}

sub unzip {
    my($class,$file) = @_;
    if ($CPAN::META->has_inst("Archive::Zip")) {
        # blueprint of the code from Archive::Zip::Tree::extractTree();
        my $zip = Archive::Zip->new();
        my $status;
        $status = $zip->read($file);
        die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
        $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
        my @members = $zip->members();
        for my $member ( @members ) {
            my $af = $member->fileName();
            if ($af =~ m!^(/|\.\./)!) {
                $CPAN::Frontend->mydie("ALERT: Archive contains ".
                                       "illegal member [$af]");
            }
            my $status = $member->extractToFileNamed( $af );
            $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
            die "Extracting of file[$af] from zipfile[$file] failed\n" if
                $status != Archive::Zip::AZ_OK();
            return if $CPAN::Signal;
        }
        return 1;
    } else {
        my $unzip = $CPAN::Config->{unzip} or
            $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
        my @system = ($unzip, $file);
        return system(@system) == 0;
    }
}


package CPAN::Version;
# CPAN::Version::vcmp courtesy Jost Krieger
sub vcmp {
  my($self,$l,$r) = @_;
  local($^W) = 0;
  CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;

  return 0 if $l eq $r; # short circuit for quicker success

  if ($l=~/^v/ <=> $r=~/^v/) {
      for ($l,$r) {
          next if /^v/;
          $_ = $self->float2vv($_);
      }
  }

  return
      ($l ne "undef") <=> ($r ne "undef") ||
          ($] >= 5.006 &&
           $l =~ /^v/ &&
           $r =~ /^v/ &&
           $self->vstring($l) cmp $self->vstring($r)) ||
               $l <=> $r ||
                   $l cmp $r;
}

sub vgt {
  my($self,$l,$r) = @_;
  $self->vcmp($l,$r) > 0;
}

sub vstring {
  my($self,$n) = @_;
  $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
  pack "U*", split /\./, $n;
}

# vv => visible vstring
sub float2vv {
    my($self,$n) = @_;
    my($rev) = int($n);
    $rev ||= 0;
    my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
                                          # architecture influence
    $mantissa ||= 0;
    $mantissa .= "0" while length($mantissa)%3;
    my $ret = "v" . $rev;
    while ($mantissa) {
        $mantissa =~ s/(\d{1,3})// or
            die "Panic: length>0 but not a digit? mantissa[$mantissa]";
        $ret .= ".".int($1);
    }
    # warn "n[$n]ret[$ret]";
    $ret;
}

sub readable {
  my($self,$n) = @_;
  $n =~ /^([\w\-\+\.]+)/;

  return $1 if defined $1 && length($1)>0;
  # if the first user reaches version v43, he will be treated as "+".
  # We'll have to decide about a new rule here then, depending on what
  # will be the prevailing versioning behavior then.

  if ($] < 5.006) { # or whenever v-strings were introduced
    # we get them wrong anyway, whatever we do, because 5.005 will
    # have already interpreted 0.2.4 to be "0.24". So even if he
    # indexer sends us something like "v0.2.4" we compare wrongly.

    # And if they say v1.2, then the old perl takes it as "v12"

    $CPAN::Frontend->mywarn("Suspicious version string seen [$n]");
    return $n;
  }
  my $better = sprintf "v%vd", $n;
  CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
  return $better;
}

package CPAN;

1;

__END__

=head1 NAME

CPAN - query, download and build perl modules from CPAN sites

=head1 SYNOPSIS

Interactive mode:

  perl -MCPAN -e shell;

Batch mode:

  use CPAN;

  autobundle, clean, install, make, recompile, test

=head1 DESCRIPTION

The CPAN module is designed to automate the make and install of perl
modules and extensions. It includes some searching capabilities and
knows how to use Net::FTP or LWP (or lynx or an external ftp client)
to fetch the raw data from the net.

Modules are fetched from one or more of the mirrored CPAN
(Comprehensive Perl Archive Network) sites and unpacked in a dedicated
directory.

The CPAN module also supports the concept of named and versioned
I<bundles> of modules. Bundles simplify the handling of sets of
related modules. See Bundles below.

The package contains a session manager and a cache manager. There is
no status retained between sessions. The session manager keeps track
of what has been fetched, built and installed in the current
session. The cache manager keeps track of the disk space occupied by
the make processes and deletes excess space according to a simple FIFO
mechanism.

For extended searching capabilities there's a plugin for CPAN available,
L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
that indexes all documents available in CPAN authors directories. If
C<CPAN::WAIT> is installed on your system, the interactive shell of
CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
which send queries to the WAIT server that has been configured for your
installation.

All other methods provided are accessible in a programmer style and in an
interactive shell style.

=head2 Interactive Mode

The interactive mode is entered by running

    perl -MCPAN -e shell

which puts you into a readline interface. You will have the most fun if
you install Term::ReadKey and Term::ReadLine to enjoy both history and
command completion.

Once you are on the command line, type 'h' and the rest should be
self-explanatory.

The function call C<shell> takes two optional arguments, one is the
prompt, the second is the default initial command line (the latter
only works if a real ReadLine interface module is installed).

The most common uses of the interactive modes are

=over 2

=item Searching for authors, bundles, distribution files and modules

There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
for each of the four categories and another, C<i> for any of the
mentioned four. Each of the four entities is implemented as a class
with slightly differing methods for displaying an object.

Arguments you pass to these commands are either strings exactly matching
the identification string of an object or regular expressions that are
then matched case-insensitively against various attributes of the
objects. The parser recognizes a regular expression only if you
enclose it between two slashes.

The principle is that the number of found objects influences how an
item is displayed. If the search finds one item, the result is
displayed with the rather verbose method C<as_string>, but if we find
more than one, we display each object with the terse method
<as_glimpse>.

=item make, test, install, clean  modules or distributions

These commands take any number of arguments and investigate what is
necessary to perform the action. If the argument is a distribution
file name (recognized by embedded slashes), it is processed. If it is
a module, CPAN determines the distribution file in which this module
is included and processes that, following any dependencies named in
the module's Makefile.PL (this behavior is controlled by
I<prerequisites_policy>.)

Any C<make> or C<test> are run unconditionally. An

  install <distribution_file>

also is run unconditionally. But for

  install <module>

CPAN checks if an install is actually needed for it and prints
I<module up to date> in the case that the distribution file containing
the module doesn't need to be updated.

CPAN also keeps track of what it has done within the current session
and doesn't try to build a package a second time regardless if it
succeeded or not. The C<force> command takes as a first argument the
method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
command from scratch.

Example:

    cpan> install OpenGL
    OpenGL is up to date.
    cpan> force install OpenGL
    Running make
    OpenGL-0.4/
    OpenGL-0.4/COPYRIGHT
    [...]

A C<clean> command results in a

  make clean

being executed within the distribution file's working directory.

=item get, readme, look module or distribution

C<get> downloads a distribution file without further action. C<readme>
displays the README file of the associated distribution. C<Look> gets
and untars (if not yet done) the distribution file, changes to the
appropriate directory and opens a subshell process in that directory.

=item ls author

C<ls> lists all distribution files in and below an author's CPAN
directory. Only those files that contain modules are listed and if
there is more than one for any given module, only the most recent one
is listed.

=item Signals

CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
in the cpan-shell it is intended that you can press C<^C> anytime and
return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
to clean up and leave the shell loop. You can emulate the effect of a
SIGTERM by sending two consecutive SIGINTs, which usually means by
pressing C<^C> twice.

CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.

=back

=head2 CPAN::Shell

The commands that are available in the shell interface are methods in
the package CPAN::Shell. If you enter the shell command, all your
input is split by the Text::ParseWords::shellwords() routine which
acts like most shells do. The first word is being interpreted as the
method to be called and the rest of the words are treated as arguments
to this method. Continuation lines are supported if a line ends with a
literal backslash.

=head2 autobundle

C<autobundle> writes a bundle file into the
C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
a list of all modules that are both available from CPAN and currently
installed within @INC. The name of the bundle file is based on the
current date and a counter.

=head2 recompile

recompile() is a very special command in that it takes no argument and
runs the make/test/install cycle with brute force over all installed
dynamically loadable extensions (aka XS modules) with 'force' in
effect. The primary purpose of this command is to finish a network
installation. Imagine, you have a common source tree for two different
architectures. You decide to do a completely independent fresh
installation. You start on one architecture with the help of a Bundle
file produced earlier. CPAN installs the whole Bundle for you, but
when you try to repeat the job on the second architecture, CPAN
responds with a C<"Foo up to date"> message for all modules. So you
invoke CPAN's recompile on the second architecture and you're done.

Another popular use for C<recompile> is to act as a rescue in case your
perl breaks binary compatibility. If one of the modules that CPAN uses
is in turn depending on binary compatibility (so you cannot run CPAN
commands), then you should try the CPAN::Nox module for recovery.

=head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution

Although it may be considered internal, the class hierarchy does matter
for both users and programmer. CPAN.pm deals with above mentioned four
classes, and all those classes share a set of methods. A classical
single polymorphism is in effect. A metaclass object registers all
objects of all kinds and indexes them with a string. The strings
referencing objects have a separated namespace (well, not completely
separated):

         Namespace                         Class

   words containing a "/" (slash)      Distribution
    words starting with Bundle::          Bundle
          everything else            Module or Author

Modules know their associated Distribution objects. They always refer
to the most recent official release. Developers may mark their releases
as unstable development versions (by inserting an underbar into the
module version number which will also be reflected in the distribution
name when you run 'make dist'), so the really hottest and newest 
distribution is not always the default.  If a module Foo circulates 
on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient 
way to install version 1.23 by saying

    install Foo

This would install the complete distribution file (say
BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
like to install version 1.23_90, you need to know where the
distribution file resides on CPAN relative to the authors/id/
directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
so you would have to say

    install BAR/Foo-1.23_90.tar.gz

The first example will be driven by an object of the class
CPAN::Module, the second by an object of class CPAN::Distribution.

=head2 Programmer's interface

If you do not enter the shell, the available shell commands are both
available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
functions in the calling package (C<install(...)>).

There's currently only one class that has a stable interface -
CPAN::Shell. All commands that are available in the CPAN shell are
methods of the class CPAN::Shell. Each of the commands that produce
listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
the IDs of all modules within the list.

=over 2

=item expand($type,@things)

The IDs of all objects available within a program are strings that can
be expanded to the corresponding real objects with the
C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
list of CPAN::Module objects according to the C<@things> arguments
given. In scalar context it only returns the first element of the
list.

=item expandany(@things)

Like expand, but returns objects of the appropriate type, i.e.
CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
CPAN::Distribution objects fro distributions.

=item Programming Examples

This enables the programmer to do operations that combine
functionalities that are available in the shell.

    # install everything that is outdated on my disk:
    perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'

    # install my favorite programs if necessary:
    for $mod (qw(Net::FTP MD5 Data::Dumper)){
        my $obj = CPAN::Shell->expand('Module',$mod);
        $obj->install;
    }

    # list all modules on my disk that have no VERSION number
    for $mod (CPAN::Shell->expand("Module","/./")){
	next unless $mod->inst_file;
        # MakeMaker convention for undefined $VERSION:
	next unless $mod->inst_version eq "undef";
	print "No VERSION in ", $mod->id, "\n";
    }

    # find out which distribution on CPAN contains a module:
    print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file

Or if you want to write a cronjob to watch The CPAN, you could list
all modules that need updating. First a quick and dirty way:

    perl -e 'use CPAN; CPAN::Shell->r;'

If you don't want to get any output in the case that all modules are
up to date, you can parse the output of above command for the regular
expression //modules are up to date// and decide to mail the output
only if it doesn't match. Ick?

If you prefer to do it more in a programmer style in one single
process, maybe something like this suits you better:

  # list all modules on my disk that have newer versions on CPAN
  for $mod (CPAN::Shell->expand("Module","/./")){
    next unless $mod->inst_file;
    next if $mod->uptodate;
    printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
        $mod->id, $mod->inst_version, $mod->cpan_version;
  }

If that gives you too much output every day, you maybe only want to
watch for three modules. You can write

  for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){

as the first line instead. Or you can combine some of the above
tricks:

  # watch only for a new mod_perl module
  $mod = CPAN::Shell->expand("Module","mod_perl");
  exit if $mod->uptodate;
  # new mod_perl arrived, let me know all update recommendations
  CPAN::Shell->r;

=back

=head2 Methods in the other Classes

The programming interface for the classes CPAN::Module,
CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
beta and partially even alpha. In the following paragraphs only those
methods are documented that have proven useful over a longer time and
thus are unlikely to change.

=over 4

=item CPAN::Author::as_glimpse()

Returns a one-line description of the author

=item CPAN::Author::as_string()

Returns a multi-line description of the author

=item CPAN::Author::email()

Returns the author's email address

=item CPAN::Author::fullname()

Returns the author's name

=item CPAN::Author::name()

An alias for fullname

=item CPAN::Bundle::as_glimpse()

Returns a one-line description of the bundle

=item CPAN::Bundle::as_string()

Returns a multi-line description of the bundle

=item CPAN::Bundle::clean()

Recursively runs the C<clean> method on all items contained in the bundle.

=item CPAN::Bundle::contains()

Returns a list of objects' IDs contained in a bundle. The associated
objects may be bundles, modules or distributions.

=item CPAN::Bundle::force($method,@args)

Forces CPAN to perform a task that normally would have failed. Force
takes as arguments a method name to be called and any number of
additional arguments that should be passed to the called method. The
internals of the object get the needed changes so that CPAN.pm does
not refuse to take the action. The C<force> is passed recursively to
all contained objects.

=item CPAN::Bundle::get()

Recursively runs the C<get> method on all items contained in the bundle

=item CPAN::Bundle::inst_file()

Returns the highest installed version of the bundle in either @INC or
C<$CPAN::Config->{cpan_home}>. Note that this is different from
CPAN::Module::inst_file.

=item CPAN::Bundle::inst_version()

Like CPAN::Bundle::inst_file, but returns the $VERSION

=item CPAN::Bundle::uptodate()

Returns 1 if the bundle itself and all its members are uptodate.

=item CPAN::Bundle::install()

Recursively runs the C<install> method on all items contained in the bundle

=item CPAN::Bundle::make()

Recursively runs the C<make> method on all items contained in the bundle

=item CPAN::Bundle::readme()

Recursively runs the C<readme> method on all items contained in the bundle

=item CPAN::Bundle::test()

Recursively runs the C<test> method on all items contained in the bundle

=item CPAN::Distribution::as_glimpse()

Returns a one-line description of the distribution

=item CPAN::Distribution::as_string()

Returns a multi-line description of the distribution

=item CPAN::Distribution::clean()

Changes to the directory where the distribution has been unpacked and
runs C<make clean> there.

=item CPAN::Distribution::containsmods()

Returns a list of IDs of modules contained in a distribution file.
Only works for distributions listed in the 02packages.details.txt.gz
file. This typically means that only the most recent version of a
distribution is covered.

=item CPAN::Distribution::cvs_import()

Changes to the directory where the distribution has been unpacked and
runs something like

    cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version

there.

=item CPAN::Distribution::dir()

Returns the directory into which this distribution has been unpacked.

=item CPAN::Distribution::force($method,@args)

Forces CPAN to perform a task that normally would have failed. Force
takes as arguments a method name to be called and any number of
additional arguments that should be passed to the called method. The
internals of the object get the needed changes so that CPAN.pm does
not refuse to take the action.

=item CPAN::Distribution::get()

Downloads the distribution from CPAN and unpacks it. Does nothing if
the distribution has already been downloaded and unpacked within the
current session.

=item CPAN::Distribution::install()

Changes to the directory where the distribution has been unpacked and
runs the external command C<make install> there. If C<make> has not
yet been run, it will be run first. A C<make test> will be issued in
any case and if this fails, the install will be cancelled. The
cancellation can be avoided by letting C<force> run the C<install> for
you.

=item CPAN::Distribution::isa_perl()

Returns 1 if this distribution file seems to be a perl distribution.
Normally this is derived from the file name only, but the index from
CPAN can contain a hint to achieve a return value of true for other
filenames too.

=item CPAN::Distribution::look()

Changes to the directory where the distribution has been unpacked and
opens a subshell there. Exiting the subshell returns.

=item CPAN::Distribution::make()

First runs the C<get> method to make sure the distribution is
downloaded and unpacked. Changes to the directory where the
distribution has been unpacked and runs the external commands C<perl
Makefile.PL> and C<make> there.

=item CPAN::Distribution::prereq_pm()

Returns the hash reference that has been announced by a distribution
as the PREREQ_PM hash in the Makefile.PL. Note: works only after an
attempt has been made to C<make> the distribution. Returns undef
otherwise.

=item CPAN::Distribution::readme()

Downloads the README file associated with a distribution and runs it
through the pager specified in C<$CPAN::Config->{pager}>.

=item CPAN::Distribution::test()

Changes to the directory where the distribution has been unpacked and
runs C<make test> there.

=item CPAN::Distribution::uptodate()

Returns 1 if all the modules contained in the distribution are
uptodate. Relies on containsmods.

=item CPAN::Index::force_reload()

Forces a reload of all indices.

=item CPAN::Index::reload()

Reloads all indices if they have been read more than
C<$CPAN::Config->{index_expire}> days.

=item CPAN::InfoObj::dump()

CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
inherit this method. It prints the data structure associated with an
object. Useful for debugging. Note: the data structure is considered
internal and thus subject to change without notice.

=item CPAN::Module::as_glimpse()

Returns a one-line description of the module

=item CPAN::Module::as_string()

Returns a multi-line description of the module

=item CPAN::Module::clean()

Runs a clean on the distribution associated with this module.

=item CPAN::Module::cpan_file()

Returns the filename on CPAN that is associated with the module.

=item CPAN::Module::cpan_version()

Returns the latest version of this module available on CPAN.

=item CPAN::Module::cvs_import()

Runs a cvs_import on the distribution associated with this module.

=item CPAN::Module::description()

Returns a 44 chracter description of this module. Only available for
modules listed in The Module List (CPAN/modules/00modlist.long.html
or 00modlist.long.txt.gz)

=item CPAN::Module::force($method,@args)

Forces CPAN to perform a task that normally would have failed. Force
takes as arguments a method name to be called and any number of
additional arguments that should be passed to the called method. The
internals of the object get the needed changes so that CPAN.pm does
not refuse to take the action.

=item CPAN::Module::get()

Runs a get on the distribution associated with this module.

=item CPAN::Module::inst_file()

Returns the filename of the module found in @INC. The first file found
is reported just like perl itself stops searching @INC when it finds a
module.

=item CPAN::Module::inst_version()

Returns the version number of the module in readable format.

=item CPAN::Module::install()

Runs an C<install> on the distribution associated with this module.

=item CPAN::Module::look()

Changes to the directory where the distribution assoicated with this
module has been unpacked and opens a subshell there. Exiting the
subshell returns.

=item CPAN::Module::make()

Runs a C<make> on the distribution associated with this module.

=item CPAN::Module::manpage_headline()

If module is installed, peeks into the module's manpage, reads the
headline and returns it. Moreover, if the module has been downloaded
within this session, does the equivalent on the downloaded module even
if it is not installed.

=item CPAN::Module::readme()

Runs a C<readme> on the distribution associated with this module.

=item CPAN::Module::test()

Runs a C<test> on the distribution associated with this module.

=item CPAN::Module::uptodate()

Returns 1 if the module is installed and up-to-date.

=item CPAN::Module::userid()

Returns the author's ID of the module.

=back

=head2 Cache Manager

Currently the cache manager only keeps track of the build directory
($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
deletes complete directories below C<build_dir> as soon as the size of
all directories there gets bigger than $CPAN::Config->{build_cache}
(in MB). The contents of this cache may be used for later
re-installations that you intend to do manually, but will never be
trusted by CPAN itself. This is due to the fact that the user might
use these directories for building modules on different architectures.

There is another directory ($CPAN::Config->{keep_source_where}) where
the original distribution files are kept. This directory is not
covered by the cache manager and must be controlled by the user. If
you choose to have the same directory as build_dir and as
keep_source_where directory, then your sources will be deleted with
the same fifo mechanism.

=head2 Bundles

A bundle is just a perl module in the namespace Bundle:: that does not
define any functions or methods. It usually only contains documentation.

It starts like a perl module with a package declaration and a $VERSION
variable. After that the pod section looks like any other pod with the
only difference being that I<one special pod section> exists starting with
(verbatim):

	=head1 CONTENTS

In this pod section each line obeys the format

        Module_Name [Version_String] [- optional text]

The only required part is the first field, the name of a module
(e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
of the line is optional. The comment part is delimited by a dash just
as in the man page header.

The distribution of a bundle should follow the same convention as
other distributions.

Bundles are treated specially in the CPAN package. If you say 'install
Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
the modules in the CONTENTS section of the pod. You can install your
own Bundles locally by placing a conformant Bundle file somewhere into
your @INC path. The autobundle() command which is available in the
shell interface does that for you by including all currently installed
modules in a snapshot bundle file.

=head2 Prerequisites

If you have a local mirror of CPAN and can access all files with
"file:" URLs, then you only need a perl better than perl5.003 to run
this module. Otherwise Net::FTP is strongly recommended. LWP may be
required for non-UNIX systems or if your nearest CPAN site is
associated with an URL that is not C<ftp:>.

If you have neither Net::FTP nor LWP, there is a fallback mechanism
implemented for an external ftp command or for an external lynx
command.

=head2 Finding packages and VERSION

This module presumes that all packages on CPAN

=over 2

=item *

declare their $VERSION variable in an easy to parse manner. This
prerequisite can hardly be relaxed because it consumes far too much
memory to load all packages into the running program just to determine
the $VERSION variable. Currently all programs that are dealing with
version use something like this

    perl -MExtUtils::MakeMaker -le \
        'print MM->parse_version(shift)' filename

If you are author of a package and wonder if your $VERSION can be
parsed, please try the above method.

=item *

come as compressed or gzipped tarfiles or as zip files and contain a
Makefile.PL (well, we try to handle a bit more, but without much
enthusiasm).

=back

=head2 Debugging

The debugging of this module is a bit complex, because we have
interferences of the software producing the indices on CPAN, of the
mirroring process on CPAN, of packaging, of configuration, of
synchronicity, and of bugs within CPAN.pm.

For code debugging in interactive mode you can try "o debug" which
will list options for debugging the various parts of the code. You
should know that "o debug" has built-in completion support.

For data debugging there is the C<dump> command which takes the same
arguments as make/test/install and outputs the object's Data::Dumper
dump.

=head2 Floppy, Zip, Offline Mode

CPAN.pm works nicely without network too. If you maintain machines
that are not networked at all, you should consider working with file:
URLs. Of course, you have to collect your modules somewhere first. So
you might use CPAN.pm to put together all you need on a networked
machine. Then copy the $CPAN::Config->{keep_source_where} (but not
$CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
of a personal CPAN. CPAN.pm on the non-networked machines works nicely
with this floppy. See also below the paragraph about CD-ROM support.

=head1 CONFIGURATION

When the CPAN module is installed, a site wide configuration file is
created as CPAN/Config.pm. The default values defined there can be
overridden in another configuration file: CPAN/MyConfig.pm. You can
store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
$HOME/.cpan is added to the search path of the CPAN module before the
use() or require() statements.

Currently the following keys in the hash reference $CPAN::Config are
defined:

  build_cache        size of cache for directories to build modules
  build_dir          locally accessible directory to build modules
  index_expire       after this many days refetch index files
  cache_metadata     use serializer to cache metadata
  cpan_home          local directory reserved for this package
  dontload_hash      anonymous hash: modules in the keys will not be
                     loaded by the CPAN::has_inst() routine
  gzip		     location of external program gzip
  inactivity_timeout breaks interactive Makefile.PLs after this
                     many seconds inactivity. Set to 0 to never break.
  inhibit_startup_message
                     if true, does not print the startup message
  keep_source_where  directory in which to keep the source (if we do)
  make               location of external make program
  make_arg	     arguments that should always be passed to 'make'
  make_install_arg   same as make_arg for 'make install'
  makepl_arg	     arguments passed to 'perl Makefile.PL'
  pager              location of external program more (or any pager)
  prerequisites_policy
                     what to do if you are missing module prerequisites
                     ('follow' automatically, 'ask' me, or 'ignore')
  proxy_user         username for accessing an authenticating proxy
  proxy_pass         password for accessing an authenticating proxy
  scan_cache	     controls scanning of cache ('atstart' or 'never')
  tar                location of external program tar
  term_is_latin      if true internal UTF-8 is translated to ISO-8859-1
                     (and nonsense for characters outside latin range)
  unzip              location of external program unzip
  urllist	     arrayref to nearby CPAN sites (or equivalent locations)
  wait_list          arrayref to a wait server to try (See CPAN::WAIT)
  ftp_proxy,      }  the three usual variables for configuring
    http_proxy,   }  proxy requests. Both as CPAN::Config variables
    no_proxy      }  and as environment variables configurable.

You can set and query each of these options interactively in the cpan
shell with the command set defined within the C<o conf> command:

=over 2

=item C<o conf E<lt>scalar optionE<gt>>

prints the current value of the I<scalar option>

=item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>

Sets the value of the I<scalar option> to I<value>

=item C<o conf E<lt>list optionE<gt>>

prints the current value of the I<list option> in MakeMaker's
neatvalue format.

=item C<o conf E<lt>list optionE<gt> [shift|pop]>

shifts or pops the array in the I<list option> variable

=item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>

works like the corresponding perl commands.

=back

=head2 Note on urllist parameter's format

urllist parameters are URLs according to RFC 1738. We do a little
guessing if your URL is not compliant, but if you have problems with
file URLs, please try the correct format. Either:

    file://localhost/whatever/ftp/pub/CPAN/

or

    file:///home/ftp/pub/CPAN/

=head2 urllist parameter has CD-ROM support

The C<urllist> parameter of the configuration table contains a list of
URLs that are to be used for downloading. If the list contains any
C<file> URLs, CPAN always tries to get files from there first. This
feature is disabled for index files. So the recommendation for the
owner of a CD-ROM with CPAN contents is: include your local, possibly
outdated CD-ROM as a C<file> URL at the end of urllist, e.g.

  o conf urllist push file://localhost/CDROM/CPAN

CPAN.pm will then fetch the index files from one of the CPAN sites
that come at the beginning of urllist. It will later check for each
module if there is a local copy of the most recent version.

Another peculiarity of urllist is that the site that we could
successfully fetch the last file from automatically gets a preference
token and is tried as the first site for the next request. So if you
add a new site at runtime it may happen that the previously preferred
site will be tried another time. This means that if you want to disallow
a site for the next transfer, it must be explicitly removed from
urllist.

=head1 SECURITY

There's no strong security layer in CPAN.pm. CPAN.pm helps you to
install foreign, unmasked, unsigned code on your machine. We compare
to a checksum that comes from the net just as the distribution file
itself. If somebody has managed to tamper with the distribution file,
they may have as well tampered with the CHECKSUMS file. Future
development will go towards strong authentication.

=head1 EXPORT

Most functions in package CPAN are exported per default. The reason
for this is that the primary use is intended for the cpan shell or for
oneliners.

=head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES

Populating a freshly installed perl with my favorite modules is pretty
easy if you maintain a private bundle definition file. To get a useful
blueprint of a bundle definition file, the command autobundle can be used
on the CPAN shell command line. This command writes a bundle definition
file for all modules that are installed for the currently running perl
interpreter. It's recommended to run this command only once and from then
on maintain the file manually under a private name, say
Bundle/my_bundle.pm. With a clever bundle file you can then simply say

    cpan> install Bundle::my_bundle

then answer a few questions and then go out for a coffee.

Maintaining a bundle definition file means keeping track of two
things: dependencies and interactivity. CPAN.pm sometimes fails on
calculating dependencies because not all modules define all MakeMaker
attributes correctly, so a bundle definition file should specify
prerequisites as early as possible. On the other hand, it's a bit
annoying that many distributions need some interactive configuring. So
what I try to accomplish in my private bundle file is to have the
packages that need to be configured early in the file and the gentle
ones later, so I can go out after a few minutes and leave CPAN.pm
untended.

=head1 WORKING WITH CPAN.pm BEHIND FIREWALLS

Thanks to Graham Barr for contributing the following paragraphs about
the interaction between perl, and various firewall configurations. For
further informations on firewalls, it is recommended to consult the
documentation that comes with the ncftp program. If you are unable to
go through the firewall with a simple Perl setup, it is very likely
that you can configure ncftp so that it works for your firewall.

=head2 Three basic types of firewalls

Firewalls can be categorized into three basic types.

=over 4

=item http firewall

This is where the firewall machine runs a web server and to access the
outside world you must do it via the web server. If you set environment
variables like http_proxy or ftp_proxy to a values beginning with http://
or in your web browser you have to set proxy information then you know
you are running a http firewall.

To access servers outside these types of firewalls with perl (even for
ftp) you will need to use LWP.

=item ftp firewall

This where the firewall machine runs a ftp server. This kind of
firewall will only let you access ftp servers outside the firewall.
This is usually done by connecting to the firewall with ftp, then
entering a username like "user@outside.host.com"

To access servers outside these type of firewalls with perl you
will need to use Net::FTP.

=item One way visibility

I say one way visibility as these firewalls try to make themselve look
invisible to the users inside the firewall. An FTP data connection is
normally created by sending the remote server your IP address and then
listening for the connection. But the remote server will not be able to
connect to you because of the firewall. So for these types of firewall
FTP connections need to be done in a passive mode.

There are two that I can think off.

=over 4

=item SOCKS

If you are using a SOCKS firewall you will need to compile perl and link
it with the SOCKS library, this is what is normally called a 'socksified'
perl. With this executable you will be able to connect to servers outside
the firewall as if it is not there.

=item IP Masquerade

This is the firewall implemented in the Linux kernel, it allows you to
hide a complete network behind one IP address. With this firewall no
special compiling is needed as you can access hosts directly.

=back

=back

=head2 Configuring lynx or ncftp for going through a firewall

If you can go through your firewall with e.g. lynx, presumably with a
command such as

    /usr/local/bin/lynx -pscott:tiger

then you would configure CPAN.pm with the command

    o conf lynx "/usr/local/bin/lynx -pscott:tiger"

That's all. Similarly for ncftp or ftp, you would configure something
like

    o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"

Your milage may vary...

=head1 FAQ

=over 4

=item 1)

I installed a new version of module X but CPAN keeps saying,
I have the old version installed

Most probably you B<do> have the old version installed. This can
happen if a module installs itself into a different directory in the
@INC path than it was previously installed. This is not really a
CPAN.pm problem, you would have the same problem when installing the
module manually. The easiest way to prevent this behaviour is to add
the argument C<UNINST=1> to the C<make install> call, and that is why
many people add this argument permanently by configuring

  o conf make_install_arg UNINST=1

=item 2)

So why is UNINST=1 not the default?

Because there are people who have their precise expectations about who
may install where in the @INC path and who uses which @INC array. In
fine tuned environments C<UNINST=1> can cause damage.

=item 3)

I want to clean up my mess, and install a new perl along with
all modules I have. How do I go about it?

Run the autobundle command for your old perl and optionally rename the
resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
with the Configure option prefix, e.g.

    ./Configure -Dprefix=/usr/local/perl-5.6.78.9

Install the bundle file you produced in the first step with something like

    cpan> install Bundle::mybundle

and you're done.

=item 4)

When I install bundles or multiple modules with one command
there is too much output to keep track of.

You may want to configure something like

  o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
  o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"

so that STDOUT is captured in a file for later inspection.


=item 5)

I am not root, how can I install a module in a personal directory?

You will most probably like something like this:

  o conf makepl_arg "LIB=~/myperl/lib \
                    INSTALLMAN1DIR=~/myperl/man/man1 \
                    INSTALLMAN3DIR=~/myperl/man/man3"
  install Sybase::Sybperl

You can make this setting permanent like all C<o conf> settings with
C<o conf commit>.

You will have to add ~/myperl/man to the MANPATH environment variable
and also tell your perl programs to look into ~/myperl/lib, e.g. by
including

  use lib "$ENV{HOME}/myperl/lib";

or setting the PERL5LIB environment variable.

Another thing you should bear in mind is that the UNINST parameter
should never be set if you are not root.

=item 6)

How to get a package, unwrap it, and make a change before building it?

  look Sybase::Sybperl

=item 7)

I installed a Bundle and had a couple of fails. When I
retried, everything resolved nicely. Can this be fixed to work
on first try?

The reason for this is that CPAN does not know the dependencies of all
modules when it starts out. To decide about the additional items to
install, it just uses data found in the generated Makefile. An
undetected missing piece breaks the process. But it may well be that
your Bundle installs some prerequisite later than some depending item
and thus your second try is able to resolve everything. Please note,
CPAN.pm does not know the dependency tree in advance and cannot sort
the queue of things to install in a topologically correct order. It
resolves perfectly well IFF all modules declare the prerequisites
correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
fail and you need to install often, it is recommended sort the Bundle
definition file manually. It is planned to improve the metadata
situation for dependencies on CPAN in general, but this will still
take some time.

=item 8)

In our intranet we have many modules for internal use. How
can I integrate these modules with CPAN.pm but without uploading
the modules to CPAN?

Have a look at the CPAN::Site module.

=item 9)

When I run CPAN's shell, I get error msg about line 1 to 4,
setting meta input/output via the /etc/inputrc file.

Some versions of readline are picky about capitalization in the
/etc/inputrc file and specifically RedHat 6.2 comes with a
/etc/inputrc that contains the word C<on> in lowercase. Change the
occurrences of C<on> to C<On> and the bug should disappear.

=item 10)

Some authors have strange characters in their names.

Internally CPAN.pm uses the UTF-8 charset. If your terminal is
expecting ISO-8859-1 charset, a converter can be activated by setting
term_is_latin to a true value in your config file. One way of doing so
would be

    cpan> ! $CPAN::Config->{term_is_latin}=1

Extended support for converters will be made available as soon as perl
becomes stable with regard to charset issues.

=back

=head1 BUGS

We should give coverage for B<all> of the CPAN and not just the PAUSE
part, right? In this discussion CPAN and PAUSE have become equal --
but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
PAUSE plus the clpa/, doc/, misc/, ports/, and src/.

Future development should be directed towards a better integration of
the other parts.

If a Makefile.PL requires special customization of libraries, prompts
the user for special input, etc. then you may find CPAN is not able to
build the distribution. In that case, you should attempt the
traditional method of building a Perl module package from a shell.

=head1 AUTHOR

Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>

=head1 TRANSLATIONS

Kawai,Takanori provides a Japanese translation of this manpage at
http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm

=head1 SEE ALSO

perl(1), CPAN::Nox(3)

=cut

       $sel = "->[\$i]";
            }
            elsif( defined $hashes{$name} ){                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                ;# ctime.pl is a simple Perl emulation for the well known ctime(3C) function.
#
# This library is no longer being maintained, and is included for backward
# compatibility with Perl 4 programs which may require it.
#
# In particular, this should not be used as an example of modern Perl
# programming techniques.
#
# Suggested alternative: the POSIX ctime function
;#
;# Waldemar Kebsch, Federal Republic of Germany, November 1988
;# kebsch.pad@nixpbe.UUCP
;# Modified March 1990, Feb 1991 to properly handle timezones
;#  $RCSfile: ctime.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:47 $
;#   Marion Hakanson (hakanson@cse.ogi.edu)
;#   Oregon Graduate Institute of Science and Technology
;#
;# usage:
;#
;#     #include <ctime.pl>          # see the -P and -I option in perl.man
;#     $Date = &ctime(time);

CONFIG: {
    package ctime;

    @DoW = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
    @MoY = ('Jan','Feb','Mar','Apr','May','Jun',
	    'Jul','Aug','Sep','Oct','Nov','Dec');
}

sub ctime {
    package ctime;

    local($time) = @_;
    local($[) = 0;
    local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst);

    # Determine what time zone is in effect.
    # Use GMT if TZ is defined as null, local time if TZ undefined.
    # There's no portable way to find the system default timezone.

    $TZ = defined($ENV{'TZ'}) ? ( $ENV{'TZ'} ? $ENV{'TZ'} : 'GMT' ) : '';
    ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) =
        ($TZ eq 'GMT') ? gmtime($time) : localtime($time);

    # Hack to deal with 'PST8PDT' format of TZ
    # Note that this can't deal with all the esoteric forms, but it
    # does recognize the most common: [:]STDoff[DST[off][,rule]]

    if($TZ=~/^([^:\d+\-,]{3,})([+-]?\d{1,2}(:\d{1,2}){0,2})([^\d+\-,]{3,})?/){
        $TZ = $isdst ? $4 : $1;
    }
    $TZ .= ' ' unless $TZ eq '';

    $year += 1900;
    sprintf("%s %s %2d %2d:%02d:%02d %s%4d\n",
      $DoW[$wday], $MoY[$mon], $mday, $hour, $min, $sec, $TZ, $year);
}
1;

                                    # array type acces                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                package Cwd;
require 5.6.0;

=head1 NAME

Cwd - get pathname of current working directory

=head1 SYNOPSIS

    use Cwd;
    $dir = cwd;

    use Cwd;
    $dir = getcwd;

    use Cwd;
    $dir = fastcwd;

    use Cwd;
    $dir = fastgetcwd;

    use Cwd 'chdir';
    chdir "/tmp";
    print $ENV{'PWD'};

    use Cwd 'abs_path';	    # aka realpath()
    print abs_path($ENV{'PWD'});

    use Cwd 'fast_abs_path';
    print fast_abs_path($ENV{'PWD'});

=head1 DESCRIPTION

This module provides functions for determining the pathname of the
current working directory.  By default, it exports the functions
cwd(), getcwd(), fastcwd(), and fastgetcwd() into the caller's
namespace.  Each of these functions are called without arguments and
return the absolute path of the current working directory.  It is
recommended that cwd (or another *cwd() function) be used in I<all>
code to ensure portability.

The cwd() is the most natural and safe form for the current
architecture. For most systems it is identical to `pwd` (but without
the trailing line terminator).

The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions
in Perl.

The fastcwd() function looks the same as getcwd(), but runs faster.
It's also more dangerous because it might conceivably chdir() you out
of a directory that it can't chdir() you back into.  If fastcwd
encounters a problem it will return undef but will probably leave you
in a different directory.  For a measure of extra security, if
everything appears to have worked, the fastcwd() function will check
that it leaves you in the same directory that it started in. If it has
changed it will C<die> with the message "Unstable directory path,
current directory changed unexpectedly". That should never happen.

The fastgetcwd() function is provided as a synonym for cwd().

The abs_path() function takes a single argument and returns the
absolute pathname for that argument.  It uses the same algorithm as
getcwd().  (Actually, getcwd() is abs_path("."))  Symbolic links and
relative-path components ("." and "..") are resolved to return the
canonical pathname, just like realpath(3).  This function is also
callable as realpath().

The fast_abs_path() function looks the same as abs_path() but runs
faster and, like fastcwd(), is more dangerous.

If you ask to override your chdir() built-in function, then your PWD
environment variable will be kept up to date.  (See
L<perlsub/Overriding Builtin Functions>.) Note that it will only be
kept up to date if all packages which use chdir import it from Cwd.

=head1 NOTES

=over 4

=item *

On Mac OS (Classic), the path separator is ':', not '/', and the 
current directory is denoted as ':', not '.'. To move up the directory 
tree, you will use '::' to move up one level, but ':::' and so on to 
move up the tree two or more levels (i.e. the equivalent to '../../..'
is '::::'). Generally, you should be careful about specifying relative pathnames. 
While a full path always begins with a volume name, a relative pathname 
should always begin with a ':'.  If specifying a volume name only, a 
trailing ':' is required.

Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
functions  are all aliases for the C<cwd()> function, which, on Mac OS,
calls `pwd`. Likewise, the C<abs_path()> function is an alias for
C<fast_abs_path()>.

=back

=cut

use strict;

use Carp;

our $VERSION = '2.05';

use base qw/ Exporter /;
our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);


# The 'natural and safe form' for UNIX (pwd may be setuid root)

sub _backtick_pwd {
    my $cwd = `pwd`;
    # `pwd` may fail e.g. if the disk is full
    chomp($cwd) if defined $cwd;
    $cwd;
}

# Since some ports may predefine cwd internally (e.g., NT)
# we take care not to override an existing definition for cwd().

unless(defined &cwd) {
    # The pwd command is not available in some chroot(2)'ed environments
    if($^O eq 'MacOS' || grep { -x "$_/pwd" } split(':', $ENV{PATH})) {
	*cwd = \&_backtick_pwd;
    }
    else {
	*cwd = \&getcwd;
    }
}

# set a reasonable (and very safe) default for fastgetcwd, in case it
# isn't redefined later (20001212 rspier)
*fastgetcwd = \&cwd;

# By Brandon S. Allbery
#
# Usage: $cwd = getcwd();

sub getcwd
{
    abs_path('.');
}

# By John Bazik
#
# Usage: $cwd = &fastcwd;
#
# This is a faster version of getcwd.  It's also more dangerous because
# you might chdir out of a directory that you can't chdir back into.
    
sub fastcwd {
    my($odev, $oino, $cdev, $cino, $tdev, $tino);
    my(@path, $path);
    local(*DIR);

    my($orig_cdev, $orig_cino) = stat('.');
    ($cdev, $cino) = ($orig_cdev, $orig_cino);
    for (;;) {
	my $direntry;
	($odev, $oino) = ($cdev, $cino);
	CORE::chdir('..') || return undef;
	($cdev, $cino) = stat('.');
	last if $odev == $cdev && $oino == $cino;
	opendir(DIR, '.') || return undef;
	for (;;) {
	    $direntry = readdir(DIR);
	    last unless defined $direntry;
	    next if $direntry eq '.';
	    next if $direntry eq '..';

	    ($tdev, $tino) = lstat($direntry);
	    last unless $tdev != $odev || $tino != $oino;
	}
	closedir(DIR);
	return undef unless defined $direntry; # should never happen
	unshift(@path, $direntry);
    }
    $path = '/' . join('/', @path);
    if ($^O eq 'apollo') { $path = "/".$path; }
    # At this point $path may be tainted (if tainting) and chdir would fail.
    # To be more useful we untaint it then check that we landed where we started.
    $path = $1 if $path =~ /^(.*)\z/s;	# untaint
    CORE::chdir($path) || return undef;
    ($cdev, $cino) = stat('.');
    die "Unstable directory path, current directory changed unexpectedly"
	if $cdev != $orig_cdev || $cino != $orig_cino;
    $path;
}


# Keeps track of current working directory in PWD environment var
# Usage:
#	use Cwd 'chdir';
#	chdir $newdir;

my $chdir_init = 0;

sub chdir_init {
    if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
	my($dd,$di) = stat('.');
	my($pd,$pi) = stat($ENV{'PWD'});
	if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
	    $ENV{'PWD'} = cwd();
	}
    }
    else {
	my $wd = cwd();
	$wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
	$ENV{'PWD'} = $wd;
    }
    # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
    if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
	my($pd,$pi) = stat($2);
	my($dd,$di) = stat($1);
	if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
	    $ENV{'PWD'}="$2$3";
	}
    }
    $chdir_init = 1;
}

sub chdir {
    my $newdir = @_ ? shift : '';	# allow for no arg (chdir to HOME dir)
    $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
    chdir_init() unless $chdir_init;
    my $newpwd;
    if ($^O eq 'MSWin32') {
	# get the full path name *before* the chdir()
	$newpwd = Win32::GetFullPathName($newdir);
    }

    return 0 unless CORE::chdir $newdir;

    if ($^O eq 'VMS') {
	return $ENV{'PWD'} = $ENV{'DEFAULT'}
    }
    elsif ($^O eq 'MacOS') {
	return $ENV{'PWD'} = cwd();
    }
    elsif ($^O eq 'MSWin32') {
	$ENV{'PWD'} = $newpwd;
	return 1;
    }

    if ($newdir =~ m#^/#s) {
	$ENV{'PWD'} = $newdir;
    } else {
	my @curdir = split(m#/#,$ENV{'PWD'});
	@curdir = ('') unless @curdir;
	my $component;
	foreach $component (split(m#/#, $newdir)) {
	    next if $component eq '.';
	    pop(@curdir),next if $component eq '..';
	    push(@curdir,$component);
	}
	$ENV{'PWD'} = join('/',@curdir) || '/';
    }
    1;
}

# Taken from Cwd.pm It is really getcwd with an optional
# parameter instead of '.'
#

sub abs_path
{
    my $start = @_ ? shift : '.';
    my($dotdots, $cwd, @pst, @cst, $dir, @tst);

    unless (@cst = stat( $start ))
    {
	carp "stat($start): $!";
	return '';
    }
    $cwd = '';
    $dotdots = $start;
    do
    {
	$dotdots .= '/..';
	@pst = @cst;
	unless (opendir(PARENT, $dotdots))
	{
	    carp "opendir($dotdots): $!";
	    return '';
	}
	unless (@cst = stat($dotdots))
	{
	    carp "stat($dotdots): $!";
	    closedir(PARENT);
	    return '';
	}
	if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
	{
	    $dir = undef;
	}
	else
	{
	    do
	    {
		unless (defined ($dir = readdir(PARENT)))
	        {
		    carp "readdir($dotdots): $!";
		    closedir(PARENT);
		    return '';
		}
		$tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
	    }
	    while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
		   $tst[1] != $pst[1]);
	}
	$cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
	closedir(PARENT);
    } while (defined $dir);
    chop($cwd) unless $cwd eq '/'; # drop the trailing /
    $cwd;
}

# added function alias for those of us more
# used to the libc function.  --tchrist 27-Jan-00
*realpath = \&abs_path;

sub fast_abs_path {
    my $cwd = getcwd();
    require File::Spec;
    my $path = @_ ? shift : File::Spec->curdir;
    CORE::chdir($path) || croak "Cannot chdir to $path:$!";
    my $realpath = getcwd();
    CORE::chdir($cwd)  || croak "Cannot chdir back to $cwd:$!";
    $realpath;
}

# added function alias to follow principle of least surprise
# based on previous aliasing.  --tchrist 27-Jan-00
*fast_realpath = \&fast_abs_path;


# --- PORTING SECTION ---

# VMS: $ENV{'DEFAULT'} points to default directory at all times
# 06-Mar-1996  Charles Bailey  bailey@newman.upenn.edu
# Note: Use of Cwd::chdir() causes the logical name PWD to be defined
#   in the process logical name table as the default device and directory
#   seen by Perl. This may not be the same as the default device
#   and directory seen by DCL after Perl exits, since the effects
#   the CRTL chdir() function persist only until Perl exits.

sub _vms_cwd {
    return $ENV{'DEFAULT'};
}

sub _vms_abs_path {
    return $ENV{'DEFAULT'} unless @_;
    my $path = VMS::Filespec::pathify($_[0]);
    croak("Invalid path name $_[0]") unless defined $path;
    return VMS::Filespec::rmsexpand($path);
}

sub _os2_cwd {
    $ENV{'PWD'} = `cmd /c cd`;
    chop $ENV{'PWD'};
    $ENV{'PWD'} =~ s:\\:/:g ;
    return $ENV{'PWD'};
}

sub _win32_cwd {
    $ENV{'PWD'} = Win32::GetCwd();
    $ENV{'PWD'} =~ s:\\:/:g ;
    return $ENV{'PWD'};
}

*_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd && 
                            defined &Win32::GetCwd);

*_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;

sub _dos_cwd {
    if (!defined &Dos::GetCwd) {
        $ENV{'PWD'} = `command /c cd`;
        chop $ENV{'PWD'};
        $ENV{'PWD'} =~ s:\\:/:g ;
    } else {
        $ENV{'PWD'} = Dos::GetCwd();
    }
    return $ENV{'PWD'};
}

sub _qnx_cwd {
    $ENV{'PWD'} = `/usr/bin/fullpath -t`;
    chop $ENV{'PWD'};
    return $ENV{'PWD'};
}

sub _qnx_abs_path {
    my $path = @_ ? shift : '.';
    my $realpath=`/usr/bin/fullpath -t $path`;
    chop $realpath;
    return $realpath;
}

sub _epoc_cwd {
    $ENV{'PWD'} = EPOC::getcwd();
    return $ENV{'PWD'};
}

{
    no warnings;	# assignments trigger 'subroutine redefined' warning

    if ($^O eq 'VMS') {
        *cwd		= \&_vms_cwd;
        *getcwd		= \&_vms_cwd;
        *fastcwd	= \&_vms_cwd;
        *fastgetcwd	= \&_vms_cwd;
        *abs_path	= \&_vms_abs_path;
        *fast_abs_path	= \&_vms_abs_path;
    }
    elsif ($^O eq 'NT' or $^O eq 'MSWin32') {
        # We assume that &_NT_cwd is defined as an XSUB or in the core.
        *cwd		= \&_NT_cwd;
        *getcwd		= \&_NT_cwd;
        *fastcwd	= \&_NT_cwd;
        *fastgetcwd	= \&_NT_cwd;
        *abs_path	= \&fast_abs_path;
    }
    elsif ($^O eq 'os2') {
        # sys_cwd may keep the builtin command
        *cwd		= defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
        *getcwd		= \&cwd;
        *fastgetcwd	= \&cwd;
        *fastcwd	= \&cwd;
        *abs_path	= \&fast_abs_path;
    }
    elsif ($^O eq 'dos') {
        *cwd		= \&_dos_cwd;
        *getcwd		= \&_dos_cwd;
        *fastgetcwd	= \&_dos_cwd;
        *fastcwd	= \&_dos_cwd;
        *abs_path	= \&fast_abs_path;
    }
    elsif ($^O eq 'qnx') {
        *cwd		= \&_qnx_cwd;
        *getcwd		= \&_qnx_cwd;
        *fastgetcwd	= \&_qnx_cwd;
        *fastcwd	= \&_qnx_cwd;
        *abs_path	= \&_qnx_abs_path;
        *fast_abs_path	= \&_qnx_abs_path;
    }
    elsif ($^O eq 'cygwin') {
        *getcwd	= \&cwd;
        *fastgetcwd	= \&cwd;
        *fastcwd	= \&cwd;
        *abs_path	= \&fast_abs_path;
    }
    elsif ($^O eq 'epoc') {
        *cwd            = \&_epoc_cwd;
        *getcwd	        = \&_epoc_cwd;
        *fastgetcwd	= \&_epoc_cwd;
        *fastcwd	= \&_epoc_cwd;
        *abs_path	= \&fast_abs_path;
    }
    elsif ($^O eq 'MacOS') {
    	*getcwd     = \&cwd;
    	*fastgetcwd = \&cwd;
    	*fastcwd    = \&cwd;
    	*abs_path   = \&fast_abs_path;
    }
}

# package main; eval join('',<DATA>) || die $@;	# quick test

1;

__END__
BEGIN { import Cwd qw(:DEFAULT chdir); }
print join("\n", cwd, getcwd, fastcwd, "");
chdir('..');
print join("\n", cwd, getcwd, fastcwd, "");
print "$ENV{PWD}\n";
           foreach $cmp (@match) {
                            until (substr($cmp, 0, $l) eq substr($test, 0, $l)) {
                                $l--;
                            }
                        }
                        print("\a");
                    }
                    print($test = substr($test, $r, $l - $r));
                    $r = length($return .= $test);
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                           #
# Data/Dumper.pm
#
# convert perl data structures into perl syntax suitable for both printing
# and eval
#
# Documentation at the __END__
#

package Data::Dumper;

$VERSION = '2.102';

#$| = 1;

require 5.005_64;
require Exporter;
use XSLoader ();
require overload;

use Carp;

@ISA = qw(Exporter);
@EXPORT = qw(Dumper);
@EXPORT_OK = qw(DumperX);

XSLoader::load 'Data::Dumper';

# module vars and their defaults
$Indent = 2 unless defined $Indent;
$Purity = 0 unless defined $Purity;
$Pad = "" unless defined $Pad;
$Varname = "VAR" unless defined $Varname;
$Useqq = 0 unless defined $Useqq;
$Terse = 0 unless defined $Terse;
$Freezer = "" unless defined $Freezer;
$Toaster = "" unless defined $Toaster;
$Deepcopy = 0 unless defined $Deepcopy;
$Quotekeys = 1 unless defined $Quotekeys;
$Bless = "bless" unless defined $Bless;
#$Expdepth = 0 unless defined $Expdepth;
$Maxdepth = 0 unless defined $Maxdepth;

#
# expects an arrayref of values to be dumped.
# can optionally pass an arrayref of names for the values.
# names must have leading $ sign stripped. begin the name with *
# to cause output of arrays and hashes rather than refs.
#
sub new {
  my($c, $v, $n) = @_;

  croak "Usage:  PACKAGE->new(ARRAYREF, [ARRAYREF])" 
    unless (defined($v) && (ref($v) eq 'ARRAY'));
  $n = [] unless (defined($n) && (ref($v) eq 'ARRAY'));

  my($s) = { 
             level      => 0,           # current recursive depth
	     indent     => $Indent,     # various styles of indenting
	     pad	=> $Pad,        # all lines prefixed by this string
	     xpad       => "",          # padding-per-level
	     apad       => "",          # added padding for hash keys n such
	     sep        => "",          # list separator
	     seen       => {},          # local (nested) refs (id => [name, val])
	     todump     => $v,          # values to dump []
	     names      => $n,          # optional names for values []
	     varname    => $Varname,    # prefix to use for tagging nameless ones
             purity     => $Purity,     # degree to which output is evalable
             useqq 	=> $Useqq,      # use "" for strings (backslashitis ensues)
             terse 	=> $Terse,      # avoid name output (where feasible)
             freezer	=> $Freezer,    # name of Freezer method for objects
             toaster	=> $Toaster,    # name of method to revive objects
             deepcopy	=> $Deepcopy,   # dont cross-ref, except to stop recursion
             quotekeys	=> $Quotekeys,  # quote hash keys
             'bless'	=> $Bless,	# keyword to use for "bless"
#	     expdepth   => $Expdepth,   # cutoff depth for explicit dumping
	     maxdepth	=> $Maxdepth,   # depth beyond which we give up
	   };

  if ($Indent > 0) {
    $s->{xpad} = "  ";
    $s->{sep} = "\n";
  }
  return bless($s, $c);
}

#
# add-to or query the table of already seen references
#
sub Seen {
  my($s, $g) = @_;
  if (defined($g) && (ref($g) eq 'HASH'))  {
    my($k, $v, $id);
    while (($k, $v) = each %$g) {
      if (defined $v and ref $v) {
	($id) = (overload::StrVal($v) =~ /\((.*)\)$/);
	if ($k =~ /^[*](.*)$/) {
	  $k = (ref $v eq 'ARRAY') ? ( "\\\@" . $1 ) :
	       (ref $v eq 'HASH')  ? ( "\\\%" . $1 ) :
	       (ref $v eq 'CODE')  ? ( "\\\&" . $1 ) :
				     (   "\$" . $1 ) ;
	}
	elsif ($k !~ /^\$/) {
	  $k = "\$" . $k;
	}
	$s->{seen}{$id} = [$k, $v];
      }
      else {
	carp "Only refs supported, ignoring non-ref item \$$k";
      }
    }
    return $s;
  }
  else {
    return map { @$_ } values %{$s->{seen}};
  }
}

#
# set or query the values to be dumped
#
sub Values {
  my($s, $v) = @_;
  if (defined($v) && (ref($v) eq 'ARRAY'))  {
    $s->{todump} = [@$v];        # make a copy
    return $s;
  }
  else {
    return @{$s->{todump}};
  }
}

#
# set or query the names of the values to be dumped
#
sub Names {
  my($s, $n) = @_;
  if (defined($n) && (ref($n) eq 'ARRAY'))  {
    $s->{names} = [@$n];         # make a copy
    return $s;
  }
  else {
    return @{$s->{names}};
  }
}

sub DESTROY {}

sub Dump {
    return &Dumpxs
	unless $Data::Dumper::Useqq || (ref($_[0]) && $_[0]->{useqq});
    return &Dumpperl;
}

#
# dump the refs in the current dumper object.
# expects same args as new() if called via package name.
#
sub Dumpperl {
  my($s) = shift;
  my(@out, $val, $name);
  my($i) = 0;
  local(@post);

  $s = $s->new(@_) unless ref $s;

  for $val (@{$s->{todump}}) {
    my $out = "";
    @post = ();
    $name = $s->{names}[$i++];
    if (defined $name) {
      if ($name =~ /^[*](.*)$/) {
	if (defined $val) {
	  $name = (ref $val eq 'ARRAY') ? ( "\@" . $1 ) :
		  (ref $val eq 'HASH')  ? ( "\%" . $1 ) :
		  (ref $val eq 'CODE')  ? ( "\*" . $1 ) :
					  ( "\$" . $1 ) ;
	}
	else {
	  $name = "\$" . $1;
	}
      }
      elsif ($name !~ /^\$/) {
	$name = "\$" . $name;
      }
    }
    else {
      $name = "\$" . $s->{varname} . $i;
    }

    my $valstr;
    {
      local($s->{apad}) = $s->{apad};
      $s->{apad} .= ' ' x (length($name) + 3) if $s->{indent} >= 2;
      $valstr = $s->_dump($val, $name);
    }

    $valstr = "$name = " . $valstr . ';' if @post or !$s->{terse};
    $out .= $s->{pad} . $valstr . $s->{sep};
    $out .= $s->{pad} . join(';' . $s->{sep} . $s->{pad}, @post) 
      . ';' . $s->{sep} if @post;

    push @out, $out;
  }
  return wantarray ? @out : join('', @out);
}

#
# twist, toil and turn;
# and recurse, of course.
#
sub _dump {
  my($s, $val, $name) = @_;
  my($sname);
  my($out, $realpack, $realtype, $type, $ipad, $id, $blesspad);

  $type = ref $val;
  $out = "";

  if ($type) {

    # prep it, if it looks like an object
    if (my $freezer = $s->{freezer}) {
      $val->$freezer() if UNIVERSAL::can($val, $freezer);
    }

    ($realpack, $realtype, $id) =
      (overload::StrVal($val) =~ /^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$/);

    # if it has a name, we need to either look it up, or keep a tab
    # on it so we know when we hit it later
    if (defined($name) and length($name)) {
      # keep a tab on it so that we dont fall into recursive pit
      if (exists $s->{seen}{$id}) {
#	if ($s->{expdepth} < $s->{level}) {
	  if ($s->{purity} and $s->{level} > 0) {
	    $out = ($realtype eq 'HASH')  ? '{}' :
	      ($realtype eq 'ARRAY') ? '[]' :
		'do{my $o}' ;
	    push @post, $name . " = " . $s->{seen}{$id}[0];
	  }
	  else {
	    $out = $s->{seen}{$id}[0];
	    if ($name =~ /^([\@\%])/) {
	      my $start = $1;
	      if ($out =~ /^\\$start/) {
		$out = substr($out, 1);
	      }
	      else {
		$out = $start . '{' . $out . '}';
	      }
	    }
          }
	  return $out;
#        }
      }
      else {
        # store our name
        $s->{seen}{$id} = [ (($name =~ /^[@%]/)     ? ('\\' . $name ) :
			     ($realtype eq 'CODE' and
			      $name =~ /^[*](.*)$/) ? ('\\&' . $1 )   :
			     $name          ),
			    $val ];
      }
    }

    if ($realpack and $realpack eq 'Regexp') {
	$out = "$val";
	$out =~ s,/,\\/,g;
	return "qr/$out/";
    }

    # If purity is not set and maxdepth is set, then check depth: 
    # if we have reached maximum depth, return the string
    # representation of the thing we are currently examining
    # at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)'). 
    if (!$s->{purity}
	and $s->{maxdepth} > 0
	and $s->{level} >= $s->{maxdepth})
    {
      return qq['$val'];
    }

    # we have a blessed ref
    if ($realpack) {
      $out = $s->{'bless'} . '( ';
      $blesspad = $s->{apad};
      $s->{apad} .= '       ' if ($s->{indent} >= 2);
    }

    $s->{level}++;
    $ipad = $s->{xpad} x $s->{level};

    if ($realtype eq 'SCALAR' || $realtype eq 'REF') {
      if ($realpack) {
	$out .= 'do{\\(my $o = ' . $s->_dump($$val, "\${$name}") . ')}';
      }
      else {
	$out .= '\\' . $s->_dump($$val, "\${$name}");
      }
    }
    elsif ($realtype eq 'GLOB') {
	$out .= '\\' . $s->_dump($$val, "*{$name}");
    }
    elsif ($realtype eq 'ARRAY') {
      my($v, $pad, $mname);
      my($i) = 0;
      $out .= ($name =~ /^\@/) ? '(' : '[';
      $pad = $s->{sep} . $s->{pad} . $s->{apad};
      ($name =~ /^\@(.*)$/) ? ($mname = "\$" . $1) : 
	# omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar}
	($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) :
	  ($mname = $name . '->');
      $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/;
      for $v (@$val) {
	$sname = $mname . '[' . $i . ']';
	$out .= $pad . $ipad . '#' . $i if $s->{indent} >= 3;
	$out .= $pad . $ipad . $s->_dump($v, $sname);
	$out .= "," if $i++ < $#$val;
      }
      $out .= $pad . ($s->{xpad} x ($s->{level} - 1)) if $i;
      $out .= ($name =~ /^\@/) ? ')' : ']';
    }
    elsif ($realtype eq 'HASH') {
      my($k, $v, $pad, $lpad, $mname);
      $out .= ($name =~ /^\%/) ? '(' : '{';
      $pad = $s->{sep} . $s->{pad} . $s->{apad};
      $lpad = $s->{apad};
      ($name =~ /^\%(.*)$/) ? ($mname = "\$" . $1) :
	# omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar}
	($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) :
	  ($mname = $name . '->');
      $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/;
      while (($k, $v) = each %$val) {
	my $nk = $s->_dump($k, "");
	$nk = $1 if !$s->{quotekeys} and $nk =~ /^[\"\']([A-Za-z_]\w*)[\"\']$/;
	$sname = $mname . '{' . $nk . '}';
	$out .= $pad . $ipad . $nk . " => ";

	# temporarily alter apad
	$s->{apad} .= (" " x (length($nk) + 4)) if $s->{indent} >= 2;
	$out .= $s->_dump($val->{$k}, $sname) . ",";
	$s->{apad} = $lpad if $s->{indent} >= 2;
      }
      if (substr($out, -1) eq ',') {
	chop $out;
	$out .= $pad . ($s->{xpad} x ($s->{level} - 1));
      }
      $out .= ($name =~ /^\%/) ? ')' : '}';
    }
    elsif ($realtype eq 'CODE') {
      $out .= 'sub { "DUMMY" }';
      carp "Encountered CODE ref, using dummy placeholder" if $s->{purity};
    }
    else {
      croak "Can\'t handle $realtype type.";
    }
    
    if ($realpack) { # we have a blessed ref
      $out .= ', \'' . $realpack . '\'' . ' )';
      $out .= '->' . $s->{toaster} . '()'  if $s->{toaster} ne '';
      $s->{apad} = $blesspad;
    }
    $s->{level}--;

  }
  else {                                 # simple scalar

    my $ref = \$_[1];
    # first, catalog the scalar
    if ($name ne '') {
      ($id) = ("$ref" =~ /\(([^\(]*)\)$/);
      if (exists $s->{seen}{$id}) {
        if ($s->{seen}{$id}[2]) {
	  $out = $s->{seen}{$id}[0];
	  #warn "[<$out]\n";
	  return "\${$out}";
	}
      }
      else {
	#warn "[>\\$name]\n";
	$s->{seen}{$id} = ["\\$name", $ref];
      }
    }
    if (ref($ref) eq 'GLOB' or "$ref" =~ /=GLOB\([^()]+\)$/) {  # glob
      my $name = substr($val, 1);
      if ($name =~ /^[A-Za-z_][\w:]*$/) {
	$name =~ s/^main::/::/;
	$sname = $name;
      }
      else {
	$sname = $s->_dump($name, "");
	$sname = '{' . $sname . '}';
      }
      if ($s->{purity}) {
	my $k;
	local ($s->{level}) = 0;
	for $k (qw(SCALAR ARRAY HASH)) {
	  my $gval = *$val{$k};
	  next unless defined $gval;
	  next if $k eq "SCALAR" && ! defined $$gval;  # always there

	  # _dump can push into @post, so we hold our place using $postlen
	  my $postlen = scalar @post;
	  $post[$postlen] = "\*$sname = ";
	  local ($s->{apad}) = " " x length($post[$postlen]) if $s->{indent} >= 2;
	  $post[$postlen] .= $s->_dump($gval, "\*$sname\{$k\}");
	}
      }
      $out .= '*' . $sname;
    }
    elsif (!defined($val)) {
      $out .= "undef";
    }
    elsif ($val =~ /^(?:0|-?[1-9]\d{0,8})$/) { # safe decimal number
      $out .= $val;
    }
    else {				 # string
      if ($s->{useqq}) {
	$out .= qquote($val, $s->{useqq});
      }
      else {
	$val =~ s/([\\\'])/\\$1/g;
	$out .= '\'' . $val .  '\'';
      }
    }
  }
  if ($id) {
    # if we made it this far, $id was added to seen list at current
    # level, so remove it to get deep copies
    if ($s->{deepcopy}) {
      delete($s->{seen}{$id});
    }
    elsif ($name) {
      $s->{seen}{$id}[2] = 1;
    }
  }
  return $out;
}
  
#
# non-OO style of earlier version
#
sub Dumper {
  return Data::Dumper->Dump([@_]);
}

# compat stub
sub DumperX {
  return Data::Dumper->Dumpxs([@_], []);
}

sub Dumpf { return Data::Dumper->Dump(@_) }

sub Dumpp { print Data::Dumper->Dump(@_) }

#
# reset the "seen" cache 
#
sub Reset {
  my($s) = shift;
  $s->{seen} = {};
  return $s;
}

sub Indent {
  my($s, $v) = @_;
  if (defined($v)) {
    if ($v == 0) {
      $s->{xpad} = "";
      $s->{sep} = "";
    }
    else {
      $s->{xpad} = "  ";
      $s->{sep} = "\n";
    }
    $s->{indent} = $v;
    return $s;
  }
  else {
    return $s->{indent};
  }
}

sub Pad {
  my($s, $v) = @_;
  defined($v) ? (($s->{pad} = $v), return $s) : $s->{pad};
}

sub Varname {
  my($s, $v) = @_;
  defined($v) ? (($s->{varname} = $v), return $s) : $s->{varname};
}

sub Purity {
  my($s, $v) = @_;
  defined($v) ? (($s->{purity} = $v), return $s) : $s->{purity};
}

sub Useqq {
  my($s, $v) = @_;
  defined($v) ? (($s->{useqq} = $v), return $s) : $s->{useqq};
}

sub Terse {
  my($s, $v) = @_;
  defined($v) ? (($s->{terse} = $v), return $s) : $s->{terse};
}

sub Freezer {
  my($s, $v) = @_;
  defined($v) ? (($s->{freezer} = $v), return $s) : $s->{freezer};
}

sub Toaster {
  my($s, $v) = @_;
  defined($v) ? (($s->{toaster} = $v), return $s) : $s->{toaster};
}

sub Deepcopy {
  my($s, $v) = @_;
  defined($v) ? (($s->{deepcopy} = $v), return $s) : $s->{deepcopy};
}

sub Quotekeys {
  my($s, $v) = @_;
  defined($v) ? (($s->{quotekeys} = $v), return $s) : $s->{quotekeys};
}

sub Bless {
  my($s, $v) = @_;
  defined($v) ? (($s->{'bless'} = $v), return $s) : $s->{'bless'};
}

sub Maxdepth {
  my($s, $v) = @_;
  defined($v) ? (($s->{'maxdepth'} = $v), return $s) : $s->{'maxdepth'};
}


# used by qquote below
my %esc = (  
    "\a" => "\\a",
    "\b" => "\\b",
    "\t" => "\\t",
    "\n" => "\\n",
    "\f" => "\\f",
    "\r" => "\\r",
    "\e" => "\\e",
);

# put a string value in double quotes
sub qquote {
  local($_) = shift;
  s/([\\\"\@\$])/\\$1/g;
  return qq("$_") unless 
    /[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~]/;  # fast exit

  my $high = shift || "";
  s/([\a\b\t\n\f\r\e])/$esc{$1}/g;

  if (ord('^')==94)  { # ascii
    # no need for 3 digits in escape for these
    s/([\0-\037])(?!\d)/'\\'.sprintf('%o',ord($1))/eg;
    s/([\0-\037\177])/'\\'.sprintf('%03o',ord($1))/eg;
    # all but last branch below not supported --BEHAVIOR SUBJECT TO CHANGE--
    if ($high eq "iso8859") {
      s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg;
    } elsif ($high eq "utf8") {
#     use utf8;
#     $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge;
    } elsif ($high eq "8bit") {
        # leave it as it is
    } else {
      s/([\200-\377])/'\\'.sprintf('%03o',ord($1))/eg;
    }
  }
  else { # ebcdic
      s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])(?!\d)}
       {my $v = ord($1); '\\'.sprintf(($v <= 037 ? '%o' : '%03o'), $v)}eg;
      s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])}
       {'\\'.sprintf('%03o',ord($1))}eg;
  }

  return qq("$_");
}

1;
__END__

=head1 NAME

Data::Dumper - stringified perl data structures, suitable for both printing and C<eval>


=head1 SYNOPSIS

    use Data::Dumper;

    # simple procedural interface
    print Dumper($foo, $bar);

    # extended usage with names
    print Data::Dumper->Dump([$foo, $bar], [qw(foo *ary)]);

    # configuration variables
    {
      local $Data::Dump::Purity = 1;
      eval Data::Dumper->Dump([$foo, $bar], [qw(foo *ary)]);
    }

    # OO usage
    $d = Data::Dumper->new([$foo, $bar], [qw(foo *ary)]);
       ...
    print $d->Dump;
       ...
    $d->Purity(1)->Terse(1)->Deepcopy(1);
    eval $d->Dump;


=head1 DESCRIPTION

Given a list of scalars or reference variables, writes out their contents in
perl syntax. The references can also be objects.  The contents of each
variable is output in a single Perl statement.  Handles self-referential
structures correctly.

The return value can be C<eval>ed to get back an identical copy of the
original reference structure.

Any references that are the same as one of those passed in will be named
C<$VAR>I<n> (where I<n> is a numeric suffix), and other duplicate references
to substructures within C<$VAR>I<n> will be appropriately labeled using arrow
notation.  You can specify names for individual values to be dumped if you
use the C<Dump()> method, or you can change the default C<$VAR> prefix to
something else.  See C<$Data::Dumper::Varname> and C<$Data::Dumper::Terse>
below.

The default output of self-referential structures can be C<eval>ed, but the
nested references to C<$VAR>I<n> will be undefined, since a recursive
structure cannot be constructed using one Perl statement.  You should set the
C<Purity> flag to 1 to get additional statements that will correctly fill in
these references.

In the extended usage form, the references to be dumped can be given
user-specified names.  If a name begins with a C<*>, the output will 
describe the dereferenced type of the supplied reference for hashes and
arrays, and coderefs.  Output of names will be avoided where possible if
the C<Terse> flag is set.

In many cases, methods that are used to set the internal state of the
object will return the object itself, so method calls can be conveniently
chained together.

Several styles of output are possible, all controlled by setting
the C<Indent> flag.  See L<Configuration Variables or Methods> below 
for details.


=head2 Methods

=over 4

=item I<PACKAGE>->new(I<ARRAYREF [>, I<ARRAYREF]>)

Returns a newly created C<Data::Dumper> object.  The first argument is an
anonymous array of values to be dumped.  The optional second argument is an
anonymous array of names for the values.  The names need not have a leading
C<$> sign, and must be comprised of alphanumeric characters.  You can begin
a name with a C<*> to specify that the dereferenced type must be dumped
instead of the reference itself, for ARRAY and HASH references.

The prefix specified by C<$Data::Dumper::Varname> will be used with a
numeric suffix if the name for a value is undefined.

Data::Dumper will catalog all references encountered while dumping the
values. Cross-references (in the form of names of substructures in perl
syntax) will be inserted at all possible points, preserving any structural
interdependencies in the original set of values.  Structure traversal is
depth-first,  and proceeds in order from the first supplied value to
the last.

=item I<$OBJ>->Dump  I<or>  I<PACKAGE>->Dump(I<ARRAYREF [>, I<ARRAYREF]>)

Returns the stringified form of the values stored in the object (preserving
the order in which they were supplied to C<new>), subject to the
configuration options below.  In a list context, it returns a list
of strings corresponding to the supplied values.

The second form, for convenience, simply calls the C<new> method on its
arguments before dumping the object immediately.

=item I<$OBJ>->Seen(I<[HASHREF]>)

Queries or adds to the internal table of already encountered references.
You must use C<Reset> to explicitly clear the table if needed.  Such
references are not dumped; instead, their names are inserted wherever they
are encountered subsequently.  This is useful especially for properly
dumping subroutine references.

Expects a anonymous hash of name => value pairs.  Same rules apply for names
as in C<new>.  If no argument is supplied, will return the "seen" list of
name => value pairs, in a list context.  Otherwise, returns the object
itself.

=item I<$OBJ>->Values(I<[ARRAYREF]>)

Queries or replaces the internal array of values that will be dumped.
When called without arguments, returns the values.  Otherwise, returns the
object itself.

=item I<$OBJ>->Names(I<[ARRAYREF]>)

Queries or replaces the internal array of user supplied names for the values
that will be dumped.  When called without arguments, returns the names.
Otherwise, returns the object itself.

=item I<$OBJ>->Reset

Clears the internal table of "seen" references and returns the object
itself.

=back

=head2 Functions

=over 4

=item Dumper(I<LIST>)

Returns the stringified form of the values in the list, subject to the
configuration options below.  The values will be named C<$VAR>I<n> in the
output, where I<n> is a numeric suffix.  Will return a list of strings
in a list context.

=back

=head2 Configuration Variables or Methods

Several configuration variables can be used to control the kind of output
generated when using the procedural interface.  These variables are usually
C<local>ized in a block so that other parts of the code are not affected by
the change.  

These variables determine the default state of the object created by calling
the C<new> method, but cannot be used to alter the state of the object
thereafter.  The equivalent method names should be used instead to query
or set the internal state of the object.

The method forms return the object itself when called with arguments,
so that they can be chained together nicely.

=over 4

=item $Data::Dumper::Indent  I<or>  I<$OBJ>->Indent(I<[NEWVAL]>)

Controls the style of indentation.  It can be set to 0, 1, 2 or 3.  Style 0
spews output without any newlines, indentation, or spaces between list
items.  It is the most compact format possible that can still be called
valid perl.  Style 1 outputs a readable form with newlines but no fancy
indentation (each level in the structure is simply indented by a fixed
amount of whitespace).  Style 2 (the default) outputs a very readable form
which takes into account the length of hash keys (so the hash value lines
up).  Style 3 is like style 2, but also annotates the elements of arrays
with their index (but the comment is on its own line, so array output
consumes twice the number of lines).  Style 2 is the default.

=item $Data::Dumper::Purity  I<or>  I<$OBJ>->Purity(I<[NEWVAL]>)

Controls the degree to which the output can be C<eval>ed to recreate the
supplied reference structures.  Setting it to 1 will output additional perl
statements that will correctly recreate nested references.  The default is
0.

=item $Data::Dumper::Pad  I<or>  I<$OBJ>->Pad(I<[NEWVAL]>)

Specifies the string that will be prefixed to every line of the output.
Empty string by default.

=item $Data::Dumper::Varname  I<or>  I<$OBJ>->Varname(I<[NEWVAL]>)

Contains the prefix to use for tagging variable names in the output. The
default is "VAR".

=item $Data::Dumper::Useqq  I<or>  I<$OBJ>->Useqq(I<[NEWVAL]>)

When set, enables the use of double quotes for representing string values.
Whitespace other than space will be represented as C<[\n\t\r]>, "unsafe"
characters will be backslashed, and unprintable characters will be output as
quoted octal integers.  Since setting this variable imposes a performance
penalty, the default is 0.  C<Dump()> will run slower if this flag is set,
since the fast XSUB implementation doesn't support it yet.

=item $Data::Dumper::Terse  I<or>  I<$OBJ>->Terse(I<[NEWVAL]>)

When set, Data::Dumper will emit single, non-self-referential values as
atoms/terms rather than statements.  This means that the C<$VAR>I<n> names
will be avoided where possible, but be advised that such output may not
always be parseable by C<eval>.

=item $Data::Dumper::Freezer  I<or>  $I<OBJ>->Freezer(I<[NEWVAL]>)

Can be set to a method name, or to an empty string to disable the feature.
Data::Dumper will invoke that method via the object before attempting to
stringify it.  This method can alter the contents of the object (if, for
instance, it contains data allocated from C), and even rebless it in a
different package.  The client is responsible for making sure the specified
method can be called via the object, and that the object ends up containing
only perl data types after the method has been called.  Defaults to an empty
string.

=item $Data::Dumper::Toaster  I<or>  $I<OBJ>->Toaster(I<[NEWVAL]>)

Can be set to a method name, or to an empty string to disable the feature.
Data::Dumper will emit a method call for any objects that are to be dumped
using the syntax C<bless(DATA, CLASS)->METHOD()>.  Note that this means that
the method specified will have to perform any modifications required on the
object (like creating new state within it, and/or reblessing it in a
different package) and then return it.  The client is responsible for making
sure the method can be called via the object, and that it returns a valid
object.  Defaults to an empty string.

=item $Data::Dumper::Deepcopy  I<or>  $I<OBJ>->Deepcopy(I<[NEWVAL]>)

Can be set to a boolean value to enable deep copies of structures.
Cross-referencing will then only be done when absolutely essential
(i.e., to break reference cycles).  Default is 0.

=item $Data::Dumper::Quotekeys  I<or>  $I<OBJ>->Quotekeys(I<[NEWVAL]>)

Can be set to a boolean value to control whether hash keys are quoted.
A false value will avoid quoting hash keys when it looks like a simple
string.  Default is 1, which will always enclose hash keys in quotes.

=item $Data::Dumper::Bless  I<or>  $I<OBJ>->Bless(I<[NEWVAL]>)

Can be set to a string that specifies an alternative to the C<bless>
builtin operator used to create objects.  A function with the specified
name should exist, and should accept the same arguments as the builtin.
Default is C<bless>.

=item $Data::Dumper::Maxdepth  I<or>  $I<OBJ>->Maxdepth(I<[NEWVAL]>)

Can be set to a positive integer that specifies the depth beyond which
which we don't venture into a structure.  Has no effect when
C<Data::Dumper::Purity> is set.  (Useful in debugger when we often don't
want to see more than enough).  Default is 0, which means there is 
no maximum depth. 

=back

=head2 Exports

=over 4

=item Dumper

=back

=head1 EXAMPLES

Run these code snippets to get a quick feel for the behavior of this
module.  When you are through with these examples, you may want to
add or change the various configuration variables described above,
to see their behavior.  (See the testsuite in the Data::Dumper
distribution for more examples.)


    use Data::Dumper;

    package Foo;
    sub new {bless {'a' => 1, 'b' => sub { return "foo" }}, $_[0]};

    package Fuz;                       # a weird REF-REF-SCALAR object
    sub new {bless \($_ = \ 'fu\'z'), $_[0]};

    package main;
    $foo = Foo->new;
    $fuz = Fuz->new;
    $boo = [ 1, [], "abcd", \*foo,
             {1 => 'a', 023 => 'b', 0x45 => 'c'}, 
             \\"p\q\'r", $foo, $fuz];

    ########
    # simple usage
    ########

    $bar = eval(Dumper($boo));
    print($@) if $@;
    print Dumper($boo), Dumper($bar);  # pretty print (no array indices)

    $Data::Dumper::Terse = 1;          # don't output names where feasible
    $Data::Dumper::Indent = 0;         # turn off all pretty print
    print Dumper($boo), "\n";

    $Data::Dumper::Indent = 1;         # mild pretty print
    print Dumper($boo);

    $Data::Dumper::Indent = 3;         # pretty print with array indices
    print Dumper($boo);

    $Data::Dumper::Useqq = 1;          # print strings in double quotes
    print Dumper($boo);


    ########
    # recursive structures
    ########

    @c = ('c');
    $c = \@c;
    $b = {};
    $a = [1, $b, $c];
    $b->{a} = $a;
    $b->{b} = $a->[1];
    $b->{c} = $a->[2];
    print Data::Dumper->Dump([$a,$b,$c], [qw(a b c)]);


    $Data::Dumper::Purity = 1;         # fill in the holes for eval
    print Data::Dumper->Dump([$a, $b], [qw(*a b)]); # print as @a
    print Data::Dumper->Dump([$b, $a], [qw(*b a)]); # print as %b


    $Data::Dumper::Deepcopy = 1;       # avoid cross-refs
    print Data::Dumper->Dump([$b, $a], [qw(*b a)]);


    $Data::Dumper::Purity = 0;         # avoid cross-refs
    print Data::Dumper->Dump([$b, $a], [qw(*b a)]);

    ########
    # deep structures
    ########

    $a = "pearl";
    $b = [ $a ];
    $c = { 'b' => $b };
    $d = [ $c ];
    $e = { 'd' => $d };
    $f = { 'e' => $e };
    print Data::Dumper->Dump([$f], [qw(f)]);

    $Data::Dumper::Maxdepth = 3;       # no deeper than 3 refs down
    print Data::Dumper->Dump([$f], [qw(f)]);


    ########
    # object-oriented usage
    ########

    $d = Data::Dumper->new([$a,$b], [qw(a b)]);
    $d->Seen({'*c' => $c});            # stash a ref without printing it
    $d->Indent(3);
    print $d->Dump;
    $d->Reset->Purity(0);              # empty the seen cache
    print join "----\n", $d->Dump;


    ########
    # persistence
    ########

    package Foo;
    sub new { bless { state => 'awake' }, shift }
    sub Freeze {
        my $s = shift;
	print STDERR "preparing to sleep\n";
	$s->{state} = 'asleep';
	return bless $s, 'Foo::ZZZ';
    }

    package Foo::ZZZ;
    sub Thaw {
        my $s = shift;
	print STDERR "waking up\n";
	$s->{state} = 'awake';
	return bless $s, 'Foo';
    }

    package Foo;
    use Data::Dumper;
    $a = Foo->new;
    $b = Data::Dumper->new([$a], ['c']);
    $b->Freezer('Freeze');
    $b->Toaster('Thaw');
    $c = $b->Dump;
    print $c;
    $d = eval $c;
    print Data::Dumper->Dump([$d], ['d']);


    ########
    # symbol substitution (useful for recreating CODE refs)
    ########

    sub foo { print "foo speaking\n" }
    *other = \&foo;
    $bar = [ \&other ];
    $d = Data::Dumper->new([\&other,$bar],['*other','bar']);
    $d->Seen({ '*foo' => \&foo });
    print $d->Dump;


=head1 BUGS

Due to limitations of Perl subroutine call semantics, you cannot pass an
array or hash.  Prepend it with a C<\> to pass its reference instead.  This
will be remedied in time, with the arrival of prototypes in later versions
of Perl.  For now, you need to use the extended usage form, and prepend the
name with a C<*> to output it as a hash or array.

C<Data::Dumper> cheats with CODE references.  If a code reference is
encountered in the structure being processed, an anonymous subroutine that
contains the string '"DUMMY"' will be inserted in its place, and a warning
will be printed if C<Purity> is set.  You can C<eval> the result, but bear
in mind that the anonymous sub that gets created is just a placeholder.
Someday, perl will have a switch to cache-on-demand the string
representation of a compiled piece of code, I hope.  If you have prior
knowledge of all the code refs that your data structures are likely
to have, you can use the C<Seen> method to pre-seed the internal reference
table and make the dumped output point to them, instead.  See L<EXAMPLES>
above.

The C<Useqq> flag makes Dump() run slower, since the XSUB implementation
does not support it.

SCALAR objects have the weirdest looking C<bless> workaround.


=head1 AUTHOR

Gurusamy Sarathy        gsar@activestate.com

Copyright (c) 1996-98 Gurusamy Sarathy. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.


=head1 VERSION

Version 2.11   (unreleased)

=head1 SEE ALSO

perl(1)

=cut
List/Util                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                #
# Documentation is at the __END__
#

package DB;

# "private" globals

my ($running, $ready, $deep, $usrctxt, $evalarg, 
    @stack, @saved, @skippkg, @clients);
my $preeval = {};
my $posteval = {};
my $ineval = {};

####
#
# Globals - must be defined at startup so that clients can refer to 
# them right after a C<require DB;>
#
####

BEGIN {

  # these are hardcoded in perl source (some are magical)

  $DB::sub = '';        # name of current subroutine
  %DB::sub = ();        # "filename:fromline-toline" for every known sub
  $DB::single = 0;      # single-step flag (set it to 1 to enable stops in BEGIN/use)
  $DB::signal = 0;      # signal flag (will cause a stop at the next line)
  $DB::trace = 0;       # are we tracing through subroutine calls?
  @DB::args = ();       # arguments of current subroutine or @ARGV array
  @DB::dbline = ();     # list of lines in currently loaded file
  %DB::dbline = ();     # actions in current file (keyed by line number)
  @DB::ret = ();        # return value of last sub executed in list context
  $DB::ret = '';        # return value of last sub executed in scalar context

  # other "public" globals  

  $DB::package = '';    # current package space
  $DB::filename = '';   # current filename
  $DB::subname = '';    # currently executing sub (fullly qualified name)
  $DB::lineno = '';     # current line number

  $DB::VERSION = $DB::VERSION = '1.0';

  # initialize private globals to avoid warnings

  $running = 1;         # are we running, or are we stopped?
  @stack = (0);
  @clients = ();
  $deep = 100;
  $ready = 0;
  @saved = ();
  @skippkg = ();
  $usrctxt = '';
  $evalarg = '';
}

####
# entry point for all subroutine calls
#
sub sub {
  push(@stack, $DB::single);
  $DB::single &= 1;
  $DB::single |= 4 if $#stack == $deep;
#  print $DB::sub, "\n";
  if ($DB::sub =~ /(?:^|::)DESTROY$/ or not defined wantarray) {
    &$DB::sub;
    $DB::single |= pop(@stack);
    $DB::ret = undef;
  }
  elsif (wantarray) {
    @DB::ret = &$DB::sub;
    $DB::single |= pop(@stack);
    @DB::ret;
  }
  else {
    $DB::ret = &$DB::sub;
    $DB::single |= pop(@stack);
    $DB::ret;
  }
}

####
# this is called by perl for every statement
#
sub DB {
  return unless $ready;
  &save;
  ($DB::package, $DB::filename, $DB::lineno) = caller;

  return if @skippkg and grep { $_ eq $DB::package } @skippkg;

  $usrctxt = "package $DB::package;";		# this won't let them modify, alas
  local(*DB::dbline) = "::_<$DB::filename";

  # we need to check for pseudofiles on Mac OS (these are files
  # not attached to a filename, but instead stored in Dev:Pseudo)
  # since this is done late, $DB::filename will be "wrong" after
  # skippkg
  if ($^O eq 'MacOS' && $#DB::dbline < 0) {
    $DB::filename = 'Dev:Pseudo';
    *DB::dbline = "::_<$DB::filename";
  }

  my ($stop, $action);
  if (($stop,$action) = split(/\0/,$DB::dbline{$DB::lineno})) {
    if ($stop eq '1') {
      $DB::signal |= 1;
    }
    else {
      $stop = 0 unless $stop;			# avoid un_init warning
      $evalarg = "\$DB::signal |= do { $stop; }"; &eval;
      $DB::dbline{$DB::lineno} =~ s/;9($|\0)/$1/;    # clear any temp breakpt
    }
  }
  if ($DB::single || $DB::trace || $DB::signal) {
    $DB::subname = ($DB::sub =~ /\'|::/) ? $DB::sub : "${DB::package}::$DB::sub"; #';
    DB->loadfile($DB::filename, $DB::lineno);
  }
  $evalarg = $action, &eval if $action;
  if ($DB::single || $DB::signal) {
    _outputall($#stack . " levels deep in subroutine calls.\n") if $DB::single & 4;
    $DB::single = 0;
    $DB::signal = 0;
    $running = 0;
    
    &eval if ($evalarg = DB->prestop);
    my $c;
    for $c (@clients) {
      # perform any client-specific prestop actions
      &eval if ($evalarg = $c->cprestop);
      
      # Now sit in an event loop until something sets $running
      do {
	$c->idle;                     # call client event loop; must not block
	if ($running == 2) {          # client wants something eval-ed
	  &eval if ($evalarg = $c->evalcode);
	  $running = 0;
	}
      } until $running;
      
      # perform any client-specific poststop actions
      &eval if ($evalarg = $c->cpoststop);
    }
    &eval if ($evalarg = DB->poststop);
  }
  ($@, $!, $,, $/, $\, $^W) = @saved;
  ();
}
  
####
# this takes its argument via $evalarg to preserve current @_
#    
sub eval {
  ($@, $!, $,, $/, $\, $^W) = @saved;
  eval "$usrctxt $evalarg; &DB::save";
  _outputall($@) if $@;
}

###############################################################################
#         no compile-time subroutine call allowed before this point           #
###############################################################################

use strict;                # this can run only after DB() and sub() are defined

sub save {
  @saved = ($@, $!, $,, $/, $\, $^W);
  $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
}

sub catch {
  for (@clients) { $_->awaken; }
  $DB::signal = 1;
  $ready = 1;
}

####
#
# Client callable (read inheritable) methods defined after this point
#
####

sub register {
  my $s = shift;
  $s = _clientname($s) if ref($s);
  push @clients, $s;
}

sub done {
  my $s = shift;
  $s = _clientname($s) if ref($s);
  @clients = grep {$_ ne $s} @clients;
  $s->cleanup;
#  $running = 3 unless @clients;
  exit(0) unless @clients;
}

sub _clientname {
  my $name = shift;
  "$name" =~ /^(.+)=[A-Z]+\(.+\)$/;
  return $1;
}

sub next {
  my $s = shift;
  $DB::single = 2;
  $running = 1;
}

sub step {
  my $s = shift;
  $DB::single = 1;
  $running = 1;
}

sub cont {
  my $s = shift;
  my $i = shift;
  $s->set_tbreak($i) if $i;
  for ($i = 0; $i <= $#stack;) {
	$stack[$i++] &= ~1;
  }
  $DB::single = 0;
  $running = 1;
}

####
# XXX caller must experimentally determine $i (since it depends
# on how many client call frames are between this call and the DB call).
# Such is life.
#
sub ret {
  my $s = shift;
  my $i = shift;      # how many levels to get to DB sub
  $i = 0 unless defined $i;
  $stack[$#stack-$i] |= 1;
  $DB::single = 0;
  $running = 1;
}

####
# XXX caller must experimentally determine $start (since it depends
# on how many client call frames are between this call and the DB call).
# Such is life.
#
sub backtrace {
  my $self = shift;
  my $start = shift;
  my($p,$f,$l,$s,$h,$w,$e,$r,$a, @a, @ret,$i);
  $start = 1 unless $start;
  for ($i = $start; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) {
    @a = @DB::args;
    for (@a) {
      s/'/\\'/g;
      s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
      s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
      s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
    }
    $w = $w ? '@ = ' : '$ = ';
    $a = $h ? '(' . join(', ', @a) . ')' : '';
    $e =~ s/\n\s*\;\s*\Z// if $e;
    $e =~ s/[\\\']/\\$1/g if $e;
    if ($r) {
      $s = "require '$e'";
    } elsif (defined $r) {
      $s = "eval '$e'";
    } elsif ($s eq '(eval)') {
      $s = "eval {...}";
    }
    $f = "file `$f'" unless $f eq '-e';
    push @ret, "$w&$s$a from $f line $l";
    last if $DB::signal;
  }
  return @ret;
}

sub _outputall {
  my $c;
  for $c (@clients) {
    $c->output(@_);
  }
}

sub trace_toggle {
  my $s = shift;
  $DB::trace = !$DB::trace;
}


####
# without args: returns all defined subroutine names
# with subname args: returns a listref [file, start, end]
#
sub subs {
  my $s = shift;
  if (@_) {
    my(@ret) = ();
    while (@_) {
      my $name = shift;
      push @ret, [$DB::sub{$name} =~ /^(.*)\:(\d+)-(\d+)$/] 
	if exists $DB::sub{$name};
    }
    return @ret;
  }
  return keys %DB::sub;
}

####
# first argument is a filename whose subs will be returned
# if a filename is not supplied, all subs in the current
# filename are returned.
#
sub filesubs {
  my $s = shift;
  my $fname = shift;
  $fname = $DB::filename unless $fname;
  return grep { $DB::sub{$_} =~ /^$fname/ } keys %DB::sub;
}

####
# returns a list of all filenames that DB knows about
#
sub files {
  my $s = shift;
  my(@f) = grep(m|^_<|, keys %main::);
  return map { substr($_,2) } @f;
}

####
# returns reference to an array holding the lines in currently
# loaded file
#
sub lines {
  my $s = shift;
  return \@DB::dbline;
}

####
# loadfile($file, $line)
#
sub loadfile {
  my $s = shift;
  my($file, $line) = @_;
  if (!defined $main::{'_<' . $file}) {
    my $try;
    if (($try) = grep(m|^_<.*$file|, keys %main::)) {  
      $file = substr($try,2);
    }
  }
  if (defined($main::{'_<' . $file})) {
    my $c;
#    _outputall("Loading file $file..");
    *DB::dbline = "::_<$file";
    $DB::filename = $file;
    for $c (@clients) {
#      print "2 ", $file, '|', $line, "\n";
      $c->showfile($file, $line);
    }
    return $file;
  }
  return undef;
}

sub lineevents {
  my $s = shift;
  my $fname = shift;
  my(%ret) = ();
  my $i;
  $fname = $DB::filename unless $fname;
  local(*DB::dbline) = "::_<$fname";
  for ($i = 1; $i <= $#DB::dbline; $i++) {
    $ret{$i} = [$DB::dbline[$i], split(/\0/, $DB::dbline{$i})] 
      if defined $DB::dbline{$i};
  }
  return %ret;
}

sub set_break {
  my $s = shift;
  my $i = shift;
  my $cond = shift;
  $i ||= $DB::lineno;
  $cond ||= '1';
  $i = _find_subline($i) if ($i =~ /\D/);
  $s->output("Subroutine not found.\n") unless $i;
  if ($i) {
    if ($DB::dbline[$i] == 0) {
      $s->output("Line $i not breakable.\n");
    }
    else {
      $DB::dbline{$i} =~ s/^[^\0]*/$cond/;
    }
  }
}

sub set_tbreak {
  my $s = shift;
  my $i = shift;
  $i = _find_subline($i) if ($i =~ /\D/);
  $s->output("Subroutine not found.\n") unless $i;
  if ($i) {
    if ($DB::dbline[$i] == 0) {
      $s->output("Line $i not breakable.\n");
    }
    else {
      $DB::dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
    }
  }
}

sub _find_subline {
  my $name = shift;
  $name =~ s/\'/::/;
  $name = "${DB::package}\:\:" . $name if $name !~ /::/;
  $name = "main" . $name if substr($name,0,2) eq "::";
  my($fname, $from, $to) = ($DB::sub{$name} =~ /^(.*):(\d+)-(\d+)$/);
  if ($from) {
    # XXX this needs local()-ization of some sort
    *DB::dbline = "::_<$fname";
    ++$from while $DB::dbline[$from] == 0 && $from < $to;
    return $from;
  }
  return undef;
}

sub clr_breaks {
  my $s = shift;
  my $i;
  if (@_) {
    while (@_) {
      $i = shift;
      $i = _find_subline($i) if ($i =~ /\D/);
      $s->output("Subroutine not found.\n") unless $i;
      if (defined $DB::dbline{$i}) {
        $DB::dbline{$i} =~ s/^[^\0]+//;
        if ($DB::dbline{$i} =~ s/^\0?$//) {
          delete $DB::dbline{$i};
        }
      }
    }
  }
  else {
    for ($i = 1; $i <= $#DB::dbline ; $i++) {
      if (defined $DB::dbline{$i}) {
        $DB::dbline{$i} =~ s/^[^\0]+//;
        if ($DB::dbline{$i} =~ s/^\0?$//) {
          delete $DB::dbline{$i};
        }
      }
    }
  }
}

sub set_action {
  my $s = shift;
  my $i = shift;
  my $act = shift;
  $i = _find_subline($i) if ($i =~ /\D/);
  $s->output("Subroutine not found.\n") unless $i;
  if ($i) {
    if ($DB::dbline[$i] == 0) {
      $s->output("Line $i not actionable.\n");
    }
    else {
      $DB::dbline{$i} =~ s/\0[^\0]*//;
      $DB::dbline{$i} .= "\0" . $act;
    }
  }
}

sub clr_actions {
  my $s = shift;
  my $i;
  if (@_) {
    while (@_) {
      my $i = shift;
      $i = _find_subline($i) if ($i =~ /\D/);
      $s->output("Subroutine not found.\n") unless $i;
      if ($i && $DB::dbline[$i] != 0) {
	$DB::dbline{$i} =~ s/\0[^\0]*//;
	delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//;
      }
    }
  }
  else {
    for ($i = 1; $i <= $#DB::dbline ; $i++) {
      if (defined $DB::dbline{$i}) {
	$DB::dbline{$i} =~ s/\0[^\0]*//;
	delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//;
      }
    }
  }
}

sub prestop {
  my ($client, $val) = @_;
  return defined($val) ? $preeval->{$client} = $val : $preeval->{$client};
}

sub poststop {
  my ($client, $val) = @_;
  return defined($val) ? $posteval->{$client} = $val : $posteval->{$client};
}

#
# "pure virtual" methods
#

# client-specific pre/post-stop actions.
sub cprestop {}
sub cpoststop {}

# client complete startup
sub awaken {}

sub skippkg {
  my $s = shift;
  push @skippkg, @_ if @_;
}

sub evalcode {
  my ($client, $val) = @_;
  if (defined $val) {
    $running = 2;    # hand over to DB() to evaluate in its context
    $ineval->{$client} = $val;
  }
  return $ineval->{$client};
}

sub ready {
  my $s = shift;
  return $ready = 1;
}

# stubs
    
sub init {}
sub stop {}
sub idle {}
sub cleanup {}
sub output {}

#
# client init
#
for (@clients) { $_->init }

$SIG{'INT'} = \&DB::catch;

# disable this if stepping through END blocks is desired
# (looks scary and deconstructivist with Swat)
END { $ready = 0 }

1;
__END__

=head1 NAME

DB - programmatic interface to the Perl debugging API (draft, subject to
change)

=head1 SYNOPSIS

    package CLIENT;
    use DB;
    @ISA = qw(DB);

    # these (inherited) methods can be called by the client

    CLIENT->register()      # register a client package name
    CLIENT->done()          # de-register from the debugging API
    CLIENT->skippkg('hide::hide')  # ask DB not to stop in this package
    CLIENT->cont([WHERE])       # run some more (until BREAK or another breakpt)
    CLIENT->step()              # single step
    CLIENT->next()              # step over
    CLIENT->ret()               # return from current subroutine
    CLIENT->backtrace()         # return the call stack description
    CLIENT->ready()             # call when client setup is done
    CLIENT->trace_toggle()      # toggle subroutine call trace mode
    CLIENT->subs([SUBS])        # return subroutine information
    CLIENT->files()             # return list of all files known to DB
    CLIENT->lines()             # return lines in currently loaded file
    CLIENT->loadfile(FILE,LINE) # load a file and let other clients know
    CLIENT->lineevents()        # return info on lines with actions
    CLIENT->set_break([WHERE],[COND])
    CLIENT->set_tbreak([WHERE])
    CLIENT->clr_breaks([LIST])
    CLIENT->set_action(WHERE,ACTION)
    CLIENT->clr_actions([LIST])
    CLIENT->evalcode(STRING)  # eval STRING in executing code's context
    CLIENT->prestop([STRING]) # execute in code context before stopping
    CLIENT->poststop([STRING])# execute in code context before resuming

    # These methods will be called at the appropriate times.
    # Stub versions provided do nothing.
    # None of these can block.

    CLIENT->init()          # called when debug API inits itself
    CLIENT->stop(FILE,LINE) # when execution stops
    CLIENT->idle()          # while stopped (can be a client event loop)
    CLIENT->cleanup()       # just before exit
    CLIENT->output(LIST)    # called to print any output that API must show

=head1 DESCRIPTION

Perl debug information is frequently required not just by debuggers,
but also by modules that need some "special" information to do their
job properly, like profilers.

This module abstracts and provides all of the hooks into Perl internal
debugging functionality, so that various implementations of Perl debuggers
(or packages that want to simply get at the "privileged" debugging data)
can all benefit from the development of this common code.  Currently used
by Swat, the perl/Tk GUI debugger.

Note that multiple "front-ends" can latch into this debugging API
simultaneously.  This is intended to facilitate things like
debugging with a command line and GUI at the same time, debugging 
debuggers etc.  [Sounds nice, but this needs some serious support -- GSAR]

In particular, this API does B<not> provide the following functions:

=over 4

=item *

data display

=item *

command processing

=item *

command alias management

=item *

user interface (tty or graphical)

=back

These are intended to be services performed by the clients of this API.

This module attempts to be squeaky clean w.r.t C<use strict;> and when
warnings are enabled.


=head2 Global Variables

The following "public" global names can be read by clients of this API.
Beware that these should be considered "readonly".

=over 8

=item  $DB::sub

Name of current executing subroutine.

=item  %DB::sub

The keys of this hash are the names of all the known subroutines.  Each value
is an encoded string that has the sprintf(3) format 
C<("%s:%d-%d", filename, fromline, toline)>.

=item  $DB::single

Single-step flag.  Will be true if the API will stop at the next statement.

=item  $DB::signal

Signal flag. Will be set to a true value if a signal was caught.  Clients may
check for this flag to abort time-consuming operations.

=item  $DB::trace

This flag is set to true if the API is tracing through subroutine calls.

=item  @DB::args

Contains the arguments of current subroutine, or the C<@ARGV> array if in the 
toplevel context.

=item  @DB::dbline

List of lines in currently loaded file.

=item  %DB::dbline

Actions in current file (keys are line numbers).  The values are strings that
have the sprintf(3) format C<("%s\000%s", breakcondition, actioncode)>. 

=item  $DB::package

Package namespace of currently executing code.

=item  $DB::filename

Currently loaded filename.

=item  $DB::subname

Fully qualified name of currently executing subroutine.

=item  $DB::lineno

Line number that will be executed next.

=back

=head2 API Methods

The following are methods in the DB base class.  A client must
access these methods by inheritance (*not* by calling them directly),
since the API keeps track of clients through the inheritance
mechanism.

=over 8

=item CLIENT->register()

register a client object/package

=item CLIENT->evalcode(STRING)

eval STRING in executing code context

=item CLIENT->skippkg('D::hide')

ask DB not to stop in these packages

=item CLIENT->run()

run some more (until a breakpt is reached)

=item CLIENT->step()

single step

=item CLIENT->next()

step over

=item CLIENT->done()

de-register from the debugging API

=back

=head2 Client Callback Methods

The following "virtual" methods can be defined by the client.  They will
be called by the API at appropriate points.  Note that unless specified
otherwise, the debug API only defines empty, non-functional default versions
of these methods.

=over 8

=item CLIENT->init()

Called after debug API inits itself.

=item CLIENT->prestop([STRING])

Usually inherited from DB package.  If no arguments are passed,
returns the prestop action string.

=item CLIENT->stop()

Called when execution stops (w/ args file, line).

=item CLIENT->idle()

Called while stopped (can be a client event loop).

=item CLIENT->poststop([STRING])

Usually inherited from DB package.  If no arguments are passed,
returns the poststop action string.

=item CLIENT->evalcode(STRING)

Usually inherited from DB package.  Ask for a STRING to be C<eval>-ed
in executing code context.

=item CLIENT->cleanup()

Called just before exit.

=item CLIENT->output(LIST)

Called when API must show a message (warnings, errors etc.).


=back


=head1 BUGS

The interface defined by this module is missing some of the later additions
to perl's debugging functionality.  As such, this interface should be considered
highly experimental and subject to change.

=head1 AUTHOR

Gurusamy Sarathy	gsar@activestate.com

This code heavily adapted from an early version of perl5db.pl attributable
to Larry Wall and the Perl Porters.

=cut
= -1 or
    substr($config_sh, 0, length($_[1])+2) eq "$_[1]='" or
    index($config_sh, "\n$_[1]=\"") != -1 or
    substr($config_sh, 0, length($_[1])+2) eq "$_[1]=\"" or
    $_[1] =~ /^(?                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                # DB_File.pm -- Perl 5 interface to Berkeley DB 
#
# written by Paul Marquess (Paul.Marquess@btinternet.com)
# last modified 17th December 2000
# version 1.75
#
#     Copyright (c) 1995-2000 Paul Marquess. All rights reserved.
#     This program is free software; you can redistribute it and/or
#     modify it under the same terms as Perl itself.


package DB_File::HASHINFO ;

require 5.003 ;

use warnings;
use strict;
use Carp;
require Tie::Hash;
@DB_File::HASHINFO::ISA = qw(Tie::Hash);

sub new
{
    my $pkg = shift ;
    my %x ;
    tie %x, $pkg ;
    bless \%x, $pkg ;
}


sub TIEHASH
{
    my $pkg = shift ;

    bless { VALID => { map {$_, 1} 
		       qw( bsize ffactor nelem cachesize hash lorder)
		     }, 
	    GOT   => {}
          }, $pkg ;
}


sub FETCH 
{  
    my $self  = shift ;
    my $key   = shift ;

    return $self->{GOT}{$key} if exists $self->{VALID}{$key}  ;

    my $pkg = ref $self ;
    croak "${pkg}::FETCH - Unknown element '$key'" ;
}


sub STORE 
{
    my $self  = shift ;
    my $key   = shift ;
    my $value = shift ;

    if ( exists $self->{VALID}{$key} )
    {
        $self->{GOT}{$key} = $value ;
        return ;
    }
    
    my $pkg = ref $self ;
    croak "${pkg}::STORE - Unknown element '$key'" ;
}

sub DELETE 
{
    my $self = shift ;
    my $key  = shift ;

    if ( exists $self->{VALID}{$key} )
    {
        delete $self->{GOT}{$key} ;
        return ;
    }
    
    my $pkg = ref $self ;
    croak "DB_File::HASHINFO::DELETE - Unknown element '$key'" ;
}

sub EXISTS
{
    my $self = shift ;
    my $key  = shift ;

    exists $self->{VALID}{$key} ;
}

sub NotHere
{
    my $self = shift ;
    my $method = shift ;

    croak ref($self) . " does not define the method ${method}" ;
}

sub FIRSTKEY { my $self = shift ; $self->NotHere("FIRSTKEY") }
sub NEXTKEY  { my $self = shift ; $self->NotHere("NEXTKEY") }
sub CLEAR    { my $self = shift ; $self->NotHere("CLEAR") }

package DB_File::RECNOINFO ;

use warnings;
use strict ;

@DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ;

sub TIEHASH
{
    my $pkg = shift ;

    bless { VALID => { map {$_, 1} 
		       qw( bval cachesize psize flags lorder reclen bfname )
		     },
	    GOT   => {},
          }, $pkg ;
}

package DB_File::BTREEINFO ;

use warnings;
use strict ;

@DB_File::BTREEINFO::ISA = qw(DB_File::HASHINFO) ;

sub TIEHASH
{
    my $pkg = shift ;

    bless { VALID => { map {$_, 1} 
		       qw( flags cachesize maxkeypage minkeypage psize 
			   compare prefix lorder )
	    	     },
	    GOT   => {},
          }, $pkg ;
}


package DB_File ;

use warnings;
use strict;
use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO 
            $db_version $use_XSLoader
           ) ;
use Carp;


$VERSION = "1.75" ;

#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
$DB_BTREE = new DB_File::BTREEINFO ;
$DB_HASH  = new DB_File::HASHINFO ;
$DB_RECNO = new DB_File::RECNOINFO ;

require Tie::Hash;
require Exporter;
use AutoLoader;
BEGIN {
    $use_XSLoader = 1 ;
    eval { require XSLoader } ;

    if ($@) {
        $use_XSLoader = 0 ;
        require DynaLoader;
        @ISA = qw(DynaLoader);
    }
}

push @ISA, qw(Tie::Hash Exporter);
@EXPORT = qw(
        $DB_BTREE $DB_HASH $DB_RECNO 

	BTREEMAGIC
	BTREEVERSION
	DB_LOCK
	DB_SHMEM
	DB_TXN
	HASHMAGIC
	HASHVERSION
	MAX_PAGE_NUMBER
	MAX_PAGE_OFFSET
	MAX_REC_NUMBER
	RET_ERROR
	RET_SPECIAL
	RET_SUCCESS
	R_CURSOR
	R_DUP
	R_FIRST
	R_FIXEDLEN
	R_IAFTER
	R_IBEFORE
	R_LAST
	R_NEXT
	R_NOKEY
	R_NOOVERWRITE
	R_PREV
	R_RECNOSYNC
	R_SETCURSOR
	R_SNAPSHOT
	__R_UNUSED

);

sub AUTOLOAD {
    my($constname);
    ($constname = $AUTOLOAD) =~ s/.*:://;
    local $! = 0;
    my $val = constant($constname, @_ ? $_[0] : 0);
    if ($! != 0) {
	if ($! =~ /Invalid/ || $!{EINVAL}) {
	    $AutoLoader::AUTOLOAD = $AUTOLOAD;
	    goto &AutoLoader::AUTOLOAD;
	}
	else {
	    my($pack,$file,$line) = caller;
	    croak "Your vendor has not defined DB macro $constname, used at $file line $line.
";
	}
    }
    eval "sub $AUTOLOAD { $val }";
    goto &$AUTOLOAD;
}


eval {
    # Make all Fcntl O_XXX constants available for importing
    require Fcntl;
    my @O = grep /^O_/, @Fcntl::EXPORT;
    Fcntl->import(@O);  # first we import what we want to export
    push(@EXPORT, @O);
};

if ($use_XSLoader)
  { XSLoader::load("DB_File", $VERSION)}
else
  { bootstrap DB_File $VERSION }

# Preloaded methods go here.  Autoload methods go after __END__, and are
# processed by the autosplit program.

sub tie_hash_or_array
{
    my (@arg) = @_ ;
    my $tieHASH = ( (caller(1))[3] =~ /TIEHASH/ ) ;

    $arg[4] = tied %{ $arg[4] } 
	if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ;

    # make recno in Berkeley DB version 2 work like recno in version 1.
    if ($db_version > 1 and defined $arg[4] and $arg[4] =~ /RECNO/ and 
	$arg[1] and ! -e $arg[1]) {
	open(FH, ">$arg[1]") or return undef ;
	close FH ;
	chmod $arg[3] ? $arg[3] : 0666 , $arg[1] ;
    }

    DoTie_($tieHASH, @arg) ;
}

sub TIEHASH
{
    tie_hash_or_array(@_) ;
}

sub TIEARRAY
{
    tie_hash_or_array(@_) ;
}

sub CLEAR 
{
    my $self = shift;
    my $key = 0 ;
    my $value = "" ;
    my $status = $self->seq($key, $value, R_FIRST());
    my @keys;
 
    while ($status == 0) {
        push @keys, $key;
        $status = $self->seq($key, $value, R_NEXT());
    }
    foreach $key (reverse @keys) {
        my $s = $self->del($key); 
    }
}

sub EXTEND { }

sub STORESIZE
{
    my $self = shift;
    my $length = shift ;
    my $current_length = $self->length() ;

    if ($length < $current_length) {
	my $key ;
        for ($key = $current_length - 1 ; $key >= $length ; -- $key)
	  { $self->del($key) }
    }
    elsif ($length > $current_length) {
        $self->put($length-1, "") ;
    }
}
 
sub find_dup
{
    croak "Usage: \$db->find_dup(key,value)\n"
        unless @_ == 3 ;
 
    my $db        = shift ;
    my ($origkey, $value_wanted) = @_ ;
    my ($key, $value) = ($origkey, 0);
    my ($status) = 0 ;

    for ($status = $db->seq($key, $value, R_CURSOR() ) ;
         $status == 0 ;
         $status = $db->seq($key, $value, R_NEXT() ) ) {

        return 0 if $key eq $origkey and $value eq $value_wanted ;
    }

    return $status ;
}

sub del_dup
{
    croak "Usage: \$db->del_dup(key,value)\n"
        unless @_ == 3 ;
 
    my $db        = shift ;
    my ($key, $value) = @_ ;
    my ($status) = $db->find_dup($key, $value) ;
    return $status if $status != 0 ;

    $status = $db->del($key, R_CURSOR() ) ;
    return $status ;
}

sub get_dup
{
    croak "Usage: \$db->get_dup(key [,flag])\n"
        unless @_ == 2 or @_ == 3 ;
 
    my $db        = shift ;
    my $key       = shift ;
    my $flag	  = shift ;
    my $value 	  = 0 ;
    my $origkey   = $key ;
    my $wantarray = wantarray ;
    my %values	  = () ;
    my @values    = () ;
    my $counter   = 0 ;
    my $status    = 0 ;
 
    # iterate through the database until either EOF ($status == 0)
    # or a different key is encountered ($key ne $origkey).
    for ($status = $db->seq($key, $value, R_CURSOR()) ;
	 $status == 0 and $key eq $origkey ;
         $status = $db->seq($key, $value, R_NEXT()) ) {
 
        # save the value or count number of matches
        if ($wantarray) {
	    if ($flag)
                { ++ $values{$value} }
	    else
                { push (@values, $value) }
	}
        else
            { ++ $counter }
     
    }
 
    return ($wantarray ? ($flag ? %values : @values) : $counter) ;
}


1;
__END__

=head1 NAME

DB_File - Perl5 access to Berkeley DB version 1.x

=head1 SYNOPSIS

 use DB_File ;
 
 [$X =] tie %hash,  'DB_File', [$filename, $flags, $mode, $DB_HASH] ;
 [$X =] tie %hash,  'DB_File', $filename, $flags, $mode, $DB_BTREE ;
 [$X =] tie @array, 'DB_File', $filename, $flags, $mode, $DB_RECNO ;

 $status = $X->del($key [, $flags]) ;
 $status = $X->put($key, $value [, $flags]) ;
 $status = $X->get($key, $value [, $flags]) ;
 $status = $X->seq($key, $value, $flags) ;
 $status = $X->sync([$flags]) ;
 $status = $X->fd ;

 # BTREE only
 $count = $X->get_dup($key) ;
 @list  = $X->get_dup($key) ;
 %list  = $X->get_dup($key, 1) ;
 $status = $X->find_dup($key, $value) ;
 $status = $X->del_dup($key, $value) ;

 # RECNO only
 $a = $X->length;
 $a = $X->pop ;
 $X->push(list);
 $a = $X->shift;
 $X->unshift(list);

 # DBM Filters
 $old_filter = $db->filter_store_key  ( sub { ... } ) ;
 $old_filter = $db->filter_store_value( sub { ... } ) ;
 $old_filter = $db->filter_fetch_key  ( sub { ... } ) ;
 $old_filter = $db->filter_fetch_value( sub { ... } ) ;

 untie %hash ;
 untie @array ;

=head1 DESCRIPTION

B<DB_File> is a module which allows Perl programs to make use of the
facilities provided by Berkeley DB version 1.x (if you have a newer
version of DB, see L<Using DB_File with Berkeley DB version 2 or 3>).
It is assumed that you have a copy of the Berkeley DB manual pages at
hand when reading this documentation. The interface defined here
mirrors the Berkeley DB interface closely.

Berkeley DB is a C library which provides a consistent interface to a
number of database formats.  B<DB_File> provides an interface to all
three of the database types currently supported by Berkeley DB.

The file types are:

=over 5

=item B<DB_HASH>

This database type allows arbitrary key/value pairs to be stored in data
files. This is equivalent to the functionality provided by other
hashing packages like DBM, NDBM, ODBM, GDBM, and SDBM. Remember though,
the files created using DB_HASH are not compatible with any of the
other packages mentioned.

A default hashing algorithm, which will be adequate for most
applications, is built into Berkeley DB. If you do need to use your own
hashing algorithm it is possible to write your own in Perl and have
B<DB_File> use it instead.

=item B<DB_BTREE>

The btree format allows arbitrary key/value pairs to be stored in a
sorted, balanced binary tree.

As with the DB_HASH format, it is possible to provide a user defined
Perl routine to perform the comparison of keys. By default, though, the
keys are stored in lexical order.

=item B<DB_RECNO>

DB_RECNO allows both fixed-length and variable-length flat text files
to be manipulated using the same key/value pair interface as in DB_HASH
and DB_BTREE.  In this case the key will consist of a record (line)
number.

=back

=head2 Using DB_File with Berkeley DB version 2 or 3

Although B<DB_File> is intended to be used with Berkeley DB version 1,
it can also be used with version 2.or 3 In this case the interface is
limited to the functionality provided by Berkeley DB 1.x. Anywhere the
version 2 or 3 interface differs, B<DB_File> arranges for it to work
like version 1. This feature allows B<DB_File> scripts that were built
with version 1 to be migrated to version 2 or 3 without any changes.

If you want to make use of the new features available in Berkeley DB
2.x or greater, use the Perl module B<BerkeleyDB> instead.

B<Note:> The database file format has changed in both Berkeley DB
version 2 and 3. If you cannot recreate your databases, you must dump
any existing databases with the C<db_dump185> utility that comes with
Berkeley DB.
Once you have rebuilt DB_File to use Berkeley DB version 2 or 3, your
databases can be recreated using C<db_load>. Refer to the Berkeley DB
documentation for further details.

Please read L<"COPYRIGHT"> before using version 2.x or 3.x of Berkeley
DB with DB_File.

=head2 Interface to Berkeley DB

B<DB_File> allows access to Berkeley DB files using the tie() mechanism
in Perl 5 (for full details, see L<perlfunc/tie()>). This facility
allows B<DB_File> to access Berkeley DB files using either an
associative array (for DB_HASH & DB_BTREE file types) or an ordinary
array (for the DB_RECNO file type).

In addition to the tie() interface, it is also possible to access most
of the functions provided in the Berkeley DB API directly.
See L<THE API INTERFACE>.

=head2 Opening a Berkeley DB Database File

Berkeley DB uses the function dbopen() to open or create a database.
Here is the C prototype for dbopen():

      DB*
      dbopen (const char * file, int flags, int mode, 
              DBTYPE type, const void * openinfo)

The parameter C<type> is an enumeration which specifies which of the 3
interface methods (DB_HASH, DB_BTREE or DB_RECNO) is to be used.
Depending on which of these is actually chosen, the final parameter,
I<openinfo> points to a data structure which allows tailoring of the
specific interface method.

This interface is handled slightly differently in B<DB_File>. Here is
an equivalent call using B<DB_File>:

        tie %array, 'DB_File', $filename, $flags, $mode, $DB_HASH ;

The C<filename>, C<flags> and C<mode> parameters are the direct
equivalent of their dbopen() counterparts. The final parameter $DB_HASH
performs the function of both the C<type> and C<openinfo> parameters in
dbopen().

In the example above $DB_HASH is actually a pre-defined reference to a
hash object. B<DB_File> has three of these pre-defined references.
Apart from $DB_HASH, there is also $DB_BTREE and $DB_RECNO.

The keys allowed in each of these pre-defined references is limited to
the names used in the equivalent C structure. So, for example, the
$DB_HASH reference will only allow keys called C<bsize>, C<cachesize>,
C<ffactor>, C<hash>, C<lorder> and C<nelem>. 

To change one of these elements, just assign to it like this:

	$DB_HASH->{'cachesize'} = 10000 ;

The three predefined variables $DB_HASH, $DB_BTREE and $DB_RECNO are
usually adequate for most applications.  If you do need to create extra
instances of these objects, constructors are available for each file
type.

Here are examples of the constructors and the valid options available
for DB_HASH, DB_BTREE and DB_RECNO respectively.

     $a = new DB_File::HASHINFO ;
     $a->{'bsize'} ;
     $a->{'cachesize'} ;
     $a->{'ffactor'};
     $a->{'hash'} ;
     $a->{'lorder'} ;
     $a->{'nelem'} ;

     $b = new DB_File::BTREEINFO ;
     $b->{'flags'} ;
     $b->{'cachesize'} ;
     $b->{'maxkeypage'} ;
     $b->{'minkeypage'} ;
     $b->{'psize'} ;
     $b->{'compare'} ;
     $b->{'prefix'} ;
     $b->{'lorder'} ;

     $c = new DB_File::RECNOINFO ;
     $c->{'bval'} ;
     $c->{'cachesize'} ;
     $c->{'psize'} ;
     $c->{'flags'} ;
     $c->{'lorder'} ;
     $c->{'reclen'} ;
     $c->{'bfname'} ;

The values stored in the hashes above are mostly the direct equivalent
of their C counterpart. Like their C counterparts, all are set to a
default values - that means you don't have to set I<all> of the
values when you only want to change one. Here is an example:

     $a = new DB_File::HASHINFO ;
     $a->{'cachesize'} =  12345 ;
     tie %y, 'DB_File', "filename", $flags, 0777, $a ;

A few of the options need extra discussion here. When used, the C
equivalent of the keys C<hash>, C<compare> and C<prefix> store pointers
to C functions. In B<DB_File> these keys are used to store references
to Perl subs. Below are templates for each of the subs:

    sub hash
    {
        my ($data) = @_ ;
        ...
        # return the hash value for $data
	return $hash ;
    }

    sub compare
    {
	my ($key, $key2) = @_ ;
        ...
        # return  0 if $key1 eq $key2
        #        -1 if $key1 lt $key2
        #         1 if $key1 gt $key2
        return (-1 , 0 or 1) ;
    }

    sub prefix
    {
	my ($key, $key2) = @_ ;
        ...
        # return number of bytes of $key2 which are 
        # necessary to determine that it is greater than $key1
        return $bytes ;
    }

See L<Changing the BTREE sort order> for an example of using the
C<compare> template.

If you are using the DB_RECNO interface and you intend making use of
C<bval>, you should check out L<The 'bval' Option>.

=head2 Default Parameters

It is possible to omit some or all of the final 4 parameters in the
call to C<tie> and let them take default values. As DB_HASH is the most
common file format used, the call:

    tie %A, "DB_File", "filename" ;

is equivalent to:

    tie %A, "DB_File", "filename", O_CREAT|O_RDWR, 0666, $DB_HASH ;

It is also possible to omit the filename parameter as well, so the
call:

    tie %A, "DB_File" ;

is equivalent to:

    tie %A, "DB_File", undef, O_CREAT|O_RDWR, 0666, $DB_HASH ;

See L<In Memory Databases> for a discussion on the use of C<undef>
in place of a filename.

=head2 In Memory Databases

Berkeley DB allows the creation of in-memory databases by using NULL
(that is, a C<(char *)0> in C) in place of the filename.  B<DB_File>
uses C<undef> instead of NULL to provide this functionality.

=head1 DB_HASH

The DB_HASH file format is probably the most commonly used of the three
file formats that B<DB_File> supports. It is also very straightforward
to use.

=head2 A Simple Example

This example shows how to create a database, add key/value pairs to the
database, delete keys/value pairs and finally how to enumerate the
contents of the database.

    use warnings ;
    use strict ;
    use DB_File ;
    use vars qw( %h $k $v ) ;

    unlink "fruit" ;
    tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH 
        or die "Cannot open file 'fruit': $!\n";

    # Add a few key/value pairs to the file
    $h{"apple"} = "red" ;
    $h{"orange"} = "orange" ;
    $h{"banana"} = "yellow" ;
    $h{"tomato"} = "red" ;

    # Check for existence of a key
    print "Banana Exists\n\n" if $h{"banana"} ;

    # Delete a key/value pair.
    delete $h{"apple"} ;

    # print the contents of the file
    while (($k, $v) = each %h)
      { print "$k -> $v\n" }

    untie %h ;

here is the output:

    Banana Exists
 
    orange -> orange
    tomato -> red
    banana -> yellow

Note that the like ordinary associative arrays, the order of the keys
retrieved is in an apparently random order.

=head1 DB_BTREE

The DB_BTREE format is useful when you want to store data in a given
order. By default the keys will be stored in lexical order, but as you
will see from the example shown in the next section, it is very easy to
define your own sorting function.

=head2 Changing the BTREE sort order

This script shows how to override the default sorting algorithm that
BTREE uses. Instead of using the normal lexical ordering, a case
insensitive compare function will be used.

    use warnings ;
    use strict ;
    use DB_File ;

    my %h ;

    sub Compare
    {
        my ($key1, $key2) = @_ ;
        "\L$key1" cmp "\L$key2" ;
    }

    # specify the Perl sub that will do the comparison
    $DB_BTREE->{'compare'} = \&Compare ;

    unlink "tree" ;
    tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE 
        or die "Cannot open file 'tree': $!\n" ;

    # Add a key/value pair to the file
    $h{'Wall'} = 'Larry' ;
    $h{'Smith'} = 'John' ;
    $h{'mouse'} = 'mickey' ;
    $h{'duck'}  = 'donald' ;

    # Delete
    delete $h{"duck"} ;

    # Cycle through the keys printing them in order.
    # Note it is not necessary to sort the keys as
    # the btree will have kept them in order automatically.
    foreach (keys %h)
      { print "$_\n" }

    untie %h ;

Here is the output from the code above.

    mouse
    Smith
    Wall

There are a few point to bear in mind if you want to change the
ordering in a BTREE database:

=over 5

=item 1.

The new compare function must be specified when you create the database.

=item 2.

You cannot change the ordering once the database has been created. Thus
you must use the same compare function every time you access the
database.

=back 

=head2 Handling Duplicate Keys 

The BTREE file type optionally allows a single key to be associated
with an arbitrary number of values. This option is enabled by setting
the flags element of C<$DB_BTREE> to R_DUP when creating the database.

There are some difficulties in using the tied hash interface if you
want to manipulate a BTREE database with duplicate keys. Consider this
code:

    use warnings ;
    use strict ;
    use DB_File ;

    use vars qw($filename %h ) ;

    $filename = "tree" ;
    unlink $filename ;
 
    # Enable duplicate records
    $DB_BTREE->{'flags'} = R_DUP ;
 
    tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
	or die "Cannot open $filename: $!\n";
 
    # Add some key/value pairs to the file
    $h{'Wall'} = 'Larry' ;
    $h{'Wall'} = 'Brick' ; # Note the duplicate key
    $h{'Wall'} = 'Brick' ; # Note the duplicate key and value
    $h{'Smith'} = 'John' ;
    $h{'mouse'} = 'mickey' ;

    # iterate through the associative array
    # and print each key/value pair.
    foreach (sort keys %h)
      { print "$_  -> $h{$_}\n" }

    untie %h ;

Here is the output:

    Smith   -> John
    Wall    -> Larry
    Wall    -> Larry
    Wall    -> Larry
    mouse   -> mickey

As you can see 3 records have been successfully created with key C<Wall>
- the only thing is, when they are retrieved from the database they
I<seem> to have the same value, namely C<Larry>. The problem is caused
by the way that the associative array interface works. Basically, when
the associative array interface is used to fetch the value associated
with a given key, it will only ever retrieve the first value.

Although it may not be immediately obvious from the code above, the
associative array interface can be used to write values with duplicate
keys, but it cannot be used to read them back from the database.

The way to get around this problem is to use the Berkeley DB API method
called C<seq>.  This method allows sequential access to key/value
pairs. See L<THE API INTERFACE> for details of both the C<seq> method
and the API in general.

Here is the script above rewritten using the C<seq> API method.

    use warnings ;
    use strict ;
    use DB_File ;
 
    use vars qw($filename $x %h $status $key $value) ;

    $filename = "tree" ;
    unlink $filename ;
 
    # Enable duplicate records
    $DB_BTREE->{'flags'} = R_DUP ;
 
    $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
	or die "Cannot open $filename: $!\n";
 
    # Add some key/value pairs to the file
    $h{'Wall'} = 'Larry' ;
    $h{'Wall'} = 'Brick' ; # Note the duplicate key
    $h{'Wall'} = 'Brick' ; # Note the duplicate key and value
    $h{'Smith'} = 'John' ;
    $h{'mouse'} = 'mickey' ;
 
    # iterate through the btree using seq
    # and print each key/value pair.
    $key = $value = 0 ;
    for ($status = $x->seq($key, $value, R_FIRST) ;
         $status == 0 ;
         $status = $x->seq($key, $value, R_NEXT) )
      {  print "$key -> $value\n" }
 
    undef $x ;
    untie %h ;

that prints:

    Smith   -> John
    Wall    -> Brick
    Wall    -> Brick
    Wall    -> Larry
    mouse   -> mickey

This time we have got all the key/value pairs, including the multiple
values associated with the key C<Wall>.

To make life easier when dealing with duplicate keys, B<DB_File> comes with 
a few utility methods.

=head2 The get_dup() Method

The C<get_dup> method assists in
reading duplicate values from BTREE databases. The method can take the
following forms:

    $count = $x->get_dup($key) ;
    @list  = $x->get_dup($key) ;
    %list  = $x->get_dup($key, 1) ;

In a scalar context the method returns the number of values associated
with the key, C<$key>.

In list context, it returns all the values which match C<$key>. Note
that the values will be returned in an apparently random order.

In list context, if the second parameter is present and evaluates
TRUE, the method returns an associative array. The keys of the
associative array correspond to the values that matched in the BTREE
and the values of the array are a count of the number of times that
particular value occurred in the BTREE.

So assuming the database created above, we can use C<get_dup> like
this:

    use warnings ;
    use strict ;
    use DB_File ;
 
    use vars qw($filename $x %h ) ;

    $filename = "tree" ;
 
    # Enable duplicate records
    $DB_BTREE->{'flags'} = R_DUP ;
 
    $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
	or die "Cannot open $filename: $!\n";

    my $cnt  = $x->get_dup("Wall") ;
    print "Wall occurred $cnt times\n" ;

    my %hash = $x->get_dup("Wall", 1) ;
    print "Larry is there\n" if $hash{'Larry'} ;
    print "There are $hash{'Brick'} Brick Walls\n" ;

    my @list = sort $x->get_dup("Wall") ;
    print "Wall =>	[@list]\n" ;

    @list = $x->get_dup("Smith") ;
    print "Smith =>	[@list]\n" ;
 
    @list = $x->get_dup("Dog") ;
    print "Dog =>	[@list]\n" ;


and it will print:

    Wall occurred 3 times
    Larry is there
    There are 2 Brick Walls
    Wall =>	[Brick Brick Larry]
    Smith =>	[John]
    Dog =>	[]

=head2 The find_dup() Method

    $status = $X->find_dup($key, $value) ;

This method checks for the existence of a specific key/value pair. If the
pair exists, the cursor is left pointing to the pair and the method 
returns 0. Otherwise the method returns a non-zero value.

Assuming the database from the previous example:

    use warnings ;
    use strict ;
    use DB_File ;
 
    use vars qw($filename $x %h $found) ;

    my $filename = "tree" ;
 
    # Enable duplicate records
    $DB_BTREE->{'flags'} = R_DUP ;
 
    $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
	or die "Cannot open $filename: $!\n";

    $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; 
    print "Larry Wall is $found there\n" ;
    
    $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ; 
    print "Harry Wall is $found there\n" ;
    
    undef $x ;
    untie %h ;

prints this

    Larry Wall is  there
    Harry Wall is not there


=head2 The del_dup() Method

    $status = $X->del_dup($key, $value) ;

This method deletes a specific key/value pair. It returns
0 if they exist and have been deleted successfully.
Otherwise the method returns a non-zero value.

Again assuming the existence of the C<tree> database

    use warnings ;
    use strict ;
    use DB_File ;
 
    use vars qw($filename $x %h $found) ;

    my $filename = "tree" ;
 
    # Enable duplicate records
    $DB_BTREE->{'flags'} = R_DUP ;
 
    $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
	or die "Cannot open $filename: $!\n";

    $x->del_dup("Wall", "Larry") ;

    $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; 
    print "Larry Wall is $found there\n" ;
    
    undef $x ;
    untie %h ;

prints this

    Larry Wall is not there

=head2 Matching Partial Keys 

The BTREE interface has a feature which allows partial keys to be
matched. This functionality is I<only> available when the C<seq> method
is used along with the R_CURSOR flag.

    $x->seq($key, $value, R_CURSOR) ;

Here is the relevant quote from the dbopen man page where it defines
the use of the R_CURSOR flag with seq:

    Note, for the DB_BTREE access method, the returned key is not
    necessarily an exact match for the specified key. The returned key
    is the smallest key greater than or equal to the specified key,
    permitting partial key matches and range searches.

In the example script below, the C<match> sub uses this feature to find
and print the first matching key/value pair given a partial key.

    use warnings ;
    use strict ;
    use DB_File ;
    use Fcntl ;

    use vars qw($filename $x %h $st $key $value) ;

    sub match
    {
        my $key = shift ;
        my $value = 0;
        my $orig_key = $key ;
        $x->seq($key, $value, R_CURSOR) ;
        print "$orig_key\t-> $key\t-> $value\n" ;
    }

    $filename = "tree" ;
    unlink $filename ;

    $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
        or die "Cannot open $filename: $!\n";
 
    # Add some key/value pairs to the file
    $h{'mouse'} = 'mickey' ;
    $h{'Wall'} = 'Larry' ;
    $h{'Walls'} = 'Brick' ; 
    $h{'Smith'} = 'John' ;
 

    $key = $value = 0 ;
    print "IN ORDER\n" ;
    for ($st = $x->seq($key, $value, R_FIRST) ;
	 $st == 0 ;
         $st = $x->seq($key, $value, R_NEXT) )
	
      {  print "$key	-> $value\n" }
 
    print "\nPARTIAL MATCH\n" ;

    match "Wa" ;
    match "A" ;
    match "a" ;

    undef $x ;
    untie %h ;

Here is the output:

    IN ORDER
    Smith -> John
    Wall  -> Larry
    Walls -> Brick
    mouse -> mickey

    PARTIAL MATCH
    Wa -> Wall  -> Larry
    A  -> Smith -> John
    a  -> mouse -> mickey

=head1 DB_RECNO

DB_RECNO provides an interface to flat text files. Both variable and
fixed length records are supported.

In order to make RECNO more compatible with Perl, the array offset for
all RECNO arrays begins at 0 rather than 1 as in Berkeley DB.

As with normal Perl arrays, a RECNO array can be accessed using
negative indexes. The index -1 refers to the last element of the array,
-2 the second last, and so on. Attempting to access an element before
the start of the array will raise a fatal run-time error.

=head2 The 'bval' Option

The operation of the bval option warrants some discussion. Here is the
definition of bval from the Berkeley DB 1.85 recno manual page:

    The delimiting byte to be used to mark  the  end  of  a
    record for variable-length records, and the pad charac-
    ter for fixed-length records.  If no  value  is  speci-
    fied,  newlines  (``\n'')  are  used to mark the end of
    variable-length records and  fixed-length  records  are
    padded with spaces.

The second sentence is wrong. In actual fact bval will only default to
C<"\n"> when the openinfo parameter in dbopen is NULL. If a non-NULL
openinfo parameter is used at all, the value that happens to be in bval
will be used. That means you always have to specify bval when making
use of any of the options in the openinfo parameter. This documentation
error will be fixed in the next release of Berkeley DB.

That clarifies the situation with regards Berkeley DB itself. What
about B<DB_File>? Well, the behavior defined in the quote above is
quite useful, so B<DB_File> conforms to it.

That means that you can specify other options (e.g. cachesize) and
still have bval default to C<"\n"> for variable length records, and
space for fixed length records.

=head2 A Simple Example

Here is a simple example that uses RECNO (if you are using a version 
of Perl earlier than 5.004_57 this example won't work -- see 
L<Extra RECNO Methods> for a workaround).

    use warnings ;
    use strict ;
    use DB_File ;

    my $filename = "text" ;
    unlink $filename ;

    my @h ;
    tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO 
        or die "Cannot open file 'text': $!\n" ;

    # Add a few key/value pairs to the file
    $h[0] = "orange" ;
    $h[1] = "blue" ;
    $h[2] = "yellow" ;

    push @h, "green", "black" ;

    my $elements = scalar @h ;
    print "The array contains $elements entries\n" ;

    my $last = pop @h ;
    print "popped $last\n" ;

    unshift @h, "white" ;
    my $first = shift @h ;
    print "shifted $first\n" ;

    # Check for existence of a key
    print "Element 1 Exists with value $h[1]\n" if $h[1] ;

    # use a negative index
    print "The last element is $h[-1]\n" ;
    print "The 2nd last element is $h[-2]\n" ;

    untie @h ;

Here is the output from the script:

    The array contains 5 entries
    popped black
    shifted white
    Element 1 Exists with value blue
    The last element is green
    The 2nd last element is yellow

=head2 Extra RECNO Methods

If you are using a version of Perl earlier than 5.004_57, the tied
array interface is quite limited. In the example script above
C<push>, C<pop>, C<shift>, C<unshift>
or determining the array length will not work with a tied array.

To make the interface more useful for older versions of Perl, a number
of methods are supplied with B<DB_File> to simulate the missing array
operations. All these methods are accessed via the object returned from
the tie call.

Here are the methods:

=over 5

=item B<$X-E<gt>push(list) ;>

Pushes the elements of C<list> to the end of the array.

=item B<$value = $X-E<gt>pop ;>

Removes and returns the last element of the array.

=item B<$X-E<gt>shift>

Removes and returns the first element of the array.

=item B<$X-E<gt>unshift(list) ;>

Pushes the elements of C<list> to the start of the array.

=item B<$X-E<gt>length>

Returns the number of elements in the array.

=back

=head2 Another Example

Here is a more complete example that makes use of some of the methods
described above. It also makes use of the API interface directly (see 
L<THE API INTERFACE>).

    use warnings ;
    use strict ;
    use vars qw(@h $H $file $i) ;
    use DB_File ;
    use Fcntl ;
    
    $file = "text" ;

    unlink $file ;

    $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $DB_RECNO 
        or die "Cannot open file $file: $!\n" ;
    
    # first create a text file to play with
    $h[0] = "zero" ;
    $h[1] = "one" ;
    $h[2] = "two" ;
    $h[3] = "three" ;
    $h[4] = "four" ;

    
    # Print the records in order.
    #
    # The length method is needed here because evaluating a tied
    # array in a scalar context does not return the number of
    # elements in the array.  

    print "\nORIGINAL\n" ;
    foreach $i (0 .. $H->length - 1) {
        print "$i: $h[$i]\n" ;
    }

    # use the push & pop methods
    $a = $H->pop ;
    $H->push("last") ;
    print "\nThe last record was [$a]\n" ;

    # and the shift & unshift methods
    $a = $H->shift ;
    $H->unshift("first") ;
    print "The first record was [$a]\n" ;

    # Use the API to add a new record after record 2.
    $i = 2 ;
    $H->put($i, "Newbie", R_IAFTER) ;

    # and a new record before record 1.
    $i = 1 ;
    $H->put($i, "New One", R_IBEFORE) ;

    # delete record 3
    $H->del(3) ;

    # now print the records in reverse order
    print "\nREVERSE\n" ;
    for ($i = $H->length - 1 ; $i >= 0 ; -- $i)
      { print "$i: $h[$i]\n" }

    # same again, but use the API functions instead
    print "\nREVERSE again\n" ;
    my ($s, $k, $v)  = (0, 0, 0) ;
    for ($s = $H->seq($k, $v, R_LAST) ; 
             $s == 0 ; 
             $s = $H->seq($k, $v, R_PREV))
      { print "$k: $v\n" }

    undef $H ;
    untie @h ;

and this is what it outputs:

    ORIGINAL
    0: zero
    1: one
    2: two
    3: three
    4: four

    The last record was [four]
    The first record was [zero]

    REVERSE
    5: last
    4: three
    3: Newbie
    2: one
    1: New One
    0: first

    REVERSE again
    5: last
    4: three
    3: Newbie
    2: one
    1: New One
    0: first

Notes:

=over 5

=item 1.

Rather than iterating through the array, C<@h> like this:

    foreach $i (@h)

it is necessary to use either this:

    foreach $i (0 .. $H->length - 1) 

or this:

    for ($a = $H->get($k, $v, R_FIRST) ;
         $a == 0 ;
         $a = $H->get($k, $v, R_NEXT) )

=item 2.

Notice that both times the C<put> method was used the record index was
specified using a variable, C<$i>, rather than the literal value
itself. This is because C<put> will return the record number of the
inserted line via that parameter.

=back

=head1 THE API INTERFACE

As well as accessing Berkeley DB using a tied hash or array, it is also
possible to make direct use of most of the API functions defined in the
Berkeley DB documentation.

To do this you need to store a copy of the object returned from the tie.

	$db = tie %hash, "DB_File", "filename" ;

Once you have done that, you can access the Berkeley DB API functions
as B<DB_File> methods directly like this:

	$db->put($key, $value, R_NOOVERWRITE) ;

B<Important:> If you have saved a copy of the object returned from
C<tie>, the underlying database file will I<not> be closed until both
the tied variable is untied and all copies of the saved object are
destroyed. 

    use DB_File ;
    $db = tie %hash, "DB_File", "filename" 
        or die "Cannot tie filename: $!" ;
    ...
    undef $db ;
    untie %hash ;

See L<The untie() Gotcha> for more details.

All the functions defined in L<dbopen> are available except for
close() and dbopen() itself. The B<DB_File> method interface to the
supported functions have been implemented to mirror the way Berkeley DB
works whenever possible. In particular note that:

=over 5

=item *

The methods return a status value. All return 0 on success.
All return -1 to signify an error and set C<$!> to the exact
error code. The return code 1 generally (but not always) means that the
key specified did not exist in the database.

Other return codes are defined. See below and in the Berkeley DB
documentation for details. The Berkeley DB documentation should be used
as the definitive source.

=item *

Whenever a Berkeley DB function returns data via one of its parameters,
the equivalent B<DB_File> method does exactly the same.

=item *

If you are careful, it is possible to mix API calls with the tied
hash/array interface in the same piece of code. Although only a few of
the methods used to implement the tied interface currently make use of
the cursor, you should always assume that the cursor has been changed
any time the tied hash/array interface is used. As an example, this
code will probably not do what you expect:

    $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE
        or die "Cannot tie $filename: $!" ;

    # Get the first key/value pair and set  the cursor
    $X->seq($key, $value, R_FIRST) ;

    # this line will modify the cursor
    $count = scalar keys %x ; 

    # Get the second key/value pair.
    # oops, it didn't, it got the last key/value pair!
    $X->seq($key, $value, R_NEXT) ;

The code above can be rearranged to get around the problem, like this:

    $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE
        or die "Cannot tie $filename: $!" ;

    # this line will modify the cursor
    $count = scalar keys %x ; 

    # Get the first key/value pair and set  the cursor
    $X->seq($key, $value, R_FIRST) ;

    # Get the second key/value pair.
    # worked this time.
    $X->seq($key, $value, R_NEXT) ;

=back

All the constants defined in L<dbopen> for use in the flags parameters
in the methods defined below are also available. Refer to the Berkeley
DB documentation for the precise meaning of the flags values.

Below is a list of the methods available.

=over 5

=item B<$status = $X-E<gt>get($key, $value [, $flags]) ;>

Given a key (C<$key>) this method reads the value associated with it
from the database. The value read from the database is returned in the
C<$value> parameter.

If the key does not exist the method returns 1.

No flags are currently defined for this method.

=item B<$status = $X-E<gt>put($key, $value [, $flags]) ;>

Stores the key/value pair in the database.

If you use either the R_IAFTER or R_IBEFORE flags, the C<$key> parameter
will have the record number of the inserted key/value pair set.

Valid flags are R_CURSOR, R_IAFTER, R_IBEFORE, R_NOOVERWRITE and
R_SETCURSOR.

=item B<$status = $X-E<gt>del($key [, $flags]) ;>

Removes all key/value pairs with key C<$key> from the database.

A return code of 1 means that the requested key was not in the
database.

R_CURSOR is the only valid flag at present.

=item B<$status = $X-E<gt>fd ;>

Returns the file descriptor for the underlying database.

See L<Locking: The Trouble with fd> for an explanation for why you should
not use C<fd> to lock your database.

=item B<$status = $X-E<gt>seq($key, $value, $flags) ;>

This interface allows sequential retrieval from the database. See
L<dbopen> for full details.

Both the C<$key> and C<$value> parameters will be set to the key/value
pair read from the database.

The flags parameter is mandatory. The valid flag values are R_CURSOR,
R_FIRST, R_LAST, R_NEXT and R_PREV.

=item B<$status = $X-E<gt>sync([$flags]) ;>

Flushes any cached buffers to disk.

R_RECNOSYNC is the only valid flag at present.

=back

=head1 DBM FILTERS

A DBM Filter is a piece of code that is be used when you I<always>
want to make the same transformation to all keys and/or values in a
DBM database.

There are four methods associated with DBM Filters. All work identically,
and each is used to install (or uninstall) a single DBM Filter. Each
expects a single parameter, namely a reference to a sub. The only
difference between them is the place that the filter is installed.

To summarise:

=over 5

=item B<filter_store_key>

If a filter has been installed with this method, it will be invoked
every time you write a key to a DBM database.

=item B<filter_store_value>

If a filter has been installed with this method, it will be invoked
every time you write a value to a DBM database.


=item B<filter_fetch_key>

If a filter has been installed with this method, it will be invoked
every time you read a key from a DBM database.

=item B<filter_fetch_value>

If a filter has been installed with this method, it will be invoked
every time you read a value from a DBM database.

=back

You can use any combination of the methods, from none, to all four.

All filter methods return the existing filter, if present, or C<undef>
in not.

To delete a filter pass C<undef> to it.

=head2 The Filter

When each filter is called by Perl, a local copy of C<$_> will contain
the key or value to be filtered. Filtering is achieved by modifying
the contents of C<$_>. The return code from the filter is ignored.

=head2 An Example -- the NULL termination problem.

Consider the following scenario. You have a DBM database
that you need to share with a third-party C application. The C application
assumes that I<all> keys and values are NULL terminated. Unfortunately
when Perl writes to DBM databases it doesn't use NULL termination, so
your Perl application will have to manage NULL termination itself. When
you write to the database you will have to use something like this:

    $hash{"$key\0"} = "$value\0" ;

Similarly the NULL needs to be taken into account when you are considering
the length of existing keys/values.

It would be much better if you could ignore the NULL terminations issue
in the main application code and have a mechanism that automatically
added the terminating NULL to all keys and values whenever you write to
the database and have them removed when you read from the database. As I'm
sure you have already guessed, this is a problem that DBM Filters can
fix very easily.

    use warnings ;
    use strict ;
    use DB_File ;

    my %hash ;
    my $filename = "/tmp/filt" ;
    unlink $filename ;

    my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH 
      or die "Cannot open $filename: $!\n" ;

    # Install DBM Filters
    $db->filter_fetch_key  ( sub { s/\0$//    } ) ;
    $db->filter_store_key  ( sub { $_ .= "\0" } ) ;
    $db->filter_fetch_value( sub { s/\0$//    } ) ;
    $db->filter_store_value( sub { $_ .= "\0" } ) ;

    $hash{"abc"} = "def" ;
    my $a = $hash{"ABC"} ;
    # ...
    undef $db ;
    untie %hash ;

Hopefully the contents of each of the filters should be
self-explanatory. Both "fetch" filters remove the terminating NULL,
and both "store" filters add a terminating NULL.


=head2 Another Example -- Key is a C int.

Here is another real-life example. By default, whenever Perl writes to
a DBM database it always writes the key and value as strings. So when
you use this:

    $hash{12345} = "soemthing" ;

the key 12345 will get stored in the DBM database as the 5 byte string
"12345". If you actually want the key to be stored in the DBM database
as a C int, you will have to use C<pack> when writing, and C<unpack>
when reading.

Here is a DBM Filter that does it:

    use warnings ;
    use strict ;
    use DB_File ;
    my %hash ;
    my $filename = "/tmp/filt" ;
    unlink $filename ;


    my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH 
      or die "Cannot open $filename: $!\n" ;

    $db->filter_fetch_key  ( sub { $_ = unpack("i", $_) } ) ;
    $db->filter_store_key  ( sub { $_ = pack ("i", $_) } ) ;
    $hash{123} = "def" ;
    # ...
    undef $db ;
    untie %hash ;

This time only two filters have been used -- we only need to manipulate
the contents of the key, so it wasn't necessary to install any value
filters.

=head1 HINTS AND TIPS 


=head2 Locking: The Trouble with fd

Until version 1.72 of this module, the recommended technique for locking
B<DB_File> databases was to flock the filehandle returned from the "fd"
function. Unfortunately this technique has been shown to be fundamentally
flawed (Kudos to David Harris for tracking this down). Use it at your own
peril!

The locking technique went like this. 

    $db = tie(%db, 'DB_File', '/tmp/foo.db', O_CREAT|O_RDWR, 0644)
        || die "dbcreat /tmp/foo.db $!";
    $fd = $db->fd;
    open(DB_FH, "+<&=$fd") || die "dup $!";
    flock (DB_FH, LOCK_EX) || die "flock: $!";
    ...
    $db{"Tom"} = "Jerry" ;
    ...
    flock(DB_FH, LOCK_UN);
    undef $db;
    untie %db;
    close(DB_FH);

In simple terms, this is what happens:

=over 5

=item 1.

Use "tie" to open the database.

=item 2.

Lock the database with fd & flock.

=item 3.

Read & Write to the database.

=item 4.

Unlock and close the database.

=back

Here is the crux of the problem. A side-effect of opening the B<DB_File>
database in step 2 is that an initial block from the database will get
read from disk and cached in memory.

To see why this is a problem, consider what can happen when two processes,
say "A" and "B", both want to update the same B<DB_File> database
using the locking steps outlined above. Assume process "A" has already
opened the database and has a write lock, but it hasn't actually updated
the database yet (it has finished step 2, but not started step 3 yet). Now
process "B" tries to open the same database - step 1 will succeed,
but it will block on step 2 until process "A" releases the lock. The
important thing to notice here is that at this point in time both
processes will have cached identical initial blocks from the database.

Now process "A" updates the database and happens to change some of the
data held in the initial buffer. Process "A" terminates, flushing
all cached data to disk and releasing the database lock. At this point
the database on disk will correctly reflect the changes made by process
"A".

With the lock released, process "B" can now continue. It also updates the
database and unfortunately it too modifies the data that was in its
initial buffer. Once that data gets flushed to disk it will overwrite
some/all of the changes process "A" made to the database.

The result of this scenario is at best a database that doesn't contain
what you expect. At worst the database will corrupt.

The above won't happen every time competing process update the same
B<DB_File> database, but it does illustrate why the technique should
not be used.

=head2 Safe ways to lock a database

Starting with version 2.x, Berkeley DB  has internal support for locking.
The companion module to this one, B<BerkeleyDB>, provides an interface
to this locking functionality. If you are serious about locking
Berkeley DB databases, I strongly recommend using B<BerkeleyDB>.

If using B<BerkeleyDB> isn't an option, there are a number of modules
available on CPAN that can be used to implement locking. Each one
implements locking differently and has different goals in mind. It is
therefore worth knowing the difference, so that you can pick the right
one for your application. Here are the three locking wrappers:

=over 5

=item B<Tie::DB_Lock>

A B<DB_File> wrapper which creates copies of the database file for
read access, so that you have a kind of a multiversioning concurrent read
system. However, updates are still serial. Use for databases where reads
may be lengthy and consistency problems may occur.

=item B<Tie::DB_LockFile> 

A B<DB_File> wrapper that has the ability to lock and unlock the database
while it is being used. Avoids the tie-before-flock problem by simply
re-tie-ing the database when you get or drop a lock.  Because of the
flexibility in dropping and re-acquiring the lock in the middle of a
session, this can be massaged into a system that will work with long
updates and/or reads if the application follows the hints in the POD
documentation.

=item B<DB_File::Lock> 

An extremely lightweight B<DB_File> wrapper that simply flocks a lockfile
before tie-ing the database and drops the lock after the untie. Allows
one to use the same lockfile for multiple databases to avoid deadlock
problems, if desired. Use for databases where updates are reads are
quick and simple flock locking semantics are enough.

=back

=head2 Sharing Databases With C Applications

There is no technical reason why a Berkeley DB database cannot be
shared by both a Perl and a C application.

The vast majority of problems that are reported in this area boil down
to the fact that C strings are NULL terminated, whilst Perl strings are
not. See L<DBM FILTERS> for a generic way to work around this problem.

Here is a real example. Netscape 2.0 keeps a record of the locations you
visit along with the time you last visited them in a DB_HASH database.
This is usually stored in the file F<~/.netscape/history.db>. The key
field in the database is the location string and the value field is the
time the location was last visited stored as a 4 byte binary value.

If you haven't already guessed, the location string is stored with a
terminating NULL. This means you need to be careful when accessing the
database.

Here is a snippet of code that is loosely based on Tom Christiansen's
I<ggh> script (available from your nearest CPAN archive in
F<authors/id/TOMC/scripts/nshist.gz>).

    use warnings ;
    use strict ;
    use DB_File ;
    use Fcntl ;

    use vars qw( $dotdir $HISTORY %hist_db $href $binary_time $date ) ;
    $dotdir = $ENV{HOME} || $ENV{LOGNAME};

    $HISTORY = "$dotdir/.netscape/history.db";

    tie %hist_db, 'DB_File', $HISTORY
        or die "Cannot open $HISTORY: $!\n" ;;

    # Dump the complete database
    while ( ($href, $binary_time) = each %hist_db ) {

        # remove the terminating NULL
        $href =~ s/\x00$// ;

        # convert the binary time into a user friendly string
        $date = localtime unpack("V", $binary_time);
        print "$date $href\n" ;
    }

    # check for the existence of a specific key
    # remember to add the NULL
    if ( $binary_time = $hist_db{"http://mox.perl.com/\x00"} ) {
        $date = localtime unpack("V", $binary_time) ;
        print "Last visited mox.perl.com on $date\n" ;
    }
    else {
        print "Never visited mox.perl.com\n"
    }

    untie %hist_db ;

=head2 The untie() Gotcha

If you make use of the Berkeley DB API, it is I<very> strongly
recommended that you read L<perltie/The untie Gotcha>. 

Even if you don't currently make use of the API interface, it is still
worth reading it.

Here is an example which illustrates the problem from a B<DB_File>
perspective:

    use DB_File ;
    use Fcntl ;

    my %x ;
    my $X ;

    $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_TRUNC
        or die "Cannot tie first time: $!" ;

    $x{123} = 456 ;

    untie %x ;

    tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT
        or die "Cannot tie second time: $!" ;

    untie %x ;

When run, the script will produce this error message:

    Cannot tie second time: Invalid argument at bad.file line 14.

Although the error message above refers to the second tie() statement
in the script, the source of the problem is really with the untie()
statement that precedes it.

Having read L<perltie> you will probably have already guessed that the
error is caused by the extra copy of the tied object stored in C<$X>.
If you haven't, then the problem boils down to the fact that the
B<DB_File> destructor, DESTROY, will not be called until I<all>
references to the tied object are destroyed. Both the tied variable,
C<%x>, and C<$X> above hold a reference to the object. The call to
untie() will destroy the first, but C<$X> still holds a valid
reference, so the destructor will not get called and the database file
F<tst.fil> will remain open. The fact that Berkeley DB then reports the
attempt to open a database that is already open via the catch-all
"Invalid argument" doesn't help.

If you run the script with the C<-w> flag the error message becomes:

    untie attempted while 1 inner references still exist at bad.file line 12.
    Cannot tie second time: Invalid argument at bad.file line 14.

which pinpoints the real problem. Finally the script can now be
modified to fix the original problem by destroying the API object
before the untie:

    ...
    $x{123} = 456 ;

    undef $X ;
    untie %x ;

    $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT
    ...


=head1 COMMON QUESTIONS

=head2 Why is there Perl source in my database?

If you look at the contents of a database file created by DB_File,
there can sometimes be part of a Perl script included in it.

This happens because Berkeley DB uses dynamic memory to allocate
buffers which will subsequently be written to the database file. Being
dynamic, the memory could have been used for anything before DB
malloced it. As Berkeley DB doesn't clear the memory once it has been
allocated, the unused portions will contain random junk. In the case
where a Perl script gets written to the database, the random junk will
correspond to an area of dynamic memory that happened to be used during
the compilation of the script.

Unless you don't like the possibility of there being part of your Perl
scripts embedded in a database file, this is nothing to worry about.

=head2 How do I store complex data structures with DB_File?

Although B<DB_File> cannot do this directly, there is a module which
can layer transparently over B<DB_File> to accomplish this feat.

Check out the MLDBM module, available on CPAN in the directory
F<modules/by-module/MLDBM>.

=head2 What does "Invalid Argument" mean?

You will get this error message when one of the parameters in the
C<tie> call is wrong. Unfortunately there are quite a few parameters to
get wrong, so it can be difficult to figure out which one it is.

Here are a couple of possibilities:

=over 5

=item 1.

Attempting to reopen a database without closing it. 

=item 2.

Using the O_WRONLY flag.

=back

=head2 What does "Bareword 'DB_File' not allowed" mean? 

You will encounter this particular error message when you have the
C<strict 'subs'> pragma (or the full strict pragma) in your script.
Consider this script:

    use warnings ;
    use strict ;
    use DB_File ;
    use vars qw(%x) ;
    tie %x, DB_File, "filename" ;

Running it produces the error in question:

    Bareword "DB_File" not allowed while "strict subs" in use 

To get around the error, place the word C<DB_File> in either single or
double quotes, like this:

    tie %x, "DB_File", "filename" ;

Although it might seem like a real pain, it is really worth the effort
of having a C<use strict> in all your scripts.

=head1 REFERENCES

Articles that are either about B<DB_File> or make use of it.

=over 5

=item 1.

I<Full-Text Searching in Perl>, Tim Kientzle (tkientzle@ddj.com),
Dr. Dobb's Journal, Issue 295, January 1999, pp 34-41

=back

=head1 HISTORY

Moved to the Changes file.

=head1 BUGS

Some older versions of Berkeley DB had problems with fixed length
records using the RECNO file format. This problem has been fixed since
version 1.85 of Berkeley DB.

I am sure there are bugs in the code. If you do find any, or can
suggest any enhancements, I would welcome your comments.

=head1 AVAILABILITY

B<DB_File> comes with the standard Perl source distribution. Look in
the directory F<ext/DB_File>. Given the amount of time between releases
of Perl the version that ships with Perl is quite likely to be out of
date, so the most recent version can always be found on CPAN (see
L<perlmod/CPAN> for details), in the directory
F<modules/by-module/DB_File>.

This version of B<DB_File> will work with either version 1.x, 2.x or
3.x of Berkeley DB, but is limited to the functionality provided by
version 1.

The official web site for Berkeley DB is F<http://www.sleepycat.com>.
All versions of Berkeley DB are available there.

Alternatively, Berkeley DB version 1 is available at your nearest CPAN
archive in F<src/misc/db.1.85.tar.gz>.

If you are running IRIX, then get Berkeley DB version 1 from
F<http://reality.sgi.com/ariel>. It has the patches necessary to
compile properly on IRIX 5.3.

=head1 COPYRIGHT

Copyright (c) 1995-1999 Paul Marquess. All rights reserved. This program
is free software; you can redistribute it and/or modify it under the
same terms as Perl itself.

Although B<DB_File> is covered by the Perl license, the library it
makes use of, namely Berkeley DB, is not. Berkeley DB has its own
copyright and its own license. Please take the time to read it.

Here are are few words taken from the Berkeley DB FAQ (at
F<http://www.sleepycat.com>) regarding the license:

    Do I have to license DB to use it in Perl scripts? 

    No. The Berkeley DB license requires that software that uses
    Berkeley DB be freely redistributable. In the case of Perl, that
    software is Perl, and not your scripts. Any Perl scripts that you
    write are your property, including scripts that make use of
    Berkeley DB. Neither the Perl license nor the Berkeley DB license
    place any restriction on what you may do with them.

If you are in any doubt about the license situation, contact either the
Berkeley DB authors or the author of DB_File. See L<"AUTHOR"> for details.


=head1 SEE ALSO

L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)>,
L<dbmfilter>

=head1 AUTHOR

The DB_File interface was written by Paul Marquess
E<lt>Paul.Marquess@btinternet.comE<gt>.
Questions about the DB system itself may be addressed to
E<lt>db@sleepycat.com<gt>.

=cut
 the system provides
a prototype for the sbrk() function.  Otherwise, it is
up                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                require 5.005_64;

=head1 NAME

Devel::DProf - a Perl code profiler

=head1 SYNOPSIS

	perl5 -d:DProf test.pl

=head1 DESCRIPTION

The Devel::DProf package is a Perl code profiler.  This will collect
information on the execution time of a Perl script and of the subs in that
script.  This information can be used to determine which subroutines are
using the most time and which subroutines are being called most often.  This
information can also be used to create an execution graph of the script,
showing subroutine relationships.

To profile a Perl script run the perl interpreter with the B<-d> debugging
switch.  The profiler uses the debugging hooks.  So to profile script
F<test.pl> the following command should be used:

	perl5 -d:DProf test.pl

When the script terminates (or when the output buffer is filled) the
profiler will dump the profile information to a file called
F<tmon.out>.  A tool like I<dprofpp> can be used to interpret the
information which is in that profile.  The following command will
print the top 15 subroutines which used the most time:

	dprofpp

To print an execution graph of the subroutines in the script use the
following command:

	dprofpp -T

Consult L<dprofpp> for other options.

=head1 PROFILE FORMAT

The old profile is a text file which looks like this:

	#fOrTyTwO
	$hz=100;
	$XS_VERSION='DProf 19970606';
	# All values are given in HZ
	$rrun_utime=2; $rrun_stime=0; $rrun_rtime=7
	PART2
	+ 26 28 566822884 DynaLoader::import
	- 26 28 566822884 DynaLoader::import
	+ 27 28 566822885 main::bar
	- 27 28 566822886 main::bar
	+ 27 28 566822886 main::baz
	+ 27 28 566822887 main::bar
	- 27 28 566822888 main::bar
	[....]

The first line is the magic number.  The second line is the hertz value, or
clock ticks, of the machine where the profile was collected.  The third line
is the name and version identifier of the tool which created the profile.
The fourth line is a comment.  The fifth line contains three variables
holding the user time, system time, and realtime of the process while it was
being profiled.  The sixth line indicates the beginning of the sub
entry/exit profile section.

The columns in B<PART2> are:

	sub entry(+)/exit(-) mark
	app's user time at sub entry/exit mark, in ticks
	app's system time at sub entry/exit mark, in ticks
	app's realtime at sub entry/exit mark, in ticks
	fully-qualified sub name, when possible

With newer perls another format is used, which may look like this:

        #fOrTyTwO
        $hz=10000;
        $XS_VERSION='DProf 19971213';
        # All values are given in HZ
        $over_utime=5917; $over_stime=0; $over_rtime=5917;
        $over_tests=10000;
        $rrun_utime=1284; $rrun_stime=0; $rrun_rtime=1284;
        $total_marks=6;

        PART2
        @ 406 0 406
        & 2 main bar
        + 2
        @ 456 0 456
        - 2
        @ 1 0 1
        & 3 main baz
        + 3
        @ 141 0 141
        + 2
        @ 141 0 141
        - 2
        @ 1 0 1
        & 4 main foo
        + 4
        @ 142 0 142
        + & Devel::DProf::write
        @ 5 0 5
        - & Devel::DProf::write

(with high value of $ENV{PERL_DPROF_TICKS}).  

New C<$over_*> values show the measured overhead of making $over_tests
calls to the profiler These values are used by the profiler to
subtract the overhead from the runtimes.

The lines starting with C<@> mark time passed from the previous C<@>
line.  The lines starting with C<&> introduce new subroutine I<id> and
show the package and the subroutine name of this id.  Lines starting
with C<+>, C<-> and C<*> mark entering and exit of subroutines by
I<id>s, and C<goto &subr>.

The I<old-style> C<+>- and C<->-lines are used to mark the overhead
related to writing to profiler-output file.

=head1 AUTOLOAD

When Devel::DProf finds a call to an C<&AUTOLOAD> subroutine it looks at the
C<$AUTOLOAD> variable to find the real name of the sub being called.  See
L<perlsub/"Autoloading">.

=head1 ENVIRONMENT

C<PERL_DPROF_BUFFER> sets size of output buffer in words.  Defaults to 2**14.

C<PERL_DPROF_TICKS> sets number of ticks per second on some systems where
a replacement for times() is used.  Defaults to the value of C<HZ> macro.

C<PERL_DPROF_OUT_FILE_NAME> sets the name of the output file.  If not set,
defaults to tmon.out.

=head1 BUGS

Builtin functions cannot be measured by Devel::DProf.

With a newer Perl DProf relies on the fact that the numeric slot of
$DB::sub contains an address of a subroutine.  Excessive manipulation
of this variable may overwrite this slot, as in

  $DB::sub = 'current_sub';
  ...
  $addr = $DB::sub + 0;

will set this numeric slot to numeric value of the string
C<current_sub>, i.e., to C<0>.  This will cause a segfault on the exit
from this subroutine.  Note that the first assignment above does not
change the numeric slot (it will I<mark> it as invalid, but will not
write over it).

Mail bug reports and feature requests to the perl5-porters mailing list at
F<E<lt>perl5-porters@perl.orgE<gt>>.

=head1 SEE ALSO

L<perl>, L<dprofpp>, times(2)

=cut

# This sub is needed for calibration.
package Devel::DProf;

sub NONESUCH_noxs {
	return $Devel::DProf::VERSION;
}

package DB;

#
# As of perl5.003_20, &DB::sub stub is not needed (some versions
# even had problems if stub was redefined with XS version).
#

# disable DB single-stepping
BEGIN { $single = 0; }

# This sub is needed during startup.
sub DB { 
#	print "nonXS DBDB\n";
}

use XSLoader ();

# Underscore to allow older Perls to access older version from CPAN
$Devel::DProf::VERSION = '20000000.00_00';  # this version not authorized by
				     # Dean Roehrich. See "Changes" file.

XSLoader::load 'Devel::DProf', $Devel::DProf::VERSION;

1;
current
process.

=item C<d_setrgid>

From F<d_setrgid.U>:

This variable conditionally defines the C<HAS_SETRGID> symbol, which
indicates to the C program that the setrgid() routine is available
to change the real gid of the current program.

=item C<d_setruid>

From F<d_setruid.U>:

This variable conditionally defines the C<HAS_SETRUID> symbol, which
indicates to the C program that the setruid() routine is available
to change the real uid of                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                # Devel::Peek - A data debugging tool for the XS programmer
# The documentation is after the __END__

package Devel::Peek;

# Underscore to allow older Perls to access older version from CPAN
$VERSION = '1.00_01';

require Exporter;
use XSLoader ();

@ISA = qw(Exporter);
@EXPORT = qw(Dump mstat DeadCode DumpArray DumpWithOP DumpProg
	     fill_mstats mstats_fillhash mstats2hash);
@EXPORT_OK = qw(SvREFCNT SvREFCNT_inc SvREFCNT_dec CvGV);
%EXPORT_TAGS = ('ALL' => [@EXPORT, @EXPORT_OK]);

XSLoader::load 'Devel::Peek';

sub DumpWithOP ($;$) {
   local($Devel::Peek::dump_ops)=1;
   my $depth = @_ > 1 ? $_[1] : 4 ;
   Dump($_[0],$depth);
}

1;
__END__

=head1 NAME

Devel::Peek - A data debugging tool for the XS programmer

=head1 SYNOPSIS

        use Devel::Peek;
        Dump( $a );
        Dump( $a, 5 );
        DumpArray( 5, $a, $b, ... );
	mstat "Point 5";

=head1 DESCRIPTION

Devel::Peek contains functions which allows raw Perl datatypes to be
manipulated from a Perl script.  This is used by those who do XS programming
to check that the data they are sending from C to Perl looks as they think
it should look.  The trick, then, is to know what the raw datatype is
supposed to look like when it gets to Perl.  This document offers some tips
and hints to describe good and bad raw data.

It is very possible that this document will fall far short of being useful
to the casual reader.  The reader is expected to understand the material in
the first few sections of L<perlguts>.

Devel::Peek supplies a C<Dump()> function which can dump a raw Perl
datatype, and C<mstat("marker")> function to report on memory usage
(if perl is compiled with corresponding option).  The function
DeadCode() provides statistics on the data "frozen" into inactive
C<CV>.  Devel::Peek also supplies C<SvREFCNT()>, C<SvREFCNT_inc()>, and
C<SvREFCNT_dec()> which can query, increment, and decrement reference
counts on SVs.  This document will take a passive, and safe, approach
to data debugging and for that it will describe only the C<Dump()>
function.

Function C<DumpArray()> allows dumping of multiple values (useful when you
need to analyze returns of functions).

The global variable $Devel::Peek::pv_limit can be set to limit the
number of character printed in various string values.  Setting it to 0
means no limit.

=head2 Memory footprint debugging

When perl is compiled with support for memory footprint debugging
(default with Perl's malloc()), Devel::Peek provides an access to this API.

Use mstat() function to emit a memory state statistic to the terminal.
For more information on the format of output of mstat() see
L<perldebug/Using C<$ENV{PERL_DEBUG_MSTATS}>>.

Three additional functions allow access to this statistic from Perl.
First, use C<mstats_fillhash(%hash)> to get the information contained
in the output of mstat() into %hash. The field of this hash are

  minbucket nbuckets sbrk_good sbrk_slack sbrked_remains sbrks start_slack
  topbucket topbucket_ev topbucket_odd total total_chain total_sbrk totfree

Two additional fields C<free>, C<used> contain array references which
provide per-bucket count of free and used chunks.  Two other fields
C<mem_size>, C<available_size> contain array references which provide
the information about the allocated size and usable size of chunks in
each bucket.  Again, see L<perldebug/Using C<$ENV{PERL_DEBUG_MSTATS}>>
for details.

Keep in mind that only the first several "odd-numbered" buckets are
used, so the information on size of the "odd-numbered" buckets which are
not used is probably meaningless.

The information in

 mem_size available_size minbucket nbuckets

is the property of a particular build of perl, and does not depend on
the current process.  If you do not provide the optional argument to
the functions mstats_fillhash(), fill_mstats(), mstats2hash(), then
the information in fields C<mem_size>, C<available_size> is not
updated.

C<fill_mstats($buf)> is a much cheaper call (both speedwise and
memory-wise) which collects the statistic into $buf in
machine-readable form.  At a later moment you may need to call
C<mstats2hash($buf, %hash)> to use this information to fill %hash.

All three APIs C<fill_mstats($buf)>, C<mstats_fillhash(%hash)>, and
C<mstats2hash($buf, %hash)> are designed to allocate no memory if used
I<the second time> on the same $buf and/or %hash.

So, if you want to collect memory info in a cycle, you may call

  $#buf = 999;
  fill_mstats($_) for @buf;
  mstats_fillhash(%report, 1);		# Static info too

  foreach (@buf) {
    # Do something...
    fill_mstats $_;			# Collect statistic
  }
  foreach (@buf) {
    mstats2hash($_, %report);		# Preserve static info
    # Do something with %report
  }

=head1 EXAMPLES

The following examples don't attempt to show everything as that would be a
monumental task, and, frankly, we don't want this manpage to be an internals
document for Perl.  The examples do demonstrate some basics of the raw Perl
datatypes, and should suffice to get most determined people on their way.
There are no guidewires or safety nets, nor blazed trails, so be prepared to
travel alone from this point and on and, if at all possible, don't fall into
the quicksand (it's bad for business).

Oh, one final bit of advice: take L<perlguts> with you.  When you return we
expect to see it well-thumbed.

=head2 A simple scalar string

Let's begin by looking a simple scalar which is holding a string.

        use Devel::Peek;
        $a = "hello";
        Dump $a;

The output:

        SV = PVIV(0xbc288)
          REFCNT = 1
          FLAGS = (POK,pPOK)
          IV = 0
          PV = 0xb2048 "hello"\0
          CUR = 5
          LEN = 6

This says C<$a> is an SV, a scalar.  The scalar is a PVIV, a string.
Its reference count is 1.  It has the C<POK> flag set, meaning its
current PV field is valid.  Because POK is set we look at the PV item
to see what is in the scalar.  The \0 at the end indicate that this
PV is properly NUL-terminated.
If the FLAGS had been IOK we would look
at the IV item.  CUR indicates the number of characters in the PV.
LEN indicates the number of bytes requested for the PV (one more than
CUR, in this case, because LEN includes an extra byte for the
end-of-string marker).

=head2 A simple scalar number

If the scalar contains a number the raw SV will be leaner.

        use Devel::Peek;
        $a = 42;
        Dump $a;

The output:

        SV = IV(0xbc818)
          REFCNT = 1
          FLAGS = (IOK,pIOK)
          IV = 42

This says C<$a> is an SV, a scalar.  The scalar is an IV, a number.  Its
reference count is 1.  It has the C<IOK> flag set, meaning it is currently
being evaluated as a number.  Because IOK is set we look at the IV item to
see what is in the scalar.

=head2 A simple scalar with an extra reference

If the scalar from the previous example had an extra reference:

        use Devel::Peek;
        $a = 42;
        $b = \$a;
        Dump $a;

The output:

        SV = IV(0xbe860)
          REFCNT = 2
          FLAGS = (IOK,pIOK)
          IV = 42

Notice that this example differs from the previous example only in its
reference count.  Compare this to the next example, where we dump C<$b>
instead of C<$a>.

=head2 A reference to a simple scalar

This shows what a reference looks like when it references a simple scalar.

        use Devel::Peek;
        $a = 42;
        $b = \$a;
        Dump $b;

The output:

        SV = RV(0xf041c)
          REFCNT = 1
          FLAGS = (ROK)
          RV = 0xbab08
        SV = IV(0xbe860)
          REFCNT = 2
          FLAGS = (IOK,pIOK)
          IV = 42

Starting from the top, this says C<$b> is an SV.  The scalar is an RV, a
reference.  It has the C<ROK> flag set, meaning it is a reference.  Because
ROK is set we have an RV item rather than an IV or PV.  Notice that Dump
follows the reference and shows us what C<$b> was referencing.  We see the
same C<$a> that we found in the previous example.

Note that the value of C<RV> coincides with the numbers we see when we
stringify $b. The addresses inside RV() and IV() are addresses of
C<X***> structure which holds the current state of an C<SV>. This
address may change during lifetime of an SV.

=head2 A reference to an array

This shows what a reference to an array looks like.

        use Devel::Peek;
        $a = [42];
        Dump $a;

The output:

        SV = RV(0xf041c)
          REFCNT = 1
          FLAGS = (ROK)
          RV = 0xb2850
        SV = PVAV(0xbd448)
          REFCNT = 1
          FLAGS = ()
          IV = 0
          NV = 0
          ARRAY = 0xb2048
          ALLOC = 0xb2048
          FILL = 0
          MAX = 0
          ARYLEN = 0x0
          FLAGS = (REAL)
        Elt No. 0 0xb5658
        SV = IV(0xbe860)
          REFCNT = 1
          FLAGS = (IOK,pIOK)
          IV = 42

This says C<$a> is an SV and that it is an RV.  That RV points to
another SV which is a PVAV, an array.  The array has one element,
element zero, which is another SV. The field C<FILL> above indicates
the last element in the array, similar to C<$#$a>.

If C<$a> pointed to an array of two elements then we would see the
following.

        use Devel::Peek 'Dump';
        $a = [42,24];
        Dump $a;

The output:

        SV = RV(0xf041c)
          REFCNT = 1
          FLAGS = (ROK)
          RV = 0xb2850
        SV = PVAV(0xbd448)
          REFCNT = 1
          FLAGS = ()
          IV = 0
          NV = 0
          ARRAY = 0xb2048
          ALLOC = 0xb2048
          FILL = 0
          MAX = 0
          ARYLEN = 0x0
          FLAGS = (REAL)
        Elt No. 0  0xb5658
        SV = IV(0xbe860)
          REFCNT = 1
          FLAGS = (IOK,pIOK)
          IV = 42
        Elt No. 1  0xb5680
        SV = IV(0xbe818)
          REFCNT = 1
          FLAGS = (IOK,pIOK)
          IV = 24

Note that C<Dump> will not report I<all> the elements in the array,
only several first (depending on how deep it already went into the
report tree).

=head2 A reference to a hash

The following shows the raw form of a reference to a hash.

        use Devel::Peek;
        $a = {hello=>42};
        Dump $a;

The output:

        SV = RV(0xf041c)
          REFCNT = 1
          FLAGS = (ROK)
          RV = 0xb2850
        SV = PVHV(0xbd448)
          REFCNT = 1
          FLAGS = ()
          NV = 0
          ARRAY = 0xbd748
          KEYS = 1
          FILL = 1
          MAX = 7
          RITER = -1
          EITER = 0x0
        Elt "hello" => 0xbaaf0
        SV = IV(0xbe860)
          REFCNT = 1
          FLAGS = (IOK,pIOK)
          IV = 42

This shows C<$a> is a reference pointing to an SV.  That SV is a PVHV, a
hash. Fields RITER and EITER are used by C<L<each>>.

=head2 Dumping a large array or hash

The C<Dump()> function, by default, dumps up to 4 elements from a
toplevel array or hash.  This number can be increased by supplying a
second argument to the function.

        use Devel::Peek;
        $a = [10,11,12,13,14];
        Dump $a;

Notice that C<Dump()> prints only elements 10 through 13 in the above code.
The following code will print all of the elements.

        use Devel::Peek 'Dump';
        $a = [10,11,12,13,14];
        Dump $a, 5;

=head2 A reference to an SV which holds a C pointer

This is what you really need to know as an XS programmer, of course.  When
an XSUB returns a pointer to a C structure that pointer is stored in an SV
and a reference to that SV is placed on the XSUB stack.  So the output from
an XSUB which uses something like the T_PTROBJ map might look something like
this:

        SV = RV(0xf381c)
          REFCNT = 1
          FLAGS = (ROK)
          RV = 0xb8ad8
        SV = PVMG(0xbb3c8)
          REFCNT = 1
          FLAGS = (OBJECT,IOK,pIOK)
          IV = 729160
          NV = 0
          PV = 0
          STASH = 0xc1d10       "CookBookB::Opaque"

This shows that we have an SV which is an RV.  That RV points at another
SV.  In this case that second SV is a PVMG, a blessed scalar.  Because it is
blessed it has the C<OBJECT> flag set.  Note that an SV which holds a C
pointer also has the C<IOK> flag set.  The C<STASH> is set to the package
name which this SV was blessed into.

The output from an XSUB which uses something like the T_PTRREF map, which
doesn't bless the object, might look something like this:

        SV = RV(0xf381c)
          REFCNT = 1
          FLAGS = (ROK)
          RV = 0xb8ad8
        SV = PVMG(0xbb3c8)
          REFCNT = 1
          FLAGS = (IOK,pIOK)
          IV = 729160
          NV = 0
          PV = 0

=head2 A reference to a subroutine

Looks like this:

	SV = RV(0x798ec)
	  REFCNT = 1
	  FLAGS = (TEMP,ROK)
	  RV = 0x1d453c
	SV = PVCV(0x1c768c)
	  REFCNT = 2
	  FLAGS = ()
	  IV = 0
	  NV = 0
	  COMP_STASH = 0x31068  "main"
	  START = 0xb20e0
	  ROOT = 0xbece0
	  XSUB = 0x0
	  XSUBANY = 0
	  GVGV::GV = 0x1d44e8   "MY" :: "top_targets"
	  FILE = "(eval 5)"
	  DEPTH = 0
	  PADLIST = 0x1c9338

This shows that 

=over

=item *

the subroutine is not an XSUB (since C<START> and C<ROOT> are
non-zero, and C<XSUB> is zero);

=item *

that it was compiled in the package C<main>;

=item *

under the name C<MY::top_targets>; 

=item *

inside a 5th eval in the program;

=item *

it is not currently executed (see C<DEPTH>);

=item *

it has no prototype (C<PROTOTYPE> field is missing).

=back

=head1 EXPORTS

C<Dump>, C<mstat>, C<DeadCode>, C<DumpArray>, C<DumpWithOP> and
C<DumpProg>, C<fill_mstats>, C<mstats_fillhash>, C<mstats2hash> by
default. Additionally available C<SvREFCNT>, C<SvREFCNT_inc> and
C<SvREFCNT_dec>.

=head1 BUGS

Readers have been known to skip important parts of L<perlguts>, causing much
frustration for all.

=head1 AUTHOR

Ilya Zakharevich	ilya@math.ohio-state.edu

Copyright (c) 1995-98 Ilya Zakharevich. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

Author of this software makes no claim whatsoever about suitability,
reliability, edability, editability or usability of this product, and
should not be kept liable for any damage resulting from the use of
it. If you can use it, you are in luck, if not, I should not be kept
responsible. Keep a handy copy of your backup tape at hand.

=head1 SEE ALSO

L<perlguts>, and L<perlguts>, again.

=cut
ader file.  In older versions of C<DB>, it was
int, while                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                package Devel::SelfStubber;
require SelfLoader;
@ISA = qw(SelfLoader);
@EXPORT = 'AUTOLOAD';
$JUST_STUBS = 1;
$VERSION = '1.02';
sub Version {$VERSION}

# Use as
# perl -e 'use Devel::SelfStubber;Devel::SelfStubber->stub(MODULE_NAME,LIB)'
# (LIB defaults to '.') e.g.
# perl -e 'use Devel::SelfStubber;Devel::SelfStubber->stub('Math::BigInt')'
# would print out stubs needed if you added a __DATA__ before the subs.
# Setting $Devel::SelfStubber::JUST_STUBS to 0 will print out the whole
# module with the stubs entered just before the __DATA__

sub _add_to_cache {
    my($self,$fullname,$pack,$lines, $prototype) = @_;
    push(@DATA,@{$lines});
    if($fullname){push(@STUBS,"sub $fullname $prototype;\n")}; # stubs
    '1;';
}

sub _package_defined {
    my($self,$line) = @_;
    push(@DATA,$line);
}

sub stub {
    my($self,$module,$lib) = @_;
    my($line,$end,$fh,$mod_file,$found_selfloader);
    $lib ||= '.';
    ($mod_file = $module) =~ s,::,/,g;
    
    $mod_file = "$lib/$mod_file.pm";
    $fh = "${module}::DATA";

    open($fh,$mod_file) || die "Unable to open $mod_file";
    while(defined ($line = <$fh>) and $line !~ m/^__DATA__/) {
	push(@BEFORE_DATA,$line);
	$line =~ /use\s+SelfLoader/ && $found_selfloader++;
    }
    $line =~ m/^__DATA__/ || die "$mod_file doesn't contain a __DATA__ token";
    $found_selfloader || 
	print 'die "\'use SelfLoader;\' statement NOT FOUND!!\n"',"\n";
    $self->_load_stubs($module);
    if ( fileno($fh) ) {
	$end = 1;
	while(defined($line = <$fh>)) {
	    push(@AFTER_DATA,$line);
	}
    }
    unless ($JUST_STUBS) {
    	print @BEFORE_DATA;
    }
    print @STUBS;
    unless ($JUST_STUBS) {
    	print "1;\n__DATA__\n",@DATA;
    	if($end) { print "__END__\n",@AFTER_DATA; }
    }
}

1;
__END__

=head1 NAME

Devel::SelfStubber - generate stubs for a SelfLoading module

=head1 SYNOPSIS

To generate just the stubs:

    use Devel::SelfStubber;
    Devel::SelfStubber->stub('MODULENAME','MY_LIB_DIR');

or to generate the whole module with stubs inserted correctly

    use Devel::SelfStubber;
    $Devel::SelfStubber::JUST_STUBS=0;
    Devel::SelfStubber->stub('MODULENAME','MY_LIB_DIR');

MODULENAME is the Perl module name, e.g. Devel::SelfStubber,
NOT 'Devel/SelfStubber' or 'Devel/SelfStubber.pm'.

MY_LIB_DIR defaults to '.' if not present.

=head1 DESCRIPTION

Devel::SelfStubber prints the stubs you need to put in the module
before the __DATA__ token (or you can get it to print the entire
module with stubs correctly placed). The stubs ensure that if
a method is called, it will get loaded. They are needed specifically
for inherited autoloaded methods.

This is best explained using the following example:

Assume four classes, A,B,C & D.

A is the root class, B is a subclass of A, C is a subclass of B,
and D is another subclass of A.

                        A
                       / \
                      B   D
                     /
                    C

If D calls an autoloaded method 'foo' which is defined in class A,
then the method is loaded into class A, then executed. If C then
calls method 'foo', and that method was reimplemented in class
B, but set to be autoloaded, then the lookup mechanism never gets to
the AUTOLOAD mechanism in B because it first finds the method
already loaded in A, and so erroneously uses that. If the method
foo had been stubbed in B, then the lookup mechanism would have
found the stub, and correctly loaded and used the sub from B.

So, for classes and subclasses to have inheritance correctly
work with autoloading, you need to ensure stubs are loaded.

The SelfLoader can load stubs automatically at module initialization
with the statement 'SelfLoader-E<gt>load_stubs()';, but you may wish to
avoid having the stub loading overhead associated with your
initialization (though note that the SelfLoader::load_stubs method
will be called sooner or later - at latest when the first sub
is being autoloaded). In this case, you can put the sub stubs
before the __DATA__ token. This can be done manually, but this
module allows automatic generation of the stubs.

By default it just prints the stubs, but you can set the
global $Devel::SelfStubber::JUST_STUBS to 0 and it will
print out the entire module with the stubs positioned correctly.

At the very least, this is useful to see what the SelfLoader
thinks are stubs - in order to ensure future versions of the
SelfStubber remain in step with the SelfLoader, the
SelfStubber actually uses the SelfLoader to determine which
stubs are needed.

=cut
item C<freetype>

From F<mallocsrc.U>:

This variable contains the return type of free(                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                package diagnostics;

=head1 NAME

diagnostics - Perl compiler pragma to force verbose warning diagnostics

splain - standalone program to do the same thing

=head1 SYNOPSIS

As a pragma:

    use diagnostics;
    use diagnostics -verbose;

    enable  diagnostics;
    disable diagnostics;

Aa a program:

    perl program 2>diag.out
    splain [-v] [-p] diag.out


=head1 DESCRIPTION

=head2 The C<diagnostics> Pragma

This module extends the terse diagnostics normally emitted by both the
perl compiler and the perl interpreter, augmenting them with the more
explicative and endearing descriptions found in L<perldiag>.  Like the
other pragmata, it affects the compilation phase of your program rather
than merely the execution phase.

To use in your program as a pragma, merely invoke

    use diagnostics;

at the start (or near the start) of your program.  (Note 
that this I<does> enable perl's B<-w> flag.)  Your whole
compilation will then be subject(ed :-) to the enhanced diagnostics.
These still go out B<STDERR>.

Due to the interaction between runtime and compiletime issues,
and because it's probably not a very good idea anyway,
you may not use C<no diagnostics> to turn them off at compiletime.
However, you may control their behaviour at runtime using the 
disable() and enable() methods to turn them off and on respectively.

The B<-verbose> flag first prints out the L<perldiag> introduction before
any other diagnostics.  The $diagnostics::PRETTY variable can generate nicer
escape sequences for pagers.

Warnings dispatched from perl itself (or more accurately, those that match
descriptions found in L<perldiag>) are only displayed once (no duplicate
descriptions).  User code generated warnings ala warn() are unaffected,
allowing duplicate user messages to be displayed.

=head2 The I<splain> Program

While apparently a whole nuther program, I<splain> is actually nothing
more than a link to the (executable) F<diagnostics.pm> module, as well as
a link to the F<diagnostics.pod> documentation.  The B<-v> flag is like
the C<use diagnostics -verbose> directive.
The B<-p> flag is like the
$diagnostics::PRETTY variable.  Since you're post-processing with 
I<splain>, there's no sense in being able to enable() or disable() processing.

Output from I<splain> is directed to B<STDOUT>, unlike the pragma.

=head1 EXAMPLES

The following file is certain to trigger a few errors at both
runtime and compiletime:

    use diagnostics;
    print NOWHERE "nothing\n";
    print STDERR "\n\tThis message should be unadorned.\n";
    warn "\tThis is a user warning";
    print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: ";
    my $a, $b = scalar <STDIN>;
    print "\n";
    print $x/$y;

If you prefer to run your program first and look at its problem
afterwards, do this:

    perl -w test.pl 2>test.out
    ./splain < test.out

Note that this is not in general possible in shells of more dubious heritage, 
as the theoretical 

    (perl -w test.pl >/dev/tty) >& test.out
    ./splain < test.out

Because you just moved the existing B<stdout> to somewhere else.

If you don't want to modify your source code, but still have on-the-fly
warnings, do this:

    exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&- 

Nifty, eh?

If you want to control warnings on the fly, do something like this.
Make sure you do the C<use> first, or you won't be able to get
at the enable() or disable() methods.

    use diagnostics; # checks entire compilation phase 
	print "\ntime for 1st bogus diags: SQUAWKINGS\n";
	print BOGUS1 'nada';
	print "done with 1st bogus\n";

    disable diagnostics; # only turns off runtime warnings
	print "\ntime for 2nd bogus: (squelched)\n";
	print BOGUS2 'nada';
	print "done with 2nd bogus\n";

    enable diagnostics; # turns back on runtime warnings
	print "\ntime for 3rd bogus: SQUAWKINGS\n";
	print BOGUS3 'nada';
	print "done with 3rd bogus\n";

    disable diagnostics;
	print "\ntime for 4th bogus: (squelched)\n";
	print BOGUS4 'nada';
	print "done with 4th bogus\n";

=head1 INTERNALS

Diagnostic messages derive from the F<perldiag.pod> file when available at
runtime.  Otherwise, they may be embedded in the file itself when the
splain package is built.   See the F<Makefile> for details.

If an extant $SIG{__WARN__} handler is discovered, it will continue
to be honored, but only after the diagnostics::splainthis() function 
(the module's $SIG{__WARN__} interceptor) has had its way with your
warnings.

There is a $diagnostics::DEBUG variable you may set if you're desperately
curious what sorts of things are being intercepted.

    BEGIN { $diagnostics::DEBUG = 1 } 


=head1 BUGS

Not being able to say "no diagnostics" is annoying, but may not be
insurmountable.

The C<-pretty> directive is called too late to affect matters.
You have to do this instead, and I<before> you load the module.

    BEGIN { $diagnostics::PRETTY = 1 } 

I could start up faster by delaying compilation until it should be
needed, but this gets a "panic: top_level" when using the pragma form
in Perl 5.001e.

While it's true that this documentation is somewhat subserious, if you use
a program named I<splain>, you should expect a bit of whimsy.

=head1 AUTHOR

Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.

=cut

use strict;
use 5.6.0;
use Carp;

our $VERSION = 1.0;
our $DEBUG;
our $VERBOSE;
our $PRETTY;

use Config;
my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
if ($^O eq 'VMS') {
    require VMS::Filespec;
    $privlib = VMS::Filespec::unixify($privlib);
    $archlib = VMS::Filespec::unixify($archlib);
}
my @trypod = (
	   "$archlib/pod/perldiag.pod",
	   "$privlib/pod/perldiag-$Config{version}.pod",
	   "$privlib/pod/perldiag.pod",
	   "$archlib/pods/perldiag.pod",
	   "$privlib/pods/perldiag-$Config{version}.pod",
	   "$privlib/pods/perldiag.pod",
	  );
# handy for development testing of new warnings etc
unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
(my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];

if ($^O eq 'MacOS') {
    # just updir one from each lib dir, we'll find it ...
    ($PODFILE) = grep { -e } map { "$_:pod:perldiag.pod" } @INC;
}

$DEBUG ||= 0;
my $WHOAMI = ref bless [];  # nobody's business, prolly not even mine

local $| = 1;
local $_;

my $standalone;
my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);

CONFIG: {
    our $opt_p = our $opt_d = our $opt_v = our $opt_f = '';

    unless (caller) {
	$standalone++;
	require Getopt::Std;
	Getopt::Std::getopts('pdvf:')
	    or die "Usage: $0 [-v] [-p] [-f splainpod]";
	$PODFILE = $opt_f if $opt_f;
	$DEBUG = 2 if $opt_d;
	$VERBOSE = $opt_v;
	$PRETTY = $opt_p;
    }

    if (open(POD_DIAG, $PODFILE)) {
	warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
	last CONFIG;
    } 

    if (caller) {
	INCPATH: {
	    for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
		warn "Checking $file\n" if $DEBUG;
		if (open(POD_DIAG, $file)) {
		    while (<POD_DIAG>) {
			next unless
			    /^__END__\s*# wish diag dbase were more accessible/;
			print STDERR "podfile is $file\n" if $DEBUG;
			last INCPATH;
		    }
		}
	    } 
	}
    } else { 
	print STDERR "podfile is <DATA>\n" if $DEBUG;
	*POD_DIAG = *main::DATA;
    }
}
if (eof(POD_DIAG)) { 
    die "couldn't find diagnostic data in $PODFILE @INC $0";
}


%HTML_2_Troff = (
    'amp'	=>	'&',	#   ampersand
    'lt'	=>	'<',	#   left chevron, less-than
    'gt'	=>	'>',	#   right chevron, greater-than
    'quot'	=>	'"',	#   double quote

    "Aacute"	=>	"A\\*'",	#   capital A, acute accent
    # etc

);

%HTML_2_Latin_1 = (
    'amp'	=>	'&',	#   ampersand
    'lt'	=>	'<',	#   left chevron, less-than
    'gt'	=>	'>',	#   right chevron, greater-than
    'quot'	=>	'"',	#   double quote

    "Aacute"	=>	"\xC1"	#   capital A, acute accent

    # etc
);

%HTML_2_ASCII_7 = (
    'amp'	=>	'&',	#   ampersand
    'lt'	=>	'<',	#   left chevron, less-than
    'gt'	=>	'>',	#   right chevron, greater-than
    'quot'	=>	'"',	#   double quote

    "Aacute"	=>	"A"	#   capital A, acute accent
    # etc
);

our %HTML_Escapes;
*HTML_Escapes = do {
    if ($standalone) {
	$PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7; 
    } else {
	\%HTML_2_Latin_1; 
    }
}; 

*THITHER = $standalone ? *STDOUT : *STDERR;

my $transmo = <<EOFUNC;
sub transmo {
    #local \$^W = 0;  # recursive warnings we do NOT need!
    study;
EOFUNC

my %msg;
{
    print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
    local $/ = '';
    local $_;
    my $header;
    my $for_item;
    while (<POD_DIAG>) {

	unescape();
	if ($PRETTY) {
	    sub noop   { return $_[0] }  # spensive for a noop
	    sub bold   { my $str =$_[0];  $str =~ s/(.)/$1\b$1/g; return $str; } 
	    sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g;  return $str; } 
	    s/[BC]<(.*?)>/bold($1)/ges;
	    s/[LIF]<(.*?)>/italic($1)/ges;
	} else {
	    s/[BC]<(.*?)>/$1/gs;
	    s/[LIF]<(.*?)>/$1/gs;
	} 
	unless (/^=/) {
	    if (defined $header) { 
		if ( $header eq 'DESCRIPTION' && 
		    (   /Optional warnings are enabled/ 
		     || /Some of these messages are generic./
		    ) )
		{
		    next;
		} 
		s/^/    /gm;
		$msg{$header} .= $_;
	 	undef $for_item;	
	    }
	    next;
	} 
	unless ( s/=item (.*?)\s*\z//) {

	    if ( s/=head1\sDESCRIPTION//) {
		$msg{$header = 'DESCRIPTION'} = '';
		undef $for_item;
	    }
	    elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
		$for_item = $1;
	    } 
	    next;
	}

	# strip formatting directives in =item line
	$header = $for_item || $1;
	undef $for_item;	
	$header =~ s/[A-Z]<(.*?)>/$1/g;

	if ($header =~ /%[csd]/) {
	    my $rhs = my $lhs = $header;
	    if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E-?\\d+\Q$2\E/g)  {
		$lhs =~ s/\\%s/.*?/g;
	    } else {
		# if i had lookbehind negations,
		# i wouldn't have to do this \377 noise
		$lhs =~ s/(.*?)%s/\Q$1\E.*?\377/g;
		$lhs =~ s/\377([^\377]*)$/\Q$1\E/;
		$lhs =~ s/\377//g;
		$lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all
	    } 
	    $lhs =~ s/\\%c/./g;
	    $transmo .= "    s{^$lhs}\n     {\Q$rhs\E}s\n\t&& return 1;\n";
	} else {
	    $transmo .= "    m{^\Q$header\E} && return 1;\n";
	} 

	print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
	    if $msg{$header};

	$msg{$header} = '';
    } 


    close POD_DIAG unless *main::DATA eq *POD_DIAG;

    die "No diagnostics?" unless %msg;

    $transmo .= "    return 0;\n}\n";
    print STDERR $transmo if $DEBUG;
    eval $transmo;
    die $@ if $@;
}

if ($standalone) {
    if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } 
    while (defined (my $error = <>)) {
	splainthis($error) || print THITHER $error;
    } 
    exit;
} 

my $olddie;
my $oldwarn;

sub import {
    shift;
    $^W = 1; # yup, clobbered the global variable; 
	     # tough, if you want diags, you want diags.
    return if $SIG{__WARN__} eq \&warn_trap;

    for (@_) {

	/^-d(ebug)?$/ 	   	&& do {
				    $DEBUG++;
				    next;
				   };

	/^-v(erbose)?$/ 	&& do {
				    $VERBOSE++;
				    next;
				   };

	/^-p(retty)?$/ 		&& do {
				    print STDERR "$0: I'm afraid it's too late for prettiness.\n";
				    $PRETTY++;
				    next;
			       };

	warn "Unknown flag: $_";
    } 

    $oldwarn = $SIG{__WARN__};
    $olddie = $SIG{__DIE__};
    $SIG{__WARN__} = \&warn_trap;
    $SIG{__DIE__} = \&death_trap;
} 

sub enable { &import }

sub disable {
    shift;
    return unless $SIG{__WARN__} eq \&warn_trap;
    $SIG{__WARN__} = $oldwarn || '';
    $SIG{__DIE__} = $olddie || '';
} 

sub warn_trap {
    my $warning = $_[0];
    if (caller eq $WHOAMI or !splainthis($warning)) {
	print STDERR $warning;
    } 
    &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
};

sub death_trap {
    my $exception = $_[0];

    # See if we are coming from anywhere within an eval. If so we don't
    # want to explain the exception because it's going to get caught.
    my $in_eval = 0;
    my $i = 0;
    while (1) {
      my $caller = (caller($i++))[3] or last;
      if ($caller eq '(eval)') {
	$in_eval = 1;
	last;
      }
    }

    splainthis($exception) unless $in_eval;
    if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; } 
    &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;

    # We don't want to unset these if we're coming from an eval because
    # then we've turned off diagnostics. (Actually what does this next
    # line do?  -PSeibel)
    $SIG{__DIE__} = $SIG{__WARN__} = '' unless $in_eval;
    local($Carp::CarpLevel) = 1;
    confess "Uncaught exception from user code:\n\t$exception";
	# up we go; where we stop, nobody knows, but i think we die now
	# but i'm deeply afraid of the &$olddie guy reraising and us getting
	# into an indirect recursion loop
};

my %exact_duplicate;
my %old_diag;
my $count;
my $wantspace;
sub splainthis {
    local $_ = shift;
    local $\;
    ### &finish_compilation unless %msg;
    s/\.?\n+$//;
    my $orig = $_;
    # return unless defined;
    s/, <.*?> (?:line|chunk).*$//;
    my $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/;
    s/^\((.*)\)$/$1/;
    if ($exact_duplicate{$orig}++) {
	return &transmo;
    }
    else {
	return 0 unless &transmo;
    }
    $orig = shorten($orig);
    if ($old_diag{$_}) {
	autodescribe();
	print THITHER "$orig (#$old_diag{$_})\n";
	$wantspace = 1;
    } else {
	autodescribe();
	$old_diag{$_} = ++$count;
	print THITHER "\n" if $wantspace;
	$wantspace = 0;
	print THITHER "$orig (#$old_diag{$_})\n";
	if ($msg{$_}) {
	    print THITHER $msg{$_};
	} else {
	    if (0 and $standalone) { 
		print THITHER "    **** Error #$old_diag{$_} ",
			($real ? "is" : "appears to be"),
			" an unknown diagnostic message.\n\n";
	    }
	    return 0;
	} 
    }
    return 1;
} 

sub autodescribe {
    if ($VERBOSE and not $count) {
	print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
		"\n$msg{DESCRIPTION}\n";
    } 
} 

sub unescape { 
    s {
            E<  
            ( [A-Za-z]+ )       
            >   
    } { 
         do {   
             exists $HTML_Escapes{$1}
                ? do { $HTML_Escapes{$1} }
                : do {
                    warn "Unknown escape: E<$1> in $_";
                    "E<$1>";
                } 
         } 
    }egx;
}

sub shorten {
    my $line = $_[0];
    if (length($line) > 79 and index($line, "\n") == -1) {
	my $space_place = rindex($line, ' ', 79);
	if ($space_place != -1) {
	    substr($line, $space_place, 1) = "\n\t";
	} 
    } 
    return $line;
} 


1 unless $standalone;  # or it'll complain about itself
__END__ # wish diag dbase were more accessible
ad of <sys/ioctl.h>.

=item C<i_sysstat>

From F<i_sysstat.U>:

This variable conditionally defines the C<I_SYS_STAT> symbol,
and indicates whether a C program should include <sys/stat.h>.

=item C<i_sysstatfs>

From F<i_sysstatfs.U>:

This variable conditionally d                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                package Digest::MD5;

use strict;
use vars qw($VERSION @ISA @EXPORT_OK);

$VERSION = '2.16';  # $Date: 2001/09/07 05:45:14 $

require Exporter;
*import = \&Exporter::import;
@EXPORT_OK = qw(md5 md5_hex md5_base64);

require DynaLoader;
@ISA=qw(DynaLoader);

eval {
    Digest::MD5->bootstrap($VERSION);
};
if ($@) {
    my $olderr = $@;
    eval {
	# Try to load the pure perl version
	require Digest::Perl::MD5;

	Digest::Perl::MD5->import(qw(md5 md5_hex md5_base64));
	push(@ISA, "Digest::Perl::MD5");  # make OO interface work
    };
    if ($@) {
	# restore the original error
	die $olderr;
    }
}
else {
    *reset = \&new;
}

1;
__END__

=head1 NAME

Digest::MD5 - Perl interface to the MD5 Algorithm

=head1 SYNOPSIS

 # Functional style
 use Digest::MD5  qw(md5 md5_hex md5_base64);

 $digest = md5($data);
 $digest = md5_hex($data);
 $digest = md5_base64($data);

 # OO style
 use Digest::MD5;

 $ctx = Digest::MD5->new;

 $ctx->add($data);
 $ctx->addfile(*FILE);

 $digest = $ctx->digest;
 $digest = $ctx->hexdigest;
 $digest = $ctx->b64digest;

=head1 DESCRIPTION

The C<Digest::MD5> module allows you to use the RSA Data Security
Inc. MD5 Message Digest algorithm from within Perl programs.  The
algorithm takes as input a message of arbitrary length and produces as
output a 128-bit "fingerprint" or "message digest" of the input.

The C<Digest::MD5> module provide a procedural interface for simple
use, as well as an object oriented interface that can handle messages
of arbitrary length and which can read files directly.

A binary digest will be 16 bytes long.  A hex digest will be 32
characters long.  A base64 digest will be 22 characters long.

=head1 FUNCTIONS

The following functions can be exported from the C<Digest::MD5>
module.  No functions are exported by default.

=over 4

=item md5($data,...)

This function will concatenate all arguments, calculate the MD5 digest
of this "message", and return it in binary form.

=item md5_hex($data,...)

Same as md5(), but will return the digest in hexadecimal form.

=item md5_base64($data,...)

Same as md5(), but will return the digest as a base64 encoded string.

The base64 encoded string returned is not padded to be a multiple of 4
bytes long.  If you want interoperability with other base64 encoded
md5 digests you might want to append the string "==" to the result.

=back

=head1 METHODS

The following methods are available:

=over 4

=item $md5 = Digest::MD5->new

The constructor returns a new C<Digest::MD5> object which encapsulate
the state of the MD5 message-digest algorithm.  You can add data to
the object and finally ask for the digest.

If called as a instance method (i.e. $md5->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.

=item $md5->reset

This is just an alias for $md5->new.

=item $md5->add($data,...)

The $data provided as argument are appended to the message we
calculate the digest for.  The return value is the $md5 object itself.

=item $md5->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 $md5
object itself.

In most cases you want to make sure that the $io_handle is set up to
be in binmode().

=item $md5->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 C<Digest::MD5>
object is automatically C<reset> and can be used to calculate another
digest value.

=item $md5->hexdigest

Same as $md5->digest, but will return the digest in hexadecimal form.

=item $md5->b64digest

Same as $md5->digest, but will return the digest as a base64 encoded
string.

The base64 encoded string returned is not padded to be a multiple of 4
bytes long.  If you want interoperability with other base64 encoded
md5 digests you might want to append the string "==" to the result.

=back


=head1 EXAMPLES

The simplest way to use this library is to import the md5_hex()
function (or one of its cousins):

    use Digest::MD5 qw(md5_hex);
    print "Digest is ", md5_hex("foobarbaz"), "\n";

The above example would print out the message

    Digest is 6df23dc03f9b54cc38a0fc1483df6e21

provided that the implementation is working correctly.  The same
checksum can also be calculated in OO style:

    use Digest::MD5;
    
    $md5 = Digest::MD5->new;
    $md5->add('foo', 'bar');
    $md5->add('baz');
    $digest = $md5->hexdigest;
    
    print "Digest is $digest\n";

With OO style you can break the message arbitrary.  This means that we
are no longer limited to have space for the whole message in memory, i.e.
we can handle messages of any size.

This is useful when calculating checksum for files:

    use Digest::MD5;

    my $file = shift || "/etc/passwd";
    open(FILE, $file) or die "Can't open '$file': $!";
    binmode(FILE);

    $md5 = Digest::MD5->new;
    while (<FILE>) {
        $md5->add($_);
    }
    close(FILE);
    print $md5->b64digest, " $file\n";

Or we can use the builtin addfile method for more efficient reading of
the file:

    use Digest::MD5;

    my $file = shift || "/etc/passwd";
    open(FILE, $file) or die "Can't open '$file': $!";
    binmode(FILE);

    print Digest::MD5->new->addfile(*FILE)->hexdigest, " $file\n";

=head1 SEE ALSO

L<Digest>,
L<Digest::MD2>,
L<Digest::SHA1>,
L<Digest::HMAC>

L<md5sum(1)>

RFC 1321

=head1 COPYRIGHT

This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

 Copyright 1998-2001 Gisle Aas.
 Copyright 1995-1996 Neil Winton.
 Copyright 1991-1992 RSA Data Security, Inc.

The MD5 algorithm is defined in RFC 1321. The basic C code
implementing the algorithm is derived from that in the RFC and is
covered by the following copyright:

=over 4

=item

Copyright (C) 1991-2, RSA Data Security, Inc. Created 1991. All
rights reserved.

License to copy and use this software is granted provided that it
is identified as the "RSA Data Security, Inc. MD5 Message-Digest
Algorithm" in all material mentioning or referencing this software
or this function.

License is also granted to make and use derivative works provided
that such works are identified as "derived from the RSA Data
Security, Inc. MD5 Message-Digest Algorithm" in all material
mentioning or referencing the derived work.

RSA Data Security, Inc. makes no representations concerning either
the merchantability of this software or the suitability of this
software for any particular purpose. It is provided "as is"
without express or implied warranty of any kind.

These notices must be retained in any copies of any part of this
documentation and/or software.

=back

This copyright does not prohibit distribution of any version of Perl
containing this extension under the terms of the GNU or Artistic
licenses.

=head1 AUTHORS

The original MD5 interface was written by Neil Winton
(C<N.Winton@axion.bt.co.uk>).

This release was made by Gisle Aas <gisle@ActiveState.com>

=cut
nly this variable
should be used in makefiles.

=item C<installsitebin>

From F<sitebin.U>:

This varia                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                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
erl.a>, but can also be F<libperl.so.xxx> if
the user wishes to build a perl executable with a shared
library.

=item C<libpth>

From F<libpth.U>:

This variable holds the general path (space-separated) used to find
libraries. It is intended to be used by other units.

=item C<libs>

From F<libs.U>:

This variable holds the additional libraries we want to use.
It is up to th                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                package DirHandle;

our $VERSION = '1.00';

=head1 NAME 

DirHandle - supply object methods for directory handles

=head1 SYNOPSIS

    use DirHandle;
    $d = new DirHandle ".";
    if (defined $d) {
        while (defined($_ = $d->read)) { something($_); }
        $d->rewind;
        while (defined($_ = $d->read)) { something_else($_); }
        undef $d;
    }

=head1 DESCRIPTION

The C<DirHandle> method provide an alternative interface to the
opendir(), closedir(), readdir(), and rewinddir() functions.

The only objective benefit to using C<DirHandle> is that it avoids
namespace pollution by creating globs to hold directory handles.

=head1 NOTES

=over 4

=item *

On Mac OS (Classic), the path separator is ':', not '/', and the 
current directory is denoted as ':', not '.'. You should be careful 
about specifying relative pathnames. While a full path always begins 
with a volume name, a relative pathname should always begin with a 
':'.  If specifying a volume name only, a trailing ':' is required.

=back

=cut

require 5.000;
use Carp;
use Symbol;

sub new {
    @_ >= 1 && @_ <= 2 or croak 'usage: new DirHandle [DIRNAME]';
    my $class = shift;
    my $dh = gensym;
    if (@_) {
	DirHandle::open($dh, $_[0])
	    or return undef;
    }
    bless $dh, $class;
}

sub DESTROY {
    my ($dh) = @_;
    closedir($dh);
}

sub open {
    @_ == 2 or croak 'usage: $dh->open(DIRNAME)';
    my ($dh, $dirname) = @_;
    opendir($dh, $dirname);
}

sub close {
    @_ == 1 or croak 'usage: $dh->close()';
    my ($dh) = @_;
    closedir($dh);
}

sub read {
    @_ == 1 or croak 'usage: $dh->read()';
    my ($dh) = @_;
    readdir($dh);
}

sub rewind {
    @_ == 1 or croak 'usage: $dh->rewind()';
    my ($dh) = @_;
    rewinddir($dh);
}

1;
in the Makefile. It is either C<ln -s> or C<ln>

=item C<locincpth>

From F<ccflags.U>:

This variable contains a list of additional directories to be
searched by the compiler.  The appropriate C<-I> directives will
be added to ccflags.  This is intended to simplify setting
local directori                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                #
#   @(#)dotsh.pl                                               03/19/94
#
# This library is no longer being maintained, and is included for backward
# compatibility with Perl 4 programs which may require it.
#
# In particular, this should not be used as an example of modern Perl
# programming techniques.
#
#
#   Author: Charles Collins
#
#   Description:
#      This routine takes a shell script and 'dots' it into the current perl
#      environment. This makes it possible to use existing system scripts
#      to alter environment variables on the fly.
#
#   Usage:
#      &dotsh ('ShellScript', 'DependentVariable(s)');
#
#         where
#
#      'ShellScript' is the full name of the shell script to be dotted
#
#      'DependentVariable(s)' is an optional list of shell variables in the
#         form VARIABLE=VALUE,VARIABLE=VALUE,... that 'ShellScript' is
#         dependent upon. These variables MUST be defined using shell syntax.
#
#   Example:
#      &dotsh ('/tmp/foo', 'arg1');
#      &dotsh ('/tmp/foo');
#      &dotsh ('/tmp/foo arg1 ... argN');
#
sub dotsh {
   local(@sh) = @_;
   local($tmp,$key,$shell,$command,$args,$vars) = '';
   local(*dotsh);
   undef *dotsh;
   $dotsh = shift(@sh);
   @dotsh = split (/\s/, $dotsh);
   $command = shift (@dotsh);
   $args = join (" ", @dotsh);
   $vars = join ("\n", @sh);
   open (_SH_ENV, "$command") || die "Could not open $dotsh!\n";
   chop($_ = <_SH_ENV>);
   $shell = "$1 -c" if ($_ =~ /^\#\!\s*(\S+(\/sh|\/ksh|\/zsh|\/csh))\s*$/);
   close (_SH_ENV);
   if (!$shell) {
      if ($ENV{'SHELL'} =~ /\/sh$|\/ksh$|\/zsh$|\/bash$|\/csh$/) {
	 $shell = "$ENV{'SHELL'} -c";
      } else {
	 print "SHELL not recognized!\nUsing /bin/sh...\n";
	 $shell = "/bin/sh -c";
      }
   }
   if (length($vars) > 0) {
      system "$shell \"$vars;. $command $args; set > /tmp/_sh_env$$\"";
   } else {
      system "$shell \". $command $args; set > /tmp/_sh_env$$\"";
   }

   open (_SH_ENV, "/tmp/_sh_env$$") || die "Could not open /tmp/_sh_env$$!\n";
   while (<_SH_ENV>) {
       chop;
       m/^([^=]*)=(.*)/s;
       $ENV{$1} = $2;
   }
   close (_SH_ENV);
   system "rm -f /tmp/_sh_env$$";

   foreach $key (keys(%ENV)) {
       $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/;
   }
   eval $tmp;
}
1;
s,
the value is reset to a plain C<make> and is not useful.

=item C<make_set_make>

From F<make.U>:

Some versions of C<make> set the variable C<MAKE>.  Others do not.
This variable contains the string to be included in F<Makefile.SH>
so that C<MAKE> is set if needed, and not if no                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                use 5.005_64;			# for (defined ref) and $#$v and our
package Dumpvalue;
use strict;
our(%address, $stab, @stab, %stab, %subs);

# translate control chars to ^X - Randal Schwartz
# Modifications to print types by Peter Gordon v1.0

# Ilya Zakharevich -- patches after 5.001 (and some before ;-)

# Won't dump symbol tables and contents of debugged files by default

# (IZ) changes for objectification:
#   c) quote() renamed to method set_quote();
#   d) unctrlSet() renamed to method set_unctrl();
#   f) Compiles with `use strict', but in two places no strict refs is needed:
#      maybe more problems are waiting...

my %defaults = (
		globPrint	      => 0,
		printUndef	      => 1,
		tick		      => "auto",
		unctrl		      => 'quote',
		subdump		      => 1,
		dumpReused	      => 0,
		bareStringify	      => 1,
		hashDepth	      => '',
		arrayDepth	      => '',
		dumpDBFiles	      => '',
		dumpPackages	      => '',
		quoteHighBit	      => '',
		usageOnly	      => '',
		compactDump	      => '',
		veryCompact	      => '',
		stopDbSignal	      => '',
	       );

sub new {
  my $class = shift;
  my %opt = (%defaults, @_);
  bless \%opt, $class;
}

sub set {
  my $self = shift;
  my %opt = @_;
  @$self{keys %opt} = values %opt;
}

sub get {
  my $self = shift;
  wantarray ? @$self{@_} : $$self{pop @_};
}

sub dumpValue {
  my $self = shift;
  die "usage: \$dumper->dumpValue(value)" unless @_ == 1;
  local %address;
  local $^W=0;
  (print "undef\n"), return unless defined $_[0];
  (print $self->stringify($_[0]), "\n"), return unless ref $_[0];
  $self->unwrap($_[0],0);
}

sub dumpValues {
  my $self = shift;
  local %address;
  local $^W=0;
  (print "undef\n"), return unless defined $_[0];
  $self->unwrap(\@_,0);
}

# This one is good for variable names:

sub unctrl {
  local($_) = @_;

  return \$_ if ref \$_ eq "GLOB";
  s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
  $_;
}

sub stringify {
  my $self = shift;
  local $_ = shift;
  my $noticks = shift;
  my $tick = $self->{tick};

  return 'undef' unless defined $_ or not $self->{printUndef};
  return $_ . "" if ref \$_ eq 'GLOB';
  { no strict 'refs';
    $_ = &{'overload::StrVal'}($_)
      if $self->{bareStringify} and ref $_
	and %overload:: and defined &{'overload::StrVal'};
  }

  if ($tick eq 'auto') {
    if (/[\000-\011\013-\037\177]/) {
      $tick = '"';
    } else {
      $tick = "'";
    }
  }
  if ($tick eq "'") {
    s/([\'\\])/\\$1/g;
  } elsif ($self->{unctrl} eq 'unctrl') {
    s/([\"\\])/\\$1/g ;
    s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
    s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg
      if $self->{quoteHighBit};
  } elsif ($self->{unctrl} eq 'quote') {
    s/([\"\\\$\@])/\\$1/g if $tick eq '"';
    s/\033/\\e/g;
    s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
  }
  s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $self->{quoteHighBit};
  ($noticks || /^\d+(\.\d*)?\Z/)
    ? $_
      : $tick . $_ . $tick;
}

sub DumpElem {
  my ($self, $v) = (shift, shift);
  my $short = $self->stringify($v, ref $v);
  my $shortmore = '';
  if ($self->{veryCompact} && ref $v
      && (ref $v eq 'ARRAY' and !grep(ref $_, @$v) )) {
    my $depth = $#$v;
    ($shortmore, $depth) = (' ...', $self->{arrayDepth} - 1)
      if $self->{arrayDepth} and $depth >= $self->{arrayDepth};
    my @a = map $self->stringify($_), @$v[0..$depth];
    print "0..$#{$v}  @a$shortmore\n";
  } elsif ($self->{veryCompact} && ref $v
	   && (ref $v eq 'HASH') and !grep(ref $_, values %$v)) {
    my @a = sort keys %$v;
    my $depth = $#a;
    ($shortmore, $depth) = (' ...', $self->{hashDepth} - 1)
      if $self->{hashDepth} and $depth >= $self->{hashDepth};
    my @b = map {$self->stringify($_) . " => " . $self->stringify($$v{$_})}
      @a[0..$depth];
    local $" = ', ';
    print "@b$shortmore\n";
  } else {
    print "$short\n";
    $self->unwrap($v,shift);
  }
}

sub unwrap {
  my $self = shift;
  return if $DB::signal and $self->{stopDbSignal};
  my ($v) = shift ;
  my ($s) = shift ;		# extra no of spaces
  my $sp;
  my (%v,@v,$address,$short,$fileno);

  $sp = " " x $s ;
  $s += 3 ;

  # Check for reused addresses
  if (ref $v) {
    my $val = $v;
    { no strict 'refs';
      $val = &{'overload::StrVal'}($v)
	if %overload:: and defined &{'overload::StrVal'};
    }
    ($address) = $val =~ /(0x[0-9a-f]+)\)$/ ;
    if (!$self->{dumpReused} && defined $address) {
      $address{$address}++ ;
      if ( $address{$address} > 1 ) {
	print "${sp}-> REUSED_ADDRESS\n" ;
	return ;
      }
    }
  } elsif (ref \$v eq 'GLOB') {
    $address = "$v" . "";	# To avoid a bug with globs
    $address{$address}++ ;
    if ( $address{$address} > 1 ) {
      print "${sp}*DUMPED_GLOB*\n" ;
      return ;
    }
  }

  if (ref $v eq 'Regexp') {
    my $re = "$v";
    $re =~ s,/,\\/,g;
    print "$sp-> qr/$re/\n";
    return;
  }

  if ( UNIVERSAL::isa($v, 'HASH') ) {
    my @sortKeys = sort keys(%$v) ;
    my $more;
    my $tHashDepth = $#sortKeys ;
    $tHashDepth = $#sortKeys < $self->{hashDepth}-1 ? $#sortKeys : $self->{hashDepth}-1
      unless $self->{hashDepth} eq '' ;
    $more = "....\n" if $tHashDepth < $#sortKeys ;
    my $shortmore = "";
    $shortmore = ", ..." if $tHashDepth < $#sortKeys ;
    $#sortKeys = $tHashDepth ;
    if ($self->{compactDump} && !grep(ref $_, values %{$v})) {
      $short = $sp;
      my @keys;
      for (@sortKeys) {
	push @keys, $self->stringify($_) . " => " . $self->stringify($v->{$_});
      }
      $short .= join ', ', @keys;
      $short .= $shortmore;
      (print "$short\n"), return if length $short <= $self->{compactDump};
    }
    for my $key (@sortKeys) {
      return if $DB::signal and $self->{stopDbSignal};
      my $value = $ {$v}{$key} ;
      print $sp, $self->stringify($key), " => ";
      $self->DumpElem($value, $s);
    }
    print "$sp  empty hash\n" unless @sortKeys;
    print "$sp$more" if defined $more ;
  } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) {
    my $tArrayDepth = $#{$v} ;
    my $more ;
    $tArrayDepth = $#$v < $self->{arrayDepth}-1 ? $#$v : $self->{arrayDepth}-1
      unless  $self->{arrayDepth} eq '' ;
    $more = "....\n" if $tArrayDepth < $#{$v} ;
    my $shortmore = "";
    $shortmore = " ..." if $tArrayDepth < $#{$v} ;
    if ($self->{compactDump} && !grep(ref $_, @{$v})) {
      if ($#$v >= 0) {
	$short = $sp . "0..$#{$v}  " .
	  join(" ", 
	       map {exists $v->[$_] ? $self->stringify($v->[$_]) : "empty"} ($[..$tArrayDepth)
	      ) . "$shortmore";
      } else {
	$short = $sp . "empty array";
      }
      (print "$short\n"), return if length $short <= $self->{compactDump};
    }
    for my $num ($[ .. $tArrayDepth) {
      return if $DB::signal and $self->{stopDbSignal};
      print "$sp$num  ";
      if (exists $v->[$num]) {
        $self->DumpElem($v->[$num], $s);
      } else {
	print "empty slot\n";
      }
    }
    print "$sp  empty array\n" unless @$v;
    print "$sp$more" if defined $more ;
  } elsif (  UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) {
    print "$sp-> ";
    $self->DumpElem($$v, $s);
  } elsif ( UNIVERSAL::isa($v, 'CODE') ) {
    print "$sp-> ";
    $self->dumpsub(0, $v);
  } elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
    print "$sp-> ",$self->stringify($$v,1),"\n";
    if ($self->{globPrint}) {
      $s += 3;
      $self->dumpglob('', $s, "{$$v}", $$v, 1);
    } elsif (defined ($fileno = fileno($v))) {
      print( (' ' x ($s+3)) .  "FileHandle({$$v}) => fileno($fileno)\n" );
    }
  } elsif (ref \$v eq 'GLOB') {
    if ($self->{globPrint}) {
      $self->dumpglob('', $s, "{$v}", $v, 1);
    } elsif (defined ($fileno = fileno(\$v))) {
      print( (' ' x $s) .  "FileHandle({$v}) => fileno($fileno)\n" );
    }
  }
}

sub matchvar {
  $_[0] eq $_[1] or
    ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
      ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
}

sub compactDump {
  my $self = shift;
  $self->{compactDump} = shift if @_;
  $self->{compactDump} = 6*80-1 
    if $self->{compactDump} and $self->{compactDump} < 2;
  $self->{compactDump};
}

sub veryCompact {
  my $self = shift;
  $self->{veryCompact} = shift if @_;
  $self->compactDump(1) if !$self->{compactDump} and $self->{veryCompact};
  $self->{veryCompact};
}

sub set_unctrl {
  my $self = shift;
  if (@_) {
    my $in = shift;
    if ($in eq 'unctrl' or $in eq 'quote') {
      $self->{unctrl} = $in;
    } else {
      print "Unknown value for `unctrl'.\n";
    }
  }
  $self->{unctrl};
}

sub set_quote {
  my $self = shift;
  if (@_ and $_[0] eq '"') {
    $self->{tick} = '"';
    $self->{unctrl} = 'quote';
  } elsif (@_ and $_[0] eq 'auto') {
    $self->{tick} = 'auto';
    $self->{unctrl} = 'quote';
  } elsif (@_) {		# Need to set
    $self->{tick} = "'";
    $self->{unctrl} = 'unctrl';
  }
  $self->{tick};
}

sub dumpglob {
  my $self = shift;
  return if $DB::signal and $self->{stopDbSignal};
  my ($package, $off, $key, $val, $all) = @_;
  local(*stab) = $val;
  my $fileno;
  if (($key !~ /^_</ or $self->{dumpDBFiles}) and defined $stab) {
    print( (' ' x $off) . "\$", &unctrl($key), " = " );
    $self->DumpElem($stab, 3+$off);
  }
  if (($key !~ /^_</ or $self->{dumpDBFiles}) and @stab) {
    print( (' ' x $off) . "\@$key = (\n" );
    $self->unwrap(\@stab,3+$off) ;
    print( (' ' x $off) .  ")\n" );
  }
  if ($key ne "main::" && $key ne "DB::" && %stab
      && ($self->{dumpPackages} or $key !~ /::$/)
      && ($key !~ /^_</ or $self->{dumpDBFiles})
      && !($package eq "Dumpvalue" and $key eq "stab")) {
    print( (' ' x $off) . "\%$key = (\n" );
    $self->unwrap(\%stab,3+$off) ;
    print( (' ' x $off) .  ")\n" );
  }
  if (defined ($fileno = fileno(*stab))) {
    print( (' ' x $off) .  "FileHandle($key) => fileno($fileno)\n" );
  }
  if ($all) {
    if (defined &stab) {
      $self->dumpsub($off, $key);
    }
  }
}

sub CvGV_name {
  my $self = shift;
  my $in = shift;
  return if $self->{skipCvGV};	# Backdoor to avoid problems if XS broken...
  $in = \&$in;			# Hard reference...
  eval {require Devel::Peek; 1} or return;
  my $gv = Devel::Peek::CvGV($in) or return;
  *$gv{PACKAGE} . '::' . *$gv{NAME};
}

sub dumpsub {
  my $self = shift;
  my ($off,$sub) = @_;
  my $ini = $sub;
  my $s;
  $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
  my $subref = defined $1 ? \&$sub : \&$ini;
  my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})
    || (($s = $self->CvGV_name($subref)) && $DB::sub{$s})
    || ($self->{subdump} && ($s = $self->findsubs("$subref"))
	&& $DB::sub{$s});
  $s = $sub unless defined $s;
  $place = '???' unless defined $place;
  print( (' ' x $off) .  "&$s in $place\n" );
}

sub findsubs {
  my $self = shift;
  return undef unless %DB::sub;
  my ($addr, $name, $loc);
  while (($name, $loc) = each %DB::sub) {
    $addr = \&$name;
    $subs{"$addr"} = $name;
  }
  $self->{subdump} = 0;
  $subs{ shift() };
}

sub dumpvars {
  my $self = shift;
  my ($package,@vars) = @_;
  local(%address,$^W);
  my ($key,$val);
  $package .= "::" unless $package =~ /::$/;
  *stab = *main::;

  while ($package =~ /(\w+?::)/g) {
    *stab = $ {stab}{$1};
  }
  $self->{TotalStrings} = 0;
  $self->{Strings} = 0;
  $self->{CompleteTotal} = 0;
  while (($key,$val) = each(%stab)) {
    return if $DB::signal and $self->{stopDbSignal};
    next if @vars && !grep( matchvar($key, $_), @vars );
    if ($self->{usageOnly}) {
      $self->globUsage(\$val, $key)
	if ($package ne 'Dumpvalue' or $key ne 'stab')
	   and ref(\$val) eq 'GLOB';
    } else {
      $self->dumpglob($package, 0,$key, $val);
    }
  }
  if ($self->{usageOnly}) {
    print <<EOP;
String space: $self->{TotalStrings} bytes in $self->{Strings} strings.
EOP
    $self->{CompleteTotal} += $self->{TotalStrings};
    print <<EOP;
Grand total = $self->{CompleteTotal} bytes (1 level deep) + overhead.
EOP
  }
}

sub scalarUsage {
  my $self = shift;
  my $size = length($_[0]);
  $self->{TotalStrings} += $size;
  $self->{Strings}++;
  $size;
}

sub arrayUsage {		# array ref, name
  my $self = shift;
  my $size = 0;
  map {$size += $self->scalarUsage($_)} @{$_[0]};
  my $len = @{$_[0]};
  print "\@$_[1] = $len item", ($len > 1 ? "s" : ""), " (data: $size bytes)\n"
      if defined $_[1];
  $self->{CompleteTotal} +=  $size;
  $size;
}

sub hashUsage {			# hash ref, name
  my $self = shift;
  my @keys = keys %{$_[0]};
  my @values = values %{$_[0]};
  my $keys = $self->arrayUsage(\@keys);
  my $values = $self->arrayUsage(\@values);
  my $len = @keys;
  my $total = $keys + $values;
  print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
    " (keys: $keys; values: $values; total: $total bytes)\n"
      if defined $_[1];
  $total;
}

sub globUsage {			# glob ref, name
  my $self = shift;
  local *stab = *{$_[0]};
  my $total = 0;
  $total += $self->scalarUsage($stab) if defined $stab;
  $total += $self->arrayUsage(\@stab, $_[1]) if @stab;
  $total += $self->hashUsage(\%stab, $_[1]) 
    if %stab and $_[1] ne "main::" and $_[1] ne "DB::";	
  #and !($package eq "Dumpvalue" and $key eq "stab"));
  $total;
}

1;

=head1 NAME

Dumpvalue - provides screen dump of Perl data.

=head1 SYNOPSIS

  use Dumpvalue;
  my $dumper = new Dumpvalue;
  $dumper->set(globPrint => 1);
  $dumper->dumpValue(\*::);
  $dumper->dumpvars('main');

=head1 DESCRIPTION

=head2 Creation

A new dumper is created by a call

  $d = new Dumpvalue(option1 => value1, option2 => value2)

Recognized options:

=over

=item C<arrayDepth>, C<hashDepth>

Print only first N elements of arrays and hashes.  If false, prints all the
elements.

=item C<compactDump>, C<veryCompact>

Change style of array and hash dump.  If true, short array
may be printed on one line.

=item C<globPrint>

Whether to print contents of globs.

=item C<DumpDBFiles>

Dump arrays holding contents of debugged files.

=item C<DumpPackages>

Dump symbol tables of packages.

=item C<DumpReused>

Dump contents of "reused" addresses.

=item C<tick>, C<HighBit>, C<printUndef>

Change style of string dump.  Default value of C<tick> is C<auto>, one
can enable either double-quotish dump, or single-quotish by setting it
to C<"> or C<'>.  By default, characters with high bit set are printed
I<as is>.

=item C<UsageOnly>

I<very> rudimentally per-package memory usage dump.  If set,
C<dumpvars> calculates total size of strings in variables in the package.

=item unctrl

Changes the style of printout of strings.  Possible values are
C<unctrl> and C<quote>.

=item subdump

Whether to try to find the subroutine name given the reference.

=item bareStringify

Whether to write the non-overloaded form of the stringify-overloaded objects.

=item quoteHighBit

Whether to print chars with high bit set in binary or "as is".

=item stopDbSignal

Whether to abort printing if debugger signal flag is raised.

=back

Later in the life of the object the methods may be queries with get()
method and set() method (which accept multiple arguments).

=head2 Methods

=over

=item dumpValue

  $dumper->dumpValue($value);
  $dumper->dumpValue([$value1, $value2]);

=item dumpValues

  $dumper->dumpValues($value1, $value2);

=item dumpvars

  $dumper->dumpvars('my_package');
  $dumper->dumpvars('my_package', 'foo', '~bar$', '!......');

The optional arguments are considered as literal strings unless they
start with C<~> or C<!>, in which case they are interpreted as regular
expressions (possibly negated).

The second example prints entries with names C<foo>, and also entries
with names which ends on C<bar>, or are shorter than 5 chars.

=item set_quote

  $d->set_quote('"');

Sets C<tick> and C<unctrl> options to suitable values for printout with the
given quote char.  Possible values are C<auto>, C<'> and C<">.

=item set_unctrl

  $d->set_unctrl('"');

Sets C<unctrl> option with checking for an invalid argument.
Possible values are C<unctrl> and C<quote>.

=item compactDump

  $d->compactDump(1);

Sets C<compactDump> option.  If the value is 1, sets to a reasonable
big number.

=item veryCompact

  $d->veryCompact(1);

Sets C<compactDump> and C<veryCompact> options simultaneously.

=item set

  $d->set(option1 => value1, option2 => value2);

=item get

  @values = $d->get('option1', 'option2');

=back

=cut

 installation (with F<~> substitution).

=item C<privlibexp>

From F<privlib.U>:

This variable is the F<~name> expanded version of privlib, so that you
may use it directly in Makefiles or shell scripts.

=item C<prototype>

Fr                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                require 5.002;			# For (defined ref)
package dumpvar;

# Needed for PrettyPrinter only:

# require 5.001;  # Well, it coredumps anyway undef DB in 5.000 (not now)

# translate control chars to ^X - Randal Schwartz
# Modifications to print types by Peter Gordon v1.0

# Ilya Zakharevich -- patches after 5.001 (and some before ;-)

# Won't dump symbol tables and contents of debugged files by default

$winsize = 80 unless defined $winsize;


# Defaults

# $globPrint = 1;
$printUndef = 1 unless defined $printUndef;
$tick = "auto" unless defined $tick;
$unctrl = 'quote' unless defined $unctrl;
$subdump = 1;
$dumpReused = 0 unless defined $dumpReused;
$bareStringify = 1 unless defined $bareStringify;

sub main::dumpValue {
  local %address;
  local $^W=0;
  (print "undef\n"), return unless defined $_[0];
  (print &stringify($_[0]), "\n"), return unless ref $_[0];
  dumpvar::unwrap($_[0],0);
}

# This one is good for variable names:

sub unctrl {
	local($_) = @_;
	local($v) ; 

	return \$_ if ref \$_ eq "GLOB";
	s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
	$_;
}

sub stringify {
	local($_,$noticks) = @_;
	local($v) ; 
	my $tick = $tick;

	return 'undef' unless defined $_ or not $printUndef;
	return $_ . "" if ref \$_ eq 'GLOB';
	$_ = &{'overload::StrVal'}($_) 
	  if $bareStringify and ref $_ 
	    and %overload:: and defined &{'overload::StrVal'};
	
	if ($tick eq 'auto') {
	  if (/[\000-\011\013-\037\177]/) {
	    $tick = '"';
	  }else {
	    $tick = "'";
	  }
	}
	if ($tick eq "'") {
	  s/([\'\\])/\\$1/g;
	} elsif ($unctrl eq 'unctrl') {
	  s/([\"\\])/\\$1/g ;
	  s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
	  s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg 
	    if $quoteHighBit;
	} elsif ($unctrl eq 'quote') {
	  s/([\"\\\$\@])/\\$1/g if $tick eq '"';
	  s/\033/\\e/g;
	  s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
	}
	s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $quoteHighBit;
	($noticks || /^\d+(\.\d*)?\Z/) 
	  ? $_ 
	  : $tick . $_ . $tick;
}

sub ShortArray {
  my $tArrayDepth = $#{$_[0]} ; 
  $tArrayDepth = $#{$_[0]} < $arrayDepth-1 ? $#{$_[0]} : $arrayDepth-1 
    unless  $arrayDepth eq '' ; 
  my $shortmore = "";
  $shortmore = " ..." if $tArrayDepth < $#{$_[0]} ;
  if (!grep(ref $_, @{$_[0]})) {
    $short = "0..$#{$_[0]}  '" . 
      join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
    return $short if length $short <= $compactDump;
  }
  undef;
}

sub DumpElem {
  my $short = &stringify($_[0], ref $_[0]);
  if ($veryCompact && ref $_[0]
      && (ref $_[0] eq 'ARRAY' and !grep(ref $_, @{$_[0]}) )) {
    my $end = "0..$#{$v}  '" . 
      join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
  } elsif ($veryCompact && ref $_[0]
      && (ref $_[0] eq 'HASH') and !grep(ref $_, values %{$_[0]})) {
    my $end = 1;
	  $short = $sp . "0..$#{$v}  '" . 
	    join("' '", @{$v}[0..$tArrayDepth]) . "'$shortmore";
  } else {
    print "$short\n";
    unwrap($_[0],$_[1]);
  }
}

sub unwrap {
    return if $DB::signal;
    local($v) = shift ; 
    local($s) = shift ; # extra no of spaces
    local(%v,@v,$sp,$value,$key,@sortKeys,$more,$shortmore,$short) ;
    local($tHashDepth,$tArrayDepth) ;

    $sp = " " x $s ;
    $s += 3 ; 

    # Check for reused addresses
    if (ref $v) { 
      my $val = $v;
      $val = &{'overload::StrVal'}($v) 
	if %overload:: and defined &{'overload::StrVal'};
      ($address) = $val =~ /(0x[0-9a-f]+)\)$/ ; 
      if (!$dumpReused && defined $address) { 
	$address{$address}++ ;
	if ( $address{$address} > 1 ) { 
	  print "${sp}-> REUSED_ADDRESS\n" ; 
	  return ; 
	} 
      }
    } elsif (ref \$v eq 'GLOB') {
      $address = "$v" . "";	# To avoid a bug with globs
      $address{$address}++ ;
      if ( $address{$address} > 1 ) { 
	print "${sp}*DUMPED_GLOB*\n" ; 
	return ; 
      } 
    }

    if (ref $v eq 'Regexp') {
      my $re = "$v";
      $re =~ s,/,\\/,g;
      print "$sp-> qr/$re/\n";
      return;
    }

    if ( UNIVERSAL::isa($v, 'HASH') ) { 
	@sortKeys = sort keys(%$v) ;
	undef $more ; 
	$tHashDepth = $#sortKeys ; 
	$tHashDepth = $#sortKeys < $hashDepth-1 ? $#sortKeys : $hashDepth-1
	  unless $hashDepth eq '' ; 
	$more = "....\n" if $tHashDepth < $#sortKeys ; 
	$shortmore = "";
	$shortmore = ", ..." if $tHashDepth < $#sortKeys ; 
	$#sortKeys = $tHashDepth ; 
	if ($compactDump && !grep(ref $_, values %{$v})) {
	  #$short = $sp . 
	  #  (join ', ', 
# Next row core dumps during require from DB on 5.000, even with map {"_"}
	  #   map {&stringify($_) . " => " . &stringify($v->{$_})} 
	  #   @sortKeys) . "'$shortmore";
	  $short = $sp;
	  my @keys;
	  for (@sortKeys) {
	    push @keys, &stringify($_) . " => " . &stringify($v->{$_});
	  }
	  $short .= join ', ', @keys;
	  $short .= $shortmore;
	  (print "$short\n"), return if length $short <= $compactDump;
	}
	for $key (@sortKeys) {
	    return if $DB::signal;
	    $value = $ {$v}{$key} ;
	    print "$sp", &stringify($key), " => ";
	    DumpElem $value, $s;
	}
	print "$sp  empty hash\n" unless @sortKeys;
	print "$sp$more" if defined $more ;
    } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) { 
	$tArrayDepth = $#{$v} ; 
	undef $more ; 
	$tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1 
	  unless  $arrayDepth eq '' ; 
	$more = "....\n" if $tArrayDepth < $#{$v} ; 
	$shortmore = "";
	$shortmore = " ..." if $tArrayDepth < $#{$v} ;
	if ($compactDump && !grep(ref $_, @{$v})) {
	  if ($#$v >= 0) {
	    $short = $sp . "0..$#{$v}  " . 
	      join(" ", 
		   map {exists $v->[$_] ? stringify $v->[$_] : "empty"} ($[..$tArrayDepth)
		  ) . "$shortmore";
	  } else {
	    $short = $sp . "empty array";
	  }
	  (print "$short\n"), return if length $short <= $compactDump;
	}
	#if ($compactDump && $short = ShortArray($v)) {
	#  print "$short\n";
	#  return;
	#}
	for $num ($[ .. $tArrayDepth) {
	    return if $DB::signal;
	    print "$sp$num  ";
	    if (exists $v->[$num]) {
	        DumpElem $v->[$num], $s;
	    } else {
	    	print "empty slot\n";
	    }
	}
	print "$sp  empty array\n" unless @$v;
	print "$sp$more" if defined $more ;  
    } elsif (  UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) { 
	    print "$sp-> ";
	    DumpElem $$v, $s;
    } elsif ( UNIVERSAL::isa($v, 'CODE') ) { 
	    print "$sp-> ";
	    dumpsub (0, $v);
    } elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
      print "$sp-> ",&stringify($$v,1),"\n";
      if ($globPrint) {
	$s += 3;
	dumpglob($s, "{$$v}", $$v, 1);
      } elsif (defined ($fileno = fileno($v))) {
	print( (' ' x ($s+3)) .  "FileHandle({$$v}) => fileno($fileno)\n" );
      }
    } elsif (ref \$v eq 'GLOB') {
      if ($globPrint) {
	dumpglob($s, "{$v}", $v, 1) if $globPrint;
      } elsif (defined ($fileno = fileno(\$v))) {
	print( (' ' x $s) .  "FileHandle({$v}) => fileno($fileno)\n" );
      }
    }
}

sub matchvar {
  $_[0] eq $_[1] or 
    ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and 
      ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
}

sub compactDump {
  $compactDump = shift if @_;
  $compactDump = 6*80-1 if $compactDump and $compactDump < 2;
  $compactDump;
}

sub veryCompact {
  $veryCompact = shift if @_;
  compactDump(1) if !$compactDump and $veryCompact;
  $veryCompact;
}

sub unctrlSet {
  if (@_) {
    my $in = shift;
    if ($in eq 'unctrl' or $in eq 'quote') {
      $unctrl = $in;
    } else {
      print "Unknown value for `unctrl'.\n";
    }
  }
  $unctrl;
}

sub quote {
  if (@_ and $_[0] eq '"') {
    $tick = '"';
    $unctrl = 'quote';
  } elsif (@_ and $_[0] eq 'auto') {
    $tick = 'auto';
    $unctrl = 'quote';
  } elsif (@_) {		# Need to set
    $tick = "'";
    $unctrl = 'unctrl';
  }
  $tick;
}

sub dumpglob {
    return if $DB::signal;
    my ($off,$key, $val, $all) = @_;
    local(*entry) = $val;
    my $fileno;
    if (($key !~ /^_</ or $dumpDBFiles) and defined $entry) {
      print( (' ' x $off) . "\$", &unctrl($key), " = " );
      DumpElem $entry, 3+$off;
    }
    if (($key !~ /^_</ or $dumpDBFiles) and @entry) {
      print( (' ' x $off) . "\@$key = (\n" );
      unwrap(\@entry,3+$off) ;
      print( (' ' x $off) .  ")\n" );
    }
    if ($key ne "main::" && $key ne "DB::" && %entry
	&& ($dumpPackages or $key !~ /::$/)
	&& ($key !~ /^_</ or $dumpDBFiles)
	&& !($package eq "dumpvar" and $key eq "stab")) {
      print( (' ' x $off) . "\%$key = (\n" );
      unwrap(\%entry,3+$off) ;
      print( (' ' x $off) .  ")\n" );
    }
    if (defined ($fileno = fileno(*entry))) {
      print( (' ' x $off) .  "FileHandle($key) => fileno($fileno)\n" );
    }
    if ($all) {
      if (defined &entry) {
	dumpsub($off, $key);
      }
    }
}

sub CvGV_name_or_bust {
  my $in = shift;
  return if $skipCvGV;		# Backdoor to avoid problems if XS broken...
  $in = \&$in;			# Hard reference...
  eval {require Devel::Peek; 1} or return;
  my $gv = Devel::Peek::CvGV($in) or return;
  *$gv{PACKAGE} . '::' . *$gv{NAME};
}

sub dumpsub {
    my ($off,$sub) = @_;
    my $ini = $sub;
    my $s;
    $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
    my $subref = defined $1 ? \&$sub : \&$ini;
    my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})
      || (($s = CvGV_name_or_bust($subref)) && $DB::sub{$s})
      || ($subdump && ($s = findsubs("$subref")) && $DB::sub{$s});
    $place = '???' unless defined $place;
    $s = $sub unless defined $s;
    print( (' ' x $off) .  "&$s in $place\n" );
}

sub findsubs {
  return undef unless %DB::sub;
  my ($addr, $name, $loc);
  while (($name, $loc) = each %DB::sub) {
    $addr = \&$name;
    $subs{"$addr"} = $name;
  }
  $subdump = 0;
  $subs{ shift() };
}

sub main::dumpvar {
    my ($package,@vars) = @_;
    local(%address,$key,$val,$^W);
    $package .= "::" unless $package =~ /::$/;
    *stab = *{"main::"};
    while ($package =~ /(\w+?::)/g){
      *stab = $ {stab}{$1};
    }
    local $TotalStrings = 0;
    local $Strings = 0;
    local $CompleteTotal = 0;
    while (($key,$val) = each(%stab)) {
      return if $DB::signal;
      next if @vars && !grep( matchvar($key, $_), @vars );
      if ($usageOnly) {
	globUsage(\$val, $key)
	  if ($package ne 'dumpvar' or $key ne 'stab')
	     and ref(\$val) eq 'GLOB';
      } else {
	dumpglob(0,$key, $val);
      }
    }
    if ($usageOnly) {
      print "String space: $TotalStrings bytes in $Strings strings.\n";
      $CompleteTotal += $TotalStrings;
      print "Grand total = $CompleteTotal bytes (1 level deep) + overhead.\n";
    }
}

sub scalarUsage {
  my $size = length($_[0]);
  $TotalStrings += $size;
  $Strings++;
  $size;
}

sub arrayUsage {		# array ref, name
  my $size = 0;
  map {$size += scalarUsage($_)} @{$_[0]};
  my $len = @{$_[0]};
  print "\@$_[1] = $len item", ($len > 1 ? "s" : ""),
    " (data: $size bytes)\n"
      if defined $_[1];
  $CompleteTotal +=  $size;
  $size;
}

sub hashUsage {		# hash ref, name
  my @keys = keys %{$_[0]};
  my @values = values %{$_[0]};
  my $keys = arrayUsage \@keys;
  my $values = arrayUsage \@values;
  my $len = @keys;
  my $total = $keys + $values;
  print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
    " (keys: $keys; values: $values; total: $total bytes)\n"
      if defined $_[1];
  $total;
}

sub globUsage {			# glob ref, name
  local *name = *{$_[0]};
  $total = 0;
  $total += scalarUsage $name if defined $name;
  $total += arrayUsage \@name, $_[1] if @name;
  $total += hashUsage \%name, $_[1] if %name and $_[1] ne "main::" 
    and $_[1] ne "DB::";   #and !($package eq "dumpvar" and $key eq "stab"));
  $total;
}

sub packageUsage {
  my ($package,@vars) = @_;
  $package .= "::" unless $package =~ /::$/;
  local *stab = *{"main::"};
  while ($package =~ /(\w+?::)/g){
    *stab = $ {stab}{$1};
  }
  local $TotalStrings = 0;
  local $CompleteTotal = 0;
  my ($key,$val);
  while (($key,$val) = each(%stab)) {
    next if @vars && !grep($key eq $_,@vars);
    globUsage \$val, $key unless $package eq 'dumpvar' and $key eq 'stab';
  }
  print "String space: $TotalStrings.\n";
  $CompleteTotal += $TotalStrings;
  print "\nGrand total = $CompleteTotal bytes\n";
}

1;

package.U>:

This variable contains the name of the package being constructed,
with the first letter uppercased, F<i.e>. suitable for starting
sentences.

=item C<spitshell>

From F<spitshell.U>:

This variable contains the command necessary to spit out a runnable
shell on this system.  It is either cat o                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                
# Generated from DynaLoader.pm.PL

package DynaLoader;

#   And Gandalf said: 'Many folk like to know beforehand what is to
#   be set on the table; but those who have laboured to prepare the
#   feast like to keep their secret; for wonder makes the words of
#   praise louder.'

#   (Quote from Tolkien suggested by Anno Siegel.)
#
# See pod text at end of file for documentation.
# See also ext/DynaLoader/README in source tree for other information.
#
# Tim.Bunce@ig.co.uk, August 1994

use vars qw($VERSION *AUTOLOAD);

$VERSION = 1.04;	# avoid typo warning

require AutoLoader;
*AUTOLOAD = \&AutoLoader::AUTOLOAD;

use Config;

# The following require can't be removed during maintenance
# releases, sadly, because of the risk of buggy code that does 
# require Carp; Carp::croak "..."; without brackets dying 
# if Carp hasn't been loaded in earlier compile time. :-( 
# We'll let those bugs get found on the development track.
require Carp if $] < 5.00450; 

# enable debug/trace messages from DynaLoader perl code
$dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug;

#
# Flags to alter dl_load_file behaviour.  Assigned bits:
#   0x01  make symbols available for linking later dl_load_file's.
#         (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL))
#         (ignored under VMS; effect is built-in to image linking)
#
# This is called as a class method $module->dl_load_flags.  The
# definition here will be inherited and result on "default" loading
# behaviour unless a sub-class of DynaLoader defines its own version.
#

sub dl_load_flags { 0x00 }

# ($dl_dlext, $dlsrc)
#         = @Config::Config{'dlext', 'dlsrc'};
  ($dl_dlext, $dlsrc) = ('','dl_mac.xs')
;
# Some systems need special handling to expand file specifications
# (VMS support by Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>)
# See dl_expandspec() for more details. Should be harmless but
# inefficient to define on systems that don't need it.
$Is_VMS    = $^O eq 'VMS';
$do_expand = $Is_VMS;
$Is_MacOS  = $^O eq 'MacOS';

@dl_require_symbols = ();       # names of symbols we need
@dl_resolve_using   = ();       # names of files to link with
@dl_library_path    = ();       # path to look for files
@dl_librefs         = ();       # things we have loaded
@dl_modules         = ();       # Modules we have loaded

# This is a fix to support DLD's unfortunate desire to relink -lc
@dl_resolve_using = dl_findfile('-lc') if $dlsrc eq "dl_dld.xs";

# Initialise @dl_library_path with the 'standard' library path
# for this platform as determined by Configure.

push(@dl_library_path, split(' ', $Config::Config{libpth}));


my $ldlibpthname         = $Config::Config{ldlibpthname};
my $ldlibpthname_defined = defined $Config::Config{ldlibpthname};
my $pthsep               = $Config::Config{path_sep};

# Add to @dl_library_path any extra directories we can gather from environment
# during runtime.

if ($ldlibpthname_defined &&
    exists $ENV{$ldlibpthname}) {
    push(@dl_library_path, split(/$pthsep/, $ENV{$ldlibpthname}));
}

# E.g. HP-UX supports both its native SHLIB_PATH *and* LD_LIBRARY_PATH.

if ($ldlibpthname_defined &&
    $ldlibpthname ne 'LD_LIBRARY_PATH' &&
    exists $ENV{LD_LIBRARY_PATH}) {
    push(@dl_library_path, split(/$pthsep/, $ENV{LD_LIBRARY_PATH}));
}


# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here.
# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB
boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) &&
                                !defined(&dl_error);

if ($dl_debug) {
    print STDERR "DynaLoader.pm loaded (@INC, @dl_library_path)\n";
    print STDERR "DynaLoader not linked into this perl\n"
	    unless defined(&boot_DynaLoader);
}

1; # End of main code


sub croak   { require Carp; Carp::croak(@_)   }

sub bootstrap_inherit {
    my $module = $_[0];
    local *isa = *{"$module\::ISA"};
    local @isa = (@isa, 'DynaLoader');
    # Cannot goto due to delocalization.  Will report errors on a wrong line?
    bootstrap(@_);
}

# The bootstrap function cannot be autoloaded (without complications)
# so we define it here:

sub bootstrap {
    # use local vars to enable $module.bs script to edit values
    local(@args) = @_;
    local($module) = $args[0];
    local(@dirs, $file);

    unless ($module) {
	require Carp;
	Carp::confess("Usage: DynaLoader::bootstrap(module)");
    }

    # A common error on platforms which don't support dynamic loading.
    # Since it's fatal and potentially confusing we give a detailed message.
    croak("Can't load module $module, dynamic loading not available in this perl.\n".
	"  (You may need to build a new perl executable which either supports\n".
	"  dynamic loading or has the $module module statically linked into it.)\n")
	unless defined(&dl_load_file);

    my @modparts = split(/::/,$module);
    my $modfname = $modparts[-1];

    # Some systems have restrictions on files names for DLL's etc.
    # mod2fname returns appropriate file base name (typically truncated)
    # It may also edit @modparts if required.
    $modfname = &mod2fname(\@modparts) if defined &mod2fname;

    my $modpname = join(($Is_MacOS ? ':' : '/'),@modparts);

    print STDERR "DynaLoader::bootstrap for $module ",
		($Is_MacOS
		       ? "(:auto:$modpname:$modfname.$dl_dlext)\n" :
		       "(auto/$modpname/$modfname.$dl_dlext)\n")
	if $dl_debug;

    foreach (@INC) {
	chop($_ = VMS::Filespec::unixpath($_)) if $Is_VMS;
	my $dir;
	if ($Is_MacOS) {
	    my $path = $_;
	    $path .= ":"  unless /:$/;
	    $dir = "${path}auto:$modpname";
	} else {
	    $dir = "$_/auto/$modpname";
	}
	next unless -d $dir; # skip over uninteresting directories

	# check for common cases to avoid autoload of dl_findfile
	my $try = $Is_MacOS ? "$dir:$modfname.$dl_dlext" : "$dir/$modfname.$dl_dlext";
	last if $file = ($do_expand) ? dl_expandspec($try) : (-f $try && $try);

	# no luck here, save dir for possible later dl_findfile search
	push @dirs, $dir;
    }
    # last resort, let dl_findfile have a go in all known locations
    $file = dl_findfile(map("-L$_",@dirs,@INC), $modfname) unless $file;

    croak("Can't locate loadable object for module $module in \@INC (\@INC contains: @INC)")
	unless $file;	# wording similar to error from 'require'

    $file = uc($file) if $Is_VMS && $Config::Config{d_vms_case_sensitive_symbols};
    my $bootname = "boot_$module";
    $bootname =~ s/\W/_/g;
    @dl_require_symbols = ($bootname);

    # Execute optional '.bootstrap' perl script for this module.
    # The .bs file can be used to configure @dl_resolve_using etc to
    # match the needs of the individual module on this architecture.
    my $bs = $file;
    $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library
    if (-s $bs) { # only read file if it's not empty
        print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug;
        eval { do $bs; };
        warn "$bs: $@\n" if $@;
    }

    # Many dynamic extension loading problems will appear to come from
    # this section of code: XYZ failed at line 123 of DynaLoader.pm.
    # Often these errors are actually occurring in the initialisation
    # C code of the extension XS file. Perl reports the error as being
    # in this perl code simply because this was the last perl code
    # it executed.

    my $libref = dl_load_file($file, $module->dl_load_flags) or
	croak("Can't load '$file' for module $module: ".dl_error());

    push(@dl_librefs,$libref);  # record loaded object

    my @unresolved = dl_undef_symbols();
    if (@unresolved) {
	require Carp;
	Carp::carp("Undefined symbols present after loading $file: @unresolved\n");
    }

    my $boot_symbol_ref = dl_find_symbol($libref, $bootname) or
         croak("Can't find '$bootname' symbol in $file\n");

    my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file);

    push(@dl_modules, $module); # record loaded module

    # See comment block above
    &$xs(@args);
}


#sub _check_file {   # private utility to handle dl_expandspec vs -f tests
#    my($file) = @_;
#    return $file if (!$do_expand && -f $file); # the common case
#    return $file if ( $do_expand && ($file=dl_expandspec($file)));
#    return undef;
#}


# Let autosplit and the autoloader deal with these functions:
__END__


sub dl_findfile {
    # Read ext/DynaLoader/DynaLoader.doc for detailed information.
    # This function does not automatically consider the architecture
    # or the perl library auto directories.
    my (@args) = @_;
    my (@dirs,  $dir);   # which directories to search
    my (@found);         # full paths to real files we have found
    my $dl_ext= ''; # $Config::Config{'dlext'} suffix for perl extensions
    my $dl_so = 'so'; # $Config::Config{'so'} suffix for shared libraries

    print STDERR "dl_findfile(@args)\n" if $dl_debug;

    # accumulate directories but process files as they appear
    arg: foreach(@args) {
        #  Special fast case: full filepath requires no search
        if ($Is_VMS && m%[:>/\]]% && -f $_) {
	    push(@found,dl_expandspec(VMS::Filespec::vmsify($_)));
	    last arg unless wantarray;
	    next;
        }
	elsif ($Is_MacOS) {
	    if (m/:/ && -f $_) {
	    	push(@found,$_);
	    	last arg unless wantarray;
	    }
	}
        elsif (m:/: && -f $_ && !$do_expand) {
	    push(@found,$_);
	    last arg unless wantarray;
	    next;
	}

        # Deal with directories first:
        #  Using a -L prefix is the preferred option (faster and more robust)
        if (m:^-L:) { s/^-L//; push(@dirs, $_); next; }

	if ($Is_MacOS) {
            #  Otherwise we try to try to spot directories by a heuristic
            #  (this is a more complicated issue than it first appears)
	    if (m/:/ && -d $_) {   push(@dirs, $_); next; }
            #  Only files should get this far...
            my(@names, $name);    # what filenames to look for
	    s/^-l//;
	    push(@names, $_);
            foreach $dir (@dirs, @dl_library_path) {
            	next unless -d $dir;
		$dir =~ s/^([^:]+)$/:$1/;
		$dir =~ s/:$//;
            	foreach $name (@names) {
	    	    my($file) = "$dir:$name";
                    print STDERR " checking in $dir for $name\n" if $dl_debug;
		    if (-f $file) {
                    	push(@found, $file);
                    	next arg; # no need to look any further
                    }
                }
	    }
	    next;
	}
	
        #  Otherwise we try to try to spot directories by a heuristic
        #  (this is a more complicated issue than it first appears)
        if (m:/: && -d $_) {   push(@dirs, $_); next; }

        # VMS: we may be using native VMS directory syntax instead of
        # Unix emulation, so check this as well
        if ($Is_VMS && /[:>\]]/ && -d $_) {   push(@dirs, $_); next; }

        #  Only files should get this far...
        my(@names, $name);    # what filenames to look for
        if (m:-l: ) {          # convert -lname to appropriate library name
            s/-l//;
            push(@names,"lib$_.$dl_so");
            push(@names,"lib$_.a");
        } else {                # Umm, a bare name. Try various alternatives:
            # these should be ordered with the most likely first
            push(@names,"$_.$dl_ext")    unless m/\.$dl_ext$/o;
            push(@names,"$_.$dl_so")     unless m/\.$dl_so$/o;
            push(@names,"lib$_.$dl_so")  unless m:/:;
            push(@names,"$_.a")          if !m/\.a$/ and $dlsrc eq "dl_dld.xs";
            push(@names, $_);
        }
        foreach $dir (@dirs, @dl_library_path) {
            next unless -d $dir;
            chop($dir = VMS::Filespec::unixpath($dir)) if $Is_VMS;
            foreach $name (@names) {
		my($file) = "$dir/$name";
                print STDERR " checking in $dir for $name\n" if $dl_debug;
		$file = ($do_expand) ? dl_expandspec($file) : (-f $file && $file);
		#$file = _check_file($file);
		if ($file) {
                    push(@found, $file);
                    next arg; # no need to look any further
                }
            }
        }
    }
    if ($dl_debug) {
        foreach(@dirs) {
            print STDERR " dl_findfile ignored non-existent directory: $_\n" unless -d $_;
        }
        print STDERR "dl_findfile found: @found\n";
    }
    return $found[0] unless wantarray;
    @found;
}


sub dl_expandspec {
    my($spec) = @_;
    # Optional function invoked if DynaLoader.pm sets $do_expand.
    # Most systems do not require or use this function.
    # Some systems may implement it in the dl_*.xs file in which case
    # this autoload version will not be called but is harmless.

    # This function is designed to deal with systems which treat some
    # 'filenames' in a special way. For example VMS 'Logical Names'
    # (something like unix environment variables - but different).
    # This function should recognise such names and expand them into
    # full file paths.
    # Must return undef if $spec is invalid or file does not exist.

    my $file = $spec; # default output to input

    if ($Is_VMS) { # dl_expandspec should be defined in dl_vms.xs
	require Carp;
	Carp::croak("dl_expandspec: should be defined in XS file!\n");
    } else {
	return undef unless -f $file;
    }
    print STDERR "dl_expandspec($spec) => $file\n" if $dl_debug;
    $file;
}

sub dl_find_symbol_anywhere
{
    my $sym = shift;
    my $libref;
    foreach $libref (@dl_librefs) {
	my $symref = dl_find_symbol($libref,$sym);
	return $symref if $symref;
    }
    return undef;
}

=head1 NAME

DynaLoader - Dynamically load C libraries into Perl code

dl_error(), dl_findfile(), dl_expandspec(), dl_load_file(), dl_unload_file(), dl_find_symbol(), dl_find_symbol_anywhere(), dl_undef_symbols(), dl_install_xsub(), dl_load_flags(), bootstrap() - routines used by DynaLoader modules

=head1 SYNOPSIS

    package YourPackage;
    require DynaLoader;
    @ISA = qw(... DynaLoader ...);
    bootstrap YourPackage;

    # optional method for 'global' loading
    sub dl_load_flags { 0x01 }     


=head1 DESCRIPTION

This document defines a standard generic interface to the dynamic
linking mechanisms available on many platforms.  Its primary purpose is
to implement automatic dynamic loading of Perl modules.

This document serves as both a specification for anyone wishing to
implement the DynaLoader for a new platform and as a guide for
anyone wishing to use the DynaLoader directly in an application.

The DynaLoader is designed to be a very simple high-level
interface that is sufficiently general to cover the requirements
of SunOS, HP-UX, NeXT, Linux, VMS and other platforms.

It is also hoped that the interface will cover the needs of OS/2, NT
etc and also allow pseudo-dynamic linking (using C<ld -A> at runtime).

It must be stressed that the DynaLoader, by itself, is practically
useless for accessing non-Perl libraries because it provides almost no
Perl-to-C 'glue'.  There is, for example, no mechanism for calling a C
library function or supplying arguments.  A C::DynaLib module
is available from CPAN sites which performs that function for some
common system types.

DynaLoader Interface Summary

  @dl_library_path
  @dl_resolve_using
  @dl_require_symbols
  $dl_debug
  @dl_librefs
  @dl_modules
                                                  Implemented in:
  bootstrap($modulename)                               Perl
  @filepaths = dl_findfile(@names)                     Perl
  $flags = $modulename->dl_load_flags                  Perl
  $symref  = dl_find_symbol_anywhere($symbol)          Perl

  $libref  = dl_load_file($filename, $flags)           C
  $status  = dl_unload_file($libref)                   C
  $symref  = dl_find_symbol($libref, $symbol)          C
  @symbols = dl_undef_symbols()                        C
  dl_install_xsub($name, $symref [, $filename])        C
  $message = dl_error                                  C

=over 4

=item @dl_library_path

The standard/default list of directories in which dl_findfile() will
search for libraries etc.  Directories are searched in order:
$dl_library_path[0], [1], ... etc

@dl_library_path is initialised to hold the list of 'normal' directories
(F</usr/lib>, etc) determined by B<Configure> (C<$Config{'libpth'}>).  This should
ensure portability across a wide range of platforms.

@dl_library_path should also be initialised with any other directories
that can be determined from the environment at runtime (such as
LD_LIBRARY_PATH for SunOS).

After initialisation @dl_library_path can be manipulated by an
application using push and unshift before calling dl_findfile().
Unshift can be used to add directories to the front of the search order
either to save search time or to override libraries with the same name
in the 'normal' directories.

The load function that dl_load_file() calls may require an absolute
pathname.  The dl_findfile() function and @dl_library_path can be
used to search for and return the absolute pathname for the
library/object that you wish to load.

=item @dl_resolve_using

A list of additional libraries or other shared objects which can be
used to resolve any undefined symbols that might be generated by a
later call to load_file().

This is only required on some platforms which do not handle dependent
libraries automatically.  For example the Socket Perl extension
library (F<auto/Socket/Socket.so>) contains references to many socket
functions which need to be resolved when it's loaded.  Most platforms
will automatically know where to find the 'dependent' library (e.g.,
F</usr/lib/libsocket.so>).  A few platforms need to be told the
location of the dependent library explicitly.  Use @dl_resolve_using
for this.

Example usage:

    @dl_resolve_using = dl_findfile('-lsocket');

=item @dl_require_symbols

A list of one or more symbol names that are in the library/object file
to be dynamically loaded.  This is only required on some platforms.

=item @dl_librefs

An array of the handles returned by successful calls to dl_load_file(),
made by bootstrap, in the order in which they were loaded.
Can be used with dl_find_symbol() to look for a symbol in any of
the loaded files.

=item @dl_modules

An array of module (package) names that have been bootstrap'ed.

=item dl_error()

Syntax:

    $message = dl_error();

Error message text from the last failed DynaLoader function.  Note
that, similar to errno in unix, a successful function call does not
reset this message.

Implementations should detect the error as soon as it occurs in any of
the other functions and save the corresponding message for later
retrieval.  This will avoid problems on some platforms (such as SunOS)
where the error message is very temporary (e.g., dlerror()).

=item $dl_debug

Internal debugging messages are enabled when $dl_debug is set true.
Currently setting $dl_debug only affects the Perl side of the
DynaLoader.  These messages should help an application developer to
resolve any DynaLoader usage problems.

$dl_debug is set to C<$ENV{'PERL_DL_DEBUG'}> if defined.

For the DynaLoader developer/porter there is a similar debugging
variable added to the C code (see dlutils.c) and enabled if Perl was
built with the B<-DDEBUGGING> flag.  This can also be set via the
PERL_DL_DEBUG environment variable.  Set to 1 for minimal information or
higher for more.

=item dl_findfile()

Syntax:

    @filepaths = dl_findfile(@names)

Determine the full paths (including file suffix) of one or more
loadable files given their generic names and optionally one or more
directories.  Searches directories in @dl_library_path by default and
returns an empty list if no files were found.

Names can be specified in a variety of platform independent forms.  Any
names in the form B<-lname> are converted into F<libname.*>, where F<.*> is
an appropriate suffix for the platform.

If a name does not already have a suitable prefix and/or suffix then
the corresponding file will be searched for by trying combinations of
prefix and suffix appropriate to the platform: "$name.o", "lib$name.*"
and "$name".

If any directories are included in @names they are searched before
@dl_library_path.  Directories may be specified as B<-Ldir>.  Any other
names are treated as filenames to be searched for.

Using arguments of the form C<-Ldir> and C<-lname> is recommended.

Example: 

    @dl_resolve_using = dl_findfile(qw(-L/usr/5lib -lposix));


=item dl_expandspec()

Syntax:

    $filepath = dl_expandspec($spec)

Some unusual systems, such as VMS, require special filename handling in
order to deal with symbolic names for files (i.e., VMS's Logical Names).

To support these systems a dl_expandspec() function can be implemented
either in the F<dl_*.xs> file or code can be added to the autoloadable
dl_expandspec() function in F<DynaLoader.pm>.  See F<DynaLoader.pm> for
more information.

=item dl_load_file()

Syntax:

    $libref = dl_load_file($filename, $flags)

Dynamically load $filename, which must be the path to a shared object
or library.  An opaque 'library reference' is returned as a handle for
the loaded object.  Returns undef on error.

The $flags argument to alters dl_load_file behaviour.  
Assigned bits:

 0x01  make symbols available for linking later dl_load_file's.
       (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL))
       (ignored under VMS; this is a normal part of image linking)

(On systems that provide a handle for the loaded object such as SunOS
and HPUX, $libref will be that handle.  On other systems $libref will
typically be $filename or a pointer to a buffer containing $filename.
The application should not examine or alter $libref in any way.)

This is the function that does the real work.  It should use the
current values of @dl_require_symbols and @dl_resolve_using if required.

    SunOS: dlopen($filename)
    HP-UX: shl_load($filename)
    Linux: dld_create_reference(@dl_require_symbols); dld_link($filename)
    NeXT:  rld_load($filename, @dl_resolve_using)
    VMS:   lib$find_image_symbol($filename,$dl_require_symbols[0])

(The dlopen() function is also used by Solaris and some versions of
Linux, and is a common choice when providing a "wrapper" on other
mechanisms as is done in the OS/2 port.)

=item dl_unload_file()

Syntax:

    $status = dl_unload_file($libref)

Dynamically unload $libref, which must be an opaque 'library reference' as
returned from dl_load_file.  Returns one on success and zero on failure.

This function is optional and may not necessarily be provided on all platforms.
If it is defined, it is called automatically when the interpreter exits for
every shared object or library loaded by DynaLoader::bootstrap.  All such
library references are stored in @dl_librefs by DynaLoader::Bootstrap as it
loads the libraries.  The files are unloaded in last-in, first-out order.

This unloading is usually necessary when embedding a shared-object perl (e.g.
one configured with -Duseshrplib) within a larger application, and the perl
interpreter is created and destroyed several times within the lifetime of the
application.  In this case it is possible that the system dynamic linker will
unload and then subsequently reload the shared libperl without relocating any
references to it from any files DynaLoaded by the previous incarnation of the
interpreter.  As a result, any shared objects opened by DynaLoader may point to
a now invalid 'ghost' of the libperl shared object, causing apparently random
memory corruption and crashes.  This behaviour is most commonly seen when using
Apache and mod_perl built with the APXS mechanism.

    SunOS: dlclose($libref)
    HP-UX: ???
    Linux: ???
    NeXT:  ???
    VMS:   ???

(The dlclose() function is also used by Solaris and some versions of
Linux, and is a common choice when providing a "wrapper" on other
mechanisms as is done in the OS/2 port.)

=item dl_loadflags()

Syntax:

    $flags = dl_loadflags $modulename;

Designed to be a method call, and to be overridden by a derived class
(i.e. a class which has DynaLoader in its @ISA).  The definition in
DynaLoader itself returns 0, which produces standard behavior from
dl_load_file().

=item dl_find_symbol()

Syntax:

    $symref = dl_find_symbol($libref, $symbol)

Return the address of the symbol $symbol or C<undef> if not found.  If the
target system has separate functions to search for symbols of different
types then dl_find_symbol() should search for function symbols first and
then other types.

The exact manner in which the address is returned in $symref is not
currently defined.  The only initial requirement is that $symref can
be passed to, and understood by, dl_install_xsub().

    SunOS: dlsym($libref, $symbol)
    HP-UX: shl_findsym($libref, $symbol)
    Linux: dld_get_func($symbol) and/or dld_get_symbol($symbol)
    NeXT:  rld_lookup("_$symbol")
    VMS:   lib$find_image_symbol($libref,$symbol)


=item dl_find_symbol_anywhere()

Syntax:

    $symref = dl_find_symbol_anywhere($symbol)

Applies dl_find_symbol() to the members of @dl_librefs and returns
the first match found.

=item dl_undef_symbols()

Example

    @symbols = dl_undef_symbols()

Return a list of symbol names which remain undefined after load_file().
Returns C<()> if not known.  Don't worry if your platform does not provide
a mechanism for this.  Most do not need it and hence do not provide it,
they just return an empty list.


=item dl_install_xsub()

Syntax:

    dl_install_xsub($perl_name, $symref [, $filename])

Create a new Perl external subroutine named $perl_name using $symref as
a pointer to the function which implements the routine.  This is simply
a direct call to newXSUB().  Returns a reference to the installed
function.

The $filename parameter is used by Perl to identify the source file for
the function if required by die(), caller() or the debugger.  If
$filename is not defined then "DynaLoader" will be used.


=item bootstrap()

Syntax:

bootstrap($module)

This is the normal entry point for automatic dynamic loading in Perl.

It performs the following actions:

=over 8

=item *

locates an auto/$module directory by searching @INC

=item *

uses dl_findfile() to determine the filename to load

=item *

sets @dl_require_symbols to C<("boot_$module")>

=item *

executes an F<auto/$module/$module.bs> file if it exists
(typically used to add to @dl_resolve_using any files which
are required to load the module on the current platform)

=item *

calls dl_load_flags() to determine how to load the file.

=item *

calls dl_load_file() to load the file

=item *

calls dl_undef_symbols() and warns if any symbols are undefined

=item *

calls dl_find_symbol() for "boot_$module"

=item *

calls dl_install_xsub() to install it as "${module}::bootstrap"

=item *

calls &{"${module}::bootstrap"} to bootstrap the module (actually
it uses the function reference returned by dl_install_xsub for speed)

=back

=back


=head1 AUTHOR

Tim Bunce, 11 August 1994.

This interface is based on the work and comments of (in no particular
order): Larry Wall, Robert Sanders, Dean Roehrich, Jeff Okamoto, Anno
Siegel, Thomas Neumann, Paul Marquess, Charles Bailey, myself and others.

Larry Wall designed the elegant inherited bootstrap mechanism and
implemented the first Perl 5 dynamic loader using it.

Solaris global loading added by Nick Ing-Simmons with design/coding
assistance from Tim Bunce, January 1996.

=cut
 use constant E2BIG => ($! = 7);
    print   E2BIG, "\n";	# something like "Arg list too long"
    print 0+E2BIG, "\n";	# "7"

Dereferencing constant references incorrectly (such as using an array
subscript on a constant hash reference, or vice versa) will be trapped at
compile time.

In the rare case in                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                package English;

require Exporter;
@ISA = (Exporter);

=head1 NAME

English - use nice English (or awk) names for ugly punctuation variables

=head1 SYNOPSIS

    use English;
    ...
    if ($ERRNO =~ /denied/) { ... }

=head1 DESCRIPTION

This module provides aliases for the built-in variables whose
names no one seems to like to read.  Variables with side-effects
which get triggered just by accessing them (like $0) will still 
be affected.

For those variables that have an B<awk> version, both long
and short English alternatives are provided.  For example, 
the C<$/> variable can be referred to either $RS or 
$INPUT_RECORD_SEPARATOR if you are using the English module.

See L<perlvar> for a complete list of these.

=head1 BUGS

This module provokes sizeable inefficiencies for regular expressions,
due to unfortunate implementation details.  If performance matters,
consider avoiding English.

=cut

no warnings;

# Grandfather $NAME import
sub import {
    my $this = shift;
    my @list = @_;
    local $Exporter::ExportLevel = 1;
    Exporter::import($this,grep {s/^\$/*/} @list);
}

@EXPORT = qw(
	*ARG
	*MATCH
	*PREMATCH
	*POSTMATCH
	*LAST_PAREN_MATCH
	*INPUT_LINE_NUMBER
	*NR
	*INPUT_RECORD_SEPARATOR
	*RS
	*OUTPUT_AUTOFLUSH
	*OUTPUT_FIELD_SEPARATOR
	*OFS
	*OUTPUT_RECORD_SEPARATOR
	*ORS
	*LIST_SEPARATOR
	*SUBSCRIPT_SEPARATOR
	*SUBSEP
	*FORMAT_PAGE_NUMBER
	*FORMAT_LINES_PER_PAGE
	*FORMAT_LINES_LEFT
	*FORMAT_NAME
	*FORMAT_TOP_NAME
	*FORMAT_LINE_BREAK_CHARACTERS
	*FORMAT_FORMFEED
	*CHILD_ERROR
	*OS_ERROR
	*ERRNO
	*EXTENDED_OS_ERROR
	*EVAL_ERROR
	*PROCESS_ID
	*PID
	*REAL_USER_ID
	*UID
	*EFFECTIVE_USER_ID
	*EUID
	*REAL_GROUP_ID
	*GID
	*EFFECTIVE_GROUP_ID
	*EGID
	*PROGRAM_NAME
	*PERL_VERSION
	*ACCUMULATOR
	*DEBUGGING
	*SYSTEM_FD_MAX
	*INPLACE_EDIT
	*PERLDB
	*BASETIME
	*WARNING
	*EXECUTABLE_NAME
	*OSNAME
	*LAST_REGEXP_CODE_RESULT
	*EXCEPTIONS_BEING_CAUGHT
	@LAST_MATCH_START
	@LAST_MATCH_END
);

# The ground of all being. @ARG is deprecated (5.005 makes @_ lexical)

	*ARG					= *_	;

# Matching.

	*MATCH					= *&	;
	*PREMATCH				= *`	;
	*POSTMATCH				= *'	;
	*LAST_PAREN_MATCH			= *+	;
	*LAST_MATCH_START			= *-{ARRAY} ;
	*LAST_MATCH_END				= *+{ARRAY} ;

# Input.

	*INPUT_LINE_NUMBER			= *.	;
	    *NR					= *.	;
	*INPUT_RECORD_SEPARATOR			= */	;
	    *RS					= */	;

# Output.

	*OUTPUT_AUTOFLUSH			= *|	;
	*OUTPUT_FIELD_SEPARATOR			= *,	;
	    *OFS				= *,	;
	*OUTPUT_RECORD_SEPARATOR		= *\	;
	    *ORS				= *\	;

# Interpolation "constants".

	*LIST_SEPARATOR				= *"	;
	*SUBSCRIPT_SEPARATOR			= *;	;
	    *SUBSEP				= *;	;

# Formats

	*FORMAT_PAGE_NUMBER			= *%	;
	*FORMAT_LINES_PER_PAGE			= *=	;
	*FORMAT_LINES_LEFT			= *-	;
	*FORMAT_NAME				= *~	;
	*FORMAT_TOP_NAME			= *^	;
	*FORMAT_LINE_BREAK_CHARACTERS		= *:	;
	*FORMAT_FORMFEED			= *^L	;

# Error status.

	*CHILD_ERROR				= *?	;
	*OS_ERROR				= *!	;
	    *ERRNO				= *!	;
	*EXTENDED_OS_ERROR			= *^E	;
	*EVAL_ERROR				= *@	;

# Process info.

	*PROCESS_ID				= *$	;
	    *PID				= *$	;
	*REAL_USER_ID				= *<	;
	    *UID				= *<	;
	*EFFECTIVE_USER_ID			= *>	;
	    *EUID				= *>	;
	*REAL_GROUP_ID				= *(	;
	    *GID				= *(	;
	*EFFECTIVE_GROUP_ID			= *)	;
	    *EGID				= *)	;
	*PROGRAM_NAME				= *0	;

# Internals.

	*PERL_VERSION				= *^V	;
	*ACCUMULATOR				= *^A	;
	*COMPILING				= *^C	;
	*DEBUGGING				= *^D	;
	*SYSTEM_FD_MAX				= *^F	;
	*INPLACE_EDIT				= *^I	;
	*PERLDB					= *^P	;
	*LAST_REGEXP_CODE_RESULT		= *^R	;
	*EXCEPTIONS_BEING_CAUGHT		= *^S	;
	*BASETIME				= *^T	;
	*WARNING				= *^W	;
	*EXECUTABLE_NAME			= *^X	;
	*OSNAME					= *^O	;

# Deprecated.

#	*ARRAY_BASE				= *[	;
#	*OFMT					= *#	;
#	*MULTILINE_MATCHING			= **	;
#	*OLD_PERL_VERSION			= *]	;

1;
n piecemeal:
    $HQX = Convert::BinHex->open(FH=>\*STDIN) || die "open: $!";
    $HQX->read_header;                  # read header info
    @data = $HQX->read_data;            # read in all the data
    @rsrc = $HQX->read_resource;        # read in all the resource

B<Bin to hex, low-level interface.>
Conversion is actually done via an object (L<"Convert::BinHex::Bin2Hex">)
which keeps internal conversion state:

    # Create                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                 package Env;

=head1 NAME

Env - perl module that imports environment variables as scalars or arrays

=head1 SYNOPSIS

    use Env;
    use Env qw(PATH HOME TERM);
    use Env qw($SHELL @LD_LIBRARY_PATH);

=head1 DESCRIPTION

Perl maintains environment variables in a special hash named C<%ENV>.  For
when this access method is inconvenient, the Perl module C<Env> allows
environment variables to be treated as scalar or array variables.

The C<Env::import()> function ties environment variables with suitable
names to global Perl variables with the same names.  By default it
ties all existing environment variables (C<keys %ENV>) to scalars.  If
the C<import> function receives arguments, it takes them to be a list of
variables to tie; it's okay if they don't yet exist. The scalar type
prefix '$' is inferred for any element of this list not prefixed by '$'
or '@'. Arrays are implemented in terms of C<split> and C<join>, using
C<$Config::Config{path_sep}> as the delimiter.

After an environment variable is tied, merely use it like a normal variable.
You may access its value 

    @path = split(/:/, $PATH);
    print join("\n", @LD_LIBRARY_PATH), "\n";

or modify it

    $PATH .= ":.";
    push @LD_LIBRARY_PATH, $dir;

however you'd like. Bear in mind, however, that each access to a tied array
variable requires splitting the environment variable's string anew.

The code:

    use Env qw(@PATH);
    push @PATH, '.';

is equivalent to:

    use Env qw(PATH);
    $PATH .= ":.";

except that if C<$ENV{PATH}> started out empty, the second approach leaves
it with the (odd) value "C<:.>", but the first approach leaves it with "C<.>".

To remove a tied environment variable from
the environment, assign it the undefined value

    undef $PATH;
    undef @LD_LIBRARY_PATH;

=head1 LIMITATIONS

On VMS systems, arrays tied to environment variables are read-only. Attempting
to change anything will cause a warning.

=head1 AUTHOR

Chip Salzenberg E<lt>F<chip@fin.uucp>E<gt>
and
Gregor N. Purdy E<lt>F<gregor@focusresearch.com>E<gt>

=cut

sub import {
    my ($callpack) = caller(0);
    my $pack = shift;
    my @vars = grep /^[\$\@]?[A-Za-z_]\w*$/, (@_ ? @_ : keys(%ENV));
    return unless @vars;

    @vars = map { m/^[\$\@]/ ? $_ : '$'.$_ } @vars;

    eval "package $callpack; use vars qw(" . join(' ', @vars) . ")";
    die $@ if $@;
    foreach (@vars) {
	my ($type, $name) = m/^([\$\@])(.*)$/;
	if ($type eq '$') {
	    tie ${"${callpack}::$name"}, Env, $name;
	} else {
	    if ($^O eq 'VMS') {
		tie @{"${callpack}::$name"}, Env::Array::VMS, $name;
	    } else {
		tie @{"${callpack}::$name"}, Env::Array, $name;
	    }
	}
    }
}

sub TIESCALAR {
    bless \($_[1]);
}

sub FETCH {
    my ($self) = @_;
    $ENV{$$self};
}

sub STORE {
    my ($self, $value) = @_;
    if (defined($value)) {
	$ENV{$$self} = $value;
    } else {
	delete $ENV{$$self};
    }
}

######################################################################

package Env::Array;
 
use Config;
use Tie::Array;

@ISA = qw(Tie::Array);

my $sep = $Config::Config{path_sep};

sub TIEARRAY {
    bless \($_[1]);
}

sub FETCHSIZE {
    my ($self) = @_;
    my @temp = split($sep, $ENV{$$self});
    return scalar(@temp);
}

sub STORESIZE {
    my ($self, $size) = @_;
    my @temp = split($sep, $ENV{$$self});
    $#temp = $size - 1;
    $ENV{$$self} = join($sep, @temp);
}

sub CLEAR {
    my ($self) = @_;
    $ENV{$$self} = '';
}

sub FETCH {
    my ($self, $index) = @_;
    return (split($sep, $ENV{$$self}))[$index];
}

sub STORE {
    my ($self, $index, $value) = @_;
    my @temp = split($sep, $ENV{$$self});
    $temp[$index] = $value;
    $ENV{$$self} = join($sep, @temp);
    return $value;
}

sub PUSH {
    my $self = shift;
    my @temp = split($sep, $ENV{$$self});
    push @temp, @_;
    $ENV{$$self} = join($sep, @temp);
    return scalar(@temp);
}

sub POP {
    my ($self) = @_;
    my @temp = split($sep, $ENV{$$self});
    my $result = pop @temp;
    $ENV{$$self} = join($sep, @temp);
    return $result;
}

sub UNSHIFT {
    my $self = shift;
    my @temp = split($sep, $ENV{$$self});
    my $result = unshift @temp, @_;
    $ENV{$$self} = join($sep, @temp);
    return $result;
}

sub SHIFT {
    my ($self) = @_;
    my @temp = split($sep, $ENV{$$self});
    my $result = shift @temp;
    $ENV{$$self} = join($sep, @temp);
    return $result;
}

sub SPLICE {
    my $self = shift;
    my $offset = shift;
    my $length = shift;
    my @temp = split($sep, $ENV{$$self});
    if (wantarray) {
	my @result = splice @temp, $self, $offset, $length, @_;
	$ENV{$$self} = join($sep, @temp);
	return @result;
    } else {
	my $result = scalar splice @temp, $offset, $length, @_;
	$ENV{$$self} = join($sep, @temp);
	return $result;
    }
}

######################################################################

package Env::Array::VMS;
use Tie::Array;

@ISA = qw(Tie::Array);
 
sub TIEARRAY {
    bless \($_[1]);
}

sub FETCHSIZE {
    my ($self) = @_;
    my $i = 0;
    while ($i < 127 and defined $ENV{$$self . ';' . $i}) { $i++; };
    return $i;
}

sub FETCH {
    my ($self, $index) = @_;
    return $ENV{$$self . ';' . $index};
}

1;
0x0691, 0x16b0, 0x6657, 0x7676, 0x4615, 0x5634,
    0xd94c, 0xc96d, 0xf90e, 0xe92f, 0x99c8, 0x89e9, 0xb98a, 0xa9ab,
    0x5844, 0x4865, 0x7806, 0x6827, 0x18c0, 0x08e1, 0x3882, 0x28a3,
    0xcb7d, 0xdb5c, 0xeb3f, 0xfb1e, 0x8bf9, 0x9bd8, 0xabbb, 0xbb9a,
    0x4a75, 0x5a54, 0x6a37, 0x7a16, 0x0af1, 0x1ad0, 0x2ab3, 0x3a92,
    0xfd2e, 0xed0f, 0xdd6c, 0xcd4d, 0xbdaa, 0xad8b, 0x9de8, 0x8dc9,
    0x7c26, 0x6c07, 0x5c64, 0x4c45, 0x3ca2, 0x2c83, 0x1ce0, 0x0cc1,
    0xef1f, 0xff3e, 0xcf5d, 0x                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                #
# This file is auto-generated. ***ANY*** changes here will be lost
#

package Errno;
use vars qw(@EXPORT_OK %EXPORT_TAGS @ISA $VERSION %errno $AUTOLOAD);
use Exporter ();
use Config;
use strict;

#"$Config{'archname'}-$Config{'osvers'}" eq
#"-" or
#	die "Errno architecture (-) does not match executable architecture ($Config{'archname'}-$Config{'osvers'})";

$VERSION = "1.111";
@ISA = qw(Exporter);

@EXPORT_OK = qw(EPIPE ENOTSOCK ENOSPC EISCONN EOPNOTSUPP ENOTTY
	ESHUTDOWN EAFNOSUPPORT ENETUNREACH EADDRNOTAVAIL EAGAIN
	ESOCKTNOSUPPORT ENOTDIR EINPROGRESS ESRCH EISDIR EROFS EEXIST EBADF
	ENOPROTOOPT EINVAL ENOLCK ELOOK ENAMETOOLONG EMSGSIZE EDESTADDRREQ
	EINTR EPROTONOSUPPORT ELOOP ECONNREFUSED EPROTOTYPE EDEADLK EIO
	ECONNRESET ENETDOWN EFBIG ENOEXEC ENOTCONN ENFILE EACCES ETIMEDOUT
	EPERM ERANGE ECANCELED ESPIPE ENOMEM ENOSYS EXDEV ELAST ECHILD
	EPFNOSUPPORT ENODEV EALREADY EMLINK ENXIO ETOOMANYREFS EADDRINUSE
	E2BIG EBUSY ECONNABORTED ENOENT ENETRESET ENOTEMPTY EDOM EHOSTUNREACH
	ENOBUFS EFAULT EHOSTDOWN EMFILE);

%EXPORT_TAGS = (
    POSIX => [qw(
	E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT EAGAIN EALREADY
	EBADF EBUSY ECHILD ECONNABORTED ECONNREFUSED ECONNRESET EDEADLK
	EDESTADDRREQ EDOM EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH
	EINPROGRESS EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK
	EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH ENFILE ENOBUFS
	ENODEV ENOENT ENOEXEC ENOLCK ENOMEM ENOPROTOOPT ENOSPC ENOSYS ENOTCONN
	ENOTDIR ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM EPFNOSUPPORT
	EPIPE EPROTONOSUPPORT EPROTOTYPE ERANGE EROFS ESHUTDOWN
	ESOCKTNOSUPPORT ESPIPE ESRCH ETIMEDOUT ETOOMANYREFS
	EXDEV
    )]
);

sub EPERM () { 1 }
sub ENOENT () { 2 }
sub ESRCH () { 3 }
sub EINTR () { 4 }
sub EIO () { 5 }
sub ENXIO () { 6 }
sub E2BIG () { 7 }
sub ENOEXEC () { 8 }
sub EBADF () { 9 }
sub ECHILD () { 10 }
sub EDEADLK () { 11 }
sub ENOMEM () { 12 }
sub EACCES () { 13 }
sub EFAULT () { 14 }
sub ECANCELED () { 15 }
sub EBUSY () { 16 }
sub EEXIST () { 17 }
sub EXDEV () { 18 }
sub ENODEV () { 19 }
sub ENOTDIR () { 20 }
sub EISDIR () { 21 }
sub EINVAL () { 22 }
sub ENFILE () { 23 }
sub EMFILE () { 24 }
sub ENOTTY () { 25 }
sub EFBIG () { 27 }
sub ENOSPC () { 28 }
sub ESPIPE () { 29 }
sub EROFS () { 30 }
sub EMLINK () { 31 }
sub EPIPE () { 32 }
sub EDOM () { 33 }
sub ERANGE () { 34 }
sub EAGAIN () { 35 }
sub EINPROGRESS () { 36 }
sub EALREADY () { 37 }
sub ENOTSOCK () { 38 }
sub EDESTADDRREQ () { 39 }
sub EMSGSIZE () { 40 }
sub EPROTOTYPE () { 41 }
sub ENOPROTOOPT () { 42 }
sub EPROTONOSUPPORT () { 43 }
sub ESOCKTNOSUPPORT () { 44 }
sub EOPNOTSUPP () { 45 }
sub EPFNOSUPPORT () { 46 }
sub EAFNOSUPPORT () { 47 }
sub EADDRINUSE () { 48 }
sub EADDRNOTAVAIL () { 49 }
sub ENETDOWN () { 50 }
sub ENETUNREACH () { 51 }
sub ENETRESET () { 52 }
sub ECONNABORTED () { 53 }
sub ECONNRESET () { 54 }
sub ENOBUFS () { 55 }
sub EISCONN () { 56 }
sub ENOTCONN () { 57 }
sub ESHUTDOWN () { 58 }
sub ETOOMANYREFS () { 59 }
sub ETIMEDOUT () { 60 }
sub ECONNREFUSED () { 61 }
sub ELOOP () { 62 }
sub ENAMETOOLONG () { 63 }
sub EHOSTDOWN () { 64 }
sub EHOSTUNREACH () { 65 }
sub ENOTEMPTY () { 66 }
sub ELOOK () { 67 }
sub ENOLCK () { 77 }
sub ENOSYS () { 78 }
sub ELAST () { 78 }

sub TIEHASH { bless [] }

sub FETCH {
    my ($self, $errname) = @_;
    my $proto = prototype("Errno::$errname");
    my $errno = "";
    if (defined($proto) && $proto eq "") {
	no strict 'refs';
	$errno = &$errname;
        $errno = 0 unless $! == $errno;
    }
    return $errno;
}

sub STORE {
    require Carp;
    Carp::confess("ERRNO hash is read only!");
}

*CLEAR = \&STORE;
*DELETE = \&STORE;

sub NEXTKEY {
    my($k,$v);
    while(($k,$v) = each %Errno::) {
	my $proto = prototype("Errno::$k");
	last if (defined($proto) && $proto eq "");
    }
    $k
}

sub FIRSTKEY {
    my $s = scalar keys %Errno::;	# initialize iterator
    goto &NEXTKEY;
}

sub EXISTS {
    my ($self, $errname) = @_;
    my $proto = prototype($errname);
    defined($proto) && $proto eq "";
}

tie %!, __PACKAGE__;

1;
__END__

=head1 NAME

Errno - System errno constants

=head1 SYNOPSIS

    use Errno qw(EINTR EIO :POSIX);

=head1 DESCRIPTION

C<Errno> defines and conditionally exports all the error constants
defined in your system C<errno.h> include file. It has a single export
tag, C<:POSIX>, which will export all POSIX defined error numbers.

C<Errno> also makes C<%!> magic such that each element of C<%!> has a
non-zero value only if C<$!> is set to that value. For example:

    use Errno;

    unless (open(FH, "/fangorn/spouse")) {
        if ($!{ENOENT}) {
            warn "Get a wife!\n";
        } else {
            warn "This path is barred: $!";
        } 
    } 

If a specified constant C<EFOO> does not exist on the system, C<$!{EFOO}>
returns C<"">.  You may use C<exists $!{EFOO}> to check whether the
constant is available on the system.

=head1 CAVEATS

Importing a particular constant may not be very portable, because the
import will fail on platforms that do not have that constant.  A more
portable way to set C<$!> to a valid value is to use:

    if (exists &Errno::EFOO) {
        $! = &Errno::EFOO;
    }

=head1 AUTHOR

Graham Barr <gbarr@pobox.com>

=head1 COPYRIGHT

Copyright (c) 1997-8 Graham Barr. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

2Bin->new;
    $self;
}


=back

=cut




#==============================

=head2 Get/set header information

=over 4

=cut

#------------------------------

=item creator [VALUE]

I<Instance method.>
Get/set the creator of the file.  This                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                 # exceptions.pl
# tchrist@convex.com
#
# This library is no longer being maintained, and is included for backward
# compatibility with Perl 4 programs which may require it.
#
# In particular, this should not be used as an example of modern Perl
# programming techniques.
#
# 
# Here's a little code I use for exception handling.  It's really just
# glorfied eval/die.  The way to use use it is when you might otherwise
# exit, use &throw to raise an exception.  The first enclosing &catch
# handler looks at the exception and decides whether it can catch this kind
# (catch takes a list of regexps to catch), and if so, it returns the one it
# caught.  If it *can't* catch it, then it will reraise the exception
# for someone else to possibly see, or to die otherwise.
# 
# I use oddly named variables in order to make darn sure I don't conflict 
# with my caller.  I also hide in my own package, and eval the code in his.
# 
# The EXCEPTION: prefix is so you can tell whether it's a user-raised
# exception or a perl-raised one (eval error).
# 
# --tom
#
# examples:
#	if (&catch('/$user_input/', 'regexp', 'syntax error') {
#		warn "oops try again";
#		redo;
#	}
#
#	if ($error = &catch('&subroutine()')) { # catches anything
#
#	&throw('bad input') if /^$/;

sub catch {
    package exception;
    local($__code__, @__exceptions__) = @_;
    local($__package__) = caller;
    local($__exception__);

    eval "package $__package__; $__code__";
    if ($__exception__ = &'thrown) {
	for (@__exceptions__) {
	    return $__exception__ if /$__exception__/;
	} 
	&'throw($__exception__);
    } 
} 

sub throw {
    local($exception) = @_;
    die "EXCEPTION: $exception\n";
} 

sub thrown {
    $@ =~ /^(EXCEPTION: )+(.+)/ && $2;
} 

1;
nvert::BinHex $VERSION)";
    push @h, "X-HQX-Filename: " . $self->filename;
    push @h, "X-HQX-Version: "  . $self->version;
    push @h, "X-HQX-Type: "     . $self->type;
    push @h, "X-HQX-Creator: "  . $self->creator;
    push @h, "X-HQX-Flags: "    . sprintf("%x", $self->flags);
    push @h, "X-HQX-Data-                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                package Exporter;

=head1 NAME

Exporter::Heavy - Exporter guts

=head1 SYNOPIS

(internal use only)

=head1 DESCRIPTION

No user-serviceable parts inside.

=cut
#
# We go to a lot of trouble not to 'require Carp' at file scope,
#  because Carp requires Exporter, and something has to give.
#

sub heavy_export {

    # First make import warnings look like they're coming from the "use".
    local $SIG{__WARN__} = sub {
	my $text = shift;
	if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//) {
	    require Carp;
	    local $Carp::CarpLevel = 1;	# ignore package calling us too.
	    Carp::carp($text);
	}
	else {
	    warn $text;
	}
    };
    local $SIG{__DIE__} = sub {
	require Carp;
	local $Carp::CarpLevel = 1;	# ignore package calling us too.
	Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")
	    if $_[0] =~ /^Unable to create sub named "(.*?)::"/;
    };

    my($pkg, $callpkg, @imports) = @_;
    my($type, $sym, $oops);
    *exports = *{"${pkg}::EXPORT"};

    if (@imports) {
	if (!%exports) {
	    grep(s/^&//, @exports);
	    @exports{@exports} = (1) x @exports;
	    my $ok = \@{"${pkg}::EXPORT_OK"};
	    if (@$ok) {
		grep(s/^&//, @$ok);
		@exports{@$ok} = (1) x @$ok;
	    }
	}

	if ($imports[0] =~ m#^[/!:]#){
	    my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
	    my $tagdata;
	    my %imports;
	    my($remove, $spec, @names, @allexports);
	    # negated first item implies starting with default set:
	    unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/;
	    foreach $spec (@imports){
		$remove = $spec =~ s/^!//;

		if ($spec =~ s/^://){
		    if ($spec eq 'DEFAULT'){
			@names = @exports;
		    }
		    elsif ($tagdata = $tagsref->{$spec}) {
			@names = @$tagdata;
		    }
		    else {
			warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS];
			++$oops;
			next;
		    }
		}
		elsif ($spec =~ m:^/(.*)/$:){
		    my $patn = $1;
		    @allexports = keys %exports unless @allexports; # only do keys once
		    @names = grep(/$patn/, @allexports); # not anchored by default
		}
		else {
		    @names = ($spec); # is a normal symbol name
		}

		warn "Import ".($remove ? "del":"add").": @names "
		    if $Verbose;

		if ($remove) {
		   foreach $sym (@names) { delete $imports{$sym} } 
		}
		else {
		    @imports{@names} = (1) x @names;
		}
	    }
	    @imports = keys %imports;
	}

	foreach $sym (@imports) {
	    if (!$exports{$sym}) {
		if ($sym =~ m/^\d/) {
		    $pkg->require_version($sym);
		    # If the version number was the only thing specified
		    # then we should act as if nothing was specified:
		    if (@imports == 1) {
			@imports = @exports;
			last;
		    }
		    # We need a way to emulate 'use Foo ()' but still
		    # allow an easy version check: "use Foo 1.23, ''";
		    if (@imports == 2 and !$imports[1]) {
			@imports = ();
			last;
		    }
		} elsif ($sym !~ s/^&// || !$exports{$sym}) {
                    require Carp;
		    Carp::carp(qq["$sym" is not exported by the $pkg module]);
		    $oops++;
		}
	    }
	}
	if ($oops) {
	    require Carp;
	    Carp::croak("Can't continue after import errors");
	}
    }
    else {
	@imports = @exports;
    }

    *fail = *{"${pkg}::EXPORT_FAIL"};
    if (@fail) {
	if (!%fail) {
	    # Build cache of symbols. Optimise the lookup by adding
	    # barewords twice... both with and without a leading &.
	    # (Technique could be applied to %exports cache at cost of memory)
	    my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @fail;
	    warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Verbose;
	    @fail{@expanded} = (1) x @expanded;
	}
	my @failed;
	foreach $sym (@imports) { push(@failed, $sym) if $fail{$sym} }
	if (@failed) {
	    @failed = $pkg->export_fail(@failed);
	    foreach $sym (@failed) {
                require Carp;
		Carp::carp(qq["$sym" is not implemented by the $pkg module ],
			"on this architecture");
	    }
	    if (@failed) {
		require Carp;
		Carp::croak("Can't continue after import errors");
	    }
	}
    }

    warn "Importing into $callpkg from $pkg: ",
		join(", ",sort @imports) if $Verbose;

    foreach $sym (@imports) {
	# shortcut for the common case of no type character
	(*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, next)
	    unless $sym =~ s/^(\W)//;
	$type = $1;
	*{"${callpkg}::$sym"} =
	    $type eq '&' ? \&{"${pkg}::$sym"} :
	    $type eq '$' ? \${"${pkg}::$sym"} :
	    $type eq '@' ? \@{"${pkg}::$sym"} :
	    $type eq '%' ? \%{"${pkg}::$sym"} :
	    $type eq '*' ?  *{"${pkg}::$sym"} :
	    do { require Carp; Carp::croak("Can't export symbol: $type$sym") };
    }
}

sub heavy_export_to_level
{
      my $pkg = shift;
      my $level = shift;
      (undef) = shift;			# XXX redundant arg
      my $callpkg = caller($level);
      $pkg->export($callpkg, @_);
}

# Utility functions

sub _push_tags {
    my($pkg, $var, $syms) = @_;
    my $nontag;
    *export_tags = \%{"${pkg}::EXPORT_TAGS"};
    push(@{"${pkg}::$var"},
	map { $export_tags{$_} ? @{$export_tags{$_}} : scalar(++$nontag,$_) }
		(@$syms) ? @$syms : keys %export_tags);
    if ($nontag and $^W) {
	# This may change to a die one day
	require Carp;
	Carp::carp("Some names are not tags");
    }
}

# Default methods

sub export_fail {
    my $self = shift;
    @_;
}

sub require_version {
    my($self, $wanted) = @_;
    my $pkg = ref $self || $self;
    my $version = ${"${pkg}::VERSION"};
    if (!$version or $version < $wanted) {
	$version ||= "(undef)";
	    # %INC contains slashes, but $pkg contains double-colons.
	my $file = (map {s,::,/,g; $INC{$_}} "$pkg.pm")[0];
	$file &&= " ($file)";
	require Carp;
	Carp::croak("$pkg $wanted required--this is only version $version$file")
    }
    $version;
}

1;

}

#------------------------------------------------------------

=item read_resource [NBYTES]

I<Instance method.>
Read in all/some of the resource fork.
See C<read_data()> for usage.

=cut

sub read_resource {
    shift->_read_fork('Rsrc',@_);
}

=back

=cut



#------------------------------------------------------------
#
# read BUFFER, NBYTES
#
# Read the next NBYTES (decompressed) bytes from the input stream
# into BUFFER.  Returns the number of bytes actually read, and
# undef on                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                 package Exporter;

require 5.001;

$ExportLevel = 0;
$Verbose ||= 0;
$VERSION = '5.562';

sub export_to_level {
  require Exporter::Heavy;
  goto &heavy_export_to_level;
}

sub export {
  require Exporter::Heavy;
  goto &heavy_export;
}

sub export_tags {
  require Exporter::Heavy;
  _push_tags((caller)[0], "EXPORT",    \@_);
}

sub export_ok_tags {
  require Exporter::Heavy;
  _push_tags((caller)[0], "EXPORT_OK", \@_);
}

sub import {
  my $pkg = shift;
  my $callpkg = caller($ExportLevel);
  *exports = *{"$pkg\::EXPORT"};
  # We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-(
  *fail = *{"$pkg\::EXPORT_FAIL"};
  return export $pkg, $callpkg, @_
    if $Verbose or $Debug or @fail > 1;
  my $args = @_ or @_ = @exports;
  
  if ($args and not %exports) {
    foreach my $sym (@exports, @{"$pkg\::EXPORT_OK"}) {
      $sym =~ s/^&//;
      $exports{$sym} = 1;
    }
  }
  if ($Verbose or $Debug 
      or grep {/\W/ or $args and not exists $exports{$_}
	       or @fail and $_ eq $fail[0]
	       or (@{"$pkg\::EXPORT_OK"} 
		   and $_ eq ${"$pkg\::EXPORT_OK"}[0])} @_) {
    return export $pkg, $callpkg, ($args ? @_ : ());
  }
  #local $SIG{__WARN__} = sub {require Carp; goto &Carp::carp};
  local $SIG{__WARN__} = 
	sub {require Carp; local $Carp::CarpLevel = 1; &Carp::carp};
  foreach $sym (@_) {
    # shortcut for the common case of no type character
    *{"$callpkg\::$sym"} = \&{"$pkg\::$sym"};
  }
}

1;

# A simple self test harness. Change 'require Carp' to 'use Carp ()' for testing.
# package main; eval(join('',<DATA>)) or die $@ unless caller;
__END__
package Test;
$INC{'Exporter.pm'} = 1;
@ISA = qw(Exporter);
@EXPORT      = qw(A1 A2 A3 A4 A5);
@EXPORT_OK   = qw(B1 B2 B3 B4 B5);
%EXPORT_TAGS = (T1=>[qw(A1 A2 B1 B2)], T2=>[qw(A1 A2 B3 B4)], T3=>[qw(X3)]);
@EXPORT_FAIL = qw(B4);
Exporter::export_ok_tags('T3', 'unknown_tag');
sub export_fail {
    map { "Test::$_" } @_	# edit symbols just as an example
}

package main;
$Exporter::Verbose = 1;
#import Test;
#import Test qw(X3);		# export ok via export_ok_tags()
#import Test qw(:T1 !A2 /5/ !/3/ B5);
import Test qw(:T2 !B4);
import Test qw(:T2);		# should fail
1;

=head1 NAME

Exporter - Implements default import method for modules

=head1 SYNOPSIS

In module ModuleName.pm:

  package ModuleName;
  require Exporter;
  @ISA = qw(Exporter);

  @EXPORT = qw(...);            # symbols to export by default
  @EXPORT_OK = qw(...);         # symbols to export on request
  %EXPORT_TAGS = tag => [...];  # define names for sets of symbols

In other files which wish to use ModuleName:

  use ModuleName;               # import default symbols into my package

  use ModuleName qw(...);       # import listed symbols into my package

  use ModuleName ();            # do not import any symbols

=head1 DESCRIPTION

The Exporter module implements a default C<import> method which
many modules choose to inherit rather than implement their own.

Perl automatically calls the C<import> method when processing a
C<use> statement for a module. Modules and C<use> are documented
in L<perlfunc> and L<perlmod>. Understanding the concept of
modules and how the C<use> statement operates is important to
understanding the Exporter.

=head2 How to Export

The arrays C<@EXPORT> and C<@EXPORT_OK> in a module hold lists of
symbols that are going to be exported into the users name space by
default, or which they can request to be exported, respectively.  The
symbols can represent functions, scalars, arrays, hashes, or typeglobs.
The symbols must be given by full name with the exception that the
ampersand in front of a function is optional, e.g.

    @EXPORT    = qw(afunc $scalar @array);   # afunc is a function
    @EXPORT_OK = qw(&bfunc %hash *typeglob); # explicit prefix on &bfunc

=head2 Selecting What To Export

Do B<not> export method names!

Do B<not> export anything else by default without a good reason!

Exports pollute the namespace of the module user.  If you must export
try to use @EXPORT_OK in preference to @EXPORT and avoid short or
common symbol names to reduce the risk of name clashes.

Generally anything not exported is still accessible from outside the
module using the ModuleName::item_name (or $blessed_ref-E<gt>method)
syntax.  By convention you can use a leading underscore on names to
informally indicate that they are 'internal' and not for public use.

(It is actually possible to get private functions by saying:

  my $subref = sub { ... };
  &$subref;

But there's no way to call that directly as a method, since a method
must have a name in the symbol table.)

As a general rule, if the module is trying to be object oriented
then export nothing. If it's just a collection of functions then
@EXPORT_OK anything but use @EXPORT with caution.

Other module design guidelines can be found in L<perlmod>.

=head2 Specialised Import Lists

If the first entry in an import list begins with !, : or / then the
list is treated as a series of specifications which either add to or
delete from the list of names to import. They are processed left to
right. Specifications are in the form:

    [!]name         This name only
    [!]:DEFAULT     All names in @EXPORT
    [!]:tag         All names in $EXPORT_TAGS{tag} anonymous list
    [!]/pattern/    All names in @EXPORT and @EXPORT_OK which match

A leading ! indicates that matching names should be deleted from the
list of names to import.  If the first specification is a deletion it
is treated as though preceded by :DEFAULT. If you just want to import
extra names in addition to the default set you will still need to
include :DEFAULT explicitly.

e.g., Module.pm defines:

    @EXPORT      = qw(A1 A2 A3 A4 A5);
    @EXPORT_OK   = qw(B1 B2 B3 B4 B5);
    %EXPORT_TAGS = (T1 => [qw(A1 A2 B1 B2)], T2 => [qw(A1 A2 B3 B4)]);

    Note that you cannot use tags in @EXPORT or @EXPORT_OK.
    Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK.

An application using Module can say something like:

    use Module qw(:DEFAULT :T2 !B3 A3);

Other examples include:

    use Socket qw(!/^[AP]F_/ !SOMAXCONN !SOL_SOCKET);
    use POSIX  qw(:errno_h :termios_h !TCSADRAIN !/^EXIT/);

Remember that most patterns (using //) will need to be anchored
with a leading ^, e.g., C</^EXIT/> rather than C</EXIT/>.

You can say C<BEGIN { $Exporter::Verbose=1 }> to see how the
specifications are being processed and what is actually being imported
into modules.

=head2 Exporting without using Export's import method

Exporter has a special method, 'export_to_level' which is used in situations
where you can't directly call Export's import method. The export_to_level
method looks like:

MyPackage->export_to_level($where_to_export, $package, @what_to_export);

where $where_to_export is an integer telling how far up the calling stack
to export your symbols, and @what_to_export is an array telling what
symbols *to* export (usually this is @_).  The $package argument is
currently unused.

For example, suppose that you have a module, A, which already has an
import function:

package A;

@ISA = qw(Exporter);
@EXPORT_OK = qw ($b);

sub import
{
    $A::b = 1;     # not a very useful import method
}

and you want to Export symbol $A::b back to the module that called 
package A. Since Exporter relies on the import method to work, via 
inheritance, as it stands Exporter::import() will never get called. 
Instead, say the following:

package A;
@ISA = qw(Exporter);
@EXPORT_OK = qw ($b);

sub import
{
    $A::b = 1;
    A->export_to_level(1, @_);
}

This will export the symbols one level 'above' the current package - ie: to 
the program or module that used package A. 

Note: Be careful not to modify '@_' at all before you call export_to_level
- or people using your package will get very unexplained results!


=head2 Module Version Checking

The Exporter module will convert an attempt to import a number from a
module into a call to $module_name-E<gt>require_version($value). This can
be used to validate that the version of the module being used is
greater than or equal to the required version.

The Exporter module supplies a default require_version method which
checks the value of $VERSION in the exporting module.

Since the default require_version method treats the $VERSION number as
a simple numeric value it will regard version 1.10 as lower than
1.9. For this reason it is strongly recommended that you use numbers
with at least two decimal places, e.g., 1.09.

=head2 Managing Unknown Symbols

In some situations you may want to prevent certain symbols from being
exported. Typically this applies to extensions which have functions
or constants that may not exist on some systems.

The names of any symbols that cannot be exported should be listed
in the C<@EXPORT_FAIL> array.

If a module attempts to import any of these symbols the Exporter
will give the module an opportunity to handle the situation before
generating an error. The Exporter will call an export_fail method
with a list of the failed symbols:

  @failed_symbols = $module_name->export_fail(@failed_symbols);

If the export_fail method returns an empty list then no error is
recorded and all the requested symbols are exported. If the returned
list is not empty then an error is generated for each symbol and the
export fails. The Exporter provides a default export_fail method which
simply returns the list unchanged.

Uses for the export_fail method include giving better error messages
for some symbols and performing lazy architectural checks (put more
symbols into @EXPORT_FAIL by default and then take them out if someone
actually tries to use them and an expensive check shows that they are
usable on that platform).

=head2 Tag Handling Utility Functions

Since the symbols listed within %EXPORT_TAGS must also appear in either
@EXPORT or @EXPORT_OK, two utility functions are provided which allow
you to easily add tagged sets of symbols to @EXPORT or @EXPORT_OK:

  %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]);

  Exporter::export_tags('foo');     # add aa, bb and cc to @EXPORT
  Exporter::export_ok_tags('bar');  # add aa, cc and dd to @EXPORT_OK

Any names which are not tags are added to @EXPORT or @EXPORT_OK
unchanged but will trigger a warning (with C<-w>) to avoid misspelt tags
names being silently added to @EXPORT or @EXPORT_OK. Future versions
may make this a fatal error.

=cut
x, -$rem) : '');
    for (; $rem; --$rem) { chop $hex };
    return undef if ($hex eq '');            # nothing to do!

    # Convert to uuencoded format:
    $hex =~ tr
        {!"#$%&'()*+,\x2D012345689@ABCDEFGHIJKLMNPQRSTUVXYZ[`abcdefhijklmpqr}
        { -_};

    # Now, uudecode:
    my $comp = '';
    my $len;
    my $up;
    local($^W) = 0;       ### KLUDGE
    while                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                package ExtUtils::Command;

use 5.005_64;
use strict;
# use AutoLoader;
use Carp;
use File::Copy;
use File::Compare;
use File::Basename;
use File::Path qw(rmtree);
require Exporter;
our(@ISA, @EXPORT, $VERSION);
@ISA     = qw(Exporter);
@EXPORT  = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f);
$VERSION = '1.01';

=head1 NAME

ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc.

=head1 SYNOPSIS

  perl -MExtUtils::Command -e cat files... > destination
  perl -MExtUtils::Command -e mv source... destination
  perl -MExtUtils::Command -e cp source... destination
  perl -MExtUtils::Command -e touch files...
  perl -MExtUtils::Command -e rm_f file...
  perl -MExtUtils::Command -e rm_rf directories...
  perl -MExtUtils::Command -e mkpath directories...
  perl -MExtUtils::Command -e eqtime source destination
  perl -MExtUtils::Command -e chmod mode files...
  perl -MExtUtils::Command -e test_f file

=head1 DESCRIPTION

The module is used in the Win32 port to replace common UNIX commands.
Most commands are wrappers on generic modules File::Path and File::Basename.

=over 4

=cut

sub expand_wildcards
{
 @ARGV = map(/[\*\?]/ ? glob($_) : $_,@ARGV);
}

=item cat 

Concatenates all files mentioned on command line to STDOUT.

=cut 

sub cat ()
{
 expand_wildcards();
 print while (<>);
}

=item eqtime src dst

Sets modified time of dst to that of src

=cut 

sub eqtime
{
 my ($src,$dst) = @ARGV;
 open(F,">$dst");
 close(F);
 utime((stat($src))[8,9],$dst);
}

=item rm_f files....

Removes directories - recursively (even if readonly)

=cut 

sub rm_rf
{
 rmtree([grep -e $_,expand_wildcards()],0,0);
}

=item rm_f files....

Removes files (even if readonly)

=cut 

sub rm_f
{
 foreach (expand_wildcards())
  {
   next unless -f $_;        
   next if unlink($_);
   chmod(0777,$_);           
   next if unlink($_);
   carp "Cannot delete $_:$!";
  }
}

=item touch files ...

Makes files exist, with current timestamp 

=cut 

sub touch
{
 expand_wildcards();
 my $t    = time;
 while (@ARGV)
  {
   my $file = shift(@ARGV);               
   open(FILE,">>$file") || die "Cannot write $file:$!";
   close(FILE);
   utime($t,$t,$file);
  }
}

=item mv source... destination

Moves source to destination.
Multiple sources are allowed if destination is an existing directory.

=cut 

sub mv
{
 my $dst = pop(@ARGV);
 expand_wildcards();
 croak("Too many arguments") if (@ARGV > 1 && ! -d $dst);
 while (@ARGV)
  {
   my $src = shift(@ARGV);               
   move($src,$dst);
  }
}

=item cp source... destination

Copies source to destination.
Multiple sources are allowed if destination is an existing directory.

=cut 

sub cp
{
 my $dst = pop(@ARGV);
 expand_wildcards();
 croak("Too many arguments") if (@ARGV > 1 && ! -d $dst);
 while (@ARGV)
  {
   my $src = shift(@ARGV);               
   copy($src,$dst);
  }
}

=item chmod mode files...

Sets UNIX like permissions 'mode' on all the files.

=cut 

sub chmod
{
 my $mode = shift(@ARGV);
 chmod($mode,expand_wildcards()) || die "Cannot chmod ".join(' ',$mode,@ARGV).":$!";
}

=item mkpath directory...

Creates directory, including any parent directories.

=cut 

sub mkpath
{
 File::Path::mkpath([expand_wildcards()],0,0777);
}

=item test_f file

Tests if a file exists

=cut 

sub test_f
{
 exit !-f shift(@ARGV);
}


1;
__END__ 

=back

=head1 BUGS

Should probably be Auto/Self loaded.

=head1 SEE ALSO 

ExtUtils::MakeMaker, ExtUtils::MM_Unix, ExtUtils::MM_Win32

=head1 AUTHOR

Nick Ing-Simmons <F<nick@ni-s.u-net.com>>.

=cut

def;          # unknown!
}

#------------------                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                # $Id: Embed.pm,v 1.2501 $
require 5.002;

package ExtUtils::Embed;
require Exporter;
require FileHandle;
use Config;
use Getopt::Std;
use File::Spec;

#Only when we need them
#require ExtUtils::MakeMaker;
#require ExtUtils::Liblist;

use vars qw(@ISA @EXPORT $VERSION
	    @Extensions $Verbose $lib_ext
	    $opt_o $opt_s 
	    );
use strict;

$VERSION = sprintf("%d.%02d", q$Revision: 1.2505 $ =~ /(\d+)\.(\d+)/);

@ISA = qw(Exporter);
@EXPORT = qw(&xsinit &ldopts 
	     &ccopts &ccflags &ccdlflags &perl_inc
	     &xsi_header &xsi_protos &xsi_body);

#let's have Miniperl borrow from us instead
#require ExtUtils::Miniperl;
#*canon = \&ExtUtils::Miniperl::canon;

$Verbose = 0;
$lib_ext = $Config{lib_ext} || '.a';

sub is_cmd { $0 eq '-e' }

sub my_return {
    my $val = shift;
    if(is_cmd) {
	print $val;
    }
    else {
	return $val;
    }
}

sub is_perl_object {
    $Config{ccflags} =~ /-DPERL_OBJECT/;  
}

sub xsinit { 
    my($file, $std, $mods) = @_;
    my($fh,@mods,%seen);
    $file ||= "perlxsi.c";
    my $xsinit_proto = "pTHXo";

    if (@_) {
       @mods = @$mods if $mods;
    }
    else {
       getopts('o:s:');
       $file = $opt_o if defined $opt_o;
       $std  = $opt_s  if defined $opt_s;
       @mods = @ARGV;
    }
    $std = 1 unless scalar @mods;

    if ($file eq "STDOUT") {
	$fh = \*STDOUT;
    }
    else {
	$fh = new FileHandle "> $file";
    }

    push(@mods, static_ext()) if defined $std;
    @mods = grep(!$seen{$_}++, @mods);

    print $fh &xsi_header();
    print $fh "EXTERN_C void xs_init ($xsinit_proto);\n\n";     
    print $fh &xsi_protos(@mods);

    print $fh "\nEXTERN_C void\nxs_init($xsinit_proto)\n{\n";
    print $fh &xsi_body(@mods);
    print $fh "}\n";

}

sub xsi_header {
    return <<EOF;
#include <EXTERN.h>
#include <perl.h>

EOF
}    

sub xsi_protos {
    my(@exts) = @_;
    my(@retval,%seen);
    my $boot_proto = "pTHXo_ CV* cv";
    foreach $_ (@exts){
        my($pname) = canon('/', $_);
        my($mname, $cname);
        ($mname = $pname) =~ s!/!::!g;
        ($cname = $pname) =~ s!/!__!g;
	my($ccode) = "EXTERN_C void boot_${cname} ($boot_proto);\n";
	next if $seen{$ccode}++;
        push(@retval, $ccode);
    }
    return join '', @retval;
}

sub xsi_body {
    my(@exts) = @_;
    my($pname,@retval,%seen);
    my($dl) = canon('/','DynaLoader');
    push(@retval, "\tchar *file = __FILE__;\n");
    push(@retval, "\tdXSUB_SYS;\n") if $] > 5.002;
    push(@retval, "\n");

    foreach $_ (@exts){
        my($pname) = canon('/', $_);
        my($mname, $cname, $ccode);
        ($mname = $pname) =~ s!/!::!g;
        ($cname = $pname) =~ s!/!__!g;
        if ($pname eq $dl){
            # Must NOT install 'DynaLoader::boot_DynaLoader' as 'bootstrap'!
            # boot_DynaLoader is called directly in DynaLoader.pm
            $ccode = "\t/* DynaLoader is a special case */\n\tnewXS(\"${mname}::boot_${cname}\", boot_${cname}, file);\n";
            push(@retval, $ccode) unless $seen{$ccode}++;
        } else {
            $ccode = "\tnewXS(\"${mname}::bootstrap\", boot_${cname}, file);\n";
            push(@retval, $ccode) unless $seen{$ccode}++;
        }
    }
    return join '', @retval;
}

sub static_ext {
    unless (scalar @Extensions) {
	@Extensions = sort split /\s+/, $Config{static_ext};
	unshift @Extensions, qw(DynaLoader);
    }
    @Extensions;
}

sub ldopts {
    require ExtUtils::MakeMaker;
    require ExtUtils::Liblist;
    my($std,$mods,$link_args,$path) = @_;
    my(@mods,@link_args,@argv);
    my($dllib,$config_libs,@potential_libs,@path);
    local($") = ' ' unless $" eq ' ';
    my $MM = bless {} => 'MY';
    if (scalar @_) {
       @link_args = @$link_args if $link_args;
       @mods = @$mods if $mods;
    }
    else {
       @argv = @ARGV;
       #hmm
       while($_ = shift @argv) {
	   /^-std$/  && do { $std = 1; next; };
	   /^--$/    && do { @link_args = @argv; last; };
	   /^-I(.*)/ && do { $path = $1 || shift @argv; next; };
	   push(@mods, $_); 
       }
    }
    $std = 1 unless scalar @link_args;
    my $sep = $Config{path_sep} || ':';
    @path = $path ? split(/\Q$sep/, $path) : @INC;

    push(@potential_libs, @link_args)    if scalar @link_args;
    # makemaker includes std libs on windows by default
    if ($^O ne 'MSWin32' and defined($std)) {
	push(@potential_libs, $Config{perllibs});
    }

    push(@mods, static_ext()) if $std;

    my($mod,@ns,$root,$sub,$extra,$archive,@archives);
    print STDERR "Searching (@path) for archives\n" if $Verbose;
    foreach $mod (@mods) {
	@ns = split(/::|\/|\\/, $mod);
	$sub = $ns[-1];
	$root = $MM->catdir(@ns);
	
	print STDERR "searching for '$sub${lib_ext}'\n" if $Verbose;
	foreach (@path) {
	    next unless -e ($archive = $MM->catdir($_,"auto",$root,"$sub$lib_ext"));
	    push @archives, $archive;
	    if(-e ($extra = $MM->catdir($_,"auto",$root,"extralibs.ld"))) {
		local(*FH); 
		if(open(FH, $extra)) {
		    my($libs) = <FH>; chomp $libs;
		    push @potential_libs, split /\s+/, $libs;
		}
		else {  
		    warn "Couldn't open '$extra'"; 
		}
	    }
	    last;
	}
    }
    #print STDERR "\@potential_libs = @potential_libs\n";

    my $libperl;
    if ($^O eq 'MSWin32') {
	$libperl = $Config{libperl};
    }
    else {
	$libperl = (grep(/^-l\w*perl\w*$/, @link_args))[0] || "-lperl";
    }

    my $lpath = File::Spec->catdir($Config{archlibexp}, 'CORE');
    $lpath = qq["$lpath"] if $^O eq 'MSWin32';
    my($extralibs, $bsloadlibs, $ldloadlibs, $ld_run_path) =
	$MM->ext(join ' ', "-L$lpath", $libperl, @potential_libs);

    my $ld_or_bs = $bsloadlibs || $ldloadlibs;
    print STDERR "bs: $bsloadlibs ** ld: $ldloadlibs" if $Verbose;
    my $linkage = "$Config{ccdlflags} $Config{ldflags} @archives $ld_or_bs";
    print STDERR "ldopts: '$linkage'\n" if $Verbose;

    return $linkage if scalar @_;
    my_return("$linkage\n");
}

sub ccflags {
    my_return(" $Config{ccflags} ");
}

sub ccdlflags {
    my_return(" $Config{ccdlflags} ");
}

sub perl_inc {
    my $dir = File::Spec->catdir($Config{archlibexp}, 'CORE');
    $dir = qq["$dir"] if $^O eq 'MSWin32';
    my_return(" -I$dir ");
}

sub ccopts {
   ccflags . perl_inc;
}

sub canon {
    my($as, @ext) = @_;
    foreach(@ext) {
       # might be X::Y or lib/auto/X/Y/Y.a
       next if s!::!/!g;
       s:^(lib|ext)/(auto/)?::;
       s:/\w+\.\w+$::;
    }
    grep(s:/:$as:, @ext) if ($as ne '/');
    @ext;
}

__END__

=head1 NAME

ExtUtils::Embed - Utilities for embedding Perl in C/C++ applications

=head1 SYNOPSIS


 perl -MExtUtils::Embed -e xsinit 
 perl -MExtUtils::Embed -e ccopts 
 perl -MExtUtils::Embed -e ldopts 

=head1 DESCRIPTION

ExtUtils::Embed provides utility functions for embedding a Perl interpreter
and extensions in your C/C++ applications.  
Typically, an application B<Makefile> will invoke ExtUtils::Embed
functions while building your application.  

=head1 @EXPORT

ExtUtils::Embed exports the following functions:

xsinit(), ldopts(), ccopts(), perl_inc(), ccflags(), 
ccdlflags(), xsi_header(), xsi_protos(), xsi_body()

=head1 FUNCTIONS

=over

=item xsinit()

Generate C/C++ code for the XS initializer function.

When invoked as C<`perl -MExtUtils::Embed -e xsinit --`>
the following options are recognized:

B<-o> E<lt>output filenameE<gt> (Defaults to B<perlxsi.c>)

B<-o STDOUT> will print to STDOUT.

B<-std> (Write code for extensions that are linked with the current Perl.)

Any additional arguments are expected to be names of modules
to generate code for.

When invoked with parameters the following are accepted and optional:

C<xsinit($filename,$std,[@modules])>

Where,

B<$filename> is equivalent to the B<-o> option.

B<$std> is boolean, equivalent to the B<-std> option.  

B<[@modules]> is an array ref, same as additional arguments mentioned above.

=item Examples


 perl -MExtUtils::Embed -e xsinit -- -o xsinit.c Socket


This will generate code with an B<xs_init> function that glues the perl B<Socket::bootstrap> function 
to the C B<boot_Socket> function and writes it to a file named F<xsinit.c>.

Note that B<DynaLoader> is a special case where it must call B<boot_DynaLoader> directly.

 perl -MExtUtils::Embed -e xsinit


This will generate code for linking with B<DynaLoader> and 
each static extension found in B<$Config{static_ext}>.
The code is written to the default file name B<perlxsi.c>.


 perl -MExtUtils::Embed -e xsinit -- -o xsinit.c -std DBI DBD::Oracle


Here, code is written for all the currently linked extensions along with code
for B<DBI> and B<DBD::Oracle>.

If you have a working B<DynaLoader> then there is rarely any need to statically link in any 
other extensions.

=item ldopts()

Output arguments for linking the Perl library and extensions to your
application.

When invoked as C<`perl -MExtUtils::Embed -e ldopts --`>
the following options are recognized:

B<-std> 

Output arguments for linking the Perl library and any extensions linked
with the current Perl.

B<-I> E<lt>path1:path2E<gt>

Search path for ModuleName.a archives.  
Default path is B<@INC>.
Library archives are expected to be found as 
B</some/path/auto/ModuleName/ModuleName.a>
For example, when looking for B<Socket.a> relative to a search path, 
we should find B<auto/Socket/Socket.a>  

When looking for B<DBD::Oracle> relative to a search path,
we should find B<auto/DBD/Oracle/Oracle.a>

Keep in mind that you can always supply B</my/own/path/ModuleName.a>
as an additional linker argument.

B<-->  E<lt>list of linker argsE<gt>

Additional linker arguments to be considered.

Any additional arguments found before the B<--> token 
are expected to be names of modules to generate code for.

When invoked with parameters the following are accepted and optional:

C<ldopts($std,[@modules],[@link_args],$path)>

Where:

B<$std> is boolean, equivalent to the B<-std> option.  

B<[@modules]> is equivalent to additional arguments found before the B<--> token.

B<[@link_args]> is equivalent to arguments found after the B<--> token.

B<$path> is equivalent to the B<-I> option.

In addition, when ldopts is called with parameters, it will return the argument string
rather than print it to STDOUT.

=item Examples


 perl -MExtUtils::Embed -e ldopts


This will print arguments for linking with B<libperl.a>, B<DynaLoader> and 
extensions found in B<$Config{static_ext}>.  This includes libraries
found in B<$Config{libs}> and the first ModuleName.a library
for each extension that is found by searching B<@INC> or the path 
specified by the B<-I> option.  
In addition, when ModuleName.a is found, additional linker arguments
are picked up from the B<extralibs.ld> file in the same directory.


 perl -MExtUtils::Embed -e ldopts -- -std Socket


This will do the same as the above example, along with printing additional arguments for linking with the B<Socket> extension.


 perl -MExtUtils::Embed -e ldopts -- DynaLoader


This will print arguments for linking with just the B<DynaLoader> extension
and B<libperl.a>.


 perl -MExtUtils::Embed -e ldopts -- -std Msql -- -L/usr/msql/lib -lmsql


Any arguments after the second '--' token are additional linker
arguments that will be examined for potential conflict.  If there is no
conflict, the additional arguments will be part of the output.  


=item perl_inc()

For including perl header files this function simply prints:

 -I$Config{archlibexp}/CORE  

So, rather than having to say:

 perl -MConfig -e 'print "-I$Config{archlibexp}/CORE"'

Just say:

 perl -MExtUtils::Embed -e perl_inc

=item ccflags(), ccdlflags()

These functions simply print $Config{ccflags} and $Config{ccdlflags}

=item ccopts()

This function combines perl_inc(), ccflags() and ccdlflags() into one.

=item xsi_header()

This function simply returns a string defining the same B<EXTERN_C> macro as
B<perlmain.c> along with #including B<perl.h> and B<EXTERN.h>.  

=item xsi_protos(@modules)

This function returns a string of B<boot_$ModuleName> prototypes for each @modules.

=item xsi_body(@modules)

This function returns a string of calls to B<newXS()> that glue the module B<bootstrap>
function to B<boot_ModuleName> for each @modules.

B<xsinit()> uses the xsi_* functions to generate most of it's code.

=back

=head1 EXAMPLES

For examples on how to use B<ExtUtils::Embed> for building C/C++ applications
with embedded perl, see L<perlembed>.

=head1 SEE ALSO

L<perlembed>

=head1 AUTHOR

Doug MacEachern E<lt>F<dougm@osf.org>E<gt>

Based on ideas from Tim Bunce E<lt>F<Tim.Bunce@ig.co.uk>E<gt> and
B<minimod.pl> by Andreas Koenig E<lt>F<k@anna.in-berlin.de>E<gt> and Tim Bunce.

=cut

ns.
Please retry.\n";
	next;
      }
      if (-d $ans && -w _) {
	last;
      } else {
	warn "Couldn't find directory $ans
  or directory is not writable. Please retry.\n";
      }
    }
    $CPAN::Config->{cpan_home} = $ans;

                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                 #!/usr/local/bin/perl -w

use strict;
use IO::File;
use ExtUtils::Packlist;
use ExtUtils::Installed;

use vars qw($Inst @Modules);

################################################################################

sub do_module($)
{
my ($module) = @_;
my $help = <<EOF;
Available commands are:
   f [all|prog|doc]   - List installed files of a given type
   d [all|prog|doc]   - List the directories used by a module
   v                  - Validate the .packlist - check for missing files
   t <tarfile>        - Create a tar archive of the module
   q                  - Quit the module
EOF
print($help);
while (1)
   {
   print("$module cmd? ");
   my $reply = <STDIN>; chomp($reply);
   CASE:
      {
      $reply =~ /^f\s*/ and do
         {
         my $class = (split(' ', $reply))[1];
         $class = 'all' if (! $class);
         my @files;
         if (eval { @files = $Inst->files($module, $class); })
            {
            print("$class files in $module are:\n   ",
                  join("\n   ", @files), "\n");
            last CASE;
            }
         else
            { print($@); }
         };
      $reply =~ /^d\s*/ and do
         {
         my $class = (split(' ', $reply))[1];
         $class = 'all' if (! $class);
         my @dirs;
         if (eval { @dirs = $Inst->directories($module, $class); })
            {
            print("$class directories in $module are:\n   ",
                  join("\n   ", @dirs), "\n");
            last CASE;
            }
         else
            { print($@); }
         };
      $reply =~ /^t\s*/ and do
         {
         my $file = (split(' ', $reply))[1];
         my $tmp = "/tmp/inst.$$";
         if (my $fh = IO::File->new($tmp, "w"))
            {
            $fh->print(join("\n", $Inst->files($module)));
            $fh->close();
            system("tar cvf $file -I $tmp");
            unlink($tmp);
            last CASE;
            }
         else { print("Can't open $file: $!\n"); }
         last CASE;
         };
      $reply eq 'v' and do
         {
         if (my @missing = $Inst->validate($module))
            {
            print("Files missing from $module are:\n   ",
                  join("\n   ", @missing), "\n");
            }
         else
            {
            print("$module has no missing files\n");
            }
         last CASE;
         };
      $reply eq 'q' and do
         {
         return;
         };
      # Default
         print($help);
      }
   }
}

################################################################################

sub toplevel()
{
my $help = <<EOF;
Available commands are:
   l            - List all installed modules
   m <module>   - Select a module
   q            - Quit the program
EOF
print($help);
while (1)
   {
   print("cmd? ");
   my $reply = <STDIN>; chomp($reply);
   CASE:
      {
      $reply eq 'l' and do
         {
         print("Installed modules are:\n   ", join("\n   ", @Modules), "\n");
         last CASE;
         };
      $reply =~ /^m\s+/ and do
         {
         do_module((split(' ', $reply))[1]);
         last CASE;
         };
      $reply eq 'q' and do
         {
         exit(0);
         };
      # Default
         print($help);
      }
   }
}

################################################################################

$Inst = ExtUtils::Installed->new();
@Modules = $Inst->modules();
toplevel();

################################################################################
s to work properly.
Please correct me, if I guess the wrong path for a program. Don\'t
panic if you do not                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                package ExtUtils::Install;

use 5.005_64;
our(@ISA, @EXPORT, $VERSION);
$VERSION = substr q$Revision: 1.28 $, 10;
# $Date: 1998/01/25 07:08:24 $

use Exporter;
use Carp ();
use Config qw(%Config);
@ISA = ('Exporter');
@EXPORT = ('install','uninstall','pm_to_blib', 'install_default');
$Is_VMS = $^O eq 'VMS';

my $splitchar = $^O eq 'VMS' ? '|' : ($^O eq 'os2' || $^O eq 'dos') ? ';' : ':';
my @PERL_ENV_LIB = split $splitchar, defined $ENV{'PERL5LIB'} ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || '';
my $Inc_uninstall_warn_handler;

# install relative to here

my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT};

use File::Spec;

sub install_rooted_file {
    if (defined $INSTALL_ROOT) {
	MY->catfile($INSTALL_ROOT, $_[0]);
    } else {
	$_[0];
    }
}

sub install_rooted_dir {
    if (defined $INSTALL_ROOT) {
	MY->catdir($INSTALL_ROOT, $_[0]);
    } else {
	$_[0];
    }
}

#our(@EXPORT, @ISA, $Is_VMS);
#use strict;

sub forceunlink {
    chmod 0666, $_[0];
    unlink $_[0] or Carp::croak("Cannot forceunlink $_[0]: $!")
}

sub install {
    my($hash,$verbose,$nonono,$inc_uninstall) = @_;
    $verbose ||= 0;
    $nonono  ||= 0;

    use Cwd qw(cwd);
    use ExtUtils::MakeMaker; # to implement a MY class
    use ExtUtils::Packlist;
    use File::Basename qw(dirname);
    use File::Copy qw(copy);
    use File::Find qw(find);
    use File::Path qw(mkpath);
    use File::Compare qw(compare);

    my(%hash) = %$hash;
    my(%pack, $dir, $warn_permissions);
    my($packlist) = ExtUtils::Packlist->new();
    # -w doesn't work reliably on FAT dirs
    $warn_permissions++ if $^O eq 'MSWin32';
    local(*DIR);
    for (qw/read write/) {
	$pack{$_}=$hash{$_};
	delete $hash{$_};
    }
    my($source_dir_or_file);
    foreach $source_dir_or_file (sort keys %hash) {
	#Check if there are files, and if yes, look if the corresponding
	#target directory is writable for us
	opendir DIR, $source_dir_or_file or next;
	for (readdir DIR) {
	    next if $_ eq "." || $_ eq ".." || $_ eq ".exists";
		my $targetdir = install_rooted_dir($hash{$source_dir_or_file});
	    if (-w $targetdir ||
		mkpath($targetdir)) {
		last;
	    } else {
		warn "Warning: You do not have permissions to " .
		    "install into $hash{$source_dir_or_file}"
		    unless $warn_permissions++;
	    }
	}
	closedir DIR;
    }
    my $tmpfile = install_rooted_file($pack{"read"});
    $packlist->read($tmpfile) if (-f $tmpfile);
    my $cwd = cwd();

    my($source);
    MOD_INSTALL: foreach $source (sort keys %hash) {
	#copy the tree to the target directory without altering
	#timestamp and permission and remember for the .packlist
	#file. The packlist file contains the absolute paths of the
	#install locations. AFS users may call this a bug. We'll have
	#to reconsider how to add the means to satisfy AFS users also.

	#October 1997: we want to install .pm files into archlib if
	#there are any files in arch. So we depend on having ./blib/arch
	#hardcoded here.

	my $targetroot = install_rooted_dir($hash{$source});

	if ($source eq "blib/lib" and
	    exists $hash{"blib/arch"} and
	    directory_not_empty("blib/arch")) {
	    $targetroot = install_rooted_dir($hash{"blib/arch"});
            print "Files found in blib/arch: installing files in blib/lib into architecture dependent library tree\n";
	}
	chdir($source) or next;
	find(sub {
	    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
                         $atime,$mtime,$ctime,$blksize,$blocks) = stat;
	    return unless -f _;
	    return if $_ eq ".exists";
	    my $targetdir  = MY->catdir($targetroot, $File::Find::dir);
	    my $targetfile = MY->catfile($targetdir, $_);

	    my $diff = 0;
	    if ( -f $targetfile && -s _ == $size) {
		# We have a good chance, we can skip this one
		$diff = compare($_,$targetfile);
	    } else {
		print "$_ differs\n" if $verbose>1;
		$diff++;
	    }

	    if ($diff){
		if (-f $targetfile){
		    forceunlink($targetfile) unless $nonono;
		} else {
		    mkpath($targetdir,0,0755) unless $nonono;
		    print "mkpath($targetdir,0,0755)\n" if $verbose>1;
		}
		copy($_,$targetfile) unless $nonono;
		print "Installing $targetfile\n";
		utime($atime,$mtime + $Is_VMS,$targetfile) unless $nonono>1;
		print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
		$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
		chmod $mode, $targetfile;
		print "chmod($mode, $targetfile)\n" if $verbose>1;
	    } else {
		print "Skipping $targetfile (unchanged)\n" if $verbose;
	    }
	    
	    if (! defined $inc_uninstall) { # it's called 
	    } elsif ($inc_uninstall == 0){
		inc_uninstall($_,$File::Find::dir,$verbose,1); # nonono set to 1
	    } else {
		inc_uninstall($_,$File::Find::dir,$verbose,0); # nonono set to 0
	    }
	    $packlist->{$targetfile}++;

	}, ".");
	chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!");
    }
    if ($pack{'write'}) {
	$dir = install_rooted_dir(dirname($pack{'write'}));
	mkpath($dir,0,0755);
	print "Writing $pack{'write'}\n";
	$packlist->write(install_rooted_file($pack{'write'}));
    }
}

sub directory_not_empty ($) {
  my($dir) = @_;
  my $files = 0;
  find(sub {
	   return if $_ eq ".exists";
	   if (-f) {
	     $File::Find::prune++;
	     $files = 1;
	   }
       }, $dir);
  return $files;
}

sub install_default {
  @_ < 2 or die "install_default should be called with 0 or 1 argument";
  my $FULLEXT = @_ ? shift : $ARGV[0];
  defined $FULLEXT or die "Do not know to where to write install log";
  my $INST_LIB = MM->catdir(MM->curdir,"blib","lib");
  my $INST_ARCHLIB = MM->catdir(MM->curdir,"blib","arch");
  my $INST_BIN = MM->catdir(MM->curdir,'blib','bin');
  my $INST_SCRIPT = MM->catdir(MM->curdir,'blib','script');
  my $INST_MAN1DIR = MM->catdir(MM->curdir,'blib','man1');
  my $INST_MAN3DIR = MM->catdir(MM->curdir,'blib','man3');
  install({
	   read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist",
	   write => "$Config{installsitearch}/auto/$FULLEXT/.packlist",
	   $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ?
			 $Config{installsitearch} :
			 $Config{installsitelib},
	   $INST_ARCHLIB => $Config{installsitearch},
	   $INST_BIN => $Config{installbin} ,
	   $INST_SCRIPT => $Config{installscript},
	   $INST_MAN1DIR => $Config{installman1dir},
	   $INST_MAN3DIR => $Config{installman3dir},
	  },1,0,0);
}

sub uninstall {
    use ExtUtils::Packlist;
    my($fil,$verbose,$nonono) = @_;
    die "no packlist file found: $fil" unless -f $fil;
    # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
    # require $my_req; # Hairy, but for the first
    my ($packlist) = ExtUtils::Packlist->new($fil);
    foreach (sort(keys(%$packlist))) {
	chomp;
	print "unlink $_\n" if $verbose;
	forceunlink($_) unless $nonono;
    }
    print "unlink $fil\n" if $verbose;
    forceunlink($fil) unless $nonono;
}

sub inc_uninstall {
    my($file,$libdir,$verbose,$nonono) = @_;
    my($dir);
    my %seen_dir = ();
    foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw(archlibexp
						  privlibexp
						  sitearchexp
						  sitelibexp)}) {
	next if $dir eq ".";
	next if $seen_dir{$dir}++;
	my($targetfile) = MY->catfile($dir,$libdir,$file);
	next unless -f $targetfile;

	# The reason why we compare file's contents is, that we cannot
	# know, which is the file we just installed (AFS). So we leave
	# an identical file in place
	my $diff = 0;
	if ( -f $targetfile && -s _ == -s $file) {
	    # We have a good chance, we can skip this one
	    $diff = compare($file,$targetfile);
	} else {
	    print "#$file and $targetfile differ\n" if $verbose>1;
	    $diff++;
	}

	next unless $diff;
	if ($nonono) {
	    if ($verbose) {
		$Inc_uninstall_warn_handler ||= new ExtUtils::Install::Warn;
		$libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier.
		$Inc_uninstall_warn_handler->add("$libdir/$file",$targetfile);
	    }
	    # if not verbose, we just say nothing
	} else {
	    print "Unlinking $targetfile (shadowing?)\n";
	    forceunlink($targetfile);
	}
    }
}

sub run_filter {
    my ($cmd, $src, $dest) = @_;
    open(my $CMD, "|$cmd >$dest") || die "Cannot fork: $!";
    open(my $SRC, $src)           || die "Cannot open $src: $!";
    my $buf;
    my $sz = 1024;
    while (my $len = sysread($SRC, $buf, $sz)) {
	syswrite($CMD, $buf, $len);
    }
    close $SRC;
    close $CMD or die "Filter command '$cmd' failed for $src";
}

sub pm_to_blib {
    my($fromto,$autodir,$pm_filter) = @_;

    use File::Basename qw(dirname);
    use File::Copy qw(copy);
    use File::Path qw(mkpath);
    use File::Compare qw(compare);
    use AutoSplit;
    # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
    # require $my_req; # Hairy, but for the first

    if (!ref($fromto) && -r $fromto)
     {
      # Win32 has severe command line length limitations, but
      # can generate temporary files on-the-fly
      # so we pass name of file here - eval it to get hash 
      open(FROMTO,"<$fromto") or die "Cannot open $fromto:$!";
      my $str = '$fromto = {qw{'.join('',<FROMTO>).'}}';
      eval $str;
      close(FROMTO);
     }

    mkpath($autodir,0,0755);
    foreach (keys %$fromto) {
	my $dest = $fromto->{$_};
	next if -f $dest && -M $dest < -M $_;

	# When a pm_filter is defined, we need to pre-process the source first
	# to determine whether it has changed or not.  Therefore, only perform
	# the comparison check when there's no filter to be ran.
	#    -- RAM, 03/01/2001

	my $need_filtering = defined $pm_filter && length $pm_filter && /\.pm$/;

	if (!$need_filtering && 0 == compare($_,$dest)) {
	    print "Skip $dest (unchanged)\n";
	    next;
	}
	if (-f $dest){
	    forceunlink($dest);
	} else {
	    mkpath(dirname($dest),0,0755);
	}
	if ($need_filtering) {
	    run_filter($pm_filter, $_, $dest);
	    print "$pm_filter <$_ >$dest\n";
	} else {
	    copy($_,$dest);
	    print "cp $_ $dest\n";
	}
	my($mode,$atime,$mtime) = (stat)[2,8,9];
	utime($atime,$mtime+$Is_VMS,$dest);
	chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$dest);
	next unless /\.pm$/;
	autosplit($dest,$autodir);
    }
}

package ExtUtils::Install::Warn;

sub new { bless {}, shift }

sub add {
    my($self,$file,$targetfile) = @_;
    push @{$self->{$file}}, $targetfile;
}

sub DESTROY {
	unless(defined $INSTALL_ROOT) {
		my $self = shift;
		my($file,$i,$plural);
		foreach $file (sort keys %$self) {
		$plural = @{$self->{$file}} > 1 ? "s" : "";
		print "## Differing version$plural of $file found. You might like to\n";
		for (0..$#{$self->{$file}}) {
			print "rm ", $self->{$file}[$_], "\n";
			$i++;
		}
		}
		$plural = $i>1 ? "all those files" : "this file";
		print "## Running 'make install UNINST=1' will unlink $plural for you.\n";
	}
}

1;

__END__

=head1 NAME

ExtUtils::Install - install files from here to there

=head1 SYNOPSIS

B<use ExtUtils::Install;>

B<install($hashref,$verbose,$nonono);>

B<uninstall($packlistfile,$verbose,$nonono);>

B<pm_to_blib($hashref);>

=head1 DESCRIPTION

Both install() and uninstall() are specific to the way
ExtUtils::MakeMaker handles the installation and deinstallation of
perl modules. They are not designed as general purpose tools.

install() takes three arguments. A reference to a hash, a verbose
switch and a don't-really-do-it switch. The hash ref contains a
mapping of directories: each key/value pair is a combination of
directories to be copied. Key is a directory to copy from, value is a
directory to copy to. The whole tree below the "from" directory will
be copied preserving timestamps and permissions.

There are two keys with a special meaning in the hash: "read" and
"write". After the copying is done, install will write the list of
target files to the file named by C<$hashref-E<gt>{write}>. If there is
another file named by C<$hashref-E<gt>{read}>, the contents of this file will
be merged into the written file. The read and the written file may be
identical, but on AFS it is quite likely that people are installing to a
different directory than the one where the files later appear.

install_default() takes one or less arguments.  If no arguments are 
specified, it takes $ARGV[0] as if it was specified as an argument.  
The argument is the value of MakeMaker's C<FULLEXT> key, like F<Tk/Canvas>.  
This function calls install() with the same arguments as the defaults 
the MakeMaker would use.

The argument-less form is convenient for install scripts like

  perl -MExtUtils::Install -e install_default Tk/Canvas

Assuming this command is executed in a directory with a populated F<blib> 
directory, it will proceed as if the F<blib> was build by MakeMaker on 
this machine.  This is useful for binary distributions.

uninstall() takes as first argument a file containing filenames to be
unlinked. The second argument is a verbose switch, the third is a
no-don't-really-do-it-now switch.

pm_to_blib() takes a hashref as the first argument and copies all keys
of the hash to the corresponding values efficiently. Filenames with
the extension pm are autosplit. Second argument is the autosplit
directory.  If third argument is not empty, it is taken as a filter command
to be ran on each .pm file, the output of the command being what is finally
copied, and the source for auto-splitting.

You can have an environment variable PERL_INSTALL_ROOT set which will
be prepended as a directory to each installed file (and directory).

=cut
 now so that if we get called
    # again, we initialize ourselves in exactly the same way.  This allows
    # us to have several of these objects.
    @QUERY_PARAM = $self->param; # save list of parameters
    foreach (@QUERY_PARAM) {
      next unless defined $_;
      $QUERY_PARAM{$_}=$self->{$_};
    }
    $QUERY_CHARSET = $self->charset;
    %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
}

sub parse_params {
    my($self,$tosplit) = @_;
    my(@pairs) = split(/[&;]/ $package CPAN::Nox;
use strict;
u                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                package ExtUtils::Installed;

use 5.005_64;
use strict;
use Carp qw();
use ExtUtils::Packlist;
use ExtUtils::MakeMaker;
use Config;
use File::Find;
use File::Basename;
our $VERSION = '0.03';

my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/);

sub _is_prefix
{
my ($self, $path, $prefix) = @_;
if (substr($path, 0, length($prefix)) eq $prefix)
   {
   return(1);
   }
if ($DOSISH)
   {
   $path =~ s|\\|/|g;
   $prefix =~ s|\\|/|g;
   if ($path =~ m{^\Q$prefix\E}i)
      {
      return(1);
      }
   }
return(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)
   }
if ($type eq "prog")
   {
   return($self->_is_prefix($path, $Config{prefix})
          &&
          !$self->_is_prefix($path, $Config{installman1dir})
          &&
          !$self->_is_prefix($path, $Config{installman3dir})
          ? 1 : 0);
   }
return(0);
}

sub _is_under($$;)
{
my ($self, $path, @under) = @_;
$under[0] = "" if (! @under);
foreach my $dir (@under)
   {
   return(1) if ($self->_is_prefix($path, $dir));
   }
return(0);
}

sub new($)
{
my ($class) = @_;
$class = ref($class) || $class;
my $self = {};

my $installarchlib = $Config{installarchlib};
my $archlib = $Config{archlib};
my $sitearch = $Config{sitearch};

if ($DOSISH)
   {
   $installarchlib =~ s|\\|/|g;
   $archlib =~ s|\\|/|g;
   $sitearch =~ s|\\|/|g;
   }

# Read the core packlist
$self->{Perl}{packlist} =
   ExtUtils::Packlist->new("$installarchlib/.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;

   # Hack of the leading bits of the paths & convert to a module name
   my $module = $File::Find::name;
   $module =~ s!\Q$archlib\E/auto/(.*)/.packlist!$1!s;
   $module =~ s!\Q$sitearch\E/auto/(.*)/.packlist!$1!s;
   my $modfile = "$module.pm";
   $module =~ s!/!::!g;

   # Find the top-level module file in @INC
   $self->{$module}{version} = '';
   foreach my $dir (@INC)
      {
      my $p = MM->catfile($dir, $modfile);
      if (-f $p)
         {
         $self->{$module}{version} = MM->parse_version($p);
         last;
         }
      }

   # Read the .packlist
   $self->{$module}{packlist} = ExtUtils::Packlist->new($File::Find::name);
   };
find($sub, $archlib, $sitearch);

return(bless($self, $class));
}

sub modules($)
{
my ($self) = @_;
return(sort(keys(%$self)));
}

sub files($$;$)
{
my ($self, $module, $type, @under) = @_;

# Validate arguments
Carp::croak("$module is not installed") if (! exists($self->{$module}));
$type = "all" if (! defined($type));
Carp::croak('type must be "all", "prog" or "doc"')
   if ($type ne "all" && $type ne "prog" && $type ne "doc");

my (@files);
foreach my $file (keys(%{$self->{$module}{packlist}}))
   {
   push(@files, $file)
      if ($self->_is_type($file, $type) && $self->_is_under($file, @under));
   }
return(@files);
}

sub directories($$;$)
{
my ($self, $module, $type, @under) = @_;
my (%dirs);
foreach my $file ($self->files($module, $type, @under))
   {
   $dirs{dirname($file)}++;
   }
return(sort(keys(%dirs)));
}

sub directory_tree($$;$)
{
my ($self, $module, $type, @under) = @_;
my (%dirs);
foreach my $dir ($self->directories($module, $type, @under))
   {
   $dirs{$dir}++;
   my ($last) = ("");
   while ($last ne $dir)
      {
      $last = $dir;
      $dir = dirname($dir);
      last if (! $self->_is_under($dir, @under));
      $dirs{$dir}++;
      }
   }
return(sort(keys(%dirs)));
}

sub validate($;$)
{
my ($self, $module, $remove) = @_;
Carp::croak("$module is not installed") if (! exists($self->{$module}));
return($self->{$module}{packlist}->validate($remove));
}

sub packlist($$)
{
my ($self, $module) = @_;
Carp::croak("$module is not installed") if (! exists($self->{$module}));
return($self->{$module}{packlist});
}

sub version($$)
{
my ($self, $module) = @_;
Carp::croak("$module is not installed") if (! exists($self->{$module}));
return($self->{$module}{version});
}

sub DESTROY
{
}

1;

__END__

=head1 NAME

ExtUtils::Installed - Inventory management of installed modules

=head1 SYNOPSIS

   use ExtUtils::Installed;
   my ($inst) = ExtUtils::Installed->new();
   my (@modules) = $inst->modules();
   my (@missing) = $inst->validate("DBI");
   my $all_files = $inst->files("DBI");
   my $files_below_usr_local = $inst->files("DBI", "all", "/usr/local");
   my $all_dirs = $inst->directories("DBI");
   my $dirs_below_usr_local = $inst->directory_tree("DBI", "prog");
   my $packlist = $inst->packlist("DBI");

=head1 DESCRIPTION

ExtUtils::Installed  provides a standard way to find out what core and module
files have been installed.  It uses the information stored in .packlist files
created during installation to provide this information.  In addition it
provides facilities to classify the installed files and to extract directory
information from the .packlist files.

=head1 USAGE

The new() function searches for all the installed .packlists on the system, and
stores their contents. The .packlists can be queried with the functions
described below.

=head1 FUNCTIONS

=over

=item new()

This takes no parameters, and searches for all the installed .packlists on the
system.  The packlists are read using the ExtUtils::packlist module.

=item modules()

This returns a list of the names of all the installed modules.  The perl 'core'
is given the special name 'Perl'.

=item files()

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,
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.

=item 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
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
the leaf directories that contain files from the specified module.

=item directory_tree()

This is identical in operation to directory(), except that it includes all the
intermediate directories back up to the specified directories.

=item validate()

This takes one mandatory parameter, the name of a module.  It checks that all
the files listed in the modules .packlist actually exist, and returns a list of
any missing files.  If an optional second argument which evaluates to true is
given any missing files will be removed from the .packlist

=item packlist()

This returns the ExtUtils::Packlist object for the specified module.

=item version()

This returns the version number for the specified module.

=back

=head1 EXAMPLE

See the example in L<ExtUtils::Packlist>.

=head1 AUTHOR

Alan Burlison <Alan.Burlison@uk.sun.com>

=cut
$SETUPDONE);
# we delay requiring LWP::UserAgent and setting up inheritence until we need it

package CPAN::Complete;
@CPAN::Complete::ISA = qw(CPAN::Debug);
@CPAN::Complete::COMMANDS = sort qw(
		       ! a b d h i m o q r u autobundle                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                package ExtUtils::Liblist;

@ISA = qw(ExtUtils::Liblist::Kid File::Spec);

sub lsdir {
  shift;
  my $rex = qr/$_[1]/;
  opendir my $dir, $_[0];
  grep /$rex/, readdir $dir;
}

sub file_name_is_absolute {
  require File::Spec;
  shift;
  'File::Spec'->file_name_is_absolute(@_);
}


package ExtUtils::Liblist::Kid;

# This kid package is to be used by MakeMaker.  It will not work if
# $self is not a Makemaker.

use 5.005_64;
# Broken out of MakeMaker from version 4.11

our $VERSION = substr q$Revision: 1.26 $, 10;

use Config;
use Cwd 'cwd';
use File::Basename;

sub ext {
  if   ($^O eq 'VMS')     { return &_vms_ext;      }
  elsif($^O eq 'MSWin32') { return &_win32_ext;    }
  else                    { return &_unix_os2_ext; }
}

sub _unix_os2_ext {
    my($self,$potential_libs, $verbose, $give_libs) = @_;
    if ($^O =~ 'os2' and $Config{perllibs}) { 
	# Dynamic libraries are not transitive, so we may need including
	# the libraries linked against perl.dll again.

	$potential_libs .= " " if $potential_libs;
	$potential_libs .= $Config{perllibs};
    }
    return ("", "", "", "", ($give_libs ? [] : ())) unless $potential_libs;
    warn "Potential libraries are '$potential_libs':\n" if $verbose;

    my($so)   = $Config{'so'};
    my($libs) = $Config{'perllibs'};
    my $Config_libext = $Config{lib_ext} || ".a";


    # compute $extralibs, $bsloadlibs and $ldloadlibs from
    # $potential_libs
    # this is a rewrite of Andy Dougherty's extliblist in perl

    my(@searchpath); # from "-L/path" entries in $potential_libs
    my(@libpath) = split " ", $Config{'libpth'};
    my(@ldloadlibs, @bsloadlibs, @extralibs, @ld_run_path, %ld_run_path_seen);
    my(@libs, %libs_seen);
    my($fullname, $thislib, $thispth, @fullname);
    my($pwd) = cwd(); # from Cwd.pm
    my($found) = 0;

    foreach $thislib (split ' ', $potential_libs){

	# Handle possible linker path arguments.
	if ($thislib =~ s/^(-[LR])//){	# save path flag type
	    my($ptype) = $1;
	    unless (-d $thislib){
		warn "$ptype$thislib ignored, directory does not exist\n"
			if $verbose;
		next;
	    }
	    unless ($self->file_name_is_absolute($thislib)) {
	      warn "Warning: $ptype$thislib changed to $ptype$pwd/$thislib\n";
	      $thislib = $self->catdir($pwd,$thislib);
	    }
	    push(@searchpath, $thislib);
	    push(@extralibs,  "$ptype$thislib");
	    push(@ldloadlibs, "$ptype$thislib");
	    next;
	}

	# Handle possible library arguments.
	unless ($thislib =~ s/^-l//){
	  warn "Unrecognized argument in LIBS ignored: '$thislib'\n";
	  next;
	}

	my($found_lib)=0;
	foreach $thispth (@searchpath, @libpath){

		# Try to find the full name of the library.  We need this to
		# determine whether it's a dynamically-loadable library or not.
		# This tends to be subject to various os-specific quirks.
		# For gcc-2.6.2 on linux (March 1995), DLD can not load
		# .sa libraries, with the exception of libm.sa, so we
		# deliberately skip them.
	    if (@fullname =
		    $self->lsdir($thispth,"^\Qlib$thislib.$so.\E[0-9]+")){
		# Take care that libfoo.so.10 wins against libfoo.so.9.
		# Compare two libraries to find the most recent version
		# number.  E.g.  if you have libfoo.so.9.0.7 and
		# libfoo.so.10.1, first convert all digits into two
		# decimal places.  Then we'll add ".00" to the shorter
		# strings so that we're comparing strings of equal length
		# Thus we'll compare libfoo.so.09.07.00 with
		# libfoo.so.10.01.00.  Some libraries might have letters
		# in the version.  We don't know what they mean, but will
		# try to skip them gracefully -- we'll set any letter to
		# '0'.  Finally, sort in reverse so we can take the
		# first element.

		#TODO: iterate through the directory instead of sorting

		$fullname = "$thispth/" .
		(sort { my($ma) = $a;
			my($mb) = $b;
			$ma =~ tr/A-Za-z/0/s;
			$ma =~ s/\b(\d)\b/0$1/g;
			$mb =~ tr/A-Za-z/0/s;
			$mb =~ s/\b(\d)\b/0$1/g;
			while (length($ma) < length($mb)) { $ma .= ".00"; }
			while (length($mb) < length($ma)) { $mb .= ".00"; }
			# Comparison deliberately backwards
			$mb cmp $ma;} @fullname)[0];
	    } elsif (-f ($fullname="$thispth/lib$thislib.$so")
		 && (($Config{'dlsrc'} ne "dl_dld.xs") || ($thislib eq "m"))){
	    } elsif (-f ($fullname="$thispth/lib${thislib}_s$Config_libext")
                 && (! $Config{'archname'} =~ /RM\d\d\d-svr4/)
		 && ($thislib .= "_s") ){ # we must explicitly use _s version
	    } elsif (-f ($fullname="$thispth/lib$thislib$Config_libext")){
	    } elsif (-f ($fullname="$thispth/$thislib$Config_libext")){
	    } elsif (-f ($fullname="$thispth/Slib$thislib$Config_libext")){
	    } elsif ($^O eq 'dgux'
		 && -l ($fullname="$thispth/lib$thislib$Config_libext")
		 && readlink($fullname) =~ /^elink:/s) {
		 # Some of DG's libraries look like misconnected symbolic
		 # links, but development tools can follow them.  (They
		 # look like this:
		 #
		 #    libm.a -> elink:${SDE_PATH:-/usr}/sde/\
		 #    ${TARGET_BINARY_INTERFACE:-m88kdgux}/usr/lib/libm.a
		 #
		 # , the compilation tools expand the environment variables.)
	    } else {
		warn "$thislib not found in $thispth\n" if $verbose;
		next;
	    }
	    warn "'-l$thislib' found at $fullname\n" if $verbose;
	    my($fullnamedir) = dirname($fullname);
	    push @ld_run_path, $fullnamedir unless $ld_run_path_seen{$fullnamedir}++;
	    push @libs, $fullname unless $libs_seen{$fullname}++;
	    $found++;
	    $found_lib++;

	    # Now update library lists

	    # what do we know about this library...
	    my $is_dyna = ($fullname !~ /\Q$Config_libext\E\z/);
	    my $in_perl = ($libs =~ /\B-l\Q$ {thislib}\E\b/s);

	    # Do not add it into the list if it is already linked in
	    # with the main perl executable.
	    # We have to special-case the NeXT, because math and ndbm 
	    # are both in libsys_s
	    unless ($in_perl || 
		($Config{'osname'} eq 'next' &&
		    ($thislib eq 'm' || $thislib eq 'ndbm')) ){
		push(@extralibs, "-l$thislib");
	    }

	    # We might be able to load this archive file dynamically
	    if ( ($Config{'dlsrc'} =~ /dl_next/ && $Config{'osvers'} lt '4_0')
	    ||   ($Config{'dlsrc'} =~ /dl_dld/) )
	    {
		# We push -l$thislib instead of $fullname because
		# it avoids hardwiring a fixed path into the .bs file.
		# Mkbootstrap will automatically add dl_findfile() to
		# the .bs file if it sees a name in the -l format.
		# USE THIS, when dl_findfile() is fixed: 
		# push(@bsloadlibs, "-l$thislib");
		# OLD USE WAS while checking results against old_extliblist
		push(@bsloadlibs, "$fullname");
	    } else {
		if ($is_dyna){
                    # For SunOS4, do not add in this shared library if
                    # it is already linked in the main perl executable
		    push(@ldloadlibs, "-l$thislib")
			unless ($in_perl and $^O eq 'sunos');
		} else {
		    push(@ldloadlibs, "-l$thislib");
		}
	    }
	    last;	# found one here so don't bother looking further
	}
	warn "Note (probably harmless): "
		     ."No library found for -l$thislib\n"
	    unless $found_lib>0;
    }
    return ('','','','', ($give_libs ? \@libs : ())) unless $found;
    ("@extralibs", "@bsloadlibs", "@ldloadlibs",join(":",@ld_run_path), ($give_libs ? \@libs : ()));
}

sub _win32_ext {

    require Text::ParseWords;

    my($self, $potential_libs, $verbose, $give_libs) = @_;

    # If user did not supply a list, we punt.
    # (caller should probably use the list in $Config{libs})
    return ("", "", "", "", ($give_libs ? [] : ())) unless $potential_libs;

    my $cc		= $Config{cc};
    my $VC		= 1 if $cc =~ /^cl/i;
    my $BC		= 1 if $cc =~ /^bcc/i;
    my $GC		= 1 if $cc =~ /^gcc/i;
    my $so		= $Config{'so'};
    my $libs		= $Config{'perllibs'};
    my $libpth		= $Config{'libpth'};
    my $libext		= $Config{'lib_ext'} || ".lib";
    my(@libs, %libs_seen);

    if ($libs and $potential_libs !~ /:nodefault/i) { 
	# If Config.pm defines a set of default libs, we always
	# tack them on to the user-supplied list, unless the user
	# specified :nodefault

	$potential_libs .= " " if $potential_libs;
	$potential_libs .= $libs;
    }
    warn "Potential libraries are '$potential_libs':\n" if $verbose;

    # normalize to forward slashes
    $libpth =~ s,\\,/,g;
    $potential_libs =~ s,\\,/,g;

    # compute $extralibs from $potential_libs

    my @searchpath;		    # from "-L/path" in $potential_libs
    my @libpath		= Text::ParseWords::quotewords('\s+', 0, $libpth);
    my @extralibs;
    my $pwd		= cwd();    # from Cwd.pm
    my $lib		= '';
    my $found		= 0;
    my $search		= 1;
    my($fullname, $thislib, $thispth);

    # add "$Config{installarchlib}/CORE" to default search path
    push @libpath, "$Config{installarchlib}/CORE";

    if ($VC and exists $ENV{LIB} and $ENV{LIB}) {
        push @libpath, split /;/, $ENV{LIB};
    }

    foreach (Text::ParseWords::quotewords('\s+', 0, $potential_libs)){

	$thislib = $_;

        # see if entry is a flag
	if (/^:\w+$/) {
	    $search	= 0 if lc eq ':nosearch';
	    $search	= 1 if lc eq ':search';
	    warn "Ignoring unknown flag '$thislib'\n"
		if $verbose and !/^:(no)?(search|default)$/i;
	    next;
	}

	# if searching is disabled, do compiler-specific translations
	unless ($search) {
	    s/^-l(.+)$/$1.lib/ unless $GC;
	    s/^-L/-libpath:/ if $VC;
	    push(@extralibs, $_);
	    $found++;
	    next;
	}

	# handle possible linker path arguments
	if (s/^-L// and not -d) {
	    warn "$thislib ignored, directory does not exist\n"
		if $verbose;
	    next;
	}
	elsif (-d) {
	    unless ($self->file_name_is_absolute($_)) {
	      warn "Warning: '$thislib' changed to '-L$pwd/$_'\n";
	      $_ = $self->catdir($pwd,$_);
	    }
	    push(@searchpath, $_);
	    next;
	}

	# handle possible library arguments
	if (s/^-l// and $GC and !/^lib/i) {
	    $_ = "lib$_";
	}
	$_ .= $libext if !/\Q$libext\E$/i;

	my $secondpass = 0;
    LOOKAGAIN:

        # look for the file itself
	if (-f) {
	    warn "'$thislib' found as '$_'\n" if $verbose;
	    $found++;
	    push(@extralibs, $_);
	    next;
	}

	my $found_lib = 0;
	foreach $thispth (@searchpath, @libpath){
	    unless (-f ($fullname="$thispth\\$_")) {
		warn "'$thislib' not found as '$fullname'\n" if $verbose;
		next;
	    }
	    warn "'$thislib' found as '$fullname'\n" if $verbose;
	    $found++;
	    $found_lib++;
	    push(@extralibs, $fullname);
	    push @libs, $fullname unless $libs_seen{$fullname}++;
	    last;
	}

	# do another pass with (or without) leading 'lib' if they used -l
	if (!$found_lib and $thislib =~ /^-l/ and !$secondpass++) {
	    if ($GC) {
		goto LOOKAGAIN if s/^lib//i;
	    }
	    elsif (!/^lib/i) {
		$_ = "lib$_";
		goto LOOKAGAIN;
	    }
	}

	# give up
	warn "Note (probably harmless): "
		     ."No library found for '$thislib'\n"
	    unless $found_lib>0;

    }

    return ('','','','', ($give_libs ? \@libs : ())) unless $found;

    # make sure paths with spaces are properly quoted
    @extralibs = map { (/\s/ && !/^".*"$/) ? qq["$_"] : $_ } @extralibs;
    @libs = map { (/\s/ && !/^".*"$/) ? qq["$_"] : $_ } @libs;
    $lib = join(' ',@extralibs);

    # normalize back to backward slashes (to help braindead tools)
    # XXX this may break equally braindead GNU tools that don't understand
    # backslashes, either.  Seems like one can't win here.  Cursed be CP/M.
    $lib =~ s,/,\\,g;

    warn "Result: $lib\n" if $verbose;
    wantarray ? ($lib, '', $lib, '', ($give_libs ? \@libs : ())) : $lib;
}


sub _vms_ext {
  my($self, $potential_libs,$verbose,$give_libs) = @_;
  my(@crtls,$crtlstr);
  my($dbgqual) = $self->{OPTIMIZE} || $Config{'optimize'} ||
                 $self->{CCFLAS}   || $Config{'ccflags'};
  @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '')
              . 'PerlShr/Share' );
  push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'});
  push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'});
  # In general, we pass through the basic libraries from %Config unchanged.
  # The one exception is that if we're building in the Perl source tree, and
  # a library spec could be resolved via a logical name, we go to some trouble
  # to insure that the copy in the local tree is used, rather than one to
  # which a system-wide logical may point.
  if ($self->{PERL_SRC}) {
    my($lib,$locspec,$type);
    foreach $lib (@crtls) { 
      if (($locspec,$type) = $lib =~ m-^([\w$\-]+)(/\w+)?- and $locspec =~ /perl/i) {
        if    (lc $type eq '/share')   { $locspec .= $Config{'exe_ext'}; }
        elsif (lc $type eq '/library') { $locspec .= $Config{'lib_ext'}; }
        else                           { $locspec .= $Config{'obj_ext'}; }
        $locspec = $self->catfile($self->{PERL_SRC},$locspec);
        $lib = "$locspec$type" if -e $locspec;
      }
    }
  }
  $crtlstr = @crtls ? join(' ',@crtls) : '';

  unless ($potential_libs) {
    warn "Result:\n\tEXTRALIBS: \n\tLDLOADLIBS: $crtlstr\n" if $verbose;
    return ('', '', $crtlstr, '', ($give_libs ? [] : ()));
  }

  my(@dirs,@libs,$dir,$lib,%found,@fndlibs,$ldlib);
  my $cwd = cwd();
  my($so,$lib_ext,$obj_ext) = @Config{'so','lib_ext','obj_ext'};
  # List of common Unix library names and there VMS equivalents
  # (VMS equivalent of '' indicates that the library is automatially
  # searched by the linker, and should be skipped here.)
  my(@flibs, %libs_seen);
  my %libmap = ( 'm' => '', 'f77' => '', 'F77' => '', 'V77' => '', 'c' => '',
                 'malloc' => '', 'crypt' => '', 'resolv' => '', 'c_s' => '',
                 'socket' => '', 'X11' => 'DECW$XLIBSHR',
                 'Xt' => 'DECW$XTSHR', 'Xm' => 'DECW$XMLIBSHR',
                 'Xmu' => 'DECW$XMULIBSHR');
  if ($Config{'vms_cc_type'} ne 'decc') { $libmap{'curses'} = 'VAXCCURSE'; }

  warn "Potential libraries are '$potential_libs'\n" if $verbose;

  # First, sort out directories and library names in the input
  foreach $lib (split ' ',$potential_libs) {
    push(@dirs,$1),   next if $lib =~ /^-L(.*)/;
    push(@dirs,$lib), next if $lib =~ /[:>\]]$/;
    push(@dirs,$lib), next if -d $lib;
    push(@libs,$1),   next if $lib =~ /^-l(.*)/;
    push(@libs,$lib);
  }
  push(@dirs,split(' ',$Config{'libpth'}));

  # Now make sure we've got VMS-syntax absolute directory specs
  # (We don't, however, check whether someone's hidden a relative
  # path in a logical name.)
  foreach $dir (@dirs) {
    unless (-d $dir) {
      warn "Skipping nonexistent Directory $dir\n" if $verbose > 1;
      $dir = '';
      next;
    }
    warn "Resolving directory $dir\n" if $verbose;
    if ($self->file_name_is_absolute($dir)) { $dir = $self->fixpath($dir,1); }
    else                                    { $dir = $self->catdir($cwd,$dir); }
  }
  @dirs = grep { length($_) } @dirs;
  unshift(@dirs,''); # Check each $lib without additions first

  LIB: foreach $lib (@libs) {
    if (exists $libmap{$lib}) {
      next unless length $libmap{$lib};
      $lib = $libmap{$lib};
    }

    my(@variants,$variant,$name,$test,$cand);
    my($ctype) = '';

    # If we don't have a file type, consider it a possibly abbreviated name and
    # check for common variants.  We try these first to grab libraries before
    # a like-named executable image (e.g. -lperl resolves to perlshr.exe
    # before perl.exe).
    if ($lib !~ /\.[^:>\]]*$/) {
      push(@variants,"${lib}shr","${lib}rtl","${lib}lib");
      push(@variants,"lib$lib") if $lib !~ /[:>\]]/;
    }
    push(@variants,$lib);
    warn "Looking for $lib\n" if $verbose;
    foreach $variant (@variants) {
      foreach $dir (@dirs) {
        my($type);

        $name = "$dir$variant";
        warn "\tChecking $name\n" if $verbose > 2;
        if (-f ($test = VMS::Filespec::rmsexpand($name))) {
          # It's got its own suffix, so we'll have to figure out the type
          if    ($test =~ /(?:$so|exe)$/i)      { $type = 'SHR'; }
          elsif ($test =~ /(?:$lib_ext|olb)$/i) { $type = 'OLB'; }
          elsif ($test =~ /(?:$obj_ext|obj)$/i) {
            warn "Note (probably harmless): "
			 ."Plain object file $test found in library list\n";
            $type = 'OBJ';
          }
          else {
            warn "Note (probably harmless): "
			 ."Unknown library type for $test; assuming shared\n";
            $type = 'SHR';
          }
        }
        elsif (-f ($test = VMS::Filespec::rmsexpand($name,$so))      or
               -f ($test = VMS::Filespec::rmsexpand($name,'.exe')))     {
          $type = 'SHR';
          $name = $test unless $test =~ /exe;?\d*$/i;
        }
        elsif (not length($ctype) and  # If we've got a lib already, don't bother
               ( -f ($test = VMS::Filespec::rmsexpand($name,$lib_ext)) or
                 -f ($test = VMS::Filespec::rmsexpand($name,'.olb'))))  {
          $type = 'OLB';
          $name = $test unless $test =~ /olb;?\d*$/i;
        }
        elsif (not length($ctype) and  # If we've got a lib already, don't bother
               ( -f ($test = VMS::Filespec::rmsexpand($name,$obj_ext)) or
                 -f ($test = VMS::Filespec::rmsexpand($name,'.obj'))))  {
          warn "Note (probably harmless): "
		       ."Plain object file $test found in library list\n";
          $type = 'OBJ';
          $name = $test unless $test =~ /obj;?\d*$/i;
        }
        if (defined $type) {
          $ctype = $type; $cand = $name;
          last if $ctype eq 'SHR';
        }
      }
      if ($ctype) { 
        # This has to precede any other CRTLs, so just make it first
        if ($cand eq 'VAXCCURSE') { unshift @{$found{$ctype}}, $cand; }  
        else                      { push    @{$found{$ctype}}, $cand; }
        warn "\tFound as $cand (really $test), type $ctype\n" if $verbose > 1;
	push @flibs, $name unless $libs_seen{$fullname}++;
        next LIB;
      }
    }
    warn "Note (probably harmless): "
		 ."No library found for $lib\n";
  }

  push @fndlibs, @{$found{OBJ}}                      if exists $found{OBJ};
  push @fndlibs, map { "$_/Library" } @{$found{OLB}} if exists $found{OLB};
  push @fndlibs, map { "$_/Share"   } @{$found{SHR}} if exists $found{SHR};
  $lib = join(' ',@fndlibs);

  $ldlib = $crtlstr ? "$lib $crtlstr" : $lib;
  warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose;
  wantarray ? ($lib, '', $ldlib, '', ($give_libs ? \@flibs : ())) : $lib;
}

1;

__END__

=head1 NAME

ExtUtils::Liblist - determine libraries to use and how to use them

=head1 SYNOPSIS

C<require ExtUtils::Liblist;>

C<ExtUtils::Liblist::ext($self, $potential_libs, $verbose, $need_names);>

=head1 DESCRIPTION

This utility takes a list of libraries in the form C<-llib1 -llib2
-llib3> and returns lines suitable for inclusion in an extension
Makefile.  Extra library paths may be included with the form
C<-L/another/path> this will affect the searches for all subsequent
libraries.

It returns an array of four or five scalar values: EXTRALIBS,
BSLOADLIBS, LDLOADLIBS, LD_RUN_PATH, and, optionally, a reference to
the array of the filenames of actual libraries.  Some of these don't
mean anything unless on Unix.  See the details about those platform
specifics below.  The list of the filenames is returned only if
$need_names argument is true.

Dependent libraries can be linked in one of three ways:

=over 2

=item * For static extensions

by the ld command when the perl binary is linked with the extension
library. See EXTRALIBS below.

=item * For dynamic extensions

by the ld command when the shared object is built/linked. See
LDLOADLIBS below.

=item * For dynamic extensions

by the DynaLoader when the shared object is loaded. See BSLOADLIBS
below.

=back

=head2 EXTRALIBS

List of libraries that need to be linked with when linking a perl
binary which includes this extension. Only those libraries that
actually exist are included.  These are written to a file and used
when linking perl.

=head2 LDLOADLIBS and LD_RUN_PATH

List of those libraries which can or must be linked into the shared
library when created using ld. These may be static or dynamic
libraries.  LD_RUN_PATH is a colon separated list of the directories
in LDLOADLIBS. It is passed as an environment variable to the process
that links the shared library.

=head2 BSLOADLIBS

List of those libraries that are needed but can be linked in
dynamically at run time on this platform.  SunOS/Solaris does not need
this because ld records the information (from LDLOADLIBS) into the
object file.  This list is used to create a .bs (bootstrap) file.

=head1 PORTABILITY

This module deals with a lot of system dependencies and has quite a
few architecture specific C<if>s in the code.

=head2 VMS implementation

The version of ext() which is executed under VMS differs from the
Unix-OS/2 version in several respects:

=over 2

=item *

Input library and path specifications are accepted with or without the
C<-l> and C<-L> prefixes used by Unix linkers.  If neither prefix is
present, a token is considered a directory to search if it is in fact
a directory, and a library to search for otherwise.  Authors who wish
their extensions to be portable to Unix or OS/2 should use the Unix
prefixes, since the Unix-OS/2 version of ext() requires them.

=item *

Wherever possible, shareable images are preferred to object libraries,
and object libraries to plain object files.  In accordance with VMS
naming conventions, ext() looks for files named I<lib>shr and I<lib>rtl;
it also looks for I<lib>lib and libI<lib> to accommodate Unix conventions
used in some ported software.

=item *

For each library that is found, an appropriate directive for a linker options
file is generated.  The return values are space-separated strings of
these directives, rather than elements used on the linker command line.

=item *

LDLOADLIBS contains both the libraries found based on C<$potential_libs> and
the CRTLs, if any, specified in Config.pm.  EXTRALIBS contains just those
libraries found based on C<$potential_libs>.  BSLOADLIBS and LD_RUN_PATH
are always empty.

=back

In addition, an attempt is made to recognize several common Unix library
names, and filter them out or convert them to their VMS equivalents, as
appropriate.

In general, the VMS version of ext() should properly handle input from
extensions originally designed for a Unix or VMS environment.  If you
encounter problems, or discover cases where the search could be improved,
please let us know.

=head2 Win32 implementation

The version of ext() which is executed under Win32 differs from the
Unix-OS/2 version in several respects:

=over 2

=item *

If C<$potential_libs> is empty, the return value will be empty.
Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
will be appended to the list of C<$potential_libs>.  The libraries
will be searched for in the directories specified in C<$potential_libs>,
C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>.
For each library that is found,  a space-separated list of fully qualified
library pathnames is generated.

=item *

Input library and path specifications are accepted with or without the
C<-l> and C<-L> prefixes used by Unix linkers.

An entry of the form C<-La:\foo> specifies the C<a:\foo> directory to look
for the libraries that follow.

An entry of the form C<-lfoo> specifies the library C<foo>, which may be
spelled differently depending on what kind of compiler you are using.  If
you are using GCC, it gets translated to C<libfoo.a>, but for other win32
compilers, it becomes C<foo.lib>.  If no files are found by those translated
names, one more attempt is made to find them using either C<foo.a> or
C<libfoo.lib>, depending on whether GCC or some other win32 compiler is
being used, respectively.

If neither the C<-L> or C<-l> prefix is present in an entry, the entry is
considered a directory to search if it is in fact a directory, and a
library to search for otherwise.  The C<$Config{lib_ext}> suffix will
be appended to any entries that are not directories and don't already have
the suffix.

Note that the C<-L> and C<-l> prefixes are B<not required>, but authors
who wish their extensions to be portable to Unix or OS/2 should use the
prefixes, since the Unix-OS/2 version of ext() requires them.

=item *

Entries cannot be plain object files, as many Win32 compilers will
not handle object files in the place of libraries.

=item *

Entries in C<$potential_libs> beginning with a colon and followed by
alphanumeric characters are treated as flags.  Unknown flags will be ignored.

An entry that matches C</:nodefault/i> disables the appending of default
libraries found in C<$Config{perllibs}> (this should be only needed very rarely).

An entry that matches C</:nosearch/i> disables all searching for
the libraries specified after it.  Translation of C<-Lfoo> and
C<-lfoo> still happens as appropriate (depending on compiler being used,
as reflected by C<$Config{cc}>), but the entries are not verified to be
valid files or directories.

An entry that matches C</:search/i> reenables searching for
the libraries specified after it.  You can put it at the end to
enable searching for default libraries specified by C<$Config{perllibs}>.

=item *

The libraries specified may be a mixture of static libraries and
import libraries (to link with DLLs).  Since both kinds are used
pretty transparently on the Win32 platform, we do not attempt to
distinguish between them.

=item *

LDLOADLIBS and EXTRALIBS are always identical under Win32, and BSLOADLIBS
and LD_RUN_PATH are always empty (this may change in future).

=item *

You must make sure that any paths and path components are properly
surrounded with double-quotes if they contain spaces. For example,
C<$potential_libs> could be (literally):

	"-Lc:\Program Files\vc\lib" msvcrt.lib "la test\foo bar.lib"

Note how the first and last entries are protected by quotes in order
to protect the spaces.

=item *

Since this module is most often used only indirectly from extension
C<Makefile.PL> files, here is an example C<Makefile.PL> entry to add
a library to the build process for an extension:

        LIBS => ['-lgl']

When using GCC, that entry specifies that MakeMaker should first look
for C<libgl.a> (followed by C<gl.a>) in all the locations specified by
C<$Config{libpth}>.

When using a compiler other than GCC, the above entry will search for
C<gl.lib> (followed by C<libgl.lib>).

If the library happens to be in a location not in C<$Config{libpth}>,
you need:

        LIBS => ['-Lc:\gllibs -lgl']

Here is a less often used example:

        LIBS => ['-lgl', ':nosearch -Ld:\mesalibs -lmesa -luser32']

This specifies a search for library C<gl> as before.  If that search
fails to find the library, it looks at the next item in the list. The
C<:nosearch> flag will prevent searching for the libraries that follow,
so it simply returns the value as C<-Ld:\mesalibs -lmesa -luser32>,
since GCC can use that value as is with its linker.

When using the Visual C compiler, the second item is returned as
C<-libpath:d:\mesalibs mesa.lib user32.lib>.

When using the Borland compiler, the second item is returned as
C<-Ld:\mesalibs mesa.lib user32.lib>, and MakeMaker takes care of
moving the C<-Ld:\mesalibs> to the correct place in the linker
command line.

=back


=head1 SEE ALSO

L<ExtUtils::MakeMaker>

=cut

fh->open(">$configpmtest")) {
		    $fh->print("1;\n");
		    $configpm = $configpmtest;
		} else {
		    # Should never happen
		    Carp::confess("Cannot open >$configpmtest");
		}
	    } else {
		Carp::confess(qq{WARNING: CPAN.pm is unable to }.
			      qq{create a configuration file.});
	    }
	}
    }
    local($") = ", ";
    $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
We have to reconfigure CPAN.pm due to followi                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                BEGIN {require 5.002;} # MakeMaker 5.17 was the last MakeMaker that was compatible with perl5.001m

package ExtUtils::MakeMaker;

$VERSION = "5.45";
$Version_OK = "5.17";	# Makefiles older than $Version_OK will die
			# (Will be checked from MakeMaker version 4.13 onwards)
($Revision = substr(q$Revision: 1.222 $, 10)) =~ s/\s+$//;



require Exporter;
use Config;
use Carp ();
#use FileHandle ();

use vars qw(

	    @ISA @EXPORT @EXPORT_OK $AUTOLOAD
	    $ISA_TTY $Is_Mac $Is_OS2 $Is_VMS $Revision
	    $VERSION $Verbose $Version_OK %Config %Keep_after_flush
	    %MM_Sections %Prepend_dot_dot %Recognized_Att_Keys
	    @Get_from_Config @MM_Sections @Overridable @Parent

	   );
# use strict;

# &DynaLoader::mod2fname should be available to miniperl, thus 
# should be a pseudo-builtin (cmp. os2.c).
#eval {require DynaLoader;};

#
# Set up the inheritance before we pull in the MM_* packages, because they
# import variables and functions from here
#
@ISA = qw(Exporter);
@EXPORT = qw(&WriteMakefile &writeMakefile $Verbose &prompt);
@EXPORT_OK = qw($VERSION &Version_check &neatvalue &mkbootstrap &mksymlists);

#
# Dummy package MM inherits actual methods from OS-specific
# default packages.  We use this intermediate package so
# MY::XYZ->func() can call MM->func() and get the proper
# default routine without having to know under what OS
# it's running.
#
@MM::ISA = qw[ExtUtils::MM_Unix ExtUtils::Liblist::Kid ExtUtils::MakeMaker];

#
# Setup dummy package:
# MY exists for overriding methods to be defined within
#
{
    package MY;
    @MY::ISA = qw(MM);
###    sub AUTOLOAD { use Devel::Symdump; print Devel::Symdump->rnew->as_string; Carp::confess "hey why? $AUTOLOAD" }
    package MM;
    sub DESTROY {}
}

# "predeclare the package: we only load it via AUTOLOAD
# but we have already mentioned it in @ISA
package ExtUtils::Liblist::Kid;

package ExtUtils::MakeMaker;
#
# Now we can pull in the friends
#
$Is_VMS   = $^O eq 'VMS';
$Is_OS2   = $^O eq 'os2';
$Is_Mac   = $^O eq 'MacOS';
$Is_Win32 = $^O eq 'MSWin32';
$Is_Cygwin= $^O eq 'cygwin';

require ExtUtils::MM_Unix;

if ($Is_VMS) {
    require ExtUtils::MM_VMS;
    require VMS::Filespec; # is a noop as long as we require it within MM_VMS
}
if ($Is_OS2) {
    require ExtUtils::MM_OS2;
}
if ($Is_Mac) {
    require ExtUtils::MM_MacOS;
}
if ($Is_Win32) {
    require ExtUtils::MM_Win32;
}
if ($Is_Cygwin) {
    require ExtUtils::MM_Cygwin;
}

full_setup();

# The use of the Version_check target has been dropped between perl
# 5.5.63 and 5.5.64. We must keep the subroutine for a while so that
# old Makefiles can satisfy the Version_check target.

sub Version_check {
    my($checkversion) = @_;
    die "Your Makefile was built with ExtUtils::MakeMaker v $checkversion.
Current Version is $ExtUtils::MakeMaker::VERSION. There have been considerable
changes in the meantime.
Please rerun 'perl Makefile.PL' to regenerate the Makefile.\n"
    if $checkversion < $Version_OK;
    printf STDOUT "%s %s %s %s.\n", "Makefile built with ExtUtils::MakeMaker v",
    $checkversion, "Current Version is", $VERSION
	unless $checkversion == $VERSION;
}

sub warnhandler {
    $_[0] =~ /^Use of uninitialized value/ && return;
    $_[0] =~ /used only once/ && return;
    $_[0] =~ /^Subroutine\s+[\w:]+\s+redefined/ && return;
    warn @_;
}

sub WriteMakefile {
    Carp::croak "WriteMakefile: Need even number of args" if @_ % 2;
    local $SIG{__WARN__} = \&warnhandler;

    my %att = @_;
    MM->new(\%att)->flush;
}

sub prompt ($;$) {
    my($mess,$def)=@_;
    $ISA_TTY = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ;	# Pipe?
    Carp::confess("prompt function called without an argument") unless defined $mess;
    my $dispdef = defined $def ? "[$def] " : " ";
    $def = defined $def ? $def : "";
    my $ans;
    local $|=1;
    print "$mess $dispdef";
    if ($ISA_TTY) {
	chomp($ans = <STDIN>);
    } else {
	print "$def\n";
    }
    return ($ans ne '') ? $ans : $def;
}

sub eval_in_subdirs {
    my($self) = @_;
    my($dir);
    use Cwd 'cwd';
    my $pwd = cwd();

    foreach $dir (@{$self->{DIR}}){
	my($abs) = $self->catdir($pwd,$dir);
	$self->eval_in_x($abs);
    }
    chdir $pwd;
}

sub eval_in_x {
    my($self,$dir) = @_;
    package main;
    chdir $dir or Carp::carp("Couldn't change to directory $dir: $!");
#    use FileHandle ();
#    my $fh = new FileHandle;
#    $fh->open("Makefile.PL") or Carp::carp("Couldn't open Makefile.PL in $dir");
    local *FH;
    open(FH,"Makefile.PL") or Carp::carp("Couldn't open Makefile.PL in $dir");
#    my $eval = join "", <$fh>;
    my $eval = join "", <FH>;
#    $fh->close;
    close FH;
    eval $eval;
    if ($@) {
# 	  if ($@ =~ /prerequisites/) {
# 	      die "MakeMaker WARNING: $@";
# 	  } else {
# 	      warn "WARNING from evaluation of $dir/Makefile.PL: $@";
# 	  }
	warn "WARNING from evaluation of $dir/Makefile.PL: $@";
    }
}

sub full_setup {
    $Verbose ||= 0;

    # package name for the classes into which the first object will be blessed
    $PACKNAME = "PACK000";

    @Attrib_help = qw/

    AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION
    C CAPI CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DL_FUNCS DL_VARS
    EXCLUDE_EXT EXE_FILES FIRST_MAKEFILE FULLPERL FUNCLIST H 
    HTMLLIBPODS HTMLSCRIPTPODS IMPORTS
    INC INCLUDE_EXT INSTALLARCHLIB INSTALLBIN INSTALLDIRS INSTALLHTMLPRIVLIBDIR
    INSTALLHTMLSCRIPTDIR INSTALLHTMLSITELIBDIR INSTALLMAN1DIR
    INSTALLMAN3DIR INSTALLPRIVLIB INSTALLSCRIPT INSTALLSITEARCH
    INSTALLSITELIB INST_ARCHLIB INST_BIN INST_EXE INST_LIB
    INST_HTMLLIBDIR INST_HTMLSCRIPTDIR
    INST_MAN1DIR INST_MAN3DIR INST_SCRIPT LDFROM LIB LIBPERL_A LIBS
    LINKTYPE MAKEAPERL MAKEFILE MAN1PODS MAN3PODS MAP_TARGET MYEXTLIB
    PERL_MALLOC_OK
    NAME NEEDS_LINKING NOECHO NORECURS NO_VC OBJECT OPTIMIZE PERL PERLMAINCC
    PERL_ARCHLIB PERL_LIB PERL_SRC PERM_RW PERM_RWX
    PL_FILES PM PM_FILTER PMLIBDIRS POLLUTE PPM_INSTALL_EXEC
	PPM_INSTALL_SCRIPT PREFIX
    PREREQ_PM SKIP TYPEMAPS VERSION VERSION_FROM XS XSOPT XSPROTOARG
    XS_VERSION clean depend dist dynamic_lib linkext macro realclean
    tool_autosplit

    MACPERL_SRC MACPERL_LIB MACLIBS_68K MACLIBS_PPC MACLIBS_SC MACLIBS_MRC
    MACLIBS_ALL_68K MACLIBS_ALL_PPC MACLIBS_SHARED
	/;

    # IMPORTS is used under OS/2 and Win32

    # @Overridable is close to @MM_Sections but not identical.  The
    # order is important. Many subroutines declare macros. These
    # depend on each other. Let's try to collect the macros up front,
    # then pasthru, then the rules.

    # MM_Sections are the sections we have to call explicitly
    # in Overridable we have subroutines that are used indirectly


    @MM_Sections = 
	qw(

 post_initialize const_config constants tool_autosplit tool_xsubpp
 tools_other dist macro depend cflags const_loadlibs const_cccmd
 post_constants

 pasthru

 c_o xs_c xs_o top_targets linkext dlsyms dynamic dynamic_bs
 dynamic_lib static static_lib htmlifypods manifypods processPL
 installbin subdirs
 clean realclean dist_basics dist_core dist_dir dist_test dist_ci
 install force perldepend makefile staticmake test ppd

	  ); # loses section ordering

    @Overridable = @MM_Sections;
    push @Overridable, qw[

 dir_target libscan makeaperl needs_linking perm_rw perm_rwx
 subdir_x test_via_harness test_via_script
			 ];

    push @MM_Sections, qw[

 pm_to_blib selfdocument

			 ];

    # Postamble needs to be the last that was always the case
    push @MM_Sections, "postamble";
    push @Overridable, "postamble";

    # All sections are valid keys.
    @Recognized_Att_Keys{@MM_Sections} = (1) x @MM_Sections;

    # we will use all these variables in the Makefile
    @Get_from_Config = 
	qw(
	   ar cc cccdlflags ccdlflags dlext dlsrc ld lddlflags ldflags libc
	   lib_ext obj_ext osname osvers ranlib sitelibexp sitearchexp so
	   exe_ext full_ar
	  );

    my $item;
    foreach $item (@Attrib_help){
	$Recognized_Att_Keys{$item} = 1;
    }
    foreach $item (@Get_from_Config) {
	$Recognized_Att_Keys{uc $item} = $Config{$item};
	print "Attribute '\U$item\E' => '$Config{$item}'\n"
	    if ($Verbose >= 2);
    }

    #
    # When we eval a Makefile.PL in a subdirectory, that one will ask
    # us (the parent) for the values and will prepend "..", so that
    # all files to be installed end up below OUR ./blib
    #
    %Prepend_dot_dot = 
	qw(

	   INST_BIN 1 INST_EXE 1 INST_LIB 1 INST_ARCHLIB 1 INST_SCRIPT 1
	   MAP_TARGET 1 INST_HTMLLIBDIR 1 INST_HTMLSCRIPTDIR 1 
	   INST_MAN1DIR 1 INST_MAN3DIR 1 PERL_SRC 1 PERL 1 FULLPERL 1

	  );

    my @keep = qw/
	NEEDS_LINKING HAS_LINK_CODE
	/;
    @Keep_after_flush{@keep} = (1) x @keep;
}

sub writeMakefile {
    die <<END;

The extension you are trying to build apparently is rather old and
most probably outdated. We detect that from the fact, that a
subroutine "writeMakefile" is called, and this subroutine is not
supported anymore since about October 1994.

Please contact the author or look into CPAN (details about CPAN can be
found in the FAQ and at http:/www.perl.com) for a more recent version
of the extension. If you're really desperate, you can try to change
the subroutine name from writeMakefile to WriteMakefile and rerun
'perl Makefile.PL', but you're most probably left alone, when you do
so.

The MakeMaker team

END
}

sub ExtUtils::MakeMaker::new {
    my($class,$self) = @_;
    my($key);

    print STDOUT "MakeMaker (v$VERSION)\n" if $Verbose;
    if (-f "MANIFEST" && ! -f "Makefile"){
	check_manifest();
    }

    $self = {} unless (defined $self);

    check_hints($self);

    my(%initial_att) = %$self; # record initial attributes

    my($prereq);
    foreach $prereq (sort keys %{$self->{PREREQ_PM}}) {
	my $eval = "require $prereq";
	eval $eval;

	if ($@) {
	    warn "Warning: prerequisite $prereq failed to load: $@";
	}
	elsif ($prereq->VERSION < $self->{PREREQ_PM}->{$prereq} ){
	    warn "Warning: prerequisite $prereq $self->{PREREQ_PM}->{$prereq} not found";
# Why is/was this 'delete' here?  We need PREREQ_PM later to make PPDs.
#	} else {
#	    delete $self->{PREREQ_PM}{$prereq};
	}
    }
#    if (@unsatisfied){
# 	  unless (defined $ExtUtils::MakeMaker::useCPAN) {
# 	      print qq{MakeMaker WARNING: prerequisites not found (@unsatisfied)
# Please install these modules first and rerun 'perl Makefile.PL'.\n};
# 	      if ($ExtUtils::MakeMaker::hasCPAN) {
# 		  $ExtUtils::MakeMaker::useCPAN = prompt(qq{Should I try to use the CPAN module to fetch them for you?},"yes");
# 	      } else {
# 		  print qq{Hint: You may want to install the CPAN module to autofetch the needed modules\n};
# 		  $ExtUtils::MakeMaker::useCPAN=0;
# 	      }
# 	  }
# 	  if ($ExtUtils::MakeMaker::useCPAN) {
# 	      require CPAN;
# 	      CPAN->import(@unsatisfied);
# 	  } else {
# 	      die qq{prerequisites not found (@unsatisfied)};
# 	  }
#	warn qq{WARNING: prerequisites not found (@unsatisfied)};
#    }

    if (defined $self->{CONFIGURE}) {
	if (ref $self->{CONFIGURE} eq 'CODE') {
	    $self = { %$self, %{&{$self->{CONFIGURE}}}};
	} else {
	    Carp::croak "Attribute 'CONFIGURE' to WriteMakefile() not a code reference\n";
	}
    }

    # This is for old Makefiles written pre 5.00, will go away
    if ( Carp::longmess("") =~ /runsubdirpl/s ){
	Carp::carp("WARNING: Please rerun 'perl Makefile.PL' to regenerate your Makefiles\n");
    }

    my $newclass = ++$PACKNAME;
    local @Parent = @Parent;	# Protect against non-local exits
    {
#	no strict;
	print "Blessing Object into class [$newclass]\n" if $Verbose>=2;
	mv_all_methods("MY",$newclass);
	bless $self, $newclass;
	push @Parent, $self;
	@{"$newclass\:\:ISA"} = 'MM';
    }

    if (defined $Parent[-2]){
	$self->{PARENT} = $Parent[-2];
	my $key;
	for $key (keys %Prepend_dot_dot) {
	    next unless defined $self->{PARENT}{$key};
	    $self->{$key} = $self->{PARENT}{$key};
		# PERL and FULLPERL may be command verbs instead of full
		# file specifications under VMS.  If so, don't turn them
		# into a filespec.
	    $self->{$key} = $self->catdir("..",$self->{$key})
		unless $self->file_name_is_absolute($self->{$key})
		|| ($^O eq 'VMS' and ($key =~ /PERL$/ && $self->{$key} =~ /^[\w\-\$]+$/));
	}
	if ($self->{PARENT}) {
	    $self->{PARENT}->{CHILDREN}->{$newclass} = $self;
	    foreach my $opt (qw(CAPI POLLUTE)) {
		if (exists $self->{PARENT}->{$opt}
		    and not exists $self->{$opt})
		    {
			# inherit, but only if already unspecified
			$self->{$opt} = $self->{PARENT}->{$opt};
		    }
	    }
	}
    } else {
	parse_args($self,split(' ', $ENV{PERL_MM_OPT} || ''),@ARGV);
    }

    $self->{NAME} ||= $self->guess_name;

    ($self->{NAME_SYM} = $self->{NAME}) =~ s/\W+/_/g;

    $self->init_main();

    if (! $self->{PERL_SRC} ) {
	my($pthinks) = $self->canonpath($INC{'Config.pm'});
	my($cthinks) = $self->catfile($Config{'archlibexp'},'Config.pm');
	$pthinks = VMS::Filespec::vmsify($pthinks) if $Is_VMS;
	if ($pthinks ne $cthinks &&
	    !($Is_Win32 and lc($pthinks) eq lc($cthinks))) {
            print "Have $pthinks expected $cthinks\n";
	    if ($Is_Win32) {
		$pthinks =~ s![/\\]Config\.pm$!!i; $pthinks =~ s!.*[/\\]!!;
	    }
	    else {
		$pthinks =~ s!/Config\.pm$!!; $pthinks =~ s!.*/!!;
	    }
	    print STDOUT <<END unless $self->{UNINSTALLED_PERL};
Your perl and your Config.pm seem to have different ideas about the architecture
they are running on.
Perl thinks: [$pthinks]
Config says: [$Config{archname}]
This may or may not cause problems. Please check your installation of perl if you
have problems building this extension.
END
	}
    }

    $self->init_dirscan();
    $self->init_others();
    my($argv) = neatvalue(\@ARGV);
    $argv =~ s/^\[/(/;
    $argv =~ s/\]$/)/;

    push @{$self->{RESULT}}, <<END;
# This Makefile is for the $self->{NAME} extension to perl.
#
# It was generated automatically by MakeMaker version
# $VERSION (Revision: $Revision) from the contents of
# Makefile.PL. Don't edit this file, edit Makefile.PL instead.
#
#	ANY CHANGES MADE HERE WILL BE LOST!
#
#   MakeMaker ARGV: $argv
#
#   MakeMaker Parameters:
END

    foreach $key (sort keys %initial_att){
	my($v) = neatvalue($initial_att{$key});
	$v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/;
	$v =~ tr/\n/ /s;
	push @{$self->{RESULT}}, "#	$key => $v";
    }

    # turn the SKIP array into a SKIPHASH hash
    my (%skip,$skip);
    for $skip (@{$self->{SKIP} || []}) {
	$self->{SKIPHASH}{$skip} = 1;
    }
    delete $self->{SKIP}; # free memory

    if ($self->{PARENT}) {
	for (qw/install dist dist_basics dist_core dist_dir dist_test dist_ci/) {
	    $self->{SKIPHASH}{$_} = 1;
	}
    }

    # We run all the subdirectories now. They don't have much to query
    # from the parent, but the parent has to query them: if they need linking!
    unless ($self->{NORECURS}) {
	$self->eval_in_subdirs if @{$self->{DIR}};
    }

    my $section;
    foreach $section ( @MM_Sections ){
	print "Processing Makefile '$section' section\n" if ($Verbose >= 2);
	my($skipit) = $self->skipcheck($section);
	if ($skipit){
	    push @{$self->{RESULT}}, "\n# --- MakeMaker $section section $skipit.";
	} else {
	    my(%a) = %{$self->{$section} || {}};
	    push @{$self->{RESULT}}, "\n# --- MakeMaker $section section:";
	    push @{$self->{RESULT}}, "# " . join ", ", %a if $Verbose && %a;
	    push @{$self->{RESULT}}, $self->nicetext($self->$section( %a ));
	}
    }

    push @{$self->{RESULT}}, "\n# End.";

    $self;
}

sub WriteEmptyMakefile {
  if (-f 'Makefile.old') {
    chmod 0666, 'Makefile.old';
    unlink 'Makefile.old' or warn "unlink Makefile.old: $!";
  }
  rename 'Makefile', 'Makefile.old' or warn "rename Makefile Makefile.old: $!"
    if -f 'Makefile';
  open MF, '> Makefile' or die "open Makefile for write: $!";
  print MF <<'EOP';
all:

clean:

install:

makemakerdflt:

test:

EOP
  close MF or die "close Makefile for write: $!";
}

sub check_manifest {
    print STDOUT "Checking if your kit is complete...\n";
    require ExtUtils::Manifest;
    $ExtUtils::Manifest::Quiet=$ExtUtils::Manifest::Quiet=1; #avoid warning
    my(@missed)=ExtUtils::Manifest::manicheck();
    if (@missed){
	print STDOUT "Warning: the following files are missing in your kit:\n";
	print "\t", join "\n\t", @missed;
	print STDOUT "\n";
	print STDOUT "Please inform the author.\n";
    } else {
	print STDOUT "Looks good\n";
    }
}

sub parse_args{
    my($self, @args) = @_;
    foreach (@args){
	unless (m/(.*?)=(.*)/){
	    help(),exit 1 if m/^help$/;
	    ++$Verbose if m/^verb/;
	    next;
	}
	my($name, $value) = ($1, $2);
	if ($value =~ m/^~(\w+)?/){ # tilde with optional username
	    $value =~ s [^~(\w*)]
		[$1 ?
		 ((getpwnam($1))[7] || "~$1") :
		 (getpwuid($>))[7]
		 ]ex;
	}
	$self->{uc($name)} = $value;
    }

    # catch old-style 'potential_libs' and inform user how to 'upgrade'
    if (defined $self->{potential_libs}){
	my($msg)="'potential_libs' => '$self->{potential_libs}' should be";
	if ($self->{potential_libs}){
	    print STDOUT "$msg changed to:\n\t'LIBS' => ['$self->{potential_libs}']\n";
	} else {
	    print STDOUT "$msg deleted.\n";
	}
	$self->{LIBS} = [$self->{potential_libs}];
	delete $self->{potential_libs};
    }
    # catch old-style 'ARMAYBE' and inform user how to 'upgrade'
    if (defined $self->{ARMAYBE}){
	my($armaybe) = $self->{ARMAYBE};
	print STDOUT "ARMAYBE => '$armaybe' should be changed to:\n",
			"\t'dynamic_lib' => {ARMAYBE => '$armaybe'}\n";
	my(%dl) = %{$self->{dynamic_lib} || {}};
	$self->{dynamic_lib} = { %dl, ARMAYBE => $armaybe};
	delete $self->{ARMAYBE};
    }
    if (defined $self->{LDTARGET}){
	print STDOUT "LDTARGET should be changed to LDFROM\n";
	$self->{LDFROM} = $self->{LDTARGET};
	delete $self->{LDTARGET};
    }
    # Turn a DIR argument on the command line into an array
    if (defined $self->{DIR} && ref \$self->{DIR} eq 'SCALAR') {
	# So they can choose from the command line, which extensions they want
	# the grep enables them to have some colons too much in case they
	# have to build a list with the shell
	$self->{DIR} = [grep $_, split ":", $self->{DIR}];
    }
    # Turn a INCLUDE_EXT argument on the command line into an array
    if (defined $self->{INCLUDE_EXT} && ref \$self->{INCLUDE_EXT} eq 'SCALAR') {
	$self->{INCLUDE_EXT} = [grep $_, split '\s+', $self->{INCLUDE_EXT}];
    }
    # Turn a EXCLUDE_EXT argument on the command line into an array
    if (defined $self->{EXCLUDE_EXT} && ref \$self->{EXCLUDE_EXT} eq 'SCALAR') {
	$self->{EXCLUDE_EXT} = [grep $_, split '\s+', $self->{EXCLUDE_EXT}];
    }
    my $mmkey;
    foreach $mmkey (sort keys %$self){
	print STDOUT "	$mmkey => ", neatvalue($self->{$mmkey}), "\n" if $Verbose;
	print STDOUT "'$mmkey' is not a known MakeMaker parameter name.\n"
	    unless exists $Recognized_Att_Keys{$mmkey};
    }
    $| = 1 if $Verbose;
}

sub check_hints {
    my($self) = @_;
    # We allow extension-specific hints files.

    return unless -d "hints";

    # First we look for the best hintsfile we have
    my(@goodhints);
    my($hint)="${^O}_$Config{osvers}";
    $hint =~ s/\./_/g;
    $hint =~ s/_$//;
    return unless $hint;

    # Also try without trailing minor version numbers.
    while (1) {
	last if -f "hints/$hint.pl";      # found
    } continue {
	last unless $hint =~ s/_[^_]*$//; # nothing to cut off
    }
    return unless -f "hints/$hint.pl";    # really there

    # execute the hintsfile:
#    use FileHandle ();
#    my $fh = new FileHandle;
#    $fh->open("hints/$hint.pl");
    local *FH;
    open(FH,"hints/$hint.pl");
#    @goodhints = <$fh>;
    @goodhints = <FH>;
#    $fh->close;
    close FH;
    print STDOUT "Processing hints file hints/$hint.pl\n";
    eval join('',@goodhints);
    print STDOUT $@ if $@;
}

sub mv_all_methods {
    my($from,$to) = @_;
    my($method);
    my($symtab) = \%{"${from}::"};
#    no strict;

    # Here you see the *current* list of methods that are overridable
    # from Makefile.PL via MY:: subroutines. As of VERSION 5.07 I'm
    # still trying to reduce the list to some reasonable minimum --
    # because I want to make it easier for the user. A.K.

    foreach $method (@Overridable) {

	# We cannot say "next" here. Nick might call MY->makeaperl
	# which isn't defined right now

	# Above statement was written at 4.23 time when Tk-b8 was
	# around. As Tk-b9 only builds with 5.002something and MM 5 is
	# standard, we try to enable the next line again. It was
	# commented out until MM 5.23

	next unless defined &{"${from}::$method"};

	*{"${to}::$method"} = \&{"${from}::$method"};

	# delete would do, if we were sure, nobody ever called
	# MY->makeaperl directly
	
	# delete $symtab->{$method};
	
	# If we delete a method, then it will be undefined and cannot
	# be called.  But as long as we have Makefile.PLs that rely on
	# %MY:: being intact, we have to fill the hole with an
	# inheriting method:

	eval "package MY; sub $method { shift->SUPER::$method(\@_); }";
    }

    # We have to clean out %INC also, because the current directory is
    # changed frequently and Graham Barr prefers to get his version
    # out of a History.pl file which is "required" so woudn't get
    # loaded again in another extension requiring a History.pl

    # With perl5.002_01 the deletion of entries in %INC caused Tk-b11
    # to core dump in the middle of a require statement. The required
    # file was Tk/MMutil.pm.  The consequence is, we have to be
    # extremely careful when we try to give perl a reason to reload a
    # library with same name.  The workaround prefers to drop nothing
    # from %INC and teach the writers not to use such libraries.

#    my $inc;
#    foreach $inc (keys %INC) {
#	#warn "***$inc*** deleted";
#	delete $INC{$inc};
#    }
}

sub skipcheck {
    my($self) = shift;
    my($section) = @_;
    if ($section eq 'dynamic') {
	print STDOUT "Warning (non-fatal): Target 'dynamic' depends on targets ",
	"in skipped section 'dynamic_bs'\n"
            if $self->{SKIPHASH}{dynamic_bs} && $Verbose;
        print STDOUT "Warning (non-fatal): Target 'dynamic' depends on targets ",
	"in skipped section 'dynamic_lib'\n"
            if $self->{SKIPHASH}{dynamic_lib} && $Verbose;
    }
    if ($section eq 'dynamic_lib') {
        print STDOUT "Warning (non-fatal): Target '\$(INST_DYNAMIC)' depends on ",
	"targets in skipped section 'dynamic_bs'\n"
            if $self->{SKIPHASH}{dynamic_bs} && $Verbose;
    }
    if ($section eq 'static') {
        print STDOUT "Warning (non-fatal): Target 'static' depends on targets ",
	"in skipped section 'static_lib'\n"
            if $self->{SKIPHASH}{static_lib} && $Verbose;
    }
    return 'skipped' if $self->{SKIPHASH}{$section};
    return '';
}

sub flush {
    my $self = shift;
    my($chunk);
#    use FileHandle ();
#    my $fh = new FileHandle;
    local *FH;
    print STDOUT "Writing $self->{MAKEFILE} for $self->{NAME}\n";

    unlink($self->{MAKEFILE}, "MakeMaker.tmp", $Is_VMS ? 'Descrip.MMS' : '');
#    $fh->open(">MakeMaker.tmp") or die "Unable to open MakeMaker.tmp: $!";
    open(FH,">MakeMaker.tmp") or die "Unable to open MakeMaker.tmp: $!";

    for $chunk (@{$self->{RESULT}}) {
#	print $fh "$chunk\n";
	print FH "$chunk\n";
    }

#    $fh->close;
    close FH;
    my($finalname) = $self->{MAKEFILE};
    rename("MakeMaker.tmp", $finalname);
    chmod 0644, $finalname unless $Is_VMS;

    if ($self->{PARENT}) {
	foreach (keys %$self) { # safe memory
	    delete $self->{$_} unless $Keep_after_flush{$_};
	}
    }

    system("$Config::Config{eunicefix} $finalname") unless $Config::Config{eunicefix} eq ":";
}

# The following mkbootstrap() is only for installations that are calling
# the pre-4.1 mkbootstrap() from their old Makefiles. This MakeMaker
# writes Makefiles, that use ExtUtils::Mkbootstrap directly.
sub mkbootstrap {
    die <<END;
!!! Your Makefile has been built such a long time ago, !!!
!!! that is unlikely to work with current MakeMaker.   !!!
!!! Please rebuild your Makefile                       !!!
END
}

# Ditto for mksymlists() as of MakeMaker 5.17
sub mksymlists {
    die <<END;
!!! Your Makefile has been built such a long time ago, !!!
!!! that is unlikely to work with current MakeMaker.   !!!
!!! Please rebuild your Makefile                       !!!
END
}

sub neatvalue {
    my($v) = @_;
    return "undef" unless defined $v;
    my($t) = ref $v;
    return "q[$v]" unless $t;
    if ($t eq 'ARRAY') {
	my(@m, $elem, @neat);
	push @m, "[";
	foreach $elem (@$v) {
	    push @neat, "q[$elem]";
	}
	push @m, join ", ", @neat;
	push @m, "]";
	return join "", @m;
    }
    return "$v" unless $t eq 'HASH';
    my(@m, $key, $val);
    while (($key,$val) = each %$v){
	last unless defined $key; # cautious programming in case (undef,undef) is true
	push(@m,"$key=>".neatvalue($val)) ;
    }
    return "{ ".join(', ',@m)." }";
}

sub selfdocument {
    my($self) = @_;
    my(@m);
    if ($Verbose){
	push @m, "\n# Full list of MakeMaker attribute values:";
	foreach $key (sort keys %$self){
	    next if $key eq 'RESULT' || $key =~ /^[A-Z][a-z]/;
	    my($v) = neatvalue($self->{$key});
	    $v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/;
	    $v =~ tr/\n/ /s;
	    push @m, "#	$key => $v";
	}
    }
    join "\n", @m;
}

package ExtUtils::MakeMaker;
1;

__END__

=head1 NAME

ExtUtils::MakeMaker - create an extension Makefile

=head1 SYNOPSIS

C<use ExtUtils::MakeMaker;>

C<WriteMakefile( ATTRIBUTE =E<gt> VALUE [, ...] );>

which is really

C<MM-E<gt>new(\%att)-E<gt>flush;>

=head1 DESCRIPTION

This utility is designed to write a Makefile for an extension module
from a Makefile.PL. It is based on the Makefile.SH model provided by
Andy Dougherty and the perl5-porters.

It splits the task of generating the Makefile into several subroutines
that can be individually overridden.  Each subroutine returns the text
it wishes to have written to the Makefile.

MakeMaker is object oriented. Each directory below the current
directory that contains a Makefile.PL. Is treated as a separate
object. This makes it possible to write an unlimited number of
Makefiles with a single invocation of WriteMakefile().

=head2 How To Write A Makefile.PL

The short answer is: Don't.

        Always begin with h2xs.
        Always begin with h2xs!
        ALWAYS BEGIN WITH H2XS!

even if you're not building around a header file, and even if you
don't have an XS component.

Run h2xs(1) before you start thinking about writing a module. For so
called pm-only modules that consist of C<*.pm> files only, h2xs has
the C<-X> switch. This will generate dummy files of all kinds that are
useful for the module developer.

The medium answer is:

    use ExtUtils::MakeMaker;
    WriteMakefile( NAME => "Foo::Bar" );

The long answer is the rest of the manpage :-)

=head2 Default Makefile Behaviour

The generated Makefile enables the user of the extension to invoke

  perl Makefile.PL # optionally "perl Makefile.PL verbose"
  make
  make test        # optionally set TEST_VERBOSE=1
  make install     # See below

The Makefile to be produced may be altered by adding arguments of the
form C<KEY=VALUE>. E.g.

  perl Makefile.PL PREFIX=/tmp/myperl5

Other interesting targets in the generated Makefile are

  make config     # to check if the Makefile is up-to-date
  make clean      # delete local temp files (Makefile gets renamed)
  make realclean  # delete derived files (including ./blib)
  make ci         # check in all the files in the MANIFEST file
  make dist       # see below the Distribution Support section

=head2 make test

MakeMaker checks for the existence of a file named F<test.pl> in the
current directory and if it exists it adds commands to the test target
of the generated Makefile that will execute the script with the proper
set of perl C<-I> options.

MakeMaker also checks for any files matching glob("t/*.t"). It will
add commands to the test target of the generated Makefile that execute
all matching files via the L<Test::Harness> module with the C<-I>
switches set correctly.

=head2 make testdb

A useful variation of the above is the target C<testdb>. It runs the
test under the Perl debugger (see L<perldebug>). If the file
F<test.pl> exists in the current directory, it is used for the test.

If you want to debug some other testfile, set C<TEST_FILE> variable
thusly:

  make testdb TEST_FILE=t/mytest.t

By default the debugger is called using C<-d> option to perl. If you
want to specify some other option, set C<TESTDB_SW> variable:

  make testdb TESTDB_SW=-Dx

=head2 make install

make alone puts all relevant files into directories that are named by
the macros INST_LIB, INST_ARCHLIB, INST_SCRIPT, INST_HTMLLIBDIR,
INST_HTMLSCRIPTDIR, INST_MAN1DIR, and INST_MAN3DIR.  All these default
to something below ./blib if you are I<not> building below the perl
source directory. If you I<are> building below the perl source,
INST_LIB and INST_ARCHLIB default to ../../lib, and INST_SCRIPT is not
defined.

The I<install> target of the generated Makefile copies the files found
below each of the INST_* directories to their INSTALL*
counterparts. Which counterparts are chosen depends on the setting of
INSTALLDIRS according to the following table:

		       	         INSTALLDIRS set to
       	       	              perl   	          site

    INST_ARCHLIB	INSTALLARCHLIB        INSTALLSITEARCH
    INST_LIB		INSTALLPRIVLIB        INSTALLSITELIB
    INST_HTMLLIBDIR	INSTALLHTMLPRIVLIBDIR INSTALLHTMLSITELIBDIR
    INST_HTMLSCRIPTDIR            INSTALLHTMLSCRIPTDIR
    INST_BIN			  INSTALLBIN
    INST_SCRIPT                   INSTALLSCRIPT
    INST_MAN1DIR                  INSTALLMAN1DIR
    INST_MAN3DIR                  INSTALLMAN3DIR

The INSTALL... macros in turn default to their %Config
($Config{installprivlib}, $Config{installarchlib}, etc.) counterparts.

You can check the values of these variables on your system with

    perl '-V:install.*'

And to check the sequence in which the library directories are
searched by perl, run

    perl -le 'print join $/, @INC'


=head2 PREFIX and LIB attribute

PREFIX and LIB can be used to set several INSTALL* attributes in one
go. The quickest way to install a module in a non-standard place might
be

    perl Makefile.PL LIB=~/lib

This will install the module's architecture-independent files into
~/lib, the architecture-dependent files into ~/lib/$archname.

Another way to specify many INSTALL directories with a single
parameter is PREFIX.

    perl Makefile.PL PREFIX=~

This will replace the string specified by C<$Config{prefix}> in all
C<$Config{install*}> values.

Note, that in both cases the tilde expansion is done by MakeMaker, not
by perl by default, nor by make.

Conflicts between parameters LIB,
PREFIX and the various INSTALL* arguments are resolved so that:

=over 4

=item *

setting LIB overrides any setting of INSTALLPRIVLIB, INSTALLARCHLIB,
INSTALLSITELIB, INSTALLSITEARCH (and they are not affected by PREFIX);

=item *

without LIB, setting PREFIX replaces the initial C<$Config{prefix}>
part of those INSTALL* arguments, even if the latter are explicitly
set (but are set to still start with C<$Config{prefix}>).

=back

If the user has superuser privileges, and is not working on AFS
or relatives, then the defaults for
INSTALLPRIVLIB, INSTALLARCHLIB, INSTALLSCRIPT, etc. will be appropriate,
and this incantation will be the best:

    perl Makefile.PL; make; make test
    make install

make install per default writes some documentation of what has been
done into the file C<$(INSTALLARCHLIB)/perllocal.pod>. This feature
can be bypassed by calling make pure_install.

=head2 AFS users

will have to specify the installation directories as these most
probably have changed since perl itself has been installed. They will
have to do this by calling

    perl Makefile.PL INSTALLSITELIB=/afs/here/today \
	INSTALLSCRIPT=/afs/there/now INSTALLMAN3DIR=/afs/for/manpages
    make

Be careful to repeat this procedure every time you recompile an
extension, unless you are sure the AFS installation directories are
still valid.

=head2 Static Linking of a new Perl Binary

An extension that is built with the above steps is ready to use on
systems supporting dynamic loading. On systems that do not support
dynamic loading, any newly created extension has to be linked together
with the available resources. MakeMaker supports the linking process
by creating appropriate targets in the Makefile whenever an extension
is built. You can invoke the corresponding section of the makefile with

    make perl

That produces a new perl binary in the current directory with all
extensions linked in that can be found in INST_ARCHLIB , SITELIBEXP,
and PERL_ARCHLIB. To do that, MakeMaker writes a new Makefile, on
UNIX, this is called Makefile.aperl (may be system dependent). If you
want to force the creation of a new perl, it is recommended, that you
delete this Makefile.aperl, so the directories are searched-through
for linkable libraries again.

The binary can be installed into the directory where perl normally
resides on your machine with

    make inst_perl

To produce a perl binary with a different name than C<perl>, either say

    perl Makefile.PL MAP_TARGET=myperl
    make myperl
    make inst_perl

or say

    perl Makefile.PL
    make myperl MAP_TARGET=myperl
    make inst_perl MAP_TARGET=myperl

In any case you will be prompted with the correct invocation of the
C<inst_perl> target that installs the new binary into INSTALLBIN.

make inst_perl per default writes some documentation of what has been
done into the file C<$(INSTALLARCHLIB)/perllocal.pod>. This
can be bypassed by calling make pure_inst_perl.

Warning: the inst_perl: target will most probably overwrite your
existing perl binary. Use with care!

Sometimes you might want to build a statically linked perl although
your system supports dynamic loading. In this case you may explicitly
set the linktype with the invocation of the Makefile.PL or make:

    perl Makefile.PL LINKTYPE=static    # recommended

or

    make LINKTYPE=static                # works on most systems

=head2 Determination of Perl Library and Installation Locations

MakeMaker needs to know, or to guess, where certain things are
located.  Especially INST_LIB and INST_ARCHLIB (where to put the files
during the make(1) run), PERL_LIB and PERL_ARCHLIB (where to read
existing modules from), and PERL_INC (header files and C<libperl*.*>).

Extensions may be built either using the contents of the perl source
directory tree or from the installed perl library. The recommended way
is to build extensions after you have run 'make install' on perl
itself. You can do that in any directory on your hard disk that is not
below the perl source tree. The support for extensions below the ext
directory of the perl distribution is only good for the standard
extensions that come with perl.

If an extension is being built below the C<ext/> directory of the perl
source then MakeMaker will set PERL_SRC automatically (e.g.,
C<../..>).  If PERL_SRC is defined and the extension is recognized as
a standard extension, then other variables default to the following:

  PERL_INC     = PERL_SRC
  PERL_LIB     = PERL_SRC/lib
  PERL_ARCHLIB = PERL_SRC/lib
  INST_LIB     = PERL_LIB
  INST_ARCHLIB = PERL_ARCHLIB

If an extension is being built away from the perl source then MakeMaker
will leave PERL_SRC undefined and default to using the installed copy
of the perl library. The other variables default to the following:

  PERL_INC     = $archlibexp/CORE
  PERL_LIB     = $privlibexp
  PERL_ARCHLIB = $archlibexp
  INST_LIB     = ./blib/lib
  INST_ARCHLIB = ./blib/arch

If perl has not yet been installed then PERL_SRC can be defined on the
command line as shown in the previous section.


=head2 Which architecture dependent directory?

If you don't want to keep the defaults for the INSTALL* macros,
MakeMaker helps you to minimize the typing needed: the usual
relationship between INSTALLPRIVLIB and INSTALLARCHLIB is determined
by Configure at perl compilation time. MakeMaker supports the user who
sets INSTALLPRIVLIB. If INSTALLPRIVLIB is set, but INSTALLARCHLIB not,
then MakeMaker defaults the latter to be the same subdirectory of
INSTALLPRIVLIB as Configure decided for the counterparts in %Config ,
otherwise it defaults to INSTALLPRIVLIB. The same relationship holds
for INSTALLSITELIB and INSTALLSITEARCH.

MakeMaker gives you much more freedom than needed to configure
internal variables and get different results. It is worth to mention,
that make(1) also lets you configure most of the variables that are
used in the Makefile. But in the majority of situations this will not
be necessary, and should only be done if the author of a package
recommends it (or you know what you're doing).

=head2 Using Attributes and Parameters

The following attributes can be specified as arguments to WriteMakefile()
or as NAME=VALUE pairs on the command line:

=over 2

=item ABSTRACT

One line description of the module. Will be included in PPD file.

=item ABSTRACT_FROM

Name of the file that contains the package description. MakeMaker looks
for a line in the POD matching /^($package\s-\s)(.*)/. This is typically
the first line in the "=head1 NAME" section. $2 becomes the abstract.

=item AUTHOR

String containing name (and email address) of package author(s). Is used
in PPD (Perl Package Description) files for PPM (Perl Package Manager).

=item BINARY_LOCATION

Used when creating PPD files for binary packages.  It can be set to a
full or relative path or URL to the binary archive for a particular
architecture.  For example:

	perl Makefile.PL BINARY_LOCATION=x86/Agent.tar.gz

builds a PPD package that references a binary of the C<Agent> package,
located in the C<x86> directory relative to the PPD itself.

=item C

Ref to array of *.c file names. Initialised from a directory scan
and the values portion of the XS attribute hash. This is not
currently used by MakeMaker but may be handy in Makefile.PLs.

=item CAPI

[This attribute is obsolete in Perl 5.6.  PERL_OBJECT builds are C-compatible
by default.]

Switch to force usage of the Perl C API even when compiling for PERL_OBJECT.

Note that this attribute is passed through to any recursive build,
but if and only if the submodule's Makefile.PL itself makes no mention
of the 'CAPI' attribute.

=item CCFLAGS

String that will be included in the compiler call command line between
the arguments INC and OPTIMIZE.

=item CONFIG

Arrayref. E.g. [qw(archname manext)] defines ARCHNAME & MANEXT from
config.sh. MakeMaker will add to CONFIG the following values anyway:
ar
cc
cccdlflags
ccdlflags
dlext
dlsrc
ld
lddlflags
ldflags
libc
lib_ext
obj_ext
ranlib
sitelibexp
sitearchexp
so

=item CONFIGURE

CODE reference. The subroutine should return a hash reference. The
hash may contain further attributes, e.g. {LIBS =E<gt> ...}, that have to
be determined by some evaluation method.

=item DEFINE

Something like C<"-DHAVE_UNISTD_H">

=item DIR

Ref to array of subdirectories containing Makefile.PLs e.g. [ 'sdbm'
] in ext/SDBM_File

=item DISTNAME

Your name for distributing the package (by tar file). This defaults to
NAME above.

=item DL_FUNCS

Hashref of symbol names for routines to be made available as universal
symbols.  Each key/value pair consists of the package name and an
array of routine names in that package.  Used only under AIX, OS/2,
VMS and Win32 at present.  The routine names supplied will be expanded
in the same way as XSUB names are expanded by the XS() macro.
Defaults to

  {"$(NAME)" => ["boot_$(NAME)" ] }

e.g.

  {"RPC" => [qw( boot_rpcb rpcb_gettime getnetconfigent )],
   "NetconfigPtr" => [ 'DESTROY'] }

Please see the L<ExtUtils::Mksymlists> documentation for more information
about the DL_FUNCS, DL_VARS and FUNCLIST attributes.

=item DL_VARS

Array of symbol names for variables to be made available as universal symbols.
Used only under AIX, OS/2, VMS and Win32 at present.  Defaults to [].
(e.g. [ qw(Foo_version Foo_numstreams Foo_tree ) ])

=item EXCLUDE_EXT

Array of extension names to exclude when doing a static build.  This
is ignored if INCLUDE_EXT is present.  Consult INCLUDE_EXT for more
details.  (e.g.  [ qw( Socket POSIX ) ] )

This attribute may be most useful when specified as a string on the
command line:  perl Makefile.PL EXCLUDE_EXT='Socket Safe'

=item EXE_FILES

Ref to array of executable files. The files will be copied to the
INST_SCRIPT directory. Make realclean will delete them from there
again.

=item FIRST_MAKEFILE

The name of the Makefile to be produced. Defaults to the contents of
MAKEFILE, but can be overridden. This is used for the second Makefile
that will be produced for the MAP_TARGET.

=item FULLPERL

Perl binary able to run this extension.

=item FUNCLIST

This provides an alternate means to specify function names to be
exported from the extension.  Its value is a reference to an
array of function names to be exported by the extension.  These
names are passed through unaltered to the linker options file.

=item H

Ref to array of *.h file names. Similar to C.

=item HTMLLIBPODS

Hashref of .pm and .pod files.  MakeMaker will default this to all
 .pod and any .pm files that include POD directives.  The files listed
here will be converted to HTML format and installed as was requested
at Configure time.

=item HTMLSCRIPTPODS

Hashref of pod-containing files.  MakeMaker will default this to all
EXE_FILES files that include POD directives.  The files listed
here will be converted to HTML format and installed as was requested
at Configure time.

=item IMPORTS

This attribute is used to specify names to be imported into the
extension. It is only used on OS/2 and Win32.

=item INC

Include file dirs eg: C<"-I/usr/5include -I/path/to/inc">

=item INCLUDE_EXT

Array of extension names to be included when doing a static build.
MakeMaker will normally build with all of the installed extensions when
doing a static build, and that is usually the desired behavior.  If
INCLUDE_EXT is present then MakeMaker will build only with those extensions
which are explicitly mentioned. (e.g.  [ qw( Socket POSIX ) ])

It is not necessary to mention DynaLoader or the current extension when
filling in INCLUDE_EXT.  If the INCLUDE_EXT is mentioned but is empty then
only DynaLoader and the current extension will be included in the build.

This attribute may be most useful when specified as a string on the
command line:  perl Makefile.PL INCLUDE_EXT='POSIX Socket Devel::Peek'

=item INSTALLARCHLIB

Used by 'make install', which copies files from INST_ARCHLIB to this
directory if INSTALLDIRS is set to perl.

=item INSTALLBIN

Directory to install binary files (e.g. tkperl) into.

=item INSTALLDIRS

Determines which of the two sets of installation directories to
choose: installprivlib and installarchlib versus installsitelib and
installsitearch. The first pair is chosen with INSTALLDIRS=perl, the
second with INSTALLDIRS=site. Default is site.

=item INSTALLHTMLPRIVLIBDIR

This directory gets the HTML pages at 'make install' time. Defaults to
$Config{installhtmlprivlibdir}.

=item INSTALLHTMLSCRIPTDIR

This directory gets the HTML pages at 'make install' time. Defaults to
$Config{installhtmlscriptdir}.

=item INSTALLHTMLSITELIBDIR

This directory gets the HTML pages at 'make install' time. Defaults to
$Config{installhtmlsitelibdir}.


=item INSTALLMAN1DIR

This directory gets the man pages at 'make install' time. Defaults to
$Config{installman1dir}.

=item INSTALLMAN3DIR

This directory gets the man pages at 'make install' time. Defaults to
$Config{installman3dir}.

=item INSTALLPRIVLIB

Used by 'make install', which copies files from INST_LIB to this
directory if INSTALLDIRS is set to perl.

=item INSTALLSCRIPT

Used by 'make install' which copies files from INST_SCRIPT to this
directory.

=item INSTALLSITEARCH

Used by 'make install', which copies files from INST_ARCHLIB to this
directory if INSTALLDIRS is set to site (default).

=item INSTALLSITELIB

Used by 'make install', which copies files from INST_LIB to this
directory if INSTALLDIRS is set to site (default).

=item INST_ARCHLIB

Same as INST_LIB for architecture dependent files.

=item INST_BIN

Directory to put real binary files during 'make'. These will be copied
to INSTALLBIN during 'make install'

=item INST_EXE

Old name for INST_SCRIPT. Deprecated. Please use INST_SCRIPT if you
need to use it.

=item INST_HTMLLIBDIR

Directory to hold the man pages in HTML format at 'make' time

=item INST_HTMLSCRIPTDIR

Directory to hold the man pages in HTML format at 'make' time

=item INST_LIB

Directory where we put library files of this extension while building
it.

=item INST_MAN1DIR

Directory to hold the man pages at 'make' time

=item INST_MAN3DIR

Directory to hold the man pages at 'make' time

=item INST_SCRIPT

Directory, where executable files should be installed during
'make'. Defaults to "./blib/script", just to have a dummy location during
testing. make install will copy the files in INST_SCRIPT to
INSTALLSCRIPT.

=item LDFROM

defaults to "$(OBJECT)" and is used in the ld command to specify
what files to link/load from (also see dynamic_lib below for how to
specify ld flags)

=item LIB

LIB should only be set at C<perl Makefile.PL> time but is allowed as a
MakeMaker argument. It has the effect of
setting both INSTALLPRIVLIB and INSTALLSITELIB to that value regardless any
explicit setting of those arguments (or of PREFIX).  
INSTALLARCHLIB and INSTALLSITEARCH are set to the corresponding 
architecture subdirectory.

=item LIBPERL_A

The filename of the perllibrary that will be used together with this
extension. Defaults to libperl.a.

=item LIBS

An anonymous array of alternative library
specifications to be searched for (in order) until
at least one library is found. E.g.

  'LIBS' => ["-lgdbm", "-ldbm -lfoo", "-L/path -ldbm.nfs"]

Mind, that any element of the array
contains a complete set of arguments for the ld
command. So do not specify

  'LIBS' => ["-ltcl", "-ltk", "-lX11"]

See ODBM_File/Makefile.PL for an example, where an array is needed. If
you specify a scalar as in

  'LIBS' => "-ltcl -ltk -lX11"

MakeMaker will turn it into an array with one element.

=item LINKTYPE

'static' or 'dynamic' (default unless usedl=undef in
config.sh). Should only be used to force static linking (also see
linkext below).

=item MAKEAPERL

Boolean which tells MakeMaker, that it should include the rules to
make a perl. This is handled automatically as a switch by
MakeMaker. The user normally does not need it.

=item MAKEFILE

The name of the Makefile to be produced.

=item MAN1PODS

Hashref of pod-containing files. MakeMaker will default this to all
EXE_FILES files that include POD directives. The files listed
here will be converted to man pages and installed as was requested
at Configure time.

=item MAN3PODS

Hashref of .pm and .pod files. MakeMaker will default this to all
 .pod and any .pm files that include POD directives. The files listed
here will be converted to man pages and installed as was requested
at Configure time.

=item MAP_TARGET

If it is intended, that a new perl binary be produced, this variable
may hold a name for that binary. Defaults to perl

=item MYEXTLIB

If the extension links to a library that it builds set this to the
name of the library (see SDBM_File)

=item NAME

Perl module name for this extension (DBD::Oracle). This will default
to the directory name but should be explicitly defined in the
Makefile.PL.

=item NEEDS_LINKING

MakeMaker will figure out if an extension contains linkable code
anywhere down the directory tree, and will set this variable
accordingly, but you can speed it up a very little bit if you define
this boolean variable yourself.

=item NOECHO

Defaults to C<@>. By setting it to an empty string you can generate a
Makefile that echos all commands. Mainly used in debugging MakeMaker
itself.

=item NORECURS

Boolean.  Attribute to inhibit descending into subdirectories.

=item NO_VC

In general, any generated Makefile checks for the current version of
MakeMaker and the version the Makefile was built under. If NO_VC is
set, the version check is neglected. Do not write this into your
Makefile.PL, use it interactively instead.

=item OBJECT

List of object files, defaults to '$(BASEEXT)$(OBJ_EXT)', but can be a long
string containing all object files, e.g. "tkpBind.o
tkpButton.o tkpCanvas.o"

(Where BASEEXT is the last component of NAME, and OBJ_EXT is $Config{obj_ext}.)

=item OPTIMIZE

Defaults to C<-O>. Set it to C<-g> to turn debugging on. The flag is
passed to subdirectory makes.

=item PERL

Perl binary for tasks that can be done by miniperl

=item PERLMAINCC

The call to the program that is able to compile perlmain.c. Defaults
to $(CC).

=item PERL_ARCHLIB

Same as below, but for architecture dependent files.

=item PERL_LIB

Directory containing the Perl library to use.

=item PERL_MALLOC_OK

defaults to 0.  Should be set to TRUE if the extension can work with
the memory allocation routines substituted by the Perl malloc() subsystem.
This should be applicable to most extensions with exceptions of those

=over 4

=item *

with bugs in memory allocations which are caught by Perl's malloc();

=item *

which interact with the memory allocator in other ways than via
malloc(), realloc(), free(), calloc(), sbrk() and brk();

=item *

which rely on special alignment which is not provided by Perl's malloc().

=back

B<NOTE.>  Negligence to set this flag in I<any one> of loaded extension
nullifies many advantages of Perl's malloc(), such as better usage of
system resources, error detection, memory usage reporting, catchable failure
of memory allocations, etc.

=item PERL_SRC

Directory containing the Perl source code (use of this should be
avoided, it may be undefined)

=item PERM_RW

Desired permission for read/writable files. Defaults to C<644>.
See also L<MM_Unix/perm_rw>.

=item PERM_RWX

Desired permission for executable files. Defaults to C<755>.
See also L<MM_Unix/perm_rwx>.

=item PL_FILES

Ref to hash of files to be processed as perl programs. MakeMaker
will default to any found *.PL file (except Makefile.PL) being keys
and the basename of the file being the value. E.g.

  {'foobar.PL' => 'foobar'}

The *.PL files are expected to produce output to the target files
themselves. If multiple files can be generated from the same *.PL
file then the value in the hash can be a reference to an array of
target file names. E.g.

  {'foobar.PL' => ['foobar1','foobar2']}

=item PM

Hashref of .pm files and *.pl files to be installed.  e.g.

  {'name_of_file.pm' => '$(INST_LIBDIR)/install_as.pm'}

By default this will include *.pm and *.pl and the files found in
the PMLIBDIRS directories.  Defining PM in the
Makefile.PL will override PMLIBDIRS.

=item PMLIBDIRS

Ref to array of subdirectories containing library files.  Defaults to
[ 'lib', $(BASEEXT) ]. The directories will be scanned and I<any> files
they contain will be installed in the corresponding location in the
library.  A libscan() method can be used to alter the behaviour.
Defining PM in the Makefile.PL will override PMLIBDIRS.

(Where BASEEXT is the last component of NAME.)

=item PM_FILTER

A filter program, in the traditional Unix sense (input from stdin, output
to stdout) that is passed on each .pm file during the build (in the
pm_to_blib() phase).  It is empty by default, meaning no filtering is done.

Great care is necessary when defining the command if quoting needs to be
done.  For instance, you would need to say:

  {'PM_FILTER' => 'grep -v \\"^\\#\\"'}

to remove all the leading coments on the fly during the build.  The
extra \\ are necessary, unfortunately, because this variable is interpolated
within the context of a Perl program built on the command line, and double
quotes are what is used with the -e switch to build that command line.  The
# is escaped for the Makefile, since what is going to be generated will then
be:

  PM_FILTER = grep -v \"^\#\"

Without the \\ before the #, we'd have the start of a Makefile comment,
and the macro would be incorrectly defined.

=item POLLUTE

Release 5.005 grandfathered old global symbol names by providing preprocessor
macros for extension source compatibility.  As of release 5.6, these
preprocessor definitions are not available by default.  The POLLUTE flag
specifies that the old names should still be defined:

  perl Makefile.PL POLLUTE=1

Please inform the module author if this is necessary to successfully install
a module under 5.6 or later.

=item PPM_INSTALL_EXEC

Name of the executable used to run C<PPM_INSTALL_SCRIPT> below. (e.g. perl)

=item PPM_INSTALL_SCRIPT

Name of the script that gets executed by the Perl Package Manager after
the installation of a package.

=item PREFIX

Can be used to set the three INSTALL* attributes in one go (except for
probably INSTALLMAN1DIR, if it is not below PREFIX according to
%Config).  They will have PREFIX as a common directory node and will
branch from that node into lib/, lib/ARCHNAME or whatever Configure
decided at the build time of your perl (unless you override one of
them, of course).

=item PREREQ_PM

Hashref: Names of modules that need to be available to run this
extension (e.g. Fcntl for SDBM_File) are the keys of the hash and the
desired version is the value. If the required version number is 0, we
only check if any version is installed already.

=item SKIP

Arryref. E.g. [qw(name1 name2)] skip (do not write) sections of the
Makefile. Caution! Do not use the SKIP attribute for the negligible
speedup. It may seriously damage the resulting Makefile. Only use it
if you really need it.

=item TYPEMAPS

Ref to array of typemap file names.  Use this when the typemaps are
in some directory other than the current directory or when they are
not named B<typemap>.  The last typemap in the list takes
precedence.  A typemap in the current directory has highest
precedence, even if it isn't listed in TYPEMAPS.  The default system
typemap has lowest precedence.

=item VERSION

Your version number for distributing the package.  This defaults to
0.1.

=item VERSION_FROM

Instead of specifying the VERSION in the Makefile.PL you can let
MakeMaker parse a file to determine the version number. The parsing
routine requires that the file named by VERSION_FROM contains one
single line to compute the version number. The first line in the file
that contains the regular expression

    /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/

will be evaluated with eval() and the value of the named variable
B<after> the eval() will be assigned to the VERSION attribute of the
MakeMaker object. The following lines will be parsed o.k.:

    $VERSION = '1.00';
    *VERSION = \'1.01';
    ( $VERSION ) = '$Revision: 1.222 $ ' =~ /\$Revision:\s+([^\s]+)/;
    $FOO::VERSION = '1.10';
    *FOO::VERSION = \'1.11';
    our $VERSION = 1.2.3;	# new for perl5.6.0 

but these will fail:

    my $VERSION = '1.01';
    local $VERSION = '1.02';
    local $FOO::VERSION = '1.30';

(Putting C<my> or C<local> on the preceding line will work o.k.)

The file named in VERSION_FROM is not added as a dependency to
Makefile. This is not really correct, but it would be a major pain
during development to have to rewrite the Makefile for any smallish
change in that file. If you want to make sure that the Makefile
contains the correct VERSION macro after any change of the file, you
would have to do something like

    depend => { Makefile => '$(VERSION_FROM)' }

See attribute C<depend> below.

=item XS

Hashref of .xs files. MakeMaker will default this.  e.g.

  {'name_of_file.xs' => 'name_of_file.c'}

The .c files will automatically be included in the list of files
deleted by a make clean.

=item XSOPT

String of options to pass to xsubpp.  This might include C<-C++> or
C<-extern>.  Do not include typemaps here; the TYPEMAP parameter exists for
that purpose.

=item XSPROTOARG

May be set to an empty string, which is identical to C<-prototypes>, or
C<-noprototypes>. See the xsubpp documentation for details. MakeMaker
defaults to the empty string.

=item XS_VERSION

Your version number for the .xs file of this package.  This defaults
to the value of the VERSION attribute.

=back

=head2 Additional lowercase attributes

can be used to pass parameters to the methods which implement that
part of the Makefile.

=over 2

=item clean

  {FILES => "*.xyz foo"}

=item depend

  {ANY_TARGET => ANY_DEPENDECY, ...}

(ANY_TARGET must not be given a double-colon rule by MakeMaker.)

=item dist

  {TARFLAGS => 'cvfF', COMPRESS => 'gzip', SUFFIX => '.gz',
  SHAR => 'shar -m', DIST_CP => 'ln', ZIP => '/bin/zip',
  ZIPFLAGS => '-rl', DIST_DEFAULT => 'private tardist' }

If you specify COMPRESS, then SUFFIX should also be altered, as it is
needed to tell make the target file of the compression. Setting
DIST_CP to ln can be useful, if you need to preserve the timestamps on
your files. DIST_CP can take the values 'cp', which copies the file,
'ln', which links the file, and 'best' which copies symbolic links and
links the rest. Default is 'best'.

=item dynamic_lib

  {ARMAYBE => 'ar', OTHERLDFLAGS => '...', INST_DYNAMIC_DEP => '...'}

=item linkext

  {LINKTYPE => 'static', 'dynamic' or ''}

NB: Extensions that have nothing but *.pm files had to say

  {LINKTYPE => ''}

with Pre-5.0 MakeMakers. Since version 5.00 of MakeMaker such a line
can be deleted safely. MakeMaker recognizes when there's nothing to
be linked.

=item macro

  {ANY_MACRO => ANY_VALUE, ...}

=item realclean

  {FILES => '$(INST_ARCHAUTODIR)/*.xyz'}

=item test

  {TESTS => 't/*.t'}

=item tool_autosplit

  {MAXLEN => 8}

=back

=head2 Overriding MakeMaker Methods

If you cannot achieve the desired Makefile behaviour by specifying
attributes you may define private subroutines in the Makefile.PL.
Each subroutines returns the text it wishes to have written to
the Makefile. To override a section of the Makefile you can
either say:

	sub MY::c_o { "new literal text" }

or you can edit the default by saying something like:

	sub MY::c_o {
	    package MY;	# so that "SUPER" works right
	    my $inherited = shift->SUPER::c_o(@_);
	    $inherited =~ s/old text/new text/;
	    $inherited;
	}

If you are running experiments with embedding perl as a library into
other applications, you might find MakeMaker is not sufficient. You'd
better have a look at ExtUtils::Embed which is a collection of utilities
for embedding.

If you still need a different solution, try to develop another
subroutine that fits your needs and submit the diffs to
F<perl5-porters@perl.org> or F<comp.lang.perl.moderated> as appropriate.

For a complete description of all MakeMaker methods see L<ExtUtils::MM_Unix>.

Here is a simple example of how to add a new target to the generated
Makefile:

    sub MY::postamble {
	'
    $(MYEXTLIB): sdbm/Makefile
	    cd sdbm && $(MAKE) all
    ';
    }


=head2 Hintsfile support

MakeMaker.pm uses the architecture specific information from
Config.pm. In addition it evaluates architecture specific hints files
in a C<hints/> directory. The hints files are expected to be named
like their counterparts in C<PERL_SRC/hints>, but with an C<.pl> file
name extension (eg. C<next_3_2.pl>). They are simply C<eval>ed by
MakeMaker within the WriteMakefile() subroutine, and can be used to
execute commands as well as to include special variables. The rules
which hintsfile is chosen are the same as in Configure.

The hintsfile is eval()ed immediately after the arguments given to
WriteMakefile are stuffed into a hash reference $self but before this
reference becomes blessed. So if you want to do the equivalent to
override or create an attribute you would say something like

    $self->{LIBS} = ['-ldbm -lucb -lc'];

=head2 Distribution Support

For authors of extensions MakeMaker provides several Makefile
targets. Most of the support comes from the ExtUtils::Manifest module,
where additional documentation can be found.

=over 4

=item    make distcheck

reports which files are below the build directory but not in the
MANIFEST file and vice versa. (See ExtUtils::Manifest::fullcheck() for
details)

=item    make skipcheck

reports which files are skipped due to the entries in the
C<MANIFEST.SKIP> file (See ExtUtils::Manifest::skipcheck() for
details)

=item    make distclean

does a realclean first and then the distcheck. Note that this is not
needed to build a new distribution as long as you are sure that the
MANIFEST file is ok.

=item    make manifest

rewrites the MANIFEST file, adding all remaining files found (See
ExtUtils::Manifest::mkmanifest() for details)

=item    make distdir

Copies all the files that are in the MANIFEST file to a newly created
directory with the name C<$(DISTNAME)-$(VERSION)>. If that directory
exists, it will be removed first.

=item	make disttest

Makes a distdir first, and runs a C<perl Makefile.PL>, a make, and
a make test in that directory.

=item    make tardist

First does a distdir. Then a command $(PREOP) which defaults to a null
command, followed by $(TOUNIX), which defaults to a null command under
UNIX, and will convert files in distribution directory to UNIX format
otherwise. Next it runs C<tar> on that directory into a tarfile and
deletes the directory. Finishes with a command $(POSTOP) which
defaults to a null command.

=item    make dist

Defaults to $(DIST_DEFAULT) which in turn defaults to tardist.

=item    make uutardist

Runs a tardist first and uuencodes the tarfile.

=item    make shdist

First does a distdir. Then a command $(PREOP) which defaults to a null
command. Next it runs C<shar> on that directory into a sharfile and
deletes the intermediate directory again. Finishes with a command
$(POSTOP) which defaults to a null command.  Note: For shdist to work
properly a C<shar> program that can handle directories is mandatory.

=item    make zipdist

First does a distdir. Then a command $(PREOP) which defaults to a null
command. Runs C<$(ZIP) $(ZIPFLAGS)> on that directory into a
zipfile. Then deletes that directory. Finishes with a command
$(POSTOP) which defaults to a null command.

=item    make ci

Does a $(CI) and a $(RCS_LABEL) on all files in the MANIFEST file.

=back

Customization of the dist targets can be done by specifying a hash
reference to the dist attribute of the WriteMakefile call. The
following parameters are recognized:

    CI           ('ci -u')
    COMPRESS     ('gzip --best')
    POSTOP       ('@ :')
    PREOP        ('@ :')
    TO_UNIX      (depends on the system)
    RCS_LABEL    ('rcs -q -Nv$(VERSION_SYM):')
    SHAR         ('shar')
    SUFFIX       ('.gz')
    TAR          ('tar')
    TARFLAGS     ('cvf')
    ZIP          ('zip')
    ZIPFLAGS     ('-r')

An example:

    WriteMakefile( 'dist' => { COMPRESS=>"bzip2", SUFFIX=>".bz2" })

=head2 Disabling an extension

If some events detected in F<Makefile.PL> imply that there is no way
to create the Module, but this is a normal state of things, then you
can create a F<Makefile> which does nothing, but succeeds on all the
"usual" build targets.  To do so, use

   ExtUtils::MakeMaker::WriteEmptyMakefile();

instead of WriteMakefile().

This may be useful if other modules expect this module to be I<built>
OK, as opposed to I<work> OK (say, this system-dependent module builds
in a subdirectory of some other distribution, or is listed as a
dependency in a CPAN::Bundle, but the functionality is supported by
different means on the current architecture).

=head1 ENVIRONMENT

=over 8

=item PERL_MM_OPT

Command line options used by C<MakeMaker-E<gt>new()>, and thus by
C<WriteMakefile()>.  The string is split on whitespace, and the result
is processed before any actual command line arguments are processed.

=back

=head1 SEE ALSO

ExtUtils::MM_Unix, ExtUtils::Manifest, ExtUtils::testlib,
ExtUtils::Install, ExtUtils::Embed

=head1 AUTHORS

Andy Dougherty <F<doughera@lafcol.lafayette.edu>>, Andreas KE<ouml>nig
<F<A.Koenig@franz.ww.TU-Berlin.DE>>, Tim Bunce <F<Tim.Bunce@ig.co.uk>>.
VMS support by Charles Bailey <F<bailey@newman.upenn.edu>>.  OS/2
support by Ilya Zakharevich <F<ilya@math.ohio-state.edu>>.  Contact the
makemaker mailing list C<mailto:makemaker@franz.ww.tu-berlin.de>, if
you have any questions.

=cut
-> sub CPAN::Index::rd_modlist ;
sub rd_modlist {
    my($cl,$index_target) = @_;
    return unless defined $index_target;
    $CPAN::Frontend->myprint("Going to read $index_target\n");
    my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
    my @eval;
    local($/) = "\n";
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    package ExtUtils::Manifest;

require Exporter;
use Config;
use File::Find;
use File::Copy 'copy';
use Carp;
use strict;

use vars qw($VERSION @ISA @EXPORT_OK
	    $Is_MacOS $Is_VMS $Debug $Verbose $Quiet $MANIFEST $found);

$VERSION = substr(q$Revision: 1.34 $, 10);
@ISA=('Exporter');
@EXPORT_OK = ('mkmanifest', 'manicheck', 'fullcheck', 'filecheck', 
	      'skipcheck', 'maniread', 'manicopy');

$Is_MacOS = $^O eq 'MacOS';
$Is_VMS = $^O eq 'VMS';
if ($Is_VMS) { require File::Basename }

$Debug = 0;
$Verbose = 1;
$Quiet = 0;
$MANIFEST = 'MANIFEST';

# Really cool fix from Ilya :)
unless (defined $Config{d_link}) {
    no warnings;
    *ln = \&cp;
}

sub mkmanifest {
    my $manimiss = 0;
    my $read = maniread() or $manimiss++;
    $read = {} if $manimiss;
    local *M;
    rename $MANIFEST, "$MANIFEST.bak" unless $manimiss;
    open M, ">$MANIFEST" or die "Could not open $MANIFEST: $!";
    my $matches = _maniskip();
    my $found = manifind();
    my($key,$val,$file,%all);
    %all = (%$found, %$read);
    $all{$MANIFEST} = ($Is_VMS ? "$MANIFEST\t\t" : '') . 'This list of files'
        if $manimiss; # add new MANIFEST to known file list
    foreach $file (sort keys %all) {
	next if &$matches($file);
	if ($Verbose){
	    warn "Added to $MANIFEST: $file\n" unless exists $read->{$file};
	}
	my $text = $all{$file};
	($file,$text) = split(/\s+/,$text,2) if $Is_VMS && $text;
	$file = _unmacify($file);
	my $tabs = (5 - (length($file)+1)/8);
	$tabs = 1 if $tabs < 1;
	$tabs = 0 unless $text;
	print M $file, "\t" x $tabs, $text, "\n";
    }
    close M;
}

sub manifind {
    local $found = {};
    find(sub {return if -d $_;
	      (my $name = $File::Find::name) =~ s|^\./||;
	      $name =~ s/^:([^:]+)$/$1/ if $Is_MacOS;
	      warn "Debug: diskfile $name\n" if $Debug;
	      $name =~ s#(.*)\.$#\L$1# if $Is_VMS;
	      $found->{$name} = "";}, $Is_MacOS ? ":" : ".");
    $found;
}

sub fullcheck {
    _manicheck(3);
}

sub manicheck {
    return @{(_manicheck(1))[0]};
}

sub filecheck {
    return @{(_manicheck(2))[1]};
}

sub skipcheck {
    _manicheck(6);
}

sub _manicheck {
    my($arg) = @_;
    my $read = maniread();
    my $found = manifind();
    my $file;
    my $dosnames=(defined(&Dos::UseLFN) && Dos::UseLFN()==0);
    my(@missfile,@missentry);
    if ($arg & 1){
	foreach $file (sort keys %$read){
	    warn "Debug: manicheck checking from $MANIFEST $file\n" if $Debug;
            if ($dosnames){
                $file = lc $file;
                $file =~ s=(\.(\w|-)+)=substr ($1,0,4)=ge;
                $file =~ s=((\w|-)+)=substr ($1,0,8)=ge;
            }
	    unless ( exists $found->{$file} ) {
		warn "No such file: $file\n" unless $Quiet;
		push @missfile, $file;
	    }
	}
    }
    if ($arg & 2){
	$read ||= {};
	my $matches = _maniskip();
	my $skipwarn = $arg & 4;
	foreach $file (sort keys %$found){
	    if (&$matches($file)){
		warn "Skipping $file\n" if $skipwarn;
		next;
	    }
	    warn "Debug: manicheck checking from disk $file\n" if $Debug;
	    unless ( exists $read->{$file} ) {
		my $canon = "\t" . _unmacify($file) if $Is_MacOS;
		warn "Not in $MANIFEST: $file$canon\n" unless $Quiet;
		push @missentry, $file;
	    }
	}
    }
    (\@missfile,\@missentry);
}

sub maniread {
    my ($mfile) = @_;
    $mfile ||= $MANIFEST;
    my $read = {};
    local *M;
    unless (open M, $mfile){
	warn "$mfile: $!";
	return $read;
    }
    while (<M>){
	chomp;
	next if /^#/;
	if ($Is_MacOS) {
	    my($item,$text) = /^(\S+)\s*(.*)/;
	    $item = _macify($item);
	    $item =~ s/\\([0-3][0-7][0-7])/sprintf("%c", oct($1))/ge;
	    $read->{$item}=$text;
	}
	elsif ($Is_VMS) {
	    my($file)= /^(\S+)/;
	    next unless $file;
	    my($base,$dir) = File::Basename::fileparse($file);
	    # Resolve illegal file specifications in the same way as tar
	    $dir =~ tr/./_/;
	    my(@pieces) = split(/\./,$base);
	    if (@pieces > 2) { $base = shift(@pieces) . '.' . join('_',@pieces); }
	    my $okfile = "$dir$base";
	    warn "Debug: Illegal name $file changed to $okfile\n" if $Debug;
	    $read->{"\L$okfile"}=$_;
	}
	else { /^(\S+)\s*(.*)/ and $read->{$1}=$2; }
    }
    close M;
    $read;
}

# returns an anonymous sub that decides if an argument matches
sub _maniskip {
    my ($mfile) = @_;
    my $matches = sub {0};
    my @skip ;
    $mfile ||= "$MANIFEST.SKIP";
    local *M;
    return $matches unless -f $mfile;
    open M, $mfile or return $matches;
    while (<M>){
	chomp;
	next if /^#/;
	next if /^\s*$/;
	push @skip, _macify($_);
    }
    close M;
    my $opts = $Is_VMS ? 'oi ' : 'o ';
    my $sub = "\$matches = "
	. "sub { my(\$arg)=\@_; return 1 if "
	. join (" || ",  (map {s!/!\\/!g; "\$arg =~ m/$_/$opts"} @skip), 0)
	. " }";
    eval $sub;
    print "Debug: $sub\n" if $Debug;
    $matches;
}

sub manicopy {
    my($read,$target,$how)=@_;
    croak "manicopy() called without target argument" unless defined $target;
    $how ||= 'cp';
    require File::Path;
    require File::Basename;
    my(%dirs,$file);
    $target = VMS::Filespec::unixify($target) if $Is_VMS;
    File::Path::mkpath([ $target ],! $Quiet,$Is_VMS ? undef : 0755);
    foreach $file (keys %$read){
    	if ($Is_MacOS) {
	    if ($file =~ m!:!) { 
	   	my $dir = _maccat($target, $file);
		$dir =~ s/[^:]+$//;
	    	File::Path::mkpath($dir,1,0755);
	    }
	    cp_if_diff($file, _maccat($target, $file), $how);
	} else {
	    $file = VMS::Filespec::unixify($file) if $Is_VMS;
	    if ($file =~ m!/!) { # Ilya, that hurts, I fear, or maybe not?
		my $dir = File::Basename::dirname($file);
		$dir = VMS::Filespec::unixify($dir) if $Is_VMS;
		File::Path::mkpath(["$target/$dir"],