init
This commit is contained in:
Binary file not shown.
@@ -0,0 +1,122 @@
|
||||
#!/bin/sh
|
||||
# Add a new .gnupg home directory for a list of users -*- sh -*-
|
||||
#
|
||||
# Copyright 2004 Free Software Foundation, Inc.
|
||||
#
|
||||
# This file is free software; as a special exception the author gives
|
||||
# unlimited permission to copy and/or distribute it, with or without
|
||||
# modifications, as long as this notice is preserved.
|
||||
#
|
||||
# This file is distributed in the hope that it will be useful, but
|
||||
# WITHOUT ANY WARRANTY, to the extent permitted by law; without even the
|
||||
# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
PGM=addgnupghome
|
||||
any_error=0
|
||||
|
||||
|
||||
error () {
|
||||
echo "$PGM: $*" >&2
|
||||
any_error=1
|
||||
}
|
||||
|
||||
info () {
|
||||
echo "$PGM: $*" >&2
|
||||
}
|
||||
|
||||
# Do it for one user
|
||||
one_user () {
|
||||
user="$1"
|
||||
home=$(${cat_passwd} | awk -F: -v n="$user" '$1 == n {print $6}')
|
||||
if [ -z "$home" ]; then
|
||||
if ${cat_passwd} | awk -F: -v n="$user" '$1 == n {exit 1}'; then
|
||||
error "no such user \`$user'"
|
||||
else
|
||||
error "no home directory for user \`$user'"
|
||||
fi
|
||||
return
|
||||
fi
|
||||
if [ ! -d "$home" ]; then
|
||||
error "home directory \`$home' of user \`$user' does not exist"
|
||||
return
|
||||
fi
|
||||
if [ -d "$home/.gnupg" ]; then
|
||||
info "skipping user \`$user': \`.gnupg' already exists"
|
||||
return
|
||||
fi
|
||||
info "creating home directory \`$home/.gnupg' for \`$user'"
|
||||
if ! mkdir "$home/.gnupg" ; then
|
||||
error "error creating \`$home/.gnupg'"
|
||||
return
|
||||
fi
|
||||
|
||||
if ! chown $user "$home/.gnupg" ; then
|
||||
error "error changing ownership of \`$home/.gnupg'"
|
||||
return
|
||||
fi
|
||||
|
||||
group=$(id -g "$user")
|
||||
[ -z "$group" ] && group="0"
|
||||
|
||||
if [ "$group" -gt 0 ]; then
|
||||
if ! chgrp $group "$home/.gnupg" ; then
|
||||
error "error changing group of \`$home/.gnupg'"
|
||||
return
|
||||
fi
|
||||
fi
|
||||
|
||||
if ! cd "$home/.gnupg" ; then
|
||||
error "error cd-ing to \`$home/.gnupg'"
|
||||
return
|
||||
fi
|
||||
for f in $filelist; do
|
||||
if [ -d /etc/skel/.gnupg/$f ]; then
|
||||
mkdir $f
|
||||
else
|
||||
cp /etc/skel/.gnupg/$f $f
|
||||
fi
|
||||
if ! chown $user $f ; then
|
||||
error "error changing ownership of \`$f'"
|
||||
return
|
||||
fi
|
||||
if [ "$group" -gt 0 ]; then
|
||||
if ! chgrp $group "$f" ; then
|
||||
error "error changing group of \`$f'"
|
||||
return
|
||||
fi
|
||||
fi
|
||||
done
|
||||
|
||||
}
|
||||
|
||||
if [ -z "$1" ]; then
|
||||
echo "usage: $PGM userids"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
# Check whether we can use getent
|
||||
if getent --help </dev/null >/dev/null 2>&1 ; then
|
||||
cat_passwd='getent passwd'
|
||||
else
|
||||
cat_passwd='cat /etc/passwd'
|
||||
info "please note that only users from /etc/passwd are checked"
|
||||
fi
|
||||
|
||||
if [ ! -d /etc/skel/.gnupg ]; then
|
||||
error "skeleton directory \`/etc/skel/.gnupg' does not exist"
|
||||
exit 1
|
||||
fi
|
||||
cd "/etc/skel/.gnupg" || (error "error cd-ing to \`/etc/skel/.gnupg'"; exit 1)
|
||||
filelist=$(find . \( -type f -o -type d \) '!' -name '*~' '!' -name . -print)
|
||||
|
||||
|
||||
if ! umask 0077 ; then
|
||||
error "error setting umask"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
for name in $*; do
|
||||
one_user $name
|
||||
done
|
||||
|
||||
exit $any_error
|
||||
@@ -0,0 +1,81 @@
|
||||
#!/bin/sh
|
||||
# Apply defaults from /etc/gnupg/gpgconf.conf to all users -*- sh -*-
|
||||
#
|
||||
# Copyright 2007 Free Software Foundation, Inc.
|
||||
#
|
||||
# This file is free software; as a special exception the author gives
|
||||
# unlimited permission to copy and/or distribute it, with or without
|
||||
# modifications, as long as this notice is preserved.
|
||||
#
|
||||
# This file is distributed in the hope that it will be useful, but
|
||||
# WITHOUT ANY WARRANTY, to the extent permitted by law; without even the
|
||||
# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
PGM=applygnupgdefaults
|
||||
errorfile=
|
||||
|
||||
error () {
|
||||
echo "$PGM: $*" >&2
|
||||
[ -n "$errorfile" ] && echo "$PGM: $*" >>$errorfile
|
||||
}
|
||||
|
||||
info () {
|
||||
echo "$PGM: $*" >&2
|
||||
}
|
||||
|
||||
if [ -n "$1" ]; then
|
||||
echo "usage: $PGM" >&2
|
||||
exit 1
|
||||
fi
|
||||
|
||||
# Cleanup on exit
|
||||
cleanup ()
|
||||
{
|
||||
[ -n "$errorfile" -a -f "$errorfile" ] && rm "$errorfile"
|
||||
}
|
||||
trap cleanup EXIT SIGINT SIGHUP SIGPIPE
|
||||
errorfile=$(mktemp "/tmp/$PGM.log.XXXXXX")
|
||||
[ -n "$errorfile" -a -f "$errorfile" ] || exit 2
|
||||
|
||||
# Check whether we can use getent
|
||||
if getent --help </dev/null >/dev/null 2>&1 ; then
|
||||
cat_passwd='getent passwd'
|
||||
else
|
||||
cat_passwd='cat /etc/passwd'
|
||||
info "please note that only users from /etc/passwd are processed"
|
||||
fi
|
||||
|
||||
if [ ! -f /etc/gnupg/gpgconf.conf ]; then
|
||||
error "global configuration file \`/etc/gnupg/gpgconf.conf' does not exist"
|
||||
exit 1
|
||||
fi
|
||||
if [ ! -f /etc/shells ]; then
|
||||
error "missing file \`/etc/shells'"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
if [ $(id -u) -ne 0 ]; then
|
||||
error "needs to be run as root"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
${cat_passwd} \
|
||||
| while IFS=: read -r user dmy_a uid dmy_c dmy_d home shell dmy_rest; do
|
||||
# Process only entries with a valid login shell
|
||||
grep </etc/shells "^$shell" 2>/dev/null >/dev/null || continue
|
||||
# and with an pre-existing gnupg home directory
|
||||
[ -d "$home/.gnupg" ] || continue
|
||||
# but not root
|
||||
[ "${uid:-0}" -eq 0 ] && continue
|
||||
info "running \"gpgconf --apply-defaults\" for $user"
|
||||
if su -l -s /bin/sh \
|
||||
-c 'gpgconf --apply-defaults && echo SUCCESS' $user \
|
||||
| tail -1 | grep ^SUCCESS >/dev/null ; then
|
||||
:
|
||||
else
|
||||
error "failed to update gnupg defaults for $user"
|
||||
fi
|
||||
done
|
||||
|
||||
[ "$(wc -c <$errorfile)" -gt 0 ] && exit 1
|
||||
exit 0
|
||||
Binary file not shown.
@@ -0,0 +1,40 @@
|
||||
#!/bin/sh -e
|
||||
# minimalistic replacement for `run-mailcap --action=cat <file>`
|
||||
|
||||
if test "$#" != 1 ; then
|
||||
echo "Usage: astextplain <file>" 1>&2
|
||||
exit 1
|
||||
fi
|
||||
|
||||
# XXX output encoding (UTF-8) hardcoded
|
||||
case "$1" in
|
||||
*.ods | *.ODS | *.odf |*.ODF | *.odt | *.ODT)
|
||||
odt2txt "$1" || cat "$1"
|
||||
;;
|
||||
*.doc | *.DOC | *.dot | *.DOT)
|
||||
case "$(file --brief --mime-type "$1")" in
|
||||
application/msword)
|
||||
out=$(antiword -m UTF-8 "$1") && sed "s/\^M$//" <<<$out || cat "$1"
|
||||
;;
|
||||
*)
|
||||
cat "$1"
|
||||
;;
|
||||
esac
|
||||
;;
|
||||
*.docx | *.DOCX | *.dotx | *.DOTX | *.docm | *.DOCM | *.dotm | *.DOTM)
|
||||
docx2txt.pl "$1" - || cat "$1"
|
||||
;;
|
||||
*.pdf | *.PDF)
|
||||
out=$(pdftotext -q -layout -enc UTF-8 "$1" -) && sed "s/(\^M$)|(^\^L)//" <<<$out || cat "$1"
|
||||
;;
|
||||
# TODO add rtf support
|
||||
*.rtf | *.RTF)
|
||||
cat "$1"
|
||||
;;
|
||||
*)
|
||||
echo "E: unsupported filetype $1" 1>&2
|
||||
exit 1
|
||||
;;
|
||||
esac
|
||||
|
||||
exit 0
|
||||
Binary file not shown.
Binary file not shown.
@@ -0,0 +1,257 @@
|
||||
#! /bin/sh
|
||||
# Make backups.
|
||||
|
||||
# Copyright 2004-2006, 2013, 2019 Free Software Foundation
|
||||
|
||||
# This file is part of GNU tar.
|
||||
|
||||
# GNU tar is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# GNU tar is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
# Load library routines
|
||||
SYSCONFDIR=${SYSCONFDIR-/usr/etc}
|
||||
. ${LIBDIR-/usr/lib/tar}/backup.sh
|
||||
|
||||
DUMP_LEVEL=0
|
||||
TIME=
|
||||
NOW=`now`
|
||||
|
||||
usage() {
|
||||
cat - <<EOF
|
||||
usage: $PROGNAME [OPTIONS] [WHEN]
|
||||
Options are:
|
||||
|
||||
-l, --level=LEVEL Do backup level LEVEL (default $DUMP_LEVEL).
|
||||
-f, --force Force backup even if today's log file already
|
||||
exists.
|
||||
-v, --verbose[=LEVEL] Set verbosity level. Default 100.
|
||||
-t, --time=TIME Wait till TIME, then do backup.
|
||||
|
||||
Informational options:
|
||||
-h, --help Display this help message.
|
||||
-V, --version Display program version.
|
||||
|
||||
Optional argument WHEN is for backward compatibility only. It has been
|
||||
superseded by --time option.
|
||||
TIME argument can be one of:
|
||||
|
||||
now -- do backup immediately.
|
||||
HH -- do backup at HH hours.
|
||||
HH:MM -- do backup at HH:MM.
|
||||
|
||||
Send bug reports to bug-tar@gnu.org.
|
||||
EOF
|
||||
}
|
||||
|
||||
# For compatibility with previous versions, deduce the backup level
|
||||
# from the command name
|
||||
case "$PROGNAME" in
|
||||
level-[0-9]) DUMP_LEVEL=`expr $PROGNAME : 'level-\([0-9][0-9]*\)'`;;
|
||||
esac
|
||||
|
||||
for opt
|
||||
do
|
||||
if [ -z "$prev" ]; then
|
||||
option=$opt
|
||||
optarg=`expr "x$opt" : 'x[^=]*=\(.*\)'`
|
||||
else
|
||||
option="${prev}=$opt"
|
||||
prev=""
|
||||
optarg=$opt
|
||||
fi
|
||||
case $option in
|
||||
--l=*|--le=*|--lev=*|--leve=*|--level=*)
|
||||
DUMP_LEVEL=$optarg
|
||||
;;
|
||||
-l?*) DUMP_LEVEL=`expr $option : '-l\(.*\)'`;;
|
||||
-l|--l|--le|--lev|--leve|--level)
|
||||
prev=--level
|
||||
;;
|
||||
--verb=*|--verbo=*|--verbos=*|--verbose=*)
|
||||
VERBOSE=$optarg
|
||||
;;
|
||||
-v|--verb|--verbo|--verbos|--verbose)
|
||||
VERBOSE=100
|
||||
;;
|
||||
-v*) VERBOSE=`expr $option : '-v\(.*\)'`;;
|
||||
--t=*|--ti=*|--tim=*|--time=*)
|
||||
TIME=$optarg
|
||||
;;
|
||||
-t?*) TIME=`expr $option : '-t\(.*\)'`;;
|
||||
-t|--t|--ti|--tim|--time)
|
||||
prev=--time
|
||||
;;
|
||||
-V|--v|--ve|--ver|--vers|--versi|--versio|--version)
|
||||
echo "backup (GNU tar) 1.35"
|
||||
license
|
||||
exit;;
|
||||
-h|--h|--he|--hel|--help)
|
||||
usage
|
||||
exit;;
|
||||
-f|--f|--fo|--for|--forc|--force)
|
||||
FORCE=yes
|
||||
;;
|
||||
*) if [ "x$TIME" != "x" ]; then
|
||||
bailout "Extra argument. Try $PROGNAME --help for more info."
|
||||
else
|
||||
TIME=$option
|
||||
fi;;
|
||||
esac
|
||||
done
|
||||
|
||||
if [ "x$TIME" = x ]; then
|
||||
bailout "No backup time specified. Try $PROGNAME --help for more info."
|
||||
exit 1
|
||||
fi
|
||||
|
||||
init_backup
|
||||
|
||||
# Maybe sleep until around specified or default hour.
|
||||
wait_time $TIME
|
||||
|
||||
if [ $DUMP_LEVEL -ne 0 ]; then
|
||||
PREV_LEVEL=`expr $DUMP_LEVEL - 1`
|
||||
PREV_DATE=`ls -t ${LOGPATH}/log-*-level-$PREV_LEVEL|
|
||||
head -n 1|
|
||||
sed "s,${LOGPATH}/log-\(.*\)-level.*,\1,"`
|
||||
if [ "x$PREV_DATE" = x ]; then
|
||||
bailout "Can't determine date of the previous backup"
|
||||
fi
|
||||
message 0 "Backup from $PREV_DATE to $NOW"
|
||||
fi
|
||||
|
||||
# start doing things
|
||||
|
||||
# Make sure the log file did not already exist. Create it.
|
||||
|
||||
if [ "x$FORCE" = "xyes" ]; then
|
||||
rm ${LOGFILE}
|
||||
fi
|
||||
|
||||
if [ -f "${LOGFILE}" ] ; then
|
||||
bailout "Log file ${LOGFILE} already exists."
|
||||
else
|
||||
touch "${LOGFILE}"
|
||||
fi
|
||||
message 1 "Ready for backup."
|
||||
message 10 "TAR invocation: $TAR_PART1"
|
||||
message 20 "Variables:"
|
||||
message 20 "BACKUP_DIRS=$BACKUP_DIRS"
|
||||
message 20 "BACKUP_FILES=$BACKUP_FILES"
|
||||
|
||||
# The bunch of commands below is run in a subshell for which all output is
|
||||
# piped through 'tee' to the logfile. Doing this, instead of having
|
||||
# multiple pipelines all over the place, is cleaner and allows access to
|
||||
# the exit value from various commands more easily.
|
||||
(
|
||||
message 1 "preparing tapes"
|
||||
if ! $MT_BEGIN "${TAPE_FILE}"; then
|
||||
echo >&2 "$0: tape initialization failed"
|
||||
exit 1
|
||||
fi
|
||||
rm -f "${VOLNO_FILE}"
|
||||
|
||||
message 1 "processing backup directories"
|
||||
|
||||
set - ${BACKUP_DIRS}
|
||||
while [ $# -ne 0 ] ; do
|
||||
date="`date`"
|
||||
fs="`echo \"${1}\" | sed -e 's/^.*://'`"
|
||||
fs=`root_fs $fs`
|
||||
fsname="`echo \"${1}\" | sed -e 's/\//:/g'`"
|
||||
remotehost="`expr \"${1}\" : '\([^/][^/]*\):.*'`"
|
||||
if [ -z "$remotehost" ]; then
|
||||
remotehost=$localhost
|
||||
fi
|
||||
|
||||
echo "Backing up ${1} at ${date}"
|
||||
message 10 "fs=$fs"
|
||||
message 10 "fsname=$fsname"
|
||||
message 10 "remotehost=$remotehost"
|
||||
if [ $DUMP_LEVEL -eq 0 ]; then
|
||||
make_level_log ${remotehost}
|
||||
else
|
||||
echo "Last `prev_level` dump on this filesystem was on $PREV_DATE"
|
||||
remote_run "${remotehost}" cp "`level_log_name ${fsname} $PREV_LEVEL`" "`level_log_name temp`"
|
||||
fi
|
||||
|
||||
${DUMP_BEGIN-:} $DUMP_LEVEL $remotehost $fs $fsname
|
||||
backup_host ${remotehost} \
|
||||
"--listed=`level_log_name temp`" \
|
||||
"--label='`print_level` backup of ${fs} on ${remotehost} at ${NOW}'" \
|
||||
-C ${fs} .
|
||||
|
||||
# 'rsh' doesn't exit with the exit status of the remote command. What
|
||||
# stupid lossage. TODO: think of a reliable workaround.
|
||||
if [ $? -ne 0 ] ; then
|
||||
echo "$0: backup of ${1} failed." 1>&2
|
||||
# I'm assuming that the tar will have written an empty
|
||||
# file to the tape, otherwise I should do a cat here.
|
||||
else
|
||||
flush_level_log ${remotehost} ${fsname}
|
||||
fi
|
||||
${MT_STATUS} "$TAPE_FILE"
|
||||
${DUMP_END-:} $DUMP_LEVEL $remotehost $fs $fsname
|
||||
echo "sleeping ${SLEEP_TIME} seconds"
|
||||
sleep ${SLEEP_TIME}
|
||||
shift
|
||||
done
|
||||
|
||||
# Dump any individual files requested.
|
||||
|
||||
if [ "x${BACKUP_FILES}" != "x" ] ; then
|
||||
message 1 "processing individual files"
|
||||
|
||||
date="`date`"
|
||||
|
||||
if [ $DUMP_LEVEL -eq 0 ]; then
|
||||
make_level_log $localhost
|
||||
else
|
||||
echo "Last `prev_level` dump on this filesystem was on $PREV_DATE"
|
||||
remote_run "${localhost}" cp "`level_log_name MISC $PREV_LEVEL`" "`level_log_name temp`"
|
||||
fi
|
||||
|
||||
echo "Backing up miscellaneous files at ${date}"
|
||||
|
||||
${DUMP_BEGIN-:} $DUMP_LEVEL $localhost MISC MISC
|
||||
backup_host $localhost \
|
||||
"--listed=`level_log_name temp`"\
|
||||
"--label='`print_level` backup of miscellaneous files at ${NOW}'" \
|
||||
${BACKUP_FILES}
|
||||
|
||||
if [ $? -ne 0 ] ; then
|
||||
echo "Backup of miscellaneous files failed."
|
||||
# I'm assuming that the tar will have written an empty
|
||||
# file to the tape, otherwise I should do a cat here.
|
||||
else
|
||||
flush_level_log $localhost MISC
|
||||
fi
|
||||
${MT_STATUS} "$TAPE_FILE"
|
||||
${DUMP_END-:} $DUMP_LEVEL $localhost MISC MISC
|
||||
else
|
||||
echo "No miscellaneous files specified"
|
||||
fi
|
||||
message 1 "final cleanup"
|
||||
|
||||
$MT_REWIND "${TAPE_FILE}"
|
||||
$MT_OFFLINE "${TAPE_FILE}"
|
||||
echo "."
|
||||
) 2>&1 | tee -a "${LOGFILE}"
|
||||
RC=$?
|
||||
|
||||
if test "${ADMINISTRATOR}" != NONE; then
|
||||
echo "Sending the dump log to ${ADMINISTRATOR}"
|
||||
mail -s "Results of backup started ${startdate}" ${ADMINISTRATOR} < "${LOGFILE}"
|
||||
fi
|
||||
exit $RC
|
||||
# EOF
|
||||
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
@@ -0,0 +1,278 @@
|
||||
#!/bin/sh -
|
||||
#
|
||||
# bashbug - create a bug report and mail it to the bug address
|
||||
#
|
||||
# The bug address depends on the release status of the shell. Versions
|
||||
# with status `devel', `alpha', `beta', or `rc' mail bug reports to
|
||||
# chet.ramey@case.edu and, optionally, to bash-testers@cwru.edu.
|
||||
# Other versions send mail to bug-bash@gnu.org.
|
||||
#
|
||||
# Copyright (C) 1996-2021 Free Software Foundation, Inc.
|
||||
#
|
||||
# This program is free software: you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation, either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
#
|
||||
# configuration section:
|
||||
# these variables are filled in by the make target in Makefile
|
||||
#
|
||||
MACHINE="x86_64"
|
||||
OS="msys"
|
||||
CC="gcc"
|
||||
CFLAGS="-march=nocona -msahf -mtune=generic -O2 -pipe -D_STATIC_BUILD"
|
||||
RELEASE="5.2"
|
||||
PATCHLEVEL="37"
|
||||
RELSTATUS="release"
|
||||
MACHTYPE="x86_64-pc-msys"
|
||||
|
||||
PATH=/bin:/usr/bin:/usr/local/bin:$PATH
|
||||
export PATH
|
||||
|
||||
# Check if TMPDIR is set, default to /tmp
|
||||
: ${TMPDIR:=/tmp}
|
||||
|
||||
#Securely create a temporary directory for the temporary files
|
||||
TEMPDIR=$TMPDIR/bbug.$$
|
||||
(umask 077 && mkdir "$TEMPDIR") || {
|
||||
echo "$0: could not create temporary directory" >&2
|
||||
exit 1
|
||||
}
|
||||
|
||||
TEMPFILE1=$TEMPDIR/bbug1
|
||||
TEMPFILE2=$TEMPDIR/bbug2
|
||||
|
||||
USAGE="Usage: $0 [--help] [--version] [bug-report-email-address]"
|
||||
VERSTR="GNU bashbug, version ${RELEASE}.${PATCHLEVEL}-${RELSTATUS}"
|
||||
|
||||
do_help= do_version=
|
||||
|
||||
while [ $# -gt 0 ]; do
|
||||
case "$1" in
|
||||
--help) shift ; do_help=y ;;
|
||||
--version) shift ; do_version=y ;;
|
||||
--) shift ; break ;;
|
||||
-*) echo "bashbug: ${1}: invalid option" >&2
|
||||
echo "$USAGE" >&2
|
||||
exit 2 ;;
|
||||
*) break ;;
|
||||
esac
|
||||
done
|
||||
|
||||
if [ -n "$do_version" ]; then
|
||||
echo "${VERSTR}"
|
||||
exit 0
|
||||
fi
|
||||
|
||||
if [ -n "$do_help" ]; then
|
||||
echo "${VERSTR}"
|
||||
echo "${USAGE}"
|
||||
echo
|
||||
cat << HERE_EOF
|
||||
Bashbug is used to send mail to the Bash maintainers
|
||||
for when Bash doesn't behave like you'd like, or expect.
|
||||
|
||||
Bashbug will start up your editor (as defined by the shell's
|
||||
EDITOR environment variable) with a preformatted bug report
|
||||
template for you to fill in. The report will be mailed to the
|
||||
bug-bash mailing list by default. See the manual for details.
|
||||
|
||||
If you invoke bashbug by accident, just quit your editor without
|
||||
saving any changes to the template, and no bug report will be sent.
|
||||
HERE_EOF
|
||||
exit 0
|
||||
fi
|
||||
|
||||
# Figure out how to echo a string without a trailing newline
|
||||
N=`echo 'hi there\c'`
|
||||
case "$N" in
|
||||
*c) n=-n c= ;;
|
||||
*) n= c='\c' ;;
|
||||
esac
|
||||
|
||||
BASHTESTERS="bash-testers@cwru.edu"
|
||||
|
||||
case "$RELSTATUS" in
|
||||
alpha*|beta*|devel*|rc*) BUGBASH=chet.ramey@case.edu ;;
|
||||
*) BUGBASH=bug-bash@gnu.org ;;
|
||||
esac
|
||||
|
||||
case "$RELSTATUS" in
|
||||
alpha*|beta*|devel*|rc*)
|
||||
echo "$0: This is a testing release. Would you like your bug report"
|
||||
echo "$0: to be sent to the bash-testers mailing list?"
|
||||
echo $n "$0: Send to bash-testers? $c"
|
||||
read ans
|
||||
case "$ans" in
|
||||
y*|Y*) BUGBASH="${BUGBASH},${BASHTESTERS}" ;;
|
||||
esac ;;
|
||||
esac
|
||||
|
||||
BUGADDR="${1-$BUGBASH}"
|
||||
|
||||
if [ -z "$DEFEDITOR" ] && [ -z "$EDITOR" ]; then
|
||||
if [ -x /usr/bin/editor ]; then
|
||||
DEFEDITOR=editor
|
||||
elif [ -x /usr/local/bin/ce ]; then
|
||||
DEFEDITOR=ce
|
||||
elif [ -x /usr/local/bin/emacs ]; then
|
||||
DEFEDITOR=emacs
|
||||
elif [ -x /usr/contrib/bin/emacs ]; then
|
||||
DEFEDITOR=emacs
|
||||
elif [ -x /usr/bin/emacs ]; then
|
||||
DEFEDITOR=emacs
|
||||
elif [ -x /usr/bin/xemacs ]; then
|
||||
DEFEDITOR=xemacs
|
||||
elif [ -x /usr/bin/vim; then
|
||||
DEFEDITOR=vim
|
||||
elif [ -x /usr/bin/gvim; then
|
||||
DEFEDITOR=gvim
|
||||
elif [ -x /usr/bin/nano ]; then
|
||||
DEFEDITOR=nano
|
||||
elif [ -x /usr/contrib/bin/jove ]; then
|
||||
DEFEDITOR=jove
|
||||
elif [ -x /usr/local/bin/jove ]; then
|
||||
DEFEDITOR=jove
|
||||
elif [ -x /usr/bin/vi ]; then
|
||||
DEFEDITOR=vi
|
||||
else
|
||||
echo "$0: No default editor found: attempting to use vi" >&2
|
||||
DEFEDITOR=vi
|
||||
fi
|
||||
fi
|
||||
|
||||
|
||||
: ${EDITOR=$DEFEDITOR}
|
||||
|
||||
: ${USER=${LOGNAME-`whoami`}}
|
||||
|
||||
trap 'rm -rf "$TEMPDIR"; exit 1' 1 2 3 13 15
|
||||
trap 'rm -rf "$TEMPDIR"' 0
|
||||
|
||||
UN=
|
||||
if (uname) >/dev/null 2>&1; then
|
||||
UN=`uname -a`
|
||||
fi
|
||||
|
||||
if [ -f /usr/lib/sendmail ] ; then
|
||||
RMAIL="/usr/lib/sendmail"
|
||||
SMARGS="-i -t"
|
||||
elif [ -f /usr/sbin/sendmail ] ; then
|
||||
RMAIL="/usr/sbin/sendmail"
|
||||
SMARGS="-i -t"
|
||||
else
|
||||
RMAIL=rmail
|
||||
SMARGS="$BUGADDR"
|
||||
fi
|
||||
|
||||
INITIAL_SUBJECT='[50 character or so descriptive subject here (for reference)]'
|
||||
|
||||
cat > "$TEMPFILE1" <<EOF
|
||||
From: ${USER}
|
||||
To: ${BUGADDR}
|
||||
Subject: ${INITIAL_SUBJECT}
|
||||
|
||||
Configuration Information [Automatically generated, do not change]:
|
||||
Machine: $MACHINE
|
||||
OS: $OS
|
||||
Compiler: $CC
|
||||
Compilation CFLAGS: $CFLAGS
|
||||
uname output: $UN
|
||||
Machine Type: $MACHTYPE
|
||||
|
||||
Bash Version: $RELEASE
|
||||
Patch Level: $PATCHLEVEL
|
||||
Release Status: $RELSTATUS
|
||||
|
||||
Description:
|
||||
[Detailed description of the problem, suggestion, or complaint.]
|
||||
|
||||
Repeat-By:
|
||||
[Describe the sequence of events that causes the problem
|
||||
to occur.]
|
||||
|
||||
Fix:
|
||||
[Description of how to fix the problem. If you don't know a
|
||||
fix for the problem, don't include this section.]
|
||||
EOF
|
||||
|
||||
cp "$TEMPFILE1" "$TEMPFILE2"
|
||||
chmod u+w "$TEMPFILE1"
|
||||
|
||||
trap '' 2 # ignore interrupts while in editor
|
||||
|
||||
edstat=1
|
||||
while [ $edstat -ne 0 ]; do
|
||||
$EDITOR "$TEMPFILE1"
|
||||
edstat=$?
|
||||
|
||||
if [ $edstat -ne 0 ]; then
|
||||
echo "$0: editor \`$EDITOR' exited with nonzero status."
|
||||
echo "$0: Perhaps it was interrupted."
|
||||
echo "$0: Type \`y' to give up, and lose your bug report;"
|
||||
echo "$0: type \`n' to re-enter the editor."
|
||||
echo $n "$0: Do you want to give up? $c"
|
||||
|
||||
read ans
|
||||
case "$ans" in
|
||||
[Yy]*) exit 1 ;;
|
||||
esac
|
||||
|
||||
continue
|
||||
fi
|
||||
|
||||
# find the subject from the temp file and see if it's been changed
|
||||
CURR_SUB=`grep '^Subject: ' "$TEMPFILE1" | sed 's|^Subject:[ ]*||' | sed 1q`
|
||||
|
||||
case "$CURR_SUB" in
|
||||
"${INITIAL_SUBJECT}")
|
||||
echo
|
||||
echo "$0: You have not changed the subject from the default."
|
||||
echo "$0: Please use a more descriptive subject header."
|
||||
echo "$0: Type \`y' to give up, and lose your bug report;"
|
||||
echo "$0: type \`n' to re-enter the editor."
|
||||
echo $n "$0: Do you want to give up? $c"
|
||||
|
||||
read ans
|
||||
case "$ans" in
|
||||
[Yy]*) exit 1 ;;
|
||||
esac
|
||||
|
||||
echo "$0: The editor will be restarted in five seconds."
|
||||
sleep 5
|
||||
edstat=1
|
||||
;;
|
||||
esac
|
||||
|
||||
done
|
||||
|
||||
trap 'rm -rf "$TEMPDIR"; exit 1' 2 # restore trap on SIGINT
|
||||
|
||||
if cmp -s "$TEMPFILE1" "$TEMPFILE2"
|
||||
then
|
||||
echo "File not changed, no bug report submitted."
|
||||
exit
|
||||
fi
|
||||
|
||||
echo $n "Send bug report to ${BUGADDR}? [y/n] $c"
|
||||
read ans
|
||||
case "$ans" in
|
||||
[Nn]*) exit 0 ;;
|
||||
esac
|
||||
|
||||
${RMAIL} $SMARGS < "$TEMPFILE1" || {
|
||||
cat "$TEMPFILE1" >> $HOME/dead.bashbug
|
||||
echo "$0: mail to ${BUGADDR} failed: report saved in $HOME/dead.bashbug" >&2
|
||||
echo "$0: please send it manually to ${BUGADDR}" >&2
|
||||
}
|
||||
|
||||
exit 0
|
||||
Binary file not shown.
Binary file not shown.
@@ -0,0 +1,76 @@
|
||||
#!/bin/sh
|
||||
# sh is buggy on RS/6000 AIX 3.2. Replace above line with #!/bin/ksh
|
||||
|
||||
# Bzcmp/diff wrapped for bzip2,
|
||||
# adapted from zdiff by Philippe Troin <phil@fifi.org> for Debian GNU/Linux.
|
||||
|
||||
# Bzcmp and bzdiff are used to invoke the cmp or the diff pro-
|
||||
# gram on compressed files. All options specified are passed
|
||||
# directly to cmp or diff. If only 1 file is specified, then
|
||||
# the files compared are file1 and an uncompressed file1.gz.
|
||||
# If two files are specified, then they are uncompressed (if
|
||||
# necessary) and fed to cmp or diff. The exit status from cmp
|
||||
# or diff is preserved.
|
||||
|
||||
PATH="/usr/bin:/bin:$PATH"; export PATH
|
||||
prog=`echo $0 | sed 's|.*/||'`
|
||||
case "$prog" in
|
||||
*cmp) comp=${CMP-cmp} ;;
|
||||
*) comp=${DIFF-diff} ;;
|
||||
esac
|
||||
|
||||
OPTIONS=
|
||||
FILES=
|
||||
for ARG
|
||||
do
|
||||
case "$ARG" in
|
||||
-*) OPTIONS="$OPTIONS $ARG";;
|
||||
*) if test -f "$ARG"; then
|
||||
FILES="$FILES $ARG"
|
||||
else
|
||||
echo "${prog}: $ARG not found or not a regular file"
|
||||
exit 1
|
||||
fi ;;
|
||||
esac
|
||||
done
|
||||
if test -z "$FILES"; then
|
||||
echo "Usage: $prog [${comp}_options] file [file]"
|
||||
exit 1
|
||||
fi
|
||||
set $FILES
|
||||
if test $# -eq 1; then
|
||||
FILE=`echo "$1" | sed 's/.bz2$//'`
|
||||
bzip2 -cd "$FILE.bz2" | $comp $OPTIONS - "$FILE"
|
||||
STAT="$?"
|
||||
|
||||
elif test $# -eq 2; then
|
||||
case "$1" in
|
||||
*.bz2)
|
||||
case "$2" in
|
||||
*.bz2)
|
||||
F=`echo "$2" | sed 's|.*/||;s|.bz2$||'`
|
||||
tmp=`mktemp "${TMPDIR:-/tmp}"/bzdiff.XXXXXXXXXX` || {
|
||||
echo 'cannot create a temporary file' >&2
|
||||
exit 1
|
||||
}
|
||||
bzip2 -cdfq "$2" > "$tmp"
|
||||
bzip2 -cdfq "$1" | $comp $OPTIONS - "$tmp"
|
||||
STAT="$?"
|
||||
/bin/rm -f "$tmp";;
|
||||
|
||||
*) bzip2 -cdfq "$1" | $comp $OPTIONS - "$2"
|
||||
STAT="$?";;
|
||||
esac;;
|
||||
*) case "$2" in
|
||||
*.bz2)
|
||||
bzip2 -cdfq "$2" | $comp $OPTIONS "$1" -
|
||||
STAT="$?";;
|
||||
*) $comp $OPTIONS "$1" "$2"
|
||||
STAT="$?";;
|
||||
esac;;
|
||||
esac
|
||||
else
|
||||
echo "Usage: $prog [${comp}_options] file [file]"
|
||||
exit 1
|
||||
fi
|
||||
exit "$STAT"
|
||||
@@ -0,0 +1,76 @@
|
||||
#!/bin/sh
|
||||
# sh is buggy on RS/6000 AIX 3.2. Replace above line with #!/bin/ksh
|
||||
|
||||
# Bzcmp/diff wrapped for bzip2,
|
||||
# adapted from zdiff by Philippe Troin <phil@fifi.org> for Debian GNU/Linux.
|
||||
|
||||
# Bzcmp and bzdiff are used to invoke the cmp or the diff pro-
|
||||
# gram on compressed files. All options specified are passed
|
||||
# directly to cmp or diff. If only 1 file is specified, then
|
||||
# the files compared are file1 and an uncompressed file1.gz.
|
||||
# If two files are specified, then they are uncompressed (if
|
||||
# necessary) and fed to cmp or diff. The exit status from cmp
|
||||
# or diff is preserved.
|
||||
|
||||
PATH="/usr/bin:/bin:$PATH"; export PATH
|
||||
prog=`echo $0 | sed 's|.*/||'`
|
||||
case "$prog" in
|
||||
*cmp) comp=${CMP-cmp} ;;
|
||||
*) comp=${DIFF-diff} ;;
|
||||
esac
|
||||
|
||||
OPTIONS=
|
||||
FILES=
|
||||
for ARG
|
||||
do
|
||||
case "$ARG" in
|
||||
-*) OPTIONS="$OPTIONS $ARG";;
|
||||
*) if test -f "$ARG"; then
|
||||
FILES="$FILES $ARG"
|
||||
else
|
||||
echo "${prog}: $ARG not found or not a regular file"
|
||||
exit 1
|
||||
fi ;;
|
||||
esac
|
||||
done
|
||||
if test -z "$FILES"; then
|
||||
echo "Usage: $prog [${comp}_options] file [file]"
|
||||
exit 1
|
||||
fi
|
||||
set $FILES
|
||||
if test $# -eq 1; then
|
||||
FILE=`echo "$1" | sed 's/.bz2$//'`
|
||||
bzip2 -cd "$FILE.bz2" | $comp $OPTIONS - "$FILE"
|
||||
STAT="$?"
|
||||
|
||||
elif test $# -eq 2; then
|
||||
case "$1" in
|
||||
*.bz2)
|
||||
case "$2" in
|
||||
*.bz2)
|
||||
F=`echo "$2" | sed 's|.*/||;s|.bz2$||'`
|
||||
tmp=`mktemp "${TMPDIR:-/tmp}"/bzdiff.XXXXXXXXXX` || {
|
||||
echo 'cannot create a temporary file' >&2
|
||||
exit 1
|
||||
}
|
||||
bzip2 -cdfq "$2" > "$tmp"
|
||||
bzip2 -cdfq "$1" | $comp $OPTIONS - "$tmp"
|
||||
STAT="$?"
|
||||
/bin/rm -f "$tmp";;
|
||||
|
||||
*) bzip2 -cdfq "$1" | $comp $OPTIONS - "$2"
|
||||
STAT="$?";;
|
||||
esac;;
|
||||
*) case "$2" in
|
||||
*.bz2)
|
||||
bzip2 -cdfq "$2" | $comp $OPTIONS "$1" -
|
||||
STAT="$?";;
|
||||
*) $comp $OPTIONS "$1" "$2"
|
||||
STAT="$?";;
|
||||
esac;;
|
||||
esac
|
||||
else
|
||||
echo "Usage: $prog [${comp}_options] file [file]"
|
||||
exit 1
|
||||
fi
|
||||
exit "$STAT"
|
||||
@@ -0,0 +1,85 @@
|
||||
#!/bin/sh
|
||||
|
||||
# Bzgrep wrapped for bzip2,
|
||||
# adapted from zgrep by Philippe Troin <phil@fifi.org> for Debian GNU/Linux.
|
||||
## zgrep notice:
|
||||
## zgrep -- a wrapper around a grep program that decompresses files as needed
|
||||
## Adapted from a version sent by Charles Levert <charles@comm.polymtl.ca>
|
||||
|
||||
PATH="/usr/bin:$PATH"; export PATH
|
||||
|
||||
prog=`echo $0 | sed 's|.*/||'`
|
||||
case "$prog" in
|
||||
*egrep) grep=${EGREP-egrep} ;;
|
||||
*fgrep) grep=${FGREP-fgrep} ;;
|
||||
*) grep=${GREP-grep} ;;
|
||||
esac
|
||||
pat=""
|
||||
while test $# -ne 0; do
|
||||
case "$1" in
|
||||
-e | -f) opt="$opt $1"; shift; pat="$1"
|
||||
if test "$grep" = grep; then # grep is buggy with -e on SVR4
|
||||
grep=egrep
|
||||
fi;;
|
||||
-A | -B) opt="$opt $1 $2"; shift;;
|
||||
-*) opt="$opt $1";;
|
||||
*) if test -z "$pat"; then
|
||||
pat="$1"
|
||||
else
|
||||
break;
|
||||
fi;;
|
||||
esac
|
||||
shift
|
||||
done
|
||||
|
||||
if test -z "$pat"; then
|
||||
echo "grep through bzip2 files"
|
||||
echo "usage: $prog [grep_options] pattern [files]"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
list=0
|
||||
silent=0
|
||||
op=`echo "$opt" | sed -e 's/ //g' -e 's/-//g'`
|
||||
case "$op" in
|
||||
*l*) list=1
|
||||
esac
|
||||
case "$op" in
|
||||
*h*) silent=1
|
||||
esac
|
||||
|
||||
if test $# -eq 0; then
|
||||
bzip2 -cdfq | $grep $opt "$pat"
|
||||
exit $?
|
||||
fi
|
||||
|
||||
res=0
|
||||
for i do
|
||||
if test -f "$i"; then :; else if test -f "$i.bz2"; then i="$i.bz2"; fi; fi
|
||||
if test $list -eq 1; then
|
||||
bzip2 -cdfq "$i" | $grep $opt "$pat" 2>&1 > /dev/null && echo $i
|
||||
r=$?
|
||||
elif test $# -eq 1 -o $silent -eq 1; then
|
||||
bzip2 -cdfq "$i" | $grep $opt "$pat"
|
||||
r=$?
|
||||
else
|
||||
j=$(echo "$i" | sed 's/\\/&&/g;s/|/\\&/g;s/&/\\&/g')
|
||||
j=`printf "%s" "$j" | tr '\n' ' '`
|
||||
# A trick adapted from
|
||||
# https://groups.google.com/forum/#!original/comp.unix.shell/x1345iu10eg/Nn1n-1r1uU0J
|
||||
# that has the same effect as the following bash code:
|
||||
# bzip2 -cdfq "$i" | $grep $opt "$pat" | sed "s|^|${j}:|"
|
||||
# r=${PIPESTATUS[1]}
|
||||
exec 3>&1
|
||||
eval `
|
||||
exec 4>&1 >&3 3>&-
|
||||
{
|
||||
bzip2 -cdfq "$i" 4>&-
|
||||
} | {
|
||||
$grep $opt "$pat" 4>&-; echo "r=$?;" >&4
|
||||
} | sed "s|^|${j}:|"
|
||||
`
|
||||
fi
|
||||
test "$r" -ne 0 && res="$r"
|
||||
done
|
||||
exit $res
|
||||
@@ -0,0 +1,85 @@
|
||||
#!/bin/sh
|
||||
|
||||
# Bzgrep wrapped for bzip2,
|
||||
# adapted from zgrep by Philippe Troin <phil@fifi.org> for Debian GNU/Linux.
|
||||
## zgrep notice:
|
||||
## zgrep -- a wrapper around a grep program that decompresses files as needed
|
||||
## Adapted from a version sent by Charles Levert <charles@comm.polymtl.ca>
|
||||
|
||||
PATH="/usr/bin:$PATH"; export PATH
|
||||
|
||||
prog=`echo $0 | sed 's|.*/||'`
|
||||
case "$prog" in
|
||||
*egrep) grep=${EGREP-egrep} ;;
|
||||
*fgrep) grep=${FGREP-fgrep} ;;
|
||||
*) grep=${GREP-grep} ;;
|
||||
esac
|
||||
pat=""
|
||||
while test $# -ne 0; do
|
||||
case "$1" in
|
||||
-e | -f) opt="$opt $1"; shift; pat="$1"
|
||||
if test "$grep" = grep; then # grep is buggy with -e on SVR4
|
||||
grep=egrep
|
||||
fi;;
|
||||
-A | -B) opt="$opt $1 $2"; shift;;
|
||||
-*) opt="$opt $1";;
|
||||
*) if test -z "$pat"; then
|
||||
pat="$1"
|
||||
else
|
||||
break;
|
||||
fi;;
|
||||
esac
|
||||
shift
|
||||
done
|
||||
|
||||
if test -z "$pat"; then
|
||||
echo "grep through bzip2 files"
|
||||
echo "usage: $prog [grep_options] pattern [files]"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
list=0
|
||||
silent=0
|
||||
op=`echo "$opt" | sed -e 's/ //g' -e 's/-//g'`
|
||||
case "$op" in
|
||||
*l*) list=1
|
||||
esac
|
||||
case "$op" in
|
||||
*h*) silent=1
|
||||
esac
|
||||
|
||||
if test $# -eq 0; then
|
||||
bzip2 -cdfq | $grep $opt "$pat"
|
||||
exit $?
|
||||
fi
|
||||
|
||||
res=0
|
||||
for i do
|
||||
if test -f "$i"; then :; else if test -f "$i.bz2"; then i="$i.bz2"; fi; fi
|
||||
if test $list -eq 1; then
|
||||
bzip2 -cdfq "$i" | $grep $opt "$pat" 2>&1 > /dev/null && echo $i
|
||||
r=$?
|
||||
elif test $# -eq 1 -o $silent -eq 1; then
|
||||
bzip2 -cdfq "$i" | $grep $opt "$pat"
|
||||
r=$?
|
||||
else
|
||||
j=$(echo "$i" | sed 's/\\/&&/g;s/|/\\&/g;s/&/\\&/g')
|
||||
j=`printf "%s" "$j" | tr '\n' ' '`
|
||||
# A trick adapted from
|
||||
# https://groups.google.com/forum/#!original/comp.unix.shell/x1345iu10eg/Nn1n-1r1uU0J
|
||||
# that has the same effect as the following bash code:
|
||||
# bzip2 -cdfq "$i" | $grep $opt "$pat" | sed "s|^|${j}:|"
|
||||
# r=${PIPESTATUS[1]}
|
||||
exec 3>&1
|
||||
eval `
|
||||
exec 4>&1 >&3 3>&-
|
||||
{
|
||||
bzip2 -cdfq "$i" 4>&-
|
||||
} | {
|
||||
$grep $opt "$pat" 4>&-; echo "r=$?;" >&4
|
||||
} | sed "s|^|${j}:|"
|
||||
`
|
||||
fi
|
||||
test "$r" -ne 0 && res="$r"
|
||||
done
|
||||
exit $res
|
||||
@@ -0,0 +1,85 @@
|
||||
#!/bin/sh
|
||||
|
||||
# Bzgrep wrapped for bzip2,
|
||||
# adapted from zgrep by Philippe Troin <phil@fifi.org> for Debian GNU/Linux.
|
||||
## zgrep notice:
|
||||
## zgrep -- a wrapper around a grep program that decompresses files as needed
|
||||
## Adapted from a version sent by Charles Levert <charles@comm.polymtl.ca>
|
||||
|
||||
PATH="/usr/bin:$PATH"; export PATH
|
||||
|
||||
prog=`echo $0 | sed 's|.*/||'`
|
||||
case "$prog" in
|
||||
*egrep) grep=${EGREP-egrep} ;;
|
||||
*fgrep) grep=${FGREP-fgrep} ;;
|
||||
*) grep=${GREP-grep} ;;
|
||||
esac
|
||||
pat=""
|
||||
while test $# -ne 0; do
|
||||
case "$1" in
|
||||
-e | -f) opt="$opt $1"; shift; pat="$1"
|
||||
if test "$grep" = grep; then # grep is buggy with -e on SVR4
|
||||
grep=egrep
|
||||
fi;;
|
||||
-A | -B) opt="$opt $1 $2"; shift;;
|
||||
-*) opt="$opt $1";;
|
||||
*) if test -z "$pat"; then
|
||||
pat="$1"
|
||||
else
|
||||
break;
|
||||
fi;;
|
||||
esac
|
||||
shift
|
||||
done
|
||||
|
||||
if test -z "$pat"; then
|
||||
echo "grep through bzip2 files"
|
||||
echo "usage: $prog [grep_options] pattern [files]"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
list=0
|
||||
silent=0
|
||||
op=`echo "$opt" | sed -e 's/ //g' -e 's/-//g'`
|
||||
case "$op" in
|
||||
*l*) list=1
|
||||
esac
|
||||
case "$op" in
|
||||
*h*) silent=1
|
||||
esac
|
||||
|
||||
if test $# -eq 0; then
|
||||
bzip2 -cdfq | $grep $opt "$pat"
|
||||
exit $?
|
||||
fi
|
||||
|
||||
res=0
|
||||
for i do
|
||||
if test -f "$i"; then :; else if test -f "$i.bz2"; then i="$i.bz2"; fi; fi
|
||||
if test $list -eq 1; then
|
||||
bzip2 -cdfq "$i" | $grep $opt "$pat" 2>&1 > /dev/null && echo $i
|
||||
r=$?
|
||||
elif test $# -eq 1 -o $silent -eq 1; then
|
||||
bzip2 -cdfq "$i" | $grep $opt "$pat"
|
||||
r=$?
|
||||
else
|
||||
j=$(echo "$i" | sed 's/\\/&&/g;s/|/\\&/g;s/&/\\&/g')
|
||||
j=`printf "%s" "$j" | tr '\n' ' '`
|
||||
# A trick adapted from
|
||||
# https://groups.google.com/forum/#!original/comp.unix.shell/x1345iu10eg/Nn1n-1r1uU0J
|
||||
# that has the same effect as the following bash code:
|
||||
# bzip2 -cdfq "$i" | $grep $opt "$pat" | sed "s|^|${j}:|"
|
||||
# r=${PIPESTATUS[1]}
|
||||
exec 3>&1
|
||||
eval `
|
||||
exec 4>&1 >&3 3>&-
|
||||
{
|
||||
bzip2 -cdfq "$i" 4>&-
|
||||
} | {
|
||||
$grep $opt "$pat" 4>&-; echo "r=$?;" >&4
|
||||
} | sed "s|^|${j}:|"
|
||||
`
|
||||
fi
|
||||
test "$r" -ne 0 && res="$r"
|
||||
done
|
||||
exit $res
|
||||
Binary file not shown.
Binary file not shown.
@@ -0,0 +1,61 @@
|
||||
#!/bin/sh
|
||||
|
||||
# Bzmore wrapped for bzip2,
|
||||
# adapted from zmore by Philippe Troin <phil@fifi.org> for Debian GNU/Linux.
|
||||
|
||||
PATH="/usr/bin:$PATH"; export PATH
|
||||
|
||||
prog=`echo $0 | sed 's|.*/||'`
|
||||
case "$prog" in
|
||||
*less) more=less ;;
|
||||
*) more=more ;;
|
||||
esac
|
||||
|
||||
if test "`echo -n a`" = "-n a"; then
|
||||
# looks like a SysV system:
|
||||
n1=''; n2='\c'
|
||||
else
|
||||
n1='-n'; n2=''
|
||||
fi
|
||||
oldtty=`stty -g 2>/dev/null`
|
||||
if stty -cbreak 2>/dev/null; then
|
||||
cb='cbreak'; ncb='-cbreak'
|
||||
else
|
||||
# 'stty min 1' resets eof to ^a on both SunOS and SysV!
|
||||
cb='min 1 -icanon'; ncb='icanon eof ^d'
|
||||
fi
|
||||
if test $? -eq 0 && test -n "$oldtty"; then
|
||||
trap 'stty $oldtty 2>/dev/null; exit' 0 INT QUIT TRAP USR1 PIPE TERM
|
||||
else
|
||||
trap 'stty $ncb echo 2>/dev/null; exit' 0 INT QUIT TRAP USR1 PIPE TERM
|
||||
fi
|
||||
|
||||
if test $# = 0; then
|
||||
if test -t 0; then
|
||||
echo usage: $prog files...
|
||||
else
|
||||
bzip2 -cdfq | eval $more
|
||||
fi
|
||||
else
|
||||
FIRST=1
|
||||
for FILE
|
||||
do
|
||||
if test $FIRST -eq 0; then
|
||||
echo $n1 "--More--(Next file: $FILE)$n2"
|
||||
stty $cb -echo 2>/dev/null
|
||||
ANS=`dd bs=1 count=1 2>/dev/null`
|
||||
stty $ncb echo 2>/dev/null
|
||||
echo " "
|
||||
if test "$ANS" = 'e' || test "$ANS" = 'q'; then
|
||||
exit
|
||||
fi
|
||||
fi
|
||||
if test "$ANS" != 's'; then
|
||||
echo "------> $FILE <------"
|
||||
bzip2 -cdfq "$FILE" | eval $more
|
||||
fi
|
||||
if test -t; then
|
||||
FIRST=0
|
||||
fi
|
||||
done
|
||||
fi
|
||||
@@ -0,0 +1,253 @@
|
||||
#!/usr/bin/env perl
|
||||
|
||||
# WARNING: do not edit!
|
||||
# Generated by Makefile from tools/c_rehash.in
|
||||
# Copyright 1999-2022 The OpenSSL Project Authors. All Rights Reserved.
|
||||
#
|
||||
# Licensed under the Apache License 2.0 (the "License"). You may not use
|
||||
# this file except in compliance with the License. You can obtain a copy
|
||||
# in the file LICENSE in the source distribution or at
|
||||
# https://www.openssl.org/source/license.html
|
||||
|
||||
# Perl c_rehash script, scan all files in a directory
|
||||
# and add symbolic links to their hash values.
|
||||
|
||||
my $dir = "/usr/ssl";
|
||||
my $prefix = "/usr";
|
||||
|
||||
my $errorcount = 0;
|
||||
my $openssl = $ENV{OPENSSL} || "openssl";
|
||||
my $pwd;
|
||||
my $x509hash = "-subject_hash";
|
||||
my $crlhash = "-hash";
|
||||
my $verbose = 0;
|
||||
my $symlink_exists=eval {symlink("",""); 1};
|
||||
if ($^O eq "msys") { $symlink_exists=0 };
|
||||
my $removelinks = 1;
|
||||
|
||||
## Parse flags.
|
||||
while ( $ARGV[0] =~ /^-/ ) {
|
||||
my $flag = shift @ARGV;
|
||||
last if ( $flag eq '--');
|
||||
if ( $flag eq '-old') {
|
||||
$x509hash = "-subject_hash_old";
|
||||
$crlhash = "-hash_old";
|
||||
} elsif ( $flag eq '-h' || $flag eq '-help' ) {
|
||||
help();
|
||||
} elsif ( $flag eq '-n' ) {
|
||||
$removelinks = 0;
|
||||
} elsif ( $flag eq '-v' ) {
|
||||
$verbose++;
|
||||
}
|
||||
else {
|
||||
print STDERR "Usage error; try -h.\n";
|
||||
exit 1;
|
||||
}
|
||||
}
|
||||
|
||||
sub help {
|
||||
print "Usage: c_rehash [-old] [-h] [-help] [-v] [dirs...]\n";
|
||||
print " -old use old-style digest\n";
|
||||
print " -h or -help print this help text\n";
|
||||
print " -v print files removed and linked\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
eval "require Cwd";
|
||||
if (defined(&Cwd::getcwd)) {
|
||||
$pwd=Cwd::getcwd();
|
||||
} else {
|
||||
$pwd=`pwd`;
|
||||
chomp($pwd);
|
||||
}
|
||||
|
||||
# DOS/Win32 or Unix delimiter? Prefix our installdir, then search.
|
||||
my $path_delim = ($pwd =~ /^[a-z]\:/i) ? ';' : ':';
|
||||
$ENV{PATH} = "$prefix/bin" . ($ENV{PATH} ? $path_delim . $ENV{PATH} : "");
|
||||
|
||||
if (! -x $openssl) {
|
||||
my $found = 0;
|
||||
foreach (split /$path_delim/, $ENV{PATH}) {
|
||||
if (-x "$_/$openssl") {
|
||||
$found = 1;
|
||||
$openssl = "$_/$openssl";
|
||||
last;
|
||||
}
|
||||
}
|
||||
if ($found == 0) {
|
||||
print STDERR "c_rehash: rehashing skipped ('openssl' program not available)\n";
|
||||
exit 0;
|
||||
}
|
||||
}
|
||||
|
||||
if (@ARGV) {
|
||||
@dirlist = @ARGV;
|
||||
} elsif ($ENV{SSL_CERT_DIR}) {
|
||||
@dirlist = split /$path_delim/, $ENV{SSL_CERT_DIR};
|
||||
} else {
|
||||
$dirlist[0] = "$dir/certs";
|
||||
}
|
||||
|
||||
if (-d $dirlist[0]) {
|
||||
chdir $dirlist[0];
|
||||
$openssl="$pwd/$openssl" if (!-x $openssl);
|
||||
chdir $pwd;
|
||||
}
|
||||
|
||||
foreach (@dirlist) {
|
||||
if (-d $_ ) {
|
||||
if ( -w $_) {
|
||||
hash_dir($_);
|
||||
} else {
|
||||
print "Skipping $_, can't write\n";
|
||||
$errorcount++;
|
||||
}
|
||||
}
|
||||
}
|
||||
exit($errorcount);
|
||||
|
||||
sub copy_file {
|
||||
my ($src_fname, $dst_fname) = @_;
|
||||
|
||||
if (open(my $in, "<", $src_fname)) {
|
||||
if (open(my $out, ">", $dst_fname)) {
|
||||
print $out $_ while (<$in>);
|
||||
close $out;
|
||||
} else {
|
||||
warn "Cannot open $dst_fname for write, $!";
|
||||
}
|
||||
close $in;
|
||||
} else {
|
||||
warn "Cannot open $src_fname for read, $!";
|
||||
}
|
||||
}
|
||||
|
||||
sub hash_dir {
|
||||
my $dir = shift;
|
||||
my %hashlist;
|
||||
|
||||
print "Doing $dir\n";
|
||||
|
||||
if (!chdir $dir) {
|
||||
print STDERR "WARNING: Cannot chdir to '$dir', $!\n";
|
||||
return;
|
||||
}
|
||||
|
||||
opendir(DIR, ".") || print STDERR "WARNING: Cannot opendir '.', $!\n";
|
||||
my @flist = sort readdir(DIR);
|
||||
closedir DIR;
|
||||
if ( $removelinks ) {
|
||||
# Delete any existing symbolic links
|
||||
foreach (grep {/^[\da-f]+\.r{0,1}\d+$/} @flist) {
|
||||
if (-l $_) {
|
||||
print "unlink $_\n" if $verbose;
|
||||
unlink $_ || warn "Can't unlink $_, $!\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
FILE: foreach $fname (grep {/\.(pem|crt|cer|crl)$/} @flist) {
|
||||
# Check to see if certificates and/or CRLs present.
|
||||
my ($cert, $crl) = check_file($fname);
|
||||
if (!$cert && !$crl) {
|
||||
print STDERR "WARNING: $fname does not contain a certificate or CRL: skipping\n";
|
||||
next;
|
||||
}
|
||||
link_hash_cert($fname) if ($cert);
|
||||
link_hash_crl($fname) if ($crl);
|
||||
}
|
||||
|
||||
chdir $pwd;
|
||||
}
|
||||
|
||||
sub check_file {
|
||||
my ($is_cert, $is_crl) = (0,0);
|
||||
my $fname = $_[0];
|
||||
|
||||
open(my $in, "<", $fname);
|
||||
while(<$in>) {
|
||||
if (/^-----BEGIN (.*)-----/) {
|
||||
my $hdr = $1;
|
||||
if ($hdr =~ /^(X509 |TRUSTED |)CERTIFICATE$/) {
|
||||
$is_cert = 1;
|
||||
last if ($is_crl);
|
||||
} elsif ($hdr eq "X509 CRL") {
|
||||
$is_crl = 1;
|
||||
last if ($is_cert);
|
||||
}
|
||||
}
|
||||
}
|
||||
close $in;
|
||||
return ($is_cert, $is_crl);
|
||||
}
|
||||
|
||||
sub compute_hash {
|
||||
my $fh;
|
||||
if ( $^O eq "VMS" ) {
|
||||
# VMS uses the open through shell
|
||||
# The file names are safe there and list form is unsupported
|
||||
if (!open($fh, "-|", join(' ', @_))) {
|
||||
print STDERR "Cannot compute hash on '$fname'\n";
|
||||
return;
|
||||
}
|
||||
} else {
|
||||
if (!open($fh, "-|", @_)) {
|
||||
print STDERR "Cannot compute hash on '$fname'\n";
|
||||
return;
|
||||
}
|
||||
}
|
||||
return (<$fh>, <$fh>);
|
||||
}
|
||||
|
||||
# Link a certificate to its subject name hash value, each hash is of
|
||||
# the form <hash>.<n> where n is an integer. If the hash value already exists
|
||||
# then we need to up the value of n, unless its a duplicate in which
|
||||
# case we skip the link. We check for duplicates by comparing the
|
||||
# certificate fingerprints
|
||||
|
||||
sub link_hash_cert {
|
||||
link_hash($_[0], 'cert');
|
||||
}
|
||||
|
||||
# Same as above except for a CRL. CRL links are of the form <hash>.r<n>
|
||||
|
||||
sub link_hash_crl {
|
||||
link_hash($_[0], 'crl');
|
||||
}
|
||||
|
||||
sub link_hash {
|
||||
my ($fname, $type) = @_;
|
||||
my $is_cert = $type eq 'cert';
|
||||
|
||||
my ($hash, $fprint) = compute_hash($openssl,
|
||||
$is_cert ? "x509" : "crl",
|
||||
$is_cert ? $x509hash : $crlhash,
|
||||
"-fingerprint", "-noout",
|
||||
"-in", $fname);
|
||||
chomp $hash;
|
||||
$hash =~ s/^.*=// if !$is_cert;
|
||||
chomp $fprint;
|
||||
return if !$hash;
|
||||
$fprint =~ s/^.*=//;
|
||||
$fprint =~ tr/://d;
|
||||
my $suffix = 0;
|
||||
# Search for an unused hash filename
|
||||
my $crlmark = $is_cert ? "" : "r";
|
||||
while(exists $hashlist{"$hash.$crlmark$suffix"}) {
|
||||
# Hash matches: if fingerprint matches its a duplicate cert
|
||||
if ($hashlist{"$hash.$crlmark$suffix"} eq $fprint) {
|
||||
my $what = $is_cert ? 'certificate' : 'CRL';
|
||||
print STDERR "WARNING: Skipping duplicate $what $fname\n";
|
||||
return;
|
||||
}
|
||||
$suffix++;
|
||||
}
|
||||
$hash .= ".$crlmark$suffix";
|
||||
if ($symlink_exists) {
|
||||
print "link $fname -> $hash\n" if $verbose;
|
||||
symlink $fname, $hash || warn "Can't symlink, $!";
|
||||
} else {
|
||||
print "copy $fname -> $hash\n" if $verbose;
|
||||
copy_file($fname, $hash);
|
||||
}
|
||||
$hashlist{$hash} = $fprint;
|
||||
}
|
||||
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
@@ -0,0 +1,577 @@
|
||||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0; # ^ Run only under a shell
|
||||
#!/usr/bin/perl
|
||||
|
||||
=head1 NAME
|
||||
|
||||
corelist - a commandline frontend to Module::CoreList
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
See L<Module::CoreList> for one.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
corelist -v
|
||||
corelist [-a|-d] <ModuleName> | /<ModuleRegex>/ [<ModuleVersion>] ...
|
||||
corelist [-v <PerlVersion>] [ <ModuleName> | /<ModuleRegex>/ ] ...
|
||||
corelist [-r <PerlVersion>] ...
|
||||
corelist --utils [-d] <UtilityName> [<UtilityName>] ...
|
||||
corelist --utils -v <PerlVersion>
|
||||
corelist --feature <FeatureName> [<FeatureName>] ...
|
||||
corelist --diff PerlVersion PerlVersion
|
||||
corelist --upstream <ModuleName>
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
=over
|
||||
|
||||
=item -a
|
||||
|
||||
lists all versions of the given module (or the matching modules, in case you
|
||||
used a module regexp) in the perls Module::CoreList knows about.
|
||||
|
||||
corelist -a Unicode
|
||||
|
||||
Unicode was first released with perl v5.6.2
|
||||
v5.6.2 3.0.1
|
||||
v5.8.0 3.2.0
|
||||
v5.8.1 4.0.0
|
||||
v5.8.2 4.0.0
|
||||
v5.8.3 4.0.0
|
||||
v5.8.4 4.0.1
|
||||
v5.8.5 4.0.1
|
||||
v5.8.6 4.0.1
|
||||
v5.8.7 4.1.0
|
||||
v5.8.8 4.1.0
|
||||
v5.8.9 5.1.0
|
||||
v5.9.0 4.0.0
|
||||
v5.9.1 4.0.0
|
||||
v5.9.2 4.0.1
|
||||
v5.9.3 4.1.0
|
||||
v5.9.4 4.1.0
|
||||
v5.9.5 5.0.0
|
||||
v5.10.0 5.0.0
|
||||
v5.10.1 5.1.0
|
||||
v5.11.0 5.1.0
|
||||
v5.11.1 5.1.0
|
||||
v5.11.2 5.1.0
|
||||
v5.11.3 5.2.0
|
||||
v5.11.4 5.2.0
|
||||
v5.11.5 5.2.0
|
||||
v5.12.0 5.2.0
|
||||
v5.12.1 5.2.0
|
||||
v5.12.2 5.2.0
|
||||
v5.12.3 5.2.0
|
||||
v5.12.4 5.2.0
|
||||
v5.13.0 5.2.0
|
||||
v5.13.1 5.2.0
|
||||
v5.13.2 5.2.0
|
||||
v5.13.3 5.2.0
|
||||
v5.13.4 5.2.0
|
||||
v5.13.5 5.2.0
|
||||
v5.13.6 5.2.0
|
||||
v5.13.7 6.0.0
|
||||
v5.13.8 6.0.0
|
||||
v5.13.9 6.0.0
|
||||
v5.13.10 6.0.0
|
||||
v5.13.11 6.0.0
|
||||
v5.14.0 6.0.0
|
||||
v5.14.1 6.0.0
|
||||
v5.15.0 6.0.0
|
||||
|
||||
=item -d
|
||||
|
||||
finds the first perl version where a module has been released by
|
||||
date, and not by version number (as is the default).
|
||||
|
||||
=item --diff
|
||||
|
||||
Given two versions of perl, this prints a human-readable table of all module
|
||||
changes between the two. The output format may change in the future, and is
|
||||
meant for I<humans>, not programs. For programs, use the L<Module::CoreList>
|
||||
API.
|
||||
|
||||
=item -? or -help
|
||||
|
||||
help! help! help! to see more help, try --man.
|
||||
|
||||
=item -man
|
||||
|
||||
all of the help
|
||||
|
||||
=item -v
|
||||
|
||||
lists all of the perl release versions we got the CoreList for.
|
||||
|
||||
If you pass a version argument (value of C<$]>, like C<5.00503> or C<5.008008>),
|
||||
you get a list of all the modules and their respective versions.
|
||||
(If you have the C<version> module, you can also use new-style version numbers,
|
||||
like C<5.8.8>.)
|
||||
|
||||
In module filtering context, it can be used as Perl version filter.
|
||||
|
||||
=item -r
|
||||
|
||||
lists all of the perl releases and when they were released
|
||||
|
||||
If you pass a perl version you get the release date for that version only.
|
||||
|
||||
=item --utils
|
||||
|
||||
lists the first version of perl each named utility program was released with
|
||||
|
||||
May be used with -d to modify the first release criteria.
|
||||
|
||||
If used with -v <version> then all utilities released with that version of perl
|
||||
are listed, and any utility programs named on the command line are ignored.
|
||||
|
||||
=item --feature, -f
|
||||
|
||||
lists the first version bundle of each named feature given
|
||||
|
||||
=item --upstream, -u
|
||||
|
||||
Shows if the given module is primarily maintained in perl core or on CPAN
|
||||
and bug tracker URL.
|
||||
|
||||
=back
|
||||
|
||||
As a special case, if you specify the module name C<Unicode>, you'll get
|
||||
the version number of the Unicode Character Database bundled with the
|
||||
requested perl versions.
|
||||
|
||||
=cut
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use Module::CoreList;
|
||||
use Getopt::Long qw(:config no_ignore_case);
|
||||
use Pod::Usage;
|
||||
use strict;
|
||||
use warnings;
|
||||
use List::Util qw/maxstr/;
|
||||
|
||||
my %Opts;
|
||||
|
||||
GetOptions(
|
||||
\%Opts,
|
||||
qw[ help|?! man! r|release:s v|version:s a! d diff|D utils feature|f u|upstream ]
|
||||
);
|
||||
|
||||
pod2usage(1) if $Opts{help};
|
||||
pod2usage(-verbose=>2) if $Opts{man};
|
||||
|
||||
if(exists $Opts{r} ){
|
||||
if ( !$Opts{r} ) {
|
||||
print "\nModule::CoreList has release info for the following perl versions:\n";
|
||||
my $versions = { };
|
||||
my $max_ver_len = max_mod_len(\%Module::CoreList::released);
|
||||
for my $ver ( grep !/0[01]0$/, sort keys %Module::CoreList::released ) {
|
||||
printf "%-${max_ver_len}s %s\n", format_perl_version($ver), $Module::CoreList::released{$ver};
|
||||
}
|
||||
print "\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
my $num_r = numify_version( $Opts{r} );
|
||||
my $version_hash = Module::CoreList->find_version($num_r);
|
||||
|
||||
if( !$version_hash ) {
|
||||
print "\nModule::CoreList has no info on perl $Opts{r}\n\n";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
printf "Perl %s was released on %s\n\n", format_perl_version($num_r), $Module::CoreList::released{$num_r};
|
||||
exit 0;
|
||||
}
|
||||
|
||||
if(exists $Opts{v} ){
|
||||
if( !$Opts{v} ) {
|
||||
print "\nModule::CoreList has info on the following perl versions:\n";
|
||||
print format_perl_version($_)."\n" for grep !/0[01]0$/, sort keys %Module::CoreList::version;
|
||||
print "\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
my $num_v = numify_version( $Opts{v} );
|
||||
|
||||
if ($Opts{utils}) {
|
||||
utilities_in_version($num_v);
|
||||
exit 0;
|
||||
}
|
||||
|
||||
my $version_hash = Module::CoreList->find_version($num_v);
|
||||
|
||||
if( !$version_hash ) {
|
||||
print "\nModule::CoreList has no info on perl $Opts{v}\n\n";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
if ( !@ARGV ) {
|
||||
print "\nThe following modules were in perl $Opts{v} CORE\n";
|
||||
my $max_mod_len = max_mod_len($version_hash);
|
||||
for my $mod ( sort keys %$version_hash ) {
|
||||
printf "%-${max_mod_len}s %s\n", $mod, $version_hash->{$mod} || "";
|
||||
}
|
||||
print "\n";
|
||||
exit 0;
|
||||
}
|
||||
}
|
||||
|
||||
if ($Opts{diff}) {
|
||||
if(@ARGV != 2) {
|
||||
die "\nprovide exactly two perl core versions to diff with --diff\n";
|
||||
}
|
||||
|
||||
my ($old_ver, $new_ver) = @ARGV;
|
||||
|
||||
my $old = numify_version($old_ver);
|
||||
if ( !Module::CoreList->find_version($old) ) {
|
||||
print "\nModule::CoreList has no info on perl $old_ver\n\n";
|
||||
exit 1;
|
||||
}
|
||||
my $new = numify_version($new_ver);
|
||||
if ( !Module::CoreList->find_version($new) ) {
|
||||
print "\nModule::CoreList has no info on perl $new_ver\n\n";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
my %diff = Module::CoreList::changes_between($old, $new);
|
||||
|
||||
for my $lib (sort keys %diff) {
|
||||
my $diff = $diff{$lib};
|
||||
|
||||
my $was = ! exists $diff->{left} ? '(absent)'
|
||||
: ! defined $diff->{left} ? '(undef)'
|
||||
: $diff->{left};
|
||||
|
||||
my $now = ! exists $diff->{right} ? '(absent)'
|
||||
: ! defined $diff->{right} ? '(undef)'
|
||||
: $diff->{right};
|
||||
|
||||
printf "%-35s %10s %10s\n", $lib, $was, $now;
|
||||
}
|
||||
exit(0);
|
||||
}
|
||||
|
||||
if ($Opts{utils}) {
|
||||
die "\n--utils only available with perl v5.19.1 or greater\n"
|
||||
if $] < 5.019001;
|
||||
|
||||
die "\nprovide at least one utility name to --utils\n"
|
||||
unless @ARGV;
|
||||
|
||||
warn "\n-a has no effect when --utils is used\n" if $Opts{a};
|
||||
warn "\n--diff has no effect when --utils is used\n" if $Opts{diff};
|
||||
warn "\n--upstream, or -u, has no effect when --utils is used\n" if $Opts{u};
|
||||
|
||||
my $when = maxstr(values %Module::CoreList::released);
|
||||
print "\n","Data for $when\n";
|
||||
|
||||
utility_version($_) for @ARGV;
|
||||
|
||||
exit(0);
|
||||
}
|
||||
|
||||
if ($Opts{feature}) {
|
||||
die "\n--feature is only available with perl v5.16.0 or greater\n"
|
||||
if $] < 5.016;
|
||||
|
||||
die "\nprovide at least one feature name to --feature\n"
|
||||
unless @ARGV;
|
||||
|
||||
no warnings 'once';
|
||||
require feature;
|
||||
|
||||
my %feature2version;
|
||||
my @bundles = map { $_->[0] }
|
||||
sort { $b->[1] <=> $a->[1] }
|
||||
map { [$_, numify_version($_)] }
|
||||
grep { not /[^0-9.]/ }
|
||||
keys %feature::feature_bundle;
|
||||
|
||||
for my $version (@bundles) {
|
||||
$feature2version{$_} = $version =~ /^\d\.\d+$/ ? "$version.0" : $version
|
||||
for @{ $feature::feature_bundle{$version} };
|
||||
}
|
||||
|
||||
# allow internal feature names, just in case someone gives us __SUB__
|
||||
# instead of current_sub.
|
||||
while (my ($name, $internal) = each %feature::feature) {
|
||||
$internal =~ s/^feature_//;
|
||||
$feature2version{$internal} = $feature2version{$name}
|
||||
if $feature2version{$name};
|
||||
}
|
||||
|
||||
my $when = maxstr(values %Module::CoreList::released);
|
||||
print "\n","Data for $when\n";
|
||||
|
||||
for my $feature (@ARGV) {
|
||||
print "feature \"$feature\" ",
|
||||
exists $feature2version{$feature}
|
||||
? "was first released with the perl "
|
||||
. format_perl_version(numify_version($feature2version{$feature}))
|
||||
. " feature bundle\n"
|
||||
: "doesn't exist (or so I think)\n";
|
||||
}
|
||||
exit(0);
|
||||
}
|
||||
|
||||
if ( !@ARGV ) {
|
||||
pod2usage(0);
|
||||
}
|
||||
|
||||
while (@ARGV) {
|
||||
my ($mod, $ver);
|
||||
if ($ARGV[0] =~ /=/) {
|
||||
($mod, $ver) = split /=/, shift @ARGV;
|
||||
} else {
|
||||
$mod = shift @ARGV;
|
||||
$ver = (@ARGV && $ARGV[0] =~ /^\d/) ? shift @ARGV : "";
|
||||
}
|
||||
|
||||
if ($mod !~ m|^/(.*)/([imosx]*)$|) { # not a regex
|
||||
module_version($mod,$ver);
|
||||
} else {
|
||||
my $re;
|
||||
eval { $re = $2 ? qr/(?$2)($1)/ : qr/$1/; }; # trap exceptions while building regex
|
||||
if ($@) {
|
||||
# regex errors are usually like 'Quantifier follow nothing in regex; marked by ...'
|
||||
# then we drop text after ';' to shorten message
|
||||
my $errmsg = $@ =~ /(.*);/ ? $1 : $@;
|
||||
warn "\n$mod is a bad regex: $errmsg\n";
|
||||
next;
|
||||
}
|
||||
my @mod = Module::CoreList->find_modules($re);
|
||||
if (@mod) {
|
||||
module_version($_, $ver) for @mod;
|
||||
} else {
|
||||
$ver |= '';
|
||||
print "\n$mod $ver has no match in CORE (or so I think)\n";
|
||||
}
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
exit();
|
||||
|
||||
sub module_version {
|
||||
my($mod,$ver) = @_;
|
||||
|
||||
if ( $Opts{v} ) {
|
||||
my $numeric_v = numify_version($Opts{v});
|
||||
my $version_hash = Module::CoreList->find_version($numeric_v);
|
||||
if ($version_hash) {
|
||||
print $mod, " ", $version_hash->{$mod} || 'undef', "\n";
|
||||
return;
|
||||
}
|
||||
else { die "Shouldn't happen" }
|
||||
}
|
||||
|
||||
my $ret = $Opts{d}
|
||||
? Module::CoreList->first_release_by_date(@_)
|
||||
: Module::CoreList->first_release(@_);
|
||||
my $msg = $mod;
|
||||
$msg .= " $ver" if $ver;
|
||||
|
||||
my $rem = $Opts{d}
|
||||
? Module::CoreList->removed_from_by_date($mod)
|
||||
: Module::CoreList->removed_from($mod);
|
||||
|
||||
my $when = maxstr(values %Module::CoreList::released);
|
||||
print "\n","Data for $when\n";
|
||||
|
||||
if( defined $ret ) {
|
||||
my $deprecated = Module::CoreList->deprecated_in($mod);
|
||||
$msg .= " was ";
|
||||
$msg .= "first " unless $ver;
|
||||
$msg .= "released with perl " . format_perl_version($ret);
|
||||
$msg .= ( $rem ? ',' : ' and' ) . " deprecated (will be CPAN-only) in " . format_perl_version($deprecated) if $deprecated;
|
||||
$msg .= " and removed from " . format_perl_version($rem) if $rem;
|
||||
} else {
|
||||
$msg .= " was not in CORE (or so I think)";
|
||||
}
|
||||
|
||||
print $msg,"\n";
|
||||
|
||||
if( defined $ret and exists $Opts{u} ) {
|
||||
my $upstream = $Module::CoreList::upstream{$mod};
|
||||
$upstream = 'undef' unless $upstream;
|
||||
print "upstream: $upstream\n";
|
||||
if ( $upstream ne 'blead' ) {
|
||||
my $bugtracker = $Module::CoreList::bug_tracker{$mod};
|
||||
$bugtracker = 'unknown' unless $bugtracker;
|
||||
print "bug tracker: $bugtracker\n";
|
||||
}
|
||||
}
|
||||
|
||||
if(defined $ret and exists $Opts{a} and $Opts{a}){
|
||||
display_a($mod);
|
||||
}
|
||||
}
|
||||
|
||||
sub utility_version {
|
||||
my ($utility) = @_;
|
||||
|
||||
require Module::CoreList::Utils;
|
||||
|
||||
my $released = $Opts{d}
|
||||
? Module::CoreList::Utils->first_release_by_date($utility)
|
||||
: Module::CoreList::Utils->first_release($utility);
|
||||
|
||||
my $removed = $Opts{d}
|
||||
? Module::CoreList::Utils->removed_from_by_date($utility)
|
||||
: Module::CoreList::Utils->removed_from($utility);
|
||||
|
||||
if ($released) {
|
||||
print "$utility was first released with perl ", format_perl_version($released);
|
||||
print " and later removed in ", format_perl_version($removed)
|
||||
if $removed;
|
||||
print "\n";
|
||||
} else {
|
||||
print "$utility was not in CORE (or so I think)\n";
|
||||
}
|
||||
}
|
||||
|
||||
sub utilities_in_version {
|
||||
my ($version) = @_;
|
||||
|
||||
require Module::CoreList::Utils;
|
||||
|
||||
my @utilities = Module::CoreList::Utils->utilities($version);
|
||||
|
||||
if (not @utilities) {
|
||||
print "\nModule::CoreList::Utils has no info on perl $version\n\n";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
print "\nThe following utilities were in perl ",
|
||||
format_perl_version($version), " CORE\n";
|
||||
print "$_\n" for sort { lc($a) cmp lc($b) } @utilities;
|
||||
print "\n";
|
||||
}
|
||||
|
||||
|
||||
sub max_mod_len {
|
||||
my $versions = shift;
|
||||
my $max = 0;
|
||||
for my $mod (keys %$versions) {
|
||||
$max = max($max, length $mod);
|
||||
}
|
||||
|
||||
return $max;
|
||||
}
|
||||
|
||||
sub max {
|
||||
my($this, $that) = @_;
|
||||
return $this if $this > $that;
|
||||
return $that;
|
||||
}
|
||||
|
||||
sub display_a {
|
||||
my $mod = shift;
|
||||
|
||||
for my $v (grep !/0[01]0$/, sort keys %Module::CoreList::version ) {
|
||||
next unless exists $Module::CoreList::version{$v}{$mod};
|
||||
|
||||
my $mod_v = $Module::CoreList::version{$v}{$mod} || 'undef';
|
||||
printf " %-10s %-10s\n", format_perl_version($v), $mod_v;
|
||||
}
|
||||
print "\n";
|
||||
}
|
||||
|
||||
|
||||
{
|
||||
my $have_version_pm;
|
||||
sub have_version_pm {
|
||||
return $have_version_pm if defined $have_version_pm;
|
||||
return $have_version_pm = eval { require version; 1 };
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub format_perl_version {
|
||||
my $v = shift;
|
||||
return $v if $v < 5.006 or !have_version_pm;
|
||||
return version->new($v)->normal;
|
||||
}
|
||||
|
||||
|
||||
sub numify_version {
|
||||
my $ver = shift;
|
||||
if ($ver =~ /\..+\./) {
|
||||
have_version_pm()
|
||||
or die "You need to install version.pm to use dotted version numbers\n";
|
||||
$ver = version->new($ver)->numify;
|
||||
}
|
||||
$ver += 0;
|
||||
return $ver;
|
||||
}
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
$ corelist File::Spec
|
||||
|
||||
File::Spec was first released with perl 5.005
|
||||
|
||||
$ corelist File::Spec 0.83
|
||||
|
||||
File::Spec 0.83 was released with perl 5.007003
|
||||
|
||||
$ corelist File::Spec 0.89
|
||||
|
||||
File::Spec 0.89 was not in CORE (or so I think)
|
||||
|
||||
$ corelist File::Spec::Aliens
|
||||
|
||||
File::Spec::Aliens was not in CORE (or so I think)
|
||||
|
||||
$ corelist /IPC::Open/
|
||||
|
||||
IPC::Open2 was first released with perl 5
|
||||
|
||||
IPC::Open3 was first released with perl 5
|
||||
|
||||
$ corelist /MANIFEST/i
|
||||
|
||||
ExtUtils::Manifest was first released with perl 5.001
|
||||
|
||||
$ corelist /Template/
|
||||
|
||||
/Template/ has no match in CORE (or so I think)
|
||||
|
||||
$ corelist -v 5.8.8 B
|
||||
|
||||
B 1.09_01
|
||||
|
||||
$ corelist -v 5.8.8 /^B::/
|
||||
|
||||
B::Asmdata 1.01
|
||||
B::Assembler 0.07
|
||||
B::Bblock 1.02_01
|
||||
B::Bytecode 1.01_01
|
||||
B::C 1.04_01
|
||||
B::CC 1.00_01
|
||||
B::Concise 0.66
|
||||
B::Debug 1.02_01
|
||||
B::Deparse 0.71
|
||||
B::Disassembler 1.05
|
||||
B::Lint 1.03
|
||||
B::O 1.00
|
||||
B::Showlex 1.02
|
||||
B::Stackobj 1.00
|
||||
B::Stash 1.00
|
||||
B::Terse 1.03_01
|
||||
B::Xref 1.01
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2002-2007 by D.H. aka PodMaster
|
||||
|
||||
Currently maintained by the perl 5 porters E<lt>perl5-porters@perl.orgE<gt>.
|
||||
|
||||
This program is distributed under the same terms as perl itself.
|
||||
See http://perl.org/ or http://cpan.org/ for more info on that.
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,352 @@
|
||||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0; # ^ Run only under a shell
|
||||
#!/usr/local/bin/perl
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
|
||||
use App::Cpan;
|
||||
use CPAN::Version;
|
||||
my $minver = '1.64';
|
||||
if ( CPAN::Version->vlt($App::Cpan::VERSION, $minver) ) {
|
||||
warn "WARNING: your version of App::Cpan is $App::Cpan::VERSION while we would expect at least $minver";
|
||||
}
|
||||
$VERSION = '1.64';
|
||||
|
||||
my $rc = App::Cpan->run( @ARGV );
|
||||
|
||||
# will this work under Strawberry Perl?
|
||||
exit( $rc || 0 );
|
||||
|
||||
=head1 NAME
|
||||
|
||||
cpan - easily interact with CPAN from the command line
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# with arguments and no switches, installs specified modules
|
||||
cpan module_name [ module_name ... ]
|
||||
|
||||
# with switches, installs modules with extra behavior
|
||||
cpan [-cfFimtTw] module_name [ module_name ... ]
|
||||
|
||||
# use local::lib
|
||||
cpan -I module_name [ module_name ... ]
|
||||
|
||||
# one time mirror override for faster mirrors
|
||||
cpan -p ...
|
||||
|
||||
# with just the dot, install from the distribution in the
|
||||
# current directory
|
||||
cpan .
|
||||
|
||||
# without arguments, starts CPAN.pm shell
|
||||
cpan
|
||||
|
||||
# without arguments, but some switches
|
||||
cpan [-ahpruvACDLOPX]
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This script provides a command interface (not a shell) to CPAN. At the
|
||||
moment it uses CPAN.pm to do the work, but it is not a one-shot command
|
||||
runner for CPAN.pm.
|
||||
|
||||
=head2 Options
|
||||
|
||||
=over 4
|
||||
|
||||
=item -a
|
||||
|
||||
Creates a CPAN.pm autobundle with CPAN::Shell->autobundle.
|
||||
|
||||
=item -A module [ module ... ]
|
||||
|
||||
Shows the primary maintainers for the specified modules.
|
||||
|
||||
=item -c module
|
||||
|
||||
Runs a `make clean` in the specified module's directories.
|
||||
|
||||
=item -C module [ module ... ]
|
||||
|
||||
Show the F<Changes> files for the specified modules
|
||||
|
||||
=item -D module [ module ... ]
|
||||
|
||||
Show the module details. This prints one line for each out-of-date module
|
||||
(meaning, modules locally installed but have newer versions on CPAN).
|
||||
Each line has three columns: module name, local version, and CPAN
|
||||
version.
|
||||
|
||||
=item -f
|
||||
|
||||
Force the specified action, when it normally would have failed. Use this
|
||||
to install a module even if its tests fail. When you use this option,
|
||||
-i is not optional for installing a module when you need to force it:
|
||||
|
||||
% cpan -f -i Module::Foo
|
||||
|
||||
=item -F
|
||||
|
||||
Turn off CPAN.pm's attempts to lock anything. You should be careful with
|
||||
this since you might end up with multiple scripts trying to muck in the
|
||||
same directory. This isn't so much of a concern if you're loading a special
|
||||
config with C<-j>, and that config sets up its own work directories.
|
||||
|
||||
=item -g module [ module ... ]
|
||||
|
||||
Downloads to the current directory the latest distribution of the module.
|
||||
|
||||
=item -G module [ module ... ]
|
||||
|
||||
UNIMPLEMENTED
|
||||
|
||||
Download to the current directory the latest distribution of the
|
||||
modules, unpack each distribution, and create a git repository for each
|
||||
distribution.
|
||||
|
||||
If you want this feature, check out Yanick Champoux's C<Git::CPAN::Patch>
|
||||
distribution.
|
||||
|
||||
=item -h
|
||||
|
||||
Print a help message and exit. When you specify C<-h>, it ignores all
|
||||
of the other options and arguments.
|
||||
|
||||
=item -i module [ module ... ]
|
||||
|
||||
Install the specified modules. With no other switches, this switch
|
||||
is implied.
|
||||
|
||||
=item -I
|
||||
|
||||
Load C<local::lib> (think like C<-I> for loading lib paths). Too bad
|
||||
C<-l> was already taken.
|
||||
|
||||
=item -j Config.pm
|
||||
|
||||
Load the file that has the CPAN configuration data. This should have the
|
||||
same format as the standard F<CPAN/Config.pm> file, which defines
|
||||
C<$CPAN::Config> as an anonymous hash.
|
||||
|
||||
=item -J
|
||||
|
||||
Dump the configuration in the same format that CPAN.pm uses. This is useful
|
||||
for checking the configuration as well as using the dump as a starting point
|
||||
for a new, custom configuration.
|
||||
|
||||
=item -l
|
||||
|
||||
List all installed modules with their versions
|
||||
|
||||
=item -L author [ author ... ]
|
||||
|
||||
List the modules by the specified authors.
|
||||
|
||||
=item -m
|
||||
|
||||
Make the specified modules.
|
||||
|
||||
=item -M mirror1,mirror2,...
|
||||
|
||||
A comma-separated list of mirrors to use for just this run. The C<-P>
|
||||
option can find them for you automatically.
|
||||
|
||||
=item -n
|
||||
|
||||
Do a dry run, but don't actually install anything. (unimplemented)
|
||||
|
||||
=item -O
|
||||
|
||||
Show the out-of-date modules.
|
||||
|
||||
=item -p
|
||||
|
||||
Ping the configured mirrors and print a report
|
||||
|
||||
=item -P
|
||||
|
||||
Find the best mirrors you could be using and use them for the current
|
||||
session.
|
||||
|
||||
=item -r
|
||||
|
||||
Recompiles dynamically loaded modules with CPAN::Shell->recompile.
|
||||
|
||||
=item -s
|
||||
|
||||
Drop in the CPAN.pm shell. This command does this automatically if you don't
|
||||
specify any arguments.
|
||||
|
||||
=item -t module [ module ... ]
|
||||
|
||||
Run a `make test` on the specified modules.
|
||||
|
||||
=item -T
|
||||
|
||||
Do not test modules. Simply install them.
|
||||
|
||||
=item -u
|
||||
|
||||
Upgrade all installed modules. Blindly doing this can really break things,
|
||||
so keep a backup.
|
||||
|
||||
=item -v
|
||||
|
||||
Print the script version and CPAN.pm version then exit.
|
||||
|
||||
=item -V
|
||||
|
||||
Print detailed information about the cpan client.
|
||||
|
||||
=item -w
|
||||
|
||||
UNIMPLEMENTED
|
||||
|
||||
Turn on cpan warnings. This checks various things, like directory permissions,
|
||||
and tells you about problems you might have.
|
||||
|
||||
=item -x module [ module ... ]
|
||||
|
||||
Find close matches to the named modules that you think you might have
|
||||
mistyped. This requires the optional installation of Text::Levenshtein or
|
||||
Text::Levenshtein::Damerau.
|
||||
|
||||
=item -X
|
||||
|
||||
Dump all the namespaces to standard output.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Examples
|
||||
|
||||
# print a help message
|
||||
cpan -h
|
||||
|
||||
# print the version numbers
|
||||
cpan -v
|
||||
|
||||
# create an autobundle
|
||||
cpan -a
|
||||
|
||||
# recompile modules
|
||||
cpan -r
|
||||
|
||||
# upgrade all installed modules
|
||||
cpan -u
|
||||
|
||||
# install modules ( sole -i is optional )
|
||||
cpan -i Netscape::Booksmarks Business::ISBN
|
||||
|
||||
# force install modules ( must use -i )
|
||||
cpan -fi CGI::Minimal URI
|
||||
|
||||
# install modules but without testing them
|
||||
cpan -Ti CGI::Minimal URI
|
||||
|
||||
=head2 Environment variables
|
||||
|
||||
There are several components in CPAN.pm that use environment variables.
|
||||
The build tools, L<ExtUtils::MakeMaker> and L<Module::Build> use some,
|
||||
while others matter to the levels above them. Some of these are specified
|
||||
by the Perl Toolchain Gang:
|
||||
|
||||
Lancaster Consensus: L<https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/lancaster-consensus.md>
|
||||
|
||||
Oslo Consensus: L<https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/oslo-consensus.md>
|
||||
|
||||
=over 4
|
||||
|
||||
=item NONINTERACTIVE_TESTING
|
||||
|
||||
Assume no one is paying attention and skips prompts for distributions
|
||||
that do that correctly. C<cpan(1)> sets this to C<1> unless it already
|
||||
has a value (even if that value is false).
|
||||
|
||||
=item PERL_MM_USE_DEFAULT
|
||||
|
||||
Use the default answer for a prompted questions. C<cpan(1)> sets this
|
||||
to C<1> unless it already has a value (even if that value is false).
|
||||
|
||||
=item CPAN_OPTS
|
||||
|
||||
As with C<PERL5OPT>, a string of additional C<cpan(1)> options to
|
||||
add to those you specify on the command line.
|
||||
|
||||
=item CPANSCRIPT_LOGLEVEL
|
||||
|
||||
The log level to use, with either the embedded, minimal logger or
|
||||
L<Log::Log4perl> if it is installed. Possible values are the same as
|
||||
the C<Log::Log4perl> levels: C<TRACE>, C<DEBUG>, C<INFO>, C<WARN>,
|
||||
C<ERROR>, and C<FATAL>. The default is C<INFO>.
|
||||
|
||||
=item GIT_COMMAND
|
||||
|
||||
The path to the C<git> binary to use for the Git features. The default
|
||||
is C</usr/local/bin/git>.
|
||||
|
||||
=back
|
||||
|
||||
=head1 EXIT VALUES
|
||||
|
||||
The script exits with zero if it thinks that everything worked, or a
|
||||
positive number if it thinks that something failed. Note, however, that
|
||||
in some cases it has to divine a failure by the output of things it does
|
||||
not control. For now, the exit codes are vague:
|
||||
|
||||
1 An unknown error
|
||||
|
||||
2 The was an external problem
|
||||
|
||||
4 There was an internal problem with the script
|
||||
|
||||
8 A module failed to install
|
||||
|
||||
=head1 TO DO
|
||||
|
||||
* one shot configuration values from the command line
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
* none noted
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
Most behaviour, including environment variables and configuration,
|
||||
comes directly from CPAN.pm.
|
||||
|
||||
=head1 SOURCE AVAILABILITY
|
||||
|
||||
This code is in Github in the CPAN.pm repository:
|
||||
|
||||
https://github.com/andk/cpanpm
|
||||
|
||||
The source used to be tracked separately in another GitHub repo,
|
||||
but the canonical source is now in the above repo.
|
||||
|
||||
=head1 CREDITS
|
||||
|
||||
Japheth Cleaver added the bits to allow a forced install (-f).
|
||||
|
||||
Jim Brandt suggest and provided the initial implementation for the
|
||||
up-to-date and Changes features.
|
||||
|
||||
Adam Kennedy pointed out that exit() causes problems on Windows
|
||||
where this script ends up with a .bat extension
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
brian d foy, C<< <bdfoy@cpan.org> >>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2001-2015, brian d foy, All Rights Reserved.
|
||||
|
||||
You may redistribute this under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,149 @@
|
||||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0; # ^ Run only under a shell
|
||||
#!./perl
|
||||
use 5.008001;
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use strict;
|
||||
use warnings;
|
||||
use Encode;
|
||||
use Getopt::Std;
|
||||
use Carp;
|
||||
use Encode::Guess;
|
||||
$Getopt::Std::STANDARD_HELP_VERSION = 1;
|
||||
|
||||
my %opt;
|
||||
getopts( "huSs:", \%opt );
|
||||
my @suspect_list;
|
||||
list_valid_suspects() and exit if $opt{S};
|
||||
@suspect_list = split /:,/, $opt{s} if $opt{s};
|
||||
HELP_MESSAGE() if $opt{h};
|
||||
HELP_MESSAGE() unless @ARGV;
|
||||
do_guess($_) for @ARGV;
|
||||
|
||||
sub read_file {
|
||||
my $filename = shift;
|
||||
local $/;
|
||||
open my $fh, '<:raw', $filename or croak "$filename:$!";
|
||||
my $content = <$fh>;
|
||||
close $fh;
|
||||
return $content;
|
||||
}
|
||||
|
||||
sub do_guess {
|
||||
my $filename = shift;
|
||||
my $data = read_file($filename);
|
||||
my $enc = guess_encoding( $data, @suspect_list );
|
||||
if ( !ref($enc) && $opt{u} ) {
|
||||
return 1;
|
||||
}
|
||||
print "$filename\t";
|
||||
if ( ref($enc) ) {
|
||||
print $enc->mime_name();
|
||||
}
|
||||
else {
|
||||
print "unknown";
|
||||
}
|
||||
print "\n";
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub list_valid_suspects {
|
||||
print join( "\n", Encode->encodings(":all") );
|
||||
print "\n";
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub HELP_MESSAGE {
|
||||
exec 'pod2usage', $0 or die "pod2usage: $!"
|
||||
}
|
||||
__END__
|
||||
=head1 NAME
|
||||
|
||||
encguess - guess character encodings of files
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
$Id: encguess,v 0.3 2020/12/02 01:28:17 dankogai Exp $
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
encguess [switches] filename...
|
||||
|
||||
=head2 SWITCHES
|
||||
|
||||
=over 2
|
||||
|
||||
=item -h
|
||||
|
||||
show this message and exit.
|
||||
|
||||
=item -s
|
||||
|
||||
specify a list of "suspect encoding types" to test,
|
||||
separated by either C<:> or C<,>
|
||||
|
||||
=item -S
|
||||
|
||||
output a list of all acceptable encoding types that can be used with
|
||||
the -s param
|
||||
|
||||
=item -u
|
||||
|
||||
suppress display of unidentified types
|
||||
|
||||
=back
|
||||
|
||||
=head2 EXAMPLES:
|
||||
|
||||
=over 2
|
||||
|
||||
=item *
|
||||
|
||||
Guess encoding of a file named C<test.txt>, using only the default
|
||||
suspect types.
|
||||
|
||||
encguess test.txt
|
||||
|
||||
=item *
|
||||
|
||||
Guess the encoding type of a file named C<test.txt>, using the suspect
|
||||
types C<euc-jp,shiftjis,7bit-jis>.
|
||||
|
||||
encguess -s euc-jp,shiftjis,7bit-jis test.txt
|
||||
encguess -s euc-jp:shiftjis:7bit-jis test.txt
|
||||
|
||||
=item *
|
||||
|
||||
Guess the encoding type of several files, do not display results for
|
||||
unidentified files.
|
||||
|
||||
encguess -us euc-jp,shiftjis,7bit-jis test*.txt
|
||||
|
||||
=back
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The encoding identification is done by checking one encoding type at a
|
||||
time until all but the right type are eliminated. The set of encoding
|
||||
types to try is defined by the -s parameter and defaults to ascii,
|
||||
utf8 and UTF-16/32 with BOM. This can be overridden by passing one or
|
||||
more encoding types via the -s parameter. If you need to pass in
|
||||
multiple suspect encoding types, use a quoted string with the a space
|
||||
separating each value.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Encode::Guess>, L<Encode::Detect>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
Copyright 2015 Michael LaGrasta and Dan Kogai.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the terms of the the Artistic License (2.0). You may obtain a
|
||||
copy of the full license at:
|
||||
|
||||
L<http://www.perlfoundation.org/artistic_license_2_0>
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,988 @@
|
||||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0; # ^ Run only under a shell
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
|
||||
use strict;
|
||||
|
||||
use Config;
|
||||
use File::Path qw(mkpath);
|
||||
use Getopt::Std;
|
||||
|
||||
# Make sure read permissions for all are set:
|
||||
if (defined umask && (umask() & 0444)) {
|
||||
umask (umask() & ~0444);
|
||||
}
|
||||
|
||||
getopts('Dd:rlhaQe');
|
||||
use vars qw($opt_D $opt_d $opt_r $opt_l $opt_h $opt_a $opt_Q $opt_e);
|
||||
die "-r and -a options are mutually exclusive\n" if ($opt_r and $opt_a);
|
||||
my @inc_dirs = inc_dirs() if $opt_a;
|
||||
|
||||
my $Exit = 0;
|
||||
|
||||
my $Dest_dir = $opt_d || $Config{installsitearch};
|
||||
die "Destination directory $Dest_dir doesn't exist or isn't a directory\n"
|
||||
unless -d $Dest_dir;
|
||||
|
||||
my @isatype = qw(
|
||||
char uchar u_char
|
||||
short ushort u_short
|
||||
int uint u_int
|
||||
long ulong u_long
|
||||
FILE key_t caddr_t
|
||||
float double size_t
|
||||
);
|
||||
|
||||
my %isatype;
|
||||
@isatype{@isatype} = (1) x @isatype;
|
||||
my $inif = 0;
|
||||
my %Is_converted;
|
||||
my %bad_file = ();
|
||||
|
||||
@ARGV = ('-') unless @ARGV;
|
||||
|
||||
build_preamble_if_necessary();
|
||||
|
||||
sub reindent($) {
|
||||
my($text) = shift;
|
||||
$text =~ s/\n/\n /g;
|
||||
$text =~ s/ /\t/g;
|
||||
$text;
|
||||
}
|
||||
|
||||
my ($t, $tab, %curargs, $new, $eval_index, $dir, $name, $args, $outfile);
|
||||
my ($incl, $incl_type, $incl_quote, $next);
|
||||
while (defined (my $file = next_file())) {
|
||||
if (-l $file and -d $file) {
|
||||
link_if_possible($file) if ($opt_l);
|
||||
next;
|
||||
}
|
||||
|
||||
# Recover from header files with unbalanced cpp directives
|
||||
$t = '';
|
||||
$tab = 0;
|
||||
|
||||
# $eval_index goes into '#line' directives, to help locate syntax errors:
|
||||
$eval_index = 1;
|
||||
|
||||
if ($file eq '-') {
|
||||
open(IN, "-");
|
||||
open(OUT, ">-");
|
||||
} else {
|
||||
($outfile = $file) =~ s/\.h$/.ph/ || next;
|
||||
print "$file -> $outfile\n" unless $opt_Q;
|
||||
if ($file =~ m|^(.*)/|) {
|
||||
$dir = $1;
|
||||
mkpath "$Dest_dir/$dir";
|
||||
}
|
||||
|
||||
if ($opt_a) { # automagic mode: locate header file in @inc_dirs
|
||||
foreach (@inc_dirs) {
|
||||
chdir $_;
|
||||
last if -f $file;
|
||||
}
|
||||
}
|
||||
|
||||
open(IN, "<", "$file") || (($Exit = 1),(warn "Can't open $file: $!\n"),next);
|
||||
open(OUT, ">", "$Dest_dir/$outfile") || die "Can't create $outfile: $!\n";
|
||||
}
|
||||
|
||||
print OUT
|
||||
"require '_h2ph_pre.ph';\n\n",
|
||||
"no warnings qw(redefine misc);\n\n";
|
||||
|
||||
while (defined (local $_ = next_line($file))) {
|
||||
if (s/^\s*\#\s*//) {
|
||||
if (s/^define\s+(\w+)//) {
|
||||
$name = $1;
|
||||
$new = '';
|
||||
s/\s+$//;
|
||||
s/\(\w+\s*\(\*\)\s*\(\w*\)\)\s*(-?\d+)/$1/; # (int (*)(foo_t))0
|
||||
if (s/^\(([\w,\s]*)\)//) {
|
||||
$args = $1;
|
||||
my $proto = '() ';
|
||||
if ($args ne '') {
|
||||
$proto = '';
|
||||
foreach my $arg (split(/,\s*/,$args)) {
|
||||
$arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/;
|
||||
$curargs{$arg} = 1;
|
||||
}
|
||||
$args =~ s/\b(\w)/\$$1/g;
|
||||
$args = "my($args) = \@_;\n$t ";
|
||||
}
|
||||
s/^\s+//;
|
||||
expr();
|
||||
$new =~ s/(["\\])/\\$1/g; #"]);
|
||||
EMIT($proto);
|
||||
} else {
|
||||
s/^\s+//;
|
||||
expr();
|
||||
|
||||
$new = 1 if $new eq '';
|
||||
|
||||
# Shunt around such directives as '#define FOO FOO':
|
||||
next if $new =~ /^\s*&\Q$name\E\s*\z/;
|
||||
|
||||
$new = reindent($new);
|
||||
$args = reindent($args);
|
||||
$new =~ s/(['\\])/\\$1/g; #']);
|
||||
|
||||
print OUT $t, 'eval ';
|
||||
if ($opt_h) {
|
||||
print OUT "\"\\n#line $eval_index $outfile\\n\" . ";
|
||||
$eval_index++;
|
||||
}
|
||||
print OUT "'sub $name () {$new;}' unless defined(&$name);\n";
|
||||
}
|
||||
} elsif (/^(include|import|include_next)\s*([<\"])(.*)[>\"]/) {
|
||||
$incl_type = $1;
|
||||
$incl_quote = $2;
|
||||
$incl = $3;
|
||||
if (($incl_type eq 'include_next') ||
|
||||
($opt_e && exists($bad_file{$incl}))) {
|
||||
$incl =~ s/\.h$/.ph/;
|
||||
print OUT ($t,
|
||||
"eval {\n");
|
||||
$tab += 4;
|
||||
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
|
||||
print OUT ($t, "my(\@REM);\n");
|
||||
if ($incl_type eq 'include_next') {
|
||||
print OUT ($t,
|
||||
"my(\%INCD) = map { \$INC{\$_} => 1 } ",
|
||||
"(grep { \$_ eq \"$incl\" } ",
|
||||
"keys(\%INC));\n");
|
||||
print OUT ($t,
|
||||
"\@REM = map { \"\$_/$incl\" } ",
|
||||
"(grep { not exists(\$INCD{\"\$_/$incl\"})",
|
||||
" and -f \"\$_/$incl\" } \@INC);\n");
|
||||
} else {
|
||||
print OUT ($t,
|
||||
"\@REM = map { \"\$_/$incl\" } ",
|
||||
"(grep {-r \"\$_/$incl\" } \@INC);\n");
|
||||
}
|
||||
print OUT ($t,
|
||||
"require \"\$REM[0]\" if \@REM;\n");
|
||||
$tab -= 4;
|
||||
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
|
||||
print OUT ($t,
|
||||
"};\n");
|
||||
print OUT ($t,
|
||||
"warn(\$\@) if \$\@;\n");
|
||||
} else {
|
||||
$incl =~ s/\.h$/.ph/;
|
||||
# copy the prefix in the quote syntax (#include "x.h") case
|
||||
if ($incl !~ m|/| && $incl_quote eq q{"} && $file =~ m|^(.*)/|) {
|
||||
$incl = "$1/$incl";
|
||||
}
|
||||
print OUT $t,"require '$incl';\n";
|
||||
}
|
||||
} elsif (/^ifdef\s+(\w+)/) {
|
||||
print OUT $t,"if(defined(&$1)) {\n";
|
||||
$tab += 4;
|
||||
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
|
||||
} elsif (/^ifndef\s+(\w+)/) {
|
||||
print OUT $t,"unless(defined(&$1)) {\n";
|
||||
$tab += 4;
|
||||
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
|
||||
} elsif (s/^if\s+//) {
|
||||
$new = '';
|
||||
$inif = 1;
|
||||
expr();
|
||||
$inif = 0;
|
||||
print OUT $t,"if($new) {\n";
|
||||
$tab += 4;
|
||||
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
|
||||
} elsif (s/^elif\s+//) {
|
||||
$new = '';
|
||||
$inif = 1;
|
||||
expr();
|
||||
$inif = 0;
|
||||
$tab -= 4;
|
||||
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
|
||||
print OUT $t,"}\n elsif($new) {\n";
|
||||
$tab += 4;
|
||||
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
|
||||
} elsif (/^else/) {
|
||||
$tab -= 4;
|
||||
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
|
||||
print OUT $t,"} else {\n";
|
||||
$tab += 4;
|
||||
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
|
||||
} elsif (/^endif/) {
|
||||
$tab -= 4;
|
||||
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
|
||||
print OUT $t,"}\n";
|
||||
} elsif(/^undef\s+(\w+)/) {
|
||||
print OUT $t, "undef(&$1) if defined(&$1);\n";
|
||||
} elsif(/^error\s+(".*")/) {
|
||||
print OUT $t, "die($1);\n";
|
||||
} elsif(/^error\s+(.*)/) {
|
||||
print OUT $t, "die(\"", quotemeta($1), "\");\n";
|
||||
} elsif(/^warning\s+(.*)/) {
|
||||
print OUT $t, "warn(\"", quotemeta($1), "\");\n";
|
||||
} elsif(/^ident\s+(.*)/) {
|
||||
print OUT $t, "# $1\n";
|
||||
}
|
||||
} elsif (/^\s*(typedef\s*)?enum\s*(\s+[a-zA-Z_]\w*\s*)?/) { # { for vi
|
||||
until(/\{[^}]*\}.*;/ || /;/) {
|
||||
last unless defined ($next = next_line($file));
|
||||
chomp $next;
|
||||
# drop "#define FOO FOO" in enums
|
||||
$next =~ s/^\s*#\s*define\s+(\w+)\s+\1\s*$//;
|
||||
# #defines in enums (aliases)
|
||||
$next =~ s/^\s*#\s*define\s+(\w+)\s+(\w+)\s*$/$1 = $2,/;
|
||||
$_ .= $next;
|
||||
print OUT "# $next\n" if $opt_D;
|
||||
}
|
||||
s/#\s*if.*?#\s*endif//g; # drop #ifdefs
|
||||
s@/\*.*?\*/@@g;
|
||||
s/\s+/ /g;
|
||||
next unless /^\s?(typedef\s?)?enum\s?([a-zA-Z_]\w*)?\s?\{(.*)\}\s?([a-zA-Z_]\w*)?\s?;/;
|
||||
(my $enum_subs = $3) =~ s/\s//g;
|
||||
my @enum_subs = split(/,/, $enum_subs);
|
||||
my $enum_val = -1;
|
||||
foreach my $enum (@enum_subs) {
|
||||
my ($enum_name, $enum_value) = $enum =~ /^([a-zA-Z_]\w*)(=.+)?$/;
|
||||
$enum_name or next;
|
||||
$enum_value =~ s/^=//;
|
||||
$enum_val = (length($enum_value) ? $enum_value : $enum_val + 1);
|
||||
if ($opt_h) {
|
||||
print OUT ($t,
|
||||
"eval(\"\\n#line $eval_index $outfile\\n",
|
||||
"sub $enum_name () \{ $enum_val; \}\") ",
|
||||
"unless defined(\&$enum_name);\n");
|
||||
++ $eval_index;
|
||||
} else {
|
||||
print OUT ($t,
|
||||
"eval(\"sub $enum_name () \{ $enum_val; \}\") ",
|
||||
"unless defined(\&$enum_name);\n");
|
||||
}
|
||||
}
|
||||
} elsif (/^(?:__extension__\s+)?(?:extern|static)\s+(?:__)?inline(?:__)?\s+/
|
||||
and !/;\s*$/ and !/{\s*}\s*$/)
|
||||
{ # { for vi
|
||||
# This is a hack to parse the inline functions in the glibc headers.
|
||||
# Warning: massive kludge ahead. We suppose inline functions
|
||||
# are mainly constructed like macros.
|
||||
while (1) {
|
||||
last unless defined ($next = next_line($file));
|
||||
chomp $next;
|
||||
undef $_, last if $next =~ /__THROW\s*;/
|
||||
or $next =~ /^(__extension__|extern|static)\b/;
|
||||
$_ .= " $next";
|
||||
print OUT "# $next\n" if $opt_D;
|
||||
last if $next =~ /^}|^{.*}\s*$/;
|
||||
}
|
||||
next if not defined; # because it's only a prototype
|
||||
s/\b(__extension__|extern|static|(?:__)?inline(?:__)?)\b//g;
|
||||
# violently drop #ifdefs
|
||||
s/#\s*if.*?#\s*endif//g
|
||||
and print OUT "# some #ifdef were dropped here -- fill in the blanks\n";
|
||||
if (s/^(?:\w|\s|\*)*\s(\w+)\s*//) {
|
||||
$name = $1;
|
||||
} else {
|
||||
warn "name not found"; next; # shouldn't occur...
|
||||
}
|
||||
my @args;
|
||||
if (s/^\(([^()]*)\)\s*(\w+\s*)*//) {
|
||||
for my $arg (split /,/, $1) {
|
||||
if ($arg =~ /(\w+)\s*$/) {
|
||||
$curargs{$1} = 1;
|
||||
push @args, $1;
|
||||
}
|
||||
}
|
||||
}
|
||||
$args = (
|
||||
@args
|
||||
? "my(" . (join ',', map "\$$_", @args) . ") = \@_;\n$t "
|
||||
: ""
|
||||
);
|
||||
my $proto = @args ? '' : '() ';
|
||||
$new = '';
|
||||
s/\breturn\b//g; # "return" doesn't occur in macros usually...
|
||||
expr();
|
||||
# try to find and perlify local C variables
|
||||
our @local_variables = (); # needs to be a our(): (?{...}) bug workaround
|
||||
{
|
||||
use re "eval";
|
||||
my $typelist = join '|', keys %isatype;
|
||||
$new =~ s['
|
||||
(?:(?:__)?const(?:__)?\s+)?
|
||||
(?:(?:un)?signed\s+)?
|
||||
(?:long\s+)?
|
||||
(?:$typelist)\s+
|
||||
(\w+)
|
||||
(?{ push @local_variables, $1 })
|
||||
']
|
||||
[my \$$1]gx;
|
||||
$new =~ s['
|
||||
(?:(?:__)?const(?:__)?\s+)?
|
||||
(?:(?:un)?signed\s+)?
|
||||
(?:long\s+)?
|
||||
(?:$typelist)\s+
|
||||
' \s+ &(\w+) \s* ;
|
||||
(?{ push @local_variables, $1 })
|
||||
]
|
||||
[my \$$1;]gx;
|
||||
}
|
||||
$new =~ s/&$_\b/\$$_/g for @local_variables;
|
||||
$new =~ s/(["\\])/\\$1/g; #"]);
|
||||
# now that's almost like a macro (we hope)
|
||||
EMIT($proto);
|
||||
}
|
||||
}
|
||||
$Is_converted{$file} = 1;
|
||||
if ($opt_e && exists($bad_file{$file})) {
|
||||
unlink($Dest_dir . '/' . $outfile);
|
||||
$next = '';
|
||||
} else {
|
||||
print OUT "1;\n";
|
||||
queue_includes_from($file) if $opt_a;
|
||||
}
|
||||
}
|
||||
|
||||
if ($opt_e && (scalar(keys %bad_file) > 0)) {
|
||||
warn "Was unable to convert the following files:\n";
|
||||
warn "\t" . join("\n\t",sort(keys %bad_file)) . "\n";
|
||||
}
|
||||
|
||||
exit $Exit;
|
||||
|
||||
sub EMIT {
|
||||
my $proto = shift;
|
||||
|
||||
$new = reindent($new);
|
||||
$args = reindent($args);
|
||||
if ($t ne '') {
|
||||
$new =~ s/(['\\])/\\$1/g; #']);
|
||||
if ($opt_h) {
|
||||
print OUT $t,
|
||||
"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
|
||||
$eval_index++;
|
||||
} else {
|
||||
print OUT $t,
|
||||
"eval 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
|
||||
}
|
||||
} else {
|
||||
print OUT "unless(defined(\&$name)) {\n sub $name $proto\{\n\t${args}eval q($new);\n }\n}\n";
|
||||
}
|
||||
%curargs = ();
|
||||
return;
|
||||
}
|
||||
|
||||
sub expr {
|
||||
if (/\b__asm__\b/) { # freak out
|
||||
$new = '"(assembly code)"';
|
||||
return
|
||||
}
|
||||
my $joined_args;
|
||||
if(keys(%curargs)) {
|
||||
$joined_args = join('|', keys(%curargs));
|
||||
}
|
||||
while ($_ ne '') {
|
||||
s/^\&\&// && do { $new .= " &&"; next;}; # handle && operator
|
||||
s/^\&([\(a-z\)]+)/$1/i; # hack for things that take the address of
|
||||
s/^(\s+)// && do {$new .= ' '; next;};
|
||||
s/^0X([0-9A-F]+)[UL]*//i
|
||||
&& do {my $hex = $1;
|
||||
$hex =~ s/^0+//;
|
||||
if (length $hex > 8 && !$Config{use64bitint}) {
|
||||
# Croak if nv_preserves_uv_bits < 64 ?
|
||||
$new .= hex(substr($hex, -8)) +
|
||||
2**32 * hex(substr($hex, 0, -8));
|
||||
# The above will produce "erroneous" code
|
||||
# if the hex constant was e.g. inside UINT64_C
|
||||
# macro, but then again, h2ph is an approximation.
|
||||
} else {
|
||||
$new .= lc("0x$hex");
|
||||
}
|
||||
next;};
|
||||
s/^(-?\d+\.\d+E[-+]?\d+)[FL]?//i && do {$new .= $1; next;};
|
||||
s/^(\d+)\s*[LU]*//i && do {$new .= $1; next;};
|
||||
s/^("(\\"|[^"])*")// && do {$new .= $1; next;};
|
||||
s/^'((\\"|[^"])*)'// && do {
|
||||
if ($curargs{$1}) {
|
||||
$new .= "ord('\$$1')";
|
||||
} else {
|
||||
$new .= "ord('$1')";
|
||||
}
|
||||
next;
|
||||
};
|
||||
# replace "sizeof(foo)" with "{foo}"
|
||||
# also, remove * (C dereference operator) to avoid perl syntax
|
||||
# problems. Where the %sizeof array comes from is anyone's
|
||||
# guess (c2ph?), but this at least avoids fatal syntax errors.
|
||||
# Behavior is undefined if sizeof() delimiters are unbalanced.
|
||||
# This code was modified to able to handle constructs like this:
|
||||
# sizeof(*(p)), which appear in the HP-UX 10.01 header files.
|
||||
s/^sizeof\s*\(// && do {
|
||||
$new .= '$sizeof';
|
||||
my $lvl = 1; # already saw one open paren
|
||||
# tack { on the front, and skip it in the loop
|
||||
$_ = "{" . "$_";
|
||||
my $index = 1;
|
||||
# find balanced closing paren
|
||||
while ($index <= length($_) && $lvl > 0) {
|
||||
$lvl++ if substr($_, $index, 1) eq "(";
|
||||
$lvl-- if substr($_, $index, 1) eq ")";
|
||||
$index++;
|
||||
}
|
||||
# tack } on the end, replacing )
|
||||
substr($_, $index - 1, 1) = "}";
|
||||
# remove pesky * operators within the sizeof argument
|
||||
substr($_, 0, $index - 1) =~ s/\*//g;
|
||||
next;
|
||||
};
|
||||
# Eliminate typedefs
|
||||
/\(([\w\s]+)[\*\s]*\)\s*[\w\(]/ && do {
|
||||
my $doit = 1;
|
||||
foreach (split /\s+/, $1) { # Make sure all the words are types,
|
||||
unless($isatype{$_} or $_ eq 'struct' or $_ eq 'union'){
|
||||
$doit = 0;
|
||||
last;
|
||||
}
|
||||
}
|
||||
if( $doit ){
|
||||
s/\([\w\s]+[\*\s]*\)// && next; # then eliminate them.
|
||||
}
|
||||
};
|
||||
# struct/union member, including arrays:
|
||||
s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i && do {
|
||||
my $id = $1;
|
||||
$id =~ s/(\.|(->))([^\.\-]*)/->\{$3\}/g;
|
||||
$id =~ s/\b([^\$])($joined_args)/$1\$$2/g if length($joined_args);
|
||||
while($id =~ /\[\s*([^\$\&\d\]]+)\]/) {
|
||||
my($index) = $1;
|
||||
$index =~ s/\s//g;
|
||||
if(exists($curargs{$index})) {
|
||||
$index = "\$$index";
|
||||
} else {
|
||||
$index = "&$index";
|
||||
}
|
||||
$id =~ s/\[\s*([^\$\&\d\]]+)\]/[$index]/;
|
||||
}
|
||||
$new .= " (\$$id)";
|
||||
};
|
||||
s/^([_a-zA-Z]\w*)// && do {
|
||||
my $id = $1;
|
||||
if ($id eq 'struct' || $id eq 'union') {
|
||||
s/^\s+(\w+)//;
|
||||
$id .= ' ' . $1;
|
||||
$isatype{$id} = 1;
|
||||
} elsif ($id =~ /^((un)?signed)|(long)|(short)$/) {
|
||||
while (s/^\s+(\w+)//) { $id .= ' ' . $1; }
|
||||
$isatype{$id} = 1;
|
||||
}
|
||||
if ($curargs{$id}) {
|
||||
$new .= "\$$id";
|
||||
$new .= '->' if /^[\[\{]/;
|
||||
} elsif ($id eq 'defined') {
|
||||
$new .= 'defined';
|
||||
} elsif (/^\s*\(/) {
|
||||
s/^\s*\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat
|
||||
$new .= " &$id";
|
||||
} elsif ($isatype{$id}) {
|
||||
if ($new =~ /\{\s*$/) {
|
||||
$new .= "'$id'";
|
||||
} elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
|
||||
$new =~ s/\(\s*$//;
|
||||
s/^[\s*]*\)//;
|
||||
} else {
|
||||
$new .= q(').$id.q(');
|
||||
}
|
||||
} else {
|
||||
if ($inif) {
|
||||
if ($new =~ /defined\s*$/) {
|
||||
$new .= '(&' . $id . ')';
|
||||
} elsif ($new =~ /defined\s*\($/) {
|
||||
$new .= '&' . $id;
|
||||
} else {
|
||||
$new .= '(defined(&' . $id . ') ? &' . $id . ' : undef)';
|
||||
}
|
||||
} elsif (/^\[/) {
|
||||
$new .= " \$$id";
|
||||
} else {
|
||||
$new .= ' &' . $id;
|
||||
}
|
||||
}
|
||||
next;
|
||||
};
|
||||
s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub next_line
|
||||
{
|
||||
my $file = shift;
|
||||
my ($in, $out);
|
||||
my $pre_sub_tri_graphs = 1;
|
||||
|
||||
READ: while (not eof IN) {
|
||||
$in .= <IN>;
|
||||
chomp $in;
|
||||
next unless length $in;
|
||||
|
||||
while (length $in) {
|
||||
if ($pre_sub_tri_graphs) {
|
||||
# Preprocess all tri-graphs
|
||||
# including things stuck in quoted string constants.
|
||||
$in =~ s/\?\?=/#/g; # | ??=| #|
|
||||
$in =~ s/\?\?\!/|/g; # | ??!| ||
|
||||
$in =~ s/\?\?'/^/g; # | ??'| ^|
|
||||
$in =~ s/\?\?\(/[/g; # | ??(| [|
|
||||
$in =~ s/\?\?\)/]/g; # | ??)| ]|
|
||||
$in =~ s/\?\?\-/~/g; # | ??-| ~|
|
||||
$in =~ s/\?\?\//\\/g; # | ??/| \|
|
||||
$in =~ s/\?\?</{/g; # | ??<| {|
|
||||
$in =~ s/\?\?>/}/g; # | ??>| }|
|
||||
}
|
||||
if ($in =~ /^\#ifdef __LANGUAGE_PASCAL__/) {
|
||||
# Tru64 disassembler.h evilness: mixed C and Pascal.
|
||||
while (<IN>) {
|
||||
last if /^\#endif/;
|
||||
}
|
||||
$in = "";
|
||||
next READ;
|
||||
}
|
||||
if ($in =~ /^extern inline / && # Inlined assembler.
|
||||
$^O eq 'linux' && $file =~ m!(?:^|/)asm/[^/]+\.h$!) {
|
||||
while (<IN>) {
|
||||
last if /^}/;
|
||||
}
|
||||
$in = "";
|
||||
next READ;
|
||||
}
|
||||
if ($in =~ s/\\$//) { # \-newline
|
||||
$out .= ' ';
|
||||
next READ;
|
||||
} elsif ($in =~ s/^([^"'\\\/]+)//) { # Passthrough
|
||||
$out .= $1;
|
||||
} elsif ($in =~ s/^(\\.)//) { # \...
|
||||
$out .= $1;
|
||||
} elsif ($in =~ /^'/) { # '...
|
||||
if ($in =~ s/^('(\\.|[^'\\])*')//) {
|
||||
$out .= $1;
|
||||
} else {
|
||||
next READ;
|
||||
}
|
||||
} elsif ($in =~ /^"/) { # "...
|
||||
if ($in =~ s/^("(\\.|[^"\\])*")//) {
|
||||
$out .= $1;
|
||||
} else {
|
||||
next READ;
|
||||
}
|
||||
} elsif ($in =~ s/^\/\/.*//) { # //...
|
||||
# fall through
|
||||
} elsif ($in =~ m/^\/\*/) { # /*...
|
||||
# C comment removal adapted from perlfaq6:
|
||||
if ($in =~ s/^\/\*[^*]*\*+([^\/*][^*]*\*+)*\///) {
|
||||
$out .= ' ';
|
||||
} else { # Incomplete /* */
|
||||
next READ;
|
||||
}
|
||||
} elsif ($in =~ s/^(\/)//) { # /...
|
||||
$out .= $1;
|
||||
} elsif ($in =~ s/^([^\'\"\\\/]+)//) {
|
||||
$out .= $1;
|
||||
} elsif ($^O eq 'linux' &&
|
||||
$file =~ m!(?:^|/)linux/byteorder/pdp_endian\.h$! &&
|
||||
$in =~ s!\'T KNOW!!) {
|
||||
$out =~ s!I DON$!I_DO_NOT_KNOW!;
|
||||
} else {
|
||||
if ($opt_e) {
|
||||
warn "Cannot parse $file:\n$in\n";
|
||||
$bad_file{$file} = 1;
|
||||
$in = '';
|
||||
$out = undef;
|
||||
last READ;
|
||||
} else {
|
||||
die "Cannot parse:\n$in\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
last READ if $out =~ /\S/;
|
||||
}
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
|
||||
# Handle recursive subdirectories without getting a grotesquely big stack.
|
||||
# Could this be implemented using File::Find?
|
||||
sub next_file
|
||||
{
|
||||
my $file;
|
||||
|
||||
while (@ARGV) {
|
||||
$file = shift @ARGV;
|
||||
|
||||
if ($file eq '-' or -f $file or -l $file) {
|
||||
return $file;
|
||||
} elsif (-d $file) {
|
||||
if ($opt_r) {
|
||||
expand_glob($file);
|
||||
} else {
|
||||
print STDERR "Skipping directory '$file'\n";
|
||||
}
|
||||
} elsif ($opt_a) {
|
||||
return $file;
|
||||
} else {
|
||||
print STDERR "Skipping '$file': not a file or directory\n";
|
||||
}
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
|
||||
# Put all the files in $directory into @ARGV for processing.
|
||||
sub expand_glob
|
||||
{
|
||||
my ($directory) = @_;
|
||||
|
||||
$directory =~ s:/$::;
|
||||
|
||||
opendir DIR, $directory;
|
||||
foreach (readdir DIR) {
|
||||
next if ($_ eq '.' or $_ eq '..');
|
||||
|
||||
# expand_glob() is going to be called until $ARGV[0] isn't a
|
||||
# directory; so push directories, and unshift everything else.
|
||||
if (-d "$directory/$_") { push @ARGV, "$directory/$_" }
|
||||
else { unshift @ARGV, "$directory/$_" }
|
||||
}
|
||||
closedir DIR;
|
||||
}
|
||||
|
||||
|
||||
# Given $file, a symbolic link to a directory in the C include directory,
|
||||
# make an equivalent symbolic link in $Dest_dir, if we can figure out how.
|
||||
# Otherwise, just duplicate the file or directory.
|
||||
sub link_if_possible
|
||||
{
|
||||
my ($dirlink) = @_;
|
||||
my $target = eval 'readlink($dirlink)';
|
||||
|
||||
if ($target =~ m:^\.\./: or $target =~ m:^/:) {
|
||||
# The target of a parent or absolute link could leave the $Dest_dir
|
||||
# hierarchy, so let's put all of the contents of $dirlink (actually,
|
||||
# the contents of $target) into @ARGV; as a side effect down the
|
||||
# line, $dirlink will get created as an _actual_ directory.
|
||||
expand_glob($dirlink);
|
||||
} else {
|
||||
if (-l "$Dest_dir/$dirlink") {
|
||||
unlink "$Dest_dir/$dirlink" or
|
||||
print STDERR "Could not remove link $Dest_dir/$dirlink: $!\n";
|
||||
}
|
||||
|
||||
if (eval 'symlink($target, "$Dest_dir/$dirlink")') {
|
||||
print "Linking $target -> $Dest_dir/$dirlink\n";
|
||||
|
||||
# Make sure that the link _links_ to something:
|
||||
if (! -e "$Dest_dir/$target") {
|
||||
mkpath("$Dest_dir/$target", 0755) or
|
||||
print STDERR "Could not create $Dest_dir/$target/\n";
|
||||
}
|
||||
} else {
|
||||
print STDERR "Could not symlink $target -> $Dest_dir/$dirlink: $!\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# Push all #included files in $file onto our stack, except for STDIN
|
||||
# and files we've already processed.
|
||||
sub queue_includes_from
|
||||
{
|
||||
my ($file) = @_;
|
||||
my $line;
|
||||
|
||||
return if ($file eq "-");
|
||||
|
||||
open HEADER, "<", $file or return;
|
||||
while (defined($line = <HEADER>)) {
|
||||
while (/\\$/) { # Handle continuation lines
|
||||
chop $line;
|
||||
$line .= <HEADER>;
|
||||
}
|
||||
|
||||
if ($line =~ /^#\s*include\s+([<"])(.*?)[>"]/) {
|
||||
my ($delimiter, $new_file) = ($1, $2);
|
||||
# copy the prefix in the quote syntax (#include "x.h") case
|
||||
if ($delimiter eq q{"} && $file =~ m|^(.*)/|) {
|
||||
$new_file = "$1/$new_file";
|
||||
}
|
||||
push(@ARGV, $new_file) unless $Is_converted{$new_file};
|
||||
}
|
||||
}
|
||||
close HEADER;
|
||||
}
|
||||
|
||||
|
||||
# Determine include directories; $Config{usrinc} should be enough for (all
|
||||
# non-GCC?) C compilers, but gcc uses additional include directories.
|
||||
sub inc_dirs
|
||||
{
|
||||
my $from_gcc = `LC_ALL=C $Config{cc} -v -E - < /dev/null 2>&1 | awk '/^#include/, /^End of search list/' | grep '^ '`;
|
||||
length($from_gcc) ? (split(' ', $from_gcc), $Config{usrinc}) : ($Config{usrinc});
|
||||
}
|
||||
|
||||
|
||||
# Create "_h2ph_pre.ph", if it doesn't exist or was built by a different
|
||||
# version of h2ph.
|
||||
sub build_preamble_if_necessary
|
||||
{
|
||||
# Increment $VERSION every time this function is modified:
|
||||
my $VERSION = 4;
|
||||
my $preamble = "$Dest_dir/_h2ph_pre.ph";
|
||||
|
||||
# Can we skip building the preamble file?
|
||||
if (-r $preamble) {
|
||||
# Extract version number from first line of preamble:
|
||||
open PREAMBLE, "<", $preamble or die "Cannot open $preamble: $!";
|
||||
my $line = <PREAMBLE>;
|
||||
$line =~ /(\b\d+\b)/;
|
||||
close PREAMBLE or die "Cannot close $preamble: $!";
|
||||
|
||||
# Don't build preamble if a compatible preamble exists:
|
||||
return if $1 == $VERSION;
|
||||
}
|
||||
|
||||
my (%define) = _extract_cc_defines();
|
||||
|
||||
open PREAMBLE, ">", $preamble or die "Cannot open $preamble: $!";
|
||||
print PREAMBLE "# This file was created by h2ph version $VERSION\n";
|
||||
# Prevent non-portable hex constants from warning.
|
||||
#
|
||||
# We still produce an overflow warning if we can't represent
|
||||
# a hex constant as an integer.
|
||||
print PREAMBLE "no warnings qw(portable);\n";
|
||||
|
||||
foreach (sort keys %define) {
|
||||
if ($opt_D) {
|
||||
print PREAMBLE "# $_=$define{$_}\n";
|
||||
}
|
||||
if ($define{$_} =~ /^\((.*)\)$/) {
|
||||
# parenthesized value: d=(v)
|
||||
$define{$_} = $1;
|
||||
}
|
||||
if (/^(\w+)\((\w)\)$/) {
|
||||
my($macro, $arg) = ($1, $2);
|
||||
my $def = $define{$_};
|
||||
$def =~ s/$arg/\$\{$arg\}/g;
|
||||
print PREAMBLE <<DEFINE;
|
||||
unless (defined &$macro) { sub $macro(\$) { my (\$$arg) = \@_; \"$def\" } }
|
||||
|
||||
DEFINE
|
||||
} elsif
|
||||
($define{$_} =~ /^([+-]?(\d+)?\.\d+([eE][+-]?\d+)?)[FL]?$/) {
|
||||
# float:
|
||||
print PREAMBLE
|
||||
"unless (defined &$_) { sub $_() { $1 } }\n\n";
|
||||
} elsif ($define{$_} =~ /^([+-]?\d+)U?L{0,2}$/i) {
|
||||
# integer:
|
||||
print PREAMBLE
|
||||
"unless (defined &$_) { sub $_() { $1 } }\n\n";
|
||||
} elsif ($define{$_} =~ /^([+-]?0x[\da-f]+)U?L{0,2}$/i) {
|
||||
# hex integer
|
||||
# Special cased, since perl warns on hex integers
|
||||
# that can't be represented in a UV.
|
||||
#
|
||||
# This way we get the warning at time of use, so the user
|
||||
# only gets the warning if they happen to use this
|
||||
# platform-specific definition.
|
||||
my $code = $1;
|
||||
$code = "hex('$code')" if length $code > 10;
|
||||
print PREAMBLE
|
||||
"unless (defined &$_) { sub $_() { $code } }\n\n";
|
||||
} elsif ($define{$_} =~ /^\w+$/) {
|
||||
my $def = $define{$_};
|
||||
if ($isatype{$def}) {
|
||||
print PREAMBLE
|
||||
"unless (defined &$_) { sub $_() { \"$def\" } }\n\n";
|
||||
} else {
|
||||
print PREAMBLE
|
||||
"unless (defined &$_) { sub $_() { &$def } }\n\n";
|
||||
}
|
||||
} else {
|
||||
print PREAMBLE
|
||||
"unless (defined &$_) { sub $_() { \"",
|
||||
quotemeta($define{$_}), "\" } }\n\n";
|
||||
}
|
||||
}
|
||||
print PREAMBLE "\n1;\n"; # avoid 'did not return a true value' when empty
|
||||
close PREAMBLE or die "Cannot close $preamble: $!";
|
||||
}
|
||||
|
||||
|
||||
# %Config contains information on macros that are pre-defined by the
|
||||
# system's compiler. We need this information to make the .ph files
|
||||
# function with perl as the .h files do with cc.
|
||||
sub _extract_cc_defines
|
||||
{
|
||||
my %define;
|
||||
my $allsymbols = join " ",
|
||||
@Config{'ccsymbols', 'cppsymbols', 'cppccsymbols'};
|
||||
|
||||
# Split compiler pre-definitions into 'key=value' pairs:
|
||||
while ($allsymbols =~ /([^\s]+)=((\\\s|[^\s])+)/g) {
|
||||
$define{$1} = $2;
|
||||
if ($opt_D) {
|
||||
print STDERR "$_: $1 -> $2\n";
|
||||
}
|
||||
}
|
||||
|
||||
return %define;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
##############################################################################
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
h2ph - convert .h C header files to .ph Perl header files
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
B<h2ph [-d destination directory] [-r | -a] [-l] [-h] [-e] [-D] [-Q]
|
||||
[headerfiles]>
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
I<h2ph>
|
||||
converts any C header files specified to the corresponding Perl header file
|
||||
format.
|
||||
It is most easily run while in /usr/include:
|
||||
|
||||
cd /usr/include; h2ph * sys/*
|
||||
|
||||
or
|
||||
|
||||
cd /usr/include; h2ph * sys/* arpa/* netinet/*
|
||||
|
||||
or
|
||||
|
||||
cd /usr/include; h2ph -r -l .
|
||||
|
||||
The output files are placed in the hierarchy rooted at Perl's
|
||||
architecture dependent library directory. You can specify a different
|
||||
hierarchy with a B<-d> switch.
|
||||
|
||||
If run with no arguments, filters standard input to standard output.
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
=over 4
|
||||
|
||||
=item -d destination_dir
|
||||
|
||||
Put the resulting B<.ph> files beneath B<destination_dir>, instead of
|
||||
beneath the default Perl library location (C<$Config{'installsitearch'}>).
|
||||
|
||||
=item -r
|
||||
|
||||
Run recursively; if any of B<headerfiles> are directories, then run I<h2ph>
|
||||
on all files in those directories (and their subdirectories, etc.). B<-r>
|
||||
and B<-a> are mutually exclusive.
|
||||
|
||||
=item -a
|
||||
|
||||
Run automagically; convert B<headerfiles>, as well as any B<.h> files
|
||||
which they include. This option will search for B<.h> files in all
|
||||
directories which your C compiler ordinarily uses. B<-a> and B<-r> are
|
||||
mutually exclusive.
|
||||
|
||||
=item -l
|
||||
|
||||
Symbolic links will be replicated in the destination directory. If B<-l>
|
||||
is not specified, then links are skipped over.
|
||||
|
||||
=item -h
|
||||
|
||||
Put 'hints' in the .ph files which will help in locating problems with
|
||||
I<h2ph>. In those cases when you B<require> a B<.ph> file containing syntax
|
||||
errors, instead of the cryptic
|
||||
|
||||
[ some error condition ] at (eval mmm) line nnn
|
||||
|
||||
you will see the slightly more helpful
|
||||
|
||||
[ some error condition ] at filename.ph line nnn
|
||||
|
||||
However, the B<.ph> files almost double in size when built using B<-h>.
|
||||
|
||||
=item -e
|
||||
|
||||
If an error is encountered during conversion, output file will be removed and
|
||||
a warning emitted instead of terminating the conversion immediately.
|
||||
|
||||
=item -D
|
||||
|
||||
Include the code from the B<.h> file as a comment in the B<.ph> file.
|
||||
This is primarily used for debugging I<h2ph>.
|
||||
|
||||
=item -Q
|
||||
|
||||
'Quiet' mode; don't print out the names of the files being converted.
|
||||
|
||||
=back
|
||||
|
||||
=head1 ENVIRONMENT
|
||||
|
||||
No environment variables are used.
|
||||
|
||||
=head1 FILES
|
||||
|
||||
/usr/include/*.h
|
||||
/usr/include/sys/*.h
|
||||
|
||||
etc.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Larry Wall
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
perl(1)
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
The usual warnings if it can't read or write the files involved.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Doesn't construct the %sizeof array for you.
|
||||
|
||||
It doesn't handle all C constructs, but it does attempt to isolate
|
||||
definitions inside evals so that you can get at the definitions
|
||||
that it can translate.
|
||||
|
||||
It's only intended as a rough tool.
|
||||
You may need to dicker with the files produced.
|
||||
|
||||
You have to run this program by hand; it's not run as part of the Perl
|
||||
installation.
|
||||
|
||||
Doesn't handle complicated expressions built piecemeal, a la:
|
||||
|
||||
enum {
|
||||
FIRST_VALUE,
|
||||
SECOND_VALUE,
|
||||
#ifdef ABC
|
||||
THIRD_VALUE
|
||||
#endif
|
||||
};
|
||||
|
||||
Doesn't necessarily locate all of your C compiler's internally-defined
|
||||
symbols.
|
||||
|
||||
=cut
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,196 @@
|
||||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0; # ^ Run only under a shell
|
||||
#!/usr/bin/perl -w
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use strict;
|
||||
use IO::File;
|
||||
use ExtUtils::Packlist;
|
||||
use ExtUtils::Installed;
|
||||
|
||||
use vars qw($Inst @Modules);
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
instmodsh - A shell to examine installed modules
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
instmodsh
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A little interface to ExtUtils::Installed to examine installed modules,
|
||||
validate your packlists and even create a tarball from an installed module.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
ExtUtils::Installed
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
my $Module_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
|
||||
h - Display module help
|
||||
q - Quit the module
|
||||
EOF
|
||||
|
||||
my %Module_Commands = (
|
||||
f => \&list_installed,
|
||||
d => \&list_directories,
|
||||
v => \&validate_packlist,
|
||||
t => \&create_archive,
|
||||
h => \&module_help,
|
||||
);
|
||||
|
||||
sub do_module($) {
|
||||
my ($module) = @_;
|
||||
|
||||
print($Module_Help);
|
||||
MODULE_CMD: while (1) {
|
||||
print("$module cmd? ");
|
||||
|
||||
my $reply = <STDIN>; chomp($reply);
|
||||
my($cmd) = $reply =~ /^(\w)\b/;
|
||||
|
||||
last if $cmd eq 'q';
|
||||
|
||||
if( $Module_Commands{$cmd} ) {
|
||||
$Module_Commands{$cmd}->($reply, $module);
|
||||
}
|
||||
elsif( $cmd eq 'q' ) {
|
||||
last MODULE_CMD;
|
||||
}
|
||||
else {
|
||||
module_help();
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub list_installed {
|
||||
my($reply, $module) = @_;
|
||||
|
||||
my $class = (split(' ', $reply))[1];
|
||||
$class = 'all' unless $class;
|
||||
|
||||
my @files;
|
||||
if (eval { @files = $Inst->files($module, $class); }) {
|
||||
print("$class files in $module are:\n ",
|
||||
join("\n ", @files), "\n");
|
||||
}
|
||||
else {
|
||||
print($@);
|
||||
}
|
||||
};
|
||||
|
||||
|
||||
sub list_directories {
|
||||
my($reply, $module) = @_;
|
||||
|
||||
my $class = (split(' ', $reply))[1];
|
||||
$class = 'all' unless $class;
|
||||
|
||||
my @dirs;
|
||||
if (eval { @dirs = $Inst->directories($module, $class); }) {
|
||||
print("$class directories in $module are:\n ",
|
||||
join("\n ", @dirs), "\n");
|
||||
}
|
||||
else {
|
||||
print($@);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub create_archive {
|
||||
my($reply, $module) = @_;
|
||||
|
||||
my $file = (split(' ', $reply))[1];
|
||||
|
||||
if( !(defined $file and length $file) ) {
|
||||
print "No tar file specified\n";
|
||||
}
|
||||
elsif( eval { require Archive::Tar } ) {
|
||||
Archive::Tar->create_archive($file, 0, $Inst->files($module));
|
||||
}
|
||||
else {
|
||||
my($first, @rest) = $Inst->files($module);
|
||||
system('tar', 'cvf', $file, $first);
|
||||
for my $f (@rest) {
|
||||
system('tar', 'rvf', $file, $f);
|
||||
}
|
||||
print "Can't use tar\n" if $?;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub validate_packlist {
|
||||
my($reply, $module) = @_;
|
||||
|
||||
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");
|
||||
}
|
||||
}
|
||||
|
||||
sub module_help {
|
||||
print $Module_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();
|
||||
|
||||
###############################################################################
|
||||
@@ -0,0 +1,240 @@
|
||||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0; # ^ Run only under a shell
|
||||
#!/usr/bin/perl
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use strict;
|
||||
use Getopt::Long;
|
||||
use Encode ();
|
||||
|
||||
use JSON::PP ();
|
||||
|
||||
# imported from JSON-XS/bin/json_xs
|
||||
|
||||
my %allow_json_opt = map { $_ => 1 } qw(
|
||||
ascii latin1 utf8 pretty indent space_before space_after relaxed canonical allow_nonref
|
||||
allow_singlequote allow_barekey allow_bignum loose escape_slash indent_length
|
||||
);
|
||||
|
||||
|
||||
GetOptions(
|
||||
'v' => \( my $opt_verbose ),
|
||||
'f=s' => \( my $opt_from = 'json' ),
|
||||
't=s' => \( my $opt_to = 'json' ),
|
||||
'json_opt=s' => \( my $json_opt = 'pretty' ),
|
||||
'V' => \( my $version ),
|
||||
) or die "Usage: $0 [-V] [-f from_format] [-t to_format] [-json_opt options_to_json1[,options_to_json2[,...]]]\n";
|
||||
|
||||
|
||||
if ( $version ) {
|
||||
print "$JSON::PP::VERSION\n";
|
||||
exit;
|
||||
}
|
||||
|
||||
|
||||
$json_opt = '' if $json_opt eq '-';
|
||||
|
||||
my %json_opt;
|
||||
for my $opt (split /,/, $json_opt) {
|
||||
my ($key, $value) = split /=/, $opt, 2;
|
||||
$value = 1 unless defined $value;
|
||||
die "'$_' is not a valid json option" unless $allow_json_opt{$key};
|
||||
$json_opt{$key} = $value;
|
||||
}
|
||||
|
||||
my %F = (
|
||||
'json' => sub {
|
||||
my $json = JSON::PP->new;
|
||||
my $enc =
|
||||
/^\x00\x00\x00/s ? "utf-32be"
|
||||
: /^\x00.\x00/s ? "utf-16be"
|
||||
: /^.\x00\x00\x00/s ? "utf-32le"
|
||||
: /^.\x00.\x00/s ? "utf-16le"
|
||||
: "utf-8";
|
||||
for my $key (keys %json_opt) {
|
||||
next if $key eq 'utf8';
|
||||
$json->$key($json_opt{$key});
|
||||
}
|
||||
$json->decode( Encode::decode($enc, $_) );
|
||||
},
|
||||
'eval' => sub {
|
||||
my $v = eval "no strict;\n#line 1 \"input\"\n$_";
|
||||
die "$@" if $@;
|
||||
return $v;
|
||||
},
|
||||
);
|
||||
|
||||
|
||||
my %T = (
|
||||
'null' => sub { "" },
|
||||
'json' => sub {
|
||||
my $json = JSON::PP->new->utf8;
|
||||
for my $key (keys %json_opt) {
|
||||
$json->$key($json_opt{$key});
|
||||
}
|
||||
$json->canonical if $json_opt{pretty};
|
||||
$json->encode( $_ );
|
||||
},
|
||||
'dumper' => sub {
|
||||
require Data::Dumper;
|
||||
local $Data::Dumper::Terse = 1;
|
||||
local $Data::Dumper::Indent = 1;
|
||||
local $Data::Dumper::Useqq = 1;
|
||||
local $Data::Dumper::Quotekeys = 0;
|
||||
local $Data::Dumper::Sortkeys = 1;
|
||||
Data::Dumper::Dumper($_)
|
||||
},
|
||||
);
|
||||
|
||||
|
||||
|
||||
$F{$opt_from}
|
||||
or die "$opt_from: not a valid fromformat\n";
|
||||
|
||||
$T{$opt_to}
|
||||
or die "$opt_from: not a valid toformat\n";
|
||||
|
||||
{
|
||||
local $/;
|
||||
binmode STDIN;
|
||||
$_ = <STDIN>;
|
||||
}
|
||||
|
||||
$_ = $F{$opt_from}->();
|
||||
$_ = $T{$opt_to}->();
|
||||
|
||||
print $_;
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
json_pp - JSON::PP command utility
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
json_pp [-v] [-f from_format] [-t to_format] [-json_opt options_to_json1[,options_to_json2[,...]]]
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
json_pp converts between some input and output formats (one of them is JSON).
|
||||
This program was copied from L<json_xs> and modified.
|
||||
|
||||
The default input format is json and the default output format is json with pretty option.
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
=head2 -f
|
||||
|
||||
-f from_format
|
||||
|
||||
Reads a data in the given format from STDIN.
|
||||
|
||||
Format types:
|
||||
|
||||
=over
|
||||
|
||||
=item json
|
||||
|
||||
as JSON
|
||||
|
||||
=item eval
|
||||
|
||||
as Perl code
|
||||
|
||||
=back
|
||||
|
||||
=head2 -t
|
||||
|
||||
Writes a data in the given format to STDOUT.
|
||||
|
||||
=over
|
||||
|
||||
=item null
|
||||
|
||||
no action.
|
||||
|
||||
=item json
|
||||
|
||||
as JSON
|
||||
|
||||
=item dumper
|
||||
|
||||
as Data::Dumper
|
||||
|
||||
=back
|
||||
|
||||
=head2 -json_opt
|
||||
|
||||
options to JSON::PP
|
||||
|
||||
Acceptable options are:
|
||||
|
||||
ascii latin1 utf8 pretty indent space_before space_after relaxed canonical allow_nonref
|
||||
allow_singlequote allow_barekey allow_bignum loose escape_slash indent_length
|
||||
|
||||
Multiple options must be separated by commas:
|
||||
|
||||
Right: -json_opt pretty,canonical
|
||||
|
||||
Wrong: -json_opt pretty -json_opt canonical
|
||||
|
||||
=head2 -v
|
||||
|
||||
Verbose option, but currently no action in fact.
|
||||
|
||||
=head2 -V
|
||||
|
||||
Prints version and exits.
|
||||
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
$ perl -e'print q|{"foo":"あい","bar":1234567890000000000000000}|' |\
|
||||
json_pp -f json -t dumper -json_opt pretty,utf8,allow_bignum
|
||||
|
||||
$VAR1 = {
|
||||
'bar' => bless( {
|
||||
'value' => [
|
||||
'0000000',
|
||||
'0000000',
|
||||
'5678900',
|
||||
'1234'
|
||||
],
|
||||
'sign' => '+'
|
||||
}, 'Math::BigInt' ),
|
||||
'foo' => "\x{3042}\x{3044}"
|
||||
};
|
||||
|
||||
$ perl -e'print q|{"foo":"あい","bar":1234567890000000000000000}|' |\
|
||||
json_pp -f json -t dumper -json_opt pretty
|
||||
|
||||
$VAR1 = {
|
||||
'bar' => '1234567890000000000000000',
|
||||
'foo' => "\x{e3}\x{81}\x{82}\x{e3}\x{81}\x{84}"
|
||||
};
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<JSON::PP>, L<json_xs>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
|
||||
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright 2010 by Makamaka Hannyaharamitu
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
@@ -0,0 +1,722 @@
|
||||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0; # ^ Run only under a shell
|
||||
|
||||
=head1 NAME
|
||||
|
||||
libnetcfg - configure libnet
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The libnetcfg utility can be used to configure the libnet.
|
||||
Starting from perl 5.8 libnet is part of the standard Perl
|
||||
distribution, but the libnetcfg can be used for any libnet
|
||||
installation.
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
Without arguments libnetcfg displays the current configuration.
|
||||
|
||||
$ libnetcfg
|
||||
# old config ./libnet.cfg
|
||||
daytime_hosts ntp1.none.such
|
||||
ftp_int_passive 0
|
||||
ftp_testhost ftp.funet.fi
|
||||
inet_domain none.such
|
||||
nntp_hosts nntp.none.such
|
||||
ph_hosts
|
||||
pop3_hosts pop.none.such
|
||||
smtp_hosts smtp.none.such
|
||||
snpp_hosts
|
||||
test_exist 1
|
||||
test_hosts 1
|
||||
time_hosts ntp.none.such
|
||||
# libnetcfg -h for help
|
||||
$
|
||||
|
||||
It tells where the old configuration file was found (if found).
|
||||
|
||||
The C<-h> option will show a usage message.
|
||||
|
||||
To change the configuration you will need to use either the C<-c> or
|
||||
the C<-d> options.
|
||||
|
||||
The default name of the old configuration file is by default
|
||||
"libnet.cfg", unless otherwise specified using the -i option,
|
||||
C<-i oldfile>, and it is searched first from the current directory,
|
||||
and then from your module path.
|
||||
|
||||
The default name of the new configuration file is "libnet.cfg", and by
|
||||
default it is written to the current directory, unless otherwise
|
||||
specified using the -o option, C<-o newfile>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Net::Config>, L<libnetFAQ>
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Graham Barr, the original Configure script of libnet.
|
||||
|
||||
Jarkko Hietaniemi, conversion into libnetcfg for inclusion into Perl 5.8.
|
||||
|
||||
=cut
|
||||
|
||||
# $Id: Configure,v 1.8 1997/03/04 09:22:32 gbarr Exp $
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use strict;
|
||||
use IO::File;
|
||||
use Getopt::Std;
|
||||
use ExtUtils::MakeMaker qw(prompt);
|
||||
use File::Spec;
|
||||
|
||||
use vars qw($opt_d $opt_c $opt_h $opt_o $opt_i);
|
||||
|
||||
##
|
||||
##
|
||||
##
|
||||
|
||||
my %cfg = ();
|
||||
my @cfg = ();
|
||||
|
||||
my($libnet_cfg_in,$libnet_cfg_out,$msg,$ans,$def,$have_old);
|
||||
|
||||
##
|
||||
##
|
||||
##
|
||||
|
||||
sub valid_host
|
||||
{
|
||||
my $h = shift;
|
||||
|
||||
defined($h) && (($cfg{'test_exist'} == 0) || gethostbyname($h));
|
||||
}
|
||||
|
||||
##
|
||||
##
|
||||
##
|
||||
|
||||
sub test_hostnames (\@)
|
||||
{
|
||||
my $hlist = shift;
|
||||
my @h = ();
|
||||
my $host;
|
||||
my $err = 0;
|
||||
|
||||
foreach $host (@$hlist)
|
||||
{
|
||||
if(valid_host($host))
|
||||
{
|
||||
push(@h, $host);
|
||||
next;
|
||||
}
|
||||
warn "Bad hostname: '$host'\n";
|
||||
$err++;
|
||||
}
|
||||
@$hlist = @h;
|
||||
$err ? join(" ",@h) : undef;
|
||||
}
|
||||
|
||||
##
|
||||
##
|
||||
##
|
||||
|
||||
sub Prompt
|
||||
{
|
||||
my($prompt,$def) = @_;
|
||||
|
||||
$def = "" unless defined $def;
|
||||
|
||||
chomp($prompt);
|
||||
|
||||
if($opt_d)
|
||||
{
|
||||
print $prompt,," [",$def,"]\n";
|
||||
return $def;
|
||||
}
|
||||
prompt($prompt,$def);
|
||||
}
|
||||
|
||||
##
|
||||
##
|
||||
##
|
||||
|
||||
sub get_host_list
|
||||
{
|
||||
my($prompt,$def) = @_;
|
||||
|
||||
$def = join(" ",@$def) if ref($def);
|
||||
|
||||
my @hosts;
|
||||
|
||||
do
|
||||
{
|
||||
my $ans = Prompt($prompt,$def);
|
||||
|
||||
$ans =~ s/(\A\s+|\s+\Z)//g;
|
||||
|
||||
@hosts = split(/\s+/, $ans);
|
||||
}
|
||||
while(@hosts && defined($def = test_hostnames(@hosts)));
|
||||
|
||||
\@hosts;
|
||||
}
|
||||
|
||||
##
|
||||
##
|
||||
##
|
||||
|
||||
sub get_hostname
|
||||
{
|
||||
my($prompt,$def) = @_;
|
||||
|
||||
my $host;
|
||||
|
||||
while(1)
|
||||
{
|
||||
my $ans = Prompt($prompt,$def);
|
||||
$host = ($ans =~ /(\S*)/)[0];
|
||||
last
|
||||
if(!length($host) || valid_host($host));
|
||||
|
||||
$def =""
|
||||
if $def eq $host;
|
||||
|
||||
print <<"EDQ";
|
||||
|
||||
*** ERROR:
|
||||
Hostname '$host' does not seem to exist, please enter again
|
||||
or a single space to clear any default
|
||||
|
||||
EDQ
|
||||
}
|
||||
|
||||
length $host
|
||||
? $host
|
||||
: undef;
|
||||
}
|
||||
|
||||
##
|
||||
##
|
||||
##
|
||||
|
||||
sub get_bool ($$)
|
||||
{
|
||||
my($prompt,$def) = @_;
|
||||
|
||||
chomp($prompt);
|
||||
|
||||
my $val = Prompt($prompt,$def ? "yes" : "no");
|
||||
|
||||
$val =~ /^y/i ? 1 : 0;
|
||||
}
|
||||
|
||||
##
|
||||
##
|
||||
##
|
||||
|
||||
sub get_netmask ($$)
|
||||
{
|
||||
my($prompt,$def) = @_;
|
||||
|
||||
chomp($prompt);
|
||||
|
||||
my %list;
|
||||
@list{@$def} = ();
|
||||
|
||||
MASK:
|
||||
while(1) {
|
||||
my $bad = 0;
|
||||
my $ans = Prompt($prompt) or last;
|
||||
|
||||
if($ans eq '*') {
|
||||
%list = ();
|
||||
next;
|
||||
}
|
||||
|
||||
if($ans eq '=') {
|
||||
print "\n",( %list ? join("\n", sort keys %list) : 'none'),"\n\n";
|
||||
next;
|
||||
}
|
||||
|
||||
unless ($ans =~ m{^\s*(?:(-?\s*)(\d+(?:\.\d+){0,3})/(\d+))}) {
|
||||
warn "Bad netmask '$ans'\n";
|
||||
next;
|
||||
}
|
||||
|
||||
my($remove,$bits,@ip) = ($1,$3,split(/\./, $2),0,0,0);
|
||||
if ( $ip[0] < 1 || $bits < 1 || $bits > 32) {
|
||||
warn "Bad netmask '$ans'\n";
|
||||
next MASK;
|
||||
}
|
||||
foreach my $byte (@ip) {
|
||||
if ( $byte > 255 ) {
|
||||
warn "Bad netmask '$ans'\n";
|
||||
next MASK;
|
||||
}
|
||||
}
|
||||
|
||||
my $mask = sprintf("%d.%d.%d.%d/%d",@ip[0..3],$bits);
|
||||
|
||||
if ($remove) {
|
||||
delete $list{$mask};
|
||||
}
|
||||
else {
|
||||
$list{$mask} = 1;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
[ keys %list ];
|
||||
}
|
||||
|
||||
##
|
||||
##
|
||||
##
|
||||
|
||||
sub default_hostname
|
||||
{
|
||||
my $host;
|
||||
my @host;
|
||||
|
||||
foreach $host (@_)
|
||||
{
|
||||
if(defined($host) && valid_host($host))
|
||||
{
|
||||
return $host
|
||||
unless wantarray;
|
||||
push(@host,$host);
|
||||
}
|
||||
}
|
||||
|
||||
return wantarray ? @host : undef;
|
||||
}
|
||||
|
||||
##
|
||||
##
|
||||
##
|
||||
|
||||
getopts('dcho:i:');
|
||||
|
||||
$libnet_cfg_in = "libnet.cfg"
|
||||
unless(defined($libnet_cfg_in = $opt_i));
|
||||
|
||||
$libnet_cfg_out = "libnet.cfg"
|
||||
unless(defined($libnet_cfg_out = $opt_o));
|
||||
|
||||
my %oldcfg = ();
|
||||
|
||||
$Net::Config::CONFIGURE = 1; # Suppress load of user overrides
|
||||
if( -f $libnet_cfg_in )
|
||||
{
|
||||
%oldcfg = ( %{ local @INC = '.'; do $libnet_cfg_in } );
|
||||
}
|
||||
elsif (eval { require Net::Config })
|
||||
{
|
||||
$have_old = 1;
|
||||
%oldcfg = %Net::Config::NetConfig;
|
||||
}
|
||||
|
||||
map { $cfg{lc $_} = $cfg{$_}; delete $cfg{$_} if /[A-Z]/ } keys %cfg;
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
if ($opt_h) {
|
||||
print <<EOU;
|
||||
$0: Usage: $0 [-c] [-d] [-i oldconfigile] [-o newconfigfile] [-h]
|
||||
Without options, the old configuration is shown.
|
||||
|
||||
-c change the configuration
|
||||
-d use defaults from the old config (implies -c, non-interactive)
|
||||
-i use a specific file as the old config file
|
||||
-o use a specific file as the new config file
|
||||
-h show this help
|
||||
|
||||
The default name of the old configuration file is by default
|
||||
"libnet.cfg", unless otherwise specified using the -i option,
|
||||
C<-i oldfile>, and it is searched first from the current directory,
|
||||
and then from your module path.
|
||||
|
||||
The default name of the new configuration file is "libnet.cfg", and by
|
||||
default it is written to the current directory, unless otherwise
|
||||
specified using the -o option.
|
||||
|
||||
EOU
|
||||
exit(0);
|
||||
}
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
{
|
||||
my $oldcfgfile;
|
||||
my @inc;
|
||||
push @inc, $ENV{PERL5LIB} if exists $ENV{PERL5LIB};
|
||||
push @inc, $ENV{PERLLIB} if exists $ENV{PERLLIB};
|
||||
push @inc, @INC;
|
||||
for (@inc) {
|
||||
my $trycfgfile = File::Spec->catfile($_, $libnet_cfg_in);
|
||||
if (-f $trycfgfile && -r $trycfgfile) {
|
||||
$oldcfgfile = $trycfgfile;
|
||||
last;
|
||||
}
|
||||
}
|
||||
print "# old config $oldcfgfile\n" if defined $oldcfgfile;
|
||||
for (sort keys %oldcfg) {
|
||||
printf "%-20s %s\n", $_,
|
||||
ref $oldcfg{$_} ? @{$oldcfg{$_}} : $oldcfg{$_};
|
||||
}
|
||||
unless ($opt_c || $opt_d) {
|
||||
print "# $0 -h for help\n";
|
||||
exit(0);
|
||||
}
|
||||
}
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
$oldcfg{'test_exist'} = 1 unless exists $oldcfg{'test_exist'};
|
||||
$oldcfg{'test_hosts'} = 1 unless exists $oldcfg{'test_hosts'};
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
if($have_old && !$opt_d)
|
||||
{
|
||||
$msg = <<EDQ;
|
||||
|
||||
Ah, I see you already have installed libnet before.
|
||||
|
||||
Do you want to modify/update your configuration (y|n) ?
|
||||
EDQ
|
||||
|
||||
$opt_d = 1
|
||||
unless get_bool($msg,0);
|
||||
}
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
$msg = <<EDQ;
|
||||
|
||||
This script will prompt you to enter hostnames that can be used as
|
||||
defaults for some of the modules in the libnet distribution.
|
||||
|
||||
To ensure that you do not enter an invalid hostname, I can perform a
|
||||
lookup on each hostname you enter. If your internet connection is via
|
||||
a dialup line then you may not want me to perform these lookups, as
|
||||
it will require you to be on-line.
|
||||
|
||||
Do you want me to perform hostname lookups (y|n) ?
|
||||
EDQ
|
||||
|
||||
$cfg{'test_exist'} = get_bool($msg, $oldcfg{'test_exist'});
|
||||
|
||||
print <<EDQ unless $cfg{'test_exist'};
|
||||
|
||||
*** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
|
||||
|
||||
OK I will not check if the hostnames you give are valid
|
||||
so be very cafeful
|
||||
|
||||
*** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
|
||||
EDQ
|
||||
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
print <<EDQ;
|
||||
|
||||
The following questions all require a list of host names, separated
|
||||
with spaces. If you do not have a host available for any of the
|
||||
services, then enter a single space, followed by <CR>. To accept the
|
||||
default, hit <CR>
|
||||
|
||||
EDQ
|
||||
|
||||
$msg = 'Enter a list of available NNTP hosts :';
|
||||
|
||||
$def = $oldcfg{'nntp_hosts'} ||
|
||||
[ default_hostname($ENV{NNTPSERVER},$ENV{NEWSHOST},'news') ];
|
||||
|
||||
$cfg{'nntp_hosts'} = get_host_list($msg,$def);
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
$msg = 'Enter a list of available SMTP hosts :';
|
||||
|
||||
$def = $oldcfg{'smtp_hosts'} ||
|
||||
[ default_hostname(split(/:/,$ENV{SMTPHOSTS} || ""), 'mailhost') ];
|
||||
|
||||
$cfg{'smtp_hosts'} = get_host_list($msg,$def);
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
$msg = 'Enter a list of available POP3 hosts :';
|
||||
|
||||
$def = $oldcfg{'pop3_hosts'} || [];
|
||||
|
||||
$cfg{'pop3_hosts'} = get_host_list($msg,$def);
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
$msg = 'Enter a list of available SNPP hosts :';
|
||||
|
||||
$def = $oldcfg{'snpp_hosts'} || [];
|
||||
|
||||
$cfg{'snpp_hosts'} = get_host_list($msg,$def);
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
$msg = 'Enter a list of available PH Hosts :' ;
|
||||
|
||||
$def = $oldcfg{'ph_hosts'} ||
|
||||
[ default_hostname('dirserv') ];
|
||||
|
||||
$cfg{'ph_hosts'} = get_host_list($msg,$def);
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
$msg = 'Enter a list of available TIME Hosts :' ;
|
||||
|
||||
$def = $oldcfg{'time_hosts'} || [];
|
||||
|
||||
$cfg{'time_hosts'} = get_host_list($msg,$def);
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
$msg = 'Enter a list of available DAYTIME Hosts :' ;
|
||||
|
||||
$def = $oldcfg{'daytime_hosts'} || $oldcfg{'time_hosts'};
|
||||
|
||||
$cfg{'daytime_hosts'} = get_host_list($msg,$def);
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
$msg = <<EDQ;
|
||||
|
||||
Do you have a firewall/ftp proxy between your machine and the internet
|
||||
|
||||
If you use a SOCKS firewall answer no
|
||||
|
||||
(y|n) ?
|
||||
EDQ
|
||||
|
||||
if(get_bool($msg,0)) {
|
||||
|
||||
$msg = <<'EDQ';
|
||||
What series of FTP commands do you need to send to your
|
||||
firewall to connect to an external host.
|
||||
|
||||
user/pass => external user & password
|
||||
fwuser/fwpass => firewall user & password
|
||||
|
||||
0) None
|
||||
1) -----------------------
|
||||
USER user@remote.host
|
||||
PASS pass
|
||||
2) -----------------------
|
||||
USER fwuser
|
||||
PASS fwpass
|
||||
USER user@remote.host
|
||||
PASS pass
|
||||
3) -----------------------
|
||||
USER fwuser
|
||||
PASS fwpass
|
||||
SITE remote.site
|
||||
USER user
|
||||
PASS pass
|
||||
4) -----------------------
|
||||
USER fwuser
|
||||
PASS fwpass
|
||||
OPEN remote.site
|
||||
USER user
|
||||
PASS pass
|
||||
5) -----------------------
|
||||
USER user@fwuser@remote.site
|
||||
PASS pass@fwpass
|
||||
6) -----------------------
|
||||
USER fwuser@remote.site
|
||||
PASS fwpass
|
||||
USER user
|
||||
PASS pass
|
||||
7) -----------------------
|
||||
USER user@remote.host
|
||||
PASS pass
|
||||
AUTH fwuser
|
||||
RESP fwpass
|
||||
|
||||
Choice:
|
||||
EDQ
|
||||
$def = exists $oldcfg{'ftp_firewall_type'} ? $oldcfg{'ftp_firewall_type'} : 1;
|
||||
$ans = Prompt($msg,$def);
|
||||
$cfg{'ftp_firewall_type'} = 0+$ans;
|
||||
$def = $oldcfg{'ftp_firewall'} || $ENV{FTP_FIREWALL};
|
||||
|
||||
$cfg{'ftp_firewall'} = get_hostname("FTP proxy hostname :", $def);
|
||||
}
|
||||
else {
|
||||
delete $cfg{'ftp_firewall'};
|
||||
}
|
||||
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
if (defined $cfg{'ftp_firewall'})
|
||||
{
|
||||
print <<EDQ;
|
||||
|
||||
By default Net::FTP assumes that it only needs to use a firewall if it
|
||||
cannot resolve the name of the host given. This only works if your DNS
|
||||
system is setup to only resolve internal hostnames. If this is not the
|
||||
case and your DNS will resolve external hostnames, then another method
|
||||
is needed. Net::Config can do this if you provide the netmasks that
|
||||
describe your internal network. Each netmask should be entered in the
|
||||
form x.x.x.x/y, for example 127.0.0.0/8 or 214.8.16.32/24
|
||||
|
||||
EDQ
|
||||
$def = [];
|
||||
if(ref($oldcfg{'local_netmask'}))
|
||||
{
|
||||
$def = $oldcfg{'local_netmask'};
|
||||
print "Your current netmasks are :\n\n\t",
|
||||
join("\n\t",@{$def}),"\n\n";
|
||||
}
|
||||
|
||||
print "
|
||||
Enter one netmask at each prompt, prefix with a - to remove a netmask
|
||||
from the list, enter a '*' to clear the whole list, an '=' to show the
|
||||
current list and an empty line to continue with Configure.
|
||||
|
||||
";
|
||||
|
||||
my $mask = get_netmask("netmask :",$def);
|
||||
$cfg{'local_netmask'} = $mask if ref($mask) && @$mask;
|
||||
}
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
###$msg =<<EDQ;
|
||||
###
|
||||
###SOCKS is a commonly used firewall protocol. If you use SOCKS firewalls
|
||||
###then enter a list of hostames
|
||||
###
|
||||
###Enter a list of available SOCKS hosts :
|
||||
###EDQ
|
||||
###
|
||||
###$def = $cfg{'socks_hosts'} ||
|
||||
### [ default_hostname($ENV{SOCKS5_SERVER},
|
||||
### $ENV{SOCKS_SERVER},
|
||||
### $ENV{SOCKS4_SERVER}) ];
|
||||
###
|
||||
###$cfg{'socks_hosts'} = get_host_list($msg,$def);
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
print <<EDQ;
|
||||
|
||||
Normally when FTP needs a data connection the client tells the server
|
||||
a port to connect to, and the server initiates a connection to the client.
|
||||
|
||||
Some setups, in particular firewall setups, can/do not work using this
|
||||
protocol. In these situations the client must make the connection to the
|
||||
server, this is called a passive transfer.
|
||||
EDQ
|
||||
|
||||
if (defined $cfg{'ftp_firewall'}) {
|
||||
$msg = "\nShould all FTP connections via a firewall/proxy be passive (y|n) ?";
|
||||
|
||||
$def = $oldcfg{'ftp_ext_passive'} || 0;
|
||||
|
||||
$cfg{'ftp_ext_passive'} = get_bool($msg,$def);
|
||||
|
||||
$msg = "\nShould all other FTP connections be passive (y|n) ?";
|
||||
|
||||
}
|
||||
else {
|
||||
$msg = "\nShould all FTP connections be passive (y|n) ?";
|
||||
}
|
||||
|
||||
$def = $oldcfg{'ftp_int_passive'} || 0;
|
||||
|
||||
$cfg{'ftp_int_passive'} = get_bool($msg,$def);
|
||||
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
$def = $oldcfg{'inet_domain'} || $ENV{LOCALDOMAIN};
|
||||
|
||||
$ans = Prompt("\nWhat is your local internet domain name :",$def);
|
||||
|
||||
$cfg{'inet_domain'} = ($ans =~ /(\S+)/)[0];
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
$msg = <<EDQ;
|
||||
|
||||
If you specified some default hosts above, it is possible for me to
|
||||
do some basic tests when you run 'make test'
|
||||
|
||||
This will cause 'make test' to be quite a bit slower and, if your
|
||||
internet connection is via dialup, will require you to be on-line
|
||||
unless the hosts are local.
|
||||
|
||||
Do you want me to run these tests (y|n) ?
|
||||
EDQ
|
||||
|
||||
$cfg{'test_hosts'} = get_bool($msg,$oldcfg{'test_hosts'});
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
$msg = <<EDQ;
|
||||
|
||||
To allow Net::FTP to be tested I will need a hostname. This host
|
||||
should allow anonymous access and have a /pub directory
|
||||
|
||||
What host can I use :
|
||||
EDQ
|
||||
|
||||
$cfg{'ftp_testhost'} = get_hostname($msg,$oldcfg{'ftp_testhost'})
|
||||
if $cfg{'test_hosts'};
|
||||
|
||||
|
||||
print "\n";
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
my $fh = IO::File->new($libnet_cfg_out, "w") or
|
||||
die "Cannot create '$libnet_cfg_out': $!";
|
||||
|
||||
print "Writing $libnet_cfg_out\n";
|
||||
|
||||
print $fh "{\n";
|
||||
|
||||
my $key;
|
||||
foreach $key (keys %cfg) {
|
||||
my $val = $cfg{$key};
|
||||
if(!defined($val)) {
|
||||
$val = "undef";
|
||||
}
|
||||
elsif(ref($val)) {
|
||||
$val = '[' . join(",",
|
||||
map {
|
||||
my $v = "undef";
|
||||
if(defined $_) {
|
||||
($v = $_) =~ s/'/\'/sog;
|
||||
$v = "'" . $v . "'";
|
||||
}
|
||||
$v;
|
||||
} @$val ) . ']';
|
||||
}
|
||||
else {
|
||||
$val =~ s/'/\'/sog;
|
||||
$val = "'" . $val . "'" if $val =~ /\D/;
|
||||
}
|
||||
print $fh "\t'",$key,"' => ",$val,",\n";
|
||||
}
|
||||
|
||||
print $fh "}\n";
|
||||
|
||||
$fh->close;
|
||||
|
||||
############################################################################
|
||||
############################################################################
|
||||
|
||||
exit 0;
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,14 @@
|
||||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0;
|
||||
|
||||
# This "perldoc" file was generated by "perldoc.PL"
|
||||
|
||||
require 5;
|
||||
BEGIN {
|
||||
$^W = 1 if $ENV{'PERLDOCDEBUG'};
|
||||
pop @INC if $INC[-1] eq '.';
|
||||
}
|
||||
use Pod::Perldoc;
|
||||
exit( Pod::Perldoc->run() );
|
||||
|
||||
@@ -0,0 +1,392 @@
|
||||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0; # ^ Run only under a shell
|
||||
|
||||
# perlivp v5.38.2
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
|
||||
sub usage {
|
||||
warn "@_\n" if @_;
|
||||
print << " EOUSAGE";
|
||||
Usage:
|
||||
|
||||
$0 [-p] [-v] | [-h]
|
||||
|
||||
-p Print a preface before each test telling what it will test.
|
||||
-v Verbose mode in which extra information about test results
|
||||
is printed. Test failures always print out some extra information
|
||||
regardless of whether or not this switch is set.
|
||||
-h Prints this help message.
|
||||
EOUSAGE
|
||||
exit;
|
||||
}
|
||||
|
||||
use vars qw(%opt); # allow testing with older versions (do not use our)
|
||||
|
||||
@opt{ qw/? H h P p V v/ } = qw(0 0 0 0 0 0 0);
|
||||
|
||||
while ($ARGV[0] =~ /^-/) {
|
||||
$ARGV[0] =~ s/^-//;
|
||||
for my $flag (split(//,$ARGV[0])) {
|
||||
usage() if '?' =~ /\Q$flag/;
|
||||
usage() if 'h' =~ /\Q$flag/;
|
||||
usage() if 'H' =~ /\Q$flag/;
|
||||
usage("unknown flag: '$flag'") unless 'HhPpVv' =~ /\Q$flag/;
|
||||
warn "$0: '$flag' flag already set\n" if $opt{$flag}++;
|
||||
}
|
||||
shift;
|
||||
}
|
||||
|
||||
$opt{p}++ if $opt{P};
|
||||
$opt{v}++ if $opt{V};
|
||||
|
||||
my $pass__total = 0;
|
||||
my $error_total = 0;
|
||||
my $tests_total = 0;
|
||||
|
||||
my $perlpath = '/usr/bin/perl';
|
||||
my $useithreads = 'define';
|
||||
|
||||
print "## Checking Perl binary via variable '\$perlpath' = $perlpath.\n" if $opt{'p'};
|
||||
|
||||
my $label = 'Executable perl binary';
|
||||
|
||||
if (-x $perlpath) {
|
||||
print "## Perl binary '$perlpath' appears executable.\n" if $opt{'v'};
|
||||
print "ok 1 $label\n";
|
||||
$pass__total++;
|
||||
}
|
||||
else {
|
||||
print "# Perl binary '$perlpath' does not appear executable.\n";
|
||||
print "not ok 1 $label\n";
|
||||
$error_total++;
|
||||
}
|
||||
$tests_total++;
|
||||
|
||||
|
||||
print "## Checking Perl version via variable '\$]'.\n" if $opt{'p'};
|
||||
|
||||
my $ivp_VERSION = "5.038002";
|
||||
|
||||
|
||||
$label = 'Perl version correct';
|
||||
if ($ivp_VERSION eq $]) {
|
||||
print "## Perl version '$]' appears installed as expected.\n" if $opt{'v'};
|
||||
print "ok 2 $label\n";
|
||||
$pass__total++;
|
||||
}
|
||||
else {
|
||||
print "# Perl version '$]' installed, expected $ivp_VERSION.\n";
|
||||
print "not ok 2 $label\n";
|
||||
$error_total++;
|
||||
}
|
||||
$tests_total++;
|
||||
|
||||
# We have the right perl and version, so now reset @INC so we ignore
|
||||
# PERL5LIB and '.'
|
||||
{
|
||||
local $ENV{PERL5LIB};
|
||||
my $perl_V = qx($perlpath -V);
|
||||
$perl_V =~ s{.*\@INC:\n}{}ms;
|
||||
@INC = grep { length && $_ ne '.' } split ' ', $perl_V;
|
||||
}
|
||||
|
||||
print "## Checking roots of the Perl library directory tree via variable '\@INC'.\n" if $opt{'p'};
|
||||
|
||||
my $INC_total = 0;
|
||||
my $INC_there = 0;
|
||||
foreach (@INC) {
|
||||
next if $_ eq '.'; # skip -d test here
|
||||
if (-d $_) {
|
||||
print "## Perl \@INC directory '$_' exists.\n" if $opt{'v'};
|
||||
$INC_there++;
|
||||
}
|
||||
else {
|
||||
print "# Perl \@INC directory '$_' does not appear to exist.\n";
|
||||
}
|
||||
$INC_total++;
|
||||
}
|
||||
|
||||
$label = '@INC directories exist';
|
||||
if ($INC_total == $INC_there) {
|
||||
print "ok 3 $label\n";
|
||||
$pass__total++;
|
||||
}
|
||||
else {
|
||||
print "not ok 3 $label\n";
|
||||
$error_total++;
|
||||
}
|
||||
$tests_total++;
|
||||
|
||||
|
||||
print "## Checking installations of modules necessary for ivp.\n" if $opt{'p'};
|
||||
|
||||
my $needed_total = 0;
|
||||
my $needed_there = 0;
|
||||
foreach (qw(Config.pm ExtUtils/Installed.pm)) {
|
||||
$@ = undef;
|
||||
$needed_total++;
|
||||
eval "require \"$_\";";
|
||||
if (!$@) {
|
||||
print "## Module '$_' appears to be installed.\n" if $opt{'v'};
|
||||
$needed_there++;
|
||||
}
|
||||
else {
|
||||
print "# Needed module '$_' does not appear to be properly installed.\n";
|
||||
}
|
||||
$@ = undef;
|
||||
}
|
||||
$label = 'Modules needed for rest of perlivp exist';
|
||||
if ($needed_total == $needed_there) {
|
||||
print "ok 4 $label\n";
|
||||
$pass__total++;
|
||||
}
|
||||
else {
|
||||
print "not ok 4 $label\n";
|
||||
$error_total++;
|
||||
}
|
||||
$tests_total++;
|
||||
|
||||
|
||||
print "## Checking installations of extensions built with perl.\n" if $opt{'p'};
|
||||
|
||||
use Config;
|
||||
|
||||
my $extensions_total = 0;
|
||||
my $extensions_there = 0;
|
||||
if (defined($Config{'extensions'})) {
|
||||
my @extensions = split(/\s+/,$Config{'extensions'});
|
||||
foreach (@extensions) {
|
||||
next if ($_ eq '');
|
||||
if ( $useithreads !~ /define/i ) {
|
||||
next if ($_ eq 'threads');
|
||||
next if ($_ eq 'threads/shared');
|
||||
}
|
||||
# that's a distribution name, not a module name
|
||||
next if $_ eq 'IO/Compress';
|
||||
next if $_ eq 'Devel/DProf';
|
||||
next if $_ eq 'libnet';
|
||||
next if $_ eq 'Locale/Codes';
|
||||
next if $_ eq 'podlators';
|
||||
next if $_ eq 'perlfaq';
|
||||
# test modules
|
||||
next if $_ eq 'XS/APItest';
|
||||
next if $_ eq 'XS/Typemap';
|
||||
# VMS$ perl -e "eval ""require \""Devel/DProf.pm\"";"" print $@"
|
||||
# \NT> perl -e "eval \"require './Devel/DProf.pm'\"; print $@"
|
||||
# DProf: run perl with -d to use DProf.
|
||||
# Compilation failed in require at (eval 1) line 1.
|
||||
eval " require \"$_.pm\"; ";
|
||||
if (!$@) {
|
||||
print "## Module '$_' appears to be installed.\n" if $opt{'v'};
|
||||
$extensions_there++;
|
||||
}
|
||||
else {
|
||||
print "# Required module '$_' does not appear to be properly installed.\n";
|
||||
$@ = undef;
|
||||
}
|
||||
$extensions_total++;
|
||||
}
|
||||
|
||||
# A silly name for a module (that hopefully won't ever exist).
|
||||
# Note that this test serves more as a check of the validity of the
|
||||
# actual required module tests above.
|
||||
my $unnecessary = 'bLuRfle';
|
||||
|
||||
if (!grep(/$unnecessary/, @extensions)) {
|
||||
$@ = undef;
|
||||
eval " require \"$unnecessary.pm\"; ";
|
||||
if ($@) {
|
||||
print "## Unnecessary module '$unnecessary' does not appear to be installed.\n" if $opt{'v'};
|
||||
}
|
||||
else {
|
||||
print "# Unnecessary module '$unnecessary' appears to be installed.\n";
|
||||
$extensions_there++;
|
||||
}
|
||||
}
|
||||
$@ = undef;
|
||||
}
|
||||
$label = 'All (and only) expected extensions installed';
|
||||
if ($extensions_total == $extensions_there) {
|
||||
print "ok 5 $label\n";
|
||||
$pass__total++;
|
||||
}
|
||||
else {
|
||||
print "not ok 5 $label\n";
|
||||
$error_total++;
|
||||
}
|
||||
$tests_total++;
|
||||
|
||||
|
||||
print "## Checking installations of later additional extensions.\n" if $opt{'p'};
|
||||
|
||||
use ExtUtils::Installed;
|
||||
|
||||
my $installed_total = 0;
|
||||
my $installed_there = 0;
|
||||
my $version_check = 0;
|
||||
my $installed = ExtUtils::Installed -> new();
|
||||
my @modules = $installed -> modules();
|
||||
my @missing = ();
|
||||
my $version = undef;
|
||||
for (@modules) {
|
||||
$installed_total++;
|
||||
# Consider it there if it contains one or more files,
|
||||
# and has zero missing files,
|
||||
# and has a defined version
|
||||
$version = undef;
|
||||
$version = $installed -> version($_);
|
||||
if ($version) {
|
||||
print "## $_; $version\n" if $opt{'v'};
|
||||
$version_check++;
|
||||
}
|
||||
else {
|
||||
print "# $_; NO VERSION\n" if $opt{'v'};
|
||||
}
|
||||
$version = undef;
|
||||
@missing = ();
|
||||
@missing = $installed -> validate($_);
|
||||
|
||||
# .bs files are optional
|
||||
@missing = grep { ! /\.bs$/ } @missing;
|
||||
# man files are often compressed
|
||||
@missing = grep { ! ( -s "$_.gz" || -s "$_.bz2" ) } @missing;
|
||||
|
||||
if ($#missing >= 0) {
|
||||
print "# file",+($#missing == 0) ? '' : 's'," missing from installation:\n";
|
||||
print '# ',join(' ',@missing),"\n";
|
||||
}
|
||||
elsif ($#missing == -1) {
|
||||
$installed_there++;
|
||||
}
|
||||
@missing = ();
|
||||
}
|
||||
$label = 'Module files correctly installed';
|
||||
if (($installed_total == $installed_there) &&
|
||||
($installed_total == $version_check)) {
|
||||
print "ok 6 $label\n";
|
||||
$pass__total++;
|
||||
}
|
||||
else {
|
||||
print "not ok 6 $label\n";
|
||||
$error_total++;
|
||||
}
|
||||
$tests_total++;
|
||||
|
||||
# Final report (rather than feed ousrselves to Test::Harness::runtests()
|
||||
# we simply format some output on our own to keep things simple and
|
||||
# easier to "fix" - at least for now.
|
||||
|
||||
if ($error_total == 0 && $tests_total) {
|
||||
print "All tests successful.\n";
|
||||
} elsif ($tests_total==0){
|
||||
die "FAILED--no tests were run for some reason.\n";
|
||||
} else {
|
||||
my $rate = 0.0;
|
||||
if ($tests_total > 0) { $rate = sprintf "%.2f", 100.0 * ($pass__total / $tests_total); }
|
||||
printf " %d/%d subtests failed, %.2f%% okay.\n",
|
||||
$error_total, $tests_total, $rate;
|
||||
}
|
||||
|
||||
=head1 NAME
|
||||
|
||||
perlivp - Perl Installation Verification Procedure
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
B<perlivp> [B<-p>] [B<-v>] [B<-h>]
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The B<perlivp> program is set up at Perl source code build time to test the
|
||||
Perl version it was built under. It can be used after running:
|
||||
|
||||
make install
|
||||
|
||||
(or your platform's equivalent procedure) to verify that B<perl> and its
|
||||
libraries have been installed correctly. A correct installation is verified
|
||||
by output that looks like:
|
||||
|
||||
ok 1
|
||||
ok 2
|
||||
|
||||
etc.
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
=over 5
|
||||
|
||||
=item B<-h> help
|
||||
|
||||
Prints out a brief help message.
|
||||
|
||||
=item B<-p> print preface
|
||||
|
||||
Gives a description of each test prior to performing it.
|
||||
|
||||
=item B<-v> verbose
|
||||
|
||||
Gives more detailed information about each test, after it has been performed.
|
||||
Note that any failed tests ought to print out some extra information whether
|
||||
or not -v is thrown.
|
||||
|
||||
=back
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
=over 4
|
||||
|
||||
=item * print "# Perl binary '$perlpath' does not appear executable.\n";
|
||||
|
||||
Likely to occur for a perl binary that was not properly installed.
|
||||
Correct by conducting a proper installation.
|
||||
|
||||
=item * print "# Perl version '$]' installed, expected $ivp_VERSION.\n";
|
||||
|
||||
Likely to occur for a perl that was not properly installed.
|
||||
Correct by conducting a proper installation.
|
||||
|
||||
=item * print "# Perl \@INC directory '$_' does not appear to exist.\n";
|
||||
|
||||
Likely to occur for a perl library tree that was not properly installed.
|
||||
Correct by conducting a proper installation.
|
||||
|
||||
=item * print "# Needed module '$_' does not appear to be properly installed.\n";
|
||||
|
||||
One of the two modules that is used by perlivp was not present in the
|
||||
installation. This is a serious error since it adversely affects perlivp's
|
||||
ability to function. You may be able to correct this by performing a
|
||||
proper perl installation.
|
||||
|
||||
=item * print "# Required module '$_' does not appear to be properly installed.\n";
|
||||
|
||||
An attempt to C<eval "require $module"> failed, even though the list of
|
||||
extensions indicated that it should succeed. Correct by conducting a proper
|
||||
installation.
|
||||
|
||||
=item * print "# Unnecessary module 'bLuRfle' appears to be installed.\n";
|
||||
|
||||
This test not coming out ok could indicate that you have in fact installed
|
||||
a bLuRfle.pm module or that the C<eval " require \"$module_name.pm\"; ">
|
||||
test may give misleading results with your installation of perl. If yours
|
||||
is the latter case then please let the author know.
|
||||
|
||||
=item * print "# file",+($#missing == 0) ? '' : 's'," missing from installation:\n";
|
||||
|
||||
One or more files turned up missing according to a run of
|
||||
C<ExtUtils::Installed -E<gt> validate()> over your installation.
|
||||
Correct by conducting a proper installation.
|
||||
|
||||
=back
|
||||
|
||||
For further information on how to conduct a proper installation consult the
|
||||
INSTALL file that comes with the perl source and the README file for your
|
||||
platform.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Peter Prymmer
|
||||
|
||||
=cut
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,322 @@
|
||||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0; # ^ Run only under a shell
|
||||
#!./perl
|
||||
# $Id: piconv,v 2.8 2016/08/04 03:15:58 dankogai Exp $
|
||||
#
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use 5.8.0;
|
||||
use strict;
|
||||
use Encode ;
|
||||
use Encode::Alias;
|
||||
my %Scheme = map {$_ => 1} qw(from_to decode_encode perlio);
|
||||
|
||||
use File::Basename;
|
||||
my $name = basename($0);
|
||||
|
||||
use Getopt::Long qw(:config no_ignore_case);
|
||||
|
||||
my %Opt;
|
||||
|
||||
help()
|
||||
unless
|
||||
GetOptions(\%Opt,
|
||||
'from|f=s',
|
||||
'to|t=s',
|
||||
'list|l',
|
||||
'string|s=s',
|
||||
'check|C=i',
|
||||
'c',
|
||||
'perlqq|p',
|
||||
'htmlcref',
|
||||
'xmlcref',
|
||||
'debug|D',
|
||||
'scheme|S=s',
|
||||
'resolve|r=s',
|
||||
'help',
|
||||
);
|
||||
|
||||
$Opt{help} and help();
|
||||
$Opt{list} and list_encodings();
|
||||
my $locale = $ENV{LC_CTYPE} || $ENV{LC_ALL} || $ENV{LANG};
|
||||
defined $Opt{resolve} and resolve_encoding($Opt{resolve});
|
||||
$Opt{from} || $Opt{to} || help();
|
||||
my $from = $Opt{from} || $locale or help("from_encoding unspecified");
|
||||
my $to = $Opt{to} || $locale or help("to_encoding unspecified");
|
||||
$Opt{string} and Encode::from_to($Opt{string}, $from, $to) and print $Opt{string} and exit;
|
||||
my $scheme = do {
|
||||
if (defined $Opt{scheme}) {
|
||||
if (!exists $Scheme{$Opt{scheme}}) {
|
||||
warn "Unknown scheme '$Opt{scheme}', fallback to 'from_to'.\n";
|
||||
'from_to';
|
||||
} else {
|
||||
$Opt{scheme};
|
||||
}
|
||||
} else {
|
||||
'from_to';
|
||||
}
|
||||
};
|
||||
|
||||
$Opt{check} ||= $Opt{c};
|
||||
$Opt{perlqq} and $Opt{check} = Encode::PERLQQ;
|
||||
$Opt{htmlcref} and $Opt{check} = Encode::HTMLCREF;
|
||||
$Opt{xmlcref} and $Opt{check} = Encode::XMLCREF;
|
||||
|
||||
my $efrom = Encode->getEncoding($from) || die "Unknown encoding '$from'";
|
||||
my $eto = Encode->getEncoding($to) || die "Unknown encoding '$to'";
|
||||
|
||||
my $cfrom = $efrom->name;
|
||||
my $cto = $eto->name;
|
||||
|
||||
if ($Opt{debug}){
|
||||
print <<"EOT";
|
||||
Scheme: $scheme
|
||||
From: $from => $cfrom
|
||||
To: $to => $cto
|
||||
EOT
|
||||
}
|
||||
|
||||
my %use_bom =
|
||||
map { $_ => 1 } qw/UTF-16 UTF-16BE UTF-16LE UTF-32 UTF-32BE UTF-32LE/;
|
||||
|
||||
# we do not use <> (or ARGV) for the sake of binmode()
|
||||
@ARGV or push @ARGV, \*STDIN;
|
||||
|
||||
unless ( $scheme eq 'perlio' ) {
|
||||
binmode STDOUT;
|
||||
my $need2slurp = $use_bom{ $eto } || $use_bom{ $efrom };
|
||||
for my $argv (@ARGV) {
|
||||
my $ifh = ref $argv ? $argv : undef;
|
||||
$ifh or open $ifh, "<", $argv or warn "Can't open $argv: $!" and next;
|
||||
$ifh or open $ifh, "<", $argv or next;
|
||||
binmode $ifh;
|
||||
if ( $scheme eq 'from_to' ) { # default
|
||||
if ($need2slurp){
|
||||
local $/;
|
||||
$_ = <$ifh>;
|
||||
Encode::from_to( $_, $from, $to, $Opt{check} );
|
||||
print;
|
||||
}else{
|
||||
while (<$ifh>) {
|
||||
Encode::from_to( $_, $from, $to, $Opt{check} );
|
||||
print;
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ( $scheme eq 'decode_encode' ) { # step-by-step
|
||||
if ($need2slurp){
|
||||
local $/;
|
||||
$_ = <$ifh>;
|
||||
my $decoded = decode( $from, $_, $Opt{check} );
|
||||
my $encoded = encode( $to, $decoded );
|
||||
print $encoded;
|
||||
}else{
|
||||
while (<$ifh>) {
|
||||
my $decoded = decode( $from, $_, $Opt{check} );
|
||||
my $encoded = encode( $to, $decoded );
|
||||
print $encoded;
|
||||
}
|
||||
}
|
||||
}
|
||||
else { # won't reach
|
||||
die "$name: unknown scheme: $scheme";
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
|
||||
# NI-S favorite
|
||||
binmode STDOUT => "raw:encoding($to)";
|
||||
for my $argv (@ARGV) {
|
||||
my $ifh = ref $argv ? $argv : undef;
|
||||
$ifh or open $ifh, "<", $argv or warn "Can't open $argv: $!" and next;
|
||||
$ifh or open $ifh, "<", $argv or next;
|
||||
binmode $ifh => "raw:encoding($from)";
|
||||
print while (<$ifh>);
|
||||
}
|
||||
}
|
||||
|
||||
sub list_encodings {
|
||||
print join( "\n", Encode->encodings(":all") ), "\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
sub resolve_encoding {
|
||||
if ( my $alias = Encode::resolve_alias( $_[0] ) ) {
|
||||
print $alias, "\n";
|
||||
exit 0;
|
||||
}
|
||||
else {
|
||||
warn "$name: $_[0] is not known to Encode\n";
|
||||
exit 1;
|
||||
}
|
||||
}
|
||||
|
||||
sub help {
|
||||
my $message = shift;
|
||||
$message and print STDERR "$name error: $message\n";
|
||||
print STDERR <<"EOT";
|
||||
$name [-f from_encoding] [-t to_encoding]
|
||||
[-p|--perlqq|--htmlcref|--xmlcref] [-C N|-c] [-D] [-S scheme]
|
||||
[-s string|file...]
|
||||
$name -l
|
||||
$name -r encoding_alias
|
||||
$name -h
|
||||
Common options:
|
||||
-l,--list
|
||||
lists all available encodings
|
||||
-r,--resolve encoding_alias
|
||||
resolve encoding to its (Encode) canonical name
|
||||
-f,--from from_encoding
|
||||
when omitted, the current locale will be used
|
||||
-t,--to to_encoding
|
||||
when omitted, the current locale will be used
|
||||
-s,--string string
|
||||
"string" will be the input instead of STDIN or files
|
||||
The following are mainly of interest to Encode hackers:
|
||||
-C N | -c check the validity of the input
|
||||
-D,--debug show debug information
|
||||
-S,--scheme scheme use the scheme for conversion
|
||||
Those are handy when you can only see ASCII characters:
|
||||
-p,--perlqq transliterate characters missing in encoding to \\x{HHHH}
|
||||
where HHHH is the hexadecimal Unicode code point
|
||||
--htmlcref transliterate characters missing in encoding to &#NNN;
|
||||
where NNN is the decimal Unicode code point
|
||||
--xmlcref transliterate characters missing in encoding to &#xHHHH;
|
||||
where HHHH is the hexadecimal Unicode code point
|
||||
|
||||
EOT
|
||||
exit;
|
||||
}
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
piconv -- iconv(1), reinvented in perl
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
piconv [-f from_encoding] [-t to_encoding]
|
||||
[-p|--perlqq|--htmlcref|--xmlcref] [-C N|-c] [-D] [-S scheme]
|
||||
[-s string|file...]
|
||||
piconv -l
|
||||
piconv -r encoding_alias
|
||||
piconv -h
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<piconv> is perl version of B<iconv>, a character encoding converter
|
||||
widely available for various Unixen today. This script was primarily
|
||||
a technology demonstrator for Perl 5.8.0, but you can use piconv in the
|
||||
place of iconv for virtually any case.
|
||||
|
||||
piconv converts the character encoding of either STDIN or files
|
||||
specified in the argument and prints out to STDOUT.
|
||||
|
||||
Here is the list of options. Some options can be in short format (-f)
|
||||
or long (--from) one.
|
||||
|
||||
=over 4
|
||||
|
||||
=item -f,--from I<from_encoding>
|
||||
|
||||
Specifies the encoding you are converting from. Unlike B<iconv>,
|
||||
this option can be omitted. In such cases, the current locale is used.
|
||||
|
||||
=item -t,--to I<to_encoding>
|
||||
|
||||
Specifies the encoding you are converting to. Unlike B<iconv>,
|
||||
this option can be omitted. In such cases, the current locale is used.
|
||||
|
||||
Therefore, when both -f and -t are omitted, B<piconv> just acts
|
||||
like B<cat>.
|
||||
|
||||
=item -s,--string I<string>
|
||||
|
||||
uses I<string> instead of file for the source of text.
|
||||
|
||||
=item -l,--list
|
||||
|
||||
Lists all available encodings, one per line, in case-insensitive
|
||||
order. Note that only the canonical names are listed; many aliases
|
||||
exist. For example, the names are case-insensitive, and many standard
|
||||
and common aliases work, such as "latin1" for "ISO-8859-1", or "ibm850"
|
||||
instead of "cp850", or "winlatin1" for "cp1252". See L<Encode::Supported>
|
||||
for a full discussion.
|
||||
|
||||
=item -r,--resolve I<encoding_alias>
|
||||
|
||||
Resolve I<encoding_alias> to Encode canonical encoding name.
|
||||
|
||||
=item -C,--check I<N>
|
||||
|
||||
Check the validity of the stream if I<N> = 1. When I<N> = -1, something
|
||||
interesting happens when it encounters an invalid character.
|
||||
|
||||
=item -c
|
||||
|
||||
Same as C<-C 1>.
|
||||
|
||||
=item -p,--perlqq
|
||||
|
||||
Transliterate characters missing in encoding to \x{HHHH} where HHHH is the
|
||||
hexadecimal Unicode code point.
|
||||
|
||||
=item --htmlcref
|
||||
|
||||
Transliterate characters missing in encoding to &#NNN; where NNN is the
|
||||
decimal Unicode code point.
|
||||
|
||||
=item --xmlcref
|
||||
|
||||
Transliterate characters missing in encoding to &#xHHHH; where HHHH is the
|
||||
hexadecimal Unicode code point.
|
||||
|
||||
=item -h,--help
|
||||
|
||||
Show usage.
|
||||
|
||||
=item -D,--debug
|
||||
|
||||
Invokes debugging mode. Primarily for Encode hackers.
|
||||
|
||||
=item -S,--scheme I<scheme>
|
||||
|
||||
Selects which scheme is to be used for conversion. Available schemes
|
||||
are as follows:
|
||||
|
||||
=over 4
|
||||
|
||||
=item from_to
|
||||
|
||||
Uses Encode::from_to for conversion. This is the default.
|
||||
|
||||
=item decode_encode
|
||||
|
||||
Input strings are decode()d then encode()d. A straight two-step
|
||||
implementation.
|
||||
|
||||
=item perlio
|
||||
|
||||
The new perlIO layer is used. NI-S' favorite.
|
||||
|
||||
You should use this option if you are using UTF-16 and others which
|
||||
linefeed is not $/.
|
||||
|
||||
=back
|
||||
|
||||
Like the I<-D> option, this is also for Encode hackers.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<iconv(1)>
|
||||
L<locale(3)>
|
||||
L<Encode>
|
||||
L<Encode::Supported>
|
||||
L<Encode::Alias>
|
||||
L<PerlIO>
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,378 @@
|
||||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0; # ^ Run only under a shell
|
||||
|
||||
=head1 NAME
|
||||
|
||||
pl2pm - Rough tool to translate Perl4 .pl files to Perl5 .pm modules.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
B<pl2pm> F<files>
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<pl2pm> is a tool to aid in the conversion of Perl4-style .pl
|
||||
library files to Perl5-style library modules. Usually, your old .pl
|
||||
file will still work fine and you should only use this tool if you
|
||||
plan to update your library to use some of the newer Perl 5 features,
|
||||
such as AutoLoading.
|
||||
|
||||
=head1 LIMITATIONS
|
||||
|
||||
It's just a first step, but it's usually a good first step.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Larry Wall <larry@wall.org>
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
my %keyword = ();
|
||||
|
||||
while (<DATA>) {
|
||||
chomp;
|
||||
$keyword{$_} = 1;
|
||||
}
|
||||
|
||||
local $/;
|
||||
|
||||
while (<>) {
|
||||
my $newname = $ARGV;
|
||||
$newname =~ s/\.pl$/.pm/ || next;
|
||||
$newname =~ s#(.*/)?(\w+)#$1\u$2#;
|
||||
if (-f $newname) {
|
||||
warn "Won't overwrite existing $newname\n";
|
||||
next;
|
||||
}
|
||||
my $oldpack = $2;
|
||||
my $newpack = "\u$2";
|
||||
my @export = ();
|
||||
|
||||
s/\bstd(in|out|err)\b/\U$&/g;
|
||||
s/(sub\s+)(\w+)(\s*\{[ \t]*\n)\s*package\s+$oldpack\s*;[ \t]*\n+/${1}main'$2$3/ig;
|
||||
if (/sub\s+\w+'/) {
|
||||
@export = m/sub\s+\w+'(\w+)/g;
|
||||
s/(sub\s+)main'(\w+)/$1$2/g;
|
||||
}
|
||||
else {
|
||||
@export = m/sub\s+([A-Za-z]\w*)/g;
|
||||
}
|
||||
my @export_ok = grep($keyword{$_}, @export);
|
||||
@export = grep(!$keyword{$_}, @export);
|
||||
|
||||
my %export = ();
|
||||
@export{@export} = (1) x @export;
|
||||
|
||||
s/(^\s*);#/$1#/g;
|
||||
s/(#.*)require ['"]$oldpack\.pl['"]/$1use $newpack/;
|
||||
s/(package\s*)($oldpack)\s*;[ \t]*\n+//ig;
|
||||
s/([\$\@%&*])'(\w+)/&xlate($1,"",$2,$newpack,$oldpack,\%export)/eg;
|
||||
s/([\$\@%&*]?)(\w+)'(\w+)/&xlate($1,$2,$3,$newpack,$oldpack,\%export)/eg;
|
||||
if (!/\$\[\s*\)?\s*=\s*[^0\s]/) {
|
||||
s/^\s*(local\s*\()?\s*\$\[\s*\)?\s*=\s*0\s*;[ \t]*\n//g;
|
||||
s/\$\[\s*\+\s*//g;
|
||||
s/\s*\+\s*\$\[//g;
|
||||
s/\$\[/0/g;
|
||||
}
|
||||
s/open\s+(\w+)/open($1)/g;
|
||||
|
||||
my $export_ok = '';
|
||||
my $carp ='';
|
||||
|
||||
|
||||
if (s/\bdie\b/croak/g) {
|
||||
$carp = "use Carp;\n";
|
||||
s/croak "([^"]*)\\n"/croak "$1"/g;
|
||||
}
|
||||
|
||||
if (@export_ok) {
|
||||
$export_ok = "\@EXPORT_OK = qw(@export_ok);\n";
|
||||
}
|
||||
|
||||
if ( open(PM, ">", $newname) ) {
|
||||
print PM <<"END";
|
||||
package $newpack;
|
||||
use 5.006;
|
||||
require Exporter;
|
||||
$carp
|
||||
\@ISA = qw(Exporter);
|
||||
\@EXPORT = qw(@export);
|
||||
$export_ok
|
||||
$_
|
||||
END
|
||||
}
|
||||
else {
|
||||
warn "Can't create $newname: $!\n";
|
||||
}
|
||||
}
|
||||
|
||||
sub xlate {
|
||||
my ($prefix, $pack, $ident,$newpack,$oldpack,$export) = @_;
|
||||
|
||||
my $xlated ;
|
||||
if ($prefix eq '' && $ident =~ /^(t|s|m|d|ing|ll|ed|ve|re)$/) {
|
||||
$xlated = "${pack}'$ident";
|
||||
}
|
||||
elsif ($pack eq '' || $pack eq 'main') {
|
||||
if ($export->{$ident}) {
|
||||
$xlated = "$prefix$ident";
|
||||
}
|
||||
else {
|
||||
$xlated = "$prefix${pack}::$ident";
|
||||
}
|
||||
}
|
||||
elsif ($pack eq $oldpack) {
|
||||
$xlated = "$prefix${newpack}::$ident";
|
||||
}
|
||||
else {
|
||||
$xlated = "$prefix${pack}::$ident";
|
||||
}
|
||||
|
||||
return $xlated;
|
||||
}
|
||||
__END__
|
||||
AUTOLOAD
|
||||
BEGIN
|
||||
CHECK
|
||||
CORE
|
||||
DESTROY
|
||||
END
|
||||
INIT
|
||||
UNITCHECK
|
||||
abs
|
||||
accept
|
||||
alarm
|
||||
and
|
||||
atan2
|
||||
bind
|
||||
binmode
|
||||
bless
|
||||
caller
|
||||
chdir
|
||||
chmod
|
||||
chomp
|
||||
chop
|
||||
chown
|
||||
chr
|
||||
chroot
|
||||
close
|
||||
closedir
|
||||
cmp
|
||||
connect
|
||||
continue
|
||||
cos
|
||||
crypt
|
||||
dbmclose
|
||||
dbmopen
|
||||
defined
|
||||
delete
|
||||
die
|
||||
do
|
||||
dump
|
||||
each
|
||||
else
|
||||
elsif
|
||||
endgrent
|
||||
endhostent
|
||||
endnetent
|
||||
endprotoent
|
||||
endpwent
|
||||
endservent
|
||||
eof
|
||||
eq
|
||||
eval
|
||||
exec
|
||||
exists
|
||||
exit
|
||||
exp
|
||||
fcntl
|
||||
fileno
|
||||
flock
|
||||
for
|
||||
foreach
|
||||
fork
|
||||
format
|
||||
formline
|
||||
ge
|
||||
getc
|
||||
getgrent
|
||||
getgrgid
|
||||
getgrnam
|
||||
gethostbyaddr
|
||||
gethostbyname
|
||||
gethostent
|
||||
getlogin
|
||||
getnetbyaddr
|
||||
getnetbyname
|
||||
getnetent
|
||||
getpeername
|
||||
getpgrp
|
||||
getppid
|
||||
getpriority
|
||||
getprotobyname
|
||||
getprotobynumber
|
||||
getprotoent
|
||||
getpwent
|
||||
getpwnam
|
||||
getpwuid
|
||||
getservbyname
|
||||
getservbyport
|
||||
getservent
|
||||
getsockname
|
||||
getsockopt
|
||||
glob
|
||||
gmtime
|
||||
goto
|
||||
grep
|
||||
gt
|
||||
hex
|
||||
if
|
||||
index
|
||||
int
|
||||
ioctl
|
||||
join
|
||||
keys
|
||||
kill
|
||||
last
|
||||
lc
|
||||
lcfirst
|
||||
le
|
||||
length
|
||||
link
|
||||
listen
|
||||
local
|
||||
localtime
|
||||
lock
|
||||
log
|
||||
lstat
|
||||
lt
|
||||
m
|
||||
map
|
||||
mkdir
|
||||
msgctl
|
||||
msgget
|
||||
msgrcv
|
||||
msgsnd
|
||||
my
|
||||
ne
|
||||
next
|
||||
no
|
||||
not
|
||||
oct
|
||||
open
|
||||
opendir
|
||||
or
|
||||
ord
|
||||
our
|
||||
pack
|
||||
package
|
||||
pipe
|
||||
pop
|
||||
pos
|
||||
print
|
||||
printf
|
||||
prototype
|
||||
push
|
||||
q
|
||||
qq
|
||||
qr
|
||||
quotemeta
|
||||
qw
|
||||
qx
|
||||
rand
|
||||
read
|
||||
readdir
|
||||
readline
|
||||
readlink
|
||||
readpipe
|
||||
recv
|
||||
redo
|
||||
ref
|
||||
rename
|
||||
require
|
||||
reset
|
||||
return
|
||||
reverse
|
||||
rewinddir
|
||||
rindex
|
||||
rmdir
|
||||
s
|
||||
scalar
|
||||
seek
|
||||
seekdir
|
||||
select
|
||||
semctl
|
||||
semget
|
||||
semop
|
||||
send
|
||||
setgrent
|
||||
sethostent
|
||||
setnetent
|
||||
setpgrp
|
||||
setpriority
|
||||
setprotoent
|
||||
setpwent
|
||||
setservent
|
||||
setsockopt
|
||||
shift
|
||||
shmctl
|
||||
shmget
|
||||
shmread
|
||||
shmwrite
|
||||
shutdown
|
||||
sin
|
||||
sleep
|
||||
socket
|
||||
socketpair
|
||||
sort
|
||||
splice
|
||||
split
|
||||
sprintf
|
||||
sqrt
|
||||
srand
|
||||
stat
|
||||
study
|
||||
sub
|
||||
substr
|
||||
symlink
|
||||
syscall
|
||||
sysopen
|
||||
sysread
|
||||
sysseek
|
||||
system
|
||||
syswrite
|
||||
tell
|
||||
telldir
|
||||
tie
|
||||
tied
|
||||
time
|
||||
times
|
||||
tr
|
||||
truncate
|
||||
uc
|
||||
ucfirst
|
||||
umask
|
||||
undef
|
||||
unless
|
||||
unlink
|
||||
unpack
|
||||
unshift
|
||||
untie
|
||||
until
|
||||
use
|
||||
utime
|
||||
values
|
||||
vec
|
||||
wait
|
||||
waitpid
|
||||
wantarray
|
||||
warn
|
||||
while
|
||||
write
|
||||
x
|
||||
xor
|
||||
y
|
||||
@@ -0,0 +1,202 @@
|
||||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0; # ^ Run only under a shell
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
pod2html - convert .pod files to .html files
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
pod2html --help --htmldir=<name> --htmlroot=<URL>
|
||||
--infile=<name> --outfile=<name>
|
||||
--podpath=<name>:...:<name> --podroot=<name>
|
||||
--cachedir=<name> --flush --recurse --norecurse
|
||||
--quiet --noquiet --verbose --noverbose
|
||||
--index --noindex --backlink --nobacklink
|
||||
--header --noheader --poderrors --nopoderrors
|
||||
--css=<URL> --title=<name>
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Converts files from pod format (see L<perlpod>) to HTML format.
|
||||
|
||||
=head1 ARGUMENTS
|
||||
|
||||
pod2html takes the following arguments:
|
||||
|
||||
=over 4
|
||||
|
||||
=item backlink
|
||||
|
||||
--backlink
|
||||
--nobacklink
|
||||
|
||||
Turn =head1 directives into links pointing to the top of the HTML file.
|
||||
--nobacklink (which is the default behavior) does not create these backlinks.
|
||||
|
||||
=item cachedir
|
||||
|
||||
--cachedir=name
|
||||
|
||||
Specify which directory is used for storing cache. Default directory is the
|
||||
current working directory.
|
||||
|
||||
=item css
|
||||
|
||||
--css=URL
|
||||
|
||||
Specify the URL of cascading style sheet to link from resulting HTML file.
|
||||
Default is none style sheet.
|
||||
|
||||
=item flush
|
||||
|
||||
--flush
|
||||
|
||||
Flush the cache.
|
||||
|
||||
=item header
|
||||
|
||||
--header
|
||||
--noheader
|
||||
|
||||
Create header and footer blocks containing the text of the "NAME" section.
|
||||
--noheader -- which is the default behavior -- does not create header or footer
|
||||
blocks.
|
||||
|
||||
=item help
|
||||
|
||||
--help
|
||||
|
||||
Displays the usage message.
|
||||
|
||||
=item htmldir
|
||||
|
||||
--htmldir=name
|
||||
|
||||
Sets the directory to which all cross references in the resulting HTML file
|
||||
will be relative. Not passing this causes all links to be absolute since this
|
||||
is the value that tells Pod::Html the root of the documentation tree.
|
||||
|
||||
Do not use this and --htmlroot in the same call to pod2html; they are mutually
|
||||
exclusive.
|
||||
|
||||
=item htmlroot
|
||||
|
||||
--htmlroot=URL
|
||||
|
||||
Sets the base URL for the HTML files. When cross-references are made, the
|
||||
HTML root is prepended to the URL.
|
||||
|
||||
Do not use this if relative links are desired: use --htmldir instead.
|
||||
|
||||
Do not pass both this and --htmldir to pod2html; they are mutually exclusive.
|
||||
|
||||
=item index
|
||||
|
||||
--index
|
||||
|
||||
Generate an index at the top of the HTML file (default behaviour).
|
||||
|
||||
=over 4
|
||||
|
||||
=item noindex
|
||||
|
||||
--noindex
|
||||
|
||||
Do not generate an index at the top of the HTML file.
|
||||
|
||||
=back
|
||||
|
||||
=item infile
|
||||
|
||||
--infile=name
|
||||
|
||||
Specify the pod file to convert. Input is taken from STDIN if no
|
||||
infile is specified.
|
||||
|
||||
=item outfile
|
||||
|
||||
--outfile=name
|
||||
|
||||
Specify the HTML file to create. Output goes to STDOUT if no outfile
|
||||
is specified.
|
||||
|
||||
=item poderrors
|
||||
|
||||
--poderrors
|
||||
--nopoderrors
|
||||
|
||||
Include a "POD ERRORS" section in the outfile if there were any POD errors in
|
||||
the infile (default behaviour). --nopoderrors does not create this "POD
|
||||
ERRORS" section.
|
||||
|
||||
=item podpath
|
||||
|
||||
--podpath=name:...:name
|
||||
|
||||
Specify which subdirectories of the podroot contain pod files whose
|
||||
HTML converted forms can be linked-to in cross-references.
|
||||
|
||||
=item podroot
|
||||
|
||||
--podroot=name
|
||||
|
||||
Specify the base directory for finding library pods.
|
||||
|
||||
=item quiet
|
||||
|
||||
--quiet
|
||||
--noquiet
|
||||
|
||||
Don't display mostly harmless warning messages. --noquiet -- which is the
|
||||
default behavior -- I<does> display these mostly harmless warning messages (but
|
||||
this is not the same as "verbose" mode).
|
||||
|
||||
=item recurse
|
||||
|
||||
--recurse
|
||||
--norecurse
|
||||
|
||||
Recurse into subdirectories specified in podpath (default behaviour).
|
||||
--norecurse does not recurse into these subdirectories.
|
||||
|
||||
=item title
|
||||
|
||||
--title=title
|
||||
|
||||
Specify the title of the resulting HTML file.
|
||||
|
||||
=item verbose
|
||||
|
||||
--verbose
|
||||
--noverbose
|
||||
|
||||
Display progress messages. --noverbose -- which is the default behavior --
|
||||
does not display these progress messages.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Tom Christiansen, E<lt>tchrist@perl.comE<gt>.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
See L<Pod::Html> for a list of known bugs in the translator.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<perlpod>, L<Pod::Html>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
This program is distributed under the Artistic License.
|
||||
|
||||
=cut
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use Pod::Html;
|
||||
|
||||
pod2html @ARGV;
|
||||
@@ -0,0 +1,475 @@
|
||||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0; # ^ Run only under a shell
|
||||
|
||||
# Convert POD data to formatted *roff input.
|
||||
#
|
||||
# The driver script for Pod::Man.
|
||||
#
|
||||
# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl
|
||||
|
||||
use 5.006;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Getopt::Long qw(GetOptions);
|
||||
use Pod::Man ();
|
||||
use Pod::Usage qw(pod2usage);
|
||||
|
||||
use strict;
|
||||
|
||||
# Clean up $0 for error reporting.
|
||||
$0 =~ s%.*/%%;
|
||||
|
||||
# Insert -- into @ARGV before any single dash argument to hide it from
|
||||
# Getopt::Long; we want to interpret it as meaning stdin.
|
||||
my $stdin;
|
||||
@ARGV = map { $_ eq '-' && !$stdin++ ? ('--', $_) : $_ } @ARGV;
|
||||
|
||||
# Parse our options, trying to retain backward compatibility with pod2man but
|
||||
# allowing short forms as well. --lax is currently ignored.
|
||||
my %options;
|
||||
Getopt::Long::config ('bundling_override');
|
||||
GetOptions (\%options, 'center|c=s', 'date|d=s', 'encoding|e=s', 'errors=s',
|
||||
'fixed=s', 'fixedbold=s', 'fixeditalic=s', 'fixedbolditalic=s',
|
||||
'guesswork=s', 'help|h', 'lax|l', 'language=s', 'lquote=s',
|
||||
'name|n=s', 'nourls', 'official|o', 'quotes|q=s', 'release|r=s',
|
||||
'rquote=s', 'section|s=s', 'stderr', 'verbose|v', 'utf8|u')
|
||||
or exit 1;
|
||||
pod2usage (0) if $options{help};
|
||||
|
||||
# Official sets --center, but don't override things explicitly set.
|
||||
if ($options{official} && !defined $options{center}) {
|
||||
$options{center} = 'Perl Programmers Reference Guide';
|
||||
}
|
||||
|
||||
# Verbose is only our flag, not a Pod::Man flag.
|
||||
my $verbose = $options{verbose};
|
||||
delete $options{verbose};
|
||||
|
||||
# This isn't a valid Pod::Man option and is only accepted for backward
|
||||
# compatibility.
|
||||
delete $options{lax};
|
||||
|
||||
# If neither stderr nor errors is set, default to errors = die.
|
||||
if (!defined $options{stderr} && !defined $options{errors}) {
|
||||
$options{errors} = 'die';
|
||||
}
|
||||
|
||||
# Initialize and run the formatter, pulling a pair of input and output off at
|
||||
# a time. For each file, we check whether the document was completely empty
|
||||
# and, if so, will remove the created file and exit with a non-zero exit
|
||||
# status.
|
||||
my $parser = Pod::Man->new (%options);
|
||||
my $status = 0;
|
||||
my @files;
|
||||
do {
|
||||
@files = splice (@ARGV, 0, 2);
|
||||
print " $files[1]\n" if $verbose;
|
||||
$parser->parse_from_file (@files);
|
||||
if ($parser->{CONTENTLESS}) {
|
||||
$status = 1;
|
||||
if (defined $files[0]) {
|
||||
warn "$0: unable to format $files[0]\n";
|
||||
} else {
|
||||
warn "$0: unable to format standard input\n";
|
||||
}
|
||||
if (defined ($files[1]) and $files[1] ne '-') {
|
||||
unlink $files[1] unless (-s $files[1]);
|
||||
}
|
||||
}
|
||||
} while (@ARGV);
|
||||
exit $status;
|
||||
|
||||
__END__
|
||||
|
||||
=for stopwords
|
||||
en em --stderr stderr --utf8 UTF-8 overdo markup MT-LEVEL Allbery Solaris URL
|
||||
troff troff-specific formatters uppercased Christiansen --nourls UTC prepend
|
||||
lquote rquote unrepresentable mandoc manref EBCDIC
|
||||
|
||||
=head1 NAME
|
||||
|
||||
pod2man - Convert POD data to formatted *roff input
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
pod2man [B<--center>=I<string>] [B<--date>=I<string>]
|
||||
[B<--encoding>=I<encoding>] [B<--errors>=I<style>] [B<--fixed>=I<font>]
|
||||
[B<--fixedbold>=I<font>] [B<--fixeditalic>=I<font>]
|
||||
[B<--fixedbolditalic>=I<font>] [B<--guesswork>=I<rule>[,I<rule>...]]
|
||||
[B<--name>=I<name>] [B<--nourls>] [B<--official>]
|
||||
[B<--release>=I<version>] [B<--section>=I<manext>]
|
||||
[B<--quotes>=I<quotes>] [B<--lquote>=I<quote>] [B<--rquote>=I<quote>]
|
||||
[B<--stderr>] [B<--utf8>] [B<--verbose>] [I<input> [I<output>] ...]
|
||||
|
||||
pod2man B<--help>
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<pod2man> is a wrapper script around the L<Pod::Man> module, using it to
|
||||
generate *roff input from POD source. The resulting *roff code is suitable
|
||||
for display on a terminal using L<nroff(1)>, normally via L<man(1)>, or
|
||||
printing using L<troff(1)>.
|
||||
|
||||
By default (on non-EBCDIC systems), B<pod2man> outputs UTF-8 manual pages.
|
||||
Its output should work with the B<man> program on systems that use B<groff>
|
||||
(most Linux distributions) or B<mandoc> (most BSD variants), but may result in
|
||||
mangled output on older UNIX systems. To choose a different, possibly more
|
||||
backward-compatible output mangling on such systems, use C<--encoding=roff>
|
||||
(the default in earlier Pod::Man versions). See the B<--encoding> option and
|
||||
L<Pod::Man/ENCODING> for more details.
|
||||
|
||||
I<input> is the file to read for POD source (the POD can be embedded in code).
|
||||
If I<input> isn't given, it defaults to C<STDIN>. I<output>, if given, is the
|
||||
file to which to write the formatted output. If I<output> isn't given, the
|
||||
formatted output is written to C<STDOUT>. Several POD files can be processed
|
||||
in the same B<pod2man> invocation (saving module load and compile times) by
|
||||
providing multiple pairs of I<input> and I<output> files on the command line.
|
||||
|
||||
B<--section>, B<--release>, B<--center>, B<--date>, and B<--official> can be
|
||||
used to set the headers and footers to use. If not given, Pod::Man will
|
||||
assume various defaults. See below for details.
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
Each option is annotated with the version of podlators in which that option
|
||||
was added with its current meaning.
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<-c> I<string>, B<--center>=I<string>
|
||||
|
||||
[1.00] Sets the centered page header for the C<.TH> macro to I<string>. The
|
||||
default is C<User Contributed Perl Documentation>, but also see B<--official>
|
||||
below.
|
||||
|
||||
=item B<-d> I<string>, B<--date>=I<string>
|
||||
|
||||
[4.00] Set the left-hand footer string for the C<.TH> macro to I<string>. By
|
||||
default, the first of POD_MAN_DATE, SOURCE_DATE_EPOCH, the modification date
|
||||
of the input file, or the current date (if input comes from C<STDIN>) will be
|
||||
used, and the date will be in UTC. See L<Pod::Man/CLASS METHODS> for more
|
||||
details.
|
||||
|
||||
=item B<-e> I<encoding>, B<--encoding>=I<encoding>
|
||||
|
||||
[5.00] Specifies the encoding of the output. I<encoding> must be an encoding
|
||||
recognized by the L<Encode> module (see L<Encode::Supported>). The default on
|
||||
non-EBCDIC systems is UTF-8.
|
||||
|
||||
If the output contains characters that cannot be represented in this encoding,
|
||||
that is an error that will be reported as configured by the B<--errors>
|
||||
option. If error handling is other than C<die>, the unrepresentable character
|
||||
will be replaced with the Encode substitution character (normally C<?>).
|
||||
|
||||
If the C<encoding> option is set to the special value C<groff> (the default on
|
||||
EBCDIC systems), or if the Encode module is not available and the encoding is
|
||||
set to anything other than C<roff> (see below), Pod::Man will translate all
|
||||
non-ASCII characters to C<\[uNNNN]> Unicode escapes. These are not
|
||||
traditionally part of the *roff language, but are supported by B<groff> and
|
||||
B<mandoc> and thus by the majority of manual page processors in use today.
|
||||
|
||||
If I<encoding> is set to the special value C<roff>, B<pod2man> will do its
|
||||
historic transformation of (some) ISO 8859-1 characters into *roff escapes
|
||||
that may be adequate in troff and may be readable (if ugly) in nroff. This
|
||||
was the default behavior of versions of B<pod2man> before 5.00. With this
|
||||
encoding, all other non-ASCII characters will be replaced with C<X>. It may
|
||||
be required for very old troff and nroff implementations that do not support
|
||||
UTF-8, but its representation of any non-ASCII character is very poor and
|
||||
often specific to European languages. Its use is discouraged.
|
||||
|
||||
WARNING: The input encoding of the POD source is independent from the output
|
||||
encoding, and setting this option does not affect the interpretation of the
|
||||
POD input. Unless your POD source is US-ASCII, its encoding should be
|
||||
declared with the C<=encoding> command in the source. If this is not done,
|
||||
Pod::Simple will will attempt to guess the encoding and may be successful if
|
||||
it's Latin-1 or UTF-8, but it will produce warnings. See L<perlpod(1)> for
|
||||
more information.
|
||||
|
||||
=item B<--errors>=I<style>
|
||||
|
||||
[2.5.0] Set the error handling style. C<die> says to throw an exception on
|
||||
any POD formatting error. C<stderr> says to report errors on standard error,
|
||||
but not to throw an exception. C<pod> says to include a POD ERRORS section in
|
||||
the resulting documentation summarizing the errors. C<none> ignores POD
|
||||
errors entirely, as much as possible.
|
||||
|
||||
The default is C<die>.
|
||||
|
||||
=item B<--fixed>=I<font>
|
||||
|
||||
[1.0] The fixed-width font to use for verbatim text and code. Defaults to
|
||||
C<CW>. Some systems may want C<CR> instead. Only matters for B<troff>
|
||||
output.
|
||||
|
||||
=item B<--fixedbold>=I<font>
|
||||
|
||||
[1.0] Bold version of the fixed-width font. Defaults to C<CB>. Only matters
|
||||
for B<troff> output.
|
||||
|
||||
=item B<--fixeditalic>=I<font>
|
||||
|
||||
[1.0] Italic version of the fixed-width font (something of a misnomer, since
|
||||
most fixed-width fonts only have an oblique version, not an italic version).
|
||||
Defaults to C<CI>. Only matters for B<troff> output.
|
||||
|
||||
=item B<--fixedbolditalic>=I<font>
|
||||
|
||||
[1.0] Bold italic (in theory, probably oblique in practice) version of the
|
||||
fixed-width font. Pod::Man doesn't assume you have this, and defaults to
|
||||
C<CB>. Some systems (such as Solaris) have this font available as C<CX>.
|
||||
Only matters for B<troff> output.
|
||||
|
||||
=item B<--guesswork>=I<rule>[,I<rule>...]
|
||||
|
||||
[5.00] By default, B<pod2man> applies some default formatting rules based on
|
||||
guesswork and regular expressions that are intended to make writing Perl
|
||||
documentation easier and require less explicit markup. These rules may not
|
||||
always be appropriate, particularly for documentation that isn't about Perl.
|
||||
This option allows turning all or some of it off.
|
||||
|
||||
The special rule C<all> enables all guesswork. This is also the default for
|
||||
backward compatibility reasons. The special rule C<none> disables all
|
||||
guesswork. Otherwise, the value of this option should be a comma-separated
|
||||
list of one or more of the following keywords:
|
||||
|
||||
=over 4
|
||||
|
||||
=item functions
|
||||
|
||||
Convert function references like C<foo()> to bold even if they have no markup.
|
||||
The function name accepts valid Perl characters for function names (including
|
||||
C<:>), and the trailing parentheses must be present and empty.
|
||||
|
||||
=item manref
|
||||
|
||||
Make the first part (before the parentheses) of man page references like
|
||||
C<foo(1)> bold even if they have no markup. The section must be a single
|
||||
number optionally followed by lowercase letters.
|
||||
|
||||
=item quoting
|
||||
|
||||
If no guesswork is enabled, any text enclosed in CZ<><> is surrounded by
|
||||
double quotes in nroff (terminal) output unless the contents are already
|
||||
quoted. When this guesswork is enabled, quote marks will also be suppressed
|
||||
for Perl variables, function names, function calls, numbers, and hex
|
||||
constants.
|
||||
|
||||
=item variables
|
||||
|
||||
Convert Perl variable names to a fixed-width font even if they have no markup.
|
||||
This transformation will only be apparent in troff output, or some other
|
||||
output format (unlike nroff terminal output) that supports fixed-width fonts.
|
||||
|
||||
=back
|
||||
|
||||
Any unknown guesswork name is silently ignored (for potential future
|
||||
compatibility), so be careful about spelling.
|
||||
|
||||
=item B<-h>, B<--help>
|
||||
|
||||
[1.00] Print out usage information.
|
||||
|
||||
=item B<-l>, B<--lax>
|
||||
|
||||
[1.00] No longer used. B<pod2man> used to check its input for validity as a
|
||||
manual page, but this should now be done by L<podchecker(1)> instead.
|
||||
Accepted for backward compatibility; this option no longer does anything.
|
||||
|
||||
=item B<--language>=I<language>
|
||||
|
||||
[5.00] Add commands telling B<groff> that the input file is in the given
|
||||
language. The value of this setting must be a language abbreviation for which
|
||||
B<groff> provides supplemental configuration, such as C<ja> (for Japanese) or
|
||||
C<zh> (for Chinese).
|
||||
|
||||
This adds:
|
||||
|
||||
.mso <language>.tmac
|
||||
.hla <language>
|
||||
|
||||
to the start of the file, which configure correct line breaking for the
|
||||
specified language. Without these commands, groff may not know how to add
|
||||
proper line breaks for Chinese and Japanese text if the man page is installed
|
||||
into the normal man page directory, such as F</usr/share/man>.
|
||||
|
||||
On many systems, this will be done automatically if the man page is installed
|
||||
into a language-specific man page directory, such as F</usr/share/man/zh_CN>.
|
||||
In that case, this option is not required.
|
||||
|
||||
Unfortunately, the commands added with this option are specific to B<groff>
|
||||
and will not work with other B<troff> and B<nroff> implementations.
|
||||
|
||||
=item B<--lquote>=I<quote>
|
||||
|
||||
=item B<--rquote>=I<quote>
|
||||
|
||||
[4.08] Sets the quote marks used to surround CE<lt>> text. B<--lquote> sets
|
||||
the left quote mark and B<--rquote> sets the right quote mark. Either may
|
||||
also be set to the special value C<none>, in which case no quote mark is added
|
||||
on that side of CE<lt>> text (but the font is still changed for troff output).
|
||||
|
||||
Also see the B<--quotes> option, which can be used to set both quotes at once.
|
||||
If both B<--quotes> and one of the other options is set, B<--lquote> or
|
||||
B<--rquote> overrides B<--quotes>.
|
||||
|
||||
=item B<-n> I<name>, B<--name>=I<name>
|
||||
|
||||
[4.08] Set the name of the manual page for the C<.TH> macro to I<name>.
|
||||
Without this option, the manual name is set to the uppercased base name of the
|
||||
file being converted unless the manual section is 3, in which case the path is
|
||||
parsed to see if it is a Perl module path. If it is, a path like
|
||||
C<.../lib/Pod/Man.pm> is converted into a name like C<Pod::Man>. This option,
|
||||
if given, overrides any automatic determination of the name.
|
||||
|
||||
Although one does not have to follow this convention, be aware that the
|
||||
convention for UNIX manual pages is for the title to be in all-uppercase, even
|
||||
if the command isn't. (Perl modules traditionally use mixed case for the
|
||||
manual page title, however.)
|
||||
|
||||
This option is probably not useful when converting multiple POD files at once.
|
||||
|
||||
When converting POD source from standard input, the name will be set to
|
||||
C<STDIN> if this option is not provided. Providing this option is strongly
|
||||
recommended to set a meaningful manual page name.
|
||||
|
||||
=item B<--nourls>
|
||||
|
||||
[2.5.0] Normally, LZ<><> formatting codes with a URL but anchor text are
|
||||
formatted to show both the anchor text and the URL. In other words:
|
||||
|
||||
L<foo|http://example.com/>
|
||||
|
||||
is formatted as:
|
||||
|
||||
foo <http://example.com/>
|
||||
|
||||
This flag, if given, suppresses the URL when anchor text is given, so this
|
||||
example would be formatted as just C<foo>. This can produce less
|
||||
cluttered output in cases where the URLs are not particularly important.
|
||||
|
||||
=item B<-o>, B<--official>
|
||||
|
||||
[1.00] Set the default header to indicate that this page is part of the
|
||||
standard Perl release, if B<--center> is not also given.
|
||||
|
||||
=item B<-q> I<quotes>, B<--quotes>=I<quotes>
|
||||
|
||||
[4.00] Sets the quote marks used to surround CE<lt>> text to I<quotes>. If
|
||||
I<quotes> is a single character, it is used as both the left and right quote.
|
||||
Otherwise, it is split in half, and the first half of the string is used as
|
||||
the left quote and the second is used as the right quote.
|
||||
|
||||
I<quotes> may also be set to the special value C<none>, in which case no quote
|
||||
marks are added around CE<lt>> text (but the font is still changed for troff
|
||||
output).
|
||||
|
||||
Also see the B<--lquote> and B<--rquote> options, which can be used to set the
|
||||
left and right quotes independently. If both B<--quotes> and one of the other
|
||||
options is set, B<--lquote> or B<--rquote> overrides B<--quotes>.
|
||||
|
||||
=item B<-r> I<version>, B<--release>=I<version>
|
||||
|
||||
[1.00] Set the centered footer for the C<.TH> macro to I<version>. By
|
||||
default, this is set to the version of Perl you run B<pod2man> under. Setting
|
||||
this to the empty string will cause some *roff implementations to use the
|
||||
system default value.
|
||||
|
||||
Note that some system C<an> macro sets assume that the centered footer will be
|
||||
a modification date and will prepend something like C<Last modified: >. If
|
||||
this is the case for your target system, you may want to set B<--release> to
|
||||
the last modified date and B<--date> to the version number.
|
||||
|
||||
=item B<-s> I<string>, B<--section>=I<string>
|
||||
|
||||
[1.00] Set the section for the C<.TH> macro. The standard section numbering
|
||||
convention is to use 1 for user commands, 2 for system calls, 3 for functions,
|
||||
4 for devices, 5 for file formats, 6 for games, 7 for miscellaneous
|
||||
information, and 8 for administrator commands. There is a lot of variation
|
||||
here, however; some systems (like Solaris) use 4 for file formats, 5 for
|
||||
miscellaneous information, and 7 for devices. Still others use 1m instead of
|
||||
8, or some mix of both. About the only section numbers that are reliably
|
||||
consistent are 1, 2, and 3.
|
||||
|
||||
By default, section 1 will be used unless the file ends in C<.pm>, in which
|
||||
case section 3 will be selected.
|
||||
|
||||
=item B<--stderr>
|
||||
|
||||
[2.1.3] By default, B<pod2man> dies if any errors are detected in the POD
|
||||
input. If B<--stderr> is given and no B<--errors> flag is present, errors are
|
||||
sent to standard error, but B<pod2man> does not abort. This is equivalent to
|
||||
C<--errors=stderr> and is supported for backward compatibility.
|
||||
|
||||
=item B<-u>, B<--utf8>
|
||||
|
||||
[2.1.0] This option used to tell B<pod2man> to produce UTF-8 output. Since
|
||||
this is now the default as of version 5.00, it is ignored and does nothing.
|
||||
|
||||
=item B<-v>, B<--verbose>
|
||||
|
||||
[1.11] Print out the name of each output file as it is being generated.
|
||||
|
||||
=back
|
||||
|
||||
=head1 EXIT STATUS
|
||||
|
||||
As long as all documents processed result in some output, even if that output
|
||||
includes errata (a C<POD ERRORS> section generated with C<--errors=pod>),
|
||||
B<pod2man> will exit with status 0. If any of the documents being processed
|
||||
do not result in an output document, B<pod2man> will exit with status 1. If
|
||||
there are syntax errors in a POD document being processed and the error
|
||||
handling style is set to the default of C<die>, B<pod2man> will abort
|
||||
immediately with exit status 255.
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
If B<pod2man> fails with errors, see L<Pod::Man> and L<Pod::Simple> for
|
||||
information about what those errors might mean.
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
pod2man program > program.1
|
||||
pod2man SomeModule.pm /usr/perl/man/man3/SomeModule.3
|
||||
pod2man --section=7 note.pod > note.7
|
||||
|
||||
If you would like to print out a lot of man page continuously, you probably
|
||||
want to set the C and D registers to set contiguous page numbering and
|
||||
even/odd paging, at least on some versions of man(7).
|
||||
|
||||
troff -man -rC1 -rD1 perl.1 perldata.1 perlsyn.1 ...
|
||||
|
||||
To get index entries on C<STDERR>, turn on the F register, as in:
|
||||
|
||||
troff -man -rF1 perl.1
|
||||
|
||||
The indexing merely outputs messages via C<.tm> for each major page, section,
|
||||
subsection, item, and any C<XE<lt>E<gt>> directives.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Russ Allbery <rra@cpan.org>, based on the original B<pod2man> by Larry Wall
|
||||
and Tom Christiansen.
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright 1999-2001, 2004, 2006, 2008, 2010, 2012-2019, 2022 Russ Allbery
|
||||
<rra@cpan.org>
|
||||
|
||||
This program is free software; you may redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Man>, L<Pod::Simple>, L<man(1)>, L<nroff(1)>, L<perlpod(1)>,
|
||||
L<podchecker(1)>, L<perlpodstyle(1)>, L<troff(1)>, L<man(7)>
|
||||
|
||||
The man page documenting the an macro set may be L<man(5)> instead of
|
||||
L<man(7)> on your system.
|
||||
|
||||
The current version of this script is always available from its web site at
|
||||
L<https://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
|
||||
Perl core distribution as of 5.6.0.
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,368 @@
|
||||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0; # ^ Run only under a shell
|
||||
|
||||
# Convert POD data to formatted ASCII text.
|
||||
#
|
||||
# The driver script for Pod::Text, Pod::Text::Termcap, and Pod::Text::Color,
|
||||
# invoked by perldoc -t among other things.
|
||||
#
|
||||
# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl
|
||||
|
||||
use 5.006;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Getopt::Long qw(GetOptions);
|
||||
use Pod::Text ();
|
||||
use Pod::Usage qw(pod2usage);
|
||||
|
||||
# Clean up $0 for error reporting.
|
||||
$0 =~ s%.*/%%;
|
||||
|
||||
# Take an initial pass through our options, looking for one of the form
|
||||
# -<number>. We turn that into -w <number> for compatibility with the
|
||||
# original pod2text script.
|
||||
for (my $i = 0; $i < @ARGV; $i++) {
|
||||
last if $ARGV[$i] =~ /^--$/;
|
||||
if ($ARGV[$i] =~ /^-(\d+)$/) {
|
||||
splice (@ARGV, $i++, 1, '-w', $1);
|
||||
}
|
||||
}
|
||||
|
||||
# Insert -- into @ARGV before any single dash argument to hide it from
|
||||
# Getopt::Long; we want to interpret it as meaning stdin (which Pod::Simple
|
||||
# does correctly).
|
||||
my $stdin;
|
||||
@ARGV = map { $_ eq '-' && !$stdin++ ? ('--', $_) : $_ } @ARGV;
|
||||
|
||||
# Parse our options. Use the same names as Pod::Text for simplicity.
|
||||
my %options;
|
||||
Getopt::Long::config ('bundling');
|
||||
GetOptions (\%options, 'alt|a', 'code', 'color|c', 'encoding|e=s', 'errors=s',
|
||||
'guesswork=s', 'help|h', 'indent|i=i', 'loose|l',
|
||||
'margin|left-margin|m=i', 'nourls', 'overstrike|o', 'quotes|q=s',
|
||||
'sentence|s', 'stderr', 'termcap|t', 'utf8|u', 'width|w=i')
|
||||
or exit 1;
|
||||
pod2usage (1) if $options{help};
|
||||
|
||||
# Figure out what formatter we're going to use. -c overrides -t.
|
||||
my $formatter = 'Pod::Text';
|
||||
if ($options{color}) {
|
||||
$formatter = 'Pod::Text::Color';
|
||||
eval { require Term::ANSIColor };
|
||||
if ($@) { die "-c (--color) requires Term::ANSIColor be installed\n" }
|
||||
require Pod::Text::Color;
|
||||
} elsif ($options{termcap}) {
|
||||
$formatter = 'Pod::Text::Termcap';
|
||||
require Pod::Text::Termcap;
|
||||
} elsif ($options{overstrike}) {
|
||||
$formatter = 'Pod::Text::Overstrike';
|
||||
require Pod::Text::Overstrike;
|
||||
}
|
||||
delete @options{'color', 'termcap', 'overstrike'};
|
||||
|
||||
# If neither stderr nor errors is set, default to errors = die.
|
||||
if (!defined $options{stderr} && !defined $options{errors}) {
|
||||
$options{errors} = 'die';
|
||||
}
|
||||
|
||||
# Initialize and run the formatter.
|
||||
my $parser = $formatter->new (%options);
|
||||
my $status = 0;
|
||||
do {
|
||||
my ($input, $output) = splice (@ARGV, 0, 2);
|
||||
$parser->parse_from_file ($input, $output);
|
||||
if ($parser->{CONTENTLESS}) {
|
||||
$status = 1;
|
||||
if (defined $input) {
|
||||
warn "$0: unable to format $input\n";
|
||||
} else {
|
||||
warn "$0: unable to format standard input\n";
|
||||
}
|
||||
if (defined ($output) and $output ne '-') {
|
||||
unlink $output unless (-s $output);
|
||||
}
|
||||
}
|
||||
} while (@ARGV);
|
||||
exit $status;
|
||||
|
||||
__END__
|
||||
|
||||
=for stopwords
|
||||
-aclostu --alt --stderr Allbery --overstrike overstrike --termcap --utf8
|
||||
UTF-8 subclasses --nourls EBCDIC unrepresentable
|
||||
|
||||
=head1 NAME
|
||||
|
||||
pod2text - Convert POD data to formatted ASCII text
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
pod2text [B<-aclostu>] [B<--code>] S<[B<-e> I<encoding>]>
|
||||
[B<--errors>=I<style>] [B<--guesswork>=I<rule>[,I<rule>...]]
|
||||
S<[B<-i> I<indent>]> S<[B<-q> I<quotes>]>
|
||||
[B<--nourls>] [B<--stderr>] S<[B<-w> I<width>]> [I<input> [I<output> ...]]
|
||||
|
||||
pod2text B<-h>
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<pod2text> is a wrapper script around the L<Pod::Text> and its subclasses.
|
||||
It uses them to generate formatted text from POD source. It can optionally
|
||||
use either termcap sequences or ANSI color escape sequences to format the
|
||||
text.
|
||||
|
||||
I<input> is the file to read for POD source (the POD can be embedded in code).
|
||||
If I<input> isn't given, it defaults to C<STDIN>. I<output>, if given, is the
|
||||
file to which to write the formatted output. If I<output> isn't given, the
|
||||
formatted output is written to C<STDOUT>. Several POD files can be processed
|
||||
in the same B<pod2text> invocation (saving module load and compile times) by
|
||||
providing multiple pairs of I<input> and I<output> files on the command line.
|
||||
|
||||
By default, the output encoding is the same as the encoding of the input file,
|
||||
or UTF-8 if that encoding is not set (except on EBCDIC systems). See the
|
||||
B<-e> option to explicitly set the output encoding and L<Pod::Text/Encoding>
|
||||
for more discussion.
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
Each option is annotated with the version of podlators in which that option
|
||||
was added with its current meaning.
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<-a>, B<--alt>
|
||||
|
||||
[1.00] Use an alternate output format that, among other things, uses a
|
||||
different heading style and marks C<=item> entries with a colon in the left
|
||||
margin.
|
||||
|
||||
=item B<--code>
|
||||
|
||||
[1.11] Include any non-POD text from the input file in the output as well.
|
||||
Useful for viewing code documented with POD blocks with the POD rendered and
|
||||
the code left intact.
|
||||
|
||||
=item B<-c>, B<--color>
|
||||
|
||||
[1.00] Format the output with ANSI color escape sequences. Using this option
|
||||
requires that Term::ANSIColor be installed on your system.
|
||||
|
||||
=item B<-e> I<encoding>, B<--encoding>=I<encoding>
|
||||
|
||||
[5.00] Specifies the encoding of the output. I<encoding> must be an encoding
|
||||
recognized by the L<Encode> module (see L<Encode::Supported>). If the output
|
||||
contains characters that cannot be represented in this encoding, that is an
|
||||
error that will be reported as configured by the C<errors> option. If error
|
||||
handling is other than C<die>, the unrepresentable character will be replaced
|
||||
with the Encode substitution character (normally C<?>).
|
||||
|
||||
WARNING: The input encoding of the POD source is independent from the output
|
||||
encoding, and setting this option does not affect the interpretation of the
|
||||
POD input. Unless your POD source is US-ASCII, its encoding should be
|
||||
declared with the C<=encoding> command in the source, as near to the top of
|
||||
the file as possible. If this is not done, Pod::Simple will will attempt to
|
||||
guess the encoding and may be successful if it's Latin-1 or UTF-8, but it will
|
||||
produce warnings. See L<perlpod(1)> for more information.
|
||||
|
||||
=item B<--errors>=I<style>
|
||||
|
||||
[2.5.0] Set the error handling style. C<die> says to throw an exception on
|
||||
any POD formatting error. C<stderr> says to report errors on standard error,
|
||||
but not to throw an exception. C<pod> says to include a POD ERRORS section in
|
||||
the resulting documentation summarizing the errors. C<none> ignores POD
|
||||
errors entirely, as much as possible.
|
||||
|
||||
The default is C<die>.
|
||||
|
||||
=item B<--guesswork>=I<rule>[,I<rule>...]
|
||||
|
||||
[5.01] By default, B<pod2text> applies some default formatting rules based on
|
||||
guesswork and regular expressions that are intended to make writing Perl
|
||||
documentation easier and require less explicit markup. These rules may not
|
||||
always be appropriate, particularly for documentation that isn't about Perl.
|
||||
This option allows turning all or some of it off.
|
||||
|
||||
The special rule C<all> enables all guesswork. This is also the default for
|
||||
backward compatibility reasons. The special rule C<none> disables all
|
||||
guesswork. Otherwise, the value of this option should be a comma-separated
|
||||
list of one or more of the following keywords:
|
||||
|
||||
=over 4
|
||||
|
||||
=item quoting
|
||||
|
||||
If no guesswork is enabled, any text enclosed in CZ<><> is surrounded by
|
||||
double quotes in nroff (terminal) output unless the contents are already
|
||||
quoted. When this guesswork is enabled, quote marks will also be suppressed
|
||||
for Perl variables, function names, function calls, numbers, and hex
|
||||
constants.
|
||||
|
||||
=back
|
||||
|
||||
Any unknown guesswork name is silently ignored (for potential future
|
||||
compatibility), so be careful about spelling.
|
||||
|
||||
=item B<-i> I<indent>, B<--indent=>I<indent>
|
||||
|
||||
[1.00] Set the number of spaces to indent regular text, and the default
|
||||
indentation for C<=over> blocks. Defaults to 4 spaces if this option isn't
|
||||
given.
|
||||
|
||||
=item B<-h>, B<--help>
|
||||
|
||||
[1.00] Print out usage information and exit.
|
||||
|
||||
=item B<-l>, B<--loose>
|
||||
|
||||
[1.00] Print a blank line after a C<=head1> heading. Normally, no blank line
|
||||
is printed after C<=head1>, although one is still printed after C<=head2>,
|
||||
because this is the expected formatting for manual pages; if you're formatting
|
||||
arbitrary text documents, using this option is recommended.
|
||||
|
||||
=item B<-m> I<width>, B<--left-margin>=I<width>, B<--margin>=I<width>
|
||||
|
||||
[1.24] The width of the left margin in spaces. Defaults to 0. This is the
|
||||
margin for all text, including headings, not the amount by which regular text
|
||||
is indented; for the latter, see B<-i> option.
|
||||
|
||||
=item B<--nourls>
|
||||
|
||||
[2.5.0] Normally, LZ<><> formatting codes with a URL but anchor text are
|
||||
formatted to show both the anchor text and the URL. In other words:
|
||||
|
||||
L<foo|http://example.com/>
|
||||
|
||||
is formatted as:
|
||||
|
||||
foo <http://example.com/>
|
||||
|
||||
This flag, if given, suppresses the URL when anchor text is given, so this
|
||||
example would be formatted as just C<foo>. This can produce less cluttered
|
||||
output in cases where the URLs are not particularly important.
|
||||
|
||||
=item B<-o>, B<--overstrike>
|
||||
|
||||
[1.06] Format the output with overstrike printing. Bold text is rendered as
|
||||
character, backspace, character. Italics and file names are rendered as
|
||||
underscore, backspace, character. Many pagers, such as B<less>, know how to
|
||||
convert this to bold or underlined text.
|
||||
|
||||
=item B<-q> I<quotes>, B<--quotes>=I<quotes>
|
||||
|
||||
[4.00] Sets the quote marks used to surround CE<lt>> text to I<quotes>. If
|
||||
I<quotes> is a single character, it is used as both the left and right quote.
|
||||
Otherwise, it is split in half, and the first half of the string is used as
|
||||
the left quote and the second is used as the right quote.
|
||||
|
||||
I<quotes> may also be set to the special value C<none>, in which case no quote
|
||||
marks are added around CE<lt>> text.
|
||||
|
||||
=item B<-s>, B<--sentence>
|
||||
|
||||
[1.00] Assume each sentence ends with two spaces and try to preserve that
|
||||
spacing. Without this option, all consecutive whitespace in non-verbatim
|
||||
paragraphs is compressed into a single space.
|
||||
|
||||
=item B<--stderr>
|
||||
|
||||
[2.1.3] By default, B<pod2text> dies if any errors are detected in the POD
|
||||
input. If B<--stderr> is given and no B<--errors> flag is present, errors are
|
||||
sent to standard error, but B<pod2text> does not abort. This is equivalent to
|
||||
C<--errors=stderr> and is supported for backward compatibility.
|
||||
|
||||
=item B<-t>, B<--termcap>
|
||||
|
||||
[1.00] Try to determine the width of the screen and the bold and underline
|
||||
sequences for the terminal from termcap, and use that information in
|
||||
formatting the output. Output will be wrapped at two columns less than the
|
||||
width of your terminal device. Using this option requires that your system
|
||||
have a termcap file somewhere where Term::Cap can find it and requires that
|
||||
your system support termios. With this option, the output of B<pod2text> will
|
||||
contain terminal control sequences for your current terminal type.
|
||||
|
||||
=item B<-u>, B<--utf8>
|
||||
|
||||
[2.2.0] Set the output encoding to UTF-8. This is equivalent to
|
||||
C<--encoding=UTF-8> and is supported for backward compatibility.
|
||||
|
||||
=item B<-w>, B<--width=>I<width>, B<->I<width>
|
||||
|
||||
[1.00] The column at which to wrap text on the right-hand side. Defaults to
|
||||
76, unless B<-t> is given, in which case it's two columns less than the width
|
||||
of your terminal device.
|
||||
|
||||
=back
|
||||
|
||||
=head1 EXIT STATUS
|
||||
|
||||
As long as all documents processed result in some output, even if that output
|
||||
includes errata (a C<POD ERRORS> section generated with C<--errors=pod>),
|
||||
B<pod2text> will exit with status 0. If any of the documents being processed
|
||||
do not result in an output document, B<pod2text> will exit with status 1. If
|
||||
there are syntax errors in a POD document being processed and the error
|
||||
handling style is set to the default of C<die>, B<pod2text> will abort
|
||||
immediately with exit status 255.
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
If B<pod2text> fails with errors, see L<Pod::Text> and L<Pod::Simple> for
|
||||
information about what those errors might mean. Internally, it can also
|
||||
produce the following diagnostics:
|
||||
|
||||
=over 4
|
||||
|
||||
=item -c (--color) requires Term::ANSIColor be installed
|
||||
|
||||
(F) B<-c> or B<--color> were given, but Term::ANSIColor could not be loaded.
|
||||
|
||||
=item Unknown option: %s
|
||||
|
||||
(F) An unknown command line option was given.
|
||||
|
||||
=back
|
||||
|
||||
In addition, other L<Getopt::Long> error messages may result from invalid
|
||||
command-line options.
|
||||
|
||||
=head1 ENVIRONMENT
|
||||
|
||||
=over 4
|
||||
|
||||
=item COLUMNS
|
||||
|
||||
If B<-t> is given, B<pod2text> will take the current width of your screen from
|
||||
this environment variable, if available. It overrides terminal width
|
||||
information in TERMCAP.
|
||||
|
||||
=item TERMCAP
|
||||
|
||||
If B<-t> is given, B<pod2text> will use the contents of this environment
|
||||
variable if available to determine the correct formatting sequences for your
|
||||
current terminal device.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Russ Allbery <rra@cpan.org>.
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright 1999-2001, 2004, 2006, 2008, 2010, 2012-2019, 2022 Russ Allbery
|
||||
<rra@cpan.org>
|
||||
|
||||
This program is free software; you may redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Encode::Supported>, L<Pod::Text>, L<Pod::Text::Color>,
|
||||
L<Pod::Text::Overstrike>, L<Pod::Text::Termcap>, L<Pod::Simple>, L<perlpod(1)>
|
||||
|
||||
The current version of this script is always available from its web site at
|
||||
L<https://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
|
||||
Perl core distribution as of 5.6.0.
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,162 @@
|
||||
#!/usr/bin/perl
|
||||
eval 'exec perl -S $0 "$@"'
|
||||
if 0;
|
||||
|
||||
#############################################################################
|
||||
# pod2usage -- command to print usage messages from embedded pod docs
|
||||
#
|
||||
# Copyright (c) 1996-2000 by Bradford Appleton. All rights reserved.
|
||||
# Copyright (c) 2001-2016 by Marek Rouchal.
|
||||
# This file is part of "Pod-Usage". Pod-Usage is free software;
|
||||
# you can redistribute it and/or modify it under the same terms
|
||||
# as Perl itself.
|
||||
#############################################################################
|
||||
|
||||
use strict;
|
||||
#use diagnostics;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
pod2usage - print usage messages from embedded pod docs in files
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
=over 12
|
||||
|
||||
=item B<pod2usage>
|
||||
|
||||
[B<-help>]
|
||||
[B<-man>]
|
||||
[B<-exit>S< >I<exitval>]
|
||||
[B<-output>S< >I<outfile>]
|
||||
[B<-verbose> I<level>]
|
||||
[B<-pathlist> I<dirlist>]
|
||||
[B<-formatter> I<module>]
|
||||
[B<-utf8>]
|
||||
I<file>
|
||||
|
||||
=back
|
||||
|
||||
=head1 OPTIONS AND ARGUMENTS
|
||||
|
||||
=over 8
|
||||
|
||||
=item B<-help>
|
||||
|
||||
Print a brief help message and exit.
|
||||
|
||||
=item B<-man>
|
||||
|
||||
Print this command's manual page and exit.
|
||||
|
||||
=item B<-exit> I<exitval>
|
||||
|
||||
The exit status value to return.
|
||||
|
||||
=item B<-output> I<outfile>
|
||||
|
||||
The output file to print to. If the special names "-" or ">&1" or ">&STDOUT"
|
||||
are used then standard output is used. If ">&2" or ">&STDERR" is used then
|
||||
standard error is used.
|
||||
|
||||
=item B<-verbose> I<level>
|
||||
|
||||
The desired level of verbosity to use:
|
||||
|
||||
1 : print SYNOPSIS only
|
||||
2 : print SYNOPSIS sections and any OPTIONS/ARGUMENTS sections
|
||||
3 : print the entire manpage (similar to running pod2text)
|
||||
|
||||
=item B<-pathlist> I<dirlist>
|
||||
|
||||
Specifies one or more directories to search for the input file if it
|
||||
was not supplied with an absolute path. Each directory path in the given
|
||||
list should be separated by a ':' on Unix (';' on MSWin32 and DOS).
|
||||
|
||||
=item B<-formatter> I<module>
|
||||
|
||||
Which text formatter to use. Default is L<Pod::Text>, or for very old
|
||||
Perl versions L<Pod::PlainText>. An alternative would be e.g.
|
||||
L<Pod::Text::Termcap>.
|
||||
|
||||
=item B<-utf8>
|
||||
|
||||
This option assumes that the formatter (see above) understands the option
|
||||
"utf8". It turns on generation of utf8 output.
|
||||
|
||||
=item I<file>
|
||||
|
||||
The pathname of a file containing pod documentation to be output in
|
||||
usage message format. If omitted, standard input is read - but the
|
||||
output is then formatted with L<Pod::Text> only - unless a specific
|
||||
formatter has been specified with B<-formatter>.
|
||||
|
||||
=back
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<pod2usage> will read the given input file looking for pod
|
||||
documentation and will print the corresponding usage message.
|
||||
If no input file is specified then standard input is read.
|
||||
|
||||
B<pod2usage> invokes the B<pod2usage()> function in the B<Pod::Usage>
|
||||
module. Please see L<Pod::Usage/pod2usage()>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Usage>, L<pod2text>, L<Pod::Text>, L<Pod::Text::Termcap>,
|
||||
L<perldoc>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Please report bugs using L<http://rt.cpan.org>.
|
||||
|
||||
Brad Appleton E<lt>bradapp@enteract.comE<gt>
|
||||
|
||||
Based on code for B<pod2text(1)> written by
|
||||
Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
|
||||
|
||||
=cut
|
||||
|
||||
use Getopt::Long;
|
||||
|
||||
## Define options
|
||||
my %options = ();
|
||||
my @opt_specs = (
|
||||
'help',
|
||||
'man',
|
||||
'exit=i',
|
||||
'output=s',
|
||||
'pathlist=s',
|
||||
'formatter=s',
|
||||
'verbose=i',
|
||||
'utf8!'
|
||||
);
|
||||
|
||||
## Parse options
|
||||
GetOptions(\%options, @opt_specs) || pod2usage(2);
|
||||
$Pod::Usage::Formatter = $options{formatter} if $options{formatter};
|
||||
require Pod::Usage;
|
||||
Pod::Usage->import();
|
||||
pod2usage(1) if ($options{help});
|
||||
pod2usage(VERBOSE => 2) if ($options{man});
|
||||
|
||||
## Dont default to STDIN if connected to a terminal
|
||||
pod2usage(2) if ((@ARGV == 0) && (-t STDIN));
|
||||
|
||||
if (@ARGV > 1) {
|
||||
print STDERR "pod2usage: Too many filenames given\n\n";
|
||||
pod2usage(2);
|
||||
}
|
||||
|
||||
my %usage = ();
|
||||
$usage{-input} = shift(@ARGV) || \*STDIN;
|
||||
$usage{-exitval} = $options{'exit'} if (defined $options{'exit'});
|
||||
$usage{-output} = $options{'output'} if (defined $options{'output'});
|
||||
$usage{-verbose} = $options{'verbose'} if (defined $options{'verbose'});
|
||||
$usage{-pathlist} = $options{'pathlist'} if (defined $options{'pathlist'});
|
||||
$usage{-utf8} = $options{'utf8'} if (defined $options{'utf8'});
|
||||
|
||||
pod2usage(\%usage);
|
||||
|
||||
|
||||
@@ -0,0 +1,144 @@
|
||||
#!/usr/bin/perl
|
||||
eval 'exec perl -S $0 "$@"'
|
||||
if 0;
|
||||
#############################################################################
|
||||
# podchecker -- command to invoke the podchecker function in Pod::Checker
|
||||
#
|
||||
# Copyright (c) 1998-2000 by Bradford Appleton. All rights reserved.
|
||||
# This is free software; you can redistribute it and/or modify it under the
|
||||
# same terms as Perl itself.
|
||||
#############################################################################
|
||||
|
||||
use strict;
|
||||
#use diagnostics;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
podchecker - check the syntax of POD format documentation files
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
B<podchecker> [B<-help>] [B<-man>] [B<-(no)warnings>] [I<file>S< >...]
|
||||
|
||||
=head1 OPTIONS AND ARGUMENTS
|
||||
|
||||
=over 8
|
||||
|
||||
=item B<-help>
|
||||
|
||||
Print a brief help message and exit.
|
||||
|
||||
=item B<-man>
|
||||
|
||||
Print the manual page and exit.
|
||||
|
||||
=item B<-warnings> B<-nowarnings>
|
||||
|
||||
Turn on/off printing of warnings. Repeating B<-warnings> increases the
|
||||
warning level, i.e. more warnings are printed. Currently increasing to
|
||||
level two causes flagging of unescaped "E<lt>,E<gt>" characters.
|
||||
|
||||
=item I<file>
|
||||
|
||||
The pathname of a POD file to syntax-check (defaults to standard input).
|
||||
|
||||
=back
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<podchecker> will read the given input files looking for POD
|
||||
syntax errors in the POD documentation and will print any errors
|
||||
it find to STDERR. At the end, it will print a status message
|
||||
indicating the number of errors found.
|
||||
|
||||
Directories are ignored, an appropriate warning message is printed.
|
||||
|
||||
B<podchecker> invokes the B<podchecker()> function exported by B<Pod::Checker>
|
||||
Please see L<Pod::Checker/podchecker()> for more details.
|
||||
|
||||
=head1 RETURN VALUE
|
||||
|
||||
B<podchecker> returns a 0 (zero) exit status if all specified
|
||||
POD files are ok.
|
||||
|
||||
=head1 ERRORS
|
||||
|
||||
B<podchecker> returns the exit status 1 if at least one of
|
||||
the given POD files has syntax errors.
|
||||
|
||||
The status 2 indicates that at least one of the specified
|
||||
files does not contain I<any> POD commands.
|
||||
|
||||
Status 1 overrides status 2. If you want unambiguous
|
||||
results, call B<podchecker> with one single argument only.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Simple> and L<Pod::Checker>
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Please report bugs using L<http://rt.cpan.org>.
|
||||
|
||||
Brad Appleton E<lt>bradapp@enteract.comE<gt>,
|
||||
Marek Rouchal E<lt>marekr@cpan.orgE<gt>
|
||||
|
||||
Based on code for B<Pod::Text::pod2text(1)> written by
|
||||
Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
use Pod::Checker;
|
||||
use Pod::Usage;
|
||||
use Getopt::Long;
|
||||
|
||||
## Define options
|
||||
my %options;
|
||||
|
||||
## Parse options
|
||||
GetOptions(\%options, qw(help man warnings+ nowarnings)) || pod2usage(2);
|
||||
pod2usage(1) if ($options{help});
|
||||
pod2usage(-verbose => 2) if ($options{man});
|
||||
|
||||
if($options{nowarnings}) {
|
||||
$options{warnings} = 0;
|
||||
}
|
||||
elsif(!defined $options{warnings}) {
|
||||
$options{warnings} = 1; # default is warnings on
|
||||
}
|
||||
|
||||
## Dont default to STDIN if connected to a terminal
|
||||
pod2usage(2) if ((@ARGV == 0) && (-t STDIN));
|
||||
|
||||
## Invoke podchecker()
|
||||
my $status = 0;
|
||||
@ARGV = qw(-) unless(@ARGV);
|
||||
for my $podfile (@ARGV) {
|
||||
if($podfile eq '-') {
|
||||
$podfile = '<&STDIN';
|
||||
}
|
||||
elsif(-d $podfile) {
|
||||
warn "podchecker: Warning: Ignoring directory '$podfile'\n";
|
||||
next;
|
||||
}
|
||||
my $errors =
|
||||
podchecker($podfile, undef, '-warnings' => $options{warnings});
|
||||
if($errors > 0) {
|
||||
# errors occurred
|
||||
$status = 1;
|
||||
printf STDERR ("%s has %d pod syntax %s.\n",
|
||||
$podfile, $errors,
|
||||
($errors == 1) ? 'error' : 'errors');
|
||||
}
|
||||
elsif($errors < 0) {
|
||||
# no pod found
|
||||
$status = 2 unless($status);
|
||||
print STDERR "$podfile does not contain any pod commands.\n";
|
||||
}
|
||||
else {
|
||||
print STDERR "$podfile pod syntax OK.\n";
|
||||
}
|
||||
}
|
||||
exit $status;
|
||||
|
||||
@@ -0,0 +1,410 @@
|
||||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0; # ^ Run only under a shell
|
||||
#!/usr/bin/perl -w
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use strict;
|
||||
use warnings;
|
||||
use App::Prove;
|
||||
|
||||
my $app = App::Prove->new;
|
||||
$app->process_args(@ARGV);
|
||||
exit( $app->run ? 0 : 1 );
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
prove - Run tests through a TAP harness.
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
prove [options] [files or directories]
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
Boolean options:
|
||||
|
||||
-v, --verbose Print all test lines.
|
||||
-l, --lib Add 'lib' to the path for your tests (-Ilib).
|
||||
-b, --blib Add 'blib/lib' and 'blib/arch' to the path for
|
||||
your tests
|
||||
-s, --shuffle Run the tests in random order.
|
||||
-c, --color Colored test output (default).
|
||||
--nocolor Do not color test output.
|
||||
--count Show the X/Y test count when not verbose
|
||||
(default)
|
||||
--nocount Disable the X/Y test count.
|
||||
-D --dry Dry run. Show test that would have run.
|
||||
-f, --failures Show failed tests.
|
||||
-o, --comments Show comments.
|
||||
--ignore-exit Ignore exit status from test scripts.
|
||||
-m, --merge Merge test scripts' STDERR with their STDOUT.
|
||||
-r, --recurse Recursively descend into directories.
|
||||
--reverse Run the tests in reverse order.
|
||||
-q, --quiet Suppress some test output while running tests.
|
||||
-Q, --QUIET Only print summary results.
|
||||
-p, --parse Show full list of TAP parse errors, if any.
|
||||
--directives Only show results with TODO or SKIP directives.
|
||||
--timer Print elapsed time after each test.
|
||||
--trap Trap Ctrl-C and print summary on interrupt.
|
||||
--normalize Normalize TAP output in verbose output
|
||||
-T Enable tainting checks.
|
||||
-t Enable tainting warnings.
|
||||
-W Enable fatal warnings.
|
||||
-w Enable warnings.
|
||||
-h, --help Display this help
|
||||
-?, Display this help
|
||||
-V, --version Display the version
|
||||
-H, --man Longer manpage for prove
|
||||
--norc Don't process default .proverc
|
||||
|
||||
Options that take arguments:
|
||||
|
||||
-I Library paths to include.
|
||||
-P Load plugin (searches App::Prove::Plugin::*.)
|
||||
-M Load a module.
|
||||
-e, --exec Interpreter to run the tests ('' for compiled
|
||||
tests.)
|
||||
--ext Set the extension for tests (default '.t')
|
||||
--harness Define test harness to use. See TAP::Harness.
|
||||
--formatter Result formatter to use. See FORMATTERS.
|
||||
--source Load and/or configure a SourceHandler. See
|
||||
SOURCE HANDLERS.
|
||||
-a, --archive out.tgz Store the resulting TAP in an archive file.
|
||||
-j, --jobs N Run N test jobs in parallel (try 9.)
|
||||
--state=opts Control prove's persistent state.
|
||||
--statefile=file Use `file` instead of `.prove` for state
|
||||
--rc=rcfile Process options from rcfile
|
||||
--rules Rules for parallel vs sequential processing.
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
=head2 .proverc
|
||||
|
||||
If F<~/.proverc> or F<./.proverc> exist they will be read and any
|
||||
options they contain processed before the command line options. Options
|
||||
in F<.proverc> are specified in the same way as command line options:
|
||||
|
||||
# .proverc
|
||||
--state=hot,fast,save
|
||||
-j9
|
||||
|
||||
Additional option files may be specified with the C<--rc> option.
|
||||
Default option file processing is disabled by the C<--norc> option.
|
||||
|
||||
Under Windows and VMS the option file is named F<_proverc> rather than
|
||||
F<.proverc> and is sought only in the current directory.
|
||||
|
||||
=head2 Reading from C<STDIN>
|
||||
|
||||
If you have a list of tests (or URLs, or anything else you want to test) in a
|
||||
file, you can add them to your tests by using a '-':
|
||||
|
||||
prove - < my_list_of_things_to_test.txt
|
||||
|
||||
See the C<README> in the C<examples> directory of this distribution.
|
||||
|
||||
=head2 Default Test Directory
|
||||
|
||||
If no files or directories are supplied, C<prove> looks for all files
|
||||
matching the pattern C<t/*.t>.
|
||||
|
||||
=head2 Colored Test Output
|
||||
|
||||
Colored test output using L<TAP::Formatter::Color> is the default, but
|
||||
if output is not to a terminal, color is disabled. You can override this by
|
||||
adding the C<--color> switch.
|
||||
|
||||
Color support requires L<Term::ANSIColor> and, on windows platforms, also
|
||||
L<Win32::Console::ANSI>. If the necessary module(s) are not installed
|
||||
colored output will not be available.
|
||||
|
||||
=head2 Exit Code
|
||||
|
||||
If the tests fail C<prove> will exit with non-zero status.
|
||||
|
||||
=head2 Arguments to Tests
|
||||
|
||||
It is possible to supply arguments to tests. To do so separate them from
|
||||
prove's own arguments with the arisdottle, '::'. For example
|
||||
|
||||
prove -v t/mytest.t :: --url http://example.com
|
||||
|
||||
would run F<t/mytest.t> with the options '--url http://example.com'.
|
||||
When running multiple tests they will each receive the same arguments.
|
||||
|
||||
=head2 C<--exec>
|
||||
|
||||
Normally you can just pass a list of Perl tests and the harness will know how
|
||||
to execute them. However, if your tests are not written in Perl or if you
|
||||
want all tests invoked exactly the same way, use the C<-e>, or C<--exec>
|
||||
switch:
|
||||
|
||||
prove --exec '/usr/bin/ruby -w' t/
|
||||
prove --exec '/usr/bin/perl -Tw -mstrict -Ilib' t/
|
||||
prove --exec '/path/to/my/customer/exec'
|
||||
|
||||
=head2 C<--merge>
|
||||
|
||||
If you need to make sure your diagnostics are displayed in the correct
|
||||
order relative to test results you can use the C<--merge> option to
|
||||
merge the test scripts' STDERR into their STDOUT.
|
||||
|
||||
This guarantees that STDOUT (where the test results appear) and STDERR
|
||||
(where the diagnostics appear) will stay in sync. The harness will
|
||||
display any diagnostics your tests emit on STDERR.
|
||||
|
||||
Caveat: this is a bit of a kludge. In particular note that if anything
|
||||
that appears on STDERR looks like a test result the test harness will
|
||||
get confused. Use this option only if you understand the consequences
|
||||
and can live with the risk.
|
||||
|
||||
=head2 C<--trap>
|
||||
|
||||
The C<--trap> option will attempt to trap SIGINT (Ctrl-C) during a test
|
||||
run and display the test summary even if the run is interrupted
|
||||
|
||||
=head2 C<--state>
|
||||
|
||||
You can ask C<prove> to remember the state of previous test runs and
|
||||
select and/or order the tests to be run based on that saved state.
|
||||
|
||||
The C<--state> switch requires an argument which must be a comma
|
||||
separated list of one or more of the following options.
|
||||
|
||||
=over
|
||||
|
||||
=item C<last>
|
||||
|
||||
Run the same tests as the last time the state was saved. This makes it
|
||||
possible, for example, to recreate the ordering of a shuffled test.
|
||||
|
||||
# Run all tests in random order
|
||||
$ prove -b --state=save --shuffle
|
||||
|
||||
# Run them again in the same order
|
||||
$ prove -b --state=last
|
||||
|
||||
=item C<failed>
|
||||
|
||||
Run only the tests that failed on the last run.
|
||||
|
||||
# Run all tests
|
||||
$ prove -b --state=save
|
||||
|
||||
# Run failures
|
||||
$ prove -b --state=failed
|
||||
|
||||
If you also specify the C<save> option newly passing tests will be
|
||||
excluded from subsequent runs.
|
||||
|
||||
# Repeat until no more failures
|
||||
$ prove -b --state=failed,save
|
||||
|
||||
=item C<passed>
|
||||
|
||||
Run only the passed tests from last time. Useful to make sure that no
|
||||
new problems have been introduced.
|
||||
|
||||
=item C<all>
|
||||
|
||||
Run all tests in normal order. Multiple options may be specified, so to
|
||||
run all tests with the failures from last time first:
|
||||
|
||||
$ prove -b --state=failed,all,save
|
||||
|
||||
=item C<hot>
|
||||
|
||||
Run the tests that most recently failed first. The last failure time of
|
||||
each test is stored. The C<hot> option causes tests to be run in most-recent-
|
||||
failure order.
|
||||
|
||||
$ prove -b --state=hot,save
|
||||
|
||||
Tests that have never failed will not be selected. To run all tests with
|
||||
the most recently failed first use
|
||||
|
||||
$ prove -b --state=hot,all,save
|
||||
|
||||
This combination of options may also be specified thus
|
||||
|
||||
$ prove -b --state=adrian
|
||||
|
||||
=item C<todo>
|
||||
|
||||
Run any tests with todos.
|
||||
|
||||
=item C<slow>
|
||||
|
||||
Run the tests in slowest to fastest order. This is useful in conjunction
|
||||
with the C<-j> parallel testing switch to ensure that your slowest tests
|
||||
start running first.
|
||||
|
||||
$ prove -b --state=slow -j9
|
||||
|
||||
=item C<fast>
|
||||
|
||||
Run test tests in fastest to slowest order.
|
||||
|
||||
=item C<new>
|
||||
|
||||
Run the tests in newest to oldest order based on the modification times
|
||||
of the test scripts.
|
||||
|
||||
=item C<old>
|
||||
|
||||
Run the tests in oldest to newest order.
|
||||
|
||||
=item C<fresh>
|
||||
|
||||
Run those test scripts that have been modified since the last test run.
|
||||
|
||||
=item C<save>
|
||||
|
||||
Save the state on exit. The state is stored in a file called F<.prove>
|
||||
(F<_prove> on Windows and VMS) in the current directory.
|
||||
|
||||
=back
|
||||
|
||||
The C<--state> switch may be used more than once.
|
||||
|
||||
$ prove -b --state=hot --state=all,save
|
||||
|
||||
=head2 --rules
|
||||
|
||||
The C<--rules> option is used to control which tests are run sequentially and
|
||||
which are run in parallel, if the C<--jobs> option is specified. The option may
|
||||
be specified multiple times, and the order matters.
|
||||
|
||||
The most practical use is likely to specify that some tests are not
|
||||
"parallel-ready". Since mentioning a file with --rules doesn't cause it to
|
||||
be selected to run as a test, you can "set and forget" some rules preferences in
|
||||
your .proverc file. Then you'll be able to take maximum advantage of the
|
||||
performance benefits of parallel testing, while some exceptions are still run
|
||||
in parallel.
|
||||
|
||||
=head3 --rules examples
|
||||
|
||||
# All tests are allowed to run in parallel, except those starting with "p"
|
||||
--rules='seq=t/p*.t' --rules='par=**'
|
||||
|
||||
# All tests must run in sequence except those starting with "p", which should be run parallel
|
||||
--rules='par=t/p*.t'
|
||||
|
||||
=head3 --rules resolution
|
||||
|
||||
=over 4
|
||||
|
||||
=item * By default, all tests are eligible to be run in parallel. Specifying any of your own rules removes this one.
|
||||
|
||||
=item * "First match wins". The first rule that matches a test will be the one that applies.
|
||||
|
||||
=item * Any test which does not match a rule will be run in sequence at the end of the run.
|
||||
|
||||
=item * The existence of a rule does not imply selecting a test. You must still specify the tests to run.
|
||||
|
||||
=item * Specifying a rule to allow tests to run in parallel does not make them run in parallel. You still need specify the number of parallel C<jobs> in your Harness object.
|
||||
|
||||
=back
|
||||
|
||||
=head3 --rules Glob-style pattern matching
|
||||
|
||||
We implement our own glob-style pattern matching for --rules. Here are the
|
||||
supported patterns:
|
||||
|
||||
** is any number of characters, including /, within a pathname
|
||||
* is zero or more characters within a filename/directory name
|
||||
? is exactly one character within a filename/directory name
|
||||
{foo,bar,baz} is any of foo, bar or baz.
|
||||
\ is an escape character
|
||||
|
||||
=head3 More advanced specifications for parallel vs sequence run rules
|
||||
|
||||
If you need more advanced management of what runs in parallel vs in sequence, see
|
||||
the associated 'rules' documentation in L<TAP::Harness> and L<TAP::Parser::Scheduler>.
|
||||
If what's possible directly through C<prove> is not sufficient, you can write your own
|
||||
harness to access these features directly.
|
||||
|
||||
=head2 @INC
|
||||
|
||||
prove introduces a separation between "options passed to the perl which
|
||||
runs prove" and "options passed to the perl which runs tests"; this
|
||||
distinction is by design. Thus the perl which is running a test starts
|
||||
with the default C<@INC>. Additional library directories can be added
|
||||
via the C<PERL5LIB> environment variable, via -Ifoo in C<PERL5OPT> or
|
||||
via the C<-Ilib> option to F<prove>.
|
||||
|
||||
=head2 Taint Mode
|
||||
|
||||
Normally when a Perl program is run in taint mode the contents of the
|
||||
C<PERL5LIB> environment variable do not appear in C<@INC>.
|
||||
|
||||
Because C<PERL5LIB> is often used during testing to add build
|
||||
directories to C<@INC> prove passes the names of any directories found
|
||||
in C<PERL5LIB> as -I switches. The net effect of this is that
|
||||
C<PERL5LIB> is honoured even when prove is run in taint mode.
|
||||
|
||||
|
||||
=head1 FORMATTERS
|
||||
|
||||
You can load a custom L<TAP::Parser::Formatter>:
|
||||
|
||||
prove --formatter MyFormatter
|
||||
|
||||
=head1 SOURCE HANDLERS
|
||||
|
||||
You can load custom L<TAP::Parser::SourceHandler>s, to change the way the
|
||||
parser interprets particular I<sources> of TAP.
|
||||
|
||||
prove --source MyHandler --source YetAnother t
|
||||
|
||||
If you want to provide config to the source you can use:
|
||||
|
||||
prove --source MyCustom \
|
||||
--source Perl --perl-option 'foo=bar baz' --perl-option avg=0.278 \
|
||||
--source File --file-option extensions=.txt --file-option extensions=.tmp t
|
||||
--source pgTAP --pgtap-option pset=format=html --pgtap-option pset=border=2
|
||||
|
||||
Each C<--$source-option> option must specify a key/value pair separated by an
|
||||
C<=>. If an option can take multiple values, just specify it multiple times,
|
||||
as with the C<extensions=> examples above. If the option should be a hash
|
||||
reference, specify the value as a second pair separated by a C<=>, as in the
|
||||
C<pset=> examples above (escape C<=> with a backslash).
|
||||
|
||||
All C<--sources> are combined into a hash, and passed to L<TAP::Harness/new>'s
|
||||
C<sources> parameter.
|
||||
|
||||
See L<TAP::Parser::IteratorFactory> for more details on how configuration is
|
||||
passed to I<SourceHandlers>.
|
||||
|
||||
=head1 PLUGINS
|
||||
|
||||
Plugins can be loaded using the C<< -PI<plugin> >> syntax, eg:
|
||||
|
||||
prove -PMyPlugin
|
||||
|
||||
This will search for a module named C<App::Prove::Plugin::MyPlugin>, or failing
|
||||
that, C<MyPlugin>. If the plugin can't be found, C<prove> will complain & exit.
|
||||
|
||||
You can pass arguments to your plugin by appending C<=arg1,arg2,etc> to the
|
||||
plugin name:
|
||||
|
||||
prove -PMyPlugin=fou,du,fafa
|
||||
|
||||
Please check individual plugin documentation for more details.
|
||||
|
||||
=head2 Available Plugins
|
||||
|
||||
For an up-to-date list of plugins available, please check CPAN:
|
||||
|
||||
L<http://search.cpan.org/search?query=App%3A%3AProve+Plugin>
|
||||
|
||||
=head2 Writing Plugins
|
||||
|
||||
Please see L<App::Prove/PLUGINS>.
|
||||
|
||||
=cut
|
||||
|
||||
# vim:ts=4:sw=4:et:sta
|
||||
@@ -0,0 +1,143 @@
|
||||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0; # ^ Run only under a shell
|
||||
#!/usr/bin/perl
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use File::Find;
|
||||
use Getopt::Std;
|
||||
use Archive::Tar;
|
||||
use Data::Dumper;
|
||||
|
||||
# Allow historic support for dashless bundled options
|
||||
# tar cvf file.tar
|
||||
# is valid (GNU) tar style
|
||||
@ARGV && $ARGV[0] =~ m/^[DdcvzthxIC]+[fT]?$/ and
|
||||
unshift @ARGV, map { "-$_" } split m// => shift @ARGV;
|
||||
my $opts = {};
|
||||
getopts('Ddcvzthxf:ICT:', $opts) or die usage();
|
||||
|
||||
### show the help message ###
|
||||
die usage() if $opts->{h};
|
||||
|
||||
### enable debugging (undocumented feature)
|
||||
local $Archive::Tar::DEBUG = 1 if $opts->{d};
|
||||
|
||||
### enable insecure extracting.
|
||||
local $Archive::Tar::INSECURE_EXTRACT_MODE = 1 if $opts->{I};
|
||||
|
||||
### sanity checks ###
|
||||
unless ( 1 == grep { defined $opts->{$_} } qw[x t c] ) {
|
||||
die "You need exactly one of 'x', 't' or 'c' options: " . usage();
|
||||
}
|
||||
|
||||
my $compress = $opts->{z} ? 1 : 0;
|
||||
my $verbose = $opts->{v} ? 1 : 0;
|
||||
my $file = $opts->{f} ? $opts->{f} : 'default.tar';
|
||||
my $tar = Archive::Tar->new();
|
||||
|
||||
if( $opts->{c} ) {
|
||||
my @files;
|
||||
my @src = @ARGV;
|
||||
if( $opts->{T} ) {
|
||||
if( $opts->{T} eq "-" ) {
|
||||
chomp( @src = <STDIN> );
|
||||
} elsif( open my $fh, "<", $opts->{T} ) {
|
||||
chomp( @src = <$fh> );
|
||||
} else {
|
||||
die "$0: $opts->{T}: $!\n";
|
||||
}
|
||||
}
|
||||
|
||||
find( sub { push @files, $File::Find::name;
|
||||
print $File::Find::name.$/ if $verbose }, @src );
|
||||
|
||||
if ($file eq '-') {
|
||||
use IO::Handle;
|
||||
$file = IO::Handle->new();
|
||||
$file->fdopen(fileno(STDOUT),"w");
|
||||
}
|
||||
|
||||
my $tar = Archive::Tar->new;
|
||||
$tar->add_files(@files);
|
||||
if( $opts->{C} ) {
|
||||
for my $f ($tar->get_files) {
|
||||
$f->mode($f->mode & ~022); # chmod go-w
|
||||
}
|
||||
}
|
||||
$tar->write($file, $compress);
|
||||
} else {
|
||||
if ($file eq '-') {
|
||||
use IO::Handle;
|
||||
$file = IO::Handle->new();
|
||||
$file->fdopen(fileno(STDIN),"r");
|
||||
}
|
||||
|
||||
### print the files we're finding?
|
||||
my $print = $verbose || $opts->{'t'} || 0;
|
||||
|
||||
my $iter = Archive::Tar->iter( $file );
|
||||
|
||||
while( my $f = $iter->() ) {
|
||||
print $f->full_path . $/ if $print;
|
||||
|
||||
### data dumper output
|
||||
print Dumper( $f ) if $opts->{'D'};
|
||||
|
||||
### extract it
|
||||
$f->extract if $opts->{'x'};
|
||||
}
|
||||
}
|
||||
|
||||
### pod & usage in one
|
||||
sub usage {
|
||||
my $usage .= << '=cut';
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
ptar - a tar-like program written in perl
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
ptar is a small, tar look-alike program that uses the perl module
|
||||
Archive::Tar to extract, create and list tar archives.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
ptar -c [-v] [-z] [-C] [-f ARCHIVE_FILE | -] FILE FILE ...
|
||||
ptar -c [-v] [-z] [-C] [-T index | -] [-f ARCHIVE_FILE | -]
|
||||
ptar -x [-v] [-z] [-f ARCHIVE_FILE | -]
|
||||
ptar -t [-z] [-f ARCHIVE_FILE | -]
|
||||
ptar -h
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
c Create ARCHIVE_FILE or STDOUT (-) from FILE
|
||||
x Extract from ARCHIVE_FILE or STDIN (-)
|
||||
t List the contents of ARCHIVE_FILE or STDIN (-)
|
||||
f Name of the ARCHIVE_FILE to use. Default is './default.tar'
|
||||
z Read/Write zlib compressed ARCHIVE_FILE (not always available)
|
||||
v Print filenames as they are added or extracted from ARCHIVE_FILE
|
||||
h Prints this help message
|
||||
C CPAN mode - drop 022 from permissions
|
||||
T get names to create from file
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<tar(1)>, L<Archive::Tar>.
|
||||
|
||||
=cut
|
||||
|
||||
### strip the pod directives
|
||||
$usage =~ s/=pod\n//g;
|
||||
$usage =~ s/=head1 //g;
|
||||
|
||||
### add some newlines
|
||||
$usage .= $/.$/;
|
||||
|
||||
return $usage;
|
||||
}
|
||||
|
||||
@@ -0,0 +1,121 @@
|
||||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0; # ^ Run only under a shell
|
||||
#!/usr/bin/perl
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use strict;
|
||||
use warnings;
|
||||
use Archive::Tar;
|
||||
use Getopt::Std;
|
||||
|
||||
my $opts = {};
|
||||
getopts('h:', $opts) or die usage();
|
||||
|
||||
die usages() if $opts->{h};
|
||||
|
||||
### need Text::Diff -- give a polite error (not a standard prereq)
|
||||
unless ( eval { require Text::Diff; Text::Diff->import; 1 } ) {
|
||||
die "\n\t This tool requires the 'Text::Diff' module to be installed\n";
|
||||
}
|
||||
|
||||
my $arch = shift or die usage();
|
||||
my $tar = Archive::Tar->new( $arch ) or die "Couldn't read '$arch': $!";
|
||||
|
||||
|
||||
foreach my $file ( $tar->get_files ) {
|
||||
next unless $file->is_file;
|
||||
my $prefix = $file->prefix;
|
||||
my $name = $file->name;
|
||||
if (defined $prefix) {
|
||||
$name = File::Spec->catfile($prefix, $name);
|
||||
}
|
||||
|
||||
diff( \($file->get_content), $name,
|
||||
{ FILENAME_A => $name,
|
||||
MTIME_A => $file->mtime,
|
||||
OUTPUT => \*STDOUT
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
sub usage {
|
||||
return q[
|
||||
|
||||
Usage: ptardiff ARCHIVE_FILE
|
||||
ptardiff -h
|
||||
|
||||
ptardiff is a small program that diffs an extracted archive
|
||||
against an unextracted one, using the perl module Archive::Tar.
|
||||
|
||||
This effectively lets you view changes made to an archives contents.
|
||||
|
||||
Provide the progam with an ARCHIVE_FILE and it will look up all
|
||||
the files with in the archive, scan the current working directory
|
||||
for a file with the name and diff it against the contents of the
|
||||
archive.
|
||||
|
||||
|
||||
Options:
|
||||
h Prints this help message
|
||||
|
||||
|
||||
Sample Usage:
|
||||
|
||||
$ tar -xzf Acme-Buffy-1.3.tar.gz
|
||||
$ vi Acme-Buffy-1.3/README
|
||||
|
||||
[...]
|
||||
|
||||
$ ptardiff Acme-Buffy-1.3.tar.gz > README.patch
|
||||
|
||||
|
||||
See Also:
|
||||
tar(1)
|
||||
ptar
|
||||
Archive::Tar
|
||||
|
||||
] . $/;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
ptardiff - program that diffs an extracted archive against an unextracted one
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
ptardiff is a small program that diffs an extracted archive
|
||||
against an unextracted one, using the perl module Archive::Tar.
|
||||
|
||||
This effectively lets you view changes made to an archives contents.
|
||||
|
||||
Provide the progam with an ARCHIVE_FILE and it will look up all
|
||||
the files with in the archive, scan the current working directory
|
||||
for a file with the name and diff it against the contents of the
|
||||
archive.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
ptardiff ARCHIVE_FILE
|
||||
ptardiff -h
|
||||
|
||||
$ tar -xzf Acme-Buffy-1.3.tar.gz
|
||||
$ vi Acme-Buffy-1.3/README
|
||||
[...]
|
||||
$ ptardiff Acme-Buffy-1.3.tar.gz > README.patch
|
||||
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
h Prints this help message
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
tar(1), L<Archive::Tar>.
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,196 @@
|
||||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0; # ^ Run only under a shell
|
||||
#!/usr/bin/perl
|
||||
##############################################################################
|
||||
# Tool for using regular expressions against the contents of files in a tar
|
||||
# archive. See 'ptargrep --help' for more documentation.
|
||||
#
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Pod::Usage qw(pod2usage);
|
||||
use Getopt::Long qw(GetOptions);
|
||||
use Archive::Tar qw();
|
||||
use File::Path qw(mkpath);
|
||||
|
||||
my(%opt, $pattern);
|
||||
|
||||
if(!GetOptions(\%opt,
|
||||
'basename|b',
|
||||
'ignore-case|i',
|
||||
'list-only|l',
|
||||
'verbose|v',
|
||||
'help|?',
|
||||
)) {
|
||||
pod2usage(-exitval => 1, -verbose => 0);
|
||||
}
|
||||
|
||||
|
||||
pod2usage(-exitstatus => 0, -verbose => 2) if $opt{help};
|
||||
|
||||
pod2usage(-exitval => 1, -verbose => 0,
|
||||
-message => "No pattern specified",
|
||||
) unless @ARGV;
|
||||
make_pattern( shift(@ARGV) );
|
||||
|
||||
pod2usage(-exitval => 1, -verbose => 0,
|
||||
-message => "No tar files specified",
|
||||
) unless @ARGV;
|
||||
|
||||
process_archive($_) foreach @ARGV;
|
||||
|
||||
exit 0;
|
||||
|
||||
|
||||
sub make_pattern {
|
||||
my($pat) = @_;
|
||||
|
||||
if($opt{'ignore-case'}) {
|
||||
$pattern = qr{(?im)$pat};
|
||||
}
|
||||
else {
|
||||
$pattern = qr{(?m)$pat};
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub process_archive {
|
||||
my($filename) = @_;
|
||||
|
||||
_log("Processing archive: $filename");
|
||||
my $next = Archive::Tar->iter($filename);
|
||||
while( my $f = $next->() ) {
|
||||
next unless $f->is_file;
|
||||
match_file($f) if $f->size > 0;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub match_file {
|
||||
my($f) = @_;
|
||||
my $path = $f->name;
|
||||
my $prefix = $f->prefix;
|
||||
if (defined $prefix) {
|
||||
$path = File::Spec->catfile($prefix, $path);
|
||||
}
|
||||
|
||||
_log("filename: %s (%d bytes)", $path, $f->size);
|
||||
|
||||
my $body = $f->get_content();
|
||||
if($body !~ $pattern) {
|
||||
_log(" no match");
|
||||
return;
|
||||
}
|
||||
|
||||
if($opt{'list-only'}) {
|
||||
print $path, "\n";
|
||||
return;
|
||||
}
|
||||
|
||||
save_file($path, $body);
|
||||
}
|
||||
|
||||
|
||||
sub save_file {
|
||||
my($path, $body) = @_;
|
||||
|
||||
_log(" found match - extracting");
|
||||
my($fh);
|
||||
my($dir, $file) = $path =~ m{\A(?:(.*)/)?([^/]+)\z};
|
||||
if($dir and not $opt{basename}) {
|
||||
_log(" writing to $dir/$file");
|
||||
$dir =~ s{\A/}{./};
|
||||
mkpath($dir) unless -d $dir;
|
||||
open $fh, '>', "$dir/$file" or die "open($dir/$file): $!";
|
||||
}
|
||||
else {
|
||||
_log(" writing to ./$file");
|
||||
open $fh, '>', $file or die "open($file): $!";
|
||||
}
|
||||
print $fh $body;
|
||||
close($fh);
|
||||
}
|
||||
|
||||
|
||||
sub _log {
|
||||
return unless $opt{verbose};
|
||||
my($format, @args) = @_;
|
||||
warn sprintf($format, @args) . "\n";
|
||||
}
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
ptargrep - Apply pattern matching to the contents of files in a tar archive
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
ptargrep [options] <pattern> <tar file> ...
|
||||
|
||||
Options:
|
||||
|
||||
--basename|-b ignore directory paths from archive
|
||||
--ignore-case|-i do case-insensitive pattern matching
|
||||
--list-only|-l list matching filenames rather than extracting matches
|
||||
--verbose|-v write debugging message to STDERR
|
||||
--help|-? detailed help message
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This utility allows you to apply pattern matching to B<the contents> of files
|
||||
contained in a tar archive. You might use this to identify all files in an
|
||||
archive which contain lines matching the specified pattern and either print out
|
||||
the pathnames or extract the files.
|
||||
|
||||
The pattern will be used as a Perl regular expression (as opposed to a simple
|
||||
grep regex).
|
||||
|
||||
Multiple tar archive filenames can be specified - they will each be processed
|
||||
in turn.
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<--basename> (alias -b)
|
||||
|
||||
When matching files are extracted, ignore the directory path from the archive
|
||||
and write to the current directory using the basename of the file from the
|
||||
archive. Beware: if two matching files in the archive have the same basename,
|
||||
the second file extracted will overwrite the first.
|
||||
|
||||
=item B<--ignore-case> (alias -i)
|
||||
|
||||
Make pattern matching case-insensitive.
|
||||
|
||||
=item B<--list-only> (alias -l)
|
||||
|
||||
Print the pathname of each matching file from the archive to STDOUT. Without
|
||||
this option, the default behaviour is to extract each matching file.
|
||||
|
||||
=item B<--verbose> (alias -v)
|
||||
|
||||
Log debugging info to STDERR.
|
||||
|
||||
=item B<--help> (alias -?)
|
||||
|
||||
Display this documentation.
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2010 Grant McLean E<lt>grantm@cpan.orgE<gt>
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
|
||||
@@ -0,0 +1,340 @@
|
||||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0; # ^ Run only under a shell
|
||||
#!perl
|
||||
|
||||
## shasum: filter for computing SHA digests (ref. sha1sum/md5sum)
|
||||
##
|
||||
## Copyright (C) 2003-2023 Mark Shelor, All Rights Reserved
|
||||
##
|
||||
## Version: 6.04
|
||||
## Sat Feb 25 12:00:50 PM MST 2023
|
||||
|
||||
## shasum SYNOPSIS adapted from GNU Coreutils sha1sum. Add
|
||||
## "-a" option for algorithm selection,
|
||||
## "-U" option for Universal Newlines support, and
|
||||
## "-0" option for reading bit strings.
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Fcntl;
|
||||
use Getopt::Long;
|
||||
use Digest::SHA qw($errmsg);
|
||||
|
||||
my $POD = <<'END_OF_POD';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
shasum - Print or Check SHA Checksums
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Usage: shasum [OPTION]... [FILE]...
|
||||
Print or check SHA checksums.
|
||||
With no FILE, or when FILE is -, read standard input.
|
||||
|
||||
-a, --algorithm 1 (default), 224, 256, 384, 512, 512224, 512256
|
||||
-b, --binary read in binary mode
|
||||
-c, --check read SHA sums from the FILEs and check them
|
||||
--tag create a BSD-style checksum
|
||||
-t, --text read in text mode (default)
|
||||
-U, --UNIVERSAL read in Universal Newlines mode
|
||||
produces same digest on Windows/Unix/Mac
|
||||
-0, --01 read in BITS mode
|
||||
ASCII '0' interpreted as 0-bit,
|
||||
ASCII '1' interpreted as 1-bit,
|
||||
all other characters ignored
|
||||
|
||||
The following five options are useful only when verifying checksums:
|
||||
--ignore-missing don't fail or report status for missing files
|
||||
-q, --quiet don't print OK for each successfully verified file
|
||||
-s, --status don't output anything, status code shows success
|
||||
--strict exit non-zero for improperly formatted checksum lines
|
||||
-w, --warn warn about improperly formatted checksum lines
|
||||
|
||||
-h, --help display this help and exit
|
||||
-v, --version output version information and exit
|
||||
|
||||
When verifying SHA-512/224 or SHA-512/256 checksums, indicate the
|
||||
algorithm explicitly using the -a option, e.g.
|
||||
|
||||
shasum -a 512224 -c checksumfile
|
||||
|
||||
The sums are computed as described in FIPS PUB 180-4. When checking,
|
||||
the input should be a former output of this program. The default
|
||||
mode is to print a line with checksum, a character indicating type
|
||||
(`*' for binary, ` ' for text, `U' for UNIVERSAL, `^' for BITS),
|
||||
and name for each FILE. The line starts with a `\' character if the
|
||||
FILE name contains either newlines or backslashes, which are then
|
||||
replaced by the two-character sequences `\n' and `\\' respectively.
|
||||
|
||||
Report shasum bugs to mshelor@cpan.org
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Running I<shasum> is often the quickest way to compute SHA message
|
||||
digests. The user simply feeds data to the script through files or
|
||||
standard input, and then collects the results from standard output.
|
||||
|
||||
The following command shows how to compute digests for typical inputs
|
||||
such as the NIST test vector "abc":
|
||||
|
||||
perl -e "print qq(abc)" | shasum
|
||||
|
||||
Or, if you want to use SHA-256 instead of the default SHA-1, simply say:
|
||||
|
||||
perl -e "print qq(abc)" | shasum -a 256
|
||||
|
||||
Since I<shasum> mimics the behavior of the combined GNU I<sha1sum>,
|
||||
I<sha224sum>, I<sha256sum>, I<sha384sum>, and I<sha512sum> programs,
|
||||
you can install this script as a convenient drop-in replacement.
|
||||
|
||||
Unlike the GNU programs, I<shasum> encompasses the full SHA standard by
|
||||
allowing partial-byte inputs. This is accomplished through the BITS
|
||||
option (I<-0>). The following example computes the SHA-224 digest of
|
||||
the 7-bit message I<0001100>:
|
||||
|
||||
perl -e "print qq(0001100)" | shasum -0 -a 224
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Copyright (C) 2003-2023 Mark Shelor <mshelor@cpan.org>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
I<shasum> is implemented using the Perl module L<Digest::SHA>.
|
||||
|
||||
=cut
|
||||
|
||||
END_OF_POD
|
||||
|
||||
my $VERSION = "6.04";
|
||||
|
||||
sub usage {
|
||||
my($err, $msg) = @_;
|
||||
|
||||
$msg = "" unless defined $msg;
|
||||
if ($err) {
|
||||
warn($msg . "Type shasum -h for help\n");
|
||||
exit($err);
|
||||
}
|
||||
my($USAGE) = $POD =~ /SYNOPSIS(.+?)^=/sm;
|
||||
$USAGE =~ s/^\s*//;
|
||||
$USAGE =~ s/\s*$//;
|
||||
$USAGE =~ s/^ //gm;
|
||||
print $USAGE, "\n";
|
||||
exit($err);
|
||||
}
|
||||
|
||||
|
||||
## Sync stdout and stderr by forcing a flush after every write
|
||||
|
||||
select((select(STDOUT), $| = 1)[0]);
|
||||
select((select(STDERR), $| = 1)[0]);
|
||||
|
||||
|
||||
## Collect options from command line
|
||||
|
||||
my ($alg, $binary, $check, $text, $status, $quiet, $warn, $help);
|
||||
my ($version, $BITS, $UNIVERSAL, $tag, $strict, $ignore_missing);
|
||||
|
||||
eval { Getopt::Long::Configure ("bundling") };
|
||||
GetOptions(
|
||||
'b|binary' => \$binary, 'c|check' => \$check,
|
||||
't|text' => \$text, 'a|algorithm=i' => \$alg,
|
||||
's|status' => \$status, 'w|warn' => \$warn,
|
||||
'q|quiet' => \$quiet,
|
||||
'h|help' => \$help, 'v|version' => \$version,
|
||||
'0|01' => \$BITS,
|
||||
'U|UNIVERSAL' => \$UNIVERSAL,
|
||||
'tag' => \$tag,
|
||||
'strict' => \$strict,
|
||||
'ignore-missing' => \$ignore_missing,
|
||||
) or usage(1, "");
|
||||
|
||||
|
||||
## Deal with help requests and incorrect uses
|
||||
|
||||
usage(0)
|
||||
if $help;
|
||||
usage(1, "shasum: Ambiguous file mode\n")
|
||||
if scalar(grep {defined $_}
|
||||
($binary, $text, $BITS, $UNIVERSAL)) > 1;
|
||||
usage(1, "shasum: --warn option used only when verifying checksums\n")
|
||||
if $warn && !$check;
|
||||
usage(1, "shasum: --status option used only when verifying checksums\n")
|
||||
if $status && !$check;
|
||||
usage(1, "shasum: --quiet option used only when verifying checksums\n")
|
||||
if $quiet && !$check;
|
||||
usage(1, "shasum: --ignore-missing option used only when verifying checksums\n")
|
||||
if $ignore_missing && !$check;
|
||||
usage(1, "shasum: --strict option used only when verifying checksums\n")
|
||||
if $strict && !$check;
|
||||
usage(1, "shasum: --tag does not support --text mode\n")
|
||||
if $tag && $text;
|
||||
usage(1, "shasum: --tag does not support Universal Newlines mode\n")
|
||||
if $tag && $UNIVERSAL;
|
||||
usage(1, "shasum: --tag does not support BITS mode\n")
|
||||
if $tag && $BITS;
|
||||
|
||||
|
||||
## Default to SHA-1 unless overridden by command line option
|
||||
|
||||
my %isAlg = map { $_ => 1 } (1, 224, 256, 384, 512, 512224, 512256);
|
||||
$alg = 1 unless defined $alg;
|
||||
usage(1, "shasum: Unrecognized algorithm\n") unless $isAlg{$alg};
|
||||
|
||||
my %Tag = map { $_ => "SHA$_" } (1, 224, 256, 384, 512);
|
||||
$Tag{512224} = "SHA512/224";
|
||||
$Tag{512256} = "SHA512/256";
|
||||
|
||||
|
||||
## Display version information if requested
|
||||
|
||||
if ($version) {
|
||||
print "$VERSION\n";
|
||||
exit(0);
|
||||
}
|
||||
|
||||
|
||||
## Try to figure out if the OS is DOS-like. If it is,
|
||||
## default to binary mode when reading files, unless
|
||||
## explicitly overridden by command line "--text" or
|
||||
## "--UNIVERSAL" options.
|
||||
|
||||
my $isDOSish = ($^O =~ /^(MSWin\d\d|os2|dos|mint|cygwin|msys)$/);
|
||||
if ($isDOSish) { $binary = 1 unless $text || $UNIVERSAL }
|
||||
|
||||
my $modesym = $binary ? '*' : ($UNIVERSAL ? 'U' : ($BITS ? '^' : ' '));
|
||||
|
||||
|
||||
## Read from STDIN (-) if no files listed on command line
|
||||
|
||||
@ARGV = ("-") unless @ARGV;
|
||||
|
||||
|
||||
## sumfile($file): computes SHA digest of $file
|
||||
|
||||
sub sumfile {
|
||||
my $file = shift;
|
||||
|
||||
my $mode = $binary ? 'b' : ($UNIVERSAL ? 'U' : ($BITS ? '0' : ''));
|
||||
my $digest = eval { Digest::SHA->new($alg)->addfile($file, $mode) };
|
||||
if ($@) { warn "shasum: $file: $errmsg\n"; return }
|
||||
$digest->hexdigest;
|
||||
}
|
||||
|
||||
|
||||
## %len2alg: maps hex digest length to SHA algorithm
|
||||
|
||||
my %len2alg = (40 => 1, 56 => 224, 64 => 256, 96 => 384, 128 => 512);
|
||||
$len2alg{56} = 512224 if $alg == 512224;
|
||||
$len2alg{64} = 512256 if $alg == 512256;
|
||||
|
||||
|
||||
## unescape: convert backslashed filename to plain filename
|
||||
|
||||
sub unescape {
|
||||
$_ = shift;
|
||||
s/\\\\/\0/g;
|
||||
s/\\n/\n/g;
|
||||
s/\0/\\/g;
|
||||
return $_;
|
||||
}
|
||||
|
||||
|
||||
## verify: confirm the digest values in a checksum file
|
||||
|
||||
sub verify {
|
||||
my $checkfile = shift;
|
||||
my ($err, $fmt_errs, $read_errs, $match_errs) = (0, 0, 0, 0);
|
||||
my ($num_fmt_OK, $num_OK) = (0, 0);
|
||||
my ($bslash, $sum, $fname, $rsp, $digest, $isOK);
|
||||
|
||||
local *FH;
|
||||
$checkfile eq '-' and open(FH, '< -')
|
||||
and $checkfile = 'standard input'
|
||||
or sysopen(FH, $checkfile, O_RDONLY)
|
||||
or die "shasum: $checkfile: $!\n";
|
||||
while (<FH>) {
|
||||
next if /^#/;
|
||||
if (/^[ \t]*\\?SHA/) {
|
||||
$modesym = '*';
|
||||
($bslash, $alg, $fname, $sum) =
|
||||
/^[ \t]*(\\?)SHA(\S+) \((.+)\) = ([\da-fA-F]+)/;
|
||||
$alg =~ tr{/}{}d if defined $alg;
|
||||
}
|
||||
else {
|
||||
($bslash, $sum, $modesym, $fname) =
|
||||
/^[ \t]*(\\?)([\da-fA-F]+)[ \t]([ *^U])(.+)/;
|
||||
$alg = defined $sum ? $len2alg{length($sum)} : undef;
|
||||
}
|
||||
if (grep { ! defined $_ } ($alg, $sum, $modesym, $fname) or
|
||||
! $isAlg{$alg}) {
|
||||
warn("shasum: $checkfile: $.: improperly " .
|
||||
"formatted SHA checksum line\n") if $warn;
|
||||
$fmt_errs++;
|
||||
$err = 1 if $strict;
|
||||
next;
|
||||
}
|
||||
$num_fmt_OK++;
|
||||
$fname = unescape($fname) if $bslash;
|
||||
next if $ignore_missing && ! -e $fname;
|
||||
$rsp = "$fname: ";
|
||||
($binary, $text, $UNIVERSAL, $BITS) =
|
||||
map { $_ eq $modesym } ('*', ' ', 'U', '^');
|
||||
$isOK = 0;
|
||||
unless ($digest = sumfile($fname)) {
|
||||
$rsp .= "FAILED open or read\n";
|
||||
$err = 1; $read_errs++;
|
||||
}
|
||||
elsif (lc($sum) eq $digest) {
|
||||
$rsp .= "OK\n";
|
||||
$isOK = 1;
|
||||
$num_OK++;
|
||||
}
|
||||
else { $rsp .= "FAILED\n"; $err = 1; $match_errs++ }
|
||||
print $rsp unless ($status || ($quiet && $isOK));
|
||||
}
|
||||
close(FH);
|
||||
if (! $num_fmt_OK) {
|
||||
warn("shasum: $checkfile: no properly formatted " .
|
||||
"SHA checksum lines found\n");
|
||||
$err = 1;
|
||||
}
|
||||
elsif (! $status) {
|
||||
warn("shasum: WARNING: $fmt_errs line" . ($fmt_errs>1?
|
||||
's are':' is') . " improperly formatted\n") if $fmt_errs;
|
||||
warn("shasum: WARNING: $read_errs listed file" .
|
||||
($read_errs>1?'s':'') . " could not be read\n") if $read_errs;
|
||||
warn("shasum: WARNING: $match_errs computed checksum" .
|
||||
($match_errs>1?'s':'') . " did NOT match\n") if $match_errs;
|
||||
}
|
||||
if ($ignore_missing && ! $num_OK && $num_fmt_OK) {
|
||||
warn("shasum: $checkfile: no file was verified\n")
|
||||
unless $status;
|
||||
$err = 1;
|
||||
}
|
||||
return($err == 0);
|
||||
}
|
||||
|
||||
|
||||
## Verify or compute SHA checksums of requested files
|
||||
|
||||
my($file, $digest);
|
||||
my $STATUS = 0;
|
||||
for $file (@ARGV) {
|
||||
if ($check) { $STATUS = 1 unless verify($file) }
|
||||
elsif ($digest = sumfile($file)) {
|
||||
if ($file =~ /[\n\\]/) {
|
||||
$file =~ s/\\/\\\\/g; $file =~ s/\n/\\n/g;
|
||||
print "\\";
|
||||
}
|
||||
unless ($tag) { print "$digest $modesym$file\n" }
|
||||
else { print "$Tag{$alg} ($file) = $digest\n" }
|
||||
}
|
||||
else { $STATUS = 1 }
|
||||
}
|
||||
exit($STATUS);
|
||||
@@ -0,0 +1,723 @@
|
||||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0; # ^ Run only under a shell
|
||||
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
diagnostics, splain - produce verbose warning diagnostics
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Using the C<diagnostics> pragma:
|
||||
|
||||
use diagnostics;
|
||||
use diagnostics -verbose;
|
||||
|
||||
enable diagnostics;
|
||||
disable diagnostics;
|
||||
|
||||
Using the C<splain> standalone filter program:
|
||||
|
||||
perl program 2>diag.out
|
||||
splain [-v] [-p] diag.out
|
||||
|
||||
Using diagnostics to get stack traces from a misbehaving script:
|
||||
|
||||
perl -Mdiagnostics=-traceonly my_script.pl
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
=head2 The C<diagnostics> Pragma
|
||||
|
||||
This module extends the terse diagnostics normally emitted by both the
|
||||
perl compiler and the perl interpreter (from running perl with a -w
|
||||
switch or C<use warnings>), 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 a la warn() are unaffected,
|
||||
allowing duplicate user messages to be displayed.
|
||||
|
||||
This module also adds a stack trace to the error message when perl dies.
|
||||
This is useful for pinpointing what
|
||||
caused the death. The B<-traceonly> (or
|
||||
just B<-t>) flag turns off the explanations of warning messages leaving just
|
||||
the stack traces. So if your script is dieing, run it again with
|
||||
|
||||
perl -Mdiagnostics=-traceonly my_bad_script
|
||||
|
||||
to see the call stack at the time of death. By supplying the B<-warntrace>
|
||||
(or just B<-w>) flag, any warnings emitted will also come with a stack
|
||||
trace.
|
||||
|
||||
=head2 The I<splain> Program
|
||||
|
||||
Another 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.009001;
|
||||
use Carp;
|
||||
$Carp::Internal{__PACKAGE__.""}++;
|
||||
|
||||
our $VERSION = '1.39';
|
||||
our $DEBUG;
|
||||
our $VERBOSE;
|
||||
our $PRETTY;
|
||||
our $TRACEONLY = 0;
|
||||
our $WARNTRACE = 0;
|
||||
|
||||
use Config;
|
||||
use Text::Tabs 'expand';
|
||||
my $privlib = $Config{privlibexp};
|
||||
if ($^O eq 'VMS') {
|
||||
require VMS::Filespec;
|
||||
$privlib = VMS::Filespec::unixify($privlib);
|
||||
}
|
||||
my @trypod = (
|
||||
"$privlib/pod/perldiag.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];
|
||||
|
||||
$DEBUG ||= 0;
|
||||
|
||||
local $| = 1;
|
||||
local $_;
|
||||
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 { "$_/".__PACKAGE__.".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
|
||||
'sol' => '/', # forward slash / solidus
|
||||
'verbar' => '|', # vertical bar
|
||||
|
||||
"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
|
||||
'sol' => '/', # Forward slash / solidus
|
||||
'verbar' => '|', # vertical bar
|
||||
|
||||
# # capital A, acute accent
|
||||
"Aacute" => chr utf8::unicode_to_native(0xC1)
|
||||
|
||||
# etc
|
||||
);
|
||||
|
||||
%HTML_2_ASCII_7 = (
|
||||
'amp' => '&', # ampersand
|
||||
'lt' => '<', # left chevron, less-than
|
||||
'gt' => '>', # right chevron, greater-than
|
||||
'quot' => '"', # double quote
|
||||
'sol' => '/', # Forward slash / solidus
|
||||
'verbar' => '|', # vertical bar
|
||||
|
||||
"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 %transfmt = ();
|
||||
my $transmo = <<EOFUNC;
|
||||
sub transmo {
|
||||
#local \$^W = 0; # recursive warnings we do NOT need!
|
||||
EOFUNC
|
||||
|
||||
my %msg;
|
||||
my $over_level = 0; # We look only at =item lines at the first =over level
|
||||
{
|
||||
print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
|
||||
local $/ = '';
|
||||
local $_;
|
||||
my $header;
|
||||
my @headers;
|
||||
my $for_item;
|
||||
my $seen_body;
|
||||
while (<POD_DIAG>) {
|
||||
|
||||
sub _split_pod_link {
|
||||
$_[0] =~ m'(?:([^|]*)\|)?([^/]*)(?:/("?)(.*)\3)?'s;
|
||||
($1,$2,$4);
|
||||
}
|
||||
|
||||
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/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/bold($+)/ges;
|
||||
s/[IF]<(.*?)>/italic($1)/ges;
|
||||
s/L<(.*?)>/
|
||||
my($text,$page,$sect) = _split_pod_link($1);
|
||||
defined $text
|
||||
? $text
|
||||
: defined $sect
|
||||
? italic($sect) . ' in ' . italic($page)
|
||||
: italic($page)
|
||||
/ges;
|
||||
s/S<(.*?)>/
|
||||
$1
|
||||
/ges;
|
||||
} else {
|
||||
s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/gs;
|
||||
s/[IF]<(.*?)>/$1/gs;
|
||||
s/L<(.*?)>/
|
||||
my($text,$page,$sect) = _split_pod_link($1);
|
||||
defined $text
|
||||
? $text
|
||||
: defined $sect
|
||||
? qq '"$sect" in $page'
|
||||
: $page
|
||||
/ges;
|
||||
s/S<(.*?)>/
|
||||
$1
|
||||
/ges;
|
||||
}
|
||||
unless (/^=/) {
|
||||
if (defined $header) {
|
||||
if ( $header eq 'DESCRIPTION' &&
|
||||
( /Optional warnings are enabled/
|
||||
|| /Some of these messages are generic./
|
||||
) )
|
||||
{
|
||||
next;
|
||||
}
|
||||
$_ = expand $_;
|
||||
s/^/ /gm;
|
||||
$msg{$header} .= $_;
|
||||
for my $h(@headers) { $msg{$h} .= $_ }
|
||||
++$seen_body;
|
||||
undef $for_item;
|
||||
}
|
||||
next;
|
||||
}
|
||||
|
||||
# If we have not come across the body of the description yet, then
|
||||
# the previous header needs to share the same description.
|
||||
if ($seen_body) {
|
||||
@headers = ();
|
||||
}
|
||||
else {
|
||||
push @headers, $header if defined $header;
|
||||
}
|
||||
|
||||
if ( ! s/=item (.*?)\s*\z//s || $over_level != 1) {
|
||||
|
||||
if ( s/=head1\sDESCRIPTION//) {
|
||||
$msg{$header = 'DESCRIPTION'} = '';
|
||||
undef $for_item;
|
||||
}
|
||||
elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
|
||||
$for_item = $1;
|
||||
}
|
||||
elsif( /^=over\b/ ) {
|
||||
$over_level++;
|
||||
}
|
||||
elsif( /^=back\b/ ) { # Stop processing body here
|
||||
$over_level--;
|
||||
if ($over_level == 0) {
|
||||
undef $header;
|
||||
undef $for_item;
|
||||
$seen_body = 0;
|
||||
next;
|
||||
}
|
||||
}
|
||||
next;
|
||||
}
|
||||
|
||||
if( $for_item ) { $header = $for_item; undef $for_item }
|
||||
else {
|
||||
$header = $1;
|
||||
|
||||
$header =~ s/\n/ /gs; # Allow multi-line headers
|
||||
}
|
||||
|
||||
# strip formatting directives from =item line
|
||||
$header =~ s/[A-Z]<(.*?)>/$1/g;
|
||||
|
||||
# Since we strip "(\.\s*)\n" when we search a warning, strip it here as well
|
||||
$header =~ s/(\.\s*)?$//;
|
||||
|
||||
my @toks = split( /(%l?[dxX]|%[ucp]|%(?:\.\d+)?[fs])/, $header );
|
||||
if (@toks > 1) {
|
||||
my $conlen = 0;
|
||||
for my $i (0..$#toks){
|
||||
if( $i % 2 ){
|
||||
if( $toks[$i] eq '%c' ){
|
||||
$toks[$i] = '.';
|
||||
} elsif( $toks[$i] =~ /^%(?:d|u)$/ ){
|
||||
$toks[$i] = '\d+';
|
||||
} elsif( $toks[$i] =~ '^%(?:s|.*f)$' ){
|
||||
$toks[$i] = $i == $#toks ? '.*' : '.*?';
|
||||
} elsif( $toks[$i] =~ '%.(\d+)s' ){
|
||||
$toks[$i] = ".{$1}";
|
||||
} elsif( $toks[$i] =~ '^%l*([pxX])$' ){
|
||||
$toks[$i] = $1 eq 'X' ? '[\dA-F]+' : '[\da-f]+';
|
||||
}
|
||||
} elsif( length( $toks[$i] ) ){
|
||||
$toks[$i] = quotemeta $toks[$i];
|
||||
$conlen += length( $toks[$i] );
|
||||
}
|
||||
}
|
||||
my $lhs = join( '', @toks );
|
||||
$lhs =~ s/(\\\s)+/\\s+/g; # Replace lit space with multi-space match
|
||||
$transfmt{$header}{pat} =
|
||||
" s^\\s*$lhs\\s*\Q$header\Es\n\t&& return 1;\n";
|
||||
$transfmt{$header}{len} = $conlen;
|
||||
} else {
|
||||
my $lhs = "\Q$header\E";
|
||||
$lhs =~ s/(\\\s)+/\\s+/g; # Replace lit space with multi-space match
|
||||
$transfmt{$header}{pat} =
|
||||
" s^\\s*$lhs\\s*\Q$header\E\n\t && return 1;\n";
|
||||
$transfmt{$header}{len} = length( $header );
|
||||
}
|
||||
|
||||
print STDERR __PACKAGE__.": Duplicate entry: \"$header\"\n"
|
||||
if $msg{$header};
|
||||
|
||||
$msg{$header} = '';
|
||||
$seen_body = 0;
|
||||
}
|
||||
|
||||
|
||||
close POD_DIAG unless *main::DATA eq *POD_DIAG;
|
||||
|
||||
die "No diagnostics?" unless %msg;
|
||||
|
||||
# Apply patterns in order of decreasing sum of lengths of fixed parts
|
||||
# Seems the best way of hitting the right one.
|
||||
for my $hdr ( sort { $transfmt{$b}{len} <=> $transfmt{$a}{len} }
|
||||
keys %transfmt ){
|
||||
$transmo .= $transfmt{$hdr}{pat};
|
||||
}
|
||||
$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 defined $SIG{__WARN__} && ($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;
|
||||
};
|
||||
# matches trace and traceonly for legacy doc mixup reasons
|
||||
/^-t(race(only)?)?$/ && do {
|
||||
$TRACEONLY++;
|
||||
next;
|
||||
};
|
||||
/^-w(arntrace)?$/ && do {
|
||||
$WARNTRACE++;
|
||||
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 __PACKAGE__ or !splainthis($warning)) {
|
||||
if ($WARNTRACE) {
|
||||
print STDERR Carp::longmess($warning);
|
||||
} else {
|
||||
print STDERR $warning;
|
||||
}
|
||||
}
|
||||
goto &$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 (my $caller = (caller($i++))[3]) {
|
||||
if ($caller eq '(eval)') {
|
||||
$in_eval = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
splainthis($exception) unless $in_eval;
|
||||
if (caller eq __PACKAGE__) {
|
||||
print STDERR "INTERNAL EXCEPTION: $exception";
|
||||
}
|
||||
&$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
|
||||
|
||||
return if $in_eval;
|
||||
|
||||
# We don't want to unset these if we're coming from an eval because
|
||||
# then we've turned off diagnostics.
|
||||
|
||||
# Switch off our die/warn handlers so we don't wind up in our own
|
||||
# traps.
|
||||
$SIG{__DIE__} = $SIG{__WARN__} = '';
|
||||
|
||||
$exception =~ s/\n(?=.)/\n\t/gas;
|
||||
|
||||
die Carp::longmess("__diagnostics__")
|
||||
=~ s/^__diagnostics__.*?line \d+\.?\n/
|
||||
"Uncaught exception from user code:\n\t$exception"
|
||||
/re;
|
||||
# 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 {
|
||||
return 0 if $TRACEONLY;
|
||||
for (my $tmp = shift) {
|
||||
local $\;
|
||||
local $!;
|
||||
### &finish_compilation unless %msg;
|
||||
s/(\.\s*)?\n+$//;
|
||||
my $orig = $_;
|
||||
# return unless defined;
|
||||
|
||||
# get rid of the where-are-we-in-input part
|
||||
s/, <.*?> (?:line|chunk).*$//;
|
||||
|
||||
# Discard 1st " at <file> line <no>" and all text beyond
|
||||
# but be aware of messages containing " at this-or-that"
|
||||
my $real = 0;
|
||||
my @secs = split( / at / );
|
||||
return unless @secs;
|
||||
$_ = $secs[0];
|
||||
for my $i ( 1..$#secs ){
|
||||
if( $secs[$i] =~ /.+? (?:line|chunk) \d+/ ){
|
||||
$real = 1;
|
||||
last;
|
||||
} else {
|
||||
$_ .= ' at ' . $secs[$i];
|
||||
}
|
||||
}
|
||||
|
||||
# remove parenthesis occurring at the end of some messages
|
||||
s/^\((.*)\)$/$1/;
|
||||
|
||||
if ($exact_duplicate{$orig}++) {
|
||||
return &transmo;
|
||||
} else {
|
||||
return 0 unless &transmo;
|
||||
}
|
||||
|
||||
my $short = shorten($orig);
|
||||
if ($old_diag{$_}) {
|
||||
autodescribe();
|
||||
print THITHER "$short (#$old_diag{$_})\n";
|
||||
$wantspace = 1;
|
||||
} elsif (!$msg{$_} && $orig =~ /\n./s) {
|
||||
# A multiline message, like "Attempt to reload /
|
||||
# Compilation failed"
|
||||
my $found;
|
||||
for (split /^/, $orig) {
|
||||
splainthis($_) and $found = 1;
|
||||
}
|
||||
return $found;
|
||||
} else {
|
||||
autodescribe();
|
||||
$old_diag{$_} = ++$count;
|
||||
print THITHER "\n" if $wantspace;
|
||||
$wantspace = 0;
|
||||
print THITHER "$short (#$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
|
||||
@@ -0,0 +1,301 @@
|
||||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0; # ^ Run only under a shell
|
||||
#!/usr/bin/perl
|
||||
|
||||
# Streaming zip
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use IO::Compress::Zip qw(zip
|
||||
ZIP_CM_STORE
|
||||
ZIP_CM_DEFLATE
|
||||
ZIP_CM_BZIP2 ) ;
|
||||
|
||||
use Getopt::Long;
|
||||
|
||||
my $VERSION = '1.00';
|
||||
|
||||
my $compression_method = ZIP_CM_DEFLATE;
|
||||
my $stream = 0;
|
||||
my $zipfile = '-';
|
||||
my $memberName = '-' ;
|
||||
my $zip64 = 0 ;
|
||||
my $level ;
|
||||
|
||||
GetOptions("zip64" => \$zip64,
|
||||
"method=s" => \&lookupMethod,
|
||||
"0" => sub { $level = 0 },
|
||||
"1" => sub { $level = 1 },
|
||||
"2" => sub { $level = 2 },
|
||||
"3" => sub { $level = 3 },
|
||||
"4" => sub { $level = 4 },
|
||||
"5" => sub { $level = 5 },
|
||||
"6" => sub { $level = 6 },
|
||||
"7" => sub { $level = 7 },
|
||||
"8" => sub { $level = 8 },
|
||||
"9" => sub { $level = 9 },
|
||||
"stream" => \$stream,
|
||||
"zipfile=s" => \$zipfile,
|
||||
"member-name=s" => \$memberName,
|
||||
'version' => sub { print "$VERSION\n"; exit 0 },
|
||||
'help' => \&Usage,
|
||||
)
|
||||
or Usage();
|
||||
|
||||
Usage()
|
||||
if @ARGV;
|
||||
|
||||
my @extraOpts = ();
|
||||
|
||||
if ($compression_method == ZIP_CM_DEFLATE && defined $level)
|
||||
{
|
||||
push @extraOpts, (Level => $level)
|
||||
}
|
||||
|
||||
# force streaming zip file when writing to stdout.
|
||||
$stream = 1
|
||||
if $zipfile eq '-';
|
||||
|
||||
zip '-' => $zipfile,
|
||||
Name => $memberName,
|
||||
Zip64 => $zip64,
|
||||
Method => $compression_method,
|
||||
Stream => $stream,
|
||||
@extraOpts
|
||||
or die "Error creating zip file '$zipfile': $\n" ;
|
||||
|
||||
exit 0;
|
||||
|
||||
sub lookupMethod
|
||||
{
|
||||
my $name = shift;
|
||||
my $value = shift ;
|
||||
|
||||
my %valid = ( store => ZIP_CM_STORE,
|
||||
deflate => ZIP_CM_DEFLATE,
|
||||
bzip2 => ZIP_CM_BZIP2,
|
||||
lzma => 14,
|
||||
xz => 95,
|
||||
zstd => 93,
|
||||
);
|
||||
|
||||
my $method = $valid{ lc $value };
|
||||
|
||||
Usage("Unknown method '$value'")
|
||||
if ! defined $method;
|
||||
|
||||
installModule("Lzma")
|
||||
if $method == 14 ;
|
||||
|
||||
installModule("Xz")
|
||||
if $method == 95 ;
|
||||
|
||||
installModule("Zstd")
|
||||
if $method == 93;
|
||||
|
||||
$compression_method = $method;
|
||||
}
|
||||
|
||||
sub installModule
|
||||
{
|
||||
my $name = shift ;
|
||||
|
||||
eval " use IO::Compress::$name; use IO::Compress::Adapter::$name ; " ;
|
||||
die "Method '$name' needs IO::Compress::$name\n"
|
||||
if $@;
|
||||
}
|
||||
|
||||
sub Usage
|
||||
{
|
||||
print <<EOM;
|
||||
Usage:
|
||||
producer | streamzip [OPTIONS] | consumer
|
||||
producer | streamzip [OPTIONS] -zipfile output.zip
|
||||
|
||||
Stream data from stdin, compress into a Zip container, and either stream to stdout, or
|
||||
write to a named file.
|
||||
|
||||
OPTIONS
|
||||
|
||||
-zipfile=F Write zip container to the filename 'F'
|
||||
Outputs to stdout if zipfile not specified.
|
||||
-member-name=M Set member name to 'M' [Default '-']
|
||||
-0 ... -9 Set compression level for Deflate
|
||||
[Default: 6]
|
||||
-zip64 Create a Zip64-compliant zip file [Default: No]
|
||||
Enable Zip64 if input is greater than 4Gig.
|
||||
-stream Force a streamed zip file when 'zipfile' option is also enabled.
|
||||
Only applies when 'zipfile' option is used. [Default: No]
|
||||
Stream is always enabled when writing to stdout.
|
||||
-method=M Compress using method 'M'.
|
||||
Valid methods are
|
||||
store Store without compression
|
||||
deflate Use Deflate compression [Deflault]
|
||||
bzip2 Use Bzip2 compression
|
||||
lzma Use LZMA compression [needs IO::Compress::Lzma]
|
||||
xz Use LZMA compression [needs IO::Compress::Xz]
|
||||
zstd Use LZMA compression [needs IO::Compress::Zstd]
|
||||
-version Display version number [$VERSION]
|
||||
|
||||
Copyright (c) 2019-2022 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.
|
||||
|
||||
EOM
|
||||
exit;
|
||||
}
|
||||
|
||||
|
||||
__END__
|
||||
=head1 NAME
|
||||
|
||||
streamzip - create a zip file from stdin
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
producer | streamzip [opts] | consumer
|
||||
producer | streamzip [opts] -zipfile=output.zip
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This program will read data from C<stdin>, compress it into a zip container
|
||||
and, by default, write a I<streamed> zip file to C<stdout>. No temporary
|
||||
files are created.
|
||||
|
||||
The zip container written to C<stdout> is, by necessity, written in
|
||||
streaming format. Most programs that read Zip files can cope with a
|
||||
streamed zip file, but if interoperability is important, and your workflow
|
||||
allows you to write the zip file directly to disk you can create a
|
||||
non-streamed zip file using the C<zipfile> option.
|
||||
|
||||
=head2 OPTIONS
|
||||
|
||||
=over 5
|
||||
|
||||
=item -zip64
|
||||
|
||||
Create a Zip64-compliant zip container. Use this option if the input is
|
||||
greater than 4Gig.
|
||||
|
||||
Default is disabled.
|
||||
|
||||
=item -zipfile=F
|
||||
|
||||
Write zip container to the filename C<F>.
|
||||
|
||||
Use the C<Stream> option to force the creation of a streamed zip file.
|
||||
|
||||
=item -member-name=M
|
||||
|
||||
This option is used to name the "file" in the zip container.
|
||||
|
||||
Default is '-'.
|
||||
|
||||
=item -stream
|
||||
|
||||
Ignored when writing to C<stdout>.
|
||||
|
||||
If the C<zipfile> option is specified, including this option will trigger
|
||||
the creation of a streamed zip file.
|
||||
|
||||
Default: Always enabled when writing to C<stdout>, otherwise disabled.
|
||||
|
||||
=item -method=M
|
||||
|
||||
Compress using method C<M>.
|
||||
|
||||
Valid method names are
|
||||
|
||||
* store Store without compression
|
||||
* deflate Use Deflate compression [Deflault]
|
||||
* bzip2 Use Bzip2 compression
|
||||
* lzma Use LZMA compression
|
||||
* xz Use xz compression
|
||||
* zstd Use Zstandard compression
|
||||
|
||||
Note that Lzma compress needs C<IO::Compress::Lzma> to be installed.
|
||||
|
||||
Note that Zstd compress needs C<IO::Compress::Zstd> to be installed.
|
||||
|
||||
Default is C<deflate>.
|
||||
|
||||
=item -0, -1, -2, -3, -4, -5, -6, -7, -8, -9
|
||||
|
||||
Sets the compression level for C<deflate>. Ignored for all other compression methods.
|
||||
|
||||
C<-0> means no compression and C<-9> for maximum compression.
|
||||
|
||||
Default is 6
|
||||
|
||||
=item -version
|
||||
|
||||
Display version number
|
||||
|
||||
=item -help
|
||||
|
||||
Display help
|
||||
|
||||
=back
|
||||
|
||||
=head2 Examples
|
||||
|
||||
Create a zip file bt reading daa from stdin
|
||||
|
||||
$ echo Lorem ipsum dolor sit | perl ./bin/streamzip >abcd.zip
|
||||
|
||||
Check the contents of C<abcd,zip> with the standard C<unzip> utility
|
||||
|
||||
Archive: abcd.zip
|
||||
Length Date Time Name
|
||||
--------- ---------- ----- ----
|
||||
22 2021-01-08 19:45 -
|
||||
--------- -------
|
||||
22 1 file
|
||||
|
||||
Notice how the C<Name> is set to C<->.
|
||||
That is the default for a few zip utilities whwre the member name is not given.
|
||||
|
||||
If you want to explicitly name the file, use the C<-member-name> option as follows
|
||||
|
||||
$ echo Lorem ipsum dolor sit | perl ./bin/streamzip -member-name latin >abcd.zip
|
||||
|
||||
$ unzip -l abcd.zip
|
||||
Archive: abcd.zip
|
||||
Length Date Time Name
|
||||
--------- ---------- ----- ----
|
||||
22 2021-01-08 19:47 latin
|
||||
--------- -------
|
||||
22 1 file
|
||||
|
||||
|
||||
=head2 When to write a Streamed Zip File
|
||||
|
||||
A Streamed Zip File is useful in situations where you cannot seek
|
||||
backwards/forwards in the file.
|
||||
|
||||
A good examples is when you are serving dynamic content from a Web Server
|
||||
straight into a socket without needing to create a temporary zip file in
|
||||
the filesystsm.
|
||||
|
||||
Similarly if your workfow uses a Linux pipelined commands.
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
General feedback/questions/bug reports should be sent to
|
||||
L<https://github.com/pmqs/IO-Compress/issues> (preferred) or
|
||||
L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>.
|
||||
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Paul Marquess F<pmqs@cpan.org>.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2019-2022 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.
|
||||
@@ -0,0 +1,188 @@
|
||||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0; # ^ Run only under a shell
|
||||
#!perl
|
||||
use 5.006;
|
||||
BEGIN { pop @INC if $INC[-1] eq '.' }
|
||||
use strict;
|
||||
eval {
|
||||
require ExtUtils::ParseXS;
|
||||
1;
|
||||
}
|
||||
or do {
|
||||
my $err = $@ || 'Zombie error';
|
||||
my $v = $ExtUtils::ParseXS::VERSION;
|
||||
$v = '<undef>' if not defined $v;
|
||||
die "Failed to load or import from ExtUtils::ParseXS (version $v). Please check that ExtUtils::ParseXS is installed correctly and that the newest version will be found in your \@INC path: $err";
|
||||
};
|
||||
|
||||
use Getopt::Long;
|
||||
|
||||
my %args = ();
|
||||
|
||||
my $usage = "Usage: xsubpp [-v] [-csuffix csuffix] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-strip|s pattern] [-typemap typemap]... file.xs\n";
|
||||
|
||||
Getopt::Long::Configure qw(no_auto_abbrev no_ignore_case);
|
||||
|
||||
@ARGV = grep {$_ ne '-C++'} @ARGV; # Allow -C++ for backward compatibility
|
||||
GetOptions(\%args, qw(hiertype!
|
||||
prototypes!
|
||||
versioncheck!
|
||||
linenumbers!
|
||||
optimize!
|
||||
inout!
|
||||
argtypes!
|
||||
object_capi!
|
||||
except!
|
||||
v
|
||||
typemap=s@
|
||||
output=s
|
||||
s|strip=s
|
||||
csuffix=s
|
||||
))
|
||||
or die $usage;
|
||||
|
||||
if ($args{v}) {
|
||||
print "xsubpp version $ExtUtils::ParseXS::VERSION\n";
|
||||
exit;
|
||||
}
|
||||
|
||||
@ARGV == 1 or die $usage;
|
||||
|
||||
$args{filename} = shift @ARGV;
|
||||
|
||||
my $pxs = ExtUtils::ParseXS->new;
|
||||
$pxs->process_file(%args);
|
||||
exit( $pxs->report_error_count() ? 1 : 0 );
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
xsubpp - compiler to convert Perl XS code into C code
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
B<xsubpp> [B<-v>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-nooptimize>] [B<-typemap typemap>] [B<-output filename>]... file.xs
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This compiler is typically run by the makefiles created by L<ExtUtils::MakeMaker>
|
||||
or by L<Module::Build> or other Perl module build tools.
|
||||
|
||||
I<xsubpp> will compile XS code into C code by embedding the constructs
|
||||
necessary to let C functions manipulate Perl values and creates the glue
|
||||
necessary to let Perl access those functions. The compiler uses typemaps to
|
||||
determine how to map C function parameters and variables to Perl values.
|
||||
|
||||
The compiler will search for typemap files called I<typemap>. It will use
|
||||
the following search path to find default typemaps, with the rightmost
|
||||
typemap taking precedence.
|
||||
|
||||
../../../typemap:../../typemap:../typemap:typemap
|
||||
|
||||
It will also use a default typemap installed as C<ExtUtils::typemap>.
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
Note that the C<XSOPT> MakeMaker option may be used to add these options to
|
||||
any makefiles generated by MakeMaker.
|
||||
|
||||
=over 5
|
||||
|
||||
=item B<-hiertype>
|
||||
|
||||
Retains '::' in type names so that C++ hierarchical types can be mapped.
|
||||
|
||||
=item B<-except>
|
||||
|
||||
Adds exception handling stubs to the C code.
|
||||
|
||||
=item B<-typemap typemap>
|
||||
|
||||
Indicates that a user-supplied typemap should take precedence over the
|
||||
default typemaps. This option may be used multiple times, with the last
|
||||
typemap having the highest precedence.
|
||||
|
||||
=item B<-output filename>
|
||||
|
||||
Specifies the name of the output file to generate. If no file is
|
||||
specified, output will be written to standard output.
|
||||
|
||||
=item B<-v>
|
||||
|
||||
Prints the I<xsubpp> version number to standard output, then exits.
|
||||
|
||||
=item B<-prototypes>
|
||||
|
||||
By default I<xsubpp> will not automatically generate prototype code for
|
||||
all xsubs. This flag will enable prototypes.
|
||||
|
||||
=item B<-noversioncheck>
|
||||
|
||||
Disables the run time test that determines if the object file (derived
|
||||
from the C<.xs> file) and the C<.pm> files have the same version
|
||||
number.
|
||||
|
||||
=item B<-nolinenumbers>
|
||||
|
||||
Prevents the inclusion of '#line' directives in the output.
|
||||
|
||||
=item B<-nooptimize>
|
||||
|
||||
Disables certain optimizations. The only optimization that is currently
|
||||
affected is the use of I<target>s by the output C code (see L<perlguts>).
|
||||
This may significantly slow down the generated code, but this is the way
|
||||
B<xsubpp> of 5.005 and earlier operated.
|
||||
|
||||
=item B<-noinout>
|
||||
|
||||
Disable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST> declarations.
|
||||
|
||||
=item B<-noargtypes>
|
||||
|
||||
Disable recognition of ANSI-like descriptions of function signature.
|
||||
|
||||
=item B<-C++>
|
||||
|
||||
Currently doesn't do anything at all. This flag has been a no-op for
|
||||
many versions of perl, at least as far back as perl5.003_07. It's
|
||||
allowed here for backwards compatibility.
|
||||
|
||||
=item B<-s=...> or B<-strip=...>
|
||||
|
||||
I<This option is obscure and discouraged.>
|
||||
|
||||
If specified, the given string will be stripped off from the beginning
|
||||
of the C function name in the generated XS functions (if it starts with that prefix).
|
||||
This only applies to XSUBs without C<CODE> or C<PPCODE> blocks.
|
||||
For example, the XS:
|
||||
|
||||
void foo_bar(int i);
|
||||
|
||||
when C<xsubpp> is invoked with C<-s foo_> will install a C<foo_bar>
|
||||
function in Perl, but really call C<bar(i)> in C. Most of the time,
|
||||
this is the opposite of what you want and failure modes are somewhat
|
||||
obscure, so please avoid this option where possible.
|
||||
|
||||
=back
|
||||
|
||||
=head1 ENVIRONMENT
|
||||
|
||||
No environment variables are used.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Originally by Larry Wall. Turned into the C<ExtUtils::ParseXS> module
|
||||
by Ken Williams.
|
||||
|
||||
=head1 MODIFICATION HISTORY
|
||||
|
||||
See the file F<Changes>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
perl(1), perlxs(1), perlxstut(1), ExtUtils::ParseXS
|
||||
|
||||
=cut
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
@@ -0,0 +1,120 @@
|
||||
#!/usr/bin/env bash
|
||||
|
||||
# docx2txt, a command-line utility to convert Docx documents to text format.
|
||||
# Copyright (C) 2008 Sandeep Kumar
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
||||
#
|
||||
# A simple .docx to .txt converter
|
||||
#
|
||||
# This script is a wrapper around core docx2txt.pl and saves text output for
|
||||
# (filename or) filename.docx in filename.txt .
|
||||
#
|
||||
# Author : Sandeep Kumar (shimple0 -AT- Yahoo .DOT. COM)
|
||||
#
|
||||
# ChangeLog :
|
||||
#
|
||||
# 10/08/2008 - Initial version (v0.1)
|
||||
# 15/08/2008 - Invoking docx2txt.pl with docx document instead of xml file,
|
||||
# so don't need unzip and rm actions now.
|
||||
# Removed dependency on sed for generating output filename.
|
||||
# 23/09/2008 - Changed #! line to use /usr/bin/env - good suggestion from
|
||||
# Rene Maroufi (info>AT<maroufi>DOT<net) to reduce user work
|
||||
# during installation.
|
||||
# 15/09/2009 - Added support for directory (holding unzipped content of
|
||||
# .docx file) argument to keep it's usage in sync with main
|
||||
# docx2txt.pl script.
|
||||
# Fixed bug in condition check for input file accessibility.
|
||||
# 25/11/2009 - Fixed bug in set expression that was resulting in incorrect
|
||||
# handling of file/directory names containing spaces.
|
||||
#
|
||||
|
||||
|
||||
MYLOC=`dirname "$0"` # invoked perl script docx2txt.pl is expected here.
|
||||
|
||||
function usage ()
|
||||
{
|
||||
cat << _USAGE_
|
||||
|
||||
Usage : $0 <file.docx>
|
||||
|
||||
<file.docx> can also specify a directory holding the unzipped
|
||||
content of a .docx file.
|
||||
|
||||
_USAGE_
|
||||
|
||||
exit 1
|
||||
}
|
||||
|
||||
[ $# != 1 ] && usage
|
||||
|
||||
#
|
||||
# Remove trailing '/'s if any, when input specifies a directory.
|
||||
#
|
||||
shopt -s extglob
|
||||
set "${1%%+(/)}"
|
||||
|
||||
if [ -d "$1" ]
|
||||
then
|
||||
if ! [ -r "$1" -a -x "$1" ]
|
||||
then
|
||||
echo -e "\nCan't access/read input directory <$1>!\n"
|
||||
exit 1
|
||||
fi
|
||||
elif ! [ -f "$1" -a -r "$1" -a -s "$1" ]
|
||||
then
|
||||
echo -e "\nCheck if <$1> exists, is readable and has non-zero size!\n"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
|
||||
TEXTFILE=${1/%.docx/.txt}
|
||||
[ "$1" == "$TEXTFILE" ] && TEXTFILE="$1.txt"
|
||||
|
||||
|
||||
#
|
||||
# $1 : filename to check for existence
|
||||
# $2 : message regarding file
|
||||
#
|
||||
function check_for_existence ()
|
||||
{
|
||||
if [ -f "$1" ]
|
||||
then
|
||||
read -p "overwrite $2 <$1> [y/n] ? " yn
|
||||
if [ "$yn" != "y" ]
|
||||
then
|
||||
echo -e "\nPlease copy <$1> somewhere before running the script.\n"
|
||||
echeck=1
|
||||
fi
|
||||
fi
|
||||
}
|
||||
|
||||
echeck=0
|
||||
check_for_existence "$TEXTFILE" "Output text file"
|
||||
[ $echeck -ne 0 ] && exit 1
|
||||
|
||||
#
|
||||
# Invoke perl script to do the actual text extraction
|
||||
#
|
||||
|
||||
"$MYLOC/docx2txt.pl" "$1" "$TEXTFILE"
|
||||
if [ $? == 0 ]
|
||||
then
|
||||
echo -e "\nText extracted from <$1> is available in <$TEXTFILE>.\n"
|
||||
else
|
||||
echo -e "\nFailed to extract text from <$1>!\n"
|
||||
fi
|
||||
|
||||
@@ -0,0 +1,721 @@
|
||||
#!/usr/bin/env perl
|
||||
|
||||
# docx2txt, a command-line utility to convert Docx documents to text format.
|
||||
# Copyright (C) 2008-2014 Sandeep Kumar
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
||||
#
|
||||
# This script extracts text from document.xml contained inside .docx file.
|
||||
# Perl v5.10.1 was used for testing this script.
|
||||
#
|
||||
# Author : Sandeep Kumar (shimple0 -AT- Yahoo .DOT. COM)
|
||||
#
|
||||
# ChangeLog :
|
||||
#
|
||||
# 10/08/2008 - Initial version (v0.1)
|
||||
# 15/08/2008 - Script takes two arguments [second optional] now and can be
|
||||
# used independently to extract text from docx file. It accepts
|
||||
# docx file directly, instead of xml file.
|
||||
# 18/08/2008 - Added support for center and right justification of text that
|
||||
# fits in a line 80 characters wide (adjustable).
|
||||
# 03/09/2008 - Fixed the slip in usage message.
|
||||
# 12/09/2008 - Slightly changed the script invocation and argument handling
|
||||
# to incorporate some of the shell script functionality here.
|
||||
# Added support to handle embedded urls in docx document.
|
||||
# 23/09/2008 - Changed #! line to use /usr/bin/env - good suggestion from
|
||||
# Rene Maroufi (info>AT<maroufi>DOT<net) to reduce user work
|
||||
# during installation.
|
||||
# 31/08/2009 - Added support for handling more escape characters.
|
||||
# Using OS specific null device to redirect stderr.
|
||||
# Saving text file in binary mode.
|
||||
# 03/09/2009 - Updations based on feedback/suggestions from Sergei Kulakov
|
||||
# (sergei>AT<dewia>DOT<com).
|
||||
# - removal of non-document text in between TOC related tags.
|
||||
# - display of hyperlink alongside linked text user controlled.
|
||||
# - some character conversion updates
|
||||
# 05/09/2009 - Merged cjustify and rjustify into single subroutine justify.
|
||||
# Added more character conversions.
|
||||
# Organised conversion mappings in tabular form for speedup and
|
||||
# easy maintenance.
|
||||
# Tweaked code to reduce number of passes over document content.
|
||||
# 10/09/2009 - For leaner text experience, hyperlink is not displayed if
|
||||
# hyperlink and hyperlinked text are same, even if user has
|
||||
# enabled hyperlink display.
|
||||
# Improved handling of short line justification. Many
|
||||
# justification tag patterns were not captured earlier.
|
||||
# 11/09/2009 - A directory holding the unzipped content of .docx file can
|
||||
# also be specified as argument to the script, in place of file.
|
||||
# 17/09/2009 - Removed trailing slashes from input directory name.
|
||||
# Updated unzip command invocations to handle path names
|
||||
# containing spaces.
|
||||
# 01/10/2009 - Added support for configuration file.
|
||||
# 02/10/2009 - Using single quotes to specify path for unzip command.
|
||||
# 04/10/2009 - Corrected configuration option name lineIndent to listIndent.
|
||||
# 11/12/2011 - Configuration variables now begin with config_ .
|
||||
# Configuration file is looked for in HOME directory as well.
|
||||
# Added a check for existence of unzip command.
|
||||
# Superscripted cross-references are placed within [...] now.
|
||||
# Fixed bugs #3003903, #3082018 and #3082035.
|
||||
# Fixed nullDevice for Cygwin.
|
||||
# 12/12/2011 - Configuration file is also looked for in /etc, default
|
||||
# location for Unix-ish systems.
|
||||
# 22/12/2011 - Added ' and " to docx specific escape characters
|
||||
# conversions. [Bug #3463033]
|
||||
# 24/12/2011 - Improved handling of special (non-text) characters, along with
|
||||
# support for more non-text characters.
|
||||
# 05/01/2012 - Configuration file is now looked for in current directory,
|
||||
# user configuration directory and system configuration
|
||||
# directory (in the specified order). This streamlining allows
|
||||
# for per user configuration file even on Windows.
|
||||
# 14/01/2012 - Wrong code was committed during earlier fixing of nullDevice
|
||||
# for Cygwin, fixed that.
|
||||
# Usage is extended to accept docx file from standard input.
|
||||
# "-h" has to be given as the first argument to get usage help.
|
||||
# Added new configuration variable "config_tempDir".
|
||||
# 14/03/2014 - Remove deleted text from output. This effects in case changes
|
||||
# are being tracked in docx document. Patch was contributed by
|
||||
# William Parsons (wbparsons>AT<cshore>DOT<com).
|
||||
# Removed experimental config option config_exp_extra_deEscape.
|
||||
# 27/03/2014 - Remove non-document_text content marked by wp/wp14 tags.
|
||||
# 07/04/2014 - Added support for handling lists (bullet, decimal, letter,
|
||||
# roman) along with (attempt at) indentation.
|
||||
# Added new configuration variable config_twipsPerChar.
|
||||
# Removed configuration variable config_listIndent.
|
||||
# 14/04/2014 - Fixed list numbering - lvl start value needs to be considered.
|
||||
# Improved list indentation and corresponding code.
|
||||
# 27/04/2014 - Improved paragraph content layout/indentation.
|
||||
# 13/05/2014 - Added new configuration variable config_unzip_opts. Users can
|
||||
# now use unzipping programs like 7z, pkzipc, winzip as well.
|
||||
#
|
||||
|
||||
|
||||
#
|
||||
# The default settings below can be overridden via docx2txt.config in current
|
||||
# directory/ user configuration directory/ system configuration directory.
|
||||
#
|
||||
|
||||
our $config_unzip = '/usr/bin/unzip'; # Windows path like 'C:/path/to/unzip.exe'
|
||||
our $config_unzip_opts = '-p'; # To extract file on standard output
|
||||
|
||||
our $config_newLine = "\n"; # Alternative is "\r\n".
|
||||
our $config_lineWidth = 80; # Line width, used for short line justification.
|
||||
our $config_showHyperLink = "N"; # Show hyperlink alongside linked text.
|
||||
our $config_tempDir; # Directory for temporary file creation.
|
||||
our $config_twipsPerChar = 120; # Approx mapping for layout purpose.
|
||||
|
||||
|
||||
#
|
||||
# Windows/Non-Windows specific settings. Adjust these here, if needed.
|
||||
#
|
||||
|
||||
if ($ENV{OS} =~ /^Windows/ && !(exists $ENV{OSTYPE} || exists $ENV{HOME})) {
|
||||
$nullDevice = "nul";
|
||||
$userConfigDir = $ENV{APPDATA};
|
||||
|
||||
#
|
||||
# On Windows, configuration file is installed in same folder as this script.
|
||||
#
|
||||
$0 =~ m%^(.*[/\\])[^/\\]*?$%;
|
||||
$systemConfigDir = $1;
|
||||
|
||||
$config_tempDir = "$ENV{TEMP}";
|
||||
} else {
|
||||
$nullDevice = "/dev/null";
|
||||
$userConfigDir = $ENV{HOME};
|
||||
$systemConfigDir = "/etc";
|
||||
|
||||
$config_tempDir = "/tmp";
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# Character conversion tables
|
||||
#
|
||||
|
||||
# Only (amp, apos, gt, lt and quot) are the required reserved characters in HTML
|
||||
# and XHTML, others are used for better text experience.
|
||||
my %escChrs = ( amp => '&', apos => '\'', gt => '>', lt => '<', quot => '"',
|
||||
acute => '\'', brvbar => '|', copy => '(C)', divide => '/',
|
||||
laquo => '<<', macr => '-', nbsp => ' ', raquo => '>>',
|
||||
reg => '(R)', shy => '-', times => 'x'
|
||||
);
|
||||
|
||||
my %splchars = (
|
||||
"\xC2" => {
|
||||
"\xA0" => ' ', # <nbsp> non-breaking space
|
||||
"\xA2" => 'cent', # <cent>
|
||||
"\xA3" => 'Pound', # <pound>
|
||||
"\xA5" => 'Yen', # <yen>
|
||||
"\xA6" => '|', # <brvbar> broken vertical bar
|
||||
# "\xA7" => '', # <sect> section
|
||||
"\xA9" => '(C)', # <copy> copyright
|
||||
"\xAB" => '<<', # <laquo> angle quotation mark (left)
|
||||
"\xAC" => '-', # <not> negation
|
||||
"\xAE" => '(R)', # <reg> registered trademark
|
||||
"\xB1" => '+-', # <plusmn> plus-or-minus
|
||||
"\xB4" => '\'', # <acute>
|
||||
"\xB5" => 'u', # <micro>
|
||||
# "\xB6" => '', # <para> paragraph
|
||||
"\xBB" => '>>', # <raquo> angle quotation mark (right)
|
||||
"\xBC" => '(1/4)', # <frac14> fraction 1/4
|
||||
"\xBD" => '(1/2)', # <frac12> fraction 1/2
|
||||
"\xBE" => '(3/4)', # <frac34> fraction 3/4
|
||||
},
|
||||
|
||||
"\xC3" => {
|
||||
"\x97" => 'x', # <times> multiplication
|
||||
"\xB7" => '/', # <divide> division
|
||||
},
|
||||
|
||||
"\xCF" => {
|
||||
"\x80" => 'PI', # <pi>
|
||||
},
|
||||
|
||||
"\xE2\x80" => {
|
||||
"\x82" => ' ', # <ensp> en space
|
||||
"\x83" => ' ', # <emsp> em space
|
||||
"\x85" => ' ', # <qemsp>
|
||||
"\x93" => ' - ', # <ndash> en dash
|
||||
"\x94" => ' -- ', # <mdash> em dash
|
||||
"\x95" => '--', # <horizontal bar>
|
||||
"\x98" => '`', # <soq>
|
||||
"\x99" => '\'', # <scq>
|
||||
"\x9C" => '"', # <doq>
|
||||
"\x9D" => '"', # <dcq>
|
||||
"\xA2" => '::', # <diamond symbol>
|
||||
"\xA6" => '...', # <hellip> horizontal ellipsis
|
||||
"\xB0" => '%.', # <permil> per mille
|
||||
},
|
||||
|
||||
"\xE2\x82" => {
|
||||
"\xAC" => 'Euro' # <euro>
|
||||
},
|
||||
|
||||
"\xE2\x84" => {
|
||||
"\x85" => 'c/o', # <care/of>
|
||||
"\x97" => '(P)', # <sound recording copyright>
|
||||
"\xA0" => '(SM)', # <servicemark>
|
||||
"\xA2" => '(TM)', # <trade> trademark
|
||||
"\xA6" => 'Ohm', # <Ohm>
|
||||
},
|
||||
|
||||
"\xE2\x85" => {
|
||||
"\x93" => '(1/3)',
|
||||
"\x94" => '(2/3)',
|
||||
"\x95" => '(1/5)',
|
||||
"\x96" => '(2/5)',
|
||||
"\x97" => '(3/5)',
|
||||
"\x98" => '(4/5)',
|
||||
"\x99" => '(1/6)',
|
||||
"\x9B" => '(1/8)',
|
||||
"\x9C" => '(3/8)',
|
||||
"\x9D" => '(5/8)',
|
||||
"\x9E" => '(7/8)',
|
||||
"\x9F" => '1/',
|
||||
},
|
||||
|
||||
"\xE2\x86" => {
|
||||
"\x90" => '<--', # <larr> left arrow
|
||||
"\x92" => '-->', # <rarr> right arrow
|
||||
"\x94" => '<-->', # <harr> left right arrow
|
||||
},
|
||||
|
||||
"\xE2\x88" => {
|
||||
"\x82" => 'd', # partial differential
|
||||
"\x9E" => 'infinity',
|
||||
},
|
||||
|
||||
"\xE2\x89" => {
|
||||
"\xA0" => '!=', # <neq>
|
||||
"\xA4" => '<=', # <leq>
|
||||
"\xA5" => '>=', # <geq>
|
||||
},
|
||||
|
||||
"\xEF\x82" => {
|
||||
"\xB7" => '*' # small white square
|
||||
}
|
||||
);
|
||||
|
||||
|
||||
#
|
||||
# Check argument(s) sanity.
|
||||
#
|
||||
|
||||
my $usage = <<USAGE;
|
||||
|
||||
Usage: $0 [infile.docx|-|-h] [outfile.txt|-]
|
||||
$0 < infile.docx
|
||||
$0 < infile.docx > outfile.txt
|
||||
|
||||
In second usage, output is dumped on STDOUT.
|
||||
|
||||
Use '-h' as the first argument to get this usage information.
|
||||
|
||||
Use '-' as the infile name to read the docx file from STDIN.
|
||||
|
||||
Use '-' as the outfile name to dump the text on STDOUT.
|
||||
Output is saved in infile.txt if second argument is omitted.
|
||||
|
||||
Note: infile.docx can also be a directory name holding the unzipped content
|
||||
of concerned .docx file.
|
||||
|
||||
USAGE
|
||||
|
||||
die $usage if (@ARGV > 2 || $ARGV[0] eq '-h');
|
||||
|
||||
|
||||
#
|
||||
# Look for configuration file in current directory/ user configuration
|
||||
# directory/ system configuration directory - in the given order.
|
||||
#
|
||||
|
||||
my %config;
|
||||
|
||||
if (-f "docx2txt.config") {
|
||||
%config = do 'docx2txt.config';
|
||||
} elsif (-f "$userConfigDir/docx2txt.config") {
|
||||
%config = do "$userConfigDir/docx2txt.config";
|
||||
} elsif (-f "$systemConfigDir/docx2txt.config") {
|
||||
%config = do "$systemConfigDir/docx2txt.config";
|
||||
}
|
||||
|
||||
if (%config) {
|
||||
foreach my $var (keys %config) {
|
||||
$$var = $config{$var};
|
||||
}
|
||||
}
|
||||
|
||||
#
|
||||
# Check for unzip utility, before proceeding further.
|
||||
#
|
||||
|
||||
die "Failed to locate unzip command '$config_unzip'!\n" if ! -f $config_unzip;
|
||||
|
||||
|
||||
#
|
||||
# Handle cases where this script reads docx file from STDIN.
|
||||
#
|
||||
|
||||
if (@ARGV == 0) {
|
||||
$ARGV[0] = '-';
|
||||
$ARGV[1] = '-';
|
||||
$inputFileName = "STDIN";
|
||||
} elsif (@ARGV == 1 && $ARGV[0] eq '-') {
|
||||
$ARGV[1] = '-';
|
||||
$inputFileName = "STDIN";
|
||||
} else {
|
||||
$inputFileName = $ARGV[0];
|
||||
}
|
||||
|
||||
if ($ARGV[0] eq '-') {
|
||||
$tempFile = "${config_tempDir}/dx2tTemp_${$}_" . time() . ".docx";
|
||||
open my $fhTemp, "> $tempFile" or die "Can't create temporary file for storing docx file read from STDIN!\n";
|
||||
|
||||
binmode $fhTemp;
|
||||
local $/ = undef;
|
||||
my $docxFileContent = <STDIN>;
|
||||
|
||||
print $fhTemp $docxFileContent;
|
||||
close $fhTemp;
|
||||
|
||||
$ARGV[0] = $tempFile;
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# Check for existence and readability of required file in specified directory,
|
||||
# and whether it is a text file.
|
||||
#
|
||||
|
||||
sub check_for_required_file_in_folder {
|
||||
stat("$_[1]/$_[0]");
|
||||
die "Can't read <$_[0]> in <$_[1]>!\n" if ! (-f _ && -r _);
|
||||
die "<$_[1]/$_[0]> does not seem to be a text file!\n" if ! -T _;
|
||||
}
|
||||
|
||||
sub readFileInto {
|
||||
local $/ = undef;
|
||||
open my $fh, "$_[0]" or die "Couldn't read file <$_[0]>!\n";
|
||||
binmode $fh;
|
||||
$_[1] = <$fh>;
|
||||
close $fh;
|
||||
}
|
||||
|
||||
sub readOptionalFileInto {
|
||||
local $/ = undef;
|
||||
|
||||
stat("$_[0]");
|
||||
if (-f _) {
|
||||
if (-r _ && -T _) {
|
||||
open my $fh, "$_[0]" or die "Couldn't read file <$_[0]>!\n";
|
||||
binmode $fh;
|
||||
$_[1] = <$fh>;
|
||||
close $fh;
|
||||
}
|
||||
else {
|
||||
die "Invalid <$_[0]>!\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
#
|
||||
# Check whether first argument is specifying a directory holding extracted
|
||||
# content of .docx file, or .docx file itself.
|
||||
#
|
||||
|
||||
sub cleandie {
|
||||
unlink("$tempFile") if -e "$tempFile";
|
||||
die "$_[0]";
|
||||
}
|
||||
|
||||
|
||||
stat($ARGV[0]);
|
||||
|
||||
if (-d _) {
|
||||
check_for_required_file_in_folder("word/document.xml", $ARGV[0]);
|
||||
check_for_required_file_in_folder("word/_rels/document.xml.rels", $ARGV[0]);
|
||||
$inpIsDir = 'y';
|
||||
}
|
||||
else {
|
||||
cleandie "Can't read docx file <$inputFileName>!\n" if ! (-f _ && -r _);
|
||||
cleandie "<$inputFileName> does not seem to be a docx file!\n" if -T _;
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# Extract xml document content from argument docx file/directory.
|
||||
#
|
||||
|
||||
my $unzip_cmd = "'$config_unzip' $config_unzip_opts";
|
||||
|
||||
if ($inpIsDir eq 'y') {
|
||||
readFileInto("$ARGV[0]/word/document.xml", $content);
|
||||
} else {
|
||||
$content = `$unzip_cmd "$ARGV[0]" word/document.xml 2>$nullDevice`;
|
||||
}
|
||||
|
||||
cleandie "Failed to extract required information from <$inputFileName>!\n" if ! $content;
|
||||
|
||||
|
||||
#
|
||||
# Be ready for outputting the extracted text contents.
|
||||
#
|
||||
|
||||
if (@ARGV == 1) {
|
||||
$ARGV[1] = $ARGV[0];
|
||||
|
||||
# Remove any trailing slashes to generate proper output filename, when
|
||||
# input is directory.
|
||||
$ARGV[1] =~ s%[/\\]+$%% if ($inpIsDir eq 'y');
|
||||
|
||||
$ARGV[1] .= ".txt" if !($ARGV[1] =~ s/\.docx$/\.txt/);
|
||||
}
|
||||
|
||||
my $txtfile;
|
||||
open($txtfile, "> $ARGV[1]") || cleandie "Can't create <$ARGV[1]> for output!\n";
|
||||
binmode $txtfile; # Ensure no auto-conversion of '\n' to '\r\n' on Windows.
|
||||
|
||||
|
||||
#
|
||||
# Gather information about header, footer, hyperlinks, images, footnotes etc.
|
||||
#
|
||||
|
||||
if ($inpIsDir eq 'y') {
|
||||
readFileInto("$ARGV[0]/word/_rels/document.xml.rels", $_);
|
||||
} else {
|
||||
$_ = `$unzip_cmd "$ARGV[0]" word/_rels/document.xml.rels 2>$nullDevice`;
|
||||
}
|
||||
|
||||
my %docurels;
|
||||
while (/<Relationship Id="(.*?)" Type=".*?\/([^\/]*?)" Target="(.*?)"( .*?)?\/>/g)
|
||||
{
|
||||
$docurels{"$2:$1"} = $3;
|
||||
}
|
||||
|
||||
#
|
||||
# Gather list numbering information.
|
||||
#
|
||||
|
||||
$_ = "";
|
||||
if ($inpIsDir eq 'y') {
|
||||
readOptionalFileInto("$ARGV[0]/word/numbering.xml", $_);
|
||||
} else {
|
||||
$_ = `$unzip_cmd "$ARGV[0]" word/numbering.xml 2>$nullDevice`;
|
||||
}
|
||||
|
||||
my %abstractNum;
|
||||
my @N2ANId = ();
|
||||
|
||||
my %NFList = (
|
||||
"bullet" => \&bullet,
|
||||
"decimal" => \&decimal,
|
||||
"lowerLetter" => \&lowerLetter,
|
||||
"upperLetter" => \&upperLetter,
|
||||
"lowerRoman" => \&lowerRoman,
|
||||
"upperRoman" => \&upperRoman
|
||||
);
|
||||
|
||||
if ($_) {
|
||||
while (/<w:abstractNum w:abstractNumId="(\d+)">(.*?)<\/w:abstractNum>/g)
|
||||
{
|
||||
my $abstractNumId = $1, $temp = $2;
|
||||
|
||||
while ($temp =~ /<w:lvl w:ilvl="(\d+)"[^>]*><w:start w:val="(\d+)"[^>]*><w:numFmt w:val="(.*?)"[^>]*>.*?<w:lvlText w:val="(.*?)"[^>]*>.*?<w:ind w:left="(\d+)" w:hanging="(\d+)"[^>]*>/g )
|
||||
{
|
||||
# $2: Start $3: NumFmt, $4: LvlText, ($5,$6): (Indent (twips), hanging)
|
||||
|
||||
@{$abstractNum{"$abstractNumId:$1"}} = (
|
||||
$NFList{$3},
|
||||
$4,
|
||||
$2,
|
||||
int ((($5-$6) / $config_twipsPerChar) + 0.5),
|
||||
$5
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
while ( /<w:num w:numId="(\d+)"><w:abstractNumId w:val="(\d+)"/g )
|
||||
{
|
||||
$N2ANId[$1] = $2;
|
||||
}
|
||||
}
|
||||
|
||||
# Remove the temporary file (if) created to store input from STDIN. All the
|
||||
# (needed) data is read from it already.
|
||||
unlink("$tempFile") if -e "$tempFile";
|
||||
|
||||
|
||||
#
|
||||
# Subroutines for center and right justification of text in a line.
|
||||
#
|
||||
|
||||
sub justify {
|
||||
my $len = length $_[1];
|
||||
|
||||
if ($_[0] eq "center" && $len < ($config_lineWidth - 1)) {
|
||||
return ' ' x (($config_lineWidth - $len) / 2) . $_[1];
|
||||
} elsif ($_[0] eq "right" && $len < $config_lineWidth) {
|
||||
return ' ' x ($config_lineWidth - $len) . $_[1];
|
||||
} else {
|
||||
return $_[1];
|
||||
}
|
||||
}
|
||||
|
||||
#
|
||||
# Subroutines for dealing with embedded links and images
|
||||
#
|
||||
|
||||
sub hyperlink {
|
||||
my $hlrid = $_[0];
|
||||
my $hltext = $_[1];
|
||||
my $hlink = $docurels{"hyperlink:$hlrid"};
|
||||
|
||||
$hltext =~ s/<[^>]*?>//og;
|
||||
$hltext .= " [HYPERLINK: $hlink]" if (lc $config_showHyperLink eq "y" && $hltext ne $hlink);
|
||||
|
||||
return $hltext;
|
||||
}
|
||||
|
||||
#
|
||||
# Subroutines for processing numbering information.
|
||||
#
|
||||
|
||||
my @RomanNumbers = ( "",
|
||||
"i", "ii", "iii", "iv", "v", "vi", "vii", "viii", "ix", "x", "xi", "xii",
|
||||
"xiii", "xiv", "xv", "xvi", "xvii", "xviii", "xix", "xx", "xxi", "xxii",
|
||||
"xxiii", "xxiv", "xxv", "xxvi", "xxvii", "xxviii", "xxix", "xxx", "xxxi",
|
||||
"xxxii", "xxxiii", "xxxiv", "xxxv", "xxxvi", "xxxvii", "xxxviii", "xxxix",
|
||||
"xl", "xli", "xlii", "xliii", "xliv", "xlv", "xlvi", "xlvii", "xlviii",
|
||||
"xlix", "l", "li" );
|
||||
|
||||
|
||||
sub lowerRoman {
|
||||
return $RomanNumbers[$_[0]] if ($_[0] < @RomanNumbers);
|
||||
|
||||
@rcode = ("i", "iv", "v", "ix", "x", "xl", "l", "xc", "c", "cd", "d", "cm", "m");
|
||||
@dval = (1, 4, 5, 9, 10, 40, 50, 90, 100, 400, 500, 900, 1000);
|
||||
|
||||
my $roman = "";
|
||||
my $num = $_[0];
|
||||
|
||||
my $div, $i = (@rcode - 1);
|
||||
while ($num > 0) {
|
||||
$i-- while ($num < $dval[$i]);
|
||||
$div = $num / $dval[$i];
|
||||
$num = $num % $dval[$i];
|
||||
$roman .= $rcode[$i] x $div;
|
||||
}
|
||||
|
||||
return $roman;
|
||||
}
|
||||
|
||||
sub upperRoman {
|
||||
return uc lowerRoman(@_);
|
||||
}
|
||||
|
||||
|
||||
sub lowerLetter {
|
||||
@Alphabets = split '' , "abcdefghijklmnopqrstuvwxyz";
|
||||
return $Alphabets[($_[0] % 26) - 1] x (($_[0] - 1)/26 + 1);
|
||||
}
|
||||
|
||||
sub upperLetter {
|
||||
return uc lowerLetter(@_);
|
||||
}
|
||||
|
||||
|
||||
sub decimal {
|
||||
return $_[0];
|
||||
}
|
||||
|
||||
|
||||
my %bullets = (
|
||||
"\x6F" => 'o',
|
||||
"\xEF\x81\xB6" => '::', # Diamond
|
||||
"\xEF\x82\xA7" => '#', # Small Black Square
|
||||
"\xEF\x82\xB7" => '*', # Small Black Circle
|
||||
"\xEF\x83\x98" => '>', # Arrowhead
|
||||
"\xEF\x83\xBC" => '+' # Right Sign
|
||||
);
|
||||
|
||||
sub bullet {
|
||||
return $bullets{$_[0]} ? $bullets{$_[0]} : 'oo';
|
||||
}
|
||||
|
||||
my @lastCnt = (0);
|
||||
my @twipStack = (0);
|
||||
my @keyStack = (undef);
|
||||
my $ssiz = 1;
|
||||
|
||||
sub listNumbering {
|
||||
my $aref = \@{$abstractNum{"$N2ANId[$_[0]]:$_[1]"}};
|
||||
my $lvlText;
|
||||
|
||||
if ($aref->[0] != \&bullet) {
|
||||
my $key = "$N2ANId[$_[0]]:$_[1]";
|
||||
my $ccnt;
|
||||
|
||||
if ($aref->[4] < $twipStack[$ssiz-1]) {
|
||||
while ($twipStack[$ssiz-1] > $aref->[4]) {
|
||||
pop @twipStack;
|
||||
pop @keyStack;
|
||||
pop @lastCnt;
|
||||
$ssiz--;
|
||||
}
|
||||
}
|
||||
|
||||
if ($aref->[4] == $twipStack[$ssiz-1]) {
|
||||
if ($key eq $keyStack[$ssiz-1]) {
|
||||
++$lastCnt[$ssiz-1];
|
||||
}
|
||||
else {
|
||||
$keyStack[$ssiz-1] = $key;
|
||||
$lastCnt[$ssiz-1] = $aref->[2];
|
||||
}
|
||||
}
|
||||
elsif ($aref->[4] > $twipStack[$ssiz-1]) {
|
||||
push @twipStack, $aref->[4];
|
||||
push @keyStack, $key;
|
||||
push @lastCnt, $aref->[2];
|
||||
$ssiz++;
|
||||
}
|
||||
|
||||
$ccnt = $lastCnt[$ssiz-1];
|
||||
|
||||
$lvlText = $aref->[1];
|
||||
$lvlText =~ s/%\d([^%]*)$/($aref->[0]->($ccnt)).$1/oe;
|
||||
|
||||
my $i = $ssiz - 2;
|
||||
$i-- while ($lvlText =~ s/%\d([^%]*)$/$lastCnt[$i]$1/o);
|
||||
}
|
||||
else {
|
||||
$lvlText = $aref->[0]->($aref->[1]);
|
||||
}
|
||||
|
||||
return ' ' x $aref->[3] . $lvlText . ' ';
|
||||
}
|
||||
|
||||
#
|
||||
# Subroutines for processing paragraph content.
|
||||
#
|
||||
|
||||
sub processParagraph {
|
||||
my $para = $_[0] . "$config_newLine";
|
||||
my $align = $1 if ($_[0] =~ /<w:jc w:val="([^"]*?)"\/>/);
|
||||
|
||||
$para =~ s/<.*?>//og;
|
||||
return justify($align,$para) if $align;
|
||||
|
||||
return $para;
|
||||
}
|
||||
|
||||
#
|
||||
# Text extraction starts.
|
||||
#
|
||||
|
||||
my %tag2chr = (tab => "\t", noBreakHyphen => "-", softHyphen => " - ");
|
||||
|
||||
$content =~ s/<?xml .*?\?>(\r)?\n//;
|
||||
|
||||
$content =~ s{<(wp14|wp):[^>]*>.*?</\1:[^>]*>}||og;
|
||||
|
||||
# Remove the field instructions (instrText) and data (fldData), and deleted
|
||||
# text.
|
||||
$content =~ s{<w:(instrText|fldData|delText)[^>]*>.*?</w:\1>}||ogs;
|
||||
|
||||
# Mark cross-reference superscripting within [...].
|
||||
$content =~ s|<w:vertAlign w:val="superscript"/></w:rPr><w:t>(.*?)</w:t>|[$1]|og;
|
||||
|
||||
$content =~ s{<w:(tab|noBreakHyphen|softHyphen)/>}|$tag2chr{$1}|og;
|
||||
|
||||
my $hr = '-' x $config_lineWidth . $config_newLine;
|
||||
$content =~ s|<w:pBdr>.*?</w:pBdr>|$hr|og;
|
||||
|
||||
$content =~ s{<w:caps/>.*?(<w:t>|<w:t [^>]+>)(.*?)</w:t>}/uc $2/oge;
|
||||
|
||||
$content =~ s{<w:hyperlink r:id="(.*?)".*?>(.*?)</w:hyperlink>}/hyperlink($1,$2)/oge;
|
||||
|
||||
$content =~ s|<w:numPr><w:ilvl w:val="(\d+)"/><w:numId w:val="(\d+)"\/>|listNumbering($2,$1)|oge;
|
||||
|
||||
$content =~ s{<w:ind w:(left|firstLine)="(\d+)"( w:hanging="(\d+)")?[^>]*>}|' ' x int((($2-$4)/$config_twipsPerChar)+0.5)|oge;
|
||||
|
||||
$content =~ s{<w:p [^/>]+?/>|<w:br/>}|$config_newLine|og;
|
||||
|
||||
$content =~ s/<w:p[^>]+?>(.*?)<\/w:p>/processParagraph($1)/ogse;
|
||||
|
||||
$content =~ s/<.*?>//og;
|
||||
|
||||
|
||||
#
|
||||
# Convert non-ASCII characters/character sequences to ASCII characters.
|
||||
#
|
||||
|
||||
$content =~ s/(\xC2|\xC3|\xCF|\xE2.|\xEF.)(.)/($splchars{$1}{$2} ? $splchars{$1}{$2} : $1.$2)/oge;
|
||||
|
||||
#
|
||||
# Convert docx specific (reserved HTML/XHTML) escape characters.
|
||||
#
|
||||
$content =~ s/(&)(amp|apos|gt|lt|quot)(;)/$escChrs{lc $2}/iog;
|
||||
|
||||
#
|
||||
# Write the extracted and converted text contents to output.
|
||||
#
|
||||
|
||||
print $txtfile $content;
|
||||
close $txtfile;
|
||||
|
||||
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
@@ -0,0 +1,2 @@
|
||||
#!/bin/sh
|
||||
exec grep -E "$@"
|
||||
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
@@ -0,0 +1,2 @@
|
||||
#!/bin/sh
|
||||
exec grep -F "$@"
|
||||
Binary file not shown.
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user