p147685/CardiacPhase
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Initial class construction

Browse Source
This commit is contained in:
João Narciso
2019-05-06 16:34:28 +02:00
parent 67f2d57e03
commit 431ff5f7d4
5813 changed files with 1622108 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Git/usr/bin/[.exe
BIN
View File
Binary file not shown.
Git/usr/bin/addgnupghome
+122
View File
@@ -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
Git/usr/bin/applygnupgdefaults
+81
View File
@@ -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
Git/usr/bin/arch.exe
BIN
View File
Binary file not shown.
Git/usr/bin/astextplain
+33
View File
@@ -0,0 +1,33 @@
#!/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)
antiword -m UTF-8 "$1" | sed "s/\^M$//" || cat "$1"
;;
*.docx | *.DOCX | *.dotx | *.DOTX | *.docm | *.DOCM | *.dotm | *.DOTM)
docx2txt.pl "$1" -
;;
*.pdf | *.PDF)
pdftotext -layout -enc UTF-8 "$1" - | sed "s/(\^M$)|(^\^L)//"
;;
# TODO add rtf support
*.rtf | *.RTF)
cat "$1"
;;
*)
echo "E: unsupported filetype $1" 1>&2
exit 1
;;
esac
exit 0
Git/usr/bin/autopoint
+811
View File
@@ -0,0 +1,811 @@
#! /bin/sh
#
# Copyright (C) 2002-2016 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/>.
#
# This file is meant for authors, maintainers, co-maintainers or installers
# of packages which are internationalized with the help of GNU gettext. For
# further information how to use it consult the GNU gettext manual.
progname=$0
package=gettext-tools
version=0.19.8.1
archive_version=0.19.8
# Set variables
# - gettext_datadir directory where the data files are stored.
prefix="/usr"
datarootdir="${prefix}/share"
: ${gettext_datadir="${datarootdir}/gettext"}
: ${AUTOM4TE=autom4te}
# func_tmpdir
# creates a temporary directory.
# Sets variable
# - tmp pathname of freshly created temporary directory
func_tmpdir ()
{
# Use the environment variable TMPDIR, falling back to /tmp. This allows
# users to specify a different temporary directory, for example, if their
# /tmp is filled up or too small.
: ${TMPDIR=/tmp}
{
# Use the mktemp program if available. If not available, hide the error
# message.
tmp=`(umask 077 && mktemp -d "$TMPDIR/gtXXXXXX") 2>/dev/null` &&
test -n "$tmp" && test -d "$tmp"
} ||
{
# Use a simple mkdir command. It is guaranteed to fail if the directory
# already exists. $RANDOM is bash specific and expands to empty in shells
# other than bash, ksh and zsh. Its use does not increase security;
# rather, it minimizes the probability of failure in a very cluttered /tmp
# directory.
tmp=$TMPDIR/gt$$-$RANDOM
(umask 077 && mkdir "$tmp")
} ||
{
echo "$0: cannot create a temporary directory in $TMPDIR" >&2
{ (exit 1); exit 1; }
}
}
# Support for relocatability.
func_find_curr_installdir ()
{
# Determine curr_installdir, even taking into account symlinks.
curr_executable="$0"
case "$curr_executable" in
*/* | *\\*) ;;
*) # Need to look in the PATH.
save_IFS="$IFS"; IFS="${PATH_SEPARATOR=':'}"
for dir in $PATH; do
IFS="$save_IFS"
test -z "$dir" && dir=.
for exec_ext in ''; do
if test -f "$dir/$curr_executable$exec_ext"; then
curr_executable="$dir/$curr_executable$exec_ext"
break 2
fi
done
done
IFS="$save_IFS"
;;
esac
# Make absolute.
case "$curr_executable" in
/* | ?:/* | ?:\\*) ;;
*) curr_executable=`pwd`/"$curr_executable" ;;
esac
# Resolve symlinks.
sed_dirname='s,/[^/]*$,,'
sed_linkdest='s,^.* -> \(.*\),\1,p'
while : ; do
lsline=`LC_ALL=C ls -l "$curr_executable"`
case "$lsline" in
*" -> "*)
linkdest=`echo "$lsline" | sed -n -e "$sed_linkdest"`
case "$linkdest" in
/* | ?:/* | ?:\\*) curr_executable="$linkdest" ;;
*) curr_executable=`echo "$curr_executable" | sed -e "$sed_dirname"`/"$linkdest" ;;
esac ;;
*) break ;;
esac
done
curr_installdir=`echo "$curr_executable" | sed -e 's,/[^/]*$,,'`
# Canonicalize.
curr_installdir=`cd "$curr_installdir" && pwd`
}
func_find_prefixes ()
{
# Compute the original/current installation prefixes by stripping the
# trailing directories off the original/current installation directories.
orig_installprefix="$orig_installdir"
curr_installprefix="$curr_installdir"
while true; do
orig_last=`echo "$orig_installprefix" | sed -n -e 's,^.*/\([^/]*\)$,\1,p'`
curr_last=`echo "$curr_installprefix" | sed -n -e 's,^.*/\([^/]*\)$,\1,p'`
if test -z "$orig_last" || test -z "$curr_last"; then
break
fi
if test "$orig_last" != "$curr_last"; then
break
fi
orig_installprefix=`echo "$orig_installprefix" | sed -e 's,/[^/]*$,,'`
curr_installprefix=`echo "$curr_installprefix" | sed -e 's,/[^/]*$,,'`
done
}
if test "no" = yes; then
exec_prefix="${prefix}"
bindir="${exec_prefix}/bin"
orig_installdir="$bindir" # see Makefile.am's *_SCRIPTS variables
func_find_curr_installdir # determine curr_installdir
func_find_prefixes
# Relocate the directory variables that we use.
gettext_datadir=`echo "$gettext_datadir/" | sed -e "s%^${orig_installprefix}/%${curr_installprefix}/%" | sed -e 's,/$,,'`
fi
# func_trace_autoconf macro configure.ac
# traces an Autoconf macro call and outputs the arguments to stdout,
# using autom4te.
func_trace_autoconf ()
{
echo '\
dnl replace macros which may abort autom4te with a no-op variant
m4_pushdef([m4_assert])
m4_pushdef([m4_fatal])
m4_pushdef([m4_warn])
m4_pushdef([m4_errprintn])
m4_pushdef([m4_exit])
m4_pushdef([m4_include])
m4_pushdef([m4_esyscmd])
' \
| "$AUTOM4TE" --no-cache --language=Autoconf-without-aclocal-m4 \
--trace="$1":\$% - "$2" 2>/dev/null
}
# func_trace_sed macro configure.ac
# traces an Autoconf macro call and outputs the arguments to stdout,
# using sed.
func_trace_sed ()
{
sed_extract_arguments='
s,#.*$,,; s,^dnl .*$,,; s, dnl .*$,,;
/'"$1"'(/ {
ta
:a
s/)/)/
tb
s/\\$//
N
ba
:b
s,^.*'"$1"'([[ ]*\([^]"$`\\)]*\).*$,\1,p
}
d'
sed -e "$sed_extract_arguments" "$2"
}
# func_usage
# outputs to stdout the --help usage message.
func_usage ()
{
echo "\
Usage: autopoint [OPTION]...
Copies standard gettext infrastructure files into a source package.
Options:
--help print this help and exit
--version print version information and exit
-f, --force force overwriting of files that already exist
-n, --dry-run print modifications but don't perform them"
echo "\
-V version copy the infrastructure of the specified gettext version
(dangerous)"
echo "
Report bugs to <bug-gnu-gettext@gnu.org>."
}
# func_version
# outputs to stdout the --version message.
func_version ()
{
echo "$progname (GNU $package) $version"
echo "Uses a versions archive in dirxz format."
echo "Copyright (C) 2002-2013 Free Software Foundation, Inc.
License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
This is free software: you are free to change and redistribute it.
There is NO WARRANTY, to the extent permitted by law."
echo "Written by" "Bruno Haible"
}
# func_fatal_error message
# outputs to stderr a fatal error message, and terminates the program.
func_fatal_error ()
{
echo "autopoint: *** $1" 1>&2
echo "autopoint: *** Stop." 1>&2
exit 1
}
# Nuisances.
(unset CDPATH) >/dev/null 2>&1 && unset CDPATH
# Unset more variables known to interfere with behavior of common tools.
CLICOLOR_FORCE= GREP_OPTIONS=
unset CLICOLOR_FORCE GREP_OPTIONS
# Command-line option processing.
# Removes the OPTIONS from the arguments. Sets the variables:
# - force yes if --force was given, empty otherwise
# - ver gettext version if -V was given, empty otherwise
# - doit false if --dry-run was given, : otherwise
{
force=
ver=
doit=:
while test $# -gt 0; do
case "$1" in
-n | --dry-run | --dry-ru | --dry-r | --dry- | --dry | --dr | --d )
shift
doit=false ;;
-f | --force | --forc | --for | --fo | --f )
shift
force=yes ;;
--help | --hel | --he | --h )
func_usage; exit 0 ;;
-V ) # Some people put a space between -V and the version number.
shift
if test $# = 0; then
func_usage 1>&2
exit 1
fi
ver=$1;
shift ;;
-V*) # Some people omit the space between -V and the version number.
ver=`echo "X$1" | sed -e 's/^X-V//'`
shift ;;
--version | --versio | --versi | --vers | --ver | --ve | --v )
func_version
exit 0 ;;
-- ) # Stop option prcessing
shift; break ;;
-* )
echo "autopoint: unknown option $1" 1>&2
echo "Try 'autopoint --help' for more information." 1>&2
exit 1 ;;
* )
break ;;
esac
done
}
# Command-line argument processing.
# Analyzes the remaining arguments.
{
if test $# -gt 0; then
func_usage 1>&2
exit 1
fi
}
srcdir=`pwd`
# The current directory is now $srcdir.
# Check integrity of package: A configure.in/ac must be present. Sets variable
# - configure_in name of configure.in/ac file.
if test -f configure.in; then
configure_in=configure.in
else
if test -f configure.ac; then
configure_in=configure.ac
else
# KDE specific convention: configure.in.in
if test -f configure.in.in; then
configure_in=configure.in.in
else
func_fatal_error "Missing configure.in or configure.ac, please cd to your package first."
fi
fi
fi
# Select the method for Autoconf macro tracing. func_trace_autoconf
# is more accurate than func_trace_sed, but it only works with
# autoconf >= 2.69.
if echo "AC_PREREQ([2.69])" \
| "$AUTOM4TE" --no-cache --language=Autoconf-without-aclocal-m4 - 2>&1; then
func_trace=func_trace_autoconf
else
func_trace=func_trace_sed
fi
# func_version_prereq required_version version
# compares the required version and the latest archive version.
func_version_prereq ()
{
req="$1"
ver="$2"
echo "m4_if(m4_version_compare([$ver], [$req]), [-1], [m4_exit([1])])" \
| "$AUTOM4TE" --language=M4sugar 2>&1 >/dev/null
}
# If AM_GNU_GETTEXT_REQUIRE_VERSION is used and archive_version is newer than
# that, use archive_version.
xreq=`func_trace_sed AM_GNU_GETTEXT_REQUIRE_VERSION "$configure_in"`
# Need to use func_trace_sed instead of $func_trace, since
# AM_GNU_GETTEXT_VERSION is not a standard Autoconf trace.
xver=`func_trace_sed AM_GNU_GETTEXT_VERSION "$configure_in"`
# Prefer AM_GNU_GETTEXT_REQUIRE_VERSION over AM_GNU_GETTEXT_VERSION if both are
# specified.
if test -n "$xreq" && test -n "$xver"; then
echo "autopoint: using AM_GNU_GETTEXT_REQUIRE_VERSION instead of AM_GNU_GETTEXT_VERSION"
fi
if test -n "$xreq"; then
if func_version_prereq "$xreq" "$archive_version"; then
ver="$archive_version"
else
func_fatal_error "gettext version $xreq or newer is required"
fi
else
if test -z "$xver" && test -f intl/VERSION; then
xver=`cat intl/VERSION | LC_ALL=C sed -n -e 's/^.*gettext-\([-+_.0-9A-Za-z]*\).*$/\1/p'`
fi
# Check whether the -V option and the version number in configure.in match.
# At least one of the two must be given. If both are given, they must agree.
if test -n "$xver"; then
if test -n "$ver"; then
if test "X$ver" != "X$xver"; then
echo "autopoint: warning: Version mismatch: specified -V $ver but the package uses gettext version $xver. Forcibly upgrading to $ver" 1>&2
fi
else
ver="$xver"
fi
fi
fi
if test -z "$ver"; then
func_fatal_error "Missing version: please specify in $configure_in through a line 'AM_GNU_GETTEXT_VERSION(x.yy.zz)' the gettext version the package is using"
fi
# Check whether the version number is supported.
case "$ver" in
0.10.35 | 0.10.36 | 0.10.37 | 0.10.38 | 0.10.39 | 0.10.40 | \
0.11 | 0.11.1 | 0.11.2 | 0.11.3 | 0.11.4 | 0.11.5 | \
0.12 | 0.12.1 | \
0.13 | 0.13.1 | \
0.14 | 0.14.1 | 0.14.2 | 0.14.3 | 0.14.4 | 0.14.5 | 0.14.6 | \
0.15 | \
0.16 | 0.16.1 | \
0.17 | \
0.18 | 0.18.1 | 0.18.2 | 0.18.3 | \
0.19 | 0.19.1 | 0.19.2 | 0.19.3 | 0.19.4 | 0.19.5 | 0.19.6 | 0.19.7 | 0.19.8 )
;;
*)
func_fatal_error "The AM_GNU_GETTEXT_VERSION declaration in your $configure_in
file requires the infrastructure from gettext-$ver but this version
is older. Please upgrade to gettext-$ver or newer."
;;
esac
# Check in which directory config.rpath, mkinstalldirs etc. belong.
auxdir=`"$func_trace" AC_CONFIG_AUX_DIR "$configure_in"`
if test -n "$auxdir"; then
auxdir="$auxdir/"
fi
# Check in which directory the *.m4 macros belong.
macrodirs=`"$func_trace" AC_CONFIG_MACRO_DIR_TRACE "$configure_in"`
if test -z "$macrodirs"; then
macrodirs=`"$func_trace" AC_CONFIG_MACRO_DIR "$configure_in"`
fi
for arg in $macrodirs; do
m4dir="$arg"
break
done
if test -z "$m4dir" && test -f Makefile.am; then
# A package using automake.
# Extract the macro directory name from Makefile.am.
aclocal_amflags=`grep '^ACLOCAL_AMFLAGS[ ]*=' Makefile.am | sed -e 's/^ACLOCAL_AMFLAGS[ ]*=\(.*\)$/\1/'`
m4dir_is_next=
for arg in $aclocal_amflags; do
if test -n "$m4dir_is_next"; then
m4dir="$arg"
break
else
if test "X$arg" = "X-I"; then
m4dir_is_next=yes
else
m4dir_is_next=
fi
fi
done
fi
if test -z "$m4dir"; then
m4dir=m4
fi
# Check whether to omit the intl/ directory.
omitintl=
# Need to use func_trace_sed instead of $func_trace, since
# AM_GNU_GETTEXT is not a standard Autoconf trace.
xargs=`func_trace_sed AM_GNU_GETTEXT "$configure_in"`
save_IFS="$IFS"; IFS=:
for arg in $xargs; do
if test 'external' = "$arg"; then
omitintl=yes
break
fi
done
IFS="$save_IFS"
# Check in which directory or directories the po/* infrastructure belongs.
configfiles=`"$func_trace" AC_CONFIG_FILES "$configure_in"`
# PO directories have a Makefile.in generated from Makefile.in.in.
# Treat a directory as a PO directory if and only if it has a
# POTFILES.in file. This allows packages to have multiple PO
# directories under different names or in different locations.
sed_remove_Makefile_in='s,/Makefile\.in$,,'
podirs=`for f in $configfiles; do case "$f" in */Makefile.in) echo $f;; esac; done | sed -e "$sed_remove_Makefile_in"`
if test -z "$podirs"; then
# If we cannot get the list of PO directories from configure.ac, assume the
# common default.
podirs="po"
fi
# Set up a temporary checkout directory.
# Set variables
# - work_dir directory containing the temporary checkout
work_dir=tmpwrk$$
mkdir "$work_dir" || {
if test -d "$work_dir"; then
func_fatal_error "directory $work_dir already exists"
else
func_fatal_error "cannot create directory $work_dir"
fi
}
# We support three archive formats.
#
# Format | Size (KiB) for gettext-0.17 | Extra tools needed |
# -------+-----------------------------+--------------------+
# dir | 3000 | -- |
# cvs | 356 | cvs |
# git | 484 | git |
# -------+-----------------------------+--------------------+
case "dirxz" in
dir*)
# The archive of different versions is very large (unless xz compression is
# used), but using it does not require special tools.
case "dirxz" in
dirgz) gzip -d -c < "$gettext_datadir/archive.dir.tar.gz" ;;
dirbz2) bzip2 -d -c < "$gettext_datadir/archive.dir.tar.bz2" ;;
dirxz) xz -d -c < "$gettext_datadir/archive.dir.tar.xz" ;;
esac \
| (cd "$work_dir" && tar xf - "gettext-$ver")
if test `find "$work_dir" -type f -print | wc -l` = 0; then
rm -rf "$work_dir"
func_fatal_error "infrastructure files for version $ver not found; this is autopoint from GNU $package $version"
fi
mv "$work_dir/gettext-$ver" "$work_dir/archive"
;;
cvs)
# We distributed the many different versions of the files in a CVS
# repository. This guaranteed a good compression rate:
#
# Including version size in KB of
# "du autopoint-files/archive"
# 0.10.35 240
# 0.10.36 428
# 0.10.37 436
# 0.10.38 488
# 0.10.39 500
# 0.10.40 528
# 0.11 720
# 0.11.1 740
# 0.11.2 748
# 0.11.3 804
# 0.11.4 864
# 0.11.5 880
# 0.12 1032
# 0.12.1 1032
# 0.13 1220
# 0.13.1 1236
# 0.14 1296
# 0.14.1 1300
# 0.14.2 1420
# 0.14.3 1428
# 0.14.4 1464
# 0.14.5 1508
# 0.14.6 1580
# 0.15 1760
# 0.16 1808
# 0.16.1 1812
# 0.17 2128
# 0.18 2656
#
# The requirement that the user must have the CVS program available is not
# a severe restrictions, because most of the people who use autopoint are
# users of CVS.
#
# But the CVS format is now deprecated, because "cvs init" does not work in
# all circumstances
# (see <http://lists.gnu.org/archive/html/bug-cvs/2010-05/msg00003.html>)
# and we are not allowed to distribute the cvs infrastructure files
# ourselves
# (see <http://lists.gnu.org/archive/html/bug-cvs/2010-06/msg00011.html>).
#
# Check availability of the CVS program.
(cvs -v) >/dev/null 2>/dev/null || func_fatal_error "cvs program not found"
# Set up a temporary CVS repository.
# We need the temporary CVS repository because any checkout needs write
# access to the CVSROOT/history file, so it cannot be under $gettext_datadir.
# We need the temporary checkout directory because when --force was not
# given, we need to compare the existing files with the checked out ones.
# Set variables
# - cvs_dir directory containing the temporary repository
cvs_dir=tmpcvs$$
# Use an umask of 077, to avoid attacks that work by overwriting files in
# the "$CVSROOT"/CVSROOT directory.
(umask 077 && mkdir "$cvs_dir") || {
if test -d "$cvs_dir"; then
func_fatal_error "directory $cvs_dir already exists"
else
func_fatal_error "cannot create directory $cvs_dir"
fi
}
CVSROOT="$srcdir/$cvs_dir"
unset CVS_CLIENT_LOG
unset CVS_CLIENT_PORT
unset CVS_IGNORE_REMOTE_ROOT
unset CVS_LOCAL_BRANCH_NUM
unset CVS_NOBASES
unset CVS_PASSFILE
unset CVS_PASSWORD
unset CVS_PROXY_PORT
unset CVS_RCMD_PORT
unset CVS_RSH
unset CVS_SERVER
unset CVS_SERVER_SLEEP
CVS_SIGN_COMMITS=
export CVS_SIGN_COMMITS
unset CVS_SSH
unset CVS_VERIFY_CHECKOUTS
unset CVS_VERIFY_TEMPLATE
unset CVSIGNORE
unset CVSREAD
unset CVSREADONLYFS
unset CVSUMASK
unset CVSWRAPPERS
# Need to pass -d "$CVSROOT", because there may be a CVS directory in the
# current directory.
cvs -d "$CVSROOT" init
gzip -d -c < "$gettext_datadir/archive.cvs.tar.gz" | (cd "$cvs_dir" && tar xf -)
cd "$work_dir"
cvsver=gettext-`echo "$ver" | sed -e 's/\./_/g'`
(cvs -d "$CVSROOT" checkout -r"$cvsver" archive > /dev/null) 2>&1 | grep -v '^cvs checkout: Updating'
find archive -name CVS -type d -print | xargs rm -rf
cd ..
rm -rf "$cvs_dir"
# Check that really all CVS directories are gone, otherwise we would overwrite
# the contents of the user's CVS directories.
if test `find $work_dir/archive -name CVS -type d -print | wc -l` != 0; then
rm -rf "$work_dir"
func_fatal_error "failed to remove all CVS subdirectories"
fi
if test `find $work_dir/archive -type f -print | wc -l` = 0; then
rm -rf "$work_dir"
func_fatal_error "infrastructure files for version $ver not found; this is autopoint from GNU $package $version"
fi
;;
git)
# Check availability of the git program.
(git --version) >/dev/null 2>/dev/null || func_fatal_error "git program not found"
mkdir "$work_dir/archive"
gzip -d -c < "$gettext_datadir/archive.git.tar.gz" | (cd "$work_dir/archive" && tar xf -)
(cd "$work_dir/archive" && git checkout -q "gettext-$ver") || {
rm -rf "$work_dir"
func_fatal_error "infrastructure files for version $ver not found; this is autopoint from GNU $package $version"
}
(cd "$work_dir/archive" && rm -rf .git .gitignore)
;;
esac
# func_destfile file
# determines the destination file, relative to the package's top level
# directory, for a given file name, relative to archive.
# Sets variables
# - destfile relative destination file name, or
# empty if the file shall be omitted
# - sharedowner yes if the file is not only owned by GNU gettext but may
# be installed by automake or other tools, otherwise empty
# - allpodirs yes if the file is to be installed in every dir in $podirs
func_destfile ()
{
# There are five categories of files:
# ABOUT_NLS -> top level directory
# config.rpath mkinstalldirs -> $auxdir
# m4/* -> $m4dir/
# intl/* -> intl/
# po/* ->
sharedowner=
allpodirs=
case `echo "$1" | sed -e 's,[^/]*$,,'` in
"" )
case "$1" in
config.rpath ) destfile="$auxdir$1" ;;
mkinstalldirs ) destfile="$auxdir$1" sharedowner=yes ;;
* ) destfile="$1" ;;
esac
;;
m4/ ) destfile=`echo "$1" | sed -e "s,^m4/,$m4dir/,"` ;;
intl/ ) if test -n "$omitintl"; then destfile=""; else destfile="$1"; fi ;;
po/ ) destfile=`echo "$1" | sed -e "s,^po/,,"` allpodirs=yes ;;
* ) destfile="$1" ;;
esac
}
# func_compare existingfile gettextfile
# compares the existing file and the file from gettext, and decides whether the
# existing file should be overwritten with the file from gettext. Returns 0 if
# it should be overwritten, or 1 if it should be skipped.
sed_extract_serial='s/^#.* serial \([^ ]*\).*/\1/p
1q'
func_compare ()
{
if cmp -s "$1" "$2"; then
false
else
case "$2" in
*.m4)
# For interoperability with gnulib. gnulib often has newer versions of
# the *.m4 files than the latest gettext release. Don't overwrite a
# newer version from gnulib with an older version from the gettext
# release. The version can be retrieved from the first line, which
# looks like this: # file.m4 serial NN ...
existing_serial=`sed -n -e "$sed_extract_serial" < "$1"`
gettext_serial=`sed -n -e "$sed_extract_serial" < "$2"`
if test -n "$existing_serial" && test -n "$gettext_serial" \
&& test "$existing_serial" -ge "$gettext_serial" 2> /dev/null; then
false
else
true
fi
;;
*)
true
;;
esac
fi
}
# If some files have been locally modified and we have not been requested
# to overwrite them, then bail out. This is better than leaving a source
# package around where half of the files are locally modified and half are
# original - too great risk of version mismatch.
if test -z "$force"; then
mismatch=
func_tmpdir
mismatchfile="$tmp"/autopoint.diff
for file in `find "$work_dir/archive" -type f -print | sed -e "s,^$work_dir/archive/,," | LC_ALL=C sort`; do
func_destfile "$file"
if test -n "$destfile"; then
func_compare_to_destfile ()
{
finaldestfile="$1"
if test -f "$finaldestfile"; then
if func_compare "$finaldestfile" "$work_dir/archive/$file"; then
if test -n "$sharedowner"; then
echo "autopoint: warning: File $finaldestfile has been locally modified." 1>&2
else
echo "autopoint: File $finaldestfile has been locally modified." 1>&2
mismatch=yes
diff -c "$work_dir/archive/$file" "$finaldestfile" | sed -e "1s,$work_dir/archive/,," >> "$mismatchfile"
fi
fi
fi
}
if test -n "$allpodirs"; then
for dir in $podirs; do
func_compare_to_destfile "$dir/$destfile"
done
else
func_compare_to_destfile "$destfile"
fi
fi
done
if test -n "$mismatch"; then
rm -rf "$work_dir"
func_fatal_error "Some files have been locally modified. Not overwriting them because --force has not been specified. For your convenience, you find the local modifications in the file '$mismatchfile'."
fi
rm -rf "$tmp"
fi
# func_mkdir_for to
# ensures the directory that would the given file exists.
# 'to' is a relative pathname, relative to the current directory.
func_mkdir_for ()
{
base=`echo "$1" | sed -e 's,/[^/]*$,,'`
if test "X$base" != "X$1" && test -n "$base"; then
func_mkdir_for "$base"
# Recompute base. It was clobbered by the recursive call.
base=`echo "$1" | sed -e 's,/[^/]*$,,'`
test -d "$base" || { echo "Creating directory $base"; mkdir "$base"; }
fi
}
# func_copy from to
# copies a file.
# 'from' is a relative pathname, relative to the current directory.
# 'to' is a relative pathname, relative to the current directory.
func_copy ()
{
if $doit; then
func_mkdir_for "$2"
rm -f "$2"
echo "Copying file $2"
cp "$1" "$2"
else
echo "Copy file $2"
fi
}
# func_backup to
# makes a backup of a file that is about to be overwritten or replaced.
# 'to' is a relative pathname, relative to the current directory.
func_backup ()
{
if $doit; then
if test -f "$1"; then
rm -f "$1~"
cp -p "$1" "$1~"
fi
fi
}
# Now copy the files.
for file in `find "$work_dir/archive" -type f -print | sed -e "s,^$work_dir/archive/,," | LC_ALL=C sort`; do
func_destfile "$file"
if test -n "$destfile"; then
func_copy_to_destfile ()
{
finaldestfile="$1"
mustcopy=
if test -f "$finaldestfile"; then
if func_compare "$finaldestfile" "$work_dir/archive/$file"; then
if test -n "$force"; then
# Overwrite locally modified file.
mustcopy=yes
fi
# If --force is not specified, don't overwrite locally modified files
# for which GNU gettext is a shared owner.
fi
else
mustcopy=yes
fi
if test -n "$mustcopy"; then
func_backup "$finaldestfile"
func_copy "$work_dir/archive/$file" "$finaldestfile"
fi
}
if test -n "$allpodirs"; then
for dir in $podirs; do
func_copy_to_destfile "$dir/$destfile"
done
else
func_copy_to_destfile "$destfile"
fi
fi
done
# That's it.
rm -rf "$work_dir"
exit 0
Git/usr/bin/awk.exe
BIN
View File
Binary file not shown.
Git/usr/bin/b2sum.exe
BIN
View File
Binary file not shown.
Git/usr/bin/backup
+257
View File
@@ -0,0 +1,257 @@
#! /bin/sh
# Make backups.
# Copyright 2004-2006, 2013 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.31"
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 buch 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
Git/usr/bin/base32.exe
BIN
View File
Binary file not shown.
Git/usr/bin/base64.exe
BIN
View File
Binary file not shown.
Git/usr/bin/basename.exe
BIN
View File
Binary file not shown.
Git/usr/bin/bash.exe
BIN
View File
Binary file not shown.
Git/usr/bin/bashbug
+272
View File
@@ -0,0 +1,272 @@
#!/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@cwru.edu and, optionally, to bash-testers@cwru.edu.
# Other versions send mail to bug-bash@gnu.org.
#
# Copyright (C) 1996-2004 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=" -DPROGRAM='bash.exe' -DCONF_HOSTTYPE='x86_64' -DCONF_OSTYPE='msys' -DCONF_MACHTYPE='x86_64-pc-msys' -DCONF_VENDOR='pc' -DLOCALEDIR='/usr/share/locale' -DPACKAGE='bash' -DSHELL -DHAVE_CONFIG_H -DRECYCLES_PIDS -I. -I. -I./include -I./lib -DWORDEXP_OPTION -Wno-discarded-qualifiers -march=x86-64 -mtune=generic -O2 -pipe -Wno-parentheses -Wno-format-security -D_STATIC_BUILD -g"
RELEASE="4.4"
PATCHLEVEL="23"
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@cwru.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/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
Git/usr/bin/bunzip2.exe
BIN
View File
Binary file not shown.
Git/usr/bin/bzcat.exe
BIN
View File
Binary file not shown.
Git/usr/bin/bzcmp
+76
View File
@@ -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
tmp=`mktemp ${TMPDIR:-/tmp}/bzdiff.XXXXXXXXXX` || {
echo 'cannot create a temporary file' >&2
exit 1
}
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$||'`
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
exit "$STAT"
else
echo "Usage: $prog [${comp}_options] file [file]"
exit 1
fi
Git/usr/bin/bzdiff
+76
View File
@@ -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
tmp=`mktemp ${TMPDIR:-/tmp}/bzdiff.XXXXXXXXXX` || {
echo 'cannot create a temporary file' >&2
exit 1
}
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$||'`
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
exit "$STAT"
else
echo "Usage: $prog [${comp}_options] file [file]"
exit 1
fi
Git/usr/bin/bzegrep
+132
View File
@@ -0,0 +1,132 @@
#!/bin/sh
# bzgrep -- a wrapper around a grep program that decompresses files as needed
# Adapted from zgrep of the Debian gzip package by Anibal Monsalve Salazar.
# Adapted from a version sent by Charles Levert <charles@comm.polymtl.ca>
# Copyright (C) 1998, 2001, 2002 Free Software Foundation
# Copyright (C) 1993 Jean-loup Gailly
# 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 2, 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., 59 Temple Place - Suite 330, Boston, MA
# 02111-1307, USA.
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=""
after_dash_dash=""
files_with_matches=0
files_without_matches=0
no_filename=0
with_filename=0
while test $# -ne 0; do
case "$after_dash_dash$1" in
--d* | --rec*) echo >&2 "$0: $1: option not supported"; exit 2;;
--files-with-*) files_with_matches=1;;
--files-witho*) files_without_matches=1;;
--no-f*) no_filename=1;;
--wi*) with_filename=1;;
--*) ;;
-*)
case "$1" in
-*[dr]*) echo >&2 "$0: $1: option not supported"; exit 2;;
esac
case "$1" in
-*H*) with_filename=1;;
esac
case "$1" in
-*h*) no_filename=1;;
esac
case "$1" in
-*L*) files_without_matches=1;;
esac
case "$1" in
-*l*) files_with_matches=1;;
esac;;
esac
case "$after_dash_dash$1" in
-[ef]) opt="$opt $1"; shift; pat="$1"
if test "$grep" = grep; then # grep is buggy with -e on SVR4
grep=egrep
fi;;
-[ABCdm])opt="$opt $1 $2"; shift;;
--) opt="$opt $1"; after_dash_dash=1;;
-*) 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 2
fi
if test $# -eq 0; then
bzip2 -cdfq | $grep $opt "$pat"
exit $?
fi
res=0
for i do
bzip2 -cdfq -- "$i" |
if test $files_with_matches -eq 1; then
$grep $opt "$pat" > /dev/null && printf "%s\n" "$i"
elif test $files_without_matches -eq 1; then
$grep $opt "$pat" > /dev/null || printf "%s\n" "$i"
elif test $with_filename -eq 0 && { test $# -eq 1 || test $no_filename -eq 1; }; then
$grep $opt "$pat"
else
i=$(echo "$i" | sed -e 's/[\\|&]/\\&/g')
if test $with_filename -eq 1; then
sed_script="s|^[^:]*:|${i}:|"
else
sed_script="s|^|${i}:|"
fi
# Hack adapted from GPLed code at
# http://home.comcast.net/~j.p.h/cus-faq-2
# Has the same effect as the following two lines of bash:
#
# $grep $opt "$pat" | sed "$sed_script"
# exit ${PIPESTATUS[0]}
#
# Inside the `...`, fd4 goes to the pipe whose other end is read
# and passed to eval; fd1 is the normal standard output
# preserved the line before with exec 3>&1
exec 3>&1
eval `
exec 4>&1 >&3 3>&-
{
$grep $opt "$pat" 4>&-; echo "r=$?;" >&4
} | sed "$sed_script"
`
exit $r
fi
r=$?
test $res -lt $r && res=$r
done
exit $res
Git/usr/bin/bzfgrep
+132
View File
@@ -0,0 +1,132 @@
#!/bin/sh
# bzgrep -- a wrapper around a grep program that decompresses files as needed
# Adapted from zgrep of the Debian gzip package by Anibal Monsalve Salazar.
# Adapted from a version sent by Charles Levert <charles@comm.polymtl.ca>
# Copyright (C) 1998, 2001, 2002 Free Software Foundation
# Copyright (C) 1993 Jean-loup Gailly
# 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 2, 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., 59 Temple Place - Suite 330, Boston, MA
# 02111-1307, USA.
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=""
after_dash_dash=""
files_with_matches=0
files_without_matches=0
no_filename=0
with_filename=0
while test $# -ne 0; do
case "$after_dash_dash$1" in
--d* | --rec*) echo >&2 "$0: $1: option not supported"; exit 2;;
--files-with-*) files_with_matches=1;;
--files-witho*) files_without_matches=1;;
--no-f*) no_filename=1;;
--wi*) with_filename=1;;
--*) ;;
-*)
case "$1" in
-*[dr]*) echo >&2 "$0: $1: option not supported"; exit 2;;
esac
case "$1" in
-*H*) with_filename=1;;
esac
case "$1" in
-*h*) no_filename=1;;
esac
case "$1" in
-*L*) files_without_matches=1;;
esac
case "$1" in
-*l*) files_with_matches=1;;
esac;;
esac
case "$after_dash_dash$1" in
-[ef]) opt="$opt $1"; shift; pat="$1"
if test "$grep" = grep; then # grep is buggy with -e on SVR4
grep=egrep
fi;;
-[ABCdm])opt="$opt $1 $2"; shift;;
--) opt="$opt $1"; after_dash_dash=1;;
-*) 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 2
fi
if test $# -eq 0; then
bzip2 -cdfq | $grep $opt "$pat"
exit $?
fi
res=0
for i do
bzip2 -cdfq -- "$i" |
if test $files_with_matches -eq 1; then
$grep $opt "$pat" > /dev/null && printf "%s\n" "$i"
elif test $files_without_matches -eq 1; then
$grep $opt "$pat" > /dev/null || printf "%s\n" "$i"
elif test $with_filename -eq 0 && { test $# -eq 1 || test $no_filename -eq 1; }; then
$grep $opt "$pat"
else
i=$(echo "$i" | sed -e 's/[\\|&]/\\&/g')
if test $with_filename -eq 1; then
sed_script="s|^[^:]*:|${i}:|"
else
sed_script="s|^|${i}:|"
fi
# Hack adapted from GPLed code at
# http://home.comcast.net/~j.p.h/cus-faq-2
# Has the same effect as the following two lines of bash:
#
# $grep $opt "$pat" | sed "$sed_script"
# exit ${PIPESTATUS[0]}
#
# Inside the `...`, fd4 goes to the pipe whose other end is read
# and passed to eval; fd1 is the normal standard output
# preserved the line before with exec 3>&1
exec 3>&1
eval `
exec 4>&1 >&3 3>&-
{
$grep $opt "$pat" 4>&-; echo "r=$?;" >&4
} | sed "$sed_script"
`
exit $r
fi
r=$?
test $res -lt $r && res=$r
done
exit $res
Git/usr/bin/bzgrep
+132
View File
@@ -0,0 +1,132 @@
#!/bin/sh
# bzgrep -- a wrapper around a grep program that decompresses files as needed
# Adapted from zgrep of the Debian gzip package by Anibal Monsalve Salazar.
# Adapted from a version sent by Charles Levert <charles@comm.polymtl.ca>
# Copyright (C) 1998, 2001, 2002 Free Software Foundation
# Copyright (C) 1993 Jean-loup Gailly
# 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 2, 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., 59 Temple Place - Suite 330, Boston, MA
# 02111-1307, USA.
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=""
after_dash_dash=""
files_with_matches=0
files_without_matches=0
no_filename=0
with_filename=0
while test $# -ne 0; do
case "$after_dash_dash$1" in
--d* | --rec*) echo >&2 "$0: $1: option not supported"; exit 2;;
--files-with-*) files_with_matches=1;;
--files-witho*) files_without_matches=1;;
--no-f*) no_filename=1;;
--wi*) with_filename=1;;
--*) ;;
-*)
case "$1" in
-*[dr]*) echo >&2 "$0: $1: option not supported"; exit 2;;
esac
case "$1" in
-*H*) with_filename=1;;
esac
case "$1" in
-*h*) no_filename=1;;
esac
case "$1" in
-*L*) files_without_matches=1;;
esac
case "$1" in
-*l*) files_with_matches=1;;
esac;;
esac
case "$after_dash_dash$1" in
-[ef]) opt="$opt $1"; shift; pat="$1"
if test "$grep" = grep; then # grep is buggy with -e on SVR4
grep=egrep
fi;;
-[ABCdm])opt="$opt $1 $2"; shift;;
--) opt="$opt $1"; after_dash_dash=1;;
-*) 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 2
fi
if test $# -eq 0; then
bzip2 -cdfq | $grep $opt "$pat"
exit $?
fi
res=0
for i do
bzip2 -cdfq -- "$i" |
if test $files_with_matches -eq 1; then
$grep $opt "$pat" > /dev/null && printf "%s\n" "$i"
elif test $files_without_matches -eq 1; then
$grep $opt "$pat" > /dev/null || printf "%s\n" "$i"
elif test $with_filename -eq 0 && { test $# -eq 1 || test $no_filename -eq 1; }; then
$grep $opt "$pat"
else
i=$(echo "$i" | sed -e 's/[\\|&]/\\&/g')
if test $with_filename -eq 1; then
sed_script="s|^[^:]*:|${i}:|"
else
sed_script="s|^|${i}:|"
fi
# Hack adapted from GPLed code at
# http://home.comcast.net/~j.p.h/cus-faq-2
# Has the same effect as the following two lines of bash:
#
# $grep $opt "$pat" | sed "$sed_script"
# exit ${PIPESTATUS[0]}
#
# Inside the `...`, fd4 goes to the pipe whose other end is read
# and passed to eval; fd1 is the normal standard output
# preserved the line before with exec 3>&1
exec 3>&1
eval `
exec 4>&1 >&3 3>&-
{
$grep $opt "$pat" 4>&-; echo "r=$?;" >&4
} | sed "$sed_script"
`
exit $r
fi
r=$?
test $res -lt $r && res=$r
done
exit $res
Git/usr/bin/bzip2.exe
BIN
View File
Binary file not shown.
Git/usr/bin/bzip2recover.exe
BIN
View File
Binary file not shown.
Git/usr/bin/bzless
+61
View File
@@ -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
Git/usr/bin/bzmore
+61
View File
@@ -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
Git/usr/bin/c_rehash
+233
View File
@@ -0,0 +1,233 @@
#!/usr/bin/env perl
# WARNING: do not edit!
# Generated by Makefile from tools/c_rehash.in
# Copyright 1999-2018 The OpenSSL Project Authors. All Rights Reserved.
#
# Licensed under the OpenSSL license (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 hash_dir {
my %hashlist;
print "Doing $_[0]\n";
chdir $_[0];
opendir(DIR, ".");
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 $_" 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);
}
}
sub check_file {
my ($is_cert, $is_crl) = (0,0);
my $fname = $_[0];
open 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);
}
# 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 {
my $fname = $_[0];
$fname =~ s/'/'\\''/g;
my ($hash, $fprint) = `"$openssl" x509 $x509hash -fingerprint -noout -in "$fname"`;
chomp $hash;
chomp $fprint;
$fprint =~ s/^.*=//;
$fprint =~ tr/://d;
my $suffix = 0;
# Search for an unused hash filename
while(exists $hashlist{"$hash.$suffix"}) {
# Hash matches: if fingerprint matches its a duplicate cert
if ($hashlist{"$hash.$suffix"} eq $fprint) {
print STDERR "WARNING: Skipping duplicate certificate $fname\n";
return;
}
$suffix++;
}
$hash .= ".$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;
if (open($in, "<", $fname)) {
if (open($out,">", $hash)) {
print $out $_ while (<$in>);
close $out;
} else {
warn "can't open $hash for write, $!";
}
close $in;
} else {
warn "can't open $fname for read, $!";
}
}
$hashlist{$hash} = $fprint;
}
# Same as above except for a CRL. CRL links are of the form <hash>.r<n>
sub link_hash_crl {
my $fname = $_[0];
$fname =~ s/'/'\\''/g;
my ($hash, $fprint) = `"$openssl" crl $crlhash -fingerprint -noout -in '$fname'`;
chomp $hash;
chomp $fprint;
$fprint =~ s/^.*=//;
$fprint =~ tr/://d;
my $suffix = 0;
# Search for an unused hash filename
while(exists $hashlist{"$hash.r$suffix"}) {
# Hash matches: if fingerprint matches its a duplicate cert
if ($hashlist{"$hash.r$suffix"} eq $fprint) {
print STDERR "WARNING: Skipping duplicate CRL $fname\n";
return;
}
$suffix++;
}
$hash .= ".r$suffix";
if ($symlink_exists) {
print "link $fname -> $hash\n" if $verbose;
symlink $fname, $hash || warn "Can't symlink, $!";
} else {
print "cp $fname -> $hash\n" if $verbose;
system ("cp", $fname, $hash);
warn "Can't copy, $!" if ($? >> 8) != 0;
}
$hashlist{$hash} = $fprint;
}
Git/usr/bin/captoinfo.exe
BIN
View File
Binary file not shown.
Git/usr/bin/cat.exe
BIN
View File
Binary file not shown.
Git/usr/bin/chcon.exe
BIN
View File
Binary file not shown.
Git/usr/bin/chgrp.exe
BIN
View File
Binary file not shown.
Git/usr/bin/chmod.exe
BIN
View File
Binary file not shown.
Git/usr/bin/chown.exe
BIN
View File
Binary file not shown.
Git/usr/bin/chroot.exe
BIN
View File
Binary file not shown.
Git/usr/bin/cksum.exe
BIN
View File
Binary file not shown.
Git/usr/bin/clear.exe
BIN
View File
Binary file not shown.
Git/usr/bin/cmp.exe
BIN
View File
Binary file not shown.
Git/usr/bin/column.exe
BIN
View File
Binary file not shown.
Git/usr/bin/comm.exe
BIN
View File
Binary file not shown.
Git/usr/bin/core_perl/corelist
+492
View File
@@ -0,0 +1,492 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_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 --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 --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 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} );
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);
my $new = numify_version($new_ver);
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{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 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
Git/usr/bin/core_perl/cpan
+347
View File
@@ -0,0 +1,347 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_shell;
#!/usr/local/bin/perl
BEGIN { pop @INC if $INC[-1] eq '.' }
use strict;
use vars qw($VERSION);
use App::Cpan '1.64';
$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 Concensus: L<https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/lancaster-consensus.md>
Oslo Concensus: 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<PERL5OPTS>, 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;
Git/usr/bin/core_perl/enc2xs
+1499
View File
File diff suppressed because it is too large Load Diff
Git/usr/bin/core_perl/encguess
+149
View File
@@ -0,0 +1,149 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_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.2 2016/08/04 03:15:58 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,
seperated 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
Git/usr/bin/core_perl/h2ph
+988
View File
@@ -0,0 +1,988 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_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
Git/usr/bin/core_perl/h2xs
+2207
View File
File diff suppressed because it is too large Load Diff
Git/usr/bin/core_perl/instmodsh
+196
View File
@@ -0,0 +1,196 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_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();
###############################################################################
Git/usr/bin/core_perl/json_pp
+209
View File
@@ -0,0 +1,209 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_shell;
#!/usr/bin/perl
BEGIN { pop @INC if $INC[-1] eq '.' }
use strict;
use Getopt::Long;
use JSON::PP ();
my $VERSION = '1.00';
# 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
);
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]\n";
if ( $version ) {
print "$VERSION\n";
exit;
}
$json_opt = '' if $json_opt eq '-';
my @json_opt = grep { $allow_json_opt{ $_ } or die "'$_' is not a valid json option" } split/,/, $json_opt;
my %F = (
'json' => sub {
my $json = JSON::PP->new;
$json->$_() for @json_opt;
$json->decode( $_ );
},
'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;
$json->$_() for @json_opt;
$json->encode( $_ );
},
'dumper' => sub {
require Data::Dumper;
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 $/;
$_ = <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_json]
=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
=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
Git/usr/bin/core_perl/libnetcfg
+722
View File
@@ -0,0 +1,722 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_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;
Git/usr/bin/core_perl/perlbug
+1533
View File
File diff suppressed because it is too large Load Diff
Git/usr/bin/core_perl/perldoc
+14
View File
@@ -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() );
Git/usr/bin/core_perl/perlivp
+392
View File
@@ -0,0 +1,392 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_shell;
# perlivp v5.26.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.026002";
$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 directoreis 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
Git/usr/bin/core_perl/perlthanks
+1533
View File
File diff suppressed because it is too large Load Diff
Git/usr/bin/core_perl/piconv
+322
View File
@@ -0,0 +1,322 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_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
Git/usr/bin/core_perl/pl2pm
+378
View File
@@ -0,0 +1,378 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_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
Git/usr/bin/core_perl/pod2html
+225
View File
@@ -0,0 +1,225 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_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 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 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 podroot
--podroot=name
Specify the base directory for finding library pods.
=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 cachedir
--cachedir=name
Specify which directory is used for storing cache. Default directory is the
current working directory.
=item flush
--flush
Flush the cache.
=item backlink
--backlink
Turn =head1 directives into links pointing to the top of the HTML file.
=item nobacklink
--nobacklink
Do not turn =head1 directives into links pointing to the top of the HTML file
(default behaviour).
=item header
--header
Create header and footer blocks containing the text of the "NAME" section.
=item noheader
--noheader
Do not create header and footer blocks containing the text of the "NAME"
section (default behaviour).
=item poderrors
--poderrors
Include a "POD ERRORS" section in the outfile if there were any POD errors in
the infile (default behaviour).
=item nopoderrors
--nopoderrors
Do not include a "POD ERRORS" section in the outfile if there were any POD
errors in the infile.
=item index
--index
Generate an index at the top of the HTML file (default behaviour).
=item noindex
--noindex
Do not generate an index at the top of the HTML file.
=item recurse
--recurse
Recurse into subdirectories specified in podpath (default behaviour).
=item norecurse
--norecurse
Do not recurse into subdirectories specified in podpath.
=item css
--css=URL
Specify the URL of cascading style sheet to link from resulting HTML file.
Default is none style sheet.
=item title
--title=title
Specify the title of the resulting HTML file.
=item quiet
--quiet
Don't display mostly harmless warning messages.
=item noquiet
--noquiet
Display mostly harmless warning messages (default behaviour). But this is not
the same as "verbose" mode.
=item verbose
--verbose
Display progress messages.
=item noverbose
--noverbose
Do not display progress messages (default behaviour).
=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;
Git/usr/bin/core_perl/pod2man
+394
View File
@@ -0,0 +1,394 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_shell;
# pod2man -- Convert POD data to formatted *roff input.
#
# Copyright 1999, 2000, 2001, 2004, 2006, 2008, 2010, 2012, 2013, 2014, 2015,
# 2016 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.
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', 'errors=s', 'fixed=s',
'fixedbold=s', 'fixeditalic=s', 'fixedbolditalic=s', 'help|h',
'lax|l', '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;
warn "$0: unable to format $files[0]\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
=head1 NAME
pod2man - Convert POD data to formatted *roff input
=head1 SYNOPSIS
pod2man [B<--center>=I<string>] [B<--date>=I<string>] [B<--errors>=I<style>]
[B<--fixed>=I<font>] [B<--fixedbold>=I<font>] [B<--fixeditalic>=I<font>]
[B<--fixedbolditalic>=I<font>] [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 front-end for Pod::Man, using it to generate *roff input
from POD source. The resulting *roff code is suitable for display on a
terminal using nroff(1), normally via man(1), or printing using troff(1).
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 or L<Pod::Man> for details.
B<pod2man> assumes that your *roff formatters have a fixed-width font
named C<CW>. If yours is called something else (like C<CR>), use
B<--fixed> to specify it. This generally only matters for troff output
for printing. Similarly, you can set the fonts used for bold, italic, and
bold italic fixed-width output.
Besides the obvious pod conversions, Pod::Man, and therefore pod2man also
takes care of formatting func(), func(n), and simple variable references
like $foo or @bar so you don't have to use code escapes for them; complex
expressions like C<$fred{'stuff'}> will still need to be escaped, though.
It also translates dashes that aren't used as hyphens into en dashes, makes
long dashes--like this--into proper em dashes, fixes "paired quotes," and
takes care of several other troff-specific tweaks. See L<Pod::Man> for
complete information.
=head1 OPTIONS
=over 4
=item B<-c> I<string>, B<--center>=I<string>
Sets the centered page header for the C<.TH> macro to I<string>. The
default is "User Contributed Perl Documentation", but also see
B<--official> below.
=item B<-d> I<string>, B<--date>=I<string>
Set the left-hand footer string for the C<.TH> macro to I<string>. By
default, the modification date of the input file will be used, or the
current date if input comes from C<STDIN>, and will be based on UTC (so
that the output will be reproducible regardless of local time zone).
=item B<--errors>=I<style>
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>
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 troff(1)
output.
=item B<--fixedbold>=I<font>
Bold version of the fixed-width font. Defaults to C<CB>. Only matters
for troff(1) output.
=item B<--fixeditalic>=I<font>
Italic version of the fixed-width font (actually, 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 troff(1) output.
=item B<--fixedbolditalic>=I<font>
Bold italic (probably actually oblique) 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 troff(1) output.
=item B<-h>, B<--help>
Print out usage information.
=item B<-l>, B<--lax>
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<--lquote>=I<quote>
=item B<--rquote>=I<quote>
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>
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 man pages for commands is for the man page title to be
in all-uppercase, even if the command isn't.
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>
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>
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>
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>
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 "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>
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>
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>
By default, B<pod2man> produces the most conservative possible *roff
output to try to ensure that it will work with as many different *roff
implementations as possible. Many *roff implementations cannot handle
non-ASCII characters, so this means all non-ASCII characters are converted
either to a *roff escape sequence that tries to create a properly accented
character (at least for troff output) or to C<X>.
This option says to instead output literal UTF-8 characters. If your
*roff implementation can handle it, this is the best output format to use
and avoids corruption of documents containing non-ASCII characters.
However, be warned that *roff source with literal UTF-8 characters is not
supported by many implementations and may even result in segfaults and
other bad behavior.
Be aware that, when using this option, the input encoding of your POD
source should be properly declared unless it's US-ASCII. Pod::Simple will
attempt to guess the encoding and may be successful if it's Latin-1 or
UTF-8, but it will warn, which by default results in a B<pod2man> failure.
Use the C<=encoding> command to declare the encoding. See L<perlpod(1)>
for more information.
=item B<-v>, B<--verbose>
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. See
L<Pod::Man> for more details.
=head1 BUGS
Lots of this documentation is duplicated from L<Pod::Man>.
=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<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
Perl core distribution as of 5.6.0.
=head1 AUTHOR
Russ Allbery <rra@cpan.org>, based I<very> heavily on the original
B<pod2man> by Larry Wall and Tom Christiansen.
=head1 COPYRIGHT AND LICENSE
Copyright 1999, 2000, 2001, 2004, 2006, 2008, 2010, 2012, 2013, 2014,
2015, 2016 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.
=cut
Git/usr/bin/core_perl/pod2text
+324
View File
@@ -0,0 +1,324 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_shell;
# pod2text -- Convert POD data to formatted ASCII text.
#
# Copyright 1999, 2000, 2001, 2004, 2006, 2008, 2010, 2012, 2013, 2014, 2015,
# 2016 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.
#
# The driver script for Pod::Text, Pod::Text::Termcap, and Pod::Text::Color,
# invoked by perldoc -t among other things.
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, and
# default to sentence boundaries turned off for compatibility.
my %options;
$options{sentence} = 0;
Getopt::Long::config ('bundling');
GetOptions (\%options, 'alt|a', 'code', 'color|c', 'errors=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;
warn "$0: unable to format $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
=head1 NAME
pod2text - Convert POD data to formatted ASCII text
=head1 SYNOPSIS
pod2text [B<-aclostu>] [B<--code>] [B<--errors>=I<style>] [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 front-end for Pod::Text and its subclasses. It uses them
to generate formatted ASCII 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.
=head1 OPTIONS
=over 4
=item B<-a>, B<--alt>
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>
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>
Format the output with ANSI color escape sequences. Using this option
requires that Term::ANSIColor be installed on your system.
=item B<--errors>=I<style>
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<-i> I<indent>, B<--indent=>I<indent>
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>
Print out usage information and exit.
=item B<-l>, B<--loose>
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>
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>
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>
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>
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>
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>
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>
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>
By default, B<pod2text> tries to use the same output encoding as its input
encoding (to be backward-compatible with older versions). This option
says to instead force the output encoding to UTF-8.
Be aware that, when using this option, the input encoding of your POD
source should be properly declared unless it's US-ASCII. Pod::Simple
will attempt to guess the encoding and may be successful if it's
Latin-1 or UTF-8, but it will warn, which by default results in a
B<pod2text> failure. Use the C<=encoding> command to declare the
encoding. See L<perlpod(1)> for more information.
=item B<-w>, B<--width=>I<width>, B<->I<width>
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 SEE ALSO
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<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
Perl core distribution as of 5.6.0.
=head1 AUTHOR
Russ Allbery <rra@cpan.org>.
=head1 COPYRIGHT AND LICENSE
Copyright 1999, 2000, 2001, 2004, 2006, 2008, 2010, 2012, 2013, 2014, 2015,
2016 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.
=cut
Git/usr/bin/core_perl/pod2usage
+160
View File
@@ -0,0 +1,160 @@
#!/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 (defaults to standard input).
=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(1)>
=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));
@ARGV = ('-') unless (@ARGV);
if (@ARGV > 1) {
print STDERR "pod2usage: Too many filenames given\n\n";
pod2usage(2);
}
my %usage = ();
$usage{-input} = shift(@ARGV);
$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);
Git/usr/bin/core_perl/podchecker
+144
View File
@@ -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;
Git/usr/bin/core_perl/podselect
+104
View File
@@ -0,0 +1,104 @@
#!/usr/bin/perl
eval 'exec perl -S $0 "$@"'
if 0;
#############################################################################
# podselect -- command to invoke the podselect function in Pod::Select
#
# Copyright (c) 1996-2000 by Bradford Appleton. All rights reserved.
# This file is part of "PodParser". PodParser is free software;
# you can redistribute it and/or modify it under the same terms
# as Perl itself.
#############################################################################
use strict;
#use diagnostics;
=head1 NAME
podselect - print selected sections of pod documentation on standard output
=head1 SYNOPSIS
B<podselect> [B<-help>] [B<-man>] [B<-section>S< >I<section-spec>]
[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<-section>S< >I<section-spec>
Specify a section to include in the output.
See L<Pod::Parser/"SECTION SPECIFICATIONS">
for the format to use for I<section-spec>.
This option may be given multiple times on the command line.
=item I<file>
The pathname of a file from which to select sections of pod
documentation (defaults to standard input).
=back
=head1 DESCRIPTION
B<podselect> will read the given input files looking for pod
documentation and will print out (in raw pod format) all sections that
match one ore more of the given section specifications. If no section
specifications are given than all pod sections encountered are output.
B<podselect> invokes the B<podselect()> function exported by B<Pod::Select>
Please see L<Pod::Select/podselect()> for more details.
=head1 SEE ALSO
L<Pod::Parser> and L<Pod::Select>
=head1 AUTHOR
Please report bugs using L<http://rt.cpan.org>.
Brad Appleton E<lt>bradapp@enteract.comE<gt>
Based on code for B<Pod::Text::pod2text(1)> written by
Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
=cut
use Pod::Select;
use Pod::Usage;
use Getopt::Long;
## Define options
my %options = (
'help' => 0,
'man' => 0,
'sections' => [],
);
## Parse options
GetOptions(\%options, 'help', 'man', 'sections|select=s@') || pod2usage(2);
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));
## Invoke podselect().
if (@{ $options{'sections'} } > 0) {
podselect({ -sections => $options{'sections'} }, @ARGV);
}
else {
podselect(@ARGV);
}
Git/usr/bin/core_perl/prove
+409
View File
@@ -0,0 +1,409 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_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.
--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> on Unix-like platforms and
L<Win32::Console> on windows. If the necessary module is 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. Multple 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
Git/usr/bin/core_perl/ptar
+142
View File
@@ -0,0 +1,142 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_shell;
#!/usr/bin/perl
use strict;
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;
}
Git/usr/bin/core_perl/ptardiff
+120
View File
@@ -0,0 +1,120 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_shell;
#!/usr/bin/perl
BEGIN { pop @INC if $INC[-1] eq '.' }
use strict;
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
Git/usr/bin/core_perl/ptargrep
+196
View File
@@ -0,0 +1,196 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_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
Git/usr/bin/core_perl/shasum
+334
View File
@@ -0,0 +1,334 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_shell;
#!perl
## shasum: filter for computing SHA digests (ref. sha1sum/md5sum)
##
## Copyright (C) 2003-2016 Mark Shelor, All Rights Reserved
##
## Version: 5.96
## Wed Jul 27 20:04:34 MST 2016
## shasum SYNOPSIS adapted from GNU Coreutils sha1sum. Add
## "-a" option for algorithm selection,
## "-U" option for Universal Newlines support,
## "-0" option for reading bit strings, and
## "-p" option for portable digests (to be deprecated).
BEGIN { pop @INC if $INC[-1] eq '.' }
use strict;
use warnings;
use Fcntl;
use Getopt::Long;
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
-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
-p, --portable read in portable mode (to be deprecated)
The following two options are useful only when verifying checksums:
-s, --status don't output anything, status code shows success
-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, `?'
for portable), and name for each FILE.
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-2016 Mark Shelor <mshelor@cpan.org>.
=head1 SEE ALSO
I<shasum> is implemented using the Perl module L<Digest::SHA> or
L<Digest::SHA::PurePerl>.
=cut
END_OF_POD
my $VERSION = "5.96";
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, $warn, $help, $version);
my ($portable, $BITS, $reverse, $UNIVERSAL, $versions);
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,
'h|help' => \$help, 'v|version' => \$version,
'p|portable' => \$portable,
'0|01' => \$BITS,
'R|REVERSE' => \$reverse,
'U|UNIVERSAL' => \$UNIVERSAL,
'V|VERSIONS' => \$versions,
) 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, $portable, $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;
## Try to use Digest::SHA. If not installed, use the slower
## but functionally equivalent Digest::SHA::PurePerl instead.
## If option -R is invoked, reverse the module preference,
## i.e. try Digest::SHA::PurePerl first, then Digest::SHA.
my @MODS = qw(Digest::SHA Digest::SHA::PurePerl);
@MODS[0, 1] = @MODS[1, 0] if $reverse;
my $module;
for (@MODS) {
my $mod = $_;
if (eval "require $mod") {
$module = $mod;
last;
}
}
die "shasum: Unable to find " . join(" or ", @MODS) . "\n"
unless defined $module;
## Default to SHA-1 unless overridden by command line option
$alg = 1 unless defined $alg;
grep { $_ == $alg } (1, 224, 256, 384, 512, 512224, 512256)
or usage(1, "shasum: Unrecognized algorithm\n");
## Display version information if requested
if ($version) {
print "$VERSION\n";
exit(0);
}
if ($versions) {
print "shasum $VERSION\n";
print "$module ", eval "\$${module}::VERSION", "\n";
print "perl ", defined $^V ? sprintf("%vd", $^V) : $], "\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" or "--portable" options.
my $isDOSish = ($^O =~ /^(MSWin\d\d|os2|dos|mint|cygwin|msys)$/);
if ($isDOSish) { $binary = 1 unless $text || $UNIVERSAL || $portable }
my $modesym = $binary ? '*' : ($UNIVERSAL ? 'U' :
($BITS ? '^' : ($portable ? '?' : ' ')));
## 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' : ($portable ? 'p' : '')));
my $digest = eval { $module->new($alg)->addfile($file, $mode) };
if ($@) { warn "shasum: $file: $!\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;
return if /\\/;
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_lines, $num_files) = (0, 0);
my ($bslash, $sum, $fname, $rsp, $digest);
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 /^#/; s/\n$//; s/^[ \t]+//; $num_lines++;
$bslash = s/^\\//;
($sum, $modesym, $fname) =
/^([\da-fA-F]+)[ \t]([ *?^U])([^\0]*)/;
$alg = defined $sum ? $len2alg{length($sum)} : undef;
$fname = unescape($fname) if defined $fname && $bslash;
if (grep { ! defined $_ } ($alg, $sum, $modesym, $fname)) {
$alg = 1 unless defined $alg;
warn("shasum: $checkfile: $.: improperly " .
"formatted SHA$alg checksum line\n") if $warn;
$fmt_errs++;
next;
}
$fname =~ s/\r$// unless -e $fname;
$rsp = "$fname: "; $num_files++;
($binary, $text, $UNIVERSAL, $BITS, $portable) =
map { $_ eq $modesym } ('*', ' ', 'U', '^', 'p');
unless ($digest = sumfile($fname)) {
$rsp .= "FAILED open or read\n";
$err = 1; $read_errs++;
}
else {
if (lc($sum) eq $digest) { $rsp .= "OK\n" }
else { $rsp .= "FAILED\n"; $err = 1; $match_errs++ }
}
print $rsp unless $status;
}
close(FH);
unless ($num_files) {
$alg = 1 unless defined $alg;
warn("shasum: $checkfile: no properly formatted " .
"SHA$alg 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;
}
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;
$digest = "\\$digest";
}
print "$digest $modesym", "$file\n";
}
else { $STATUS = 1 }
}
exit($STATUS)
Git/usr/bin/core_perl/splain
+716
View File
@@ -0,0 +1,716 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_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
While apparently a whole nuther program, I<splain> is actually nothing
more than a link to the (executable) F<diagnostics.pm> module, as well as
a link to the F<diagnostics.pod> documentation. The B<-v> flag is like
the C<use diagnostics -verbose> directive.
The B<-p> flag is like the
$diagnostics::PRETTY variable. Since you're post-processing with
I<splain>, there's no sense in being able to enable() or disable() processing.
Output from I<splain> is directed to B<STDOUT>, unlike the pragma.
=head1 EXAMPLES
The following file is certain to trigger a few errors at both
runtime and compiletime:
use diagnostics;
print NOWHERE "nothing\n";
print STDERR "\n\tThis message should be unadorned.\n";
warn "\tThis is a user warning";
print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: ";
my $a, $b = scalar <STDIN>;
print "\n";
print $x/$y;
If you prefer to run your program first and look at its problem
afterwards, do this:
perl -w test.pl 2>test.out
./splain < test.out
Note that this is not in general possible in shells of more dubious heritage,
as the theoretical
(perl -w test.pl >/dev/tty) >& test.out
./splain < test.out
Because you just moved the existing B<stdout> to somewhere else.
If you don't want to modify your source code, but still have on-the-fly
warnings, do this:
exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&-
Nifty, eh?
If you want to control warnings on the fly, do something like this.
Make sure you do the C<use> first, or you won't be able to get
at the enable() or disable() methods.
use diagnostics; # checks entire compilation phase
print "\ntime for 1st bogus diags: SQUAWKINGS\n";
print BOGUS1 'nada';
print "done with 1st bogus\n";
disable diagnostics; # only turns off runtime warnings
print "\ntime for 2nd bogus: (squelched)\n";
print BOGUS2 'nada';
print "done with 2nd bogus\n";
enable diagnostics; # turns back on runtime warnings
print "\ntime for 3rd bogus: SQUAWKINGS\n";
print BOGUS3 'nada';
print "done with 3rd bogus\n";
disable diagnostics;
print "\ntime for 4th bogus: (squelched)\n";
print BOGUS4 'nada';
print "done with 4th bogus\n";
=head1 INTERNALS
Diagnostic messages derive from the F<perldiag.pod> file when available at
runtime. Otherwise, they may be embedded in the file itself when the
splain package is built. See the F<Makefile> for details.
If an extant $SIG{__WARN__} handler is discovered, it will continue
to be honored, but only after the diagnostics::splainthis() function
(the module's $SIG{__WARN__} interceptor) has had its way with your
warnings.
There is a $diagnostics::DEBUG variable you may set if you're desperately
curious what sorts of things are being intercepted.
BEGIN { $diagnostics::DEBUG = 1 }
=head1 BUGS
Not being able to say "no diagnostics" is annoying, but may not be
insurmountable.
The C<-pretty> directive is called too late to affect matters.
You have to do this instead, and I<before> you load the module.
BEGIN { $diagnostics::PRETTY = 1 }
I could start up faster by delaying compilation until it should be
needed, but this gets a "panic: top_level" when using the pragma form
in Perl 5.001e.
While it's true that this documentation is somewhat subserious, if you use
a program named I<splain>, you should expect a bit of whimsy.
=head1 AUTHOR
Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
=cut
use strict;
use 5.009001;
use Carp;
$Carp::Internal{__PACKAGE__.""}++;
our $VERSION = '1.36';
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
"Aacute" => "A\\*'", # capital A, acute accent
# etc
);
%HTML_2_Latin_1 = (
'amp' => '&', # ampersand
'lt' => '<', # left chevron, less-than
'gt' => '>', # right chevron, greater-than
'quot' => '"', # double quote
"Aacute" => "\xC1" # capital A, acute accent
# etc
);
%HTML_2_ASCII_7 = (
'amp' => '&', # ampersand
'lt' => '<', # left chevron, less-than
'gt' => '>', # right chevron, greater-than
'quot' => '"', # double quote
"Aacute" => "A" # capital A, acute accent
# etc
);
our %HTML_Escapes;
*HTML_Escapes = do {
if ($standalone) {
$PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
} else {
\%HTML_2_Latin_1;
}
};
*THITHER = $standalone ? *STDOUT : *STDERR;
my %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
Git/usr/bin/core_perl/xsubpp
+188
View File
@@ -0,0 +1,188 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_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
Git/usr/bin/core_perl/zipdetails
+2131
View File
File diff suppressed because it is too large Load Diff
Git/usr/bin/cp.exe
BIN
View File
Binary file not shown.
Git/usr/bin/csplit.exe
BIN
View File
Binary file not shown.
Git/usr/bin/cut.exe
BIN
View File
Binary file not shown.
Git/usr/bin/cygcheck.exe
BIN
View File
Binary file not shown.
Git/usr/bin/cygpath.exe
BIN
View File
Binary file not shown.
Git/usr/bin/cygwin-console-helper.exe
BIN
View File
Binary file not shown.
Git/usr/bin/d2u.exe
BIN
View File
Binary file not shown.
Git/usr/bin/dash.exe
BIN
View File
Binary file not shown.
Git/usr/bin/date.exe
BIN
View File
Binary file not shown.
Git/usr/bin/dd.exe
BIN
View File
Binary file not shown.
Git/usr/bin/df.exe
BIN
View File
Binary file not shown.
Git/usr/bin/diff.exe
BIN
View File
Binary file not shown.
Git/usr/bin/diff3.exe
BIN
View File
Binary file not shown.
Git/usr/bin/dir.exe
BIN
View File
Binary file not shown.
Git/usr/bin/dircolors.exe
BIN
View File
Binary file not shown.
Git/usr/bin/dirmngr-client.exe
BIN
View File
Binary file not shown.
Git/usr/bin/dirmngr.exe
BIN
View File
Binary file not shown.
Git/usr/bin/dirname.exe
BIN
View File
Binary file not shown.
Git/usr/bin/docx2txt
+120
View File
@@ -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
Git/usr/bin/docx2txt.pl
+721
View File
@@ -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 &apos; and &quot; 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;
Git/usr/bin/dos2unix.exe
BIN
View File
Binary file not shown.
Git/usr/bin/du.exe
BIN
View File
Binary file not shown.
Git/usr/bin/dumpsexp.exe
BIN
View File
Binary file not shown.
Git/usr/bin/echo.exe
BIN
View File
Binary file not shown.
Git/usr/bin/egrep
+2
View File
@@ -0,0 +1,2 @@
#!/bin/sh
exec grep -E "$@"
Git/usr/bin/env.exe
BIN
View File
Binary file not shown.
Git/usr/bin/envsubst.exe
BIN
View File
Binary file not shown.
Git/usr/bin/ex.exe
BIN
View File
Binary file not shown.
Git/usr/bin/expand.exe
BIN
View File
Binary file not shown.
Git/usr/bin/expr.exe
BIN
View File
Binary file not shown.
Git/usr/bin/factor.exe
BIN
View File
Binary file not shown.
Git/usr/bin/false.exe
BIN
View File
Binary file not shown.
Git/usr/bin/fgrep
+2
View File
@@ -0,0 +1,2 @@
#!/bin/sh
exec grep -F "$@"

Some files were not shown because too many files have changed in this diff Show More