mirror of
https://github.com/freebsd/freebsd-src
synced 2024-10-09 10:00:39 +00:00
Old Perl is leaving us. Goodbye, faithful friend.
This commit is contained in:
Mark Murray
parent
2b0daddd6a
commit
bae7411889
Notes:
svn2git
2020-12-20 02:59:44 +00:00
svn path=/head/; revision=38979
|
|
@ -1,117 +0,0 @@
|
|||
|
||||
|
||||
|
||||
|
||||
The "Artistic License"
|
||||
|
||||
Preamble
|
||||
|
||||
The intent of this document is to state the conditions under which a
|
||||
Package may be copied, such that the Copyright Holder maintains some
|
||||
semblance of artistic control over the development of the package,
|
||||
while giving the users of the package the right to use and distribute
|
||||
the Package in a more-or-less customary fashion, plus the right to make
|
||||
reasonable modifications.
|
||||
|
||||
Definitions:
|
||||
|
||||
"Package" refers to the collection of files distributed by the
|
||||
Copyright Holder, and derivatives of that collection of files
|
||||
created through textual modification.
|
||||
|
||||
"Standard Version" refers to such a Package if it has not been
|
||||
modified, or has been modified in accordance with the wishes
|
||||
of the Copyright Holder.
|
||||
|
||||
"Copyright Holder" is whoever is named in the copyright or
|
||||
copyrights for the package.
|
||||
|
||||
"You" is you, if you're thinking about copying or distributing
|
||||
this Package.
|
||||
|
||||
"Reasonable copying fee" is whatever you can justify on the
|
||||
basis of media cost, duplication charges, time of people involved,
|
||||
and so on. (You will not be required to justify it to the
|
||||
Copyright Holder, but only to the computing community at large
|
||||
as a market that must bear the fee.)
|
||||
|
||||
"Freely Available" means that no fee is charged for the item
|
||||
itself, though there may be fees involved in handling the item.
|
||||
It also means that recipients of the item may redistribute it
|
||||
under the same conditions they received it.
|
||||
|
||||
1. You may make and give away verbatim copies of the source form of the
|
||||
Standard Version of this Package without restriction, provided that you
|
||||
duplicate all of the original copyright notices and associated disclaimers.
|
||||
|
||||
2. You may apply bug fixes, portability fixes and other modifications
|
||||
derived from the Public Domain or from the Copyright Holder. A Package
|
||||
modified in such a way shall still be considered the Standard Version.
|
||||
|
||||
3. You may otherwise modify your copy of this Package in any way, provided
|
||||
that you insert a prominent notice in each changed file stating how and
|
||||
when you changed that file, and provided that you do at least ONE of the
|
||||
following:
|
||||
|
||||
a) place your modifications in the Public Domain or otherwise make them
|
||||
Freely Available, such as by posting said modifications to Usenet or
|
||||
an equivalent medium, or placing the modifications on a major archive
|
||||
site such as uunet.uu.net, or by allowing the Copyright Holder to include
|
||||
your modifications in the Standard Version of the Package.
|
||||
|
||||
b) use the modified Package only within your corporation or organization.
|
||||
|
||||
c) rename any non-standard executables so the names do not conflict
|
||||
with standard executables, which must also be provided, and provide
|
||||
a separate manual page for each non-standard executable that clearly
|
||||
documents how it differs from the Standard Version.
|
||||
|
||||
d) make other distribution arrangements with the Copyright Holder.
|
||||
|
||||
4. You may distribute the programs of this Package in object code or
|
||||
executable form, provided that you do at least ONE of the following:
|
||||
|
||||
a) distribute a Standard Version of the executables and library files,
|
||||
together with instructions (in the manual page or equivalent) on where
|
||||
to get the Standard Version.
|
||||
|
||||
b) accompany the distribution with the machine-readable source of
|
||||
the Package with your modifications.
|
||||
|
||||
c) accompany any non-standard executables with their corresponding
|
||||
Standard Version executables, giving the non-standard executables
|
||||
non-standard names, and clearly documenting the differences in manual
|
||||
pages (or equivalent), together with instructions on where to get
|
||||
the Standard Version.
|
||||
|
||||
d) make other distribution arrangements with the Copyright Holder.
|
||||
|
||||
5. You may charge a reasonable copying fee for any distribution of this
|
||||
Package. You may charge any fee you choose for support of this Package.
|
||||
You may not charge a fee for this Package itself. However,
|
||||
you may distribute this Package in aggregate with other (possibly
|
||||
commercial) programs as part of a larger (possibly commercial) software
|
||||
distribution provided that you do not advertise this Package as a
|
||||
product of your own.
|
||||
|
||||
6. The scripts and library files supplied as input to or produced as
|
||||
output from the programs of this Package do not automatically fall
|
||||
under the copyright of this Package, but belong to whomever generated
|
||||
them, and may be sold commercially, and may be aggregated with this
|
||||
Package.
|
||||
|
||||
7. C subroutines supplied by you and linked into this Package in order
|
||||
to emulate subroutines and variables of the language defined by this
|
||||
Package shall not be considered part of this Package, but are the
|
||||
equivalent of input as in Paragraph 6, provided these subroutines do
|
||||
not change the language in any way that would cause it to fail the
|
||||
regression tests for the language.
|
||||
|
||||
8. The name of the Copyright Holder may not be used to endorse or promote
|
||||
products derived from this software without specific prior written permission.
|
||||
|
||||
9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
|
||||
IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
|
||||
WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
The End
|
||||
|
|
@ -1,248 +0,0 @@
|
|||
GNU GENERAL PUBLIC LICENSE
|
||||
Version 1, February 1989
|
||||
|
||||
Copyright (C) 1989 Free Software Foundation, Inc.
|
||||
675 Mass Ave, Cambridge, MA 02139, USA
|
||||
Everyone is permitted to copy and distribute verbatim copies
|
||||
of this license document, but changing it is not allowed.
|
||||
|
||||
Preamble
|
||||
|
||||
The license agreements of most software companies try to keep users
|
||||
at the mercy of those companies. By contrast, our General Public
|
||||
License is intended to guarantee your freedom to share and change free
|
||||
software--to make sure the software is free for all its users. The
|
||||
General Public License applies to the Free Software Foundation's
|
||||
software and to any other program whose authors commit to using it.
|
||||
You can use it for your programs, too.
|
||||
|
||||
When we speak of free software, we are referring to freedom, not
|
||||
price. Specifically, the General Public License is designed to make
|
||||
sure that you have the freedom to give away or sell copies of free
|
||||
software, that you receive source code or can get it if you want it,
|
||||
that you can change the software or use pieces of it in new free
|
||||
programs; and that you know you can do these things.
|
||||
|
||||
To protect your rights, we need to make restrictions that forbid
|
||||
anyone to deny you these rights or to ask you to surrender the rights.
|
||||
These restrictions translate to certain responsibilities for you if you
|
||||
distribute copies of the software, or if you modify it.
|
||||
|
||||
For example, if you distribute copies of a such a program, whether
|
||||
gratis or for a fee, you must give the recipients all the rights that
|
||||
you have. You must make sure that they, too, receive or can get the
|
||||
source code. And you must tell them their rights.
|
||||
|
||||
We protect your rights with two steps: (1) copyright the software, and
|
||||
(2) offer you this license which gives you legal permission to copy,
|
||||
distribute and/or modify the software.
|
||||
|
||||
Also, for each author's protection and ours, we want to make certain
|
||||
that everyone understands that there is no warranty for this free
|
||||
software. If the software is modified by someone else and passed on, we
|
||||
want its recipients to know that what they have is not the original, so
|
||||
that any problems introduced by others will not reflect on the original
|
||||
authors' reputations.
|
||||
|
||||
The precise terms and conditions for copying, distribution and
|
||||
modification follow.
|
||||
|
||||
GNU GENERAL PUBLIC LICENSE
|
||||
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
|
||||
|
||||
0. This License Agreement applies to any program or other work which
|
||||
contains a notice placed by the copyright holder saying it may be
|
||||
distributed under the terms of this General Public License. The
|
||||
"Program", below, refers to any such program or work, and a "work based
|
||||
on the Program" means either the Program or any work containing the
|
||||
Program or a portion of it, either verbatim or with modifications. Each
|
||||
licensee is addressed as "you".
|
||||
|
||||
1. You may copy and distribute verbatim copies of the Program's source
|
||||
code as you receive it, in any medium, provided that you conspicuously and
|
||||
appropriately publish on each copy an appropriate copyright notice and
|
||||
disclaimer of warranty; keep intact all the notices that refer to this
|
||||
General Public License and to the absence of any warranty; and give any
|
||||
other recipients of the Program a copy of this General Public License
|
||||
along with the Program. You may charge a fee for the physical act of
|
||||
transferring a copy.
|
||||
|
||||
2. You may modify your copy or copies of the Program or any portion of
|
||||
it, and copy and distribute such modifications under the terms of Paragraph
|
||||
1 above, provided that you also do the following:
|
||||
|
||||
a) cause the modified files to carry prominent notices stating that
|
||||
you changed the files and the date of any change; and
|
||||
|
||||
b) cause the whole of any work that you distribute or publish, that
|
||||
in whole or in part contains the Program or any part thereof, either
|
||||
with or without modifications, to be licensed at no charge to all
|
||||
third parties under the terms of this General Public License (except
|
||||
that you may choose to grant warranty protection to some or all
|
||||
third parties, at your option).
|
||||
|
||||
c) If the modified program normally reads commands interactively when
|
||||
run, you must cause it, when started running for such interactive use
|
||||
in the simplest and most usual way, to print or display an
|
||||
announcement including an appropriate copyright notice and a notice
|
||||
that there is no warranty (or else, saying that you provide a
|
||||
warranty) and that users may redistribute the program under these
|
||||
conditions, and telling the user how to view a copy of this General
|
||||
Public License.
|
||||
|
||||
d) You may charge a fee for the physical act of transferring a
|
||||
copy, and you may at your option offer warranty protection in
|
||||
exchange for a fee.
|
||||
|
||||
Mere aggregation of another independent work with the Program (or its
|
||||
derivative) on a volume of a storage or distribution medium does not bring
|
||||
the other work under the scope of these terms.
|
||||
|
||||
3. You may copy and distribute the Program (or a portion or derivative of
|
||||
it, under Paragraph 2) in object code or executable form under the terms of
|
||||
Paragraphs 1 and 2 above provided that you also do one of the following:
|
||||
|
||||
a) accompany it with the complete corresponding machine-readable
|
||||
source code, which must be distributed under the terms of
|
||||
Paragraphs 1 and 2 above; or,
|
||||
|
||||
b) accompany it with a written offer, valid for at least three
|
||||
years, to give any third party free (except for a nominal charge
|
||||
for the cost of distribution) a complete machine-readable copy of the
|
||||
corresponding source code, to be distributed under the terms of
|
||||
Paragraphs 1 and 2 above; or,
|
||||
|
||||
c) accompany it with the information you received as to where the
|
||||
corresponding source code may be obtained. (This alternative is
|
||||
allowed only for noncommercial distribution and only if you
|
||||
received the program in object code or executable form alone.)
|
||||
|
||||
Source code for a work means the preferred form of the work for making
|
||||
modifications to it. For an executable file, complete source code means
|
||||
all the source code for all modules it contains; but, as a special
|
||||
exception, it need not include source code for modules which are standard
|
||||
libraries that accompany the operating system on which the executable
|
||||
file runs, or for standard header files or definitions files that
|
||||
accompany that operating system.
|
||||
|
||||
4. You may not copy, modify, sublicense, distribute or transfer the
|
||||
Program except as expressly provided under this General Public License.
|
||||
Any attempt otherwise to copy, modify, sublicense, distribute or transfer
|
||||
the Program is void, and will automatically terminate your rights to use
|
||||
the Program under this License. However, parties who have received
|
||||
copies, or rights to use copies, from you under this General Public
|
||||
License will not have their licenses terminated so long as such parties
|
||||
remain in full compliance.
|
||||
|
||||
5. By copying, distributing or modifying the Program (or any work based
|
||||
on the Program) you indicate your acceptance of this license to do so,
|
||||
and all its terms and conditions.
|
||||
|
||||
6. Each time you redistribute the Program (or any work based on the
|
||||
Program), the recipient automatically receives a license from the original
|
||||
licensor to copy, distribute or modify the Program subject to these
|
||||
terms and conditions. You may not impose any further restrictions on the
|
||||
recipients' exercise of the rights granted herein.
|
||||
|
||||
7. The Free Software Foundation may publish revised and/or new versions
|
||||
of the General Public License from time to time. Such new versions will
|
||||
be similar in spirit to the present version, but may differ in detail to
|
||||
address new problems or concerns.
|
||||
|
||||
Each version is given a distinguishing version number. If the Program
|
||||
specifies a version number of the license which applies to it and "any
|
||||
later version", you have the option of following the terms and conditions
|
||||
either of that version or of any later version published by the Free
|
||||
Software Foundation. If the Program does not specify a version number of
|
||||
the license, you may choose any version ever published by the Free Software
|
||||
Foundation.
|
||||
|
||||
8. If you wish to incorporate parts of the Program into other free
|
||||
programs whose distribution conditions are different, write to the author
|
||||
to ask for permission. For software which is copyrighted by the Free
|
||||
Software Foundation, write to the Free Software Foundation; we sometimes
|
||||
make exceptions for this. Our decision will be guided by the two goals
|
||||
of preserving the free status of all derivatives of our free software and
|
||||
of promoting the sharing and reuse of software generally.
|
||||
|
||||
NO WARRANTY
|
||||
|
||||
9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
|
||||
FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
|
||||
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
|
||||
PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
|
||||
OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
|
||||
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
|
||||
TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
|
||||
PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
|
||||
REPAIR OR CORRECTION.
|
||||
|
||||
10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
|
||||
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
|
||||
REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
|
||||
INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
|
||||
OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
|
||||
TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
|
||||
YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
|
||||
PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
|
||||
POSSIBILITY OF SUCH DAMAGES.
|
||||
|
||||
END OF TERMS AND CONDITIONS
|
||||
|
||||
Appendix: How to Apply These Terms to Your New Programs
|
||||
|
||||
If you develop a new program, and you want it to be of the greatest
|
||||
possible use to humanity, the best way to achieve this is to make it
|
||||
free software which everyone can redistribute and change under these
|
||||
terms.
|
||||
|
||||
To do so, attach the following notices to the program. It is safest to
|
||||
attach them to the start of each source file to most effectively convey
|
||||
the exclusion of warranty; and each file should have at least the
|
||||
"copyright" line and a pointer to where the full notice is found.
|
||||
|
||||
<one line to give the program's name and a brief idea of what it does.>
|
||||
Copyright (C) 19yy <name of author>
|
||||
|
||||
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 1, 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., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
|
||||
Also add information on how to contact you by electronic and paper mail.
|
||||
|
||||
If the program is interactive, make it output a short notice like this
|
||||
when it starts in an interactive mode:
|
||||
|
||||
Gnomovision version 69, Copyright (C) 19xx name of author
|
||||
Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
|
||||
This is free software, and you are welcome to redistribute it
|
||||
under certain conditions; type `show c' for details.
|
||||
|
||||
The hypothetical commands `show w' and `show c' should show the
|
||||
appropriate parts of the General Public License. Of course, the
|
||||
commands you use may be called something other than `show w' and `show
|
||||
c'; they could even be mouse-clicks or menu items--whatever suits your
|
||||
program.
|
||||
|
||||
You should also get your employer (if you work as a programmer) or your
|
||||
school, if any, to sign a "copyright disclaimer" for the program, if
|
||||
necessary. Here a sample; alter the names:
|
||||
|
||||
Yoyodyne, Inc., hereby disclaims all copyright interest in the
|
||||
program `Gnomovision' (a program to direct compilers to make passes
|
||||
at assemblers) written by James Hacker.
|
||||
|
||||
<signature of Ty Coon>, 1 April 1989
|
||||
Ty Coon, President of Vice
|
||||
|
||||
That's all there is to it!
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
#
|
||||
# Bmake file for perl 4.036
|
||||
#
|
||||
# Note: I'm not sure what to do with c2ph located in misc...
|
||||
#
|
||||
|
||||
SUBDIR= perl tperl usub lib x2p
|
||||
|
||||
.if !defined(NOSUIDPERL) && exists(${.CURDIR}/sperl)
|
||||
SUBDIR+=sperl
|
||||
.endif
|
||||
|
||||
.include <bsd.subdir.mk>
|
||||
|
||||
|
|
@ -1,195 +0,0 @@
|
|||
|
||||
Perl Kit, Version 4.0
|
||||
|
||||
Copyright (c) 1989,1990,1991, Larry Wall
|
||||
All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the terms of either:
|
||||
|
||||
a) the GNU General Public License as published by the Free
|
||||
Software Foundation; either version 1, or (at your option) any
|
||||
later version, or
|
||||
|
||||
b) the "Artistic License" which comes with this Kit.
|
||||
|
||||
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 either
|
||||
the GNU General Public License or the Artistic License for more details.
|
||||
|
||||
You should have received a copy of the Artistic License with this
|
||||
Kit, in the file named "Artistic". If not, I'll be glad to provide one.
|
||||
|
||||
You should also have received a copy of the GNU General Public License
|
||||
along with this program; if not, write to the Free Software
|
||||
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
|
||||
For those of you that choose to use the GNU General Public License,
|
||||
my interpretation of the GNU General Public License is that no Perl
|
||||
script falls under the terms of the GPL unless you explicitly put
|
||||
said script under the terms of the GPL yourself. Furthermore, any
|
||||
object code linked with uperl.o does not automatically fall under the
|
||||
terms of the GPL, provided such object code only adds definitions
|
||||
of subroutines and variables, and does not otherwise impair the
|
||||
resulting interpreter from executing any standard Perl script. I
|
||||
consider linking in C subroutines in this manner to be the moral
|
||||
equivalent of defining subroutines in the Perl language itself. You
|
||||
may sell such an object file as proprietary provided that you provide
|
||||
or offer to provide the Perl source, as specified by the GNU General
|
||||
Public License. (This is merely an alternate way of specifying input
|
||||
to the program.) You may also sell a binary produced by the dumping of
|
||||
a running Perl script that belongs to you, provided that you provide or
|
||||
offer to provide the Perl source as specified by the GPL. (The
|
||||
fact that a Perl interpreter and your code are in the same binary file
|
||||
is, in this case, a form of mere aggregation.) This is my interpretation
|
||||
of the GPL. If you still have concerns or difficulties understanding
|
||||
my intent, feel free to contact me. Of course, the Artistic License
|
||||
spells all this out for your protection, so you may prefer to use that.
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
|
||||
Perl is a language that combines some of the features of C, sed, awk and shell.
|
||||
See the manual page for more hype. There's also a Nutshell Handbook published
|
||||
by O'Reilly & Assoc. Their U.S. number is 1-800-338-6887 (dev-nuts) and
|
||||
their international number is 1-707-829-0515. E-mail to nuts@ora.com.
|
||||
|
||||
Perl will probably not run on machines with a small address space.
|
||||
|
||||
Please read all the directions below before you proceed any further, and
|
||||
then follow them carefully.
|
||||
|
||||
After you have unpacked your kit, you should have all the files listed
|
||||
in MANIFEST.
|
||||
|
||||
Installation
|
||||
|
||||
1) Run Configure. This will figure out various things about your system.
|
||||
Some things Configure will figure out for itself, other things it will
|
||||
ask you about. It will then proceed to make config.h, config.sh, and
|
||||
Makefile. If you're a hotshot, run Configure -d to take all the
|
||||
defaults and then edit config.sh to patch up any flaws.
|
||||
|
||||
You might possibly have to trim # comments from the front of Configure
|
||||
if your sh doesn't handle them, but all other # comments will be taken
|
||||
care of.
|
||||
|
||||
(If you don't have sh, you'll have to copy the sample file config.H to
|
||||
config.h and edit the config.h to reflect your system's peculiarities.)
|
||||
|
||||
2) Glance through config.h to make sure system dependencies are correct.
|
||||
Most of them should have been taken care of by running the Configure script.
|
||||
|
||||
If you have any additional changes to make to the C definitions, they
|
||||
can be done in cflags.SH. For instance, to turn off the optimizer
|
||||
on eval.c, find the line in the switch structure for eval.c and
|
||||
put the command $optimize='-g' before the ;;. You will probably
|
||||
want to change the entry for teval.c too. To change the C flags
|
||||
for all the files, edit config.sh and change either $ccflags or $optimize.
|
||||
|
||||
3) make depend
|
||||
|
||||
This will look for all the includes and modify Makefile accordingly.
|
||||
Configure will offer to do this for you.
|
||||
|
||||
4) make
|
||||
|
||||
This will attempt to make perl in the current directory.
|
||||
|
||||
If you can't compile successfully, try adding a -DCRIPPLED_CC flag.
|
||||
(Just because you get no errors doesn't mean it compiled right!)
|
||||
This simplifies some complicated expressions for compilers that
|
||||
get indigestion easily. If that has no effect, try turning off
|
||||
optimization. If you have missing routines, you probably need to
|
||||
add some library or other, or you need to undefine some feature that
|
||||
Configure thought was there but is defective or incomplete.
|
||||
|
||||
Some compilers will not compile or optimize the larger files without
|
||||
some extra switches to use larger jump offsets or allocate larger
|
||||
internal tables. You can customize the switches for each file in
|
||||
cflags.SH. It's okay to insert rules for specific files into
|
||||
Makefile.SH, since a default rule only takes effect in the
|
||||
absence of a specific rule.
|
||||
|
||||
Most of the following hints are now done automatically by Configure.
|
||||
|
||||
The 3b2 needs to turn off -O.
|
||||
Compilers with limited switch tables may have to define -DSMALLSWITCHES
|
||||
Domain/OS 10.3 (at least) native C 6.7 may need -opt 2 for eval.c
|
||||
AIX/RT may need a -a switch and -DCRIPPLED_CC.
|
||||
AIX RS/6000 needs to use system malloc and avoid -O on eval.c and toke.c.
|
||||
AIX RS/6000 needs -D_NO_PROTO.
|
||||
SUNOS 4.0.[12] needs -DFPUTS_BOTCH.
|
||||
SUNOS 3.[45] should use the system malloc.
|
||||
SGI machines may need -Ddouble="long float" and -O1.
|
||||
Vax-based systems may need to hand assemble teval.s with a -J switch.
|
||||
Ultrix on MIPS machines may need -DLANGUAGE_C.
|
||||
Ultrix 4.0 on MIPS machines may need -Olimit 2900 or so.
|
||||
Ultrix 3.[01] on MIPS needs to undefine WAITPID--the system call is busted.
|
||||
MIPS machines need /bin before /bsd43/bin in PATH.
|
||||
MIPS machines may need to undef d_volatile.
|
||||
MIPS machines may need to turn off -O on cmd.c, perl.c and tperl.c.
|
||||
Some MIPS machines may need to undefine CASTNEGFLOAT.
|
||||
Xenix 386 needs -Sm11000 for yacc, and may need -UM_I86.
|
||||
SCO Xenix may need -m25000 for yacc. See also README.xenix.
|
||||
Genix needs to use libc rather than libc_s, or #undef VARARGS.
|
||||
NCR Tower 32 (OS 2.01.01) may need -W2,-Sl,2000 and #undef MKDIR.
|
||||
A/UX may appears to work with -O -B/usr/lib/big/ optimizer flags.
|
||||
A/UX needs -lposix to find rewinddir.
|
||||
A/UX may need -ZP -DPOSIX, and -g if big cc is used.
|
||||
FPS machines may need -J and -DBADSWITCH.
|
||||
UTS may need one or more of -DCRIPPLED_CC, -K or -g, and undef LSTAT.
|
||||
dynix may need to undefine CASTNEGFLOAT (d_castneg='undef' in config.sh).
|
||||
Dnix (not dynix) may need to remove -O.
|
||||
IRIX 3.3 may need to undefine VFORK.
|
||||
HP/UX may need to pull cerror.o and syscall.o out of libc.a and link
|
||||
them in explicitly.
|
||||
If you get syntax errors on '(', try -DCRIPPLED_CC or -DBADSWITCH or both.
|
||||
Machines with half-implemented dbm routines will need to #undef ODBM & NDBM.
|
||||
If you have GDBM available and want it instead of NDBM, say -DHAS_GDBM.
|
||||
C's that don't try to restore registers on longjmp() may need -DJMPCLOBBER.
|
||||
(Try this if you get random glitches.)
|
||||
If you get duplicates upon linking for malloc et al, say -DHIDEMYMALLOC.
|
||||
Turn on support for 64-bit integers (long longs) with -DQUAD.
|
||||
|
||||
5) make test
|
||||
|
||||
This will run the regression tests on the perl you just made.
|
||||
If it doesn't say "All tests successful" then something went wrong.
|
||||
See the README in the t subdirectory. Note that you can't run it
|
||||
in background if this disables opening of /dev/tty. If "make test"
|
||||
bombs out, just cd to the t directory and run TEST by hand to see if
|
||||
it makes any difference. If individual tests bomb, you can run
|
||||
them by hand, e.g., ./perl op/groups.t
|
||||
|
||||
6) make install
|
||||
|
||||
This will put perl into a public directory (such as /usr/local/bin).
|
||||
It will also try to put the man pages in a reasonable place. It will not
|
||||
nroff the man page, however. You may need to be root to do this. If
|
||||
you are not root, you must own the directories in question and you should
|
||||
ignore any messages about chown not working.
|
||||
|
||||
7) Read the manual entry before running perl.
|
||||
|
||||
8) IMPORTANT! Help save the world! Communicate any problems and suggested
|
||||
patches to me, lwall@netlabs.com (Larry Wall), so we can
|
||||
keep the world in sync. If you have a problem, there's someone else
|
||||
out there who either has had or will have the same problem.
|
||||
|
||||
If possible, send in patches such that the patch program will apply them.
|
||||
Context diffs are the best, then normal diffs. Don't send ed scripts--
|
||||
I've probably changed my copy since the version you have. It's also
|
||||
helpful if you send the output of "uname -a".
|
||||
|
||||
Watch for perl patches in comp.lang.perl. Patches will generally be
|
||||
in a form usable by the patch program. If you are just now bringing up
|
||||
perl and aren't sure how many patches there are, write to me and I'll
|
||||
send any you don't have. Your current patch level is shown in patchlevel.h.
|
||||
|
||||
|
||||
Just a personal note: I want you to know that I create nice things like this
|
||||
because it pleases the Author of my story. If this bothers you, then your
|
||||
notion of Authorship needs some revision. But you can use perl anyway. :-)
|
||||
|
||||
The author.
|
||||
|
|
@ -1 +0,0 @@
|
|||
Perl 4.0 patchlevel 36
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
built-in cpp
|
||||
perl to C translator
|
||||
multi-threading
|
||||
make more easily embeddable
|
||||
built-in globbing
|
||||
compile to threaded code
|
||||
rewrite regexp parser for better integrated optimization
|
||||
add structured types and objects
|
||||
allow for lexical scoping
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/ADB,v 1.1.1.1 1993/08/23 21:29:43 nate Exp $
|
||||
|
||||
# This script is only useful when used in your crash directory.
|
||||
|
||||
$num = shift;
|
||||
exec 'adb', '-k', "vmunix.$num", "vmcore.$num";
|
||||
|
|
@ -1,22 +0,0 @@
|
|||
Although supplied with the perl package, the perl scripts in this eg
|
||||
directory and its subdirectories are placed in the public domain, and
|
||||
you may do anything with them that you wish.
|
||||
|
||||
This stuff is supplied on an as-is basis--little attempt has been made to make
|
||||
any of it portable. It's mostly here to give you an idea of what perl code
|
||||
looks like, and what tricks and idioms are used.
|
||||
|
||||
System administrators responsible for many computers will enjoy the items
|
||||
down in the g directory very much. The scan directory contains the beginnings
|
||||
of a system to check on and report various kinds of anomalies.
|
||||
|
||||
If you machine doesn't support #!, the first thing you'll want to do is
|
||||
replace the #! with a couple of lines that look like this:
|
||||
|
||||
eval "exec /usr/bin/perl -S $0 $*"
|
||||
if $running_under_some_shell;
|
||||
|
||||
being sure to include any flags that were on the #! line. A supplied script
|
||||
called "nih" will translate perl scripts in place for you:
|
||||
|
||||
nih g/g??
|
||||
|
|
@ -1,34 +0,0 @@
|
|||
#!/usr/bin/perl -P
|
||||
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/changes,v 1.1.1.1 1993/08/23 21:29:43 nate Exp $
|
||||
|
||||
($dir, $days) = @ARGV;
|
||||
$dir = '/' if $dir eq '';
|
||||
$days = '14' if $days eq '';
|
||||
|
||||
# Masscomps do things differently from Suns
|
||||
|
||||
#if defined(mc300) || defined(mc500) || defined(mc700)
|
||||
open(Find, "find $dir -mtime -$days -print |") ||
|
||||
die "changes: can't run find";
|
||||
#else
|
||||
open(Find, "find $dir \\( -fstype nfs -prune \\) -o -mtime -$days -ls |") ||
|
||||
die "changes: can't run find";
|
||||
#endif
|
||||
|
||||
while (<Find>) {
|
||||
|
||||
#if defined(mc300) || defined(mc500) || defined(mc700)
|
||||
$x = `/bin/ls -ild $_`;
|
||||
$_ = $x;
|
||||
($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
|
||||
= split(' ');
|
||||
#else
|
||||
($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
|
||||
= split(' ');
|
||||
#endif
|
||||
|
||||
printf("%10s%3s %-8s %-8s%9s %3s %2s %s\n",
|
||||
$perm,$links,$owner,$group,$size,$month,$day,$name);
|
||||
}
|
||||
|
||||
|
|
@ -1,34 +0,0 @@
|
|||
#!./perl
|
||||
|
||||
$pat = 'S n C4 x8';
|
||||
$inet = 2;
|
||||
$echo = 7;
|
||||
$smtp = 25;
|
||||
$nntp = 119;
|
||||
$test = 2345;
|
||||
|
||||
$SIG{'INT'} = 'dokill';
|
||||
|
||||
$this = pack($pat,$inet,0, 128,149,13,43);
|
||||
$that = pack($pat,$inet,$test,127,0,0,1);
|
||||
|
||||
if (socket(S,2,1,6)) { print "socket ok\n"; } else { die $!; }
|
||||
if (bind(S,$this)) { print "bind ok\n"; } else { die $!; }
|
||||
if (connect(S,$that)) { print "connect ok\n"; } else { die $!; }
|
||||
|
||||
select(S); $| = 1; select(stdout);
|
||||
|
||||
if ($child = fork) {
|
||||
while (<STDIN>) {
|
||||
print S;
|
||||
}
|
||||
sleep 3;
|
||||
do dokill();
|
||||
}
|
||||
else {
|
||||
while (<S>) {
|
||||
print;
|
||||
}
|
||||
}
|
||||
|
||||
sub dokill { kill 9,$child if $child; }
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
$| = 1;
|
||||
if ($#ARGV >= 0) {
|
||||
$cmd = join(' ',@ARGV);
|
||||
}
|
||||
else {
|
||||
print "Command: ";
|
||||
$cmd = <stdin>;
|
||||
chop($cmd);
|
||||
while ($cmd =~ s/\\$//) {
|
||||
print "+ ";
|
||||
$cmd .= <stdin>;
|
||||
chop($cmd);
|
||||
}
|
||||
}
|
||||
$cwd = `pwd`; chop($cwd);
|
||||
|
||||
open(FIND,'find . -type d -print|') || die "Can't run find";
|
||||
|
||||
while (<FIND>) {
|
||||
chop;
|
||||
unless (chdir $_) {
|
||||
print stderr "Can't cd to $_\n";
|
||||
next;
|
||||
}
|
||||
print "\t--> ",$_,"\n";
|
||||
system $cmd;
|
||||
chdir $cwd;
|
||||
}
|
||||
|
|
@ -1,22 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/dus,v 1.1.1.1 1993/08/23 21:29:43 nate Exp $
|
||||
|
||||
# This script does a du -s on any directories in the current directory that
|
||||
# are not mount points for another filesystem.
|
||||
|
||||
($mydev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
|
||||
$blksize,$blocks) = stat('.');
|
||||
|
||||
open(ls,'ls -F1|');
|
||||
|
||||
while (<ls>) {
|
||||
chop;
|
||||
next unless s|/$||;
|
||||
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
|
||||
$blksize,$blocks) = stat($_);
|
||||
next unless $dev == $mydev;
|
||||
push(@ary,$_);
|
||||
}
|
||||
|
||||
exec 'du', '-s', @ary;
|
||||
|
|
@ -1,53 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/findcp,v 1.1.1.1 1993/08/23 21:29:43 nate Exp $
|
||||
|
||||
# This is a wrapper around the find command that pretends find has a switch
|
||||
# of the form -cp host:destination. It presumes your find implements -ls.
|
||||
# It uses tar to do the actual copy. If your tar knows about the I switch
|
||||
# you may prefer to use findtar, since this one has to do the tar in batches.
|
||||
|
||||
sub copy {
|
||||
`tar cf - $list | rsh $desthost cd $destdir '&&' tar xBpf -`;
|
||||
}
|
||||
|
||||
$sourcedir = $ARGV[0];
|
||||
if ($sourcedir =~ /^\//) {
|
||||
$ARGV[0] = '.';
|
||||
unless (chdir($sourcedir)) { die "Can't find directory $sourcedir: $!"; }
|
||||
}
|
||||
|
||||
$args = join(' ',@ARGV);
|
||||
if ($args =~ s/-cp *([^ ]+)/-ls/) {
|
||||
$dest = $1;
|
||||
if ($dest =~ /(.*):(.*)/) {
|
||||
$desthost = $1;
|
||||
$destdir = $2;
|
||||
}
|
||||
else {
|
||||
die "Malformed destination--should be host:directory";
|
||||
}
|
||||
}
|
||||
else {
|
||||
die("No destination specified");
|
||||
}
|
||||
|
||||
open(find,"find $args |") || die "Can't run find for you: $!";
|
||||
|
||||
while (<find>) {
|
||||
@x = split(' ');
|
||||
if ($x[2] =~ /^d/) { next;}
|
||||
chop($filename = $x[10]);
|
||||
if (length($list) > 5000) {
|
||||
do copy();
|
||||
$list = '';
|
||||
}
|
||||
else {
|
||||
$list .= ' ';
|
||||
}
|
||||
$list .= $filename;
|
||||
}
|
||||
|
||||
if ($list) {
|
||||
do copy();
|
||||
}
|
||||
|
|
@ -1,17 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/findtar,v 1.1.1.1 1993/08/23 21:29:43 nate Exp $
|
||||
|
||||
# findtar takes find-style arguments and spits out a tarfile on stdout.
|
||||
# It won't work unless your find supports -ls and your tar the I flag.
|
||||
|
||||
$args = join(' ',@ARGV);
|
||||
open(find,"/usr/bin/find $args -ls |") || die "Can't run find for you.";
|
||||
|
||||
open(tar,"| /bin/tar cIf - -") || die "Can't run tar for you: $!";
|
||||
|
||||
while (<find>) {
|
||||
@x = split(' ');
|
||||
if ($x[2] =~ /^d/) { print tar '-d ';}
|
||||
print tar $x[10],"\n";
|
||||
}
|
||||
|
|
@ -1,114 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/g/gcp,v 1.1.1.1 1993/08/23 21:29:44 nate Exp $
|
||||
|
||||
# Here is a script to do global rcps. See man page.
|
||||
|
||||
$#ARGV >= 1 || die "Not enough arguments.\n";
|
||||
|
||||
if ($ARGV[0] eq '-r') {
|
||||
$rcp = 'rcp -r';
|
||||
shift;
|
||||
} else {
|
||||
$rcp = 'rcp';
|
||||
}
|
||||
$args = $rcp;
|
||||
$dest = $ARGV[$#ARGV];
|
||||
|
||||
$SIG{'QUIT'} = 'CLEANUP';
|
||||
$SIG{'INT'} = 'CONT';
|
||||
|
||||
while ($arg = shift) {
|
||||
if ($arg =~ /^([-a-zA-Z0-9_+]+):/) {
|
||||
if ($systype && $systype ne $1) {
|
||||
die "Can't mix system type specifers ($systype vs $1).\n";
|
||||
}
|
||||
$#ARGV < 0 || $arg !~ /:$/ || die "No source file specified.\n";
|
||||
$systype = $1;
|
||||
$args .= " $arg";
|
||||
} else {
|
||||
if ($#ARGV >= 0) {
|
||||
if ($arg =~ /^[\/~]/) {
|
||||
$arg =~ /^(.*)\// && ($dir = $1);
|
||||
} else {
|
||||
if (!$pwd) {
|
||||
chop($pwd = `pwd`);
|
||||
}
|
||||
$dir = $pwd;
|
||||
}
|
||||
}
|
||||
if ($olddir && $dir ne $olddir && $dest =~ /:$/) {
|
||||
$args .= " $dest$olddir; $rcp";
|
||||
}
|
||||
$olddir = $dir;
|
||||
$args .= " $arg";
|
||||
}
|
||||
}
|
||||
|
||||
die "No system type specified.\n" unless $systype;
|
||||
|
||||
$args =~ s/:$/:$olddir/;
|
||||
|
||||
chop($thishost = `hostname`);
|
||||
|
||||
$one_of_these = ":$systype:";
|
||||
if ($systype =~ s/\+/[+]/g) {
|
||||
$one_of_these =~ s/\+/:/g;
|
||||
}
|
||||
$one_of_these =~ s/-/:-/g;
|
||||
|
||||
@ARGV = ();
|
||||
push(@ARGV,'.grem') if -f '.grem';
|
||||
push(@ARGV,'.ghosts') if -f '.ghosts';
|
||||
push(@ARGV,'/etc/ghosts');
|
||||
|
||||
$remainder = '';
|
||||
|
||||
line: while (<>) {
|
||||
s/[ \t]*\n//;
|
||||
if (!$_ || /^#/) {
|
||||
next line;
|
||||
}
|
||||
if (/^([a-zA-Z_0-9]+)=(.+)/) {
|
||||
$name = $1; $repl = $2;
|
||||
$repl =~ s/\+/:/g;
|
||||
$repl =~ s/-/:-/g;
|
||||
$one_of_these =~ s/:$name:/:$repl:/;
|
||||
$repl =~ s/:/:-/g;
|
||||
$one_of_these =~ s/:-$name:/:-$repl:/g;
|
||||
next line;
|
||||
}
|
||||
@gh = split(' ');
|
||||
$host = $gh[0];
|
||||
next line if $host eq $thishost; # should handle aliases too
|
||||
$wanted = 0;
|
||||
foreach $class (@gh) {
|
||||
$wanted++ if index($one_of_these,":$class:") >= 0;
|
||||
$wanted = -9999 if index($one_of_these,":-$class:") >= 0;
|
||||
}
|
||||
if ($wanted > 0) {
|
||||
($cmd = $args) =~ s/[ \t]$systype:/ $host:/g;
|
||||
print "$cmd\n";
|
||||
$result = `$cmd 2>&1`;
|
||||
$remainder .= "$host+" if
|
||||
$result =~ /Connection timed out|Permission denied/;
|
||||
print $result;
|
||||
}
|
||||
}
|
||||
|
||||
if ($remainder) {
|
||||
chop($remainder);
|
||||
open(grem,">.grem") || (printf stderr "Can't create .grem: $!\n");
|
||||
print grem 'rem=', $remainder, "\n";
|
||||
close(grem);
|
||||
print 'rem=', $remainder, "\n";
|
||||
}
|
||||
|
||||
sub CLEANUP {
|
||||
exit;
|
||||
}
|
||||
|
||||
sub CONT {
|
||||
print "Continuing...\n"; # Just ignore the signal that kills rcp
|
||||
$remainder .= "$host+";
|
||||
}
|
||||
|
|
@ -1,77 +0,0 @@
|
|||
.\" $Header: /home/cvs/386BSD/ports/lang/perl/eg/g/gcp.man,v 1.1.1.1 1993/08/23 21:29:44 nate Exp $
|
||||
.TH GCP 1C "13 May 1988"
|
||||
.SH NAME
|
||||
gcp \- global file copy
|
||||
.SH SYNOPSIS
|
||||
.B gcp
|
||||
file1 file2
|
||||
.br
|
||||
.B gcp
|
||||
[
|
||||
.B \-r
|
||||
] file ... directory
|
||||
.SH DESCRIPTION
|
||||
.I gcp
|
||||
works just like rcp(1C) except that you may specify a set of hosts to copy files
|
||||
from or to.
|
||||
The host sets are defined in the file /etc/ghosts.
|
||||
(An individual host name can be used as a set containing one member.)
|
||||
You can give a command like
|
||||
|
||||
gcp /etc/motd sun:
|
||||
|
||||
to copy your /etc/motd file to /etc/motd on all the Suns.
|
||||
If, on the other hand, you say
|
||||
|
||||
gcp /a/foo /b/bar sun:/tmp
|
||||
|
||||
then your files will be copied to /tmp on all the Suns.
|
||||
The general rule is that if you don't specify the destination directory,
|
||||
files go to the same directory they are in currently.
|
||||
.P
|
||||
You may specify the union of two or more sets by using + as follows:
|
||||
|
||||
gcp /a/foo /b/bar 750+mc:
|
||||
|
||||
which will copy /a/foo to /a/foo on all 750's and Masscomps, and then copy
|
||||
/b/bar to /b/bar on all 750's and Masscomps.
|
||||
.P
|
||||
Commonly used sets should be defined in /etc/ghosts.
|
||||
For example, you could add a line that says
|
||||
|
||||
pep=manny+moe+jack
|
||||
|
||||
Another way to do that would be to add the word "pep" after each of the host
|
||||
entries:
|
||||
|
||||
manny sun3 pep
|
||||
.br
|
||||
moe sun3 pep
|
||||
.br
|
||||
jack sun3 pep
|
||||
|
||||
Hosts and sets of host can also be excluded:
|
||||
|
||||
foo=sun-sun2
|
||||
|
||||
Any host so excluded will never be included, even if a subsequent set on the
|
||||
line includes it:
|
||||
|
||||
foo=abc+def
|
||||
.br
|
||||
bar=xyz-abc+foo
|
||||
|
||||
comes out to xyz+def.
|
||||
|
||||
You can define private host sets by creating .ghosts in your current directory
|
||||
with entries just like /etc/ghosts.
|
||||
Also, if there is a file .grem, it defines "rem" to be the remaining hosts
|
||||
from the last gsh or gcp that didn't succeed everywhere.
|
||||
.PP
|
||||
Interrupting with a SIGINT will cause the rcp to the current host to be skipped
|
||||
and execution resumed with the next host.
|
||||
To stop completely, send a SIGQUIT.
|
||||
.SH SEE ALSO
|
||||
rcp(1C)
|
||||
.SH BUGS
|
||||
All the bugs of rcp, since it calls rcp.
|
||||
|
|
@ -1,21 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/g/ged,v 1.1.1.1 1993/08/23 21:29:44 nate Exp $
|
||||
|
||||
# Does inplace edits on a set of files on a set of machines.
|
||||
#
|
||||
# Typical invokation:
|
||||
#
|
||||
# ged vax+sun /etc/passwd
|
||||
# s/Freddy/Freddie/;
|
||||
# ^D
|
||||
#
|
||||
|
||||
$class = shift;
|
||||
$files = join(' ',@ARGV);
|
||||
|
||||
die "Usage: ged class files <perlcmds\n" unless $files;
|
||||
|
||||
exec "gsh", $class, "-d", "perl -pi.bak - $files";
|
||||
|
||||
die "Couldn't execute gsh for some reason, stopped";
|
||||
|
|
@ -1,33 +0,0 @@
|
|||
# This first section gives alternate sets defined in terms of the sets given
|
||||
# by the second section. The order is important--all references must be
|
||||
# forward references.
|
||||
|
||||
Nnd=sun-nd
|
||||
all=sun+mc+vax
|
||||
baseline=sun+mc
|
||||
sun=sun2+sun3
|
||||
vax=750+8600
|
||||
pep=manny+moe+jack
|
||||
|
||||
# This second section defines the basic sets. Each host should have a line
|
||||
# that specifies which sets it is a member of. Extra sets should be separated
|
||||
# by white space. (The first section isn't strictly necessary, since all sets
|
||||
# could be defined in the second section, but then it wouldn't be so readable.)
|
||||
|
||||
basvax 8600 src
|
||||
cdb0 sun3 sys
|
||||
cdb1 sun3 sys
|
||||
cdb2 sun3 sys
|
||||
chief sun3 src
|
||||
tis0 sun3
|
||||
manny sun3 sys
|
||||
moe sun3 sys
|
||||
jack sun3 sys
|
||||
disney sun3 sys
|
||||
huey sun3 nd
|
||||
dewey sun3 nd
|
||||
louie sun3 nd
|
||||
bizet sun2 src sys
|
||||
gif0 mc src
|
||||
mc0 mc
|
||||
dtv0 mc
|
||||
|
|
@ -1,117 +0,0 @@
|
|||
#! /usr/bin/perl
|
||||
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/g/gsh,v 1.1.1.1 1993/08/23 21:29:44 nate Exp $
|
||||
|
||||
# Do rsh globally--see man page
|
||||
|
||||
$SIG{'QUIT'} = 'quit'; # install signal handler for SIGQUIT
|
||||
|
||||
sub getswitches {
|
||||
while ($ARGV[0] =~ /^-/) { # parse switches
|
||||
$ARGV[0] =~ /^-h/ && ($showhost++,$silent++,shift(@ARGV),next);
|
||||
$ARGV[0] =~ /^-s/ && ($silent++,shift(@ARGV),next);
|
||||
$ARGV[0] =~ /^-d/ && ($dodist++,shift(@ARGV),next);
|
||||
$ARGV[0] =~ /^-n/ && ($n=' -n',shift(@ARGV),next);
|
||||
$ARGV[0] =~ /^-l/ && ($l=' -l ' . $ARGV[1],shift(@ARGV),shift(@ARGV),
|
||||
next);
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
do getswitches(); # get any switches before class
|
||||
$systype = shift; # get name representing set of hosts
|
||||
do getswitches(); # same switches allowed after class
|
||||
|
||||
if ($dodist) { # distribute input over all rshes?
|
||||
`cat >/tmp/gsh$$`; # get input into a handy place
|
||||
$dist = " </tmp/gsh$$"; # each rsh takes input from there
|
||||
}
|
||||
|
||||
$cmd = join(' ',@ARGV); # remaining args constitute the command
|
||||
$cmd =~ s/'/'"'"'/g; # quote any embedded single quotes
|
||||
|
||||
$one_of_these = ":$systype:"; # prepare to expand "macros"
|
||||
$one_of_these =~ s/\+/:/g; # we hope to end up with list of
|
||||
$one_of_these =~ s/-/:-/g; # colon separated attributes
|
||||
|
||||
@ARGV = ();
|
||||
push(@ARGV,'.grem') if -f '.grem';
|
||||
push(@ARGV,'.ghosts') if -f '.ghosts';
|
||||
push(@ARGV,'/etc/ghosts');
|
||||
|
||||
$remainder = '';
|
||||
|
||||
line: while (<>) { # for each line of ghosts
|
||||
|
||||
s/[ \t]*\n//; # trim trailing whitespace
|
||||
if (!$_ || /^#/) { # skip blank line or comment
|
||||
next line;
|
||||
}
|
||||
|
||||
if (/^(\w+)=(.+)/) { # a macro line?
|
||||
$name = $1; $repl = $2;
|
||||
$repl =~ s/\+/:/g;
|
||||
$repl =~ s/-/:-/g;
|
||||
$one_of_these =~ s/:$name:/:$repl:/; # do expansion in "wanted" list
|
||||
$repl =~ s/:/:-/g;
|
||||
$one_of_these =~ s/:-$name:/:-$repl:/;
|
||||
next line;
|
||||
}
|
||||
|
||||
# we have a normal line
|
||||
|
||||
@attr = split(' '); # a list of attributes to match against
|
||||
# which we put into an array
|
||||
$host = $attr[0]; # the first attribute is the host name
|
||||
if ($showhost) {
|
||||
$showhost = "$host:\t";
|
||||
}
|
||||
|
||||
$wanted = 0;
|
||||
foreach $attr (@attr) { # iterate over attribute array
|
||||
$wanted++ if index($one_of_these,":$attr:") >= 0;
|
||||
$wanted = -9999 if index($one_of_these,":-$attr:") >= 0;
|
||||
}
|
||||
if ($wanted > 0) {
|
||||
print "rsh $host$l$n '$cmd'\n" unless $silent;
|
||||
$SIG{'INT'} = 'DEFAULT';
|
||||
if (open(PIPE,"rsh $host$l$n '$cmd'$dist 2>&1|")) { # start an rsh
|
||||
$SIG{'INT'} = 'cont';
|
||||
for ($iter=0; <PIPE>; $iter++) {
|
||||
unless ($iter) {
|
||||
$remainder .= "$host+"
|
||||
if /Connection timed out|Permission denied/;
|
||||
}
|
||||
print $showhost,$_;
|
||||
}
|
||||
close(PIPE);
|
||||
} else {
|
||||
print "(Can't execute rsh: $!)\n";
|
||||
$SIG{'INT'} = 'cont';
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
unlink "/tmp/gsh$$" if $dodist;
|
||||
|
||||
if ($remainder) {
|
||||
chop($remainder);
|
||||
open(grem,">.grem") || (printf stderr "Can't make a .grem file: $!\n");
|
||||
print grem 'rem=', $remainder, "\n";
|
||||
close(grem);
|
||||
print 'rem=', $remainder, "\n";
|
||||
}
|
||||
|
||||
# here are a couple of subroutines that serve as signal handlers
|
||||
|
||||
sub cont {
|
||||
print "\rContinuing...\n";
|
||||
$remainder .= "$host+";
|
||||
}
|
||||
|
||||
sub quit {
|
||||
$| = 1;
|
||||
print "\r";
|
||||
$SIG{'INT'} = '';
|
||||
kill 2, $$;
|
||||
}
|
||||
|
|
@ -1,80 +0,0 @@
|
|||
.\" $Header: /home/cvs/386BSD/ports/lang/perl/eg/g/gsh.man,v 1.1.1.1 1993/08/23 21:29:44 nate Exp $
|
||||
.TH GSH 8 "13 May 1988"
|
||||
.SH NAME
|
||||
gsh \- global shell
|
||||
.SH SYNOPSIS
|
||||
.B gsh
|
||||
[options]
|
||||
.I host
|
||||
[options]
|
||||
.I command
|
||||
.SH DESCRIPTION
|
||||
.I gsh
|
||||
works just like rsh(1C) except that you may specify a set of hosts to execute
|
||||
the command on.
|
||||
The host sets are defined in the file /etc/ghosts.
|
||||
(An individual host name can be used as a set containing one member.)
|
||||
You can give a command like
|
||||
|
||||
gsh sun /etc/mungmotd
|
||||
|
||||
to run /etc/mungmotd on all your Suns.
|
||||
.P
|
||||
You may specify the union of two or more sets by using + as follows:
|
||||
|
||||
gsh 750+mc /etc/mungmotd
|
||||
|
||||
which will run mungmotd on all 750's and Masscomps.
|
||||
.P
|
||||
Commonly used sets should be defined in /etc/ghosts.
|
||||
For example, you could add a line that says
|
||||
|
||||
pep=manny+moe+jack
|
||||
|
||||
Another way to do that would be to add the word "pep" after each of the host
|
||||
entries:
|
||||
|
||||
manny sun3 pep
|
||||
.br
|
||||
moe sun3 pep
|
||||
.br
|
||||
jack sun3 pep
|
||||
|
||||
Hosts and sets of host can also be excluded:
|
||||
|
||||
foo=sun-sun2
|
||||
|
||||
Any host so excluded will never be included, even if a subsequent set on the
|
||||
line includes it:
|
||||
|
||||
foo=abc+def
|
||||
bar=xyz-abc+foo
|
||||
|
||||
comes out to xyz+def.
|
||||
|
||||
You can define private host sets by creating .ghosts in your current directory
|
||||
with entries just like /etc/ghosts.
|
||||
Also, if there is a file .grem, it defines "rem" to be the remaining hosts
|
||||
from the last gsh or gcp that didn't succeed everywhere.
|
||||
|
||||
Options include all those defined by rsh, as well as
|
||||
|
||||
.IP "\-d" 8
|
||||
Causes gsh to collect input till end of file, and then distribute that input
|
||||
to each invokation of rsh.
|
||||
.IP "\-h" 8
|
||||
Rather than print out the command followed by the output, merely prepends the
|
||||
host name to each line of output.
|
||||
.IP "\-s" 8
|
||||
Do work silently.
|
||||
.PP
|
||||
Interrupting with a SIGINT will cause the rsh to the current host to be skipped
|
||||
and execution resumed with the next host.
|
||||
To stop completely, send a SIGQUIT.
|
||||
.SH SEE ALSO
|
||||
rsh(1C)
|
||||
.SH BUGS
|
||||
All the bugs of rsh, since it calls rsh.
|
||||
|
||||
Also, will not properly return data from the remote execution that contains
|
||||
null characters.
|
||||
|
|
@ -1,141 +0,0 @@
|
|||
#!../perl
|
||||
|
||||
$M = '-M';
|
||||
$M = '-m' if -d '/usr/uts' && -f '/etc/master';
|
||||
|
||||
do 'getopt.pl';
|
||||
do Getopt('f');
|
||||
|
||||
if ($opt_f) {
|
||||
$makefile = $opt_f;
|
||||
}
|
||||
elsif (-f 'makefile') {
|
||||
$makefile = 'makefile';
|
||||
}
|
||||
elsif (-f 'Makefile') {
|
||||
$makefile = 'Makefile';
|
||||
}
|
||||
else {
|
||||
die "No makefile\n";
|
||||
}
|
||||
|
||||
$MF = 'mf00';
|
||||
|
||||
while(($key,$val) = each(ENV)) {
|
||||
$mac{$key} = $val;
|
||||
}
|
||||
|
||||
do scan($makefile);
|
||||
|
||||
$co = $action{'.c.o'};
|
||||
$co = ' ' unless $co;
|
||||
|
||||
$missing = "Missing dependencies:\n";
|
||||
foreach $key (sort keys(o)) {
|
||||
if ($oc{$key}) {
|
||||
$src = $oc{$key};
|
||||
$action = $action{$key};
|
||||
}
|
||||
else {
|
||||
$action = '';
|
||||
}
|
||||
if (!$action) {
|
||||
if ($co && ($c = $key) =~ s/\.o$/.c/ && -f $c) {
|
||||
$src = $c;
|
||||
$action = $co;
|
||||
}
|
||||
else {
|
||||
print "No source found for $key $c\n";
|
||||
next;
|
||||
}
|
||||
}
|
||||
$I = '';
|
||||
$D = '';
|
||||
$I .= $1 while $action =~ s/(-I\S+\s*)//;
|
||||
$D .= $1 . ' ' while $action =~ s/(-D\w+)//;
|
||||
if ($opt_v) {
|
||||
$cmd = "Checking $key: cc $M $D $I $src";
|
||||
$cmd =~ s/\s\s+/ /g;
|
||||
print stderr $cmd,"\n";
|
||||
}
|
||||
open(CPP,"cc $M $D $I $src|") || die "Can't run C preprocessor: $!";
|
||||
while (<CPP>) {
|
||||
($name,$dep) = split;
|
||||
$dep =~ s|^\./||;
|
||||
(print $missing,"$key: $dep\n"),($missing='')
|
||||
unless ($dep{"$key: $dep"} += 2) > 2;
|
||||
}
|
||||
}
|
||||
|
||||
$extra = "\nExtraneous dependencies:\n";
|
||||
foreach $key (sort keys(dep)) {
|
||||
if ($key =~ /\.o: .*\.h$/ && $dep{$key} == 1) {
|
||||
print $extra,$key,"\n";
|
||||
$extra = '';
|
||||
}
|
||||
}
|
||||
|
||||
sub scan {
|
||||
local($makefile) = @_;
|
||||
local($MF) = $MF;
|
||||
print stderr "Analyzing $makefile.\n" if $opt_v;
|
||||
$MF++;
|
||||
open($MF,$makefile) || die "Can't open $makefile: $!";
|
||||
while (<$MF>) {
|
||||
chop;
|
||||
chop($_ = $_ . <$MF>) while s/\\$//;
|
||||
next if /^#/;
|
||||
next if /^$/;
|
||||
s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg;
|
||||
s/\$\((\w+)\)/$mac{$1}/eg;
|
||||
$mac{$1} = $2, next if /^(\w+)\s*=\s*(.*)/;
|
||||
if (/^include\s+(.*)/) {
|
||||
do scan($1);
|
||||
print stderr "Continuing $makefile.\n" if $opt_v;
|
||||
next;
|
||||
}
|
||||
if (/^([^:]+):\s*(.*)/) {
|
||||
$left = $1;
|
||||
$right = $2;
|
||||
if ($right =~ /^([^;]*);(.*)/) {
|
||||
$right = $1;
|
||||
$action = $2;
|
||||
}
|
||||
else {
|
||||
$action = '';
|
||||
}
|
||||
while (<$MF>) {
|
||||
last unless /^\t/;
|
||||
chop;
|
||||
chop($_ = $_ . <$MF>) while s/\\$//;
|
||||
next if /^#/;
|
||||
last if /^$/;
|
||||
s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg;
|
||||
s/\$\((\w+)\)/$mac{$1}/eg;
|
||||
$action .= $_;
|
||||
}
|
||||
foreach $targ (split(' ',$left)) {
|
||||
$targ =~ s|^\./||;
|
||||
foreach $src (split(' ',$right)) {
|
||||
$src =~ s|^\./||;
|
||||
$deplist{$targ} .= ' ' . $src;
|
||||
$dep{"$targ: $src"} = 1;
|
||||
$o{$src} = 1 if $src =~ /\.o$/;
|
||||
$oc{$targ} = $src if $targ =~ /\.o$/ && $src =~ /\.[yc]$/;
|
||||
}
|
||||
$action{$targ} .= $action;
|
||||
}
|
||||
redo if $_;
|
||||
}
|
||||
}
|
||||
close($MF);
|
||||
}
|
||||
|
||||
sub subst {
|
||||
local($foo,$from,$to) = @_;
|
||||
$foo = $mac{$foo};
|
||||
$from =~ s/\./[.]/;
|
||||
y/a/a/;
|
||||
$foo =~ s/\b$from\b/$to/g;
|
||||
$foo;
|
||||
}
|
||||
|
|
@ -1,21 +0,0 @@
|
|||
.\" $Header: /home/cvs/386BSD/ports/lang/perl/eg/muck.man,v 1.1.1.1 1993/08/23 21:29:43 nate Exp $
|
||||
.TH MUCK 1 "10 Jan 1989"
|
||||
.SH NAME
|
||||
muck \- make usage checker
|
||||
.SH SYNOPSIS
|
||||
.B muck
|
||||
[options]
|
||||
.SH DESCRIPTION
|
||||
.I muck
|
||||
looks at your current makefile and complains if you've left out any dependencies
|
||||
between .o and .h files.
|
||||
It also complains about extraneous dependencies.
|
||||
.PP
|
||||
You can use the -f FILENAME option to specify an alternate name for your
|
||||
makefile.
|
||||
The -v option is a little more verbose about what muck is mucking around
|
||||
with at the moment.
|
||||
.SH SEE ALSO
|
||||
make(1)
|
||||
.SH BUGS
|
||||
Only knows about .h, .c and .o files.
|
||||
|
|
@ -1,29 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/myrup,v 1.1.1.1 1993/08/23 21:29:43 nate Exp $
|
||||
|
||||
# This was a customization of ruptime requested by someone here who wanted
|
||||
# to be able to find the least loaded machine easily. It uses the
|
||||
# /etc/ghosts file that's defined for gsh and gcp to prune down the
|
||||
# number of entries to those hosts we have administrative control over.
|
||||
|
||||
print "node load (u)\n------- --------\n";
|
||||
|
||||
open(ghosts,'/etc/ghosts') || die "Can't open /etc/ghosts: $!";
|
||||
line: while (<ghosts>) {
|
||||
next line if /^#/;
|
||||
next line if /^$/;
|
||||
next line if /=/;
|
||||
($host) = split;
|
||||
$wanted{$host} = 1;
|
||||
}
|
||||
|
||||
open(ruptime,'ruptime|') || die "Can't run ruptime: $!";
|
||||
open(sort,'|sort +1n');
|
||||
|
||||
while (<ruptime>) {
|
||||
($host,$upness,$foo,$users,$foo,$foo,$load) = split(/[\s,]+/);
|
||||
if ($wanted{$host} && $upness eq 'up') {
|
||||
printf sort "%s\t%s (%d)\n", $host, $load, $users;
|
||||
}
|
||||
}
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
eval "exec /usr/bin/perl -Spi.bak $0 $*"
|
||||
if $running_under_some_shell;
|
||||
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/nih,v 1.1.1.1 1993/08/23 21:29:43 nate Exp $
|
||||
|
||||
# This script makes #! scripts directly executable on machines that don't
|
||||
# support #!. It edits in place any scripts mentioned on the command line.
|
||||
|
||||
s|^#!(.*)|#!$1\neval "exec $1 -S \$0 \$*"\n\tif \$running_under_some_shell;|
|
||||
if $. == 1;
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
# Poor man's perl shell.
|
||||
|
||||
# Simply type two carriage returns every time you want to evaluate.
|
||||
# Note that it must be a complete perl statement--don't type double
|
||||
# carriage return in the middle of a loop.
|
||||
|
||||
$/ = "\n\n"; # set paragraph mode
|
||||
$SHlinesep = "\n";
|
||||
while ($SHcmd = <>) {
|
||||
$/ = $SHlinesep;
|
||||
eval $SHcmd; print $@ || "\n";
|
||||
$SHlinesep = $/; $/ = '';
|
||||
}
|
||||
|
|
@ -1,91 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
'di';
|
||||
'ig00';
|
||||
#
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/relink,v 1.1.1.1 1993/08/23 21:29:43 nate Exp $
|
||||
#
|
||||
# $Log: relink,v $
|
||||
# Revision 1.1.1.1 1993/08/23 21:29:43 nate
|
||||
# PERL!
|
||||
#
|
||||
# Revision 4.0 91/03/20 01:11:40 lwall
|
||||
# 4.0 baseline.
|
||||
#
|
||||
# Revision 3.0.1.2 90/08/09 03:17:44 lwall
|
||||
# patch19: added man page for relink and rename
|
||||
#
|
||||
|
||||
($op = shift) || die "Usage: relink perlexpr [filenames]\n";
|
||||
if (!@ARGV) {
|
||||
@ARGV = <STDIN>;
|
||||
chop(@ARGV);
|
||||
}
|
||||
for (@ARGV) {
|
||||
next unless -l; # symbolic link?
|
||||
$name = $_;
|
||||
$_ = readlink($_);
|
||||
$was = $_;
|
||||
eval $op;
|
||||
die $@ if $@;
|
||||
if ($was ne $_) {
|
||||
unlink($name);
|
||||
symlink($_, $name);
|
||||
}
|
||||
}
|
||||
##############################################################################
|
||||
|
||||
# These next few lines are legal in both Perl and nroff.
|
||||
|
||||
.00; # finish .ig
|
||||
|
||||
'di \" finish diversion--previous line must be blank
|
||||
.nr nl 0-1 \" fake up transition to first page again
|
||||
.nr % 0 \" start at page 1
|
||||
';<<'.ex'; #__END__ ############# From here on it's a standard manual page ############
|
||||
.TH RELINK 1 "July 30, 1990"
|
||||
.AT 3
|
||||
.SH LINK
|
||||
relink \- relinks multiple symbolic links
|
||||
.SH SYNOPSIS
|
||||
.B relink perlexpr [symlinknames]
|
||||
.SH DESCRIPTION
|
||||
.I Relink
|
||||
relinks the symbolic links given according to the rule specified as the
|
||||
first argument.
|
||||
The argument is a Perl expression which is expected to modify the $_
|
||||
string in Perl for at least some of the names specified.
|
||||
For each symbolic link named on the command line, the Perl expression
|
||||
will be executed on the contents of the symbolic link with that name.
|
||||
If a given symbolic link's contents is not modified by the expression,
|
||||
it will not be changed.
|
||||
If a name given on the command line is not a symbolic link, it will be ignored.
|
||||
If no names are given on the command line, names will be read
|
||||
via standard input.
|
||||
.PP
|
||||
For example, to relink all symbolic links in the current directory
|
||||
pointing to somewhere in X11R3 so that they point to X11R4, you might say
|
||||
.nf
|
||||
|
||||
relink 's/X11R3/X11R4/' *
|
||||
|
||||
.fi
|
||||
To change all occurences of links in the system from /usr/spool to /var/spool,
|
||||
you'd say
|
||||
.nf
|
||||
|
||||
find / -type l -print | relink 's#/usr/spool#/var/spool#'
|
||||
|
||||
.fi
|
||||
.SH ENVIRONMENT
|
||||
No environment variables are used.
|
||||
.SH FILES
|
||||
.SH AUTHOR
|
||||
Larry Wall
|
||||
.SH "SEE ALSO"
|
||||
ln(1)
|
||||
.br
|
||||
perl(1)
|
||||
.SH DIAGNOSTICS
|
||||
If you give an invalid Perl expression you'll get a syntax error.
|
||||
.SH BUGS
|
||||
.ex
|
||||
|
|
@ -1,83 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
'di';
|
||||
'ig00';
|
||||
#
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/rename,v 1.1.1.1 1993/08/23 21:29:43 nate Exp $
|
||||
#
|
||||
# $Log: rename,v $
|
||||
# Revision 1.1.1.1 1993/08/23 21:29:43 nate
|
||||
# PERL!
|
||||
#
|
||||
# Revision 4.0 91/03/20 01:11:53 lwall
|
||||
# 4.0 baseline.
|
||||
#
|
||||
# Revision 3.0.1.2 90/08/09 03:17:57 lwall
|
||||
# patch19: added man page for relink and rename
|
||||
#
|
||||
|
||||
($op = shift) || die "Usage: rename perlexpr [filenames]\n";
|
||||
if (!@ARGV) {
|
||||
@ARGV = <STDIN>;
|
||||
chop(@ARGV);
|
||||
}
|
||||
for (@ARGV) {
|
||||
$was = $_;
|
||||
eval $op;
|
||||
die $@ if $@;
|
||||
rename($was,$_) unless $was eq $_;
|
||||
}
|
||||
##############################################################################
|
||||
|
||||
# These next few lines are legal in both Perl and nroff.
|
||||
|
||||
.00; # finish .ig
|
||||
|
||||
'di \" finish diversion--previous line must be blank
|
||||
.nr nl 0-1 \" fake up transition to first page again
|
||||
.nr % 0 \" start at page 1
|
||||
';<<'.ex'; #__END__ ############# From here on it's a standard manual page ############
|
||||
.TH RENAME 1 "July 30, 1990"
|
||||
.AT 3
|
||||
.SH NAME
|
||||
rename \- renames multiple files
|
||||
.SH SYNOPSIS
|
||||
.B rename perlexpr [files]
|
||||
.SH DESCRIPTION
|
||||
.I Rename
|
||||
renames the filenames supplied according to the rule specified as the
|
||||
first argument.
|
||||
The argument is a Perl expression which is expected to modify the $_
|
||||
string in Perl for at least some of the filenames specified.
|
||||
If a given filename is not modified by the expression, it will not be
|
||||
renamed.
|
||||
If no filenames are given on the command line, filenames will be read
|
||||
via standard input.
|
||||
.PP
|
||||
For example, to rename all files matching *.bak to strip the extension,
|
||||
you might say
|
||||
.nf
|
||||
|
||||
rename 's/\e.bak$//' *.bak
|
||||
|
||||
.fi
|
||||
To translate uppercase names to lower, you'd use
|
||||
.nf
|
||||
|
||||
rename 'y/A-Z/a-z/' *
|
||||
|
||||
.fi
|
||||
.SH ENVIRONMENT
|
||||
No environment variables are used.
|
||||
.SH FILES
|
||||
.SH AUTHOR
|
||||
Larry Wall
|
||||
.SH "SEE ALSO"
|
||||
mv(1)
|
||||
.br
|
||||
perl(1)
|
||||
.SH DIAGNOSTICS
|
||||
If you give an invalid Perl expression you'll get a syntax error.
|
||||
.SH BUGS
|
||||
.I Rename
|
||||
does not check for the existence of target filenames, so use with care.
|
||||
.ex
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
#!/usr/bin/perl -n
|
||||
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/rmfrom,v 1.1.1.1 1993/08/23 21:29:43 nate Exp $
|
||||
|
||||
# A handy (but dangerous) script to put after a find ... -print.
|
||||
|
||||
chop; unlink;
|
||||
|
|
@ -1,51 +0,0 @@
|
|||
#!/usr/bin/perl -P
|
||||
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/scan/scan_df,v 1.1.1.1 1993/08/23 21:29:44 nate Exp $
|
||||
|
||||
# This report points out filesystems that are in danger of overflowing.
|
||||
|
||||
(chdir '/usr/adm/private/memories') || die "Can't cd to memories: $!\n";
|
||||
`df >newdf`;
|
||||
open(Df, 'olddf');
|
||||
|
||||
while (<Df>) {
|
||||
($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split;
|
||||
next if $fs =~ /:/;
|
||||
next if $fs eq '';
|
||||
$oldused{$fs} = $used;
|
||||
}
|
||||
|
||||
open(Df, 'newdf') || die "scan_df: can't open newdf";
|
||||
|
||||
while (<Df>) {
|
||||
($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split;
|
||||
next if $fs =~ /:/;
|
||||
next if $fs eq '';
|
||||
$oldused = $oldused{$fs};
|
||||
next if ($oldused == $used && $capacity < 99); # inactive filesystem
|
||||
if ($capacity >= 90) {
|
||||
#if defined(mc300) || defined(mc500) || defined(mc700)
|
||||
$_ = substr($_,0,13) . ' ' . substr($_,13,1000);
|
||||
$kbytes /= 2; # translate blocks to K
|
||||
$used /= 2;
|
||||
$oldused /= 2;
|
||||
$avail /= 2;
|
||||
#endif
|
||||
$diff = int($used - $oldused);
|
||||
if ($avail < $diff * 2) { # mark specially if in danger
|
||||
$mounted_on .= ' *';
|
||||
}
|
||||
next if $diff < 50 && $mounted_on eq '/';
|
||||
$fs =~ s|/dev/||;
|
||||
if ($diff >= 0) {
|
||||
$diff = '(+' . $diff . ')';
|
||||
}
|
||||
else {
|
||||
$diff = '(' . $diff . ')';
|
||||
}
|
||||
printf "%-8s%8d%8d %-8s%8d%7s %s\n",
|
||||
$fs,$kbytes,$used,$diff,$avail,$capacity,$mounted_on;
|
||||
}
|
||||
}
|
||||
|
||||
rename('newdf','olddf');
|
||||
|
|
@ -1,57 +0,0 @@
|
|||
#!/usr/bin/perl -P
|
||||
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/scan/scan_last,v 1.1.1.1 1993/08/23 21:29:45 nate Exp $
|
||||
|
||||
# This reports who was logged on at weird hours
|
||||
|
||||
($dy, $mo, $lastdt) = split(/ +/,`date`);
|
||||
|
||||
open(Last, 'exec last 2>&1 |') || die "scan_last: can't run last";
|
||||
|
||||
while (<Last>) {
|
||||
#if defined(mc300) || defined(mc500) || defined(mc700)
|
||||
$_ = substr($_,0,19) . substr($_,23,100);
|
||||
#endif
|
||||
next if /^$/;
|
||||
(print),next if m|^/|;
|
||||
$login = substr($_,0,8);
|
||||
$tty = substr($_,10,7);
|
||||
$from = substr($_,19,15);
|
||||
$day = substr($_,36,3);
|
||||
$mo = substr($_,40,3);
|
||||
$dt = substr($_,44,2);
|
||||
$hr = substr($_,47,2);
|
||||
$min = substr($_,50,2);
|
||||
$dash = substr($_,53,1);
|
||||
$tohr = substr($_,55,2);
|
||||
$tomin = substr($_,58,2);
|
||||
$durhr = substr($_,63,2);
|
||||
$durmin = substr($_,66,2);
|
||||
|
||||
next unless $hr;
|
||||
next if $login eq 'reboot ';
|
||||
next if $login eq 'shutdown';
|
||||
|
||||
if ($dt != $lastdt) {
|
||||
if ($lastdt < $dt) {
|
||||
$seen += $dt - $lastdt;
|
||||
}
|
||||
else {
|
||||
$seen++;
|
||||
}
|
||||
$lastdt = $dt;
|
||||
}
|
||||
|
||||
$inat = $hr + $min / 60;
|
||||
if ($tohr =~ /^[a-z]/) {
|
||||
$outat = 12; # something innocuous
|
||||
} else {
|
||||
$outat = $tohr + $tomin / 60;
|
||||
}
|
||||
|
||||
last if $seen + ($inat < 8) > 1;
|
||||
|
||||
if ($inat < 5 || $inat > 21 || $outat < 6 || $outat > 23) {
|
||||
print;
|
||||
}
|
||||
}
|
||||
|
|
@ -1,222 +0,0 @@
|
|||
#!/usr/bin/perl -P
|
||||
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/scan/scan_messages,v 1.1.1.1 1993/08/23 21:29:44 nate Exp $
|
||||
|
||||
# This prints out extraordinary console messages. You'll need to customize.
|
||||
|
||||
chdir('/usr/adm/private/memories') || die "Can't cd to memories: $!\n";
|
||||
|
||||
$maxpos = `cat oldmsgs 2>&1`;
|
||||
|
||||
#if defined(mc300) || defined(mc500) || defined(mc700)
|
||||
open(Msgs, '/dev/null') || die "scan_messages: can't open messages";
|
||||
#else
|
||||
open(Msgs, '/usr/adm/messages') || die "scan_messages: can't open messages";
|
||||
#endif
|
||||
|
||||
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
|
||||
$blksize,$blocks) = stat(Msgs);
|
||||
|
||||
if ($size < $maxpos) { # Did somebody truncate messages file?
|
||||
$maxpos = 0;
|
||||
}
|
||||
|
||||
seek(Msgs,$maxpos,0); # Start where we left off last time.
|
||||
|
||||
while (<Msgs>) {
|
||||
s/\[(\d+)\]/#/ && s/$1/#/g;
|
||||
#ifdef vax
|
||||
$_ =~ s/[A-Z][a-z][a-z] +\w+ +[0-9:]+ +\w+ +//;
|
||||
next if /root@.*:/;
|
||||
next if /^vmunix: 4.3 BSD UNIX/;
|
||||
next if /^vmunix: Copyright/;
|
||||
next if /^vmunix: avail mem =/;
|
||||
next if /^vmunix: SBIA0 at /;
|
||||
next if /^vmunix: disk ra81 is/;
|
||||
next if /^vmunix: dmf. at uba/;
|
||||
next if /^vmunix: dmf.:.*asynch/;
|
||||
next if /^vmunix: ex. at uba/;
|
||||
next if /^vmunix: ex.: HW/;
|
||||
next if /^vmunix: il. at uba/;
|
||||
next if /^vmunix: il.: hardware/;
|
||||
next if /^vmunix: ra. at uba/;
|
||||
next if /^vmunix: ra.: media/;
|
||||
next if /^vmunix: real mem/;
|
||||
next if /^vmunix: syncing disks/;
|
||||
next if /^vmunix: tms/;
|
||||
next if /^vmunix: tmscp. at uba/;
|
||||
next if /^vmunix: uba. at /;
|
||||
next if /^vmunix: uda. at /;
|
||||
next if /^vmunix: uda.: unit . ONLIN/;
|
||||
next if /^vmunix: .*buffers containing/;
|
||||
next if /^syslogd: .*newslog/;
|
||||
#endif
|
||||
next if /unknown service/;
|
||||
next if /^\.\.\.$/;
|
||||
if (/^[A-Z][a-z][a-z] [ 0-9][0-9] [ 0-9][0-9]:[0-9][0-9]/) {
|
||||
$pfx = '';
|
||||
next;
|
||||
}
|
||||
next if /^[ \t]*$/;
|
||||
next if /^[ 0-9]*done$/;
|
||||
if (/^A/) {
|
||||
next if /^Accounting [sr]/;
|
||||
}
|
||||
elsif (/^C/) {
|
||||
next if /^Called from/;
|
||||
next if /^Copyright/;
|
||||
}
|
||||
elsif (/^E/) {
|
||||
next if /^End traceback/;
|
||||
next if /^Ethernet address =/;
|
||||
}
|
||||
elsif (/^K/) {
|
||||
next if /^KERNEL MODE/;
|
||||
}
|
||||
elsif (/^R/) {
|
||||
next if /^Rebooting Unix/;
|
||||
}
|
||||
elsif (/^S/) {
|
||||
next if /^Sun UNIX 4\.2 Release/;
|
||||
}
|
||||
elsif (/^W/) {
|
||||
next if /^WARNING: clock gained/;
|
||||
}
|
||||
elsif (/^a/) {
|
||||
next if /^arg /;
|
||||
next if /^avail mem =/;
|
||||
}
|
||||
elsif (/^b/) {
|
||||
next if /^bwtwo[0-9] at /;
|
||||
}
|
||||
elsif (/^c/) {
|
||||
next if /^cgone[0-9] at /;
|
||||
next if /^cdp[0-9] at /;
|
||||
next if /^csr /;
|
||||
}
|
||||
elsif (/^d/) {
|
||||
next if /^dcpa: init/;
|
||||
next if /^done$/;
|
||||
next if /^dts/;
|
||||
next if /^dump i\/o error/;
|
||||
next if /^dumping to dev/;
|
||||
next if /^dump succeeded/;
|
||||
$pfx = '*' if /^dev = /;
|
||||
}
|
||||
elsif (/^e/) {
|
||||
next if /^end \*\*/;
|
||||
next if /^error in copy/;
|
||||
}
|
||||
elsif (/^f/) {
|
||||
next if /^found /;
|
||||
}
|
||||
elsif (/^i/) {
|
||||
next if /^ib[0-9] at /;
|
||||
next if /^ie[0-9] at /;
|
||||
}
|
||||
elsif (/^l/) {
|
||||
next if /^le[0-9] at /;
|
||||
}
|
||||
elsif (/^m/) {
|
||||
next if /^mem = /;
|
||||
next if /^mt[0-9] at /;
|
||||
next if /^mti[0-9] at /;
|
||||
$pfx = '*' if /^mode = /;
|
||||
}
|
||||
elsif (/^n/) {
|
||||
next if /^not found /;
|
||||
}
|
||||
elsif (/^p/) {
|
||||
next if /^page map /;
|
||||
next if /^pi[0-9] at /;
|
||||
$pfx = '*' if /^panic/;
|
||||
}
|
||||
elsif (/^q/) {
|
||||
next if /^qqq /;
|
||||
}
|
||||
elsif (/^r/) {
|
||||
next if /^read /;
|
||||
next if /^revarp: Requesting/;
|
||||
next if /^root [od]/;
|
||||
}
|
||||
elsif (/^s/) {
|
||||
next if /^sc[0-9] at /;
|
||||
next if /^sd[0-9] at /;
|
||||
next if /^sd[0-9]: </;
|
||||
next if /^si[0-9] at /;
|
||||
next if /^si_getstatus/;
|
||||
next if /^sk[0-9] at /;
|
||||
next if /^skioctl/;
|
||||
next if /^skopen/;
|
||||
next if /^skprobe/;
|
||||
next if /^skread/;
|
||||
next if /^skwrite/;
|
||||
next if /^sky[0-9] at /;
|
||||
next if /^st[0-9] at /;
|
||||
next if /^st0:.*load/;
|
||||
next if /^stat1 = /;
|
||||
next if /^syncing disks/;
|
||||
next if /^syslogd: going down on signal 15/;
|
||||
}
|
||||
elsif (/^t/) {
|
||||
next if /^timeout [0-9]/;
|
||||
next if /^tm[0-9] at /;
|
||||
next if /^tod[0-9] at /;
|
||||
next if /^tv [0-9]/;
|
||||
$pfx = '*' if /^trap address/;
|
||||
}
|
||||
elsif (/^u/) {
|
||||
next if /^unit nsk/;
|
||||
next if /^use one of/;
|
||||
$pfx = '' if /^using/;
|
||||
next if /^using [0-9]+ buffers/;
|
||||
}
|
||||
elsif (/^x/) {
|
||||
next if /^xy[0-9] at /;
|
||||
next if /^write [0-9]/;
|
||||
next if /^xy[0-9]: </;
|
||||
next if /^xyc[0-9] at /;
|
||||
}
|
||||
elsif (/^y/) {
|
||||
next if /^yyy [0-9]/;
|
||||
}
|
||||
elsif (/^z/) {
|
||||
next if /^zs[0-9] at /;
|
||||
}
|
||||
$pfx = '*' if /^[a-z]+:$/;
|
||||
s/pid [0-9]+: //;
|
||||
if (/last message repeated ([0-9]+) time/) {
|
||||
$seen{$last} += $1;
|
||||
next;
|
||||
}
|
||||
s/^/$pfx/ if $pfx;
|
||||
unless ($seen{$_}++) {
|
||||
push(@seen,$_);
|
||||
}
|
||||
$last = $_;
|
||||
}
|
||||
$max = tell(Msgs);
|
||||
|
||||
open(tmp,'|sort >oldmsgs.tmp') || die "Can't create tmp file: $!\n";
|
||||
while ($_ = pop(@seen)) {
|
||||
print tmp $_;
|
||||
}
|
||||
close(tmp);
|
||||
open(tmp,'oldmsgs.tmp') || die "Can't reopen tmp file: $!\n";
|
||||
while (<tmp>) {
|
||||
if (/^nd:/) {
|
||||
next if $seen{$_} < 20;
|
||||
}
|
||||
if (/NFS/) {
|
||||
next if $seen{$_} < 20;
|
||||
}
|
||||
if (/no carrier/) {
|
||||
next if $seen{$_} < 20;
|
||||
}
|
||||
if (/silo overflow/) {
|
||||
next if $seen{$_} < 20;
|
||||
}
|
||||
print $seen{$_},":\t",$_;
|
||||
}
|
||||
|
||||
print `rm -f oldmsgs.tmp 2>&1; echo $max > oldmsgs 2>&1`;
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/scan/scan_passwd,v 1.1.1.1 1993/08/23 21:29:45 nate Exp $
|
||||
|
||||
# This scans passwd file for security holes.
|
||||
|
||||
open(Pass,'/etc/passwd') || die "Can't open passwd file: $!\n";
|
||||
# $dotriv = (`date` =~ /^Mon/);
|
||||
$dotriv = 1;
|
||||
|
||||
while (<Pass>) {
|
||||
($login,$pass,$uid,$gid,$gcos,$home,$shell) = split(/:/);
|
||||
if ($shell eq '') {
|
||||
print "Short: $_";
|
||||
}
|
||||
next if /^[+]/;
|
||||
if ($pass eq '') {
|
||||
if (index(":sync:lpq:+:", ":$login:") < 0) {
|
||||
print "No pass: $login\t$gcos\n";
|
||||
}
|
||||
}
|
||||
elsif ($dotriv && crypt($login,substr($pass,0,2)) eq $pass) {
|
||||
print "Trivial: $login\t$gcos\n";
|
||||
}
|
||||
if ($uid == 0) {
|
||||
if ($login !~ /^.?root$/ && $pass ne '*') {
|
||||
print "Extra root: $_";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
#!/usr/bin/perl -P
|
||||
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/scan/scan_ps,v 1.1.1.1 1993/08/23 21:29:45 nate Exp $
|
||||
|
||||
# This looks for looping processes.
|
||||
|
||||
#if defined(mc300) || defined(mc500) || defined(mc700)
|
||||
open(Ps, '/bin/ps -el|') || die "scan_ps: can't run ps";
|
||||
|
||||
while (<Ps>) {
|
||||
next if /rwhod/;
|
||||
print if index(' T', substr($_,62,1)) < 0;
|
||||
}
|
||||
#else
|
||||
open(Ps, '/bin/ps auxww|') || die "scan_ps: can't run ps";
|
||||
|
||||
while (<Ps>) {
|
||||
next if /dataserver/;
|
||||
next if /nfsd/;
|
||||
next if /update/;
|
||||
next if /ypserv/;
|
||||
next if /rwhod/;
|
||||
next if /routed/;
|
||||
next if /pagedaemon/;
|
||||
#ifdef vax
|
||||
($user,$pid,$cpu,$mem,$sz,$rss,$tt,$stat,$start,$time) = split;
|
||||
#else
|
||||
($user,$pid,$cpu,$mem,$sz,$rss,$tt,$stat,$time) = split;
|
||||
#endif
|
||||
print if length($time) > 4;
|
||||
}
|
||||
#endif
|
||||
|
|
@ -1,54 +0,0 @@
|
|||
#!/usr/bin/perl -P
|
||||
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/scan/scan_sudo,v 1.1.1.1 1993/08/23 21:29:45 nate Exp $
|
||||
|
||||
# Analyze the sudo log.
|
||||
|
||||
chdir('/usr/adm/private/memories') || die "Can't cd to memories: $!\n";
|
||||
|
||||
if (open(Oldsudo,'oldsudo')) {
|
||||
$maxpos = <Oldsudo>;
|
||||
close Oldsudo;
|
||||
}
|
||||
else {
|
||||
$maxpos = 0;
|
||||
`echo 0 >oldsudo`;
|
||||
}
|
||||
|
||||
unless (open(Sudo, '/usr/adm/sudo.log')) {
|
||||
print "Somebody removed sudo.log!!!\n" if $maxpos;
|
||||
exit 0;
|
||||
}
|
||||
|
||||
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
|
||||
$blksize,$blocks) = stat(Sudo);
|
||||
|
||||
if ($size < $maxpos) {
|
||||
$maxpos = 0;
|
||||
print "Somebody reset sudo.log!!!\n";
|
||||
}
|
||||
|
||||
seek(Sudo,$maxpos,0);
|
||||
|
||||
while (<Sudo>) {
|
||||
s/^.* :[ \t]+//;
|
||||
s/ipcrm.*/ipcrm/;
|
||||
s/kill.*/kill/;
|
||||
unless ($seen{$_}++) {
|
||||
push(@seen,$_);
|
||||
}
|
||||
$last = $_;
|
||||
}
|
||||
$max = tell(Sudo);
|
||||
|
||||
open(tmp,'|sort >oldsudo.tmp') || die "Can't create tmp file: $!\n";
|
||||
while ($_ = pop(@seen)) {
|
||||
print tmp $_;
|
||||
}
|
||||
close(tmp);
|
||||
open(tmp,'oldsudo.tmp') || die "Can't reopen tmp file: $!\n";
|
||||
while (<tmp>) {
|
||||
print $seen{$_},":\t",$_;
|
||||
}
|
||||
|
||||
print `(rm -f oldsudo.tmp; echo $max > oldsudo) 2>&1`;
|
||||
|
|
@ -1,84 +0,0 @@
|
|||
#!/usr/bin/perl -P
|
||||
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/scan/scan_suid,v 1.1.1.1 1993/08/23 21:29:44 nate Exp $
|
||||
|
||||
# Look for new setuid root files.
|
||||
|
||||
chdir '/usr/adm/private/memories' || die "Can't cd to memories: $!\n";
|
||||
|
||||
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
|
||||
$blksize,$blocks) = stat('oldsuid');
|
||||
if ($nlink) {
|
||||
$lasttime = $mtime;
|
||||
$tmp = $ctime - $atime;
|
||||
if ($tmp <= 0 || $tmp >= 10) {
|
||||
print "WARNING: somebody has read oldsuid!\n";
|
||||
}
|
||||
$tmp = $ctime - $mtime;
|
||||
if ($tmp <= 0 || $tmp >= 10) {
|
||||
print "WARNING: somebody has modified oldsuid!!!\n";
|
||||
}
|
||||
} else {
|
||||
$lasttime = time - 60 * 60 * 24; # one day ago
|
||||
}
|
||||
$thistime = time;
|
||||
|
||||
#if defined(mc300) || defined(mc500) || defined(mc700)
|
||||
open(Find, 'find / -perm -04000 -print |') ||
|
||||
die "scan_find: can't run find";
|
||||
#else
|
||||
open(Find, 'find / \( -fstype nfs -prune \) -o -perm -04000 -ls |') ||
|
||||
die "scan_find: can't run find";
|
||||
#endif
|
||||
|
||||
open(suid, '>newsuid.tmp');
|
||||
|
||||
while (<Find>) {
|
||||
|
||||
#if defined(mc300) || defined(mc500) || defined(mc700)
|
||||
$x = `/bin/ls -il $_`;
|
||||
$_ = $x;
|
||||
s/^ *//;
|
||||
($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
|
||||
= split;
|
||||
#else
|
||||
s/^ *//;
|
||||
($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
|
||||
= split;
|
||||
#endif
|
||||
|
||||
if ($perm =~ /[sS]/ && $owner eq 'root') {
|
||||
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
|
||||
$blksize,$blocks) = stat($name);
|
||||
$foo = sprintf("%10s%3s %-8s %-8s%9s %3s %2s %s %s\n",
|
||||
$perm,$links,$owner,$group,$size,$month,$day,$name,$inode);
|
||||
print suid $foo;
|
||||
if ($ctime > $lasttime) {
|
||||
if ($ctime > $thistime) {
|
||||
print "Future file: $foo";
|
||||
}
|
||||
else {
|
||||
$ct .= $foo;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
close(suid);
|
||||
|
||||
print `sort +7 -8 newsuid.tmp >newsuid 2>&1`;
|
||||
$foo = `/bin/diff oldsuid newsuid 2>&1`;
|
||||
print "Differences in suid info:\n",$foo if $foo;
|
||||
print `mv oldsuid oldoldsuid 2>&1; mv newsuid oldsuid 2>&1`;
|
||||
print `touch oldsuid 2>&1;sleep 2 2>&1;chmod o+w oldsuid 2>&1`;
|
||||
print `rm -f newsuid.tmp 2>&1`;
|
||||
|
||||
@ct = split(/\n/,$ct);
|
||||
$ct = '';
|
||||
$* = 1;
|
||||
while ($#ct >= 0) {
|
||||
$tmp = shift(@ct);
|
||||
unless ($foo =~ "^>.*$tmp\n") { $ct .= "$tmp\n"; }
|
||||
}
|
||||
|
||||
print "Inode changed since last time:\n",$ct if $ct;
|
||||
|
||||
|
|
@ -1,87 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/scan/scanner,v 1.1.1.1 1993/08/23 21:29:44 nate Exp $
|
||||
|
||||
# This runs all the scan_* routines on all the machines in /etc/ghosts.
|
||||
# We run this every morning at about 6 am:
|
||||
|
||||
# !/bin/sh
|
||||
# cd /usr/adm/private
|
||||
# decrypt scanner | perl >scan.out 2>&1
|
||||
# mail admin <scan.out
|
||||
|
||||
# Note that the scan_* files should be encrypted with the key "-inquire", and
|
||||
# scanner should be encrypted somehow so that people can't find that key.
|
||||
# I leave it up to you to figure out how to unencrypt it before executing.
|
||||
|
||||
$ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin:/usr/ucb:.';
|
||||
|
||||
$| = 1; # command buffering on stdout
|
||||
|
||||
print "Subject: bizarre happenings\n\n";
|
||||
|
||||
(chdir '/usr/adm/private') || die "Can't cd to /usr/adm/private: $!\n";
|
||||
|
||||
if ($#ARGV >= 0) {
|
||||
@scanlist = @ARGV;
|
||||
} else {
|
||||
@scanlist = split(/[ \t\n]+/,`echo scan_*`);
|
||||
}
|
||||
|
||||
scan: while ($scan = shift(@scanlist)) {
|
||||
print "\n********** $scan **********\n";
|
||||
$showhost++;
|
||||
|
||||
$systype = 'all';
|
||||
|
||||
open(ghosts, '/etc/ghosts') || die 'No /etc/ghosts file';
|
||||
|
||||
$one_of_these = ":$systype:";
|
||||
if ($systype =~ s/\+/[+]/g) {
|
||||
$one_of_these =~ s/\+/:/g;
|
||||
}
|
||||
|
||||
line: while (<ghosts>) {
|
||||
s/[ \t]*\n//;
|
||||
if (!$_ || /^#/) {
|
||||
next line;
|
||||
}
|
||||
if (/^([a-zA-Z_0-9]+)=(.+)/) {
|
||||
$name = $1; $repl = $2;
|
||||
$repl =~ s/\+/:/g;
|
||||
$one_of_these =~ s/:$name:/:$repl:/;
|
||||
next line;
|
||||
}
|
||||
@gh = split;
|
||||
$host = $gh[0];
|
||||
if ($showhost) { $showhost = "$host:\t"; }
|
||||
class: while ($class = pop(gh)) {
|
||||
if (index($one_of_these,":$class:") >=0) {
|
||||
$iter = 0;
|
||||
`exec crypt -inquire <$scan >.x 2>/dev/null`;
|
||||
unless (open(scan,'.x')) {
|
||||
print "Can't run $scan: $!\n";
|
||||
next scan;
|
||||
}
|
||||
$cmd = <scan>;
|
||||
unless ($cmd =~ s/#!(.*)\n/$1/) {
|
||||
$cmd = '/usr/bin/perl';
|
||||
}
|
||||
close(scan);
|
||||
if (open(PIPE,"exec rsh $host '$cmd' <.x|")) {
|
||||
sleep(5);
|
||||
unlink '.x';
|
||||
while (<PIPE>) {
|
||||
last if $iter++ > 1000; # must be looping
|
||||
next if /^[0-9.]+u [0-9.]+s/;
|
||||
print $showhost,$_;
|
||||
}
|
||||
close(PIPE);
|
||||
} else {
|
||||
print "(Can't execute rsh: $!)\n";
|
||||
}
|
||||
last class;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
@ -1,27 +0,0 @@
|
|||
#!./perl
|
||||
|
||||
$pat = 'S n C4 x8';
|
||||
$inet = 2;
|
||||
$echo = 7;
|
||||
$smtp = 25;
|
||||
$nntp = 119;
|
||||
|
||||
$this = pack($pat,$inet,2345, 0,0,0,0);
|
||||
select(NS); $| = 1; select(stdout);
|
||||
|
||||
if (socket(S,2,1,6)) { print "socket ok\n"; } else { die $!; }
|
||||
if (bind(S,$this)) { print "bind ok\n"; } else { die $!; }
|
||||
if (listen(S,5)) { print "listen ok\n"; } else { die $!; }
|
||||
for (;;) {
|
||||
print "Listening again\n";
|
||||
if ($addr = accept(NS,S)) { print "accept ok\n"; } else { die $!; }
|
||||
|
||||
@ary = unpack($pat,$addr);
|
||||
$, = ' ';
|
||||
print @ary; print "\n";
|
||||
|
||||
while (<NS>) {
|
||||
print;
|
||||
print NS;
|
||||
}
|
||||
}
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/shmkill,v 1.1.1.1 1993/08/23 21:29:43 nate Exp $
|
||||
|
||||
# A script to call from crontab periodically when people are leaving shared
|
||||
# memory sitting around unattached.
|
||||
|
||||
open(ipcs,'ipcs -m -o|') || die "Can't run ipcs: $!";
|
||||
|
||||
while (<ipcs>) {
|
||||
$tmp = index($_,'NATTCH');
|
||||
$pos = $tmp if $tmp >= 0;
|
||||
if (/^m/) {
|
||||
($m,$id,$key,$mode,$owner,$group,$attach) = split;
|
||||
if ($attach != substr($_,$pos,6)) {
|
||||
die "Different ipcs format--can't parse!\n";
|
||||
}
|
||||
if ($attach == 0) {
|
||||
push(@goners,'-m',$id);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
exec 'ipcrm', @goners if $#goners >= 0;
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
FYEnjoyment, here are the test scripts I used while implementing SysV
|
||||
IPC in Perl. Each of them must be run with the parameter "s" for
|
||||
"send" or "r" for "receive"; in each case, the receiver is the server
|
||||
and the sender is the client.
|
||||
|
||||
--
|
||||
Chip Salzenberg at ComDev/TCT <chip@tct.uucp>, <uunet!ateng!tct!chip>
|
||||
|
||||
|
||||
|
|
@ -1,47 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0;
|
||||
|
||||
require 'sys/ipc.ph';
|
||||
require 'sys/msg.ph';
|
||||
|
||||
$| = 1;
|
||||
|
||||
$mode = shift;
|
||||
die "usage: ipcmsg {r|s}\n" unless $mode =~ /^[rs]$/;
|
||||
$send = ($mode eq "s");
|
||||
|
||||
$id = msgget(0x1234, ($send ? 0 : &IPC_CREAT) | 0644);
|
||||
die "Can't get message queue: $!\n" unless defined($id);
|
||||
print "message queue id: $id\n";
|
||||
|
||||
if ($send) {
|
||||
while (<STDIN>) {
|
||||
chop;
|
||||
unless (msgsnd($id, pack("LA*", $., $_), 0)) {
|
||||
die "Can't send message: $!\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
$SIG{'INT'} = $SIG{'QUIT'} = "leave";
|
||||
for (;;) {
|
||||
unless (msgrcv($id, $_, 512, 0, 0)) {
|
||||
die "Can't receive message: $!\n";
|
||||
}
|
||||
($type, $message) = unpack("La*", $_);
|
||||
printf "[%d] %s\n", $type, $message;
|
||||
}
|
||||
}
|
||||
|
||||
&leave;
|
||||
|
||||
sub leave {
|
||||
if (!$send) {
|
||||
$x = msgctl($id, &IPC_RMID, 0);
|
||||
if (!defined($x) || $x < 0) {
|
||||
die "Can't remove message queue: $!\n";
|
||||
}
|
||||
}
|
||||
exit;
|
||||
}
|
||||
|
|
@ -1,46 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0;
|
||||
|
||||
require 'sys/ipc.ph';
|
||||
require 'sys/msg.ph';
|
||||
|
||||
$| = 1;
|
||||
|
||||
$mode = shift;
|
||||
die "usage: ipcmsg {r|s}\n" unless $mode =~ /^[rs]$/;
|
||||
$signal = ($mode eq "s");
|
||||
|
||||
$id = semget(0x1234, 1, ($signal ? 0 : &IPC_CREAT) | 0644);
|
||||
die "Can't get semaphore: $!\n" unless defined($id);
|
||||
print "semaphore id: $id\n";
|
||||
|
||||
if ($signal) {
|
||||
while (<STDIN>) {
|
||||
print "Signalling\n";
|
||||
unless (semop($id, 0, pack("sss", 0, 1, 0))) {
|
||||
die "Can't signal semaphore: $!\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
$SIG{'INT'} = $SIG{'QUIT'} = "leave";
|
||||
for (;;) {
|
||||
unless (semop($id, 0, pack("sss", 0, -1, 0))) {
|
||||
die "Can't wait for semaphore: $!\n";
|
||||
}
|
||||
print "Unblocked\n";
|
||||
}
|
||||
}
|
||||
|
||||
&leave;
|
||||
|
||||
sub leave {
|
||||
if (!$signal) {
|
||||
$x = semctl($id, 0, &IPC_RMID, 0);
|
||||
if (!defined($x) || $x < 0) {
|
||||
die "Can't remove semaphore: $!\n";
|
||||
}
|
||||
}
|
||||
exit;
|
||||
}
|
||||
|
|
@ -1,50 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
||||
if 0;
|
||||
|
||||
require 'sys/ipc.ph';
|
||||
require 'sys/shm.ph';
|
||||
|
||||
$| = 1;
|
||||
|
||||
$mode = shift;
|
||||
die "usage: ipcshm {r|s}\n" unless $mode =~ /^[rs]$/;
|
||||
$send = ($mode eq "s");
|
||||
|
||||
$SIZE = 32;
|
||||
$id = shmget(0x1234, $SIZE, ($send ? 0 : &IPC_CREAT) | 0644);
|
||||
die "Can't get shared memory: $!\n" unless defined($id);
|
||||
print "shared memory id: $id\n";
|
||||
|
||||
if ($send) {
|
||||
while (<STDIN>) {
|
||||
chop;
|
||||
unless (shmwrite($id, pack("La*", length($_), $_), 0, $SIZE)) {
|
||||
die "Can't write to shared memory: $!\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
$SIG{'INT'} = $SIG{'QUIT'} = "leave";
|
||||
for (;;) {
|
||||
$_ = <STDIN>;
|
||||
unless (shmread($id, $_, 0, $SIZE)) {
|
||||
die "Can't read shared memory: $!\n";
|
||||
}
|
||||
$len = unpack("L", $_);
|
||||
$message = substr($_, length(pack("L",0)), $len);
|
||||
printf "[%d] %s\n", $len, $message;
|
||||
}
|
||||
}
|
||||
|
||||
&leave;
|
||||
|
||||
sub leave {
|
||||
if (!$send) {
|
||||
$x = shmctl($id, &IPC_RMID, 0);
|
||||
if (!defined($x) || $x < 0) {
|
||||
die "Can't remove shared memory: $!\n";
|
||||
}
|
||||
}
|
||||
exit;
|
||||
}
|
||||
|
|
@ -1,46 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
while (<>) {
|
||||
next if /^\./;
|
||||
next if /^From / .. /^$/;
|
||||
next if /^Path: / .. /^$/;
|
||||
s/^\W+//;
|
||||
push(@ary,split(' '));
|
||||
while ($#ary > 1) {
|
||||
$a = $p;
|
||||
$p = $n;
|
||||
$w = shift(@ary);
|
||||
$n = $num{$w};
|
||||
if ($n eq '') {
|
||||
push(@word,$w);
|
||||
$n = pack('S',$#word);
|
||||
$num{$w} = $n;
|
||||
}
|
||||
$lookup{$a . $p} .= $n;
|
||||
}
|
||||
}
|
||||
|
||||
for (;;) {
|
||||
$n = $lookup{$a . $p};
|
||||
($foo,$n) = each(lookup) if $n eq '';
|
||||
$n = substr($n,int(rand(length($n))) & 0177776,2);
|
||||
$a = $p;
|
||||
$p = $n;
|
||||
($w) = unpack('S',$n);
|
||||
$w = $word[$w];
|
||||
$col += length($w) + 1;
|
||||
if ($col >= 65) {
|
||||
$col = 0;
|
||||
print "\n";
|
||||
}
|
||||
else {
|
||||
print ' ';
|
||||
}
|
||||
print $w;
|
||||
if ($w =~ /\.$/) {
|
||||
if (rand() < .1) {
|
||||
print "\n";
|
||||
$col = 80;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
@ -1,45 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/van/empty,v 1.1.1.1 1993/08/23 21:29:45 nate Exp $
|
||||
|
||||
# This script empties a trashcan.
|
||||
|
||||
$recursive = shift if $ARGV[0] eq '-r';
|
||||
|
||||
@ARGV = '.' if $#ARGV < 0;
|
||||
|
||||
chop($pwd = `pwd`);
|
||||
|
||||
dir: foreach $dir (@ARGV) {
|
||||
unless (chdir $dir) {
|
||||
print stderr "Can't find directory $dir: $!\n";
|
||||
next dir;
|
||||
}
|
||||
if ($recursive) {
|
||||
do cmd('find . -name .deleted -exec /bin/rm -rf {} ;');
|
||||
}
|
||||
else {
|
||||
if (-d '.deleted') {
|
||||
do cmd('rm -rf .deleted');
|
||||
}
|
||||
else {
|
||||
if ($dir eq '.' && $pwd =~ m|/\.deleted$|) {
|
||||
chdir '..';
|
||||
do cmd('rm -rf .deleted');
|
||||
}
|
||||
else {
|
||||
print stderr "No trashcan found in directory $dir\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
continue {
|
||||
chdir $pwd;
|
||||
}
|
||||
|
||||
# force direct execution with no shell
|
||||
|
||||
sub cmd {
|
||||
system split(' ',join(' ',@_));
|
||||
}
|
||||
|
||||
|
|
@ -1,66 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/van/unvanish,v 1.1.1.1 1993/08/23 21:29:45 nate Exp $
|
||||
|
||||
sub it {
|
||||
if ($olddir ne '.') {
|
||||
chop($pwd = `pwd`) if $pwd eq '';
|
||||
(chdir $olddir) || die "Directory $olddir is not accesible";
|
||||
}
|
||||
unless ($olddir eq '.deleted') {
|
||||
if (-d '.deleted') {
|
||||
chdir '.deleted' || die "Directory .deleted is not accesible";
|
||||
}
|
||||
else {
|
||||
chop($pwd = `pwd`) if $pwd eq '';
|
||||
die "Directory .deleted does not exist" unless $pwd =~ /\.deleted$/;
|
||||
}
|
||||
}
|
||||
print `mv $startfiles$filelist..$force`;
|
||||
if ($olddir ne '.') {
|
||||
(chdir $pwd) || die "Can't get back to original directory $pwd: $!\n";
|
||||
}
|
||||
}
|
||||
|
||||
if ($#ARGV < 0) {
|
||||
open(lastcmd,'.deleted/.lastcmd') ||
|
||||
open(lastcmd,'.lastcmd') ||
|
||||
die "No previous vanish in this dir";
|
||||
$ARGV = <lastcmd>;
|
||||
close(lastcmd);
|
||||
@ARGV = split(/[\n ]+/,$ARGV);
|
||||
}
|
||||
|
||||
while ($ARGV[0] =~ /^-/) {
|
||||
$_ = shift;
|
||||
/^-f/ && ($force = ' >/dev/null 2>&1');
|
||||
/^-i/ && ($interactive = 1);
|
||||
if (/^-+$/) {
|
||||
$startfiles = '- ';
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
while ($file = shift) {
|
||||
if ($file =~ s|^(.*)/||) {
|
||||
$dir = $1;
|
||||
}
|
||||
else {
|
||||
$dir = '.';
|
||||
}
|
||||
|
||||
if ($dir ne $olddir) {
|
||||
do it() if $olddir;
|
||||
$olddir = $dir;
|
||||
}
|
||||
|
||||
if ($interactive) {
|
||||
print "unvanish: restore $dir/$file? ";
|
||||
next unless <stdin> =~ /^y/i;
|
||||
}
|
||||
|
||||
$filelist .= $file; $filelist .= ' ';
|
||||
|
||||
}
|
||||
|
||||
do it() if $olddir;
|
||||
|
|
@ -1,21 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/van/vanexp,v 1.1.1.1 1993/08/23 21:29:45 nate Exp $
|
||||
|
||||
# This is for running from a find at night to expire old .deleteds
|
||||
|
||||
$can = $ARGV[0];
|
||||
|
||||
exit 1 unless $can =~ /.deleted$/;
|
||||
|
||||
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
|
||||
$blksize,$blocks) = stat($can);
|
||||
|
||||
exit 0 unless $size;
|
||||
|
||||
if (time - $mtime > 2 * 24 * 60 * 60) {
|
||||
`/bin/rm -rf $can`;
|
||||
}
|
||||
else {
|
||||
`find $can -ctime +2 -exec rm -f {} \;`;
|
||||
}
|
||||
|
|
@ -1,65 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
# $Header: /home/cvs/386BSD/ports/lang/perl/eg/van/vanish,v 1.1.1.1 1993/08/23 21:29:45 nate Exp $
|
||||
|
||||
sub it {
|
||||
if ($olddir ne '.') {
|
||||
chop($pwd = `pwd`) if $pwd eq '';
|
||||
(chdir $olddir) || die "Directory $olddir is not accesible";
|
||||
}
|
||||
if (!-d .deleted) {
|
||||
print `mkdir .deleted; chmod 775 .deleted`;
|
||||
die "You can't remove files from $olddir" if $?;
|
||||
}
|
||||
$filelist =~ s/ $//;
|
||||
$filelist =~ s/#/\\#/g;
|
||||
if ($filelist !~ /^[ \t]*$/) {
|
||||
open(lastcmd,'>.deleted/.lastcmd');
|
||||
print lastcmd $filelist,"\n";
|
||||
close(lastcmd);
|
||||
print `/bin/mv $startfiles$filelist .deleted$force`;
|
||||
}
|
||||
if ($olddir ne '.') {
|
||||
(chdir $pwd) || die "Can't get back to original directory $pwd: $!\n";
|
||||
}
|
||||
}
|
||||
|
||||
while ($ARGV[0] =~ /^-/) {
|
||||
$_ = shift;
|
||||
/^-f/ && ($force = ' >/dev/null 2>&1');
|
||||
/^-i/ && ($interactive = 1);
|
||||
if (/^-+$/) {
|
||||
$startfiles = '- ';
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
chop($pwd = `pwd`);
|
||||
|
||||
while ($file = shift) {
|
||||
if ($file =~ s|^(.*)/||) {
|
||||
$dir = $1;
|
||||
}
|
||||
else {
|
||||
$dir = '.';
|
||||
}
|
||||
|
||||
if ($interactive) {
|
||||
print "vanish: remove $dir/$file? ";
|
||||
next unless <stdin> =~ /^y/i;
|
||||
}
|
||||
|
||||
if ($file eq '.deleted') {
|
||||
print stderr "To delete .deleted (the trashcan) use the 'empty' command.\n";
|
||||
next;
|
||||
}
|
||||
|
||||
if ($dir ne $olddir) {
|
||||
do it() if $olddir;
|
||||
$olddir = $dir;
|
||||
}
|
||||
|
||||
$filelist .= $file; $filelist .= ' ';
|
||||
}
|
||||
|
||||
do it() if $olddir;
|
||||
|
|
@ -1,13 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
# This assumes your /etc/utmp file looks like ours
|
||||
open(UTMP,'/etc/utmp');
|
||||
@mo = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec);
|
||||
while (read(UTMP,$utmp,36)) {
|
||||
($line,$name,$host,$time) = unpack('A8A8A16l',$utmp);
|
||||
if ($name) {
|
||||
$host = "($host)" if ord($host);
|
||||
($sec,$min,$hour,$mday,$mon) = localtime($time);
|
||||
printf "%-9s%-8s%s %2d %02d:%02d %s\n",
|
||||
$name,$line,$mo[$mon],$mday,$hour,$min,$host;
|
||||
}
|
||||
}
|
||||
|
|
@ -1,631 +0,0 @@
|
|||
;; Perl code editing commands for GNU Emacs
|
||||
;; Copyright (C) 1990 William F. Mann
|
||||
;; Adapted from C code editing commands 'c-mode.el', Copyright 1987 by the
|
||||
;; Free Software Foundation, under terms of its General Public License.
|
||||
|
||||
;; This file may be made part of GNU Emacs at the option of the FSF, or
|
||||
;; of the perl distribution at the option of Larry Wall.
|
||||
|
||||
;; This code is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY. No author or distributor
|
||||
;; accepts responsibility to anyone for the consequences of using it
|
||||
;; or for whether it serves any particular purpose or works at all,
|
||||
;; unless he says so in writing. Refer to the GNU Emacs General Public
|
||||
;; License for full details.
|
||||
|
||||
;; Everyone is granted permission to copy, modify and redistribute
|
||||
;; this code, but only under the conditions described in the
|
||||
;; GNU Emacs General Public License. A copy of this license is
|
||||
;; supposed to have been given to you along with GNU Emacs so you
|
||||
;; can know your rights and responsibilities. It should be in a
|
||||
;; file named COPYING. Among other things, the copyright notice
|
||||
;; and this notice must be preserved on all copies.
|
||||
|
||||
;; To enter perl-mode automatically, add (autoload 'perl-mode "perl-mode")
|
||||
;; to your .emacs file and change the first line of your perl script to:
|
||||
;; #!/usr/bin/perl -- # -*-Perl-*-
|
||||
;; With argments to perl:
|
||||
;; #!/usr/bin/perl -P- # -*-Perl-*-
|
||||
;; To handle files included with do 'filename.pl';, add something like
|
||||
;; (setq auto-mode-alist (append (list (cons "\\.pl$" 'perl-mode))
|
||||
;; auto-mode-alist))
|
||||
;; to your .emacs file; otherwise the .pl suffix defaults to prolog-mode.
|
||||
|
||||
;; This code is based on the 18.53 version c-mode.el, with extensive
|
||||
;; rewriting. Most of the features of c-mode survived intact.
|
||||
|
||||
;; I added a new feature which adds functionality to TAB; it is controlled
|
||||
;; by the variable perl-tab-to-comment. With it enabled, TAB does the
|
||||
;; first thing it can from the following list: change the indentation;
|
||||
;; move past leading white space; delete an empty comment; reindent a
|
||||
;; comment; move to end of line; create an empty comment; tell you that
|
||||
;; the line ends in a quoted string, or has a # which should be a \#.
|
||||
|
||||
;; If your machine is slow, you may want to remove some of the bindings
|
||||
;; to electric-perl-terminator. I changed the indenting defaults to be
|
||||
;; what Larry Wall uses in perl/lib, but left in all the options.
|
||||
|
||||
;; I also tuned a few things: comments and labels starting in column
|
||||
;; zero are left there by indent-perl-exp; perl-beginning-of-function
|
||||
;; goes back to the first open brace/paren in column zero, the open brace
|
||||
;; in 'sub ... {', or the equal sign in 'format ... ='; indent-perl-exp
|
||||
;; (meta-^q) indents from the current line through the close of the next
|
||||
;; brace/paren, so you don't need to start exactly at a brace or paren.
|
||||
|
||||
;; It may be good style to put a set of redundant braces around your
|
||||
;; main program. This will let you reindent it with meta-^q.
|
||||
|
||||
;; Known problems (these are all caused by limitations in the elisp
|
||||
;; parsing routine (parse-partial-sexp), which was not designed for such
|
||||
;; a rich language; writing a more suitable parser would be a big job):
|
||||
;; 1) Regular expression delimitors do not act as quotes, so special
|
||||
;; characters such as `'"#:;[](){} may need to be backslashed
|
||||
;; in regular expressions and in both parts of s/// and tr///.
|
||||
;; 2) The globbing syntax <pattern> is not recognized, so special
|
||||
;; characters in the pattern string must be backslashed.
|
||||
;; 3) The q, qq, and << quoting operators are not recognized; see below.
|
||||
;; 4) \ (backslash) always quotes the next character, so '\' is
|
||||
;; treated as the start of a string. Use "\\" as a work-around.
|
||||
;; 5) To make variables such a $' and $#array work, perl-mode treats
|
||||
;; $ just like backslash, so '$' is the same as problem 5.
|
||||
;; 6) Unfortunately, treating $ like \ makes ${var} be treated as an
|
||||
;; unmatched }. See below.
|
||||
;; 7) When ' (quote) is used as a package name separator, perl-mode
|
||||
;; doesn't understand, and thinks it is seeing a quoted string.
|
||||
|
||||
;; Here are some ugly tricks to bypass some of these problems: the perl
|
||||
;; expression /`/ (that's a back-tick) usually evaluates harmlessly,
|
||||
;; but will trick perl-mode into starting a quoted string, which
|
||||
;; can be ended with another /`/. Assuming you have no embedded
|
||||
;; back-ticks, this can used to help solve problem 3:
|
||||
;;
|
||||
;; /`/; $ugly = q?"'$?; /`/;
|
||||
;;
|
||||
;; To solve problem 6, add a /{/; before each use of ${var}:
|
||||
;; /{/; while (<${glob_me}>) ...
|
||||
;;
|
||||
;; Problem 7 is even worse, but this 'fix' does work :-(
|
||||
;; $DB'stop#'
|
||||
;; [$DB'line#'
|
||||
;; ] =~ s/;9$//;
|
||||
|
||||
|
||||
(defvar perl-mode-abbrev-table nil
|
||||
"Abbrev table in use in perl-mode buffers.")
|
||||
(define-abbrev-table 'perl-mode-abbrev-table ())
|
||||
|
||||
(defvar perl-mode-map ()
|
||||
"Keymap used in Perl mode.")
|
||||
(if perl-mode-map
|
||||
()
|
||||
(setq perl-mode-map (make-sparse-keymap))
|
||||
(define-key perl-mode-map "{" 'electric-perl-terminator)
|
||||
(define-key perl-mode-map "}" 'electric-perl-terminator)
|
||||
(define-key perl-mode-map ";" 'electric-perl-terminator)
|
||||
(define-key perl-mode-map ":" 'electric-perl-terminator)
|
||||
(define-key perl-mode-map "\e\C-a" 'perl-beginning-of-function)
|
||||
(define-key perl-mode-map "\e\C-e" 'perl-end-of-function)
|
||||
(define-key perl-mode-map "\e\C-h" 'mark-perl-function)
|
||||
(define-key perl-mode-map "\e\C-q" 'indent-perl-exp)
|
||||
(define-key perl-mode-map "\177" 'backward-delete-char-untabify)
|
||||
(define-key perl-mode-map "\t" 'perl-indent-command))
|
||||
|
||||
(autoload 'c-macro-expand "cmacexp"
|
||||
"Display the result of expanding all C macros occurring in the region.
|
||||
The expansion is entirely correct because it uses the C preprocessor."
|
||||
t)
|
||||
|
||||
(defvar perl-mode-syntax-table nil
|
||||
"Syntax table in use in perl-mode buffers.")
|
||||
|
||||
(if perl-mode-syntax-table
|
||||
()
|
||||
(setq perl-mode-syntax-table (make-syntax-table (standard-syntax-table)))
|
||||
(modify-syntax-entry ?\n ">" perl-mode-syntax-table)
|
||||
(modify-syntax-entry ?# "<" perl-mode-syntax-table)
|
||||
(modify-syntax-entry ?$ "/" perl-mode-syntax-table)
|
||||
(modify-syntax-entry ?% "." perl-mode-syntax-table)
|
||||
(modify-syntax-entry ?& "." perl-mode-syntax-table)
|
||||
(modify-syntax-entry ?\' "\"" perl-mode-syntax-table)
|
||||
(modify-syntax-entry ?* "." perl-mode-syntax-table)
|
||||
(modify-syntax-entry ?+ "." perl-mode-syntax-table)
|
||||
(modify-syntax-entry ?- "." perl-mode-syntax-table)
|
||||
(modify-syntax-entry ?/ "." perl-mode-syntax-table)
|
||||
(modify-syntax-entry ?< "." perl-mode-syntax-table)
|
||||
(modify-syntax-entry ?= "." perl-mode-syntax-table)
|
||||
(modify-syntax-entry ?> "." perl-mode-syntax-table)
|
||||
(modify-syntax-entry ?\\ "\\" perl-mode-syntax-table)
|
||||
(modify-syntax-entry ?` "\"" perl-mode-syntax-table)
|
||||
(modify-syntax-entry ?| "." perl-mode-syntax-table)
|
||||
)
|
||||
|
||||
(defconst perl-indent-level 4
|
||||
"*Indentation of Perl statements with respect to containing block.")
|
||||
(defconst perl-continued-statement-offset 4
|
||||
"*Extra indent for lines not starting new statements.")
|
||||
(defconst perl-continued-brace-offset -4
|
||||
"*Extra indent for substatements that start with open-braces.
|
||||
This is in addition to perl-continued-statement-offset.")
|
||||
(defconst perl-brace-offset 0
|
||||
"*Extra indentation for braces, compared with other text in same context.")
|
||||
(defconst perl-brace-imaginary-offset 0
|
||||
"*Imagined indentation of an open brace that actually follows a statement.")
|
||||
(defconst perl-label-offset -2
|
||||
"*Offset of Perl label lines relative to usual indentation.")
|
||||
|
||||
(defconst perl-tab-always-indent t
|
||||
"*Non-nil means TAB in Perl mode should always indent the current line,
|
||||
regardless of where in the line point is when the TAB command is used.")
|
||||
|
||||
(defconst perl-tab-to-comment t
|
||||
"*Non-nil means that for lines which don't need indenting, TAB will
|
||||
either indent an existing comment, move to end-of-line, or if at end-of-line
|
||||
already, create a new comment.")
|
||||
|
||||
(defconst perl-nochange ";?#\\|\f\\|\\s(\\|\\(\\w\\|\\s_\\)+:"
|
||||
"*Lines starting with this regular expression will not be auto-indented.")
|
||||
|
||||
(defun perl-mode ()
|
||||
"Major mode for editing Perl code.
|
||||
Expression and list commands understand all Perl brackets.
|
||||
Tab indents for Perl code.
|
||||
Comments are delimited with # ... \\n.
|
||||
Paragraphs are separated by blank lines only.
|
||||
Delete converts tabs to spaces as it moves back.
|
||||
\\{perl-mode-map}
|
||||
Variables controlling indentation style:
|
||||
perl-tab-always-indent
|
||||
Non-nil means TAB in Perl mode should always indent the current line,
|
||||
regardless of where in the line point is when the TAB command is used.
|
||||
perl-tab-to-comment
|
||||
Non-nil means that for lines which don't need indenting, TAB will
|
||||
either delete an empty comment, indent an existing comment, move
|
||||
to end-of-line, or if at end-of-line already, create a new comment.
|
||||
perl-nochange
|
||||
Lines starting with this regular expression will not be auto-indented.
|
||||
perl-indent-level
|
||||
Indentation of Perl statements within surrounding block.
|
||||
The surrounding block's indentation is the indentation
|
||||
of the line on which the open-brace appears.
|
||||
perl-continued-statement-offset
|
||||
Extra indentation given to a substatement, such as the
|
||||
then-clause of an if or body of a while.
|
||||
perl-continued-brace-offset
|
||||
Extra indentation given to a brace that starts a substatement.
|
||||
This is in addition to perl-continued-statement-offset.
|
||||
perl-brace-offset
|
||||
Extra indentation for line if it starts with an open brace.
|
||||
perl-brace-imaginary-offset
|
||||
An open brace following other text is treated as if it were
|
||||
this far to the right of the start of its line.
|
||||
perl-label-offset
|
||||
Extra indentation for line that is a label.
|
||||
|
||||
Various indentation styles: K&R BSD BLK GNU LW
|
||||
perl-indent-level 5 8 0 2 4
|
||||
perl-continued-statement-offset 5 8 4 2 4
|
||||
perl-continued-brace-offset 0 0 0 0 -4
|
||||
perl-brace-offset -5 -8 0 0 0
|
||||
perl-brace-imaginary-offset 0 0 4 0 0
|
||||
perl-label-offset -5 -8 -2 -2 -2
|
||||
|
||||
Turning on Perl mode calls the value of the variable perl-mode-hook with no
|
||||
args, if that value is non-nil."
|
||||
(interactive)
|
||||
(kill-all-local-variables)
|
||||
(use-local-map perl-mode-map)
|
||||
(setq major-mode 'perl-mode)
|
||||
(setq mode-name "Perl")
|
||||
(setq local-abbrev-table perl-mode-abbrev-table)
|
||||
(set-syntax-table perl-mode-syntax-table)
|
||||
(make-local-variable 'paragraph-start)
|
||||
(setq paragraph-start (concat "^$\\|" page-delimiter))
|
||||
(make-local-variable 'paragraph-separate)
|
||||
(setq paragraph-separate paragraph-start)
|
||||
(make-local-variable 'paragraph-ignore-fill-prefix)
|
||||
(setq paragraph-ignore-fill-prefix t)
|
||||
(make-local-variable 'indent-line-function)
|
||||
(setq indent-line-function 'perl-indent-line)
|
||||
(make-local-variable 'require-final-newline)
|
||||
(setq require-final-newline t)
|
||||
(make-local-variable 'comment-start)
|
||||
(setq comment-start "# ")
|
||||
(make-local-variable 'comment-end)
|
||||
(setq comment-end "")
|
||||
(make-local-variable 'comment-column)
|
||||
(setq comment-column 32)
|
||||
(make-local-variable 'comment-start-skip)
|
||||
(setq comment-start-skip "\\(^\\|\\s-\\);?#+ *")
|
||||
(make-local-variable 'comment-indent-hook)
|
||||
(setq comment-indent-hook 'perl-comment-indent)
|
||||
(make-local-variable 'parse-sexp-ignore-comments)
|
||||
(setq parse-sexp-ignore-comments nil)
|
||||
(run-hooks 'perl-mode-hook))
|
||||
|
||||
;; This is used by indent-for-comment
|
||||
;; to decide how much to indent a comment in Perl code
|
||||
;; based on its context.
|
||||
(defun perl-comment-indent ()
|
||||
(if (and (bolp) (not (eolp)))
|
||||
0 ;Existing comment at bol stays there.
|
||||
(save-excursion
|
||||
(skip-chars-backward " \t")
|
||||
(max (1+ (current-column)) ;Else indent at comment column
|
||||
comment-column)))) ; except leave at least one space.
|
||||
|
||||
(defun electric-perl-terminator (arg)
|
||||
"Insert character. If at end-of-line, and not in a comment or a quote,
|
||||
correct the line's indentation."
|
||||
(interactive "P")
|
||||
(let ((insertpos (point)))
|
||||
(and (not arg) ; decide whether to indent
|
||||
(eolp)
|
||||
(save-excursion
|
||||
(beginning-of-line)
|
||||
(and (not ; eliminate comments quickly
|
||||
(re-search-forward comment-start-skip insertpos t))
|
||||
(or (/= last-command-char ?:)
|
||||
;; Colon is special only after a label ....
|
||||
(looking-at "\\s-*\\(\\w\\|\\s_\\)+$"))
|
||||
(let ((pps (parse-partial-sexp
|
||||
(perl-beginning-of-function) insertpos)))
|
||||
(not (or (nth 3 pps) (nth 4 pps) (nth 5 pps))))))
|
||||
(progn ; must insert, indent, delete
|
||||
(insert-char last-command-char 1)
|
||||
(perl-indent-line)
|
||||
(delete-char -1))))
|
||||
(self-insert-command (prefix-numeric-value arg)))
|
||||
|
||||
;; not used anymore, but may be useful someday:
|
||||
;;(defun perl-inside-parens-p ()
|
||||
;; (condition-case ()
|
||||
;; (save-excursion
|
||||
;; (save-restriction
|
||||
;; (narrow-to-region (point)
|
||||
;; (perl-beginning-of-function))
|
||||
;; (goto-char (point-max))
|
||||
;; (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\()))
|
||||
;; (error nil)))
|
||||
|
||||
(defun perl-indent-command (&optional arg)
|
||||
"Indent current line as Perl code, or optionally, insert a tab character.
|
||||
|
||||
With an argument, indent the current line, regardless of other options.
|
||||
|
||||
If perl-tab-always-indent is nil and point is not in the indentation
|
||||
area at the beginning of the line, simply insert a tab.
|
||||
|
||||
Otherwise, indent the current line. If point was within the indentation
|
||||
area it is moved to the end of the indentation area. If the line was
|
||||
already indented properly and point was not within the indentation area,
|
||||
and if perl-tab-to-comment is non-nil (the default), then do the first
|
||||
possible action from the following list:
|
||||
|
||||
1) delete an empty comment
|
||||
2) move forward to start of comment, indenting if necessary
|
||||
3) move forward to end of line
|
||||
4) create an empty comment
|
||||
5) move backward to start of comment, indenting if necessary."
|
||||
(interactive "P")
|
||||
(if arg ; If arg, just indent this line
|
||||
(perl-indent-line "\f")
|
||||
(if (and (not perl-tab-always-indent)
|
||||
(<= (current-column) (current-indentation)))
|
||||
(insert-tab)
|
||||
(let (bof lsexp delta (oldpnt (point)))
|
||||
(beginning-of-line)
|
||||
(setq lsexp (point))
|
||||
(setq bof (perl-beginning-of-function))
|
||||
(goto-char oldpnt)
|
||||
(setq delta (perl-indent-line "\f\\|;?#" bof))
|
||||
(and perl-tab-to-comment
|
||||
(= oldpnt (point)) ; done if point moved
|
||||
(if (listp delta) ; if line starts in a quoted string
|
||||
(setq lsexp (or (nth 2 delta) bof))
|
||||
(= delta 0)) ; done if indenting occurred
|
||||
(let (eol state)
|
||||
(end-of-line)
|
||||
(setq eol (point))
|
||||
(if (= (char-after bof) ?=)
|
||||
(if (= oldpnt eol)
|
||||
(message "In a format statement"))
|
||||
(setq state (parse-partial-sexp lsexp eol))
|
||||
(if (nth 3 state)
|
||||
(if (= oldpnt eol) ; already at eol in a string
|
||||
(message "In a string which starts with a %c."
|
||||
(nth 3 state)))
|
||||
(if (not (nth 4 state))
|
||||
(if (= oldpnt eol) ; no comment, create one?
|
||||
(indent-for-comment))
|
||||
(beginning-of-line)
|
||||
(if (re-search-forward comment-start-skip eol 'move)
|
||||
(if (eolp)
|
||||
(progn ; kill existing comment
|
||||
(goto-char (match-beginning 0))
|
||||
(skip-chars-backward " \t")
|
||||
(kill-region (point) eol))
|
||||
(if (or (< oldpnt (point)) (= oldpnt eol))
|
||||
(indent-for-comment) ; indent existing comment
|
||||
(end-of-line)))
|
||||
(if (/= oldpnt eol)
|
||||
(end-of-line)
|
||||
(message "Use backslash to quote # characters.")
|
||||
(ding t))))))))))))
|
||||
|
||||
(defun perl-indent-line (&optional nochange parse-start)
|
||||
"Indent current line as Perl code. Return the amount the indentation
|
||||
changed by, or (parse-state) if line starts in a quoted string."
|
||||
(let ((case-fold-search nil)
|
||||
(pos (- (point-max) (point)))
|
||||
(bof (or parse-start (save-excursion (perl-beginning-of-function))))
|
||||
beg indent shift-amt)
|
||||
(beginning-of-line)
|
||||
(setq beg (point))
|
||||
(setq shift-amt
|
||||
(cond ((= (char-after bof) ?=) 0)
|
||||
((listp (setq indent (calculate-perl-indent bof))) indent)
|
||||
((looking-at (or nochange perl-nochange)) 0)
|
||||
(t
|
||||
(skip-chars-forward " \t\f")
|
||||
(cond ((looking-at "\\(\\w\\|\\s_\\)+:")
|
||||
(setq indent (max 1 (+ indent perl-label-offset))))
|
||||
((= (following-char) ?})
|
||||
(setq indent (- indent perl-indent-level)))
|
||||
((= (following-char) ?{)
|
||||
(setq indent (+ indent perl-brace-offset))))
|
||||
(- indent (current-column)))))
|
||||
(skip-chars-forward " \t\f")
|
||||
(if (and (numberp shift-amt) (/= 0 shift-amt))
|
||||
(progn (delete-region beg (point))
|
||||
(indent-to indent)))
|
||||
;; If initial point was within line's indentation,
|
||||
;; position after the indentation. Else stay at same point in text.
|
||||
(if (> (- (point-max) pos) (point))
|
||||
(goto-char (- (point-max) pos)))
|
||||
shift-amt))
|
||||
|
||||
(defun calculate-perl-indent (&optional parse-start)
|
||||
"Return appropriate indentation for current line as Perl code.
|
||||
In usual case returns an integer: the column to indent to.
|
||||
Returns (parse-state) if line starts inside a string."
|
||||
(save-excursion
|
||||
(beginning-of-line)
|
||||
(let ((indent-point (point))
|
||||
(case-fold-search nil)
|
||||
(colon-line-end 0)
|
||||
state containing-sexp)
|
||||
(if parse-start ;used to avoid searching
|
||||
(goto-char parse-start)
|
||||
(perl-beginning-of-function))
|
||||
(while (< (point) indent-point) ;repeat until right sexp
|
||||
(setq parse-start (point))
|
||||
(setq state (parse-partial-sexp (point) indent-point 0))
|
||||
; state = (depth_in_parens innermost_containing_list last_complete_sexp
|
||||
; string_terminator_or_nil inside_commentp following_quotep
|
||||
; minimum_paren-depth_this_scan)
|
||||
; Parsing stops if depth in parentheses becomes equal to third arg.
|
||||
(setq containing-sexp (nth 1 state)))
|
||||
(cond ((nth 3 state) state) ; In a quoted string?
|
||||
((null containing-sexp) ; Line is at top level.
|
||||
(skip-chars-forward " \t\f")
|
||||
(if (= (following-char) ?{)
|
||||
0 ; move to beginning of line if it starts a function body
|
||||
;; indent a little if this is a continuation line
|
||||
(perl-backward-to-noncomment)
|
||||
(if (or (bobp)
|
||||
(memq (preceding-char) '(?\; ?\})))
|
||||
0 perl-continued-statement-offset)))
|
||||
((/= (char-after containing-sexp) ?{)
|
||||
;; line is expression, not statement:
|
||||
;; indent to just after the surrounding open.
|
||||
(goto-char (1+ containing-sexp))
|
||||
(current-column))
|
||||
(t
|
||||
;; Statement level. Is it a continuation or a new statement?
|
||||
;; Find previous non-comment character.
|
||||
(perl-backward-to-noncomment)
|
||||
;; Back up over label lines, since they don't
|
||||
;; affect whether our line is a continuation.
|
||||
(while (or (eq (preceding-char) ?\,)
|
||||
(and (eq (preceding-char) ?:)
|
||||
(memq (char-syntax (char-after (- (point) 2)))
|
||||
'(?w ?_))))
|
||||
(if (eq (preceding-char) ?\,)
|
||||
(perl-backward-to-start-of-continued-exp containing-sexp))
|
||||
(beginning-of-line)
|
||||
(perl-backward-to-noncomment))
|
||||
;; Now we get the answer.
|
||||
(if (not (memq (preceding-char) '(?\; ?\} ?\{)))
|
||||
;; This line is continuation of preceding line's statement;
|
||||
;; indent perl-continued-statement-offset more than the
|
||||
;; previous line of the statement.
|
||||
(progn
|
||||
(perl-backward-to-start-of-continued-exp containing-sexp)
|
||||
(+ perl-continued-statement-offset (current-column)
|
||||
(if (save-excursion (goto-char indent-point)
|
||||
(looking-at "[ \t]*{"))
|
||||
perl-continued-brace-offset 0)))
|
||||
;; This line starts a new statement.
|
||||
;; Position at last unclosed open.
|
||||
(goto-char containing-sexp)
|
||||
(or
|
||||
;; If open paren is in col 0, close brace is special
|
||||
(and (bolp)
|
||||
(save-excursion (goto-char indent-point)
|
||||
(looking-at "[ \t]*}"))
|
||||
perl-indent-level)
|
||||
;; Is line first statement after an open-brace?
|
||||
;; If no, find that first statement and indent like it.
|
||||
(save-excursion
|
||||
(forward-char 1)
|
||||
;; Skip over comments and labels following openbrace.
|
||||
(while (progn
|
||||
(skip-chars-forward " \t\f\n")
|
||||
(cond ((looking-at ";?#")
|
||||
(forward-line 1) t)
|
||||
((looking-at "\\(\\w\\|\\s_\\)+:")
|
||||
(save-excursion
|
||||
(end-of-line)
|
||||
(setq colon-line-end (point)))
|
||||
(search-forward ":")))))
|
||||
;; The first following code counts
|
||||
;; if it is before the line we want to indent.
|
||||
(and (< (point) indent-point)
|
||||
(if (> colon-line-end (point))
|
||||
(- (current-indentation) perl-label-offset)
|
||||
(current-column))))
|
||||
;; If no previous statement,
|
||||
;; indent it relative to line brace is on.
|
||||
;; For open paren in column zero, don't let statement
|
||||
;; start there too. If perl-indent-level is zero,
|
||||
;; use perl-brace-offset + perl-continued-statement-offset
|
||||
;; For open-braces not the first thing in a line,
|
||||
;; add in perl-brace-imaginary-offset.
|
||||
(+ (if (and (bolp) (zerop perl-indent-level))
|
||||
(+ perl-brace-offset perl-continued-statement-offset)
|
||||
perl-indent-level)
|
||||
;; Move back over whitespace before the openbrace.
|
||||
;; If openbrace is not first nonwhite thing on the line,
|
||||
;; add the perl-brace-imaginary-offset.
|
||||
(progn (skip-chars-backward " \t")
|
||||
(if (bolp) 0 perl-brace-imaginary-offset))
|
||||
;; If the openbrace is preceded by a parenthesized exp,
|
||||
;; move to the beginning of that;
|
||||
;; possibly a different line
|
||||
(progn
|
||||
(if (eq (preceding-char) ?\))
|
||||
(forward-sexp -1))
|
||||
;; Get initial indentation of the line we are on.
|
||||
(current-indentation))))))))))
|
||||
|
||||
(defun perl-backward-to-noncomment ()
|
||||
"Move point backward to after the first non-white-space, skipping comments."
|
||||
(interactive)
|
||||
(let (opoint stop)
|
||||
(while (not stop)
|
||||
(setq opoint (point))
|
||||
(beginning-of-line)
|
||||
(if (re-search-forward comment-start-skip opoint 'move 1)
|
||||
(progn (goto-char (match-end 1))
|
||||
(skip-chars-forward ";")))
|
||||
(skip-chars-backward " \t\f")
|
||||
(setq stop (or (bobp)
|
||||
(not (bolp))
|
||||
(forward-char -1))))))
|
||||
|
||||
(defun perl-backward-to-start-of-continued-exp (lim)
|
||||
(if (= (preceding-char) ?\))
|
||||
(forward-sexp -1))
|
||||
(beginning-of-line)
|
||||
(if (<= (point) lim)
|
||||
(goto-char (1+ lim)))
|
||||
(skip-chars-forward " \t\f"))
|
||||
|
||||
;; note: this may be slower than the c-mode version, but I can understand it.
|
||||
(defun indent-perl-exp ()
|
||||
"Indent each line of the Perl grouping following point."
|
||||
(interactive)
|
||||
(let* ((case-fold-search nil)
|
||||
(oldpnt (point-marker))
|
||||
(bof-mark (save-excursion
|
||||
(end-of-line 2)
|
||||
(perl-beginning-of-function)
|
||||
(point-marker)))
|
||||
eol last-mark lsexp-mark delta)
|
||||
(if (= (char-after (marker-position bof-mark)) ?=)
|
||||
(message "Can't indent a format statement")
|
||||
(message "Indenting Perl expression...")
|
||||
(save-excursion (end-of-line) (setq eol (point)))
|
||||
(save-excursion ; locate matching close paren
|
||||
(while (and (not (eobp)) (<= (point) eol))
|
||||
(parse-partial-sexp (point) (point-max) 0))
|
||||
(setq last-mark (point-marker)))
|
||||
(setq lsexp-mark bof-mark)
|
||||
(beginning-of-line)
|
||||
(while (< (point) (marker-position last-mark))
|
||||
(setq delta (perl-indent-line nil (marker-position bof-mark)))
|
||||
(if (numberp delta) ; unquoted start-of-line?
|
||||
(progn
|
||||
(if (eolp)
|
||||
(delete-horizontal-space))
|
||||
(setq lsexp-mark (point-marker))))
|
||||
(end-of-line)
|
||||
(setq eol (point))
|
||||
(if (nth 4 (parse-partial-sexp (marker-position lsexp-mark) eol))
|
||||
(progn ; line ends in a comment
|
||||
(beginning-of-line)
|
||||
(if (or (not (looking-at "\\s-*;?#"))
|
||||
(listp delta)
|
||||
(and (/= 0 delta)
|
||||
(= (- (current-indentation) delta) comment-column)))
|
||||
(if (re-search-forward comment-start-skip eol t)
|
||||
(indent-for-comment))))) ; indent existing comment
|
||||
(forward-line 1))
|
||||
(goto-char (marker-position oldpnt))
|
||||
(message "Indenting Perl expression...done"))))
|
||||
|
||||
(defun perl-beginning-of-function (&optional arg)
|
||||
"Move backward to next beginning-of-function, or as far as possible.
|
||||
With argument, repeat that many times; negative args move forward.
|
||||
Returns new value of point in all cases."
|
||||
(interactive "p")
|
||||
(or arg (setq arg 1))
|
||||
(if (< arg 0) (forward-char 1))
|
||||
(and (/= arg 0)
|
||||
(re-search-backward "^\\s(\\|^\\s-*sub\\b[^{]+{\\|^\\s-*format\\b[^=]*=\\|^\\."
|
||||
nil 'move arg)
|
||||
(goto-char (1- (match-end 0))))
|
||||
(point))
|
||||
|
||||
;; note: this routine is adapted directly from emacs lisp.el, end-of-defun;
|
||||
;; no bugs have been removed :-)
|
||||
(defun perl-end-of-function (&optional arg)
|
||||
"Move forward to next end-of-function.
|
||||
The end of a function is found by moving forward from the beginning of one.
|
||||
With argument, repeat that many times; negative args move backward."
|
||||
(interactive "p")
|
||||
(or arg (setq arg 1))
|
||||
(let ((first t))
|
||||
(while (and (> arg 0) (< (point) (point-max)))
|
||||
(let ((pos (point)) npos)
|
||||
(while (progn
|
||||
(if (and first
|
||||
(progn
|
||||
(forward-char 1)
|
||||
(perl-beginning-of-function 1)
|
||||
(not (bobp))))
|
||||
nil
|
||||
(or (bobp) (forward-char -1))
|
||||
(perl-beginning-of-function -1))
|
||||
(setq first nil)
|
||||
(forward-list 1)
|
||||
(skip-chars-forward " \t")
|
||||
(if (looking-at "[#\n]")
|
||||
(forward-line 1))
|
||||
(<= (point) pos))))
|
||||
(setq arg (1- arg)))
|
||||
(while (< arg 0)
|
||||
(let ((pos (point)))
|
||||
(perl-beginning-of-function 1)
|
||||
(forward-sexp 1)
|
||||
(forward-line 1)
|
||||
(if (>= (point) pos)
|
||||
(if (progn (perl-beginning-of-function 2) (not (bobp)))
|
||||
(progn
|
||||
(forward-list 1)
|
||||
(skip-chars-forward " \t")
|
||||
(if (looking-at "[#\n]")
|
||||
(forward-line 1)))
|
||||
(goto-char (point-min)))))
|
||||
(setq arg (1+ arg)))))
|
||||
|
||||
(defun mark-perl-function ()
|
||||
"Put mark at end of Perl function, point at beginning."
|
||||
(interactive)
|
||||
(push-mark (point))
|
||||
(perl-end-of-function)
|
||||
(push-mark (point))
|
||||
(perl-beginning-of-function)
|
||||
(backward-paragraph))
|
||||
|
||||
;;;;;;;; That's all, folks! ;;;;;;;;;
|
||||
|
|
@ -1,423 +0,0 @@
|
|||
;; Run perl -d under Emacs
|
||||
;; Based on gdb.el, as written by W. Schelter, and modified by rms.
|
||||
;; Modified for Perl by Ray Lischner (uunet!mntgfx!lisch), Nov 1990.
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
;; Copyright (C) 1988,1990 Free Software Foundation, Inc.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful, but
|
||||
;; WITHOUT ANY WARRANTY. No author or distributor accepts responsibility
|
||||
;; to anyone for the consequences of using it or for whether it serves
|
||||
;; any particular purpose or works at all, unless he says so in writing.
|
||||
;; Refer to the GNU Emacs General Public License for full details.
|
||||
|
||||
;; Everyone is granted permission to copy, modify and redistribute GNU
|
||||
;; Emacs, but only under the conditions described in the GNU Emacs
|
||||
;; General Public License. A copy of this license is supposed to have
|
||||
;; been given to you along with GNU Emacs so you can know your rights and
|
||||
;; responsibilities. It should be in a file named COPYING. Among other
|
||||
;; things, the copyright notice and this notice must be preserved on all
|
||||
;; copies.
|
||||
|
||||
;; Description of perl -d interface:
|
||||
|
||||
;; A facility is provided for the simultaneous display of the source code
|
||||
;; in one window, while using perldb to step through a function in the
|
||||
;; other. A small arrow in the source window, indicates the current
|
||||
;; line.
|
||||
|
||||
;; Starting up:
|
||||
|
||||
;; In order to use this facility, invoke the command PERLDB to obtain a
|
||||
;; shell window with the appropriate command bindings. You will be asked
|
||||
;; for the name of a file to run and additional command line arguments.
|
||||
;; Perldb will be invoked on this file, in a window named *perldb-foo*
|
||||
;; if the file is foo.
|
||||
|
||||
;; M-s steps by one line, and redisplays the source file and line.
|
||||
|
||||
;; You may easily create additional commands and bindings to interact
|
||||
;; with the display. For example to put the perl debugger command n on \M-n
|
||||
;; (def-perldb n "\M-n")
|
||||
|
||||
;; This causes the emacs command perldb-next to be defined, and runs
|
||||
;; perldb-display-frame after the command.
|
||||
|
||||
;; perldb-display-frame is the basic display function. It tries to display
|
||||
;; in the other window, the file and line corresponding to the current
|
||||
;; position in the perldb window. For example after a perldb-step, it would
|
||||
;; display the line corresponding to the position for the last step. Or
|
||||
;; if you have done a backtrace in the perldb buffer, and move the cursor
|
||||
;; into one of the frames, it would display the position corresponding to
|
||||
;; that frame.
|
||||
|
||||
;; perldb-display-frame is invoked automatically when a filename-and-line-number
|
||||
;; appears in the output.
|
||||
|
||||
|
||||
(require 'shell)
|
||||
|
||||
(defvar perldb-prompt-pattern "^ DB<[0-9]+> "
|
||||
"A regexp to recognize the prompt for perldb.")
|
||||
|
||||
(defvar perldb-mode-map nil
|
||||
"Keymap for perldb-mode.")
|
||||
|
||||
(if perldb-mode-map
|
||||
nil
|
||||
(setq perldb-mode-map (copy-keymap shell-mode-map))
|
||||
(define-key perldb-mode-map "\C-l" 'perldb-refresh))
|
||||
|
||||
(define-key ctl-x-map " " 'perldb-break)
|
||||
(define-key ctl-x-map "&" 'send-perldb-command)
|
||||
|
||||
;;Of course you may use `def-perldb' with any other perldb command, including
|
||||
;;user defined ones.
|
||||
|
||||
(defmacro def-perldb (name key &optional doc)
|
||||
(let* ((fun (intern (concat "perldb-" name))))
|
||||
(` (progn
|
||||
(defun (, fun) (arg)
|
||||
(, (or doc ""))
|
||||
(interactive "p")
|
||||
(perldb-call (if (not (= 1 arg))
|
||||
(concat (, name) arg)
|
||||
(, name))))
|
||||
(define-key perldb-mode-map (, key) (quote (, fun)))))))
|
||||
|
||||
(def-perldb "s" "\M-s" "Step one source line with display")
|
||||
(def-perldb "n" "\M-n" "Step one source line (skip functions)")
|
||||
(def-perldb "c" "\M-c" "Continue with display")
|
||||
(def-perldb "r" "\C-c\C-r" "Return from current subroutine")
|
||||
(def-perldb "A" "\C-c\C-a" "Delete all actions")
|
||||
|
||||
(defun perldb-mode ()
|
||||
"Major mode for interacting with an inferior Perl debugger process.
|
||||
The following commands are available:
|
||||
|
||||
\\{perldb-mode-map}
|
||||
|
||||
\\[perldb-display-frame] displays in the other window
|
||||
the last line referred to in the perldb buffer.
|
||||
|
||||
\\[perldb-s],\\[perldb-n], and \\[perldb-n] in the perldb window,
|
||||
call perldb to step, next or continue and then update the other window
|
||||
with the current file and position.
|
||||
|
||||
If you are in a source file, you may select a point to break
|
||||
at, by doing \\[perldb-break].
|
||||
|
||||
Commands:
|
||||
Many commands are inherited from shell mode.
|
||||
Additionally we have:
|
||||
|
||||
\\[perldb-display-frame] display frames file in other window
|
||||
\\[perldb-s] advance one line in program
|
||||
\\[perldb-n] advance one line in program (skip over calls).
|
||||
\\[send-perldb-command] used for special printing of an arg at the current point.
|
||||
C-x SPACE sets break point at current line."
|
||||
(interactive)
|
||||
(kill-all-local-variables)
|
||||
(setq major-mode 'perldb-mode)
|
||||
(setq mode-name "Inferior Perl")
|
||||
(setq mode-line-process '(": %s"))
|
||||
(use-local-map perldb-mode-map)
|
||||
(make-local-variable 'last-input-start)
|
||||
(setq last-input-start (make-marker))
|
||||
(make-local-variable 'last-input-end)
|
||||
(setq last-input-end (make-marker))
|
||||
(make-local-variable 'perldb-last-frame)
|
||||
(setq perldb-last-frame nil)
|
||||
(make-local-variable 'perldb-last-frame-displayed-p)
|
||||
(setq perldb-last-frame-displayed-p t)
|
||||
(make-local-variable 'perldb-delete-prompt-marker)
|
||||
(setq perldb-delete-prompt-marker nil)
|
||||
(make-local-variable 'perldb-filter-accumulator)
|
||||
(setq perldb-filter-accumulator nil)
|
||||
(make-local-variable 'shell-prompt-pattern)
|
||||
(setq shell-prompt-pattern perldb-prompt-pattern)
|
||||
(run-hooks 'shell-mode-hook 'perldb-mode-hook))
|
||||
|
||||
(defvar current-perldb-buffer nil)
|
||||
|
||||
(defvar perldb-command-name "perl"
|
||||
"Pathname for executing perl -d.")
|
||||
|
||||
(defun end-of-quoted-arg (argstr start end)
|
||||
(let* ((chr (substring argstr start (1+ start)))
|
||||
(idx (string-match (concat "[^\\]" chr) argstr (1+ start))))
|
||||
(and idx (1+ idx))
|
||||
)
|
||||
)
|
||||
|
||||
(defun parse-args-helper (arglist argstr start end)
|
||||
(while (and (< start end) (string-match "[ \t\n\f\r\b]"
|
||||
(substring argstr start (1+ start))))
|
||||
(setq start (1+ start)))
|
||||
(cond
|
||||
((= start end) arglist)
|
||||
((string-match "[\"']" (substring argstr start (1+ start)))
|
||||
(let ((next (end-of-quoted-arg argstr start end)))
|
||||
(parse-args-helper (cons (substring argstr (1+ start) next) arglist)
|
||||
argstr (1+ next) end)))
|
||||
(t (let ((next (string-match "[ \t\n\f\b\r]" argstr start)))
|
||||
(if next
|
||||
(parse-args-helper (cons (substring argstr start next) arglist)
|
||||
argstr (1+ next) end)
|
||||
(cons (substring argstr start) arglist))))
|
||||
)
|
||||
)
|
||||
|
||||
(defun parse-args (args)
|
||||
"Extract arguments from a string ARGS.
|
||||
White space separates arguments, with single or double quotes
|
||||
used to protect spaces. A list of strings is returned, e.g.,
|
||||
(parse-args \"foo bar 'two args'\") => (\"foo\" \"bar\" \"two args\")."
|
||||
(nreverse (parse-args-helper '() args 0 (length args)))
|
||||
)
|
||||
|
||||
(defun perldb (path args)
|
||||
"Run perldb on program FILE in buffer *perldb-FILE*.
|
||||
The default directory for the current buffer becomes the initial
|
||||
working directory, by analogy with gdb . If you wish to change this, use
|
||||
the Perl command `chdir(DIR)'."
|
||||
(interactive "FRun perl -d on file: \nsCommand line arguments: ")
|
||||
(setq path (expand-file-name path))
|
||||
(let ((file (file-name-nondirectory path))
|
||||
(dir default-directory))
|
||||
(switch-to-buffer (concat "*perldb-" file "*"))
|
||||
(setq default-directory dir)
|
||||
(or (bolp) (newline))
|
||||
(insert "Current directory is " default-directory "\n")
|
||||
(apply 'make-shell
|
||||
(concat "perldb-" file) perldb-command-name nil "-d" path "-emacs"
|
||||
(parse-args args))
|
||||
(perldb-mode)
|
||||
(set-process-filter (get-buffer-process (current-buffer)) 'perldb-filter)
|
||||
(set-process-sentinel (get-buffer-process (current-buffer)) 'perldb-sentinel)
|
||||
(perldb-set-buffer)))
|
||||
|
||||
(defun perldb-set-buffer ()
|
||||
(cond ((eq major-mode 'perldb-mode)
|
||||
(setq current-perldb-buffer (current-buffer)))))
|
||||
|
||||
;; This function is responsible for inserting output from Perl
|
||||
;; into the buffer.
|
||||
;; Aside from inserting the text, it notices and deletes
|
||||
;; each filename-and-line-number;
|
||||
;; that Perl prints to identify the selected frame.
|
||||
;; It records the filename and line number, and maybe displays that file.
|
||||
(defun perldb-filter (proc string)
|
||||
(let ((inhibit-quit t))
|
||||
(if perldb-filter-accumulator
|
||||
(perldb-filter-accumulate-marker proc
|
||||
(concat perldb-filter-accumulator string))
|
||||
(perldb-filter-scan-input proc string))))
|
||||
|
||||
(defun perldb-filter-accumulate-marker (proc string)
|
||||
(setq perldb-filter-accumulator nil)
|
||||
(if (> (length string) 1)
|
||||
(if (= (aref string 1) ?\032)
|
||||
(let ((end (string-match "\n" string)))
|
||||
(if end
|
||||
(progn
|
||||
(let* ((first-colon (string-match ":" string 2))
|
||||
(second-colon
|
||||
(string-match ":" string (1+ first-colon))))
|
||||
(setq perldb-last-frame
|
||||
(cons (substring string 2 first-colon)
|
||||
(string-to-int
|
||||
(substring string (1+ first-colon)
|
||||
second-colon)))))
|
||||
(setq perldb-last-frame-displayed-p nil)
|
||||
(perldb-filter-scan-input proc
|
||||
(substring string (1+ end))))
|
||||
(setq perldb-filter-accumulator string)))
|
||||
(perldb-filter-insert proc "\032")
|
||||
(perldb-filter-scan-input proc (substring string 1)))
|
||||
(setq perldb-filter-accumulator string)))
|
||||
|
||||
(defun perldb-filter-scan-input (proc string)
|
||||
(if (equal string "")
|
||||
(setq perldb-filter-accumulator nil)
|
||||
(let ((start (string-match "\032" string)))
|
||||
(if start
|
||||
(progn (perldb-filter-insert proc (substring string 0 start))
|
||||
(perldb-filter-accumulate-marker proc
|
||||
(substring string start)))
|
||||
(perldb-filter-insert proc string)))))
|
||||
|
||||
(defun perldb-filter-insert (proc string)
|
||||
(let ((moving (= (point) (process-mark proc)))
|
||||
(output-after-point (< (point) (process-mark proc)))
|
||||
(old-buffer (current-buffer))
|
||||
start)
|
||||
(set-buffer (process-buffer proc))
|
||||
(unwind-protect
|
||||
(save-excursion
|
||||
;; Insert the text, moving the process-marker.
|
||||
(goto-char (process-mark proc))
|
||||
(setq start (point))
|
||||
(insert string)
|
||||
(set-marker (process-mark proc) (point))
|
||||
(perldb-maybe-delete-prompt)
|
||||
;; Check for a filename-and-line number.
|
||||
(perldb-display-frame
|
||||
;; Don't display the specified file
|
||||
;; unless (1) point is at or after the position where output appears
|
||||
;; and (2) this buffer is on the screen.
|
||||
(or output-after-point
|
||||
(not (get-buffer-window (current-buffer))))
|
||||
;; Display a file only when a new filename-and-line-number appears.
|
||||
t))
|
||||
(set-buffer old-buffer))
|
||||
(if moving (goto-char (process-mark proc)))))
|
||||
|
||||
(defun perldb-sentinel (proc msg)
|
||||
(cond ((null (buffer-name (process-buffer proc)))
|
||||
;; buffer killed
|
||||
;; Stop displaying an arrow in a source file.
|
||||
(setq overlay-arrow-position nil)
|
||||
(set-process-buffer proc nil))
|
||||
((memq (process-status proc) '(signal exit))
|
||||
;; Stop displaying an arrow in a source file.
|
||||
(setq overlay-arrow-position nil)
|
||||
;; Fix the mode line.
|
||||
(setq mode-line-process
|
||||
(concat ": "
|
||||
(symbol-name (process-status proc))))
|
||||
(let* ((obuf (current-buffer)))
|
||||
;; save-excursion isn't the right thing if
|
||||
;; process-buffer is current-buffer
|
||||
(unwind-protect
|
||||
(progn
|
||||
;; Write something in *compilation* and hack its mode line,
|
||||
(set-buffer (process-buffer proc))
|
||||
;; Force mode line redisplay soon
|
||||
(set-buffer-modified-p (buffer-modified-p))
|
||||
(if (eobp)
|
||||
(insert ?\n mode-name " " msg)
|
||||
(save-excursion
|
||||
(goto-char (point-max))
|
||||
(insert ?\n mode-name " " msg)))
|
||||
;; If buffer and mode line will show that the process
|
||||
;; is dead, we can delete it now. Otherwise it
|
||||
;; will stay around until M-x list-processes.
|
||||
(delete-process proc))
|
||||
;; Restore old buffer, but don't restore old point
|
||||
;; if obuf is the perldb buffer.
|
||||
(set-buffer obuf))))))
|
||||
|
||||
|
||||
(defun perldb-refresh ()
|
||||
"Fix up a possibly garbled display, and redraw the arrow."
|
||||
(interactive)
|
||||
(redraw-display)
|
||||
(perldb-display-frame))
|
||||
|
||||
(defun perldb-display-frame (&optional nodisplay noauto)
|
||||
"Find, obey and delete the last filename-and-line marker from PERLDB.
|
||||
The marker looks like \\032\\032FILENAME:LINE:CHARPOS\\n.
|
||||
Obeying it means displaying in another window the specified file and line."
|
||||
(interactive)
|
||||
(perldb-set-buffer)
|
||||
(and perldb-last-frame (not nodisplay)
|
||||
(or (not perldb-last-frame-displayed-p) (not noauto))
|
||||
(progn (perldb-display-line (car perldb-last-frame) (cdr perldb-last-frame))
|
||||
(setq perldb-last-frame-displayed-p t))))
|
||||
|
||||
;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen
|
||||
;; and that its line LINE is visible.
|
||||
;; Put the overlay-arrow on the line LINE in that buffer.
|
||||
|
||||
(defun perldb-display-line (true-file line)
|
||||
(let* ((buffer (find-file-noselect true-file))
|
||||
(window (display-buffer buffer t))
|
||||
(pos))
|
||||
(save-excursion
|
||||
(set-buffer buffer)
|
||||
(save-restriction
|
||||
(widen)
|
||||
(goto-line line)
|
||||
(setq pos (point))
|
||||
(setq overlay-arrow-string "=>")
|
||||
(or overlay-arrow-position
|
||||
(setq overlay-arrow-position (make-marker)))
|
||||
(set-marker overlay-arrow-position (point) (current-buffer)))
|
||||
(cond ((or (< pos (point-min)) (> pos (point-max)))
|
||||
(widen)
|
||||
(goto-char pos))))
|
||||
(set-window-point window overlay-arrow-position)))
|
||||
|
||||
(defun perldb-call (command)
|
||||
"Invoke perldb COMMAND displaying source in other window."
|
||||
(interactive)
|
||||
(goto-char (point-max))
|
||||
(setq perldb-delete-prompt-marker (point-marker))
|
||||
(perldb-set-buffer)
|
||||
(send-string (get-buffer-process current-perldb-buffer)
|
||||
(concat command "\n")))
|
||||
|
||||
(defun perldb-maybe-delete-prompt ()
|
||||
(if (and perldb-delete-prompt-marker
|
||||
(> (point-max) (marker-position perldb-delete-prompt-marker)))
|
||||
(let (start)
|
||||
(goto-char perldb-delete-prompt-marker)
|
||||
(setq start (point))
|
||||
(beginning-of-line)
|
||||
(delete-region (point) start)
|
||||
(setq perldb-delete-prompt-marker nil))))
|
||||
|
||||
(defun perldb-break ()
|
||||
"Set PERLDB breakpoint at this source line."
|
||||
(interactive)
|
||||
(let ((line (save-restriction
|
||||
(widen)
|
||||
(1+ (count-lines 1 (point))))))
|
||||
(send-string (get-buffer-process current-perldb-buffer)
|
||||
(concat "b " line "\n"))))
|
||||
|
||||
(defun perldb-read-token()
|
||||
"Return a string containing the token found in the buffer at point.
|
||||
A token can be a number or an identifier. If the token is a name prefaced
|
||||
by `$', `@', or `%', the leading character is included in the token."
|
||||
(save-excursion
|
||||
(let (begin)
|
||||
(or (looking-at "[$@%]")
|
||||
(re-search-backward "[^a-zA-Z_0-9]" (point-min) 'move))
|
||||
(setq begin (point))
|
||||
(or (looking-at "[$@%]") (setq begin (+ begin 1)))
|
||||
(forward-char 1)
|
||||
(buffer-substring begin
|
||||
(if (re-search-forward "[^a-zA-Z_0-9]"
|
||||
(point-max) 'move)
|
||||
(- (point) 1)
|
||||
(point)))
|
||||
)))
|
||||
|
||||
(defvar perldb-commands nil
|
||||
"List of strings or functions used by send-perldb-command.
|
||||
It is for customization by the user.")
|
||||
|
||||
(defun send-perldb-command (arg)
|
||||
"Issue a Perl debugger command selected by the prefix arg. A numeric
|
||||
arg selects the ARG'th member COMMAND of the list perldb-commands.
|
||||
The token under the cursor is passed to the command. If COMMAND is a
|
||||
string, (format COMMAND TOKEN) is inserted at the end of the perldb
|
||||
buffer, otherwise (funcall COMMAND TOKEN) is inserted. If there is
|
||||
no such COMMAND, then the token itself is inserted. For example,
|
||||
\"p %s\" is a possible string to be a member of perldb-commands,
|
||||
or \"p $ENV{%s}\"."
|
||||
(interactive "P")
|
||||
(let (comm token)
|
||||
(if arg (setq comm (nth arg perldb-commands)))
|
||||
(setq token (perldb-read-token))
|
||||
(if (eq (current-buffer) current-perldb-buffer)
|
||||
(set-mark (point)))
|
||||
(cond (comm
|
||||
(setq comm
|
||||
(if (stringp comm) (format comm token) (funcall comm token))))
|
||||
(t (setq comm token)))
|
||||
(switch-to-buffer-other-window current-perldb-buffer)
|
||||
(goto-char (dot-max))
|
||||
(insert-string comm)))
|
||||
|
|
@ -1,568 +0,0 @@
|
|||
package DB;
|
||||
|
||||
# modified Perl debugger, to be run from Emacs in perldb-mode
|
||||
# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
|
||||
|
||||
$header = '$Header: /home/cvs/386BSD/ports/lang/perl/emacs/perldb.pl,v 1.1.1.1 1993/08/23 21:29:46 nate Exp $';
|
||||
#
|
||||
# This file is automatically included if you do perl -d.
|
||||
# It's probably not useful to include this yourself.
|
||||
#
|
||||
# Perl supplies the values for @line and %sub. It effectively inserts
|
||||
# a do DB'DB(<linenum>); in front of every place that can
|
||||
# have a breakpoint. It also inserts a do 'perldb.pl' before the first line.
|
||||
#
|
||||
# $Log: perldb.pl,v $
|
||||
# Revision 1.1.1.1 1993/08/23 21:29:46 nate
|
||||
# PERL!
|
||||
#
|
||||
# Revision 4.0 91/03/20 01:18:58 lwall
|
||||
# 4.0 baseline.
|
||||
#
|
||||
# Revision 3.0.1.6 91/01/11 18:08:58 lwall
|
||||
# patch42: @_ couldn't be accessed from debugger
|
||||
#
|
||||
# Revision 3.0.1.5 90/11/10 01:40:26 lwall
|
||||
# patch38: the debugger wouldn't stop correctly or do action routines
|
||||
#
|
||||
# Revision 3.0.1.4 90/10/15 17:40:38 lwall
|
||||
# patch29: added caller
|
||||
# patch29: the debugger now understands packages and evals
|
||||
# patch29: scripts now run at almost full speed under the debugger
|
||||
# patch29: more variables are settable from debugger
|
||||
#
|
||||
# Revision 3.0.1.3 90/08/09 04:00:58 lwall
|
||||
# patch19: debugger now allows continuation lines
|
||||
# patch19: debugger can now dump lists of variables
|
||||
# patch19: debugger can now add aliases easily from prompt
|
||||
#
|
||||
# Revision 3.0.1.2 90/03/12 16:39:39 lwall
|
||||
# patch13: perl -d didn't format stack traces of *foo right
|
||||
# patch13: perl -d wiped out scalar return values of subroutines
|
||||
#
|
||||
# Revision 3.0.1.1 89/10/26 23:14:02 lwall
|
||||
# patch1: RCS expanded an unintended $Header in lib/perldb.pl
|
||||
#
|
||||
# Revision 3.0 89/10/18 15:19:46 lwall
|
||||
# 3.0 baseline
|
||||
#
|
||||
# Revision 2.0 88/06/05 00:09:45 root
|
||||
# Baseline version 2.0.
|
||||
#
|
||||
#
|
||||
|
||||
open(IN, "</dev/tty") || open(IN, "<&STDIN"); # so we don't dingle stdin
|
||||
open(OUT,">/dev/tty") || open(OUT, ">&STDOUT"); # so we don't dongle stdout
|
||||
select(OUT);
|
||||
$| = 1; # for DB'OUT
|
||||
select(STDOUT);
|
||||
$| = 1; # for real STDOUT
|
||||
$sub = '';
|
||||
|
||||
# Is Perl being run from Emacs?
|
||||
$emacs = $main'ARGV[$[] eq '-emacs';
|
||||
shift(@main'ARGV) if $emacs;
|
||||
|
||||
$header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
|
||||
print OUT "\nLoading DB routines from $header\n\nEnter h for help.\n\n";
|
||||
|
||||
sub DB {
|
||||
&save;
|
||||
($package, $filename, $line) = caller;
|
||||
$usercontext = '($@, $!, $[, $,, $/, $\) = @saved;' .
|
||||
"package $package;"; # this won't let them modify, alas
|
||||
local(*dbline) = "_<$filename";
|
||||
$max = $#dbline;
|
||||
if (($stop,$action) = split(/\0/,$dbline{$line})) {
|
||||
if ($stop eq '1') {
|
||||
$signal |= 1;
|
||||
}
|
||||
else {
|
||||
$evalarg = "\$DB'signal |= do {$stop;}"; &eval;
|
||||
$dbline{$line} =~ s/;9($|\0)/$1/;
|
||||
}
|
||||
}
|
||||
if ($single || $trace || $signal) {
|
||||
if ($emacs) {
|
||||
print OUT "\032\032$filename:$line:0\n";
|
||||
} else {
|
||||
print OUT "$package'" unless $sub =~ /'/;
|
||||
print OUT "$sub($filename:$line):\t",$dbline[$line];
|
||||
for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) {
|
||||
last if $dbline[$i] =~ /^\s*(}|#|\n)/;
|
||||
print OUT "$sub($filename:$i):\t",$dbline[$i];
|
||||
}
|
||||
}
|
||||
}
|
||||
$evalarg = $action, &eval if $action;
|
||||
if ($single || $signal) {
|
||||
$evalarg = $pre, &eval if $pre;
|
||||
print OUT $#stack . " levels deep in subroutine calls!\n"
|
||||
if $single & 4;
|
||||
$start = $line;
|
||||
while ((print OUT " DB<", $#hist+1, "> "), $cmd=&gets) {
|
||||
$single = 0;
|
||||
$signal = 0;
|
||||
$cmd eq '' && exit 0;
|
||||
chop($cmd);
|
||||
$cmd =~ s/\\$// && do {
|
||||
print OUT " cont: ";
|
||||
$cmd .= &gets;
|
||||
redo;
|
||||
};
|
||||
$cmd =~ /^q$/ && exit 0;
|
||||
$cmd =~ /^$/ && ($cmd = $laststep);
|
||||
push(@hist,$cmd) if length($cmd) > 1;
|
||||
($i) = split(/\s+/,$cmd);
|
||||
eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i};
|
||||
$cmd =~ /^h$/ && do {
|
||||
print OUT "
|
||||
T Stack trace.
|
||||
s Single step.
|
||||
n Next, steps over subroutine calls.
|
||||
r Return from current subroutine.
|
||||
c [line] Continue; optionally inserts a one-time-only breakpoint
|
||||
at the specified line.
|
||||
<CR> Repeat last n or s.
|
||||
l min+incr List incr+1 lines starting at min.
|
||||
l min-max List lines.
|
||||
l line List line;
|
||||
l List next window.
|
||||
- List previous window.
|
||||
w line List window around line.
|
||||
l subname List subroutine.
|
||||
f filename Switch to filename.
|
||||
/pattern/ Search forwards for pattern; final / is optional.
|
||||
?pattern? Search backwards for pattern.
|
||||
L List breakpoints and actions.
|
||||
S List subroutine names.
|
||||
t Toggle trace mode.
|
||||
b [line] [condition]
|
||||
Set breakpoint; line defaults to the current execution line;
|
||||
condition breaks if it evaluates to true, defaults to \'1\'.
|
||||
b subname [condition]
|
||||
Set breakpoint at first line of subroutine.
|
||||
d [line] Delete breakpoint.
|
||||
D Delete all breakpoints.
|
||||
a [line] command
|
||||
Set an action to be done before the line is executed.
|
||||
Sequence is: check for breakpoint, print line if necessary,
|
||||
do action, prompt user if breakpoint or step, evaluate line.
|
||||
A Delete all actions.
|
||||
V [pkg [vars]] List some (default all) variables in package (default current).
|
||||
X [vars] Same as \"V currentpackage [vars]\".
|
||||
< command Define command before prompt.
|
||||
| command Define command after prompt.
|
||||
! number Redo command (default previous command).
|
||||
! -number Redo number\'th to last command.
|
||||
H -number Display last number commands (default all).
|
||||
q or ^D Quit.
|
||||
p expr Same as \"print DB'OUT expr\" in current package.
|
||||
= [alias value] Define a command alias, or list current aliases.
|
||||
command Execute as a perl statement in current package.
|
||||
|
||||
";
|
||||
next; };
|
||||
$cmd =~ /^t$/ && do {
|
||||
$trace = !$trace;
|
||||
print OUT "Trace = ".($trace?"on":"off")."\n";
|
||||
next; };
|
||||
$cmd =~ /^S$/ && do {
|
||||
foreach $subname (sort(keys %sub)) {
|
||||
print OUT $subname,"\n";
|
||||
}
|
||||
next; };
|
||||
$cmd =~ s/^X\b/V $package/;
|
||||
$cmd =~ /^V$/ && do {
|
||||
$cmd = 'V $package'; };
|
||||
$cmd =~ /^V\s*(\S+)\s*(.*)/ && do {
|
||||
$packname = $1;
|
||||
@vars = split(' ',$2);
|
||||
do 'dumpvar.pl' unless defined &main'dumpvar;
|
||||
if (defined &main'dumpvar) {
|
||||
&main'dumpvar($packname,@vars);
|
||||
}
|
||||
else {
|
||||
print DB'OUT "dumpvar.pl not available.\n";
|
||||
}
|
||||
next; };
|
||||
$cmd =~ /^f\s*(.*)/ && do {
|
||||
$file = $1;
|
||||
if (!$file) {
|
||||
print OUT "The old f command is now the r command.\n";
|
||||
print OUT "The new f command switches filenames.\n";
|
||||
next;
|
||||
}
|
||||
if (!defined $_main{'_<' . $file}) {
|
||||
if (($try) = grep(m#^_<.*$file#, keys %_main)) {
|
||||
$file = substr($try,2);
|
||||
print "\n$file:\n";
|
||||
}
|
||||
}
|
||||
if (!defined $_main{'_<' . $file}) {
|
||||
print OUT "There's no code here anything matching $file.\n";
|
||||
next;
|
||||
}
|
||||
elsif ($file ne $filename) {
|
||||
*dbline = "_<$file";
|
||||
$max = $#dbline;
|
||||
$filename = $file;
|
||||
$start = 1;
|
||||
$cmd = "l";
|
||||
} };
|
||||
$cmd =~ /^l\s*(['A-Za-z_]['\w]*)/ && do {
|
||||
$subname = $1;
|
||||
$subname = "main'" . $subname unless $subname =~ /'/;
|
||||
$subname = "main" . $subname if substr($subname,0,1) eq "'";
|
||||
($file,$subrange) = split(/:/,$sub{$subname});
|
||||
if ($file ne $filename) {
|
||||
*dbline = "_<$file";
|
||||
$max = $#dbline;
|
||||
$filename = $file;
|
||||
}
|
||||
if ($subrange) {
|
||||
if (eval($subrange) < -$window) {
|
||||
$subrange =~ s/-.*/+/;
|
||||
}
|
||||
$cmd = "l $subrange";
|
||||
} else {
|
||||
print OUT "Subroutine $1 not found.\n";
|
||||
next;
|
||||
} };
|
||||
$cmd =~ /^w\s*(\d*)$/ && do {
|
||||
$incr = $window - 1;
|
||||
$start = $1 if $1;
|
||||
$start -= $preview;
|
||||
$cmd = 'l ' . $start . '-' . ($start + $incr); };
|
||||
$cmd =~ /^-$/ && do {
|
||||
$incr = $window - 1;
|
||||
$cmd = 'l ' . ($start-$window*2) . '+'; };
|
||||
$cmd =~ /^l$/ && do {
|
||||
$incr = $window - 1;
|
||||
$cmd = 'l ' . $start . '-' . ($start + $incr); };
|
||||
$cmd =~ /^l\s*(\d*)\+(\d*)$/ && do {
|
||||
$start = $1 if $1;
|
||||
$incr = $2;
|
||||
$incr = $window - 1 unless $incr;
|
||||
$cmd = 'l ' . $start . '-' . ($start + $incr); };
|
||||
$cmd =~ /^l\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
|
||||
$end = (!$2) ? $max : ($4 ? $4 : $2);
|
||||
$end = $max if $end > $max;
|
||||
$i = $2;
|
||||
$i = $line if $i eq '.';
|
||||
$i = 1 if $i < 1;
|
||||
if ($emacs) {
|
||||
print OUT "\032\032$filename:$i:0\n";
|
||||
$i = $end;
|
||||
} else {
|
||||
for (; $i <= $end; $i++) {
|
||||
print OUT "$i:\t", $dbline[$i];
|
||||
last if $signal;
|
||||
}
|
||||
}
|
||||
$start = $i; # remember in case they want more
|
||||
$start = $max if $start > $max;
|
||||
next; };
|
||||
$cmd =~ /^D$/ && do {
|
||||
print OUT "Deleting all breakpoints...\n";
|
||||
for ($i = 1; $i <= $max ; $i++) {
|
||||
if (defined $dbline{$i}) {
|
||||
$dbline{$i} =~ s/^[^\0]+//;
|
||||
if ($dbline{$i} =~ s/^\0?$//) {
|
||||
delete $dbline{$i};
|
||||
}
|
||||
}
|
||||
}
|
||||
next; };
|
||||
$cmd =~ /^L$/ && do {
|
||||
for ($i = 1; $i <= $max; $i++) {
|
||||
if (defined $dbline{$i}) {
|
||||
print OUT "$i:\t", $dbline[$i];
|
||||
($stop,$action) = split(/\0/, $dbline{$i});
|
||||
print OUT " break if (", $stop, ")\n"
|
||||
if $stop;
|
||||
print OUT " action: ", $action, "\n"
|
||||
if $action;
|
||||
last if $signal;
|
||||
}
|
||||
}
|
||||
next; };
|
||||
$cmd =~ /^b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do {
|
||||
$subname = $1;
|
||||
$cond = $2 || '1';
|
||||
$subname = "$package'" . $subname unless $subname =~ /'/;
|
||||
$subname = "main" . $subname if substr($subname,0,1) eq "'";
|
||||
($filename,$i) = split(/[:-]/, $sub{$subname});
|
||||
if ($i) {
|
||||
*dbline = "_<$filename";
|
||||
++$i while $dbline[$i] == 0 && $i < $#dbline;
|
||||
$dbline{$i} =~ s/^[^\0]*/$cond/;
|
||||
} else {
|
||||
print OUT "Subroutine $subname not found.\n";
|
||||
}
|
||||
next; };
|
||||
$cmd =~ /^b\s*(\d*)\s*(.*)/ && do {
|
||||
$i = ($1?$1:$line);
|
||||
$cond = $2 || '1';
|
||||
if ($dbline[$i] == 0) {
|
||||
print OUT "Line $i not breakable.\n";
|
||||
} else {
|
||||
$dbline{$i} =~ s/^[^\0]*/$cond/;
|
||||
}
|
||||
next; };
|
||||
$cmd =~ /^d\s*(\d+)?/ && do {
|
||||
$i = ($1?$1:$line);
|
||||
$dbline{$i} =~ s/^[^\0]*//;
|
||||
delete $dbline{$i} if $dbline{$i} eq '';
|
||||
next; };
|
||||
$cmd =~ /^A$/ && do {
|
||||
for ($i = 1; $i <= $max ; $i++) {
|
||||
if (defined $dbline{$i}) {
|
||||
$dbline{$i} =~ s/\0[^\0]*//;
|
||||
delete $dbline{$i} if $dbline{$i} eq '';
|
||||
}
|
||||
}
|
||||
next; };
|
||||
$cmd =~ /^<\s*(.*)/ && do {
|
||||
$pre = do action($1);
|
||||
next; };
|
||||
$cmd =~ /^>\s*(.*)/ && do {
|
||||
$post = do action($1);
|
||||
next; };
|
||||
$cmd =~ /^a\s*(\d+)(\s+(.*))?/ && do {
|
||||
$i = $1;
|
||||
if ($dbline[$i] == 0) {
|
||||
print OUT "Line $i may not have an action.\n";
|
||||
} else {
|
||||
$dbline{$i} =~ s/\0[^\0]*//;
|
||||
$dbline{$i} .= "\0" . do action($3);
|
||||
}
|
||||
next; };
|
||||
$cmd =~ /^n$/ && do {
|
||||
$single = 2;
|
||||
$laststep = $cmd;
|
||||
last; };
|
||||
$cmd =~ /^s$/ && do {
|
||||
$single = 1;
|
||||
$laststep = $cmd;
|
||||
last; };
|
||||
$cmd =~ /^c\s*(\d*)\s*$/ && do {
|
||||
$i = $1;
|
||||
if ($i) {
|
||||
if ($dbline[$i] == 0) {
|
||||
print OUT "Line $i not breakable.\n";
|
||||
next;
|
||||
}
|
||||
$dbline{$i} =~ s/(\0|$)/;9$1/; # add one-time-only b.p.
|
||||
}
|
||||
for ($i=0; $i <= $#stack; ) {
|
||||
$stack[$i++] &= ~1;
|
||||
}
|
||||
last; };
|
||||
$cmd =~ /^r$/ && do {
|
||||
$stack[$#stack] |= 2;
|
||||
last; };
|
||||
$cmd =~ /^T$/ && do {
|
||||
local($p,$f,$l,$s,$h,$a,@a,@sub);
|
||||
for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
|
||||
@a = @args;
|
||||
for (@a) {
|
||||
if (/^StB\000/ && length($_) == length($_main{'_main'})) {
|
||||
$_ = sprintf("%s",$_);
|
||||
}
|
||||
else {
|
||||
s/'/\\'/g;
|
||||
s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
|
||||
s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
|
||||
s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
|
||||
}
|
||||
}
|
||||
$w = $w ? '@ = ' : '$ = ';
|
||||
$a = $h ? '(' . join(', ', @a) . ')' : '';
|
||||
push(@sub, "$w&$s$a from file $f line $l\n");
|
||||
last if $signal;
|
||||
}
|
||||
for ($i=0; $i <= $#sub; $i++) {
|
||||
last if $signal;
|
||||
print OUT $sub[$i];
|
||||
}
|
||||
next; };
|
||||
$cmd =~ /^\/(.*)$/ && do {
|
||||
$inpat = $1;
|
||||
$inpat =~ s:([^\\])/$:$1:;
|
||||
if ($inpat ne "") {
|
||||
eval '$inpat =~ m'."\n$inpat\n";
|
||||
if ($@ ne "") {
|
||||
print OUT "$@";
|
||||
next;
|
||||
}
|
||||
$pat = $inpat;
|
||||
}
|
||||
$end = $start;
|
||||
eval '
|
||||
for (;;) {
|
||||
++$start;
|
||||
$start = 1 if ($start > $max);
|
||||
last if ($start == $end);
|
||||
if ($dbline[$start] =~ m'."\n$pat\n".'i) {
|
||||
if ($emacs) {
|
||||
print OUT "\032\032$filename:$start:0\n";
|
||||
} else {
|
||||
print OUT "$start:\t", $dbline[$start], "\n";
|
||||
}
|
||||
last;
|
||||
}
|
||||
} ';
|
||||
print OUT "/$pat/: not found\n" if ($start == $end);
|
||||
next; };
|
||||
$cmd =~ /^\?(.*)$/ && do {
|
||||
$inpat = $1;
|
||||
$inpat =~ s:([^\\])\?$:$1:;
|
||||
if ($inpat ne "") {
|
||||
eval '$inpat =~ m'."\n$inpat\n";
|
||||
if ($@ ne "") {
|
||||
print OUT "$@";
|
||||
next;
|
||||
}
|
||||
$pat = $inpat;
|
||||
}
|
||||
$end = $start;
|
||||
eval '
|
||||
for (;;) {
|
||||
--$start;
|
||||
$start = $max if ($start <= 0);
|
||||
last if ($start == $end);
|
||||
if ($dbline[$start] =~ m'."\n$pat\n".'i) {
|
||||
if ($emacs) {
|
||||
print OUT "\032\032$filename:$start:0\n";
|
||||
} else {
|
||||
print OUT "$start:\t", $dbline[$start], "\n";
|
||||
}
|
||||
last;
|
||||
}
|
||||
} ';
|
||||
print OUT "?$pat?: not found\n" if ($start == $end);
|
||||
next; };
|
||||
$cmd =~ /^!+\s*(-)?(\d+)?$/ && do {
|
||||
pop(@hist) if length($cmd) > 1;
|
||||
$i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist));
|
||||
$cmd = $hist[$i] . "\n";
|
||||
print OUT $cmd;
|
||||
redo; };
|
||||
$cmd =~ /^!(.+)$/ && do {
|
||||
$pat = "^$1";
|
||||
pop(@hist) if length($cmd) > 1;
|
||||
for ($i = $#hist; $i; --$i) {
|
||||
last if $hist[$i] =~ $pat;
|
||||
}
|
||||
if (!$i) {
|
||||
print OUT "No such command!\n\n";
|
||||
next;
|
||||
}
|
||||
$cmd = $hist[$i] . "\n";
|
||||
print OUT $cmd;
|
||||
redo; };
|
||||
$cmd =~ /^H\s*(-(\d+))?/ && do {
|
||||
$end = $2?($#hist-$2):0;
|
||||
$hist = 0 if $hist < 0;
|
||||
for ($i=$#hist; $i>$end; $i--) {
|
||||
print OUT "$i: ",$hist[$i],"\n"
|
||||
unless $hist[$i] =~ /^.?$/;
|
||||
};
|
||||
next; };
|
||||
$cmd =~ s/^p( .*)?$/print DB'OUT$1/;
|
||||
$cmd =~ /^=/ && do {
|
||||
if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
|
||||
$alias{$k}="s~$k~$v~";
|
||||
print OUT "$k = $v\n";
|
||||
} elsif ($cmd =~ /^=\s*$/) {
|
||||
foreach $k (sort keys(%alias)) {
|
||||
if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
|
||||
print OUT "$k = $v\n";
|
||||
} else {
|
||||
print OUT "$k\t$alias{$k}\n";
|
||||
};
|
||||
};
|
||||
};
|
||||
next; };
|
||||
$evalarg = $cmd; &eval;
|
||||
print OUT "\n";
|
||||
}
|
||||
if ($post) {
|
||||
$evalarg = $post; &eval;
|
||||
}
|
||||
}
|
||||
($@, $!, $[, $,, $/, $\) = @saved;
|
||||
}
|
||||
|
||||
sub save {
|
||||
@saved = ($@, $!, $[, $,, $/, $\);
|
||||
$[ = 0; $, = ""; $/ = "\n"; $\ = "";
|
||||
}
|
||||
|
||||
# The following takes its argument via $evalarg to preserve current @_
|
||||
|
||||
sub eval {
|
||||
eval "$usercontext $evalarg; &DB'save";
|
||||
print OUT $@;
|
||||
}
|
||||
|
||||
sub action {
|
||||
local($action) = @_;
|
||||
while ($action =~ s/\\$//) {
|
||||
print OUT "+ ";
|
||||
$action .= &gets;
|
||||
}
|
||||
$action;
|
||||
}
|
||||
|
||||
sub gets {
|
||||
local($.);
|
||||
<IN>;
|
||||
}
|
||||
|
||||
sub catch {
|
||||
$signal = 1;
|
||||
}
|
||||
|
||||
sub sub {
|
||||
push(@stack, $single);
|
||||
$single &= 1;
|
||||
$single |= 4 if $#stack == $deep;
|
||||
if (wantarray) {
|
||||
@i = &$sub;
|
||||
$single |= pop(@stack);
|
||||
@i;
|
||||
}
|
||||
else {
|
||||
$i = &$sub;
|
||||
$single |= pop(@stack);
|
||||
$i;
|
||||
}
|
||||
}
|
||||
|
||||
$single = 1; # so it stops on first executable statement
|
||||
@hist = ('?');
|
||||
$SIG{'INT'} = "DB'catch";
|
||||
$deep = 100; # warning if stack gets this deep
|
||||
$window = 10;
|
||||
$preview = 3;
|
||||
|
||||
@stack = (0);
|
||||
@ARGS = @ARGV;
|
||||
for (@args) {
|
||||
s/'/\\'/g;
|
||||
s/(.*)/'$1'/ unless /^-?[\d.]+$/;
|
||||
}
|
||||
|
||||
if (-f '.perldb') {
|
||||
do './.perldb';
|
||||
}
|
||||
elsif (-f "$ENV{'LOGDIR'}/.perldb") {
|
||||
do "$ENV{'LOGDIR'}/.perldb";
|
||||
}
|
||||
elsif (-f "$ENV{'HOME'}/.perldb") {
|
||||
do "$ENV{'HOME'}/.perldb";
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,296 +0,0 @@
|
|||
Article 4417 of comp.lang.perl:
|
||||
Path: jpl-devvax!elroy.jpl.nasa.gov!decwrl!mcnc!uvaarpa!mmdf
|
||||
From: ted@evi.com (Ted Stefanik)
|
||||
Newsgroups: comp.lang.perl
|
||||
Subject: Correction to Perl fatal error marking in GNU Emacs
|
||||
Message-ID: <1991Feb27.065853.15801@uvaarpa.Virginia.EDU>
|
||||
Date: 27 Feb 91 06:58:53 GMT
|
||||
Sender: mmdf@uvaarpa.Virginia.EDU (Uvaarpa Mail System)
|
||||
Reply-To: ted@evi.com (Ted Stefanik)
|
||||
Organization: The Internet
|
||||
Lines: 282
|
||||
|
||||
Reading my own message, it occurred to me that I didn't quite satisfy the
|
||||
request of stef@zweig.sun (Stephane Payrard):
|
||||
|
||||
| Does anyone has extended perdb/perdb.el to position the
|
||||
| point to the first syntax error? It would be cool.
|
||||
|
||||
What I posted is a way to use the "M-x compile" command to test perl scripts.
|
||||
(Needless to say, the script cannot be not interactive; you can't provide input
|
||||
to a *compilation* buffer). When creating new Perl programs, I use "M-x
|
||||
compile" until I'm sure that they are syntatically correct; if syntax errors
|
||||
occur, C-x` takes me to each in sequence. After I'm sure the syntax is
|
||||
correct, I start worrying about semantics, and switch to "M-x perldb" if
|
||||
necessary.
|
||||
|
||||
Therefore, the stuff I posted works great with "M-x compile", but not at all
|
||||
with "M-x perldb".
|
||||
|
||||
Next, let me update what I posted. I found that perl's die() command doesn't
|
||||
print the same format error message as perl does when it dies with a syntax
|
||||
error. If you put the following in your ".emacs" file, it causes C-x` to
|
||||
recognize both kinds of errors:
|
||||
|
||||
(load-library "compile")
|
||||
(setq compilation-error-regexp
|
||||
"\\([^ :\n]+\\(: *\\|, line \\|(\\)[0-9]+\\)\\|\\([0-9]+ *of *[^ \n]+\\|[^ \n]+ \\(at \\)*line [0-9]+\\)")
|
||||
|
||||
Last, so I don't look like a total fool, let me propose a way to satisfy
|
||||
Stephane Payrard's original request (repeated again):
|
||||
|
||||
| Does anyone has extended perdb/perdb.el to position the
|
||||
| point to the first syntax error? It would be cool.
|
||||
|
||||
I'm not satisfied with just the "first syntax error". Perl's parser is better
|
||||
than most about not getting out of sync; therefore, if it reports multiple
|
||||
errors, you can usually be assured they are all real errors.
|
||||
|
||||
So... I hacked in the "next-error" function from "compile.el" to form
|
||||
"perldb-next-error". You can apply the patches at the end of this message
|
||||
to add "perldb-next-error" to your "perldb.el".
|
||||
|
||||
Notes:
|
||||
1) The patch binds "perldb-next-error" to C-x~ (because ~ is the shift
|
||||
of ` on my keyboard, and C-x~ is not yet taken in my version of EMACS).
|
||||
|
||||
2) "next-error" is meant to work on a single *compilation* buffer; any new
|
||||
"M-x compile" or "M-x grep" command will clear the old *compilation*
|
||||
buffer and reset the compilation-error parser to start at the top of the
|
||||
*compilation* buffer.
|
||||
|
||||
"perldb-next-error", on the other hand, has to deal with multiple
|
||||
*perldb-<foo>* buffers, each of which keep growing. "perldb-next-error"
|
||||
correctly handles the constantly growing *perldb-<foo>* buffers by
|
||||
keeping track of the last reported error in the "current-perldb-buffer".
|
||||
|
||||
Sadly however, when you invoke a new "M-x perldb" on a different Perl
|
||||
script, "perldb-next-error" will start parsing the new *perldb-<bar>*
|
||||
buffer at the top (even if it was previously parsed), and will completely
|
||||
lose the marker of the last reported error in *perldb-<foo>*.
|
||||
|
||||
3) "perldb-next-error" still uses "compilation-error-regexp" to find
|
||||
fatal errors. Therefore, both the "M-x compile"/C-x` scheme and
|
||||
the "M-x perldb"/C-x~ scheme can be used to find fatal errors that
|
||||
match the common "compilation-error-regexp". You *will* want to install
|
||||
that "compilation-error-regexp" stuff into your .emacs file.
|
||||
|
||||
4) The patch was developed and tested with GNU Emacs 18.55.
|
||||
|
||||
5) Since the patch was ripped off from compile.el, the code is (of
|
||||
course) subject to the GNU copyleft.
|
||||
|
||||
*** perldb.el.orig Wed Feb 27 00:44:27 1991
|
||||
--- perldb.el Wed Feb 27 00:44:30 1991
|
||||
***************
|
||||
*** 199,205 ****
|
||||
|
||||
(defun perldb-set-buffer ()
|
||||
(cond ((eq major-mode 'perldb-mode)
|
||||
! (setq current-perldb-buffer (current-buffer)))))
|
||||
|
||||
;; This function is responsible for inserting output from Perl
|
||||
;; into the buffer.
|
||||
--- 199,211 ----
|
||||
|
||||
(defun perldb-set-buffer ()
|
||||
(cond ((eq major-mode 'perldb-mode)
|
||||
! (cond ((not (eq current-perldb-buffer (current-buffer)))
|
||||
! (perldb-forget-errors)
|
||||
! (setq perldb-parsing-end 2)) ;; 2 to defeat grep defeater
|
||||
! (t
|
||||
! (if (> perldb-parsing-end (point-max))
|
||||
! (setq perldb-parsing-end (max (point-max) 2)))))
|
||||
! (setq current-perldb-buffer (current-buffer)))))
|
||||
|
||||
;; This function is responsible for inserting output from Perl
|
||||
;; into the buffer.
|
||||
***************
|
||||
*** 291,297 ****
|
||||
;; process-buffer is current-buffer
|
||||
(unwind-protect
|
||||
(progn
|
||||
! ;; Write something in *compilation* and hack its mode line,
|
||||
(set-buffer (process-buffer proc))
|
||||
;; Force mode line redisplay soon
|
||||
(set-buffer-modified-p (buffer-modified-p))
|
||||
--- 297,303 ----
|
||||
;; process-buffer is current-buffer
|
||||
(unwind-protect
|
||||
(progn
|
||||
! ;; Write something in *perldb-<foo>* and hack its mode line,
|
||||
(set-buffer (process-buffer proc))
|
||||
;; Force mode line redisplay soon
|
||||
(set-buffer-modified-p (buffer-modified-p))
|
||||
***************
|
||||
*** 421,423 ****
|
||||
--- 427,593 ----
|
||||
(switch-to-buffer-other-window current-perldb-buffer)
|
||||
(goto-char (dot-max))
|
||||
(insert-string comm)))
|
||||
+
|
||||
+ (defvar perldb-error-list nil
|
||||
+ "List of error message descriptors for visiting erring functions.
|
||||
+ Each error descriptor is a list of length two.
|
||||
+ Its car is a marker pointing to an error message.
|
||||
+ Its cadr is a marker pointing to the text of the line the message is about,
|
||||
+ or nil if that is not interesting.
|
||||
+ The value may be t instead of a list;
|
||||
+ this means that the buffer of error messages should be reparsed
|
||||
+ the next time the list of errors is wanted.")
|
||||
+
|
||||
+ (defvar perldb-parsing-end nil
|
||||
+ "Position of end of buffer when last error messages parsed.")
|
||||
+
|
||||
+ (defvar perldb-error-message "No more fatal Perl errors"
|
||||
+ "Message to print when no more matches for compilation-error-regexp are found")
|
||||
+
|
||||
+ (defun perldb-next-error (&optional argp)
|
||||
+ "Visit next perldb error message and corresponding source code.
|
||||
+ This operates on the output from the \\[perldb] command.
|
||||
+ If all preparsed error messages have been processed,
|
||||
+ the error message buffer is checked for new ones.
|
||||
+ A non-nil argument (prefix arg, if interactive)
|
||||
+ means reparse the error message buffer and start at the first error."
|
||||
+ (interactive "P")
|
||||
+ (if (or (eq perldb-error-list t)
|
||||
+ argp)
|
||||
+ (progn (perldb-forget-errors)
|
||||
+ (setq perldb-parsing-end 2))) ;; 2 to defeat grep defeater
|
||||
+ (if perldb-error-list
|
||||
+ nil
|
||||
+ (save-excursion
|
||||
+ (switch-to-buffer current-perldb-buffer)
|
||||
+ (perldb-parse-errors)))
|
||||
+ (let ((next-error (car perldb-error-list)))
|
||||
+ (if (null next-error)
|
||||
+ (error (concat perldb-error-message
|
||||
+ (if (and (get-buffer-process current-perldb-buffer)
|
||||
+ (eq (process-status
|
||||
+ (get-buffer-process
|
||||
+ current-perldb-buffer))
|
||||
+ 'run))
|
||||
+ " yet" ""))))
|
||||
+ (setq perldb-error-list (cdr perldb-error-list))
|
||||
+ (if (null (car (cdr next-error)))
|
||||
+ nil
|
||||
+ (switch-to-buffer (marker-buffer (car (cdr next-error))))
|
||||
+ (goto-char (car (cdr next-error)))
|
||||
+ (set-marker (car (cdr next-error)) nil))
|
||||
+ (let* ((pop-up-windows t)
|
||||
+ (w (display-buffer (marker-buffer (car next-error)))))
|
||||
+ (set-window-point w (car next-error))
|
||||
+ (set-window-start w (car next-error)))
|
||||
+ (set-marker (car next-error) nil)))
|
||||
+
|
||||
+ ;; Set perldb-error-list to nil, and
|
||||
+ ;; unchain the markers that point to the error messages and their text,
|
||||
+ ;; so that they no longer slow down gap motion.
|
||||
+ ;; This would happen anyway at the next garbage collection,
|
||||
+ ;; but it is better to do it right away.
|
||||
+ (defun perldb-forget-errors ()
|
||||
+ (if (eq perldb-error-list t)
|
||||
+ (setq perldb-error-list nil))
|
||||
+ (while perldb-error-list
|
||||
+ (let ((next-error (car perldb-error-list)))
|
||||
+ (set-marker (car next-error) nil)
|
||||
+ (if (car (cdr next-error))
|
||||
+ (set-marker (car (cdr next-error)) nil)))
|
||||
+ (setq perldb-error-list (cdr perldb-error-list))))
|
||||
+
|
||||
+ (defun perldb-parse-errors ()
|
||||
+ "Parse the current buffer as error messages.
|
||||
+ This makes a list of error descriptors, perldb-error-list.
|
||||
+ For each source-file, line-number pair in the buffer,
|
||||
+ the source file is read in, and the text location is saved in perldb-error-list.
|
||||
+ The function next-error, assigned to \\[next-error], takes the next error off the list
|
||||
+ and visits its location."
|
||||
+ (setq perldb-error-list nil)
|
||||
+ (message "Parsing error messages...")
|
||||
+ (let (text-buffer
|
||||
+ last-filename last-linenum)
|
||||
+ ;; Don't reparse messages already seen at last parse.
|
||||
+ (goto-char perldb-parsing-end)
|
||||
+ ;; Don't parse the first two lines as error messages.
|
||||
+ ;; This matters for grep.
|
||||
+ (if (bobp)
|
||||
+ (forward-line 2))
|
||||
+ (while (re-search-forward compilation-error-regexp nil t)
|
||||
+ (let (linenum filename
|
||||
+ error-marker text-marker)
|
||||
+ ;; Extract file name and line number from error message.
|
||||
+ (save-restriction
|
||||
+ (narrow-to-region (match-beginning 0) (match-end 0))
|
||||
+ (goto-char (point-max))
|
||||
+ (skip-chars-backward "[0-9]")
|
||||
+ ;; If it's a lint message, use the last file(linenum) on the line.
|
||||
+ ;; Normally we use the first on the line.
|
||||
+ (if (= (preceding-char) ?\()
|
||||
+ (progn
|
||||
+ (narrow-to-region (point-min) (1+ (buffer-size)))
|
||||
+ (end-of-line)
|
||||
+ (re-search-backward compilation-error-regexp)
|
||||
+ (skip-chars-backward "^ \t\n")
|
||||
+ (narrow-to-region (point) (match-end 0))
|
||||
+ (goto-char (point-max))
|
||||
+ (skip-chars-backward "[0-9]")))
|
||||
+ ;; Are we looking at a "filename-first" or "line-number-first" form?
|
||||
+ (if (looking-at "[0-9]")
|
||||
+ (progn
|
||||
+ (setq linenum (read (current-buffer)))
|
||||
+ (goto-char (point-min)))
|
||||
+ ;; Line number at start, file name at end.
|
||||
+ (progn
|
||||
+ (goto-char (point-min))
|
||||
+ (setq linenum (read (current-buffer)))
|
||||
+ (goto-char (point-max))
|
||||
+ (skip-chars-backward "^ \t\n")))
|
||||
+ (setq filename (perldb-grab-filename)))
|
||||
+ ;; Locate the erring file and line.
|
||||
+ (if (and (equal filename last-filename)
|
||||
+ (= linenum last-linenum))
|
||||
+ nil
|
||||
+ (beginning-of-line 1)
|
||||
+ (setq error-marker (point-marker))
|
||||
+ ;; text-buffer gets the buffer containing this error's file.
|
||||
+ (if (not (equal filename last-filename))
|
||||
+ (setq text-buffer
|
||||
+ (and (file-exists-p (setq last-filename filename))
|
||||
+ (find-file-noselect filename))
|
||||
+ last-linenum 0))
|
||||
+ (if text-buffer
|
||||
+ ;; Go to that buffer and find the erring line.
|
||||
+ (save-excursion
|
||||
+ (set-buffer text-buffer)
|
||||
+ (if (zerop last-linenum)
|
||||
+ (progn
|
||||
+ (goto-char 1)
|
||||
+ (setq last-linenum 1)))
|
||||
+ (forward-line (- linenum last-linenum))
|
||||
+ (setq last-linenum linenum)
|
||||
+ (setq text-marker (point-marker))
|
||||
+ (setq perldb-error-list
|
||||
+ (cons (list error-marker text-marker)
|
||||
+ perldb-error-list)))))
|
||||
+ (forward-line 1)))
|
||||
+ (setq perldb-parsing-end (point-max)))
|
||||
+ (message "Parsing error messages...done")
|
||||
+ (setq perldb-error-list (nreverse perldb-error-list)))
|
||||
+
|
||||
+ (defun perldb-grab-filename ()
|
||||
+ "Return a string which is a filename, starting at point.
|
||||
+ Ignore quotes and parentheses around it, as well as trailing colons."
|
||||
+ (if (eq (following-char) ?\")
|
||||
+ (save-restriction
|
||||
+ (narrow-to-region (point)
|
||||
+ (progn (forward-sexp 1) (point)))
|
||||
+ (goto-char (point-min))
|
||||
+ (read (current-buffer)))
|
||||
+ (buffer-substring (point)
|
||||
+ (progn
|
||||
+ (skip-chars-forward "^ :,\n\t(")
|
||||
+ (point)))))
|
||||
+
|
||||
+ (define-key ctl-x-map "~" 'perldb-next-error)
|
||||
|
||||
|
||||
|
|
@ -1,71 +0,0 @@
|
|||
[This file of Tom Christiansen's has been edited to change makelib to h2ph
|
||||
and .h to .ph where appropriate--law.]
|
||||
|
||||
This directory contains files to help you convert the *.ph files generated my
|
||||
h2ph out of the perl source directory into *.pl files with all the
|
||||
indirection of the subroutine calls removed. The .ph version will be more
|
||||
safely portable, because if something isn't defined on the new system, like
|
||||
&TIOCGETP, then you'll get a fatal run-time error on the system lacking that
|
||||
function. Using the .pl version means that the subsequent scripts will give
|
||||
you a 0 $TIOCGETP and God only knows what may then happen. Still, I like the
|
||||
.pl stuff because they're faster to load.
|
||||
|
||||
FIrst, you need to run h2ph on things like sys/ioctl.h to get stuff
|
||||
into the perl library directory, often /usr/local/lib/perl. For example,
|
||||
# h2ph sys/ioctl.h
|
||||
takes /usr/include/sys/ioctl.h as input and writes (without i/o redirection)
|
||||
the file /usr/local/lib/perl/sys/ioctl.ph, which looks like this
|
||||
|
||||
eval 'sub TIOCM_RTS {0004;}';
|
||||
eval 'sub TIOCM_ST {0010;}';
|
||||
eval 'sub TIOCM_SR {0020;}';
|
||||
eval 'sub TIOCM_CTS {0040;}';
|
||||
eval 'sub TIOCM_CAR {0100;}';
|
||||
|
||||
and much worse, rather than what Larry's ioctl.pl from the perl source dir has,
|
||||
which is:
|
||||
|
||||
$TIOCM_RTS = 0004;
|
||||
$TIOCM_ST = 0010;
|
||||
$TIOCM_SR = 0020;
|
||||
$TIOCM_CTS = 0040;
|
||||
$TIOCM_CAR = 0100;
|
||||
|
||||
[Workaround for fixed bug in makedir/h2ph deleted--law.]
|
||||
|
||||
The more complicated ioctl subs look like this:
|
||||
|
||||
eval 'sub TIOCGSIZE {&TIOCGWINSZ;}';
|
||||
eval 'sub TIOCGWINSZ {&_IOR("t", 104, \'struct winsize\');}';
|
||||
eval 'sub TIOCSETD {&_IOW("t", 1, \'int\');}';
|
||||
eval 'sub TIOCGETP {&_IOR("t", 8,\'struct sgttyb\');}';
|
||||
|
||||
The _IO[RW] routines use a %sizeof array, which (presumably)
|
||||
is keyed on the type name with the value being the size in bytes.
|
||||
|
||||
To build %sizeof, try running this in this directory:
|
||||
|
||||
% ./getioctlsizes
|
||||
|
||||
Which will tell you which things the %sizeof array needs
|
||||
to hold. You can try to build a sizeof.ph file with:
|
||||
|
||||
% ./getioctlsizes | ./mksizes > sizeof.ph
|
||||
|
||||
Note that mksizes hardcodes the #include files for all the types, so it will
|
||||
probably require customization. Once you have sizeof.ph, install it in the
|
||||
perl library directory. Run my tcbreak script to see whether you can do
|
||||
ioctls in perl now. You'll get some kind of fatal run-time error if you
|
||||
can't. That script should be included in this directory.
|
||||
|
||||
If this works well, now you can try to convert the *.ph files into
|
||||
*.pl files. Try this:
|
||||
|
||||
foreach file ( sysexits.ph sys/{errno.ph,ioctl.ph} )
|
||||
./mkvars $file > t/$file:r.pl
|
||||
end
|
||||
|
||||
The last one will be the hardest. If it works, should be able to
|
||||
run tcbreak2 and have it work the same as tcbreak.
|
||||
|
||||
Good luck.
|
||||
|
|
@ -1,34 +0,0 @@
|
|||
$sgttyb_t = 'C4 S';
|
||||
|
||||
sub cbreak {
|
||||
&set_cbreak(1);
|
||||
}
|
||||
|
||||
sub cooked {
|
||||
&set_cbreak(0);
|
||||
}
|
||||
|
||||
sub set_cbreak {
|
||||
local($on) = @_;
|
||||
|
||||
require 'sizeof.ph';
|
||||
require 'sys/ioctl.ph';
|
||||
|
||||
ioctl(STDIN,&TIOCGETP,$sgttyb)
|
||||
|| die "Can't ioctl TIOCGETP: $!";
|
||||
|
||||
@ary = unpack($sgttyb_t,$sgttyb);
|
||||
if ($on) {
|
||||
$ary[4] |= &CBREAK;
|
||||
$ary[4] &= ~&ECHO;
|
||||
} else {
|
||||
$ary[4] &= ~&CBREAK;
|
||||
$ary[4] |= &ECHO;
|
||||
}
|
||||
$sgttyb = pack($sgttyb_t,@ary);
|
||||
ioctl(STDIN,&TIOCSETP,$sgttyb)
|
||||
|| die "Can't ioctl TIOCSETP: $!";
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,33 +0,0 @@
|
|||
$sgttyb_t = 'C4 S';
|
||||
|
||||
sub cbreak {
|
||||
&set_cbreak(1);
|
||||
}
|
||||
|
||||
sub cooked {
|
||||
&set_cbreak(0);
|
||||
}
|
||||
|
||||
sub set_cbreak {
|
||||
local($on) = @_;
|
||||
|
||||
require 'sys/ioctl.pl';
|
||||
|
||||
ioctl(STDIN,$TIOCGETP,$sgttyb)
|
||||
|| die "Can't ioctl TIOCGETP: $!";
|
||||
|
||||
@ary = unpack($sgttyb_t,$sgttyb);
|
||||
if ($on) {
|
||||
$ary[4] |= $CBREAK;
|
||||
$ary[4] &= ~$ECHO;
|
||||
} else {
|
||||
$ary[4] &= ~$CBREAK;
|
||||
$ary[4] |= $ECHO;
|
||||
}
|
||||
$sgttyb = pack($sgttyb_t,@ary);
|
||||
ioctl(STDIN,$TIOCSETP,$sgttyb)
|
||||
|| die "Can't ioctl TIOCSETP: $!";
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
$sizeof{'char'} = 1;
|
||||
$sizeof{'int'} = 4;
|
||||
$sizeof{'long'} = 4;
|
||||
$sizeof{'struct arpreq'} = 36;
|
||||
$sizeof{'struct ifconf'} = 8;
|
||||
$sizeof{'struct ifreq'} = 32;
|
||||
$sizeof{'struct ltchars'} = 6;
|
||||
$sizeof{'struct pcntl'} = 116;
|
||||
$sizeof{'struct rtentry'} = 52;
|
||||
$sizeof{'struct sgttyb'} = 6;
|
||||
$sizeof{'struct tchars'} = 6;
|
||||
$sizeof{'struct ttychars'} = 14;
|
||||
$sizeof{'struct winsize'} = 8;
|
||||
$sizeof{'struct termios'} = 132;
|
||||
|
|
@ -1,92 +0,0 @@
|
|||
$EPERM = 0x1;
|
||||
$ENOENT = 0x2;
|
||||
$ESRCH = 0x3;
|
||||
$EINTR = 0x4;
|
||||
$EIO = 0x5;
|
||||
$ENXIO = 0x6;
|
||||
$E2BIG = 0x7;
|
||||
$ENOEXEC = 0x8;
|
||||
$EBADF = 0x9;
|
||||
$ECHILD = 0xA;
|
||||
$EAGAIN = 0xB;
|
||||
$ENOMEM = 0xC;
|
||||
$EACCES = 0xD;
|
||||
$EFAULT = 0xE;
|
||||
$ENOTBLK = 0xF;
|
||||
$EBUSY = 0x10;
|
||||
$EEXIST = 0x11;
|
||||
$EXDEV = 0x12;
|
||||
$ENODEV = 0x13;
|
||||
$ENOTDIR = 0x14;
|
||||
$EISDIR = 0x15;
|
||||
$EINVAL = 0x16;
|
||||
$ENFILE = 0x17;
|
||||
$EMFILE = 0x18;
|
||||
$ENOTTY = 0x19;
|
||||
$ETXTBSY = 0x1A;
|
||||
$EFBIG = 0x1B;
|
||||
$ENOSPC = 0x1C;
|
||||
$ESPIPE = 0x1D;
|
||||
$EROFS = 0x1E;
|
||||
$EMLINK = 0x1F;
|
||||
$EPIPE = 0x20;
|
||||
$EDOM = 0x21;
|
||||
$ERANGE = 0x22;
|
||||
$EWOULDBLOCK = 0x23;
|
||||
$EINPROGRESS = 0x24;
|
||||
$EALREADY = 0x25;
|
||||
$ENOTSOCK = 0x26;
|
||||
$EDESTADDRREQ = 0x27;
|
||||
$EMSGSIZE = 0x28;
|
||||
$EPROTOTYPE = 0x29;
|
||||
$ENOPROTOOPT = 0x2A;
|
||||
$EPROTONOSUPPORT = 0x2B;
|
||||
$ESOCKTNOSUPPORT = 0x2C;
|
||||
$EOPNOTSUPP = 0x2D;
|
||||
$EPFNOSUPPORT = 0x2E;
|
||||
$EAFNOSUPPORT = 0x2F;
|
||||
$EADDRINUSE = 0x30;
|
||||
$EADDRNOTAVAIL = 0x31;
|
||||
$ENETDOWN = 0x32;
|
||||
$ENETUNREACH = 0x33;
|
||||
$ENETRESET = 0x34;
|
||||
$ECONNABORTED = 0x35;
|
||||
$ECONNRESET = 0x36;
|
||||
$ENOBUFS = 0x37;
|
||||
$EISCONN = 0x38;
|
||||
$ENOTCONN = 0x39;
|
||||
$ESHUTDOWN = 0x3A;
|
||||
$ETOOMANYREFS = 0x3B;
|
||||
$ETIMEDOUT = 0x3C;
|
||||
$ECONNREFUSED = 0x3D;
|
||||
$ELOOP = 0x3E;
|
||||
$ENAMETOOLONG = 0x3F;
|
||||
$EHOSTDOWN = 0x40;
|
||||
$EHOSTUNREACH = 0x41;
|
||||
$ENOTEMPTY = 0x42;
|
||||
$EPROCLIM = 0x43;
|
||||
$EUSERS = 0x44;
|
||||
$EDQUOT = 0x45;
|
||||
$ESTALE = 0x46;
|
||||
$EREMOTE = 0x47;
|
||||
$EDEADLK = 0x48;
|
||||
$ENOLCK = 0x49;
|
||||
$MTH_UNDEF_SQRT = 0x12C;
|
||||
$MTH_OVF_EXP = 0x12D;
|
||||
$MTH_UNDEF_LOG = 0x12E;
|
||||
$MTH_NEG_BASE = 0x12F;
|
||||
$MTH_ZERO_BASE = 0x130;
|
||||
$MTH_OVF_POW = 0x131;
|
||||
$MTH_LRG_SIN = 0x132;
|
||||
$MTH_LRG_COS = 0x133;
|
||||
$MTH_LRG_TAN = 0x134;
|
||||
$MTH_LRG_COT = 0x135;
|
||||
$MTH_OVF_TAN = 0x136;
|
||||
$MTH_OVF_COT = 0x137;
|
||||
$MTH_UNDEF_ASIN = 0x138;
|
||||
$MTH_UNDEF_ACOS = 0x139;
|
||||
$MTH_UNDEF_ATAN2 = 0x13A;
|
||||
$MTH_OVF_SINH = 0x13B;
|
||||
$MTH_OVF_COSH = 0x13C;
|
||||
$MTH_UNDEF_ZLOG = 0x13D;
|
||||
$MTH_UNDEF_ZDIV = 0x13E;
|
||||
|
|
@ -1,186 +0,0 @@
|
|||
$_IOCTL_ = 0x1;
|
||||
$TIOCGSIZE = 0x40087468;
|
||||
$TIOCSSIZE = 0x80087467;
|
||||
$IOCPARM_MASK = 0x7F;
|
||||
$IOC_VOID = 0x20000000;
|
||||
$IOC_OUT = 0x40000000;
|
||||
$IOC_IN = 0x80000000;
|
||||
$IOC_INOUT = 0xC0000000;
|
||||
$TIOCGETD = 0x40047400;
|
||||
$TIOCSETD = 0x80047401;
|
||||
$TIOCHPCL = 0x20007402;
|
||||
$TIOCMODG = 0x40047403;
|
||||
$TIOCMODS = 0x80047404;
|
||||
$TIOCM_LE = 0x1;
|
||||
$TIOCM_DTR = 0x2;
|
||||
$TIOCM_RTS = 0x4;
|
||||
$TIOCM_ST = 0x8;
|
||||
$TIOCM_SR = 0x10;
|
||||
$TIOCM_CTS = 0x20;
|
||||
$TIOCM_CAR = 0x40;
|
||||
$TIOCM_CD = 0x40;
|
||||
$TIOCM_RNG = 0x80;
|
||||
$TIOCM_RI = 0x80;
|
||||
$TIOCM_DSR = 0x100;
|
||||
$TIOCGETP = 0x40067408;
|
||||
$TIOCSETP = 0x80067409;
|
||||
$TIOCSETN = 0x8006740A;
|
||||
$TIOCEXCL = 0x2000740D;
|
||||
$TIOCNXCL = 0x2000740E;
|
||||
$TIOCFLUSH = 0x80047410;
|
||||
$TIOCSETC = 0x80067411;
|
||||
$TIOCGETC = 0x40067412;
|
||||
$TIOCSET = 0x80047413;
|
||||
$TIOCBIS = 0x80047414;
|
||||
$TIOCBIC = 0x80047415;
|
||||
$TIOCGET = 0x40047416;
|
||||
$TANDEM = 0x1;
|
||||
$CBREAK = 0x2;
|
||||
$LCASE = 0x4;
|
||||
$ECHO = 0x8;
|
||||
$CRMOD = 0x10;
|
||||
$RAW = 0x20;
|
||||
$ODDP = 0x40;
|
||||
$EVENP = 0x80;
|
||||
$ANYP = 0xC0;
|
||||
$NLDELAY = 0x300;
|
||||
$NL0 = 0x0;
|
||||
$NL1 = 0x100;
|
||||
$NL2 = 0x200;
|
||||
$NL3 = 0x300;
|
||||
$TBDELAY = 0xC00;
|
||||
$TAB0 = 0x0;
|
||||
$TAB1 = 0x400;
|
||||
$TAB2 = 0x800;
|
||||
$XTABS = 0xC00;
|
||||
$CRDELAY = 0x3000;
|
||||
$CR0 = 0x0;
|
||||
$CR1 = 0x1000;
|
||||
$CR2 = 0x2000;
|
||||
$CR3 = 0x3000;
|
||||
$VTDELAY = 0x4000;
|
||||
$FF0 = 0x0;
|
||||
$FF1 = 0x4000;
|
||||
$BSDELAY = 0x8000;
|
||||
$BS0 = 0x0;
|
||||
$BS1 = 0x8000;
|
||||
$ALLDELAY = 0xFF00;
|
||||
$CRTBS = 0x10000;
|
||||
$PRTERA = 0x20000;
|
||||
$CRTERA = 0x40000;
|
||||
$TILDE = 0x80000;
|
||||
$MDMBUF = 0x100000;
|
||||
$LITOUT = 0x200000;
|
||||
$TOSTOP = 0x400000;
|
||||
$FLUSHO = 0x800000;
|
||||
$NOHANG = 0x1000000;
|
||||
$L001000 = 0x2000000;
|
||||
$CRTKIL = 0x4000000;
|
||||
$L004000 = 0x8000000;
|
||||
$CTLECH = 0x10000000;
|
||||
$PENDIN = 0x20000000;
|
||||
$DECCTQ = 0x40000000;
|
||||
$NOFLSH = 0x80000000;
|
||||
$TIOCCSET = 0x800E7417;
|
||||
$TIOCCGET = 0x400E7418;
|
||||
$TIOCLBIS = 0x8004747F;
|
||||
$TIOCLBIC = 0x8004747E;
|
||||
$TIOCLSET = 0x8004747D;
|
||||
$TIOCLGET = 0x4004747C;
|
||||
$LCRTBS = 0x1;
|
||||
$LPRTERA = 0x2;
|
||||
$LCRTERA = 0x4;
|
||||
$LTILDE = 0x8;
|
||||
$LMDMBUF = 0x10;
|
||||
$LLITOUT = 0x20;
|
||||
$LTOSTOP = 0x40;
|
||||
$LFLUSHO = 0x80;
|
||||
$LNOHANG = 0x100;
|
||||
$LCRTKIL = 0x400;
|
||||
$LCTLECH = 0x1000;
|
||||
$LPENDIN = 0x2000;
|
||||
$LDECCTQ = 0x4000;
|
||||
$LNOFLSH = 0x8000;
|
||||
$TIOCSBRK = 0x2000747B;
|
||||
$TIOCCBRK = 0x2000747A;
|
||||
$TIOCSDTR = 0x20007479;
|
||||
$TIOCCDTR = 0x20007478;
|
||||
$TIOCGPGRP = 0x40047477;
|
||||
$TIOCSPGRP = 0x80047476;
|
||||
$TIOCSLTC = 0x80067475;
|
||||
$TIOCGLTC = 0x40067474;
|
||||
$TIOCOUTQ = 0x40047473;
|
||||
$TIOCSTI = 0x80017472;
|
||||
$TIOCNOTTY = 0x20007471;
|
||||
$TIOCPKT = 0x80047470;
|
||||
$TIOCPKT_DATA = 0x0;
|
||||
$TIOCPKT_FLUSHREAD = 0x1;
|
||||
$TIOCPKT_FLUSHWRITE = 0x2;
|
||||
$TIOCPKT_STOP = 0x4;
|
||||
$TIOCPKT_START = 0x8;
|
||||
$TIOCPKT_NOSTOP = 0x10;
|
||||
$TIOCPKT_DOSTOP = 0x20;
|
||||
$TIOCSTOP = 0x2000746F;
|
||||
$TIOCSTART = 0x2000746E;
|
||||
$TIOCREMOTE = 0x20007469;
|
||||
$TIOCGWINSZ = 0x40087468;
|
||||
$TIOCSWINSZ = 0x80087467;
|
||||
$TIOCRESET = 0x20007466;
|
||||
$OTTYDISC = 0x0;
|
||||
$NETLDISC = 0x1;
|
||||
$NTTYDISC = 0x2;
|
||||
$FIOCLEX = 0x20006601;
|
||||
$FIONCLEX = 0x20006602;
|
||||
$FIONREAD = 0x4004667F;
|
||||
$FIONBIO = 0x8004667E;
|
||||
$FIOASYNC = 0x8004667D;
|
||||
$FIOSETOWN = 0x8004667C;
|
||||
$FIOGETOWN = 0x4004667B;
|
||||
$STPUTTABLE = 0x8004667A;
|
||||
$STGETTABLE = 0x80046679;
|
||||
$SIOCSHIWAT = 0x80047300;
|
||||
$SIOCGHIWAT = 0x40047301;
|
||||
$SIOCSLOWAT = 0x80047302;
|
||||
$SIOCGLOWAT = 0x40047303;
|
||||
$SIOCATMARK = 0x40047307;
|
||||
$SIOCSPGRP = 0x80047308;
|
||||
$SIOCGPGRP = 0x40047309;
|
||||
$SIOCADDRT = 0x8034720A;
|
||||
$SIOCDELRT = 0x8034720B;
|
||||
$SIOCSIFADDR = 0x8020690C;
|
||||
$SIOCGIFADDR = 0xC020690D;
|
||||
$SIOCSIFDSTADDR = 0x8020690E;
|
||||
$SIOCGIFDSTADDR = 0xC020690F;
|
||||
$SIOCSIFFLAGS = 0x80206910;
|
||||
$SIOCGIFFLAGS = 0xC0206911;
|
||||
$SIOCGIFBRDADDR = 0xC0206912;
|
||||
$SIOCSIFBRDADDR = 0x80206913;
|
||||
$SIOCGIFCONF = 0xC0086914;
|
||||
$SIOCGIFNETMASK = 0xC0206915;
|
||||
$SIOCSIFNETMASK = 0x80206916;
|
||||
$SIOCGIFMETRIC = 0xC0206917;
|
||||
$SIOCSIFMETRIC = 0x80206918;
|
||||
$SIOCSARP = 0x8024691E;
|
||||
$SIOCGARP = 0xC024691F;
|
||||
$SIOCDARP = 0x80246920;
|
||||
$PIXCONTINUE = 0x80747000;
|
||||
$PIXSTEP = 0x80747001;
|
||||
$PIXTERMINATE = 0x20007002;
|
||||
$PIGETFLAGS = 0x40747003;
|
||||
$PIXINHERIT = 0x80747004;
|
||||
$PIXDETACH = 0x20007005;
|
||||
$PIXGETSUBCODE = 0xC0747006;
|
||||
$PIXRDREGS = 0xC0747007;
|
||||
$PIXWRREGS = 0xC0747008;
|
||||
$PIXRDVREGS = 0xC0747009;
|
||||
$PIXWRVREGS = 0xC074700A;
|
||||
$PIXRDVSTATE = 0xC074700B;
|
||||
$PIXWRVSTATE = 0xC074700C;
|
||||
$PIXRDCREGS = 0xC074700D;
|
||||
$PIXWRCREGS = 0xC074700E;
|
||||
$PIRDSDRS = 0xC074700F;
|
||||
$PIXGETSIGACTION = 0xC0747010;
|
||||
$PIGETU = 0xC0747011;
|
||||
$PISETRWTID = 0xC0747012;
|
||||
$PIXGETTHCOUNT = 0xC0747013;
|
||||
$PIXRUN = 0x20007014;
|
||||
|
|
@ -1,16 +0,0 @@
|
|||
$EX_OK = 0x0;
|
||||
$EX__BASE = 0x40;
|
||||
$EX_USAGE = 0x40;
|
||||
$EX_DATAERR = 0x41;
|
||||
$EX_NOINPUT = 0x42;
|
||||
$EX_NOUSER = 0x43;
|
||||
$EX_NOHOST = 0x44;
|
||||
$EX_UNAVAILABLE = 0x45;
|
||||
$EX_SOFTWARE = 0x46;
|
||||
$EX_OSERR = 0x47;
|
||||
$EX_OSFILE = 0x48;
|
||||
$EX_CANTCREAT = 0x49;
|
||||
$EX_IOERR = 0x4A;
|
||||
$EX_TEMPFAIL = 0x4B;
|
||||
$EX_PROTOCOL = 0x4C;
|
||||
$EX_NOPERM = 0x4D;
|
||||
|
|
@ -1,13 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
open (IOCTLS,'/usr/include/sys/ioctl.h') || die "ioctl open failed";
|
||||
|
||||
while (<IOCTLS>) {
|
||||
if (/^\s*#\s*define\s+\w+\s+_IO(R|W|WR)\('?\w+'?,\s*\w+,\s*([^)]+)/) {
|
||||
$need{$2}++;
|
||||
}
|
||||
}
|
||||
|
||||
foreach $key ( sort keys %need ) {
|
||||
print $key,"\n";
|
||||
}
|
||||
|
|
@ -1,42 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
($iam = $0) =~ s%.*/%%;
|
||||
$tmp = "$iam.$$";
|
||||
open (CODE,">$tmp.c") || die "$iam: cannot create $tmp.c: $!\n";
|
||||
|
||||
$mask = q/printf ("$sizeof{'%s'} = %d;\n"/;
|
||||
|
||||
# write C program
|
||||
select(CODE);
|
||||
|
||||
print <<EO_C_PROGRAM;
|
||||
#include <sys/param.h>
|
||||
#include <sys/types.h>
|
||||
#include <sys/socket.h>
|
||||
#include <net/if_arp.h>
|
||||
#include <net/if.h>
|
||||
#include <net/route.h>
|
||||
#include <sys/ioctl.h>
|
||||
|
||||
main() {
|
||||
EO_C_PROGRAM
|
||||
|
||||
while ( <> ) {
|
||||
chop;
|
||||
printf "\t%s, \n\t\t\"%s\", sizeof(%s));\n", $mask, $_,$_;
|
||||
}
|
||||
|
||||
print "\n}\n";
|
||||
|
||||
close CODE;
|
||||
|
||||
# compile C program
|
||||
|
||||
select(STDOUT);
|
||||
|
||||
system "cc $tmp.c -o $tmp";
|
||||
die "couldn't compile $tmp.c" if $?;
|
||||
system "./$tmp";
|
||||
die "couldn't run $tmp" if $?;
|
||||
|
||||
unlink "$tmp.c", $tmp;
|
||||
|
|
@ -1,31 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
require 'sizeof.ph';
|
||||
|
||||
$LIB = '/usr/share/perl';
|
||||
|
||||
foreach $include (@ARGV) {
|
||||
printf STDERR "including %s\n", $include;
|
||||
do $include;
|
||||
warn "sourcing $include: $@\n" if ($@);
|
||||
if (!open (INCLUDE,"$LIB/$include")) {
|
||||
warn "can't open $LIB/$include: $!\n";
|
||||
next;
|
||||
}
|
||||
while (<INCLUDE>) {
|
||||
chop;
|
||||
if (/^\s*eval\s+'sub\s+(\w+)\s.*[^{]$/ || /^\s*sub\s+(\w+)\s.*[^{]$/) {
|
||||
$var = $1;
|
||||
$val = eval "&$var;";
|
||||
if ($@) {
|
||||
warn "$@: $_";
|
||||
print <<EOT;
|
||||
warn "\$$var isn't correctly set" if defined \$_main{'$var'};
|
||||
EOT
|
||||
next;
|
||||
}
|
||||
( $nval = sprintf ("%x",$val ) ) =~ tr/a-z/A-Z/;
|
||||
printf "\$%s = 0x%s;\n", $var, $nval;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
@ -1,17 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
require 'cbreak.pl';
|
||||
|
||||
&cbreak;
|
||||
|
||||
$| = 1;
|
||||
|
||||
print "gimme a char: ";
|
||||
|
||||
$c = getc;
|
||||
|
||||
print "$c\n";
|
||||
|
||||
printf "you gave me `%s', which is 0x%02x\n", $c, ord($c);
|
||||
|
||||
&cooked;
|
||||
|
|
@ -1,17 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
require 'cbreak2.pl';
|
||||
|
||||
&cbreak;
|
||||
|
||||
$| = 1;
|
||||
|
||||
print "gimme a char: ";
|
||||
|
||||
$c = getc;
|
||||
|
||||
print "$c\n";
|
||||
|
||||
printf "you gave me `%s', which is 0x%02x\n", $c, ord($c);
|
||||
|
||||
&cooked;
|
||||
|
|
@ -1,17 +0,0 @@
|
|||
PLIBDIR= ${DESTDIR}/usr/share/perl
|
||||
|
||||
PLIB+= abbrev.pl assert.pl bigfloat.pl bigint.pl bigrat.pl cacheout.pl
|
||||
PLIB+= chat2.pl complete.pl ctime.pl dumpvar.pl exceptions.pl fastcwd.pl
|
||||
PLIB+= find.pl finddepth.pl flush.pl getcwd.pl gethostname.pl getopts.pl
|
||||
PLIB+= importenv.pl look.pl newgetopt.pl open2.pl perldb.pl pwd.pl
|
||||
PLIB+= shellwords.pl stat.pl syslog.pl termcap.pl timelocal.pl validate.pl
|
||||
|
||||
NOOBJ=
|
||||
|
||||
install:
|
||||
${INSTALL} -c -o ${BINOWN} -g ${BINGRP} -m 444 ${PLIB} ${PLIBDIR}
|
||||
|
||||
clean:
|
||||
cleandir:
|
||||
|
||||
.include <bsd.prog.mk>
|
||||
|
|
@ -1,33 +0,0 @@
|
|||
;# Usage:
|
||||
;# %foo = ();
|
||||
;# &abbrev(*foo,LIST);
|
||||
;# ...
|
||||
;# $long = $foo{$short};
|
||||
|
||||
package abbrev;
|
||||
|
||||
sub main'abbrev {
|
||||
local(*domain) = @_;
|
||||
shift(@_);
|
||||
@cmp = @_;
|
||||
local($[) = 0;
|
||||
foreach $name (@_) {
|
||||
@extra = split(//,$name);
|
||||
$abbrev = shift(@extra);
|
||||
$len = 1;
|
||||
foreach $cmp (@cmp) {
|
||||
next if $cmp eq $name;
|
||||
while (substr($cmp,0,$len) eq $abbrev) {
|
||||
$abbrev .= shift(@extra);
|
||||
++$len;
|
||||
}
|
||||
}
|
||||
$domain{$abbrev} = $name;
|
||||
while ($#extra >= 0) {
|
||||
$abbrev .= shift(@extra);
|
||||
$domain{$abbrev} = $name;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,52 +0,0 @@
|
|||
# assert.pl
|
||||
# tchrist@convex.com (Tom Christiansen)
|
||||
#
|
||||
# Usage:
|
||||
#
|
||||
# &assert('@x > @y');
|
||||
# &assert('$var > 10', $var, $othervar, @various_info);
|
||||
#
|
||||
# That is, if the first expression evals false, we blow up. The
|
||||
# rest of the args, if any, are nice to know because they will
|
||||
# be printed out by &panic, which is just the stack-backtrace
|
||||
# routine shamelessly borrowed from the perl debugger.
|
||||
|
||||
sub assert {
|
||||
&panic("ASSERTION BOTCHED: $_[0]",$@) unless eval $_[0];
|
||||
}
|
||||
|
||||
sub panic {
|
||||
select(STDERR);
|
||||
|
||||
print "\npanic: @_\n";
|
||||
|
||||
exit 1 if $] <= 4.003; # caller broken
|
||||
|
||||
# stack traceback gratefully borrowed from perl debugger
|
||||
|
||||
local($i,$_);
|
||||
local($p,$f,$l,$s,$h,$a,@a,@sub);
|
||||
for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
|
||||
@a = @DB'args;
|
||||
for (@a) {
|
||||
if (/^StB\000/ && length($_) == length($_main{'_main'})) {
|
||||
$_ = sprintf("%s",$_);
|
||||
}
|
||||
else {
|
||||
s/'/\\'/g;
|
||||
s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
|
||||
s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
|
||||
s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
|
||||
}
|
||||
}
|
||||
$w = $w ? '@ = ' : '$ = ';
|
||||
$a = $h ? '(' . join(', ', @a) . ')' : '';
|
||||
push(@sub, "$w&$s$a from file $f line $l\n");
|
||||
}
|
||||
for ($i=0; $i <= $#sub; $i++) {
|
||||
print $sub[$i];
|
||||
}
|
||||
exit 1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,233 +0,0 @@
|
|||
package bigfloat;
|
||||
require "bigint.pl";
|
||||
# Arbitrary length float math package
|
||||
#
|
||||
# by Mark Biggar
|
||||
#
|
||||
# number format
|
||||
# canonical strings have the form /[+-]\d+E[+-]\d+/
|
||||
# Input values can have inbedded whitespace
|
||||
# Error returns
|
||||
# 'NaN' An input parameter was "Not a Number" or
|
||||
# divide by zero or sqrt of negative number
|
||||
# Division is computed to
|
||||
# max($div_scale,length(dividend).length(divisor))
|
||||
# digits by default.
|
||||
# Also used for default sqrt scale
|
||||
|
||||
$div_scale = 40;
|
||||
|
||||
# Rounding modes one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'.
|
||||
|
||||
$rnd_mode = 'even';
|
||||
|
||||
# bigfloat routines
|
||||
#
|
||||
# fadd(NSTR, NSTR) return NSTR addition
|
||||
# fsub(NSTR, NSTR) return NSTR subtraction
|
||||
# fmul(NSTR, NSTR) return NSTR multiplication
|
||||
# fdiv(NSTR, NSTR[,SCALE]) returns NSTR division to SCALE places
|
||||
# fneg(NSTR) return NSTR negation
|
||||
# fabs(NSTR) return NSTR absolute value
|
||||
# fcmp(NSTR,NSTR) return CODE compare undef,<0,=0,>0
|
||||
# fround(NSTR, SCALE) return NSTR round to SCALE digits
|
||||
# ffround(NSTR, SCALE) return NSTR round at SCALEth place
|
||||
# fnorm(NSTR) return (NSTR) normalize
|
||||
# fsqrt(NSTR[, SCALE]) return NSTR sqrt to SCALE places
|
||||
|
||||
# Convert a number to canonical string form.
|
||||
# Takes something that looks like a number and converts it to
|
||||
# the form /^[+-]\d+E[+-]\d+$/.
|
||||
sub main'fnorm { #(string) return fnum_str
|
||||
local($_) = @_;
|
||||
s/\s+//g; # strip white space
|
||||
if (/^([+-]?)(\d*)(\.(\d*))?([Ee]([+-]?\d+))?$/ && "$2$4" ne '') {
|
||||
&norm(($1 ? "$1$2$4" : "+$2$4"),(($4 ne '') ? $6-length($4) : $6));
|
||||
} else {
|
||||
'NaN';
|
||||
}
|
||||
}
|
||||
|
||||
# normalize number -- for internal use
|
||||
sub norm { #(mantissa, exponent) return fnum_str
|
||||
local($_, $exp) = @_;
|
||||
if ($_ eq 'NaN') {
|
||||
'NaN';
|
||||
} else {
|
||||
s/^([+-])0+/$1/; # strip leading zeros
|
||||
if (length($_) == 1) {
|
||||
'+0E+0';
|
||||
} else {
|
||||
$exp += length($1) if (s/(0+)$//); # strip trailing zeros
|
||||
sprintf("%sE%+ld", $_, $exp);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# negation
|
||||
sub main'fneg { #(fnum_str) return fnum_str
|
||||
local($_) = &'fnorm($_[0]);
|
||||
vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0E+0'; # flip sign
|
||||
s/^H/N/;
|
||||
$_;
|
||||
}
|
||||
|
||||
# absolute value
|
||||
sub main'fabs { #(fnum_str) return fnum_str
|
||||
local($_) = &'fnorm($_[0]);
|
||||
s/^-/+/; # mash sign
|
||||
$_;
|
||||
}
|
||||
|
||||
# multiplication
|
||||
sub main'fmul { #(fnum_str, fnum_str) return fnum_str
|
||||
local($x,$y) = (&'fnorm($_[0]),&'fnorm($_[1]));
|
||||
if ($x eq 'NaN' || $y eq 'NaN') {
|
||||
'NaN';
|
||||
} else {
|
||||
local($xm,$xe) = split('E',$x);
|
||||
local($ym,$ye) = split('E',$y);
|
||||
&norm(&'bmul($xm,$ym),$xe+$ye);
|
||||
}
|
||||
}
|
||||
|
||||
# addition
|
||||
sub main'fadd { #(fnum_str, fnum_str) return fnum_str
|
||||
local($x,$y) = (&'fnorm($_[0]),&'fnorm($_[1]));
|
||||
if ($x eq 'NaN' || $y eq 'NaN') {
|
||||
'NaN';
|
||||
} else {
|
||||
local($xm,$xe) = split('E',$x);
|
||||
local($ym,$ye) = split('E',$y);
|
||||
($xm,$xe,$ym,$ye) = ($ym,$ye,$xm,$xe) if ($xe < $ye);
|
||||
&norm(&'badd($ym,$xm.('0' x ($xe-$ye))),$ye);
|
||||
}
|
||||
}
|
||||
|
||||
# subtraction
|
||||
sub main'fsub { #(fnum_str, fnum_str) return fnum_str
|
||||
&'fadd($_[0],&'fneg($_[1]));
|
||||
}
|
||||
|
||||
# division
|
||||
# args are dividend, divisor, scale (optional)
|
||||
# result has at most max(scale, length(dividend), length(divisor)) digits
|
||||
sub main'fdiv #(fnum_str, fnum_str[,scale]) return fnum_str
|
||||
{
|
||||
local($x,$y,$scale) = (&'fnorm($_[0]),&'fnorm($_[1]),$_[2]);
|
||||
if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') {
|
||||
'NaN';
|
||||
} else {
|
||||
local($xm,$xe) = split('E',$x);
|
||||
local($ym,$ye) = split('E',$y);
|
||||
$scale = $div_scale if (!$scale);
|
||||
$scale = length($xm)-1 if (length($xm)-1 > $scale);
|
||||
$scale = length($ym)-1 if (length($ym)-1 > $scale);
|
||||
$scale = $scale + length($ym) - length($xm);
|
||||
&norm(&round(&'bdiv($xm.('0' x $scale),$ym),$ym),
|
||||
$xe-$ye-$scale);
|
||||
}
|
||||
}
|
||||
|
||||
# round int $q based on fraction $r/$base using $rnd_mode
|
||||
sub round { #(int_str, int_str, int_str) return int_str
|
||||
local($q,$r,$base) = @_;
|
||||
if ($q eq 'NaN' || $r eq 'NaN') {
|
||||
'NaN';
|
||||
} elsif ($rnd_mode eq 'trunc') {
|
||||
$q; # just truncate
|
||||
} else {
|
||||
local($cmp) = &'bcmp(&'bmul($r,'+2'),$base);
|
||||
if ( $cmp < 0 ||
|
||||
($cmp == 0 &&
|
||||
( $rnd_mode eq 'zero' ||
|
||||
($rnd_mode eq '-inf' && (substr($q,0,1) eq '+')) ||
|
||||
($rnd_mode eq '+inf' && (substr($q,0,1) eq '-')) ||
|
||||
($rnd_mode eq 'even' && $q =~ /[24680]$/) ||
|
||||
($rnd_mode eq 'odd' && $q =~ /[13579]$/) )) ) {
|
||||
$q; # round down
|
||||
} else {
|
||||
&'badd($q, ((substr($q,0,1) eq '-') ? '-1' : '+1'));
|
||||
# round up
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# round the mantissa of $x to $scale digits
|
||||
sub main'fround { #(fnum_str, scale) return fnum_str
|
||||
local($x,$scale) = (&'fnorm($_[0]),$_[1]);
|
||||
if ($x eq 'NaN' || $scale <= 0) {
|
||||
$x;
|
||||
} else {
|
||||
local($xm,$xe) = split('E',$x);
|
||||
if (length($xm)-1 <= $scale) {
|
||||
$x;
|
||||
} else {
|
||||
&norm(&round(substr($xm,0,$scale+1),
|
||||
"+0".substr($xm,$scale+1,1),"+10"),
|
||||
$xe+length($xm)-$scale-1);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# round $x at the 10 to the $scale digit place
|
||||
sub main'ffround { #(fnum_str, scale) return fnum_str
|
||||
local($x,$scale) = (&'fnorm($_[0]),$_[1]);
|
||||
if ($x eq 'NaN') {
|
||||
'NaN';
|
||||
} else {
|
||||
local($xm,$xe) = split('E',$x);
|
||||
if ($xe >= $scale) {
|
||||
$x;
|
||||
} else {
|
||||
$xe = length($xm)+$xe-$scale;
|
||||
if ($xe < 1) {
|
||||
'+0E+0';
|
||||
} elsif ($xe == 1) {
|
||||
&norm(&round('+0',"+0".substr($xm,1,1),"+10"), $scale);
|
||||
} else {
|
||||
&norm(&round(substr($xm,0,$trunc),
|
||||
"+0".substr($xm,$trunc,1),"+10"), $scale);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# compare 2 values returns one of undef, <0, =0, >0
|
||||
# returns undef if either or both input value are not numbers
|
||||
sub main'fcmp #(fnum_str, fnum_str) return cond_code
|
||||
{
|
||||
local($x, $y) = (&'fnorm($_[0]),&'fnorm($_[1]));
|
||||
if ($x eq "NaN" || $y eq "NaN") {
|
||||
undef;
|
||||
} else {
|
||||
ord($y) <=> ord($x)
|
||||
||
|
||||
( local($xm,$xe,$ym,$ye) = split('E', $x."E$y"),
|
||||
(($xe <=> $ye) * (substr($x,0,1).'1')
|
||||
|| &bigint'cmp($xm,$ym))
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
# square root by Newtons method.
|
||||
sub main'fsqrt { #(fnum_str[, scale]) return fnum_str
|
||||
local($x, $scale) = (&'fnorm($_[0]), $_[1]);
|
||||
if ($x eq 'NaN' || $x =~ /^-/) {
|
||||
'NaN';
|
||||
} elsif ($x eq '+0E+0') {
|
||||
'+0E+0';
|
||||
} else {
|
||||
local($xm, $xe) = split('E',$x);
|
||||
$scale = $div_scale if (!$scale);
|
||||
$scale = length($xm)-1 if ($scale < length($xm)-1);
|
||||
local($gs, $guess) = (1, sprintf("1E%+d", (length($xm)+$xe-1)/2));
|
||||
while ($gs < 2*$scale) {
|
||||
$guess = &'fmul(&'fadd($guess,&'fdiv($x,$guess,$gs*2)),".5");
|
||||
$gs *= 2;
|
||||
}
|
||||
&'fround($guess, $scale);
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,271 +0,0 @@
|
|||
package bigint;
|
||||
|
||||
# arbitrary size integer math package
|
||||
#
|
||||
# by Mark Biggar
|
||||
#
|
||||
# Canonical Big integer value are strings of the form
|
||||
# /^[+-]\d+$/ with leading zeros suppressed
|
||||
# Input values to these routines may be strings of the form
|
||||
# /^\s*[+-]?[\d\s]+$/.
|
||||
# Examples:
|
||||
# '+0' canonical zero value
|
||||
# ' -123 123 123' canonical value '-123123123'
|
||||
# '1 23 456 7890' canonical value '+1234567890'
|
||||
# Output values always always in canonical form
|
||||
#
|
||||
# Actual math is done in an internal format consisting of an array
|
||||
# whose first element is the sign (/^[+-]$/) and whose remaining
|
||||
# elements are base 100000 digits with the least significant digit first.
|
||||
# The string 'NaN' is used to represent the result when input arguments
|
||||
# are not numbers, as well as the result of dividing by zero
|
||||
#
|
||||
# routines provided are:
|
||||
#
|
||||
# bneg(BINT) return BINT negation
|
||||
# babs(BINT) return BINT absolute value
|
||||
# bcmp(BINT,BINT) return CODE compare numbers (undef,<0,=0,>0)
|
||||
# badd(BINT,BINT) return BINT addition
|
||||
# bsub(BINT,BINT) return BINT subtraction
|
||||
# bmul(BINT,BINT) return BINT multiplication
|
||||
# bdiv(BINT,BINT) return (BINT,BINT) division (quo,rem) just quo if scalar
|
||||
# bmod(BINT,BINT) return BINT modulus
|
||||
# bgcd(BINT,BINT) return BINT greatest common divisor
|
||||
# bnorm(BINT) return BINT normalization
|
||||
#
|
||||
|
||||
# normalize string form of number. Strip leading zeros. Strip any
|
||||
# white space and add a sign, if missing.
|
||||
# Strings that are not numbers result the value 'NaN'.
|
||||
sub main'bnorm { #(num_str) return num_str
|
||||
local($_) = @_;
|
||||
s/\s+//g; # strip white space
|
||||
if (s/^([+-]?)0*(\d+)$/$1$2/) { # test if number
|
||||
substr($_,0,0) = '+' unless $1; # Add missing sign
|
||||
s/^-0/+0/;
|
||||
$_;
|
||||
} else {
|
||||
'NaN';
|
||||
}
|
||||
}
|
||||
|
||||
# Convert a number from string format to internal base 100000 format.
|
||||
# Assumes normalized value as input.
|
||||
sub internal { #(num_str) return int_num_array
|
||||
local($d) = @_;
|
||||
($is,$il) = (substr($d,0,1),length($d)-2);
|
||||
substr($d,0,1) = '';
|
||||
($is, reverse(unpack("a" . ($il%5+1) . ("a5" x ($il/5)), $d)));
|
||||
}
|
||||
|
||||
# Convert a number from internal base 100000 format to string format.
|
||||
# This routine scribbles all over input array.
|
||||
sub external { #(int_num_array) return num_str
|
||||
$es = shift;
|
||||
grep($_ > 9999 || ($_ = substr('0000'.$_,-5)), @_); # zero pad
|
||||
&'bnorm(join('', $es, reverse(@_))); # reverse concat and normalize
|
||||
}
|
||||
|
||||
# Negate input value.
|
||||
sub main'bneg { #(num_str) return num_str
|
||||
local($_) = &'bnorm(@_);
|
||||
vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0';
|
||||
s/^H/N/;
|
||||
$_;
|
||||
}
|
||||
|
||||
# Returns the absolute value of the input.
|
||||
sub main'babs { #(num_str) return num_str
|
||||
&abs(&'bnorm(@_));
|
||||
}
|
||||
|
||||
sub abs { # post-normalized abs for internal use
|
||||
local($_) = @_;
|
||||
s/^-/+/;
|
||||
$_;
|
||||
}
|
||||
|
||||
# Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort)
|
||||
sub main'bcmp { #(num_str, num_str) return cond_code
|
||||
local($x,$y) = (&'bnorm($_[0]),&'bnorm($_[1]));
|
||||
if ($x eq 'NaN') {
|
||||
undef;
|
||||
} elsif ($y eq 'NaN') {
|
||||
undef;
|
||||
} else {
|
||||
&cmp($x,$y);
|
||||
}
|
||||
}
|
||||
|
||||
sub cmp { # post-normalized compare for internal use
|
||||
local($cx, $cy) = @_;
|
||||
$cx cmp $cy
|
||||
&&
|
||||
(
|
||||
ord($cy) <=> ord($cx)
|
||||
||
|
||||
($cx cmp ',') * (length($cy) <=> length($cx) || $cy cmp $cx)
|
||||
);
|
||||
}
|
||||
|
||||
sub main'badd { #(num_str, num_str) return num_str
|
||||
local(*x, *y); ($x, $y) = (&'bnorm($_[0]),&'bnorm($_[1]));
|
||||
if ($x eq 'NaN') {
|
||||
'NaN';
|
||||
} elsif ($y eq 'NaN') {
|
||||
'NaN';
|
||||
} else {
|
||||
@x = &internal($x); # convert to internal form
|
||||
@y = &internal($y);
|
||||
local($sx, $sy) = (shift @x, shift @y); # get signs
|
||||
if ($sx eq $sy) {
|
||||
&external($sx, &add(*x, *y)); # if same sign add
|
||||
} else {
|
||||
($x, $y) = (&abs($x),&abs($y)); # make abs
|
||||
if (&cmp($y,$x) > 0) {
|
||||
&external($sy, &sub(*y, *x));
|
||||
} else {
|
||||
&external($sx, &sub(*x, *y));
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub main'bsub { #(num_str, num_str) return num_str
|
||||
&'badd($_[0],&'bneg($_[1]));
|
||||
}
|
||||
|
||||
# GCD -- Euclids algorithm Knuth Vol 2 pg 296
|
||||
sub main'bgcd { #(num_str, num_str) return num_str
|
||||
local($x,$y) = (&'bnorm($_[0]),&'bnorm($_[1]));
|
||||
if ($x eq 'NaN' || $y eq 'NaN') {
|
||||
'NaN';
|
||||
} else {
|
||||
($x, $y) = ($y,&'bmod($x,$y)) while $y ne '+0';
|
||||
$x;
|
||||
}
|
||||
}
|
||||
|
||||
# routine to add two base 1e5 numbers
|
||||
# stolen from Knuth Vol 2 Algorithm A pg 231
|
||||
# there are separate routines to add and sub as per Kunth pg 233
|
||||
sub add { #(int_num_array, int_num_array) return int_num_array
|
||||
local(*x, *y) = @_;
|
||||
$car = 0;
|
||||
for $x (@x) {
|
||||
last unless @y || $car;
|
||||
$x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5);
|
||||
}
|
||||
for $y (@y) {
|
||||
last unless $car;
|
||||
$y -= 1e5 if $car = (($y += $car) >= 1e5);
|
||||
}
|
||||
(@x, @y, $car);
|
||||
}
|
||||
|
||||
# subtract base 1e5 numbers -- stolen from Knuth Vol 2 pg 232, $x > $y
|
||||
sub sub { #(int_num_array, int_num_array) return int_num_array
|
||||
local(*sx, *sy) = @_;
|
||||
$bar = 0;
|
||||
for $sx (@sx) {
|
||||
last unless @y || $bar;
|
||||
$sx += 1e5 if $bar = (($sx -= shift(@sy) + $bar) < 0);
|
||||
}
|
||||
@sx;
|
||||
}
|
||||
|
||||
# multiply two numbers -- stolen from Knuth Vol 2 pg 233
|
||||
sub main'bmul { #(num_str, num_str) return num_str
|
||||
local(*x, *y); ($x, $y) = (&'bnorm($_[0]), &'bnorm($_[1]));
|
||||
if ($x eq 'NaN') {
|
||||
'NaN';
|
||||
} elsif ($y eq 'NaN') {
|
||||
'NaN';
|
||||
} else {
|
||||
@x = &internal($x);
|
||||
@y = &internal($y);
|
||||
local($signr) = (shift @x ne shift @y) ? '-' : '+';
|
||||
@prod = ();
|
||||
for $x (@x) {
|
||||
($car, $cty) = (0, 0);
|
||||
for $y (@y) {
|
||||
$prod = $x * $y + $prod[$cty] + $car;
|
||||
$prod[$cty++] =
|
||||
$prod - ($car = int($prod * 1e-5)) * 1e5;
|
||||
}
|
||||
$prod[$cty] += $car if $car;
|
||||
$x = shift @prod;
|
||||
}
|
||||
&external($signr, @x, @prod);
|
||||
}
|
||||
}
|
||||
|
||||
# modulus
|
||||
sub main'bmod { #(num_str, num_str) return num_str
|
||||
(&'bdiv(@_))[1];
|
||||
}
|
||||
|
||||
sub main'bdiv { #(dividend: num_str, divisor: num_str) return num_str
|
||||
local (*x, *y); ($x, $y) = (&'bnorm($_[0]), &'bnorm($_[1]));
|
||||
return wantarray ? ('NaN','NaN') : 'NaN'
|
||||
if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0');
|
||||
return wantarray ? ('+0',$x) : '+0' if (&cmp(&abs($x),&abs($y)) < 0);
|
||||
@x = &internal($x); @y = &internal($y);
|
||||
$srem = $y[0];
|
||||
$sr = (shift @x ne shift @y) ? '-' : '+';
|
||||
$car = $bar = $prd = 0;
|
||||
if (($dd = int(1e5/($y[$#y]+1))) != 1) {
|
||||
for $x (@x) {
|
||||
$x = $x * $dd + $car;
|
||||
$x -= ($car = int($x * 1e-5)) * 1e5;
|
||||
}
|
||||
push(@x, $car); $car = 0;
|
||||
for $y (@y) {
|
||||
$y = $y * $dd + $car;
|
||||
$y -= ($car = int($y * 1e-5)) * 1e5;
|
||||
}
|
||||
}
|
||||
else {
|
||||
push(@x, 0);
|
||||
}
|
||||
@q = (); ($v2,$v1) = @y[$#y-1,$#y];
|
||||
while ($#x > $#y) {
|
||||
($u2,$u1,$u0) = @x[($#x-2)..$#x];
|
||||
$q = (($u0 == $v1) ? 99999 : int(($u0*1e5+$u1)/$v1));
|
||||
--$q while ($v2*$q > ($u0*1e5+$u1-$q*$v1)*1e5+$u2);
|
||||
if ($q) {
|
||||
($car, $bar) = (0,0);
|
||||
for ($y = 0, $x = $#x-$#y-1; $y <= $#y; ++$y,++$x) {
|
||||
$prd = $q * $y[$y] + $car;
|
||||
$prd -= ($car = int($prd * 1e-5)) * 1e5;
|
||||
$x[$x] += 1e5 if ($bar = (($x[$x] -= $prd + $bar) < 0));
|
||||
}
|
||||
if ($x[$#x] < $car + $bar) {
|
||||
$car = 0; --$q;
|
||||
for ($y = 0, $x = $#x-$#y-1; $y <= $#y; ++$y,++$x) {
|
||||
$x[$x] -= 1e5
|
||||
if ($car = (($x[$x] += $y[$y] + $car) > 1e5));
|
||||
}
|
||||
}
|
||||
}
|
||||
pop(@x); unshift(@q, $q);
|
||||
}
|
||||
if (wantarray) {
|
||||
@d = ();
|
||||
if ($dd != 1) {
|
||||
$car = 0;
|
||||
for $x (reverse @x) {
|
||||
$prd = $car * 1e5 + $x;
|
||||
$car = $prd - ($tmp = int($prd / $dd)) * $dd;
|
||||
unshift(@d, $tmp);
|
||||
}
|
||||
}
|
||||
else {
|
||||
@d = @x;
|
||||
}
|
||||
(&external($sr, @q), &external($srem, @d, 0));
|
||||
} else {
|
||||
&external($sr, @q);
|
||||
}
|
||||
}
|
||||
1;
|
||||
|
|
@ -1,148 +0,0 @@
|
|||
package bigrat;
|
||||
require "bigint.pl";
|
||||
|
||||
# Arbitrary size rational math package
|
||||
#
|
||||
# by Mark Biggar
|
||||
#
|
||||
# Input values to these routines consist of strings of the form
|
||||
# m|^\s*[+-]?[\d\s]+(/[\d\s]+)?$|.
|
||||
# Examples:
|
||||
# "+0/1" canonical zero value
|
||||
# "3" canonical value "+3/1"
|
||||
# " -123/123 123" canonical value "-1/1001"
|
||||
# "123 456/7890" canonical value "+20576/1315"
|
||||
# Output values always include a sign and no leading zeros or
|
||||
# white space.
|
||||
# This package makes use of the bigint package.
|
||||
# The string 'NaN' is used to represent the result when input arguments
|
||||
# that are not numbers, as well as the result of dividing by zero and
|
||||
# the sqrt of a negative number.
|
||||
# Extreamly naive algorthims are used.
|
||||
#
|
||||
# Routines provided are:
|
||||
#
|
||||
# rneg(RAT) return RAT negation
|
||||
# rabs(RAT) return RAT absolute value
|
||||
# rcmp(RAT,RAT) return CODE compare numbers (undef,<0,=0,>0)
|
||||
# radd(RAT,RAT) return RAT addition
|
||||
# rsub(RAT,RAT) return RAT subtraction
|
||||
# rmul(RAT,RAT) return RAT multiplication
|
||||
# rdiv(RAT,RAT) return RAT division
|
||||
# rmod(RAT) return (RAT,RAT) integer and fractional parts
|
||||
# rnorm(RAT) return RAT normalization
|
||||
# rsqrt(RAT, cycles) return RAT square root
|
||||
|
||||
# Convert a number to the canonical string form m|^[+-]\d+/\d+|.
|
||||
sub main'rnorm { #(string) return rat_num
|
||||
local($_) = @_;
|
||||
s/\s+//g;
|
||||
if (m#^([+-]?\d+)(/(\d*[1-9]0*))?$#) {
|
||||
&norm($1, $3 ? $3 : '+1');
|
||||
} else {
|
||||
'NaN';
|
||||
}
|
||||
}
|
||||
|
||||
# Normalize by reducing to lowest terms
|
||||
sub norm { #(bint, bint) return rat_num
|
||||
local($num,$dom) = @_;
|
||||
if ($num eq 'NaN') {
|
||||
'NaN';
|
||||
} elsif ($dom eq 'NaN') {
|
||||
'NaN';
|
||||
} elsif ($dom =~ /^[+-]?0+$/) {
|
||||
'NaN';
|
||||
} else {
|
||||
local($gcd) = &'bgcd($num,$dom);
|
||||
if ($gcd ne '+1') {
|
||||
$num = &'bdiv($num,$gcd);
|
||||
$dom = &'bdiv($dom,$gcd);
|
||||
} else {
|
||||
$num = &'bnorm($num);
|
||||
$dom = &'bnorm($dom);
|
||||
}
|
||||
substr($dom,0,1) = '';
|
||||
"$num/$dom";
|
||||
}
|
||||
}
|
||||
|
||||
# negation
|
||||
sub main'rneg { #(rat_num) return rat_num
|
||||
local($_) = &'rnorm($_[0]);
|
||||
tr/-+/+-/ if ($_ ne '+0/1');
|
||||
$_;
|
||||
}
|
||||
|
||||
# absolute value
|
||||
sub main'rabs { #(rat_num) return $rat_num
|
||||
local($_) = &'rnorm($_[0]);
|
||||
substr($_,0,1) = '+' unless $_ eq 'NaN';
|
||||
$_;
|
||||
}
|
||||
|
||||
# multipication
|
||||
sub main'rmul { #(rat_num, rat_num) return rat_num
|
||||
local($xn,$xd) = split('/',&'rnorm($_[0]));
|
||||
local($yn,$yd) = split('/',&'rnorm($_[1]));
|
||||
&norm(&'bmul($xn,$yn),&'bmul($xd,$yd));
|
||||
}
|
||||
|
||||
# division
|
||||
sub main'rdiv { #(rat_num, rat_num) return rat_num
|
||||
local($xn,$xd) = split('/',&'rnorm($_[0]));
|
||||
local($yn,$yd) = split('/',&'rnorm($_[1]));
|
||||
&norm(&'bmul($xn,$yd),&'bmul($xd,$yn));
|
||||
}
|
||||
|
||||
# addition
|
||||
sub main'radd { #(rat_num, rat_num) return rat_num
|
||||
local($xn,$xd) = split('/',&'rnorm($_[0]));
|
||||
local($yn,$yd) = split('/',&'rnorm($_[1]));
|
||||
&norm(&'badd(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd));
|
||||
}
|
||||
|
||||
# subtraction
|
||||
sub main'rsub { #(rat_num, rat_num) return rat_num
|
||||
local($xn,$xd) = split('/',&'rnorm($_[0]));
|
||||
local($yn,$yd) = split('/',&'rnorm($_[1]));
|
||||
&norm(&'bsub(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd));
|
||||
}
|
||||
|
||||
# comparison
|
||||
sub main'rcmp { #(rat_num, rat_num) return cond_code
|
||||
local($xn,$xd) = split('/',&'rnorm($_[0]));
|
||||
local($yn,$yd) = split('/',&'rnorm($_[1]));
|
||||
&bigint'cmp(&'bmul($xn,$yd),&'bmul($yn,$xd));
|
||||
}
|
||||
|
||||
# int and frac parts
|
||||
sub main'rmod { #(rat_num) return (rat_num,rat_num)
|
||||
local($xn,$xd) = split('/',&'rnorm($_[0]));
|
||||
local($i,$f) = &'bdiv($xn,$xd);
|
||||
if (wantarray) {
|
||||
("$i/1", "$f/$xd");
|
||||
} else {
|
||||
"$i/1";
|
||||
}
|
||||
}
|
||||
|
||||
# square root by Newtons method.
|
||||
# cycles specifies the number of iterations default: 5
|
||||
sub main'rsqrt { #(fnum_str[, cycles]) return fnum_str
|
||||
local($x, $scale) = (&'rnorm($_[0]), $_[1]);
|
||||
if ($x eq 'NaN') {
|
||||
'NaN';
|
||||
} elsif ($x =~ /^-/) {
|
||||
'NaN';
|
||||
} else {
|
||||
local($gscale, $guess) = (0, '+1/1');
|
||||
$scale = 5 if (!$scale);
|
||||
while ($gscale++ < $scale) {
|
||||
$guess = &'rmul(&'radd($guess,&'rdiv($x,$guess)),"+1/2");
|
||||
}
|
||||
"$guess"; # quotes necessary due to perl bug
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,40 +0,0 @@
|
|||
# Open in their package.
|
||||
|
||||
sub cacheout'open {
|
||||
open($_[0], $_[1]);
|
||||
}
|
||||
|
||||
# But only this sub name is visible to them.
|
||||
|
||||
sub cacheout {
|
||||
package cacheout;
|
||||
|
||||
($file) = @_;
|
||||
if (!$isopen{$file}) {
|
||||
if (++$numopen > $maxopen) {
|
||||
local(@lru) = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen);
|
||||
splice(@lru, $maxopen / 3);
|
||||
$numopen -= @lru;
|
||||
for (@lru) { close $_; delete $isopen{$_}; }
|
||||
}
|
||||
&open($file, ($saw{$file}++ ? '>>' : '>') . $file)
|
||||
|| die "Can't create $file: $!\n";
|
||||
}
|
||||
$isopen{$file} = ++$seq;
|
||||
}
|
||||
|
||||
package cacheout;
|
||||
|
||||
$seq = 0;
|
||||
$numopen = 0;
|
||||
|
||||
if (open(PARAM,'/usr/include/sys/param.h')) {
|
||||
local($.);
|
||||
while (<PARAM>) {
|
||||
$maxopen = $1 - 4 if /^\s*#\s*define\s+NOFILE\s+(\d+)/;
|
||||
}
|
||||
close PARAM;
|
||||
}
|
||||
$maxopen = 16 unless $maxopen;
|
||||
|
||||
1;
|
||||
|
|
@ -1,339 +0,0 @@
|
|||
## chat.pl: chat with a server
|
||||
## V2.01.alpha.7 91/06/16
|
||||
## Randal L. Schwartz
|
||||
|
||||
package chat;
|
||||
|
||||
$sockaddr = 'S n a4 x8';
|
||||
chop($thishost = `hostname`); $thisaddr = (gethostbyname($thishost))[4];
|
||||
$thisproc = pack($sockaddr, 2, 0, $thisaddr);
|
||||
|
||||
# *S = symbol for current I/O, gets assigned *chatsymbol....
|
||||
$next = "chatsymbol000000"; # next one
|
||||
$nextpat = "^chatsymbol"; # patterns that match next++, ++, ++, ++
|
||||
|
||||
|
||||
## $handle = &chat'open_port("server.address",$port_number);
|
||||
## opens a named or numbered TCP server
|
||||
|
||||
sub open_port { ## public
|
||||
local($server, $port) = @_;
|
||||
|
||||
local($serveraddr,$serverproc);
|
||||
|
||||
*S = ++$next;
|
||||
if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) {
|
||||
$serveraddr = pack('C4', $1, $2, $3, $4);
|
||||
} else {
|
||||
local(@x) = gethostbyname($server);
|
||||
return undef unless @x;
|
||||
$serveraddr = $x[4];
|
||||
}
|
||||
$serverproc = pack($sockaddr, 2, $port, $serveraddr);
|
||||
unless (socket(S, 2, 1, 6)) {
|
||||
# XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
|
||||
# but who the heck would change these anyway? (:-)
|
||||
($!) = ($!, close(S)); # close S while saving $!
|
||||
return undef;
|
||||
}
|
||||
unless (bind(S, $thisproc)) {
|
||||
($!) = ($!, close(S)); # close S while saving $!
|
||||
return undef;
|
||||
}
|
||||
unless (connect(S, $serverproc)) {
|
||||
($!) = ($!, close(S)); # close S while saving $!
|
||||
return undef;
|
||||
}
|
||||
select((select(S), $| = 1)[0]);
|
||||
$next; # return symbol for switcharound
|
||||
}
|
||||
|
||||
## ($host, $port, $handle) = &chat'open_listen([$port_number]);
|
||||
## opens a TCP port on the current machine, ready to be listened to
|
||||
## if $port_number is absent or zero, pick a default port number
|
||||
## process must be uid 0 to listen to a low port number
|
||||
|
||||
sub open_listen { ## public
|
||||
|
||||
*S = ++$next;
|
||||
local($thisport) = shift || 0;
|
||||
local($thisproc_local) = pack($sockaddr, 2, $thisport, $thisaddr);
|
||||
local(*NS) = "__" . time;
|
||||
unless (socket(NS, 2, 1, 6)) {
|
||||
# XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
|
||||
# but who the heck would change these anyway? (:-)
|
||||
($!) = ($!, close(NS));
|
||||
return undef;
|
||||
}
|
||||
unless (bind(NS, $thisproc_local)) {
|
||||
($!) = ($!, close(NS));
|
||||
return undef;
|
||||
}
|
||||
unless (listen(NS, 1)) {
|
||||
($!) = ($!, close(NS));
|
||||
return undef;
|
||||
}
|
||||
select((select(NS), $| = 1)[0]);
|
||||
local($family, $port, @myaddr) =
|
||||
unpack("S n C C C C x8", getsockname(NS));
|
||||
$S{"needs_accept"} = *NS; # so expect will open it
|
||||
(@myaddr, $port, $next); # returning this
|
||||
}
|
||||
|
||||
## $handle = &chat'open_proc("command","arg1","arg2",...);
|
||||
## opens a /bin/sh on a pseudo-tty
|
||||
|
||||
sub open_proc { ## public
|
||||
local(@cmd) = @_;
|
||||
|
||||
*S = ++$next;
|
||||
local(*TTY) = "__TTY" . time;
|
||||
local($pty,$tty) = &_getpty(S,TTY);
|
||||
die "Cannot find a new pty" unless defined $pty;
|
||||
local($pid) = fork;
|
||||
die "Cannot fork: $!" unless defined $pid;
|
||||
unless ($pid) {
|
||||
close STDIN; close STDOUT; close STDERR;
|
||||
setpgrp(0,$$);
|
||||
if (open(DEVTTY, "/dev/tty")) {
|
||||
ioctl(DEVTTY,0x20007471,0); # XXX s/b &TIOCNOTTY
|
||||
close DEVTTY;
|
||||
}
|
||||
open(STDIN,"<&TTY");
|
||||
open(STDOUT,">&TTY");
|
||||
open(STDERR,">&STDOUT");
|
||||
die "Oops" unless fileno(STDERR) == 2; # sanity
|
||||
close(S);
|
||||
exec @cmd;
|
||||
die "Cannot exec @cmd: $!";
|
||||
}
|
||||
close(TTY);
|
||||
$PID{$next} = $pid;
|
||||
$next; # return symbol for switcharound
|
||||
}
|
||||
|
||||
# $S is the read-ahead buffer
|
||||
|
||||
## $return = &chat'expect([$handle,] $timeout_time,
|
||||
## $pat1, $body1, $pat2, $body2, ... )
|
||||
## $handle is from previous &chat'open_*().
|
||||
## $timeout_time is the time (either relative to the current time, or
|
||||
## absolute, ala time(2)) at which a timeout event occurs.
|
||||
## $pat1, $pat2, and so on are regexs which are matched against the input
|
||||
## stream. If a match is found, the entire matched string is consumed,
|
||||
## and the corresponding body eval string is evaled.
|
||||
##
|
||||
## Each pat is a regular-expression (probably enclosed in single-quotes
|
||||
## in the invocation). ^ and $ will work, respecting the current value of $*.
|
||||
## If pat is 'TIMEOUT', the body is executed if the timeout is exceeded.
|
||||
## If pat is 'EOF', the body is executed if the process exits before
|
||||
## the other patterns are seen.
|
||||
##
|
||||
## Pats are scanned in the order given, so later pats can contain
|
||||
## general defaults that won't be examined unless the earlier pats
|
||||
## have failed.
|
||||
##
|
||||
## The result of eval'ing body is returned as the result of
|
||||
## the invocation. Recursive invocations are not thought
|
||||
## through, and may work only accidentally. :-)
|
||||
##
|
||||
## undef is returned if either a timeout or an eof occurs and no
|
||||
## corresponding body has been defined.
|
||||
## I/O errors of any sort are treated as eof.
|
||||
|
||||
$nextsubname = "expectloop000000"; # used for subroutines
|
||||
|
||||
sub expect { ## public
|
||||
if ($_[0] =~ /$nextpat/) {
|
||||
*S = shift;
|
||||
}
|
||||
local($endtime) = shift;
|
||||
|
||||
local($timeout,$eof) = (1,1);
|
||||
local($caller) = caller;
|
||||
local($rmask, $nfound, $timeleft, $thisbuf);
|
||||
local($cases, $pattern, $action, $subname);
|
||||
$endtime += time if $endtime < 600_000_000;
|
||||
|
||||
if (defined $S{"needs_accept"}) { # is it a listen socket?
|
||||
local(*NS) = $S{"needs_accept"};
|
||||
delete $S{"needs_accept"};
|
||||
$S{"needs_close"} = *NS;
|
||||
unless(accept(S,NS)) {
|
||||
($!) = ($!, close(S), close(NS));
|
||||
return undef;
|
||||
}
|
||||
select((select(S), $| = 1)[0]);
|
||||
}
|
||||
|
||||
# now see whether we need to create a new sub:
|
||||
|
||||
unless ($subname = $expect_subname{$caller,@_}) {
|
||||
# nope. make a new one:
|
||||
$expect_subname{$caller,@_} = $subname = $nextsubname++;
|
||||
|
||||
$cases .= <<"EDQ"; # header is funny to make everything elsif's
|
||||
sub $subname {
|
||||
LOOP: {
|
||||
if (0) { ; }
|
||||
EDQ
|
||||
while (@_) {
|
||||
($pattern,$action) = splice(@_,0,2);
|
||||
if ($pattern =~ /^eof$/i) {
|
||||
$cases .= <<"EDQ";
|
||||
elsif (\$eof) {
|
||||
package $caller;
|
||||
$action;
|
||||
}
|
||||
EDQ
|
||||
$eof = 0;
|
||||
} elsif ($pattern =~ /^timeout$/i) {
|
||||
$cases .= <<"EDQ";
|
||||
elsif (\$timeout) {
|
||||
package $caller;
|
||||
$action;
|
||||
}
|
||||
EDQ
|
||||
$timeout = 0;
|
||||
} else {
|
||||
$pattern =~ s#/#\\/#g;
|
||||
$cases .= <<"EDQ";
|
||||
elsif (\$S =~ /$pattern/) {
|
||||
\$S = \$';
|
||||
package $caller;
|
||||
$action;
|
||||
}
|
||||
EDQ
|
||||
}
|
||||
}
|
||||
$cases .= <<"EDQ" if $eof;
|
||||
elsif (\$eof) {
|
||||
undef;
|
||||
}
|
||||
EDQ
|
||||
$cases .= <<"EDQ" if $timeout;
|
||||
elsif (\$timeout) {
|
||||
undef;
|
||||
}
|
||||
EDQ
|
||||
$cases .= <<'ESQ';
|
||||
else {
|
||||
$rmask = "";
|
||||
vec($rmask,fileno(S),1) = 1;
|
||||
($nfound, $rmask) =
|
||||
select($rmask, undef, undef, $endtime - time);
|
||||
if ($nfound) {
|
||||
$nread = sysread(S, $thisbuf, 1024);
|
||||
if ($nread > 0) {
|
||||
$S .= $thisbuf;
|
||||
} else {
|
||||
$eof++, redo LOOP; # any error is also eof
|
||||
}
|
||||
} else {
|
||||
$timeout++, redo LOOP; # timeout
|
||||
}
|
||||
redo LOOP;
|
||||
}
|
||||
}
|
||||
}
|
||||
ESQ
|
||||
eval $cases; die "$cases:\n$@" if $@;
|
||||
}
|
||||
$eof = $timeout = 0;
|
||||
do $subname();
|
||||
}
|
||||
|
||||
## &chat'print([$handle,] @data)
|
||||
## $handle is from previous &chat'open().
|
||||
## like print $handle @data
|
||||
|
||||
sub print { ## public
|
||||
if ($_[0] =~ /$nextpat/) {
|
||||
*S = shift;
|
||||
}
|
||||
print S @_;
|
||||
}
|
||||
|
||||
## &chat'close([$handle,])
|
||||
## $handle is from previous &chat'open().
|
||||
## like close $handle
|
||||
|
||||
sub close { ## public
|
||||
local($pid);
|
||||
if ($_[0] =~ /$nextpat/) {
|
||||
$pid = $PID{$_[0]};
|
||||
*S = shift;
|
||||
} else {
|
||||
$pid = $PID{$next};
|
||||
}
|
||||
close(S);
|
||||
waitpid($pid,0);
|
||||
if (defined $S{"needs_close"}) { # is it a listen socket?
|
||||
local(*NS) = $S{"needs_close"};
|
||||
delete $S{"needs_close"};
|
||||
close(NS);
|
||||
}
|
||||
}
|
||||
|
||||
## @ready_handles = &chat'select($timeout, @handles)
|
||||
## select()'s the handles with a timeout value of $timeout seconds.
|
||||
## Returns an array of handles that are ready for I/O.
|
||||
## Both user handles and chat handles are supported (but beware of
|
||||
## stdio's buffering for user handles).
|
||||
|
||||
sub select { ## public
|
||||
local($timeout) = shift;
|
||||
local(@handles) = @_;
|
||||
local(%handlename) = ();
|
||||
local(%ready) = ();
|
||||
local($caller) = caller;
|
||||
local($rmask) = "";
|
||||
for (@handles) {
|
||||
if (/$nextpat/o) { # one of ours... see if ready
|
||||
local(*SYM) = $_;
|
||||
if (length($SYM)) {
|
||||
$timeout = 0; # we have a winner
|
||||
$ready{$_}++;
|
||||
}
|
||||
$handlename{fileno($_)} = $_;
|
||||
} else {
|
||||
$handlename{fileno(/'/ ? $_ : "$caller\'$_")} = $_;
|
||||
}
|
||||
}
|
||||
for (sort keys %handlename) {
|
||||
vec($rmask, $_, 1) = 1;
|
||||
}
|
||||
select($rmask, undef, undef, $timeout);
|
||||
for (sort keys %handlename) {
|
||||
$ready{$handlename{$_}}++ if vec($rmask,$_,1);
|
||||
}
|
||||
sort keys %ready;
|
||||
}
|
||||
|
||||
# ($pty,$tty) = $chat'_getpty(PTY,TTY):
|
||||
# internal procedure to get the next available pty.
|
||||
# opens pty on handle PTY, and matching tty on handle TTY.
|
||||
# returns undef if can't find a pty.
|
||||
|
||||
sub _getpty { ## private
|
||||
local($_PTY,$_TTY) = @_;
|
||||
$_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
|
||||
$_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
|
||||
local($pty,$tty);
|
||||
for $bank (112..127) {
|
||||
next unless -e sprintf("/dev/pty%c0", $bank);
|
||||
for $unit (48..57) {
|
||||
$pty = sprintf("/dev/pty%c%c", $bank, $unit);
|
||||
open($_PTY,"+>$pty") || next;
|
||||
select((select($_PTY), $| = 1)[0]);
|
||||
($tty = $pty) =~ s/pty/tty/;
|
||||
open($_TTY,"+>$tty") || next;
|
||||
select((select($_TTY), $| = 1)[0]);
|
||||
system "stty nl>$tty";
|
||||
return ($pty,$tty);
|
||||
}
|
||||
}
|
||||
undef;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,110 +0,0 @@
|
|||
;#
|
||||
;# @(#)complete.pl,v1.1 (me@anywhere.EBay.Sun.COM) 09/23/91
|
||||
;#
|
||||
;# Author: Wayne Thompson
|
||||
;#
|
||||
;# Description:
|
||||
;# This routine provides word completion.
|
||||
;# (TAB) attempts word completion.
|
||||
;# (^D) prints completion list.
|
||||
;# (These may be changed by setting $Complete'complete, etc.)
|
||||
;#
|
||||
;# Diagnostics:
|
||||
;# Bell when word completion fails.
|
||||
;#
|
||||
;# Dependencies:
|
||||
;# The tty driver is put into raw mode.
|
||||
;#
|
||||
;# Bugs:
|
||||
;#
|
||||
;# Usage:
|
||||
;# $input = &Complete('prompt_string', *completion_list);
|
||||
;# or
|
||||
;# $input = &Complete('prompt_string', @completion_list);
|
||||
;#
|
||||
|
||||
CONFIG: {
|
||||
package Complete;
|
||||
|
||||
$complete = "\004";
|
||||
$kill = "\025";
|
||||
$erase1 = "\177";
|
||||
$erase2 = "\010";
|
||||
}
|
||||
|
||||
sub Complete {
|
||||
package Complete;
|
||||
|
||||
local($[) = 0;
|
||||
if ($_[1] =~ /^StB\0/) {
|
||||
($prompt, *_) = @_;
|
||||
}
|
||||
else {
|
||||
$prompt = shift(@_);
|
||||
}
|
||||
@cmp_lst = sort(@_);
|
||||
|
||||
system('stty raw -echo');
|
||||
LOOP: {
|
||||
print($prompt, $return);
|
||||
while (($_ = getc(STDIN)) ne "\r") {
|
||||
CASE: {
|
||||
# (TAB) attempt completion
|
||||
$_ eq "\t" && do {
|
||||
@match = grep(/^$return/, @cmp_lst);
|
||||
$l = length($test = shift(@match));
|
||||
unless ($#match < 0) {
|
||||
foreach $cmp (@match) {
|
||||
until (substr($cmp, 0, $l) eq substr($test, 0, $l)) {
|
||||
$l--;
|
||||
}
|
||||
}
|
||||
print("\a");
|
||||
}
|
||||
print($test = substr($test, $r, $l - $r));
|
||||
$r = length($return .= $test);
|
||||
last CASE;
|
||||
};
|
||||
|
||||
# (^D) completion list
|
||||
$_ eq $complete && do {
|
||||
print(join("\r\n", '', grep(/^$return/, @cmp_lst)), "\r\n");
|
||||
redo LOOP;
|
||||
};
|
||||
|
||||
# (^U) kill
|
||||
$_ eq $kill && do {
|
||||
if ($r) {
|
||||
undef($r, $return);
|
||||
print("\r\n");
|
||||
redo LOOP;
|
||||
}
|
||||
last CASE;
|
||||
};
|
||||
|
||||
# (DEL) || (BS) erase
|
||||
($_ eq $erase1 || $_ eq $erase2) && do {
|
||||
if($r) {
|
||||
print("\b \b");
|
||||
chop($return);
|
||||
$r--;
|
||||
}
|
||||
last CASE;
|
||||
};
|
||||
|
||||
# printable char
|
||||
ord >= 32 && do {
|
||||
$return .= $_;
|
||||
$r++;
|
||||
print;
|
||||
last CASE;
|
||||
};
|
||||
}
|
||||
}
|
||||
}
|
||||
system('stty -raw echo');
|
||||
print("\n");
|
||||
$return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,51 +0,0 @@
|
|||
;# ctime.pl is a simple Perl emulation for the well known ctime(3C) function.
|
||||
;#
|
||||
;# Waldemar Kebsch, Federal Republic of Germany, November 1988
|
||||
;# kebsch.pad@nixpbe.UUCP
|
||||
;# Modified March 1990, Feb 1991 to properly handle timezones
|
||||
;# $RCSfile: ctime.pl,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:52 $
|
||||
;# Marion Hakanson (hakanson@cse.ogi.edu)
|
||||
;# Oregon Graduate Institute of Science and Technology
|
||||
;#
|
||||
;# usage:
|
||||
;#
|
||||
;# #include <ctime.pl> # see the -P and -I option in perl.man
|
||||
;# $Date = &ctime(time);
|
||||
|
||||
CONFIG: {
|
||||
package ctime;
|
||||
|
||||
@DoW = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
|
||||
@MoY = ('Jan','Feb','Mar','Apr','May','Jun',
|
||||
'Jul','Aug','Sep','Oct','Nov','Dec');
|
||||
}
|
||||
|
||||
sub ctime {
|
||||
package ctime;
|
||||
|
||||
local($time) = @_;
|
||||
local($[) = 0;
|
||||
local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst);
|
||||
|
||||
# Determine what time zone is in effect.
|
||||
# Use GMT if TZ is defined as null, local time if TZ undefined.
|
||||
# There's no portable way to find the system default timezone.
|
||||
|
||||
$TZ = defined($ENV{'TZ'}) ? ( $ENV{'TZ'} ? $ENV{'TZ'} : 'GMT' ) : '';
|
||||
($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) =
|
||||
($TZ eq 'GMT') ? gmtime($time) : localtime($time);
|
||||
|
||||
# Hack to deal with 'PST8PDT' format of TZ
|
||||
# Note that this can't deal with all the esoteric forms, but it
|
||||
# does recognize the most common: [:]STDoff[DST[off][,rule]]
|
||||
|
||||
if($TZ=~/^([^:\d+\-,]{3,})([+-]?\d{1,2}(:\d{1,2}){0,2})([^\d+\-,]{3,})?/){
|
||||
$TZ = $isdst ? $4 : $1;
|
||||
}
|
||||
$TZ .= ' ' unless $TZ eq '';
|
||||
|
||||
$year += ($year < 70) ? 2000 : 1900;
|
||||
sprintf("%s %s %2d %2d:%02d:%02d %s%4d\n",
|
||||
$DoW[$wday], $MoY[$mon], $mday, $hour, $min, $sec, $TZ, $year);
|
||||
}
|
||||
1;
|
||||
|
|
@ -1,37 +0,0 @@
|
|||
package dumpvar;
|
||||
|
||||
# translate control chars to ^X - Randal Schwartz
|
||||
sub unctrl {
|
||||
local($_) = @_;
|
||||
s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
|
||||
$_;
|
||||
}
|
||||
sub main'dumpvar {
|
||||
($package,@vars) = @_;
|
||||
local(*stab) = eval("*_$package");
|
||||
while (($key,$val) = each(%stab)) {
|
||||
{
|
||||
next if @vars && !grep($key eq $_,@vars);
|
||||
local(*entry) = $val;
|
||||
if (defined $entry) {
|
||||
print "\$$key = '",&unctrl($entry),"'\n";
|
||||
}
|
||||
if (defined @entry) {
|
||||
print "\@$key = (\n";
|
||||
foreach $num ($[ .. $#entry) {
|
||||
print " $num\t'",&unctrl($entry[$num]),"'\n";
|
||||
}
|
||||
print ")\n";
|
||||
}
|
||||
if ($key ne "_$package" && $key ne "_DB" && defined %entry) {
|
||||
print "\%$key = (\n";
|
||||
foreach $key (sort keys(%entry)) {
|
||||
print " $key\t'",&unctrl($entry{$key}),"'\n";
|
||||
}
|
||||
print ")\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,54 +0,0 @@
|
|||
# exceptions.pl
|
||||
# tchrist@convex.com
|
||||
#
|
||||
# Here's a little code I use for exception handling. It's really just
|
||||
# glorfied eval/die. The way to use use it is when you might otherwise
|
||||
# exit, use &throw to raise an exception. The first enclosing &catch
|
||||
# handler looks at the exception and decides whether it can catch this kind
|
||||
# (catch takes a list of regexps to catch), and if so, it returns the one it
|
||||
# caught. If it *can't* catch it, then it will reraise the exception
|
||||
# for someone else to possibly see, or to die otherwise.
|
||||
#
|
||||
# I use oddly named variables in order to make darn sure I don't conflict
|
||||
# with my caller. I also hide in my own package, and eval the code in his.
|
||||
#
|
||||
# The EXCEPTION: prefix is so you can tell whether it's a user-raised
|
||||
# exception or a perl-raised one (eval error).
|
||||
#
|
||||
# --tom
|
||||
#
|
||||
# examples:
|
||||
# if (&catch('/$user_input/', 'regexp', 'syntax error') {
|
||||
# warn "oops try again";
|
||||
# redo;
|
||||
# }
|
||||
#
|
||||
# if ($error = &catch('&subroutine()')) { # catches anything
|
||||
#
|
||||
# &throw('bad input') if /^$/;
|
||||
|
||||
sub catch {
|
||||
package exception;
|
||||
local($__code__, @__exceptions__) = @_;
|
||||
local($__package__) = caller;
|
||||
local($__exception__);
|
||||
|
||||
eval "package $__package__; $__code__";
|
||||
if ($__exception__ = &'thrown) {
|
||||
for (@__exceptions__) {
|
||||
return $__exception__ if /$__exception__/;
|
||||
}
|
||||
&'throw($__exception__);
|
||||
}
|
||||
}
|
||||
|
||||
sub throw {
|
||||
local($exception) = @_;
|
||||
die "EXCEPTION: $exception\n";
|
||||
}
|
||||
|
||||
sub thrown {
|
||||
$@ =~ /^(EXCEPTION: )+(.+)/ && $2;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,35 +0,0 @@
|
|||
# By John Bazik
|
||||
#
|
||||
# Usage: $cwd = &fastcwd;
|
||||
#
|
||||
# This is a faster version of getcwd. It's also more dangerous because
|
||||
# you might chdir out of a directory that you can't chdir back into.
|
||||
|
||||
sub fastcwd {
|
||||
local($odev, $oino, $cdev, $cino, $tdev, $tino);
|
||||
local(@path, $path);
|
||||
local(*DIR);
|
||||
|
||||
($cdev, $cino) = stat('.');
|
||||
for (;;) {
|
||||
($odev, $oino) = ($cdev, $cino);
|
||||
chdir('..');
|
||||
($cdev, $cino) = stat('.');
|
||||
last if $odev == $cdev && $oino == $cino;
|
||||
opendir(DIR, '.');
|
||||
for (;;) {
|
||||
$_ = readdir(DIR);
|
||||
next if $_ eq '.';
|
||||
next if $_ eq '..';
|
||||
|
||||
last unless $_;
|
||||
($tdev, $tino) = lstat($_);
|
||||
last unless $tdev != $odev || $tino != $oino;
|
||||
}
|
||||
closedir(DIR);
|
||||
unshift(@path, $_);
|
||||
}
|
||||
chdir($path = '/' . join('/', @path));
|
||||
$path;
|
||||
}
|
||||
1;
|
||||
|
|
@ -1,106 +0,0 @@
|
|||
# Usage:
|
||||
# require "find.pl";
|
||||
#
|
||||
# &find('/foo','/bar');
|
||||
#
|
||||
# sub wanted { ... }
|
||||
# where wanted does whatever you want. $dir contains the
|
||||
# current directory name, and $_ the current filename within
|
||||
# that directory. $name contains "$dir/$_". You are cd'ed
|
||||
# to $dir when the function is called. The function may
|
||||
# set $prune to prune the tree.
|
||||
#
|
||||
# This library is primarily for find2perl, which, when fed
|
||||
#
|
||||
# find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune
|
||||
#
|
||||
# spits out something like this
|
||||
#
|
||||
# sub wanted {
|
||||
# /^\.nfs.*$/ &&
|
||||
# (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
|
||||
# int(-M _) > 7 &&
|
||||
# unlink($_)
|
||||
# ||
|
||||
# ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
|
||||
# $dev < 0 &&
|
||||
# ($prune = 1);
|
||||
# }
|
||||
|
||||
sub find {
|
||||
chop($cwd = `pwd`);
|
||||
foreach $topdir (@_) {
|
||||
(($topdev,$topino,$topmode,$topnlink) = stat($topdir))
|
||||
|| (warn("Can't stat $topdir: $!\n"), next);
|
||||
if (-d _) {
|
||||
if (chdir($topdir)) {
|
||||
($dir,$_) = ($topdir,'.');
|
||||
$name = $topdir;
|
||||
&wanted;
|
||||
$topdir =~ s,/$,, ;
|
||||
&finddir($topdir,$topnlink);
|
||||
}
|
||||
else {
|
||||
warn "Can't cd to $topdir: $!\n";
|
||||
}
|
||||
}
|
||||
else {
|
||||
unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
|
||||
($dir,$_) = ('.', $topdir);
|
||||
}
|
||||
$name = $topdir;
|
||||
chdir $dir && &wanted;
|
||||
}
|
||||
chdir $cwd;
|
||||
}
|
||||
}
|
||||
|
||||
sub finddir {
|
||||
local($dir,$nlink) = @_;
|
||||
local($dev,$ino,$mode,$subcount);
|
||||
local($name);
|
||||
|
||||
# Get the list of files in the current directory.
|
||||
|
||||
opendir(DIR,'.') || (warn "Can't open $dir: $!\n", return);
|
||||
local(@filenames) = readdir(DIR);
|
||||
closedir(DIR);
|
||||
|
||||
if ($nlink == 2) { # This dir has no subdirectories.
|
||||
for (@filenames) {
|
||||
next if $_ eq '.';
|
||||
next if $_ eq '..';
|
||||
$name = "$dir/$_";
|
||||
$nlink = 0;
|
||||
&wanted;
|
||||
}
|
||||
}
|
||||
else { # This dir has subdirectories.
|
||||
$subcount = $nlink - 2;
|
||||
for (@filenames) {
|
||||
next if $_ eq '.';
|
||||
next if $_ eq '..';
|
||||
$nlink = $prune = 0;
|
||||
$name = "$dir/$_";
|
||||
&wanted;
|
||||
if ($subcount > 0) { # Seen all the subdirs?
|
||||
|
||||
# Get link count and check for directoriness.
|
||||
|
||||
($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
|
||||
|
||||
if (-d _) {
|
||||
|
||||
# It really is a directory, so do it recursively.
|
||||
|
||||
if (!$prune && chdir $_) {
|
||||
&finddir($name,$nlink);
|
||||
chdir '..';
|
||||
}
|
||||
--$subcount;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
1;
|
||||
|
|
@ -1,105 +0,0 @@
|
|||
# Usage:
|
||||
# require "finddepth.pl";
|
||||
#
|
||||
# &finddepth('/foo','/bar');
|
||||
#
|
||||
# sub wanted { ... }
|
||||
# where wanted does whatever you want. $dir contains the
|
||||
# current directory name, and $_ the current filename within
|
||||
# that directory. $name contains "$dir/$_". You are cd'ed
|
||||
# to $dir when the function is called. The function may
|
||||
# set $prune to prune the tree.
|
||||
#
|
||||
# This library is primarily for find2perl, which, when fed
|
||||
#
|
||||
# find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune
|
||||
#
|
||||
# spits out something like this
|
||||
#
|
||||
# sub wanted {
|
||||
# /^\.nfs.*$/ &&
|
||||
# (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
|
||||
# int(-M _) > 7 &&
|
||||
# unlink($_)
|
||||
# ||
|
||||
# ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
|
||||
# $dev < 0 &&
|
||||
# ($prune = 1);
|
||||
# }
|
||||
|
||||
sub finddepth {
|
||||
chop($cwd = `pwd`);
|
||||
foreach $topdir (@_) {
|
||||
(($topdev,$topino,$topmode,$topnlink) = stat($topdir))
|
||||
|| (warn("Can't stat $topdir: $!\n"), next);
|
||||
if (-d _) {
|
||||
if (chdir($topdir)) {
|
||||
$topdir =~ s,/$,, ;
|
||||
&finddepthdir($topdir,$topnlink);
|
||||
($dir,$_) = ($topdir,'.');
|
||||
$name = $topdir;
|
||||
&wanted;
|
||||
}
|
||||
else {
|
||||
warn "Can't cd to $topdir: $!\n";
|
||||
}
|
||||
}
|
||||
else {
|
||||
unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
|
||||
($dir,$_) = ('.', $topdir);
|
||||
}
|
||||
chdir $dir && &wanted;
|
||||
}
|
||||
chdir $cwd;
|
||||
}
|
||||
}
|
||||
|
||||
sub finddepthdir {
|
||||
local($dir,$nlink) = @_;
|
||||
local($dev,$ino,$mode,$subcount);
|
||||
local($name);
|
||||
|
||||
# Get the list of files in the current directory.
|
||||
|
||||
opendir(DIR,'.') || warn "Can't open $dir: $!\n";
|
||||
local(@filenames) = readdir(DIR);
|
||||
closedir(DIR);
|
||||
|
||||
if ($nlink == 2) { # This dir has no subdirectories.
|
||||
for (@filenames) {
|
||||
next if $_ eq '.';
|
||||
next if $_ eq '..';
|
||||
$name = "$dir/$_";
|
||||
$nlink = 0;
|
||||
&wanted;
|
||||
}
|
||||
}
|
||||
else { # This dir has subdirectories.
|
||||
$subcount = $nlink - 2;
|
||||
for (@filenames) {
|
||||
next if $_ eq '.';
|
||||
next if $_ eq '..';
|
||||
$nlink = $prune = 0;
|
||||
$name = "$dir/$_";
|
||||
if ($subcount > 0) { # Seen all the subdirs?
|
||||
|
||||
# Get link count and check for directoriness.
|
||||
|
||||
($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
|
||||
|
||||
if (-d _) {
|
||||
|
||||
# It really is a directory, so do it recursively.
|
||||
|
||||
if (!$prune && chdir $_) {
|
||||
&finddepthdir($name,$nlink);
|
||||
chdir '..';
|
||||
}
|
||||
--$subcount;
|
||||
}
|
||||
}
|
||||
&wanted;
|
||||
}
|
||||
}
|
||||
}
|
||||
1;
|
||||
|
|
@ -1,23 +0,0 @@
|
|||
;# Usage: &flush(FILEHANDLE)
|
||||
;# flushes the named filehandle
|
||||
|
||||
;# Usage: &printflush(FILEHANDLE, "prompt: ")
|
||||
;# prints arguments and flushes filehandle
|
||||
|
||||
sub flush {
|
||||
local($old) = select(shift);
|
||||
$| = 1;
|
||||
print "";
|
||||
$| = 0;
|
||||
select($old);
|
||||
}
|
||||
|
||||
sub printflush {
|
||||
local($old) = select(shift);
|
||||
$| = 1;
|
||||
print @_;
|
||||
$| = 0;
|
||||
select($old);
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,62 +0,0 @@
|
|||
# By Brandon S. Allbery
|
||||
#
|
||||
# Usage: $cwd = &getcwd;
|
||||
|
||||
sub getcwd
|
||||
{
|
||||
local($dotdots, $cwd, @pst, @cst, $dir, @tst);
|
||||
|
||||
unless (@cst = stat('.'))
|
||||
{
|
||||
warn "stat(.): $!";
|
||||
return '';
|
||||
}
|
||||
$cwd = '';
|
||||
do
|
||||
{
|
||||
$dotdots .= '/' if $dotdots;
|
||||
$dotdots .= '..';
|
||||
@pst = @cst;
|
||||
unless (opendir(getcwd'PARENT, $dotdots)) #'))
|
||||
{
|
||||
warn "opendir($dotdots): $!";
|
||||
return '';
|
||||
}
|
||||
unless (@cst = stat($dotdots))
|
||||
{
|
||||
warn "stat($dotdots): $!";
|
||||
closedir(getcwd'PARENT); #');
|
||||
return '';
|
||||
}
|
||||
if ($pst[$[] == $cst[$[] && $pst[$[ + 1] == $cst[$[ + 1])
|
||||
{
|
||||
$dir = '';
|
||||
}
|
||||
else
|
||||
{
|
||||
do
|
||||
{
|
||||
unless ($dir = readdir(getcwd'PARENT)) #'))
|
||||
{
|
||||
warn "readdir($dotdots): $!";
|
||||
closedir(getcwd'PARENT); #');
|
||||
return '';
|
||||
}
|
||||
unless (@tst = lstat("$dotdots/$dir"))
|
||||
{
|
||||
warn "lstat($dotdots/$dir): $!";
|
||||
closedir(getcwd'PARENT); #');
|
||||
return '';
|
||||
}
|
||||
}
|
||||
while ($dir eq '.' || $dir eq '..' || $tst[$[] != $pst[$[] ||
|
||||
$tst[$[ + 1] != $pst[$[ + 1]);
|
||||
}
|
||||
$cwd = "$dir/$cwd";
|
||||
closedir(getcwd'PARENT); #');
|
||||
} while ($dir);
|
||||
chop($cwd);
|
||||
$cwd;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,36 +0,0 @@
|
|||
#
|
||||
# Simple package to get the hostname via __sysctl(2).
|
||||
#
|
||||
# Written 13-Feb-96 by Jörg Wunsch, interface business GmbH Dresden.
|
||||
# Placed in the public domain.
|
||||
#
|
||||
# $Id$
|
||||
#
|
||||
|
||||
package gethostname;
|
||||
|
||||
require "sys/syscall.ph";
|
||||
require "sys/sysctl.ph";
|
||||
|
||||
#
|
||||
# usage:
|
||||
#
|
||||
# require "gethostname.pl";
|
||||
# printf "This machine is named \"%s\".\n", &gethostname;
|
||||
#
|
||||
|
||||
sub main'gethostname {
|
||||
# get hostname via sysctl(2)
|
||||
local($name, $oldval, $oldlen, $len);
|
||||
$name = pack("LL", &CTL_KERN, &KERN_HOSTNAME);
|
||||
# 64-byte string to get the hostname
|
||||
$oldval = " " x 64;
|
||||
$oldlen = pack("L", length($oldval));
|
||||
syscall(&SYS___sysctl, $name, 2, $oldval, $oldlen, 0, 0) != -1 ||
|
||||
die "Cannot get hostname via sysctl(2), errno = $!\n";
|
||||
|
||||
($len) = unpack("L", $oldlen);
|
||||
return substr($oldval, 0, $len - 1);
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,41 +0,0 @@
|
|||
;# $RCSfile: getopt.pl,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:52 $
|
||||
|
||||
;# Process single-character switches with switch clustering. Pass one argument
|
||||
;# which is a string containing all switches that take an argument. For each
|
||||
;# switch found, sets $opt_x (where x is the switch name) to the value of the
|
||||
;# argument, or 1 if no argument. Switches which take an argument don't care
|
||||
;# whether there is a space between the switch and the argument.
|
||||
|
||||
;# Usage:
|
||||
;# do Getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect.
|
||||
|
||||
sub Getopt {
|
||||
local($argumentative) = @_;
|
||||
local($_,$first,$rest);
|
||||
local($[) = 0;
|
||||
|
||||
while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
|
||||
($first,$rest) = ($1,$2);
|
||||
if (index($argumentative,$first) >= $[) {
|
||||
if ($rest ne '') {
|
||||
shift(@ARGV);
|
||||
}
|
||||
else {
|
||||
shift(@ARGV);
|
||||
$rest = shift(@ARGV);
|
||||
}
|
||||
eval "\$opt_$first = \$rest;";
|
||||
}
|
||||
else {
|
||||
eval "\$opt_$first = 1;";
|
||||
if ($rest ne '') {
|
||||
$ARGV[0] = "-$rest";
|
||||
}
|
||||
else {
|
||||
shift(@ARGV);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,50 +0,0 @@
|
|||
;# getopts.pl - a better getopt.pl
|
||||
|
||||
;# Usage:
|
||||
;# do Getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a
|
||||
;# # side effect.
|
||||
|
||||
sub Getopts {
|
||||
local($argumentative) = @_;
|
||||
local(@args,$_,$first,$rest);
|
||||
local($errs) = 0;
|
||||
local($[) = 0;
|
||||
|
||||
@args = split( / */, $argumentative );
|
||||
while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
|
||||
($first,$rest) = ($1,$2);
|
||||
$pos = index($argumentative,$first);
|
||||
if($pos >= $[) {
|
||||
if($args[$pos+1] eq ':') {
|
||||
shift(@ARGV);
|
||||
if($rest eq '') {
|
||||
++$errs unless @ARGV;
|
||||
$rest = shift(@ARGV);
|
||||
}
|
||||
eval "\$opt_$first = \$rest;";
|
||||
}
|
||||
else {
|
||||
eval "\$opt_$first = 1";
|
||||
if($rest eq '') {
|
||||
shift(@ARGV);
|
||||
}
|
||||
else {
|
||||
$ARGV[0] = "-$rest";
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
print STDERR "Unknown option: $first\n";
|
||||
++$errs;
|
||||
if($rest ne '') {
|
||||
$ARGV[0] = "-$rest";
|
||||
}
|
||||
else {
|
||||
shift(@ARGV);
|
||||
}
|
||||
}
|
||||
}
|
||||
$errs == 0;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,16 +0,0 @@
|
|||
;# $Header: /home/cvs/386BSD/ports/lang/perl/lib/importenv.pl,v 1.1.1.1 1993/08/23 21:29:53 nate Exp $
|
||||
|
||||
;# This file, when interpreted, pulls the environment into normal variables.
|
||||
;# Usage:
|
||||
;# require 'importenv.pl';
|
||||
;# or
|
||||
;# #include <importenv.pl>
|
||||
|
||||
local($tmp,$key) = '';
|
||||
|
||||
foreach $key (keys(ENV)) {
|
||||
$tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/;
|
||||
}
|
||||
eval $tmp;
|
||||
|
||||
1;
|
||||
|
|
@ -1,44 +0,0 @@
|
|||
;# Usage: &look(*FILEHANDLE,$key,$dict,$fold)
|
||||
|
||||
;# Sets file position in FILEHANDLE to be first line greater than or equal
|
||||
;# (stringwise) to $key. Pass flags for dictionary order and case folding.
|
||||
|
||||
sub look {
|
||||
local(*FH,$key,$dict,$fold) = @_;
|
||||
local($max,$min,$mid,$_);
|
||||
local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
|
||||
$blksize,$blocks) = stat(FH);
|
||||
$blksize = 8192 unless $blksize;
|
||||
$key =~ s/[^\w\s]//g if $dict;
|
||||
$key =~ y/A-Z/a-z/ if $fold;
|
||||
$max = int($size / $blksize);
|
||||
while ($max - $min > 1) {
|
||||
$mid = int(($max + $min) / 2);
|
||||
seek(FH,$mid * $blksize,0);
|
||||
$_ = <FH> if $mid; # probably a partial line
|
||||
$_ = <FH>;
|
||||
chop;
|
||||
s/[^\w\s]//g if $dict;
|
||||
y/A-Z/a-z/ if $fold;
|
||||
if ($_ lt $key) {
|
||||
$min = $mid;
|
||||
}
|
||||
else {
|
||||
$max = $mid;
|
||||
}
|
||||
}
|
||||
$min *= $blksize;
|
||||
seek(FH,$min,0);
|
||||
<FH> if $min;
|
||||
while (<FH>) {
|
||||
chop;
|
||||
s/[^\w\s]//g if $dict;
|
||||
y/A-Z/a-z/ if $fold;
|
||||
last if $_ ge $key;
|
||||
$min = tell(FH);
|
||||
}
|
||||
seek(FH,$min,0);
|
||||
$min;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,271 +0,0 @@
|
|||
# newgetopt.pl -- new options parsing
|
||||
|
||||
# SCCS Status : @(#)@ newgetopt.pl 1.13
|
||||
# Author : Johan Vromans
|
||||
# Created On : Tue Sep 11 15:00:12 1990
|
||||
# Last Modified By: Johan Vromans
|
||||
# Last Modified On: Tue Jun 2 11:24:03 1992
|
||||
# Update Count : 75
|
||||
# Status : Okay
|
||||
|
||||
# This package implements a new getopt function. This function adheres
|
||||
# to the new syntax (long option names, no bundling).
|
||||
#
|
||||
# Arguments to the function are:
|
||||
#
|
||||
# - a list of possible options. These should designate valid perl
|
||||
# identifiers, optionally followed by an argument specifier ("="
|
||||
# for mandatory arguments or ":" for optional arguments) and an
|
||||
# argument type specifier: "n" or "i" for integer numbers, "f" for
|
||||
# real (fix) numbers or "s" for strings.
|
||||
# If an "@" sign is appended, the option is treated as an array.
|
||||
# Value(s) are not set, but pushed.
|
||||
#
|
||||
# - if the first option of the list consists of non-alphanumeric
|
||||
# characters only, it is interpreted as a generic option starter.
|
||||
# Everything starting with one of the characters from the starter
|
||||
# will be considered an option.
|
||||
# Likewise, a double occurrence (e.g. "--") signals end of
|
||||
# the options list.
|
||||
# The default value for the starter is "-", "--" or "+".
|
||||
#
|
||||
# Upon return, the option variables, prefixed with "opt_", are defined
|
||||
# and set to the respective option arguments, if any.
|
||||
# Options that do not take an argument are set to 1. Note that an
|
||||
# option with an optional argument will be defined, but set to '' if
|
||||
# no actual argument has been supplied.
|
||||
# A return status of 0 (false) indicates that the function detected
|
||||
# one or more errors.
|
||||
#
|
||||
# Special care is taken to give a correct treatment to optional arguments.
|
||||
#
|
||||
# E.g. if option "one:i" (i.e. takes an optional integer argument),
|
||||
# then the following situations are handled:
|
||||
#
|
||||
# -one -two -> $opt_one = '', -two is next option
|
||||
# -one -2 -> $opt_one = -2
|
||||
#
|
||||
# Also, assume "foo=s" and "bar:s" :
|
||||
#
|
||||
# -bar -xxx -> $opt_bar = '', '-xxx' is next option
|
||||
# -foo -bar -> $opt_foo = '-bar'
|
||||
# -foo -- -> $opt_foo = '--'
|
||||
#
|
||||
# HISTORY
|
||||
# 2-Jun-1992 Johan Vromans
|
||||
# Do not use //o to allow multiple NGetOpt calls with different delimeters.
|
||||
# Prevent typeless option from using previous $array state.
|
||||
# Prevent empty option from being eaten as a (negative) number.
|
||||
|
||||
# 25-May-1992 Johan Vromans
|
||||
# Add array options. "foo=s@" will return an array @opt_foo that
|
||||
# contains all values that were supplied. E.g. "-foo one -foo -two" will
|
||||
# return @opt_foo = ("one", "-two");
|
||||
# Correct bug in handling options that allow for a argument when followed
|
||||
# by another option.
|
||||
|
||||
# 4-May-1992 Johan Vromans
|
||||
# Add $ignorecase to match options in either case.
|
||||
# Allow '' option.
|
||||
|
||||
# 19-Mar-1992 Johan Vromans
|
||||
# Allow require from packages.
|
||||
# NGetOpt is now defined in the package that requires it.
|
||||
# @ARGV and $opt_... are taken from the package that calls it.
|
||||
# Use standard (?) option prefixes: -, -- and +.
|
||||
|
||||
# 20-Sep-1990 Johan Vromans
|
||||
# Set options w/o argument to 1.
|
||||
# Correct the dreadful semicolon/require bug.
|
||||
|
||||
|
||||
{ package newgetopt;
|
||||
$debug = 0; # for debugging
|
||||
$ignorecase = 1; # ignore case when matching options
|
||||
}
|
||||
|
||||
sub NGetOpt {
|
||||
|
||||
@newgetopt'optionlist = @_;
|
||||
*newgetopt'ARGV = *ARGV;
|
||||
|
||||
package newgetopt;
|
||||
|
||||
local ($[) = 0;
|
||||
local ($genprefix) = "(--|-|\\+)";
|
||||
local ($argend) = "--";
|
||||
local ($error) = 0;
|
||||
local ($opt, $optx, $arg, $type, $mand, %opctl);
|
||||
local ($pkg) = (caller)[0];
|
||||
|
||||
print STDERR "NGetOpt 1.13 -- called from $pkg\n" if $debug;
|
||||
|
||||
# See if the first element of the optionlist contains option
|
||||
# starter characters.
|
||||
if ( $optionlist[0] =~ /^\W+$/ ) {
|
||||
$genprefix = shift (@optionlist);
|
||||
# Turn into regexp.
|
||||
$genprefix =~ s/(\W)/\\\1/g;
|
||||
$genprefix = "[" . $genprefix . "]";
|
||||
undef $argend;
|
||||
}
|
||||
|
||||
# Verify correctness of optionlist.
|
||||
%opctl = ();
|
||||
foreach $opt ( @optionlist ) {
|
||||
$opt =~ tr/A-Z/a-z/ if $ignorecase;
|
||||
if ( $opt !~ /^(\w*)([=:][infse]@?)?$/ ) {
|
||||
print STDERR ("Error in option spec: \"", $opt, "\"\n");
|
||||
$error++;
|
||||
next;
|
||||
}
|
||||
$opctl{$1} = defined $2 ? $2 : "";
|
||||
}
|
||||
|
||||
return 0 if $error;
|
||||
|
||||
if ( $debug ) {
|
||||
local ($arrow, $k, $v);
|
||||
$arrow = "=> ";
|
||||
while ( ($k,$v) = each(%opctl) ) {
|
||||
print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
|
||||
$arrow = " ";
|
||||
}
|
||||
}
|
||||
|
||||
# Process argument list
|
||||
|
||||
while ( $#ARGV >= 0 ) {
|
||||
|
||||
# >>> See also the continue block <<<
|
||||
|
||||
# Get next argument
|
||||
$opt = shift (@ARGV);
|
||||
print STDERR ("=> option \"", $opt, "\"\n") if $debug;
|
||||
$arg = undef;
|
||||
|
||||
# Check for exhausted list.
|
||||
if ( $opt =~ /^$genprefix/ ) {
|
||||
# Double occurrence is terminator
|
||||
return ($error == 0)
|
||||
if ($opt eq "$+$+") || ((defined $argend) && $opt eq $argend);
|
||||
$opt = $'; # option name (w/o prefix)
|
||||
}
|
||||
else {
|
||||
# Apparently not an option - push back and exit.
|
||||
unshift (@ARGV, $opt);
|
||||
return ($error == 0);
|
||||
}
|
||||
|
||||
# Look it up.
|
||||
$opt =~ tr/A-Z/a-z/ if $ignorecase;
|
||||
unless ( defined ( $type = $opctl{$opt} ) ) {
|
||||
print STDERR ("Unknown option: ", $opt, "\n");
|
||||
$error++;
|
||||
next;
|
||||
}
|
||||
|
||||
# Determine argument status.
|
||||
print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
|
||||
|
||||
# If it is an option w/o argument, we're almost finished with it.
|
||||
if ( $type eq "" ) {
|
||||
$arg = 1; # supply explicit value
|
||||
$array = 0;
|
||||
next;
|
||||
}
|
||||
|
||||
# Get mandatory status and type info.
|
||||
($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
|
||||
|
||||
# Check if the argument list is exhausted.
|
||||
if ( $#ARGV < 0 ) {
|
||||
|
||||
# Complain if this option needs an argument.
|
||||
if ( $mand eq "=" ) {
|
||||
print STDERR ("Option ", $opt, " requires an argument\n");
|
||||
$error++;
|
||||
}
|
||||
if ( $mand eq ":" ) {
|
||||
$arg = $type eq "s" ? "" : 0;
|
||||
}
|
||||
next;
|
||||
}
|
||||
|
||||
# Get (possibly optional) argument.
|
||||
$arg = shift (@ARGV);
|
||||
|
||||
# Check if it is a valid argument. A mandatory string takes
|
||||
# anything.
|
||||
if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/ ) {
|
||||
|
||||
# Check for option list terminator.
|
||||
if ( $arg eq "$+$+" ||
|
||||
((defined $argend) && $arg eq $argend)) {
|
||||
# Push back so the outer loop will terminate.
|
||||
unshift (@ARGV, $arg);
|
||||
# Complain if an argument is required.
|
||||
if ($mand eq "=") {
|
||||
print STDERR ("Option ", $opt, " requires an argument\n");
|
||||
$error++;
|
||||
undef $arg; # don't assign it
|
||||
}
|
||||
else {
|
||||
# Supply empty value.
|
||||
$arg = $type eq "s" ? "" : 0;
|
||||
}
|
||||
next;
|
||||
}
|
||||
|
||||
# Maybe the optional argument is the next option?
|
||||
if ( $mand eq ":" && ($' eq "" || $' =~ /[a-zA-Z_]/) ) {
|
||||
# Yep. Push back.
|
||||
unshift (@ARGV, $arg);
|
||||
$arg = $type eq "s" ? "" : 0;
|
||||
next;
|
||||
}
|
||||
}
|
||||
|
||||
if ( $type eq "n" || $type eq "i" ) { # numeric/integer
|
||||
if ( $arg !~ /^-?[0-9]+$/ ) {
|
||||
print STDERR ("Value \"", $arg, "\" invalid for option ",
|
||||
$opt, " (number expected)\n");
|
||||
$error++;
|
||||
undef $arg; # don't assign it
|
||||
}
|
||||
next;
|
||||
}
|
||||
|
||||
if ( $type eq "f" ) { # fixed real number, int is also ok
|
||||
if ( $arg !~ /^-?[0-9.]+$/ ) {
|
||||
print STDERR ("Value \"", $arg, "\" invalid for option ",
|
||||
$opt, " (real number expected)\n");
|
||||
$error++;
|
||||
undef $arg; # don't assign it
|
||||
}
|
||||
next;
|
||||
}
|
||||
|
||||
if ( $type eq "s" ) { # string
|
||||
next;
|
||||
}
|
||||
|
||||
}
|
||||
continue {
|
||||
if ( defined $arg ) {
|
||||
if ( $array ) {
|
||||
print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n")
|
||||
if $debug;
|
||||
eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);");
|
||||
}
|
||||
else {
|
||||
print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n")
|
||||
if $debug;
|
||||
eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return ($error == 0);
|
||||
}
|
||||
1;
|
||||
|
|
@ -1,54 +0,0 @@
|
|||
# &open2: tom christiansen, <tchrist@convex.com>
|
||||
#
|
||||
# usage: $pid = &open2('rdr', 'wtr', 'some cmd and args');
|
||||
# or $pid = &open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args');
|
||||
#
|
||||
# spawn the given $cmd and connect $rdr for
|
||||
# reading and $wtr for writing. return pid
|
||||
# of child, or 0 on failure.
|
||||
#
|
||||
# WARNING: this is dangerous, as you may block forever
|
||||
# unless you are very careful.
|
||||
#
|
||||
# $wtr is left unbuffered.
|
||||
#
|
||||
# abort program if
|
||||
# rdr or wtr are null
|
||||
# pipe or fork or exec fails
|
||||
|
||||
package open2;
|
||||
$fh = 'FHOPEN000'; # package static in case called more than once
|
||||
|
||||
sub main'open2 {
|
||||
local($kidpid);
|
||||
local($dad_rdr, $dad_wtr, @cmd) = @_;
|
||||
|
||||
$dad_rdr ne '' || die "open2: rdr should not be null";
|
||||
$dad_wtr ne '' || die "open2: wtr should not be null";
|
||||
|
||||
# force unqualified filehandles into callers' package
|
||||
local($package) = caller;
|
||||
$dad_rdr =~ s/^[^']+$/$package'$&/;
|
||||
$dad_wtr =~ s/^[^']+$/$package'$&/;
|
||||
|
||||
local($kid_rdr) = ++$fh;
|
||||
local($kid_wtr) = ++$fh;
|
||||
|
||||
pipe($dad_rdr, $kid_wtr) || die "open2: pipe 1 failed: $!";
|
||||
pipe($kid_rdr, $dad_wtr) || die "open2: pipe 2 failed: $!";
|
||||
|
||||
if (($kidpid = fork) < 0) {
|
||||
die "open2: fork failed: $!";
|
||||
} elsif ($kidpid == 0) {
|
||||
close $dad_rdr; close $dad_wtr;
|
||||
open(STDIN, "<&$kid_rdr");
|
||||
open(STDOUT, ">&$kid_wtr");
|
||||
warn "execing @cmd\n" if $debug;
|
||||
exec @cmd;
|
||||
die "open2: exec of @cmd failed";
|
||||
}
|
||||
close $kid_rdr; close $kid_wtr;
|
||||
select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
|
||||
$kidpid;
|
||||
}
|
||||
1; # so require is happy
|
||||
|
|
@ -1,598 +0,0 @@
|
|||
package DB;
|
||||
|
||||
# modified Perl debugger, to be run from Emacs in perldb-mode
|
||||
# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
|
||||
# Johan Vromans -- upgrade to 4.0 pl 10
|
||||
|
||||
$header = '$RCSfile: perldb.pl,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:51 $';
|
||||
#
|
||||
# This file is automatically included if you do perl -d.
|
||||
# It's probably not useful to include this yourself.
|
||||
#
|
||||
# Perl supplies the values for @line and %sub. It effectively inserts
|
||||
# a do DB'DB(<linenum>); in front of every place that can
|
||||
# have a breakpoint. It also inserts a do 'perldb.pl' before the first line.
|
||||
#
|
||||
# $Log: perldb.pl,v $
|
||||
# Revision 1.1.1.1 1993/08/23 21:29:51 nate
|
||||
# PERL!
|
||||
#
|
||||
# Revision 4.0.1.3 92/06/08 13:43:57 lwall
|
||||
# patch20: support for MSDOS folded into perldb.pl
|
||||
# patch20: perldb couldn't debug file containing '-', such as STDIN designator
|
||||
#
|
||||
# Revision 4.0.1.2 91/11/05 17:55:58 lwall
|
||||
# patch11: perldb.pl modified to run within emacs in perldb-mode
|
||||
#
|
||||
# Revision 4.0.1.1 91/06/07 11:17:44 lwall
|
||||
# patch4: added $^P variable to control calling of perldb routines
|
||||
# patch4: debugger sometimes listed wrong number of lines for a statement
|
||||
#
|
||||
# Revision 4.0 91/03/20 01:25:50 lwall
|
||||
# 4.0 baseline.
|
||||
#
|
||||
# Revision 3.0.1.6 91/01/11 18:08:58 lwall
|
||||
# patch42: @_ couldn't be accessed from debugger
|
||||
#
|
||||
# Revision 3.0.1.5 90/11/10 01:40:26 lwall
|
||||
# patch38: the debugger wouldn't stop correctly or do action routines
|
||||
#
|
||||
# Revision 3.0.1.4 90/10/15 17:40:38 lwall
|
||||
# patch29: added caller
|
||||
# patch29: the debugger now understands packages and evals
|
||||
# patch29: scripts now run at almost full speed under the debugger
|
||||
# patch29: more variables are settable from debugger
|
||||
#
|
||||
# Revision 3.0.1.3 90/08/09 04:00:58 lwall
|
||||
# patch19: debugger now allows continuation lines
|
||||
# patch19: debugger can now dump lists of variables
|
||||
# patch19: debugger can now add aliases easily from prompt
|
||||
#
|
||||
# Revision 3.0.1.2 90/03/12 16:39:39 lwall
|
||||
# patch13: perl -d didn't format stack traces of *foo right
|
||||
# patch13: perl -d wiped out scalar return values of subroutines
|
||||
#
|
||||
# Revision 3.0.1.1 89/10/26 23:14:02 lwall
|
||||
# patch1: RCS expanded an unintended $Header in lib/perldb.pl
|
||||
#
|
||||
# Revision 3.0 89/10/18 15:19:46 lwall
|
||||
# 3.0 baseline
|
||||
#
|
||||
# Revision 2.0 88/06/05 00:09:45 root
|
||||
# Baseline version 2.0.
|
||||
#
|
||||
#
|
||||
|
||||
if (-e "/dev/tty") {
|
||||
$console = "/dev/tty";
|
||||
$rcfile=".perldb";
|
||||
}
|
||||
else {
|
||||
$console = "con";
|
||||
$rcfile="perldb.ini";
|
||||
}
|
||||
|
||||
open(IN, "<$console") || open(IN, "<&STDIN"); # so we don't dingle stdin
|
||||
open(OUT,">$console") || open(OUT, ">&STDOUT"); # so we don't dongle stdout
|
||||
select(OUT);
|
||||
$| = 1; # for DB'OUT
|
||||
select(STDOUT);
|
||||
$| = 1; # for real STDOUT
|
||||
$sub = '';
|
||||
|
||||
# Is Perl being run from Emacs?
|
||||
$emacs = $main'ARGV[$[] eq '-emacs';
|
||||
shift(@main'ARGV) if $emacs;
|
||||
|
||||
$header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
|
||||
print OUT "\nLoading DB routines from $header\n";
|
||||
print OUT ("Emacs support ",
|
||||
$emacs ? "enabled" : "available",
|
||||
".\n");
|
||||
print OUT "\nEnter h for help.\n\n";
|
||||
|
||||
sub DB {
|
||||
&save;
|
||||
($package, $filename, $line) = caller;
|
||||
$usercontext = '($@, $!, $[, $,, $/, $\) = @saved;' .
|
||||
"package $package;"; # this won't let them modify, alas
|
||||
local($^P) = 0; # don't debug our own evals
|
||||
local(*dbline) = "_<$filename";
|
||||
$max = $#dbline;
|
||||
if (($stop,$action) = split(/\0/,$dbline{$line})) {
|
||||
if ($stop eq '1') {
|
||||
$signal |= 1;
|
||||
}
|
||||
else {
|
||||
$evalarg = "\$DB'signal |= do {$stop;}"; &eval;
|
||||
$dbline{$line} =~ s/;9($|\0)/$1/;
|
||||
}
|
||||
}
|
||||
if ($single || $trace || $signal) {
|
||||
if ($emacs) {
|
||||
print OUT "\032\032$filename:$line:0\n";
|
||||
} else {
|
||||
print OUT "$package'" unless $sub =~ /'/;
|
||||
print OUT "$sub($filename:$line):\t",$dbline[$line];
|
||||
for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) {
|
||||
last if $dbline[$i] =~ /^\s*(}|#|\n)/;
|
||||
print OUT "$sub($filename:$i):\t",$dbline[$i];
|
||||
}
|
||||
}
|
||||
}
|
||||
$evalarg = $action, &eval if $action;
|
||||
if ($single || $signal) {
|
||||
$evalarg = $pre, &eval if $pre;
|
||||
print OUT $#stack . " levels deep in subroutine calls!\n"
|
||||
if $single & 4;
|
||||
$start = $line;
|
||||
CMD:
|
||||
while ((print OUT " DB<", $#hist+1, "> "), $cmd=&gets) {
|
||||
{
|
||||
$single = 0;
|
||||
$signal = 0;
|
||||
$cmd eq '' && exit 0;
|
||||
chop($cmd);
|
||||
$cmd =~ s/\\$// && do {
|
||||
print OUT " cont: ";
|
||||
$cmd .= &gets;
|
||||
redo CMD;
|
||||
};
|
||||
$cmd =~ /^q$/ && exit 0;
|
||||
$cmd =~ /^$/ && ($cmd = $laststep);
|
||||
push(@hist,$cmd) if length($cmd) > 1;
|
||||
($i) = split(/\s+/,$cmd);
|
||||
eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i};
|
||||
$cmd =~ /^h$/ && do {
|
||||
print OUT "
|
||||
T Stack trace.
|
||||
s Single step.
|
||||
n Next, steps over subroutine calls.
|
||||
r Return from current subroutine.
|
||||
c [line] Continue; optionally inserts a one-time-only breakpoint
|
||||
at the specified line.
|
||||
<CR> Repeat last n or s.
|
||||
l min+incr List incr+1 lines starting at min.
|
||||
l min-max List lines.
|
||||
l line List line;
|
||||
l List next window.
|
||||
- List previous window.
|
||||
w line List window around line.
|
||||
l subname List subroutine.
|
||||
f filename Switch to filename.
|
||||
/pattern/ Search forwards for pattern; final / is optional.
|
||||
?pattern? Search backwards for pattern.
|
||||
L List breakpoints and actions.
|
||||
S List subroutine names.
|
||||
t Toggle trace mode.
|
||||
b [line] [condition]
|
||||
Set breakpoint; line defaults to the current execution line;
|
||||
condition breaks if it evaluates to true, defaults to \'1\'.
|
||||
b subname [condition]
|
||||
Set breakpoint at first line of subroutine.
|
||||
d [line] Delete breakpoint.
|
||||
D Delete all breakpoints.
|
||||
a [line] command
|
||||
Set an action to be done before the line is executed.
|
||||
Sequence is: check for breakpoint, print line if necessary,
|
||||
do action, prompt user if breakpoint or step, evaluate line.
|
||||
A Delete all actions.
|
||||
V [pkg [vars]] List some (default all) variables in package (default current).
|
||||
X [vars] Same as \"V currentpackage [vars]\".
|
||||
< command Define command before prompt.
|
||||
> command Define command after prompt.
|
||||
! number Redo command (default previous command).
|
||||
! -number Redo number\'th to last command.
|
||||
H -number Display last number commands (default all).
|
||||
q or ^D Quit.
|
||||
p expr Same as \"print DB'OUT expr\" in current package.
|
||||
= [alias value] Define a command alias, or list current aliases.
|
||||
command Execute as a perl statement in current package.
|
||||
|
||||
";
|
||||
next CMD; };
|
||||
$cmd =~ /^t$/ && do {
|
||||
$trace = !$trace;
|
||||
print OUT "Trace = ".($trace?"on":"off")."\n";
|
||||
next CMD; };
|
||||
$cmd =~ /^S$/ && do {
|
||||
foreach $subname (sort(keys %sub)) {
|
||||
print OUT $subname,"\n";
|
||||
}
|
||||
next CMD; };
|
||||
$cmd =~ s/^X\b/V $package/;
|
||||
$cmd =~ /^V$/ && do {
|
||||
$cmd = 'V $package'; };
|
||||
$cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
|
||||
$packname = $1;
|
||||
@vars = split(' ',$2);
|
||||
do 'dumpvar.pl' unless defined &main'dumpvar;
|
||||
if (defined &main'dumpvar) {
|
||||
&main'dumpvar($packname,@vars);
|
||||
}
|
||||
else {
|
||||
print DB'OUT "dumpvar.pl not available.\n";
|
||||
}
|
||||
next CMD; };
|
||||
$cmd =~ /^f\b\s*(.*)/ && do {
|
||||
$file = $1;
|
||||
if (!$file) {
|
||||
print OUT "The old f command is now the r command.\n";
|
||||
print OUT "The new f command switches filenames.\n";
|
||||
next CMD;
|
||||
}
|
||||
if (!defined $_main{'_<' . $file}) {
|
||||
if (($try) = grep(m#^_<.*$file#, keys %_main)) {
|
||||
$file = substr($try,2);
|
||||
print "\n$file:\n";
|
||||
}
|
||||
}
|
||||
if (!defined $_main{'_<' . $file}) {
|
||||
print OUT "There's no code here anything matching $file.\n";
|
||||
next CMD;
|
||||
}
|
||||
elsif ($file ne $filename) {
|
||||
*dbline = "_<$file";
|
||||
$max = $#dbline;
|
||||
$filename = $file;
|
||||
$start = 1;
|
||||
$cmd = "l";
|
||||
} };
|
||||
$cmd =~ /^l\b\s*(['A-Za-z_]['\w]*)/ && do {
|
||||
$subname = $1;
|
||||
$subname = "main'" . $subname unless $subname =~ /'/;
|
||||
$subname = "main" . $subname if substr($subname,0,1) eq "'";
|
||||
($file,$subrange) = split(/:/,$sub{$subname});
|
||||
if ($file ne $filename) {
|
||||
*dbline = "_<$file";
|
||||
$max = $#dbline;
|
||||
$filename = $file;
|
||||
}
|
||||
if ($subrange) {
|
||||
if (eval($subrange) < -$window) {
|
||||
$subrange =~ s/-.*/+/;
|
||||
}
|
||||
$cmd = "l $subrange";
|
||||
} else {
|
||||
print OUT "Subroutine $1 not found.\n";
|
||||
next CMD;
|
||||
} };
|
||||
$cmd =~ /^w\b\s*(\d*)$/ && do {
|
||||
$incr = $window - 1;
|
||||
$start = $1 if $1;
|
||||
$start -= $preview;
|
||||
$cmd = 'l ' . $start . '-' . ($start + $incr); };
|
||||
$cmd =~ /^-$/ && do {
|
||||
$incr = $window - 1;
|
||||
$cmd = 'l ' . ($start-$window*2) . '+'; };
|
||||
$cmd =~ /^l$/ && do {
|
||||
$incr = $window - 1;
|
||||
$cmd = 'l ' . $start . '-' . ($start + $incr); };
|
||||
$cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
|
||||
$start = $1 if $1;
|
||||
$incr = $2;
|
||||
$incr = $window - 1 unless $incr;
|
||||
$cmd = 'l ' . $start . '-' . ($start + $incr); };
|
||||
$cmd =~ /^l\b\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
|
||||
$end = (!$2) ? $max : ($4 ? $4 : $2);
|
||||
$end = $max if $end > $max;
|
||||
$i = $2;
|
||||
$i = $line if $i eq '.';
|
||||
$i = 1 if $i < 1;
|
||||
if ($emacs) {
|
||||
print OUT "\032\032$filename:$i:0\n";
|
||||
$i = $end;
|
||||
} else {
|
||||
for (; $i <= $end; $i++) {
|
||||
print OUT "$i:\t", $dbline[$i];
|
||||
last if $signal;
|
||||
}
|
||||
}
|
||||
$start = $i; # remember in case they want more
|
||||
$start = $max if $start > $max;
|
||||
next CMD; };
|
||||
$cmd =~ /^D$/ && do {
|
||||
print OUT "Deleting all breakpoints...\n";
|
||||
for ($i = 1; $i <= $max ; $i++) {
|
||||
if (defined $dbline{$i}) {
|
||||
$dbline{$i} =~ s/^[^\0]+//;
|
||||
if ($dbline{$i} =~ s/^\0?$//) {
|
||||
delete $dbline{$i};
|
||||
}
|
||||
}
|
||||
}
|
||||
next CMD; };
|
||||
$cmd =~ /^L$/ && do {
|
||||
for ($i = 1; $i <= $max; $i++) {
|
||||
if (defined $dbline{$i}) {
|
||||
print OUT "$i:\t", $dbline[$i];
|
||||
($stop,$action) = split(/\0/, $dbline{$i});
|
||||
print OUT " break if (", $stop, ")\n"
|
||||
if $stop;
|
||||
print OUT " action: ", $action, "\n"
|
||||
if $action;
|
||||
last if $signal;
|
||||
}
|
||||
}
|
||||
next CMD; };
|
||||
$cmd =~ /^b\b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do {
|
||||
$subname = $1;
|
||||
$cond = $2 || '1';
|
||||
$subname = "$package'" . $subname unless $subname =~ /'/;
|
||||
$subname = "main" . $subname if substr($subname,0,1) eq "'";
|
||||
($filename,$i) = split(/:/, $sub{$subname});
|
||||
$i += 0;
|
||||
if ($i) {
|
||||
*dbline = "_<$filename";
|
||||
++$i while $dbline[$i] == 0 && $i < $#dbline;
|
||||
$dbline{$i} =~ s/^[^\0]*/$cond/;
|
||||
} else {
|
||||
print OUT "Subroutine $subname not found.\n";
|
||||
}
|
||||
next CMD; };
|
||||
$cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
|
||||
$i = ($1?$1:$line);
|
||||
$cond = $2 || '1';
|
||||
if ($dbline[$i] == 0) {
|
||||
print OUT "Line $i not breakable.\n";
|
||||
} else {
|
||||
$dbline{$i} =~ s/^[^\0]*/$cond/;
|
||||
}
|
||||
next CMD; };
|
||||
$cmd =~ /^d\b\s*(\d+)?/ && do {
|
||||
$i = ($1?$1:$line);
|
||||
$dbline{$i} =~ s/^[^\0]*//;
|
||||
delete $dbline{$i} if $dbline{$i} eq '';
|
||||
next CMD; };
|
||||
$cmd =~ /^A$/ && do {
|
||||
for ($i = 1; $i <= $max ; $i++) {
|
||||
if (defined $dbline{$i}) {
|
||||
$dbline{$i} =~ s/\0[^\0]*//;
|
||||
delete $dbline{$i} if $dbline{$i} eq '';
|
||||
}
|
||||
}
|
||||
next CMD; };
|
||||
$cmd =~ /^<\s*(.*)/ && do {
|
||||
$pre = do action($1);
|
||||
next CMD; };
|
||||
$cmd =~ /^>\s*(.*)/ && do {
|
||||
$post = do action($1);
|
||||
next CMD; };
|
||||
$cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
|
||||
$i = $1;
|
||||
if ($dbline[$i] == 0) {
|
||||
print OUT "Line $i may not have an action.\n";
|
||||
} else {
|
||||
$dbline{$i} =~ s/\0[^\0]*//;
|
||||
$dbline{$i} .= "\0" . do action($3);
|
||||
}
|
||||
next CMD; };
|
||||
$cmd =~ /^n$/ && do {
|
||||
$single = 2;
|
||||
$laststep = $cmd;
|
||||
last CMD; };
|
||||
$cmd =~ /^s$/ && do {
|
||||
$single = 1;
|
||||
$laststep = $cmd;
|
||||
last CMD; };
|
||||
$cmd =~ /^c\b\s*(\d*)\s*$/ && do {
|
||||
$i = $1;
|
||||
if ($i) {
|
||||
if ($dbline[$i] == 0) {
|
||||
print OUT "Line $i not breakable.\n";
|
||||
next CMD;
|
||||
}
|
||||
$dbline{$i} =~ s/(\0|$)/;9$1/; # add one-time-only b.p.
|
||||
}
|
||||
for ($i=0; $i <= $#stack; ) {
|
||||
$stack[$i++] &= ~1;
|
||||
}
|
||||
last CMD; };
|
||||
$cmd =~ /^r$/ && do {
|
||||
$stack[$#stack] |= 2;
|
||||
last CMD; };
|
||||
$cmd =~ /^T$/ && do {
|
||||
local($p,$f,$l,$s,$h,$a,@a,@sub);
|
||||
for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
|
||||
@a = @args;
|
||||
for (@a) {
|
||||
if (/^StB\000/ && length($_) == length($_main{'_main'})) {
|
||||
$_ = sprintf("%s",$_);
|
||||
}
|
||||
else {
|
||||
s/'/\\'/g;
|
||||
s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
|
||||
s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
|
||||
s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
|
||||
}
|
||||
}
|
||||
$w = $w ? '@ = ' : '$ = ';
|
||||
$a = $h ? '(' . join(', ', @a) . ')' : '';
|
||||
push(@sub, "$w&$s$a from file $f line $l\n");
|
||||
last if $signal;
|
||||
}
|
||||
for ($i=0; $i <= $#sub; $i++) {
|
||||
last if $signal;
|
||||
print OUT $sub[$i];
|
||||
}
|
||||
next CMD; };
|
||||
$cmd =~ /^\/(.*)$/ && do {
|
||||
$inpat = $1;
|
||||
$inpat =~ s:([^\\])/$:$1:;
|
||||
if ($inpat ne "") {
|
||||
eval '$inpat =~ m'."\n$inpat\n";
|
||||
if ($@ ne "") {
|
||||
print OUT "$@";
|
||||
next CMD;
|
||||
}
|
||||
$pat = $inpat;
|
||||
}
|
||||
$end = $start;
|
||||
eval '
|
||||
for (;;) {
|
||||
++$start;
|
||||
$start = 1 if ($start > $max);
|
||||
last if ($start == $end);
|
||||
if ($dbline[$start] =~ m'."\n$pat\n".'i) {
|
||||
if ($emacs) {
|
||||
print OUT "\032\032$filename:$start:0\n";
|
||||
} else {
|
||||
print OUT "$start:\t", $dbline[$start], "\n";
|
||||
}
|
||||
last;
|
||||
}
|
||||
} ';
|
||||
print OUT "/$pat/: not found\n" if ($start == $end);
|
||||
next CMD; };
|
||||
$cmd =~ /^\?(.*)$/ && do {
|
||||
$inpat = $1;
|
||||
$inpat =~ s:([^\\])\?$:$1:;
|
||||
if ($inpat ne "") {
|
||||
eval '$inpat =~ m'."\n$inpat\n";
|
||||
if ($@ ne "") {
|
||||
print OUT "$@";
|
||||
next CMD;
|
||||
}
|
||||
$pat = $inpat;
|
||||
}
|
||||
$end = $start;
|
||||
eval '
|
||||
for (;;) {
|
||||
--$start;
|
||||
$start = $max if ($start <= 0);
|
||||
last if ($start == $end);
|
||||
if ($dbline[$start] =~ m'."\n$pat\n".'i) {
|
||||
if ($emacs) {
|
||||
print OUT "\032\032$filename:$start:0\n";
|
||||
} else {
|
||||
print OUT "$start:\t", $dbline[$start], "\n";
|
||||
}
|
||||
last;
|
||||
}
|
||||
} ';
|
||||
print OUT "?$pat?: not found\n" if ($start == $end);
|
||||
next CMD; };
|
||||
$cmd =~ /^!+\s*(-)?(\d+)?$/ && do {
|
||||
pop(@hist) if length($cmd) > 1;
|
||||
$i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist));
|
||||
$cmd = $hist[$i] . "\n";
|
||||
print OUT $cmd;
|
||||
redo CMD; };
|
||||
$cmd =~ /^!(.+)$/ && do {
|
||||
$pat = "^$1";
|
||||
pop(@hist) if length($cmd) > 1;
|
||||
for ($i = $#hist; $i; --$i) {
|
||||
last if $hist[$i] =~ $pat;
|
||||
}
|
||||
if (!$i) {
|
||||
print OUT "No such command!\n\n";
|
||||
next CMD;
|
||||
}
|
||||
$cmd = $hist[$i] . "\n";
|
||||
print OUT $cmd;
|
||||
redo CMD; };
|
||||
$cmd =~ /^H\b\s*(-(\d+))?/ && do {
|
||||
$end = $2?($#hist-$2):0;
|
||||
$hist = 0 if $hist < 0;
|
||||
for ($i=$#hist; $i>$end; $i--) {
|
||||
print OUT "$i: ",$hist[$i],"\n"
|
||||
unless $hist[$i] =~ /^.?$/;
|
||||
};
|
||||
next CMD; };
|
||||
$cmd =~ s/^p( .*)?$/print DB'OUT$1/;
|
||||
$cmd =~ /^=/ && do {
|
||||
if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
|
||||
$alias{$k}="s~$k~$v~";
|
||||
print OUT "$k = $v\n";
|
||||
} elsif ($cmd =~ /^=\s*$/) {
|
||||
foreach $k (sort keys(%alias)) {
|
||||
if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
|
||||
print OUT "$k = $v\n";
|
||||
} else {
|
||||
print OUT "$k\t$alias{$k}\n";
|
||||
};
|
||||
};
|
||||
};
|
||||
next CMD; };
|
||||
}
|
||||
$evalarg = $cmd; &eval;
|
||||
print OUT "\n";
|
||||
}
|
||||
if ($post) {
|
||||
$evalarg = $post; &eval;
|
||||
}
|
||||
}
|
||||
($@, $!, $[, $,, $/, $\) = @saved;
|
||||
}
|
||||
|
||||
sub save {
|
||||
@saved = ($@, $!, $[, $,, $/, $\);
|
||||
$[ = 0; $, = ""; $/ = "\n"; $\ = "";
|
||||
}
|
||||
|
||||
# The following takes its argument via $evalarg to preserve current @_
|
||||
|
||||
sub eval {
|
||||
eval "$usercontext $evalarg; &DB'save";
|
||||
print OUT $@;
|
||||
}
|
||||
|
||||
sub action {
|
||||
local($action) = @_;
|
||||
while ($action =~ s/\\$//) {
|
||||
print OUT "+ ";
|
||||
$action .= &gets;
|
||||
}
|
||||
$action;
|
||||
}
|
||||
|
||||
sub gets {
|
||||
local($.);
|
||||
<IN>;
|
||||
}
|
||||
|
||||
sub catch {
|
||||
$signal = 1;
|
||||
}
|
||||
|
||||
sub sub {
|
||||
push(@stack, $single);
|
||||
$single &= 1;
|
||||
$single |= 4 if $#stack == $deep;
|
||||
if (wantarray) {
|
||||
@i = &$sub;
|
||||
$single |= pop(@stack);
|
||||
@i;
|
||||
}
|
||||
else {
|
||||
$i = &$sub;
|
||||
$single |= pop(@stack);
|
||||
$i;
|
||||
}
|
||||
}
|
||||
|
||||
$single = 1; # so it stops on first executable statement
|
||||
@hist = ('?');
|
||||
$SIG{'INT'} = "DB'catch";
|
||||
$deep = 100; # warning if stack gets this deep
|
||||
$window = 10;
|
||||
$preview = 3;
|
||||
|
||||
@stack = (0);
|
||||
@ARGS = @ARGV;
|
||||
for (@args) {
|
||||
s/'/\\'/g;
|
||||
s/(.*)/'$1'/ unless /^-?[\d.]+$/;
|
||||
}
|
||||
|
||||
if (-f $rcfile) {
|
||||
do "./$rcfile";
|
||||
}
|
||||
elsif (-f "$ENV{'LOGDIR'}/$rcfile") {
|
||||
do "$ENV{'LOGDIR'}/$rcfile";
|
||||
}
|
||||
elsif (-f "$ENV{'HOME'}/$rcfile") {
|
||||
do "$ENV{'HOME'}/$rcfile";
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,72 +0,0 @@
|
|||
;# pwd.pl - keeps track of current working directory in PWD environment var
|
||||
;#
|
||||
;# $RCSfile: pwd.pl,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:52 $
|
||||
;#
|
||||
;# $Log: pwd.pl,v $
|
||||
# Revision 1.1.1.1 1993/08/23 21:29:52 nate
|
||||
# PERL!
|
||||
#
|
||||
;# Revision 4.0.1.1 92/06/08 13:45:22 lwall
|
||||
;# patch20: support added to pwd.pl to strip automounter crud
|
||||
;#
|
||||
;# Revision 4.0 91/03/20 01:26:03 lwall
|
||||
;# 4.0 baseline.
|
||||
;#
|
||||
;# Revision 3.0.1.2 91/01/11 18:09:24 lwall
|
||||
;# patch42: some .pl files were missing their trailing 1;
|
||||
;#
|
||||
;# Revision 3.0.1.1 90/08/09 04:01:24 lwall
|
||||
;# patch19: Initial revision
|
||||
;#
|
||||
;#
|
||||
;# Usage:
|
||||
;# require "pwd.pl";
|
||||
;# &initpwd;
|
||||
;# ...
|
||||
;# &chdir($newdir);
|
||||
|
||||
package pwd;
|
||||
|
||||
sub main'initpwd {
|
||||
if ($ENV{'PWD'}) {
|
||||
local($dd,$di) = stat('.');
|
||||
local($pd,$pi) = stat($ENV{'PWD'});
|
||||
if ($di != $pi || $dd != $pd) {
|
||||
chop($ENV{'PWD'} = `pwd`);
|
||||
}
|
||||
}
|
||||
else {
|
||||
chop($ENV{'PWD'} = `pwd`);
|
||||
}
|
||||
if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) {
|
||||
local($pd,$pi) = stat($2);
|
||||
local($dd,$di) = stat($1);
|
||||
if ($di == $pi && $dd == $pd) {
|
||||
$ENV{'PWD'}="$2$3";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub main'chdir {
|
||||
local($newdir) = shift;
|
||||
if (chdir $newdir) {
|
||||
if ($newdir =~ m#^/#) {
|
||||
$ENV{'PWD'} = $newdir;
|
||||
}
|
||||
else {
|
||||
local(@curdir) = split(m#/#,$ENV{'PWD'});
|
||||
@curdir = '' unless @curdir;
|
||||
foreach $component (split(m#/#, $newdir)) {
|
||||
next if $component eq '.';
|
||||
pop(@curdir),next if $component eq '..';
|
||||
push(@curdir,$component);
|
||||
}
|
||||
$ENV{'PWD'} = join('/',@curdir) || '/';
|
||||
}
|
||||
}
|
||||
else {
|
||||
0;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,48 +0,0 @@
|
|||
;# shellwords.pl
|
||||
;#
|
||||
;# Usage:
|
||||
;# require 'shellwords.pl';
|
||||
;# @words = &shellwords($line);
|
||||
;# or
|
||||
;# @words = &shellwords(@lines);
|
||||
;# or
|
||||
;# @words = &shellwords; # defaults to $_ (and clobbers it)
|
||||
|
||||
sub shellwords {
|
||||
package shellwords;
|
||||
local($_) = join('', @_) if @_;
|
||||
local(@words,$snippet,$field);
|
||||
|
||||
s/^\s+//;
|
||||
while ($_ ne '') {
|
||||
$field = '';
|
||||
for (;;) {
|
||||
if (s/^"(([^"\\]|\\[\\"])*)"//) {
|
||||
($snippet = $1) =~ s#\\(.)#$1#g;
|
||||
}
|
||||
elsif (/^"/) {
|
||||
die "Unmatched double quote: $_\n";
|
||||
}
|
||||
elsif (s/^'(([^'\\]|\\[\\'])*)'//) {
|
||||
($snippet = $1) =~ s#\\(.)#$1#g;
|
||||
}
|
||||
elsif (/^'/) {
|
||||
die "Unmatched single quote: $_\n";
|
||||
}
|
||||
elsif (s/^\\(.)//) {
|
||||
$snippet = $1;
|
||||
}
|
||||
elsif (s/^([^\s\\'"]+)//) {
|
||||
$snippet = $1;
|
||||
}
|
||||
else {
|
||||
s/^\s+//;
|
||||
last;
|
||||
}
|
||||
$field .= $snippet;
|
||||
}
|
||||
push(@words, $field);
|
||||
}
|
||||
@words;
|
||||
}
|
||||
1;
|
||||
|
|
@ -1,31 +0,0 @@
|
|||
;# $Header: /home/cvs/386BSD/ports/lang/perl/lib/stat.pl,v 1.1.1.1 1993/08/23 21:29:53 nate Exp $
|
||||
|
||||
;# Usage:
|
||||
;# require 'stat.pl';
|
||||
;# @ary = stat(foo);
|
||||
;# $st_dev = @ary[$ST_DEV];
|
||||
;#
|
||||
$ST_DEV = 0 + $[;
|
||||
$ST_INO = 1 + $[;
|
||||
$ST_MODE = 2 + $[;
|
||||
$ST_NLINK = 3 + $[;
|
||||
$ST_UID = 4 + $[;
|
||||
$ST_GID = 5 + $[;
|
||||
$ST_RDEV = 6 + $[;
|
||||
$ST_SIZE = 7 + $[;
|
||||
$ST_ATIME = 8 + $[;
|
||||
$ST_MTIME = 9 + $[;
|
||||
$ST_CTIME = 10 + $[;
|
||||
$ST_BLKSIZE = 11 + $[;
|
||||
$ST_BLOCKS = 12 + $[;
|
||||
|
||||
;# Usage:
|
||||
;# require 'stat.pl';
|
||||
;# do Stat('foo'); # sets st_* as a side effect
|
||||
;#
|
||||
sub Stat {
|
||||
($st_dev,$st_ino,$st_mode,$st_nlink,$st_uid,$st_gid,$st_rdev,$st_size,
|
||||
$st_atime,$st_mtime,$st_ctime,$st_blksize,$st_blocks) = stat(shift(@_));
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,224 +0,0 @@
|
|||
#
|
||||
# syslog.pl
|
||||
#
|
||||
# $Log: syslog.pl,v $
|
||||
# Revision 1.1.1.1 1993/08/23 21:29:51 nate
|
||||
# PERL!
|
||||
#
|
||||
# Revision 4.0.1.1 92/06/08 13:48:05 lwall
|
||||
# patch20: new warning for ambiguous use of unary operators
|
||||
#
|
||||
# Revision 4.0 91/03/20 01:26:24 lwall
|
||||
# 4.0 baseline.
|
||||
#
|
||||
# Revision 3.0.1.4 90/11/10 01:41:11 lwall
|
||||
# patch38: syslog.pl was referencing an absolute path
|
||||
#
|
||||
# Revision 3.0.1.3 90/10/15 17:42:18 lwall
|
||||
# patch29: various portability fixes
|
||||
#
|
||||
# Revision 3.0.1.1 90/08/09 03:57:17 lwall
|
||||
# patch19: Initial revision
|
||||
#
|
||||
# Revision 1.2 90/06/11 18:45:30 18:45:30 root ()
|
||||
# - Changed 'warn' to 'mail|warning' in test call (to give example of
|
||||
# facility specification, and because 'warn' didn't work on HP-UX).
|
||||
# - Fixed typo in &openlog ("ncons" should be "cons").
|
||||
# - Added (package-global) $maskpri, and &setlogmask.
|
||||
# - In &syslog:
|
||||
# - put argument test ahead of &connect (why waste cycles?),
|
||||
# - allowed facility to be specified in &syslog's first arg (temporarily
|
||||
# overrides any $facility set in &openlog), just as in syslog(3C),
|
||||
# - do a return 0 when bit for $numpri not set in log mask (see syslog(3C)),
|
||||
# - changed $whoami code to use getlogin, getpwuid($<) and 'syslog'
|
||||
# (in that order) when $ident is null,
|
||||
# - made PID logging consistent with syslog(3C) and subject to $lo_pid only,
|
||||
# - fixed typo in "print CONS" statement ($<facility should be <$facility).
|
||||
# - changed \n to \r in print CONS (\r is useful, $message already has a \n).
|
||||
# - Changed &xlate to return -1 for an unknown name, instead of croaking.
|
||||
#
|
||||
#
|
||||
# tom christiansen <tchrist@convex.com>
|
||||
# modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>
|
||||
# NOTE: openlog now takes three arguments, just like openlog(3)
|
||||
#
|
||||
# call syslog() with a string priority and a list of printf() args
|
||||
# like syslog(3)
|
||||
#
|
||||
# usage: require 'syslog.pl';
|
||||
#
|
||||
# then (put these all in a script to test function)
|
||||
#
|
||||
#
|
||||
# do openlog($program,'cons,pid','user');
|
||||
# do syslog('info','this is another test');
|
||||
# do syslog('mail|warning','this is a better test: %d', time);
|
||||
# do closelog();
|
||||
#
|
||||
# do syslog('debug','this is the last test');
|
||||
# do openlog("$program $$",'ndelay','user');
|
||||
# do syslog('notice','fooprogram: this is really done');
|
||||
#
|
||||
# $! = 55;
|
||||
# do syslog('info','problem was %m'); # %m == $! in syslog(3)
|
||||
|
||||
package syslog;
|
||||
|
||||
$host = 'localhost' unless $host; # set $syslog'host to change
|
||||
|
||||
require 'syslog.ph';
|
||||
|
||||
$maskpri = &LOG_UPTO(&LOG_DEBUG);
|
||||
|
||||
sub main'openlog {
|
||||
($ident, $logopt, $facility) = @_; # package vars
|
||||
$lo_pid = $logopt =~ /\bpid\b/;
|
||||
$lo_ndelay = $logopt =~ /\bndelay\b/;
|
||||
$lo_cons = $logopt =~ /\bcons\b/;
|
||||
$lo_nowait = $logopt =~ /\bnowait\b/;
|
||||
&connect if $lo_ndelay;
|
||||
}
|
||||
|
||||
sub main'closelog {
|
||||
$facility = $ident = '';
|
||||
&disconnect;
|
||||
}
|
||||
|
||||
sub main'setlogmask {
|
||||
local($oldmask) = $maskpri;
|
||||
$maskpri = shift;
|
||||
$oldmask;
|
||||
}
|
||||
|
||||
sub main'syslog {
|
||||
local($priority) = shift;
|
||||
local($mask) = shift;
|
||||
local($message, $whoami);
|
||||
local(@words, $num, $numpri, $numfac, $sum);
|
||||
local($facility) = $facility; # may need to change temporarily.
|
||||
|
||||
die "syslog: expected both priority and mask" unless $mask && $priority;
|
||||
|
||||
@words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility".
|
||||
undef $numpri;
|
||||
undef $numfac;
|
||||
foreach (@words) {
|
||||
$num = &xlate($_); # Translate word to number.
|
||||
if (/^kern$/ || $num < 0) {
|
||||
die "syslog: invalid level/facility: $_\n";
|
||||
}
|
||||
elsif ($num <= &LOG_PRIMASK) {
|
||||
die "syslog: too many levels given: $_\n" if defined($numpri);
|
||||
$numpri = $num;
|
||||
return 0 unless &LOG_MASK($numpri) & $maskpri;
|
||||
}
|
||||
else {
|
||||
die "syslog: too many facilities given: $_\n" if defined($numfac);
|
||||
$facility = $_;
|
||||
$numfac = $num;
|
||||
}
|
||||
}
|
||||
|
||||
die "syslog: level must be given\n" unless defined($numpri);
|
||||
|
||||
if (!defined($numfac)) { # Facility not specified in this call.
|
||||
$facility = 'user' unless $facility;
|
||||
$numfac = &xlate($facility);
|
||||
}
|
||||
|
||||
&connect unless $connected;
|
||||
|
||||
$whoami = $ident;
|
||||
|
||||
if (!$ident && $mask =~ /^(\S.*):\s?(.*)/) {
|
||||
$whoami = $1;
|
||||
$mask = $2;
|
||||
}
|
||||
|
||||
unless ($whoami) {
|
||||
($whoami = getlogin) ||
|
||||
($whoami = getpwuid($<)) ||
|
||||
($whoami = 'syslog');
|
||||
}
|
||||
|
||||
$whoami .= "[$$]" if $lo_pid;
|
||||
|
||||
$mask =~ s/%m/$!/g;
|
||||
$mask .= "\n" unless $mask =~ /\n$/;
|
||||
$message = sprintf ($mask, @_);
|
||||
|
||||
$sum = $numpri + $numfac;
|
||||
unless (send(SYSLOG,"<$sum>$whoami: $message",0)) {
|
||||
if ($lo_cons) {
|
||||
if ($pid = fork) {
|
||||
unless ($lo_nowait) {
|
||||
do {$died = wait;} until $died == $pid || $died < 0;
|
||||
}
|
||||
}
|
||||
else {
|
||||
open(CONS,">/dev/console");
|
||||
print CONS "<$facility.$priority>$whoami: $message\r";
|
||||
exit if defined $pid; # if fork failed, we're parent
|
||||
close CONS;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub xlate {
|
||||
local($name) = @_;
|
||||
$name =~ y/a-z/A-Z/;
|
||||
$name = "LOG_$name" unless $name =~ /^LOG_/;
|
||||
$name = "syslog'$name";
|
||||
eval(&$name) || -1;
|
||||
}
|
||||
|
||||
sub connect {
|
||||
$pat = 'S n C4 x8';
|
||||
|
||||
$af_unix = 1;
|
||||
$af_inet = 2;
|
||||
|
||||
$stream = 1;
|
||||
$datagram = 2;
|
||||
|
||||
($name,$aliases,$proto) = getprotobyname('udp');
|
||||
$udp = $proto;
|
||||
|
||||
($name,$aliase,$port,$proto) = getservbyname('syslog','udp');
|
||||
$syslog = $port;
|
||||
|
||||
if (chop($myname = `hostname`)) {
|
||||
($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($myname);
|
||||
die "Can't lookup $myname\n" unless $name;
|
||||
@bytes = unpack("C4",$addrs[0]);
|
||||
}
|
||||
else {
|
||||
@bytes = (0,0,0,0);
|
||||
}
|
||||
$this = pack($pat, $af_inet, 0, @bytes);
|
||||
|
||||
if ($host =~ /^\d+\./) {
|
||||
@bytes = split(/\./,$host);
|
||||
}
|
||||
else {
|
||||
($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($host);
|
||||
die "Can't lookup $host\n" unless $name;
|
||||
@bytes = unpack("C4",$addrs[0]);
|
||||
}
|
||||
$that = pack($pat,$af_inet,$syslog,@bytes);
|
||||
|
||||
socket(SYSLOG,$af_inet,$datagram,$udp) || die "socket: $!\n";
|
||||
bind(SYSLOG,$this) || die "bind: $!\n";
|
||||
connect(SYSLOG,$that) || die "connect: $!\n";
|
||||
|
||||
local($old) = select(SYSLOG); $| = 1; select($old);
|
||||
$connected = 1;
|
||||
}
|
||||
|
||||
sub disconnect {
|
||||
close SYSLOG;
|
||||
$connected = 0;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,165 +0,0 @@
|
|||
;# $RCSfile: termcap.pl,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:52 $
|
||||
;#
|
||||
;# Usage:
|
||||
;# require 'ioctl.pl';
|
||||
;# ioctl(TTY,$TIOCGETP,$foo);
|
||||
;# ($ispeed,$ospeed) = unpack('cc',$foo);
|
||||
;# require 'termcap.pl';
|
||||
;# &Tgetent('vt100'); # sets $TC{'cm'}, etc.
|
||||
;# &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE');
|
||||
;# &Tputs($TC{'dl'},$affcnt,'FILEHANDLE');
|
||||
;#
|
||||
sub Tgetent {
|
||||
local($TERM) = @_;
|
||||
local($TERMCAP,$_,$entry,$loop,$field);
|
||||
|
||||
warn "Tgetent: no ospeed set" unless $ospeed;
|
||||
foreach $key (keys(TC)) {
|
||||
delete $TC{$key};
|
||||
}
|
||||
$TERM = $ENV{'TERM'} unless $TERM;
|
||||
$TERMCAP = $ENV{'TERMCAP'};
|
||||
$TERMCAP = '/etc/termcap' unless $TERMCAP;
|
||||
if ($TERMCAP !~ m:^/:) {
|
||||
if ($TERMCAP !~ /(^|\|)$TERM[:\|]/) {
|
||||
$TERMCAP = '/etc/termcap';
|
||||
}
|
||||
}
|
||||
if ($TERMCAP =~ m:^/:) {
|
||||
$entry = '';
|
||||
do {
|
||||
$loop = "
|
||||
open(TERMCAP,'<$TERMCAP') || die \"Can't open $TERMCAP\";
|
||||
while (<TERMCAP>) {
|
||||
next if /^#/;
|
||||
next if /^\t/;
|
||||
if (/(^|\\|)$TERM[:\\|]/) {
|
||||
chop;
|
||||
while (chop eq '\\\\') {
|
||||
\$_ .= <TERMCAP>;
|
||||
chop;
|
||||
}
|
||||
\$_ .= ':';
|
||||
last;
|
||||
}
|
||||
}
|
||||
close TERMCAP;
|
||||
\$entry .= \$_;
|
||||
";
|
||||
eval $loop;
|
||||
} while s/:tc=([^:]+):/:/ && ($TERM = $1);
|
||||
$TERMCAP = $entry;
|
||||
}
|
||||
|
||||
foreach $field (split(/:[\s:\\]*/,$TERMCAP)) {
|
||||
if ($field =~ /^\w\w$/) {
|
||||
$TC{$field} = 1;
|
||||
}
|
||||
elsif ($field =~ /^(\w\w)#(.*)/) {
|
||||
$TC{$1} = $2 if $TC{$1} eq '';
|
||||
}
|
||||
elsif ($field =~ /^(\w\w)=(.*)/) {
|
||||
$entry = $1;
|
||||
$_ = $2;
|
||||
s/\\E/\033/g;
|
||||
s/\\(\d\d\d)/pack('c',$1 & 0177)/eg;
|
||||
s/\\n/\n/g;
|
||||
s/\\r/\r/g;
|
||||
s/\\t/\t/g;
|
||||
s/\\b/\b/g;
|
||||
s/\\f/\f/g;
|
||||
s/\\\^/\377/g;
|
||||
s/\^\?/\177/g;
|
||||
s/\^(.)/pack('c',ord($1) & 31)/eg;
|
||||
s/\\(.)/$1/g;
|
||||
s/\377/^/g;
|
||||
$TC{$entry} = $_ if $TC{$entry} eq '';
|
||||
}
|
||||
}
|
||||
$TC{'pc'} = "\0" if $TC{'pc'} eq '';
|
||||
$TC{'bc'} = "\b" if $TC{'bc'} eq '';
|
||||
}
|
||||
|
||||
@Tputs = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2);
|
||||
|
||||
sub Tputs {
|
||||
local($string,$affcnt,$FH) = @_;
|
||||
local($ms);
|
||||
if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
|
||||
$ms = $1;
|
||||
$ms *= $affcnt if $2;
|
||||
$string = $3;
|
||||
$decr = $Tputs[$ospeed];
|
||||
if ($decr > .1) {
|
||||
$ms += $decr / 2;
|
||||
$string .= $TC{'pc'} x ($ms / $decr);
|
||||
}
|
||||
}
|
||||
print $FH $string if $FH;
|
||||
$string;
|
||||
}
|
||||
|
||||
sub Tgoto {
|
||||
local($string) = shift(@_);
|
||||
local($result) = '';
|
||||
local($after) = '';
|
||||
local($code,$tmp) = @_;
|
||||
local(@tmp);
|
||||
@tmp = ($tmp,$code);
|
||||
local($online) = 0;
|
||||
while ($string =~ /^([^%]*)%(.)(.*)/) {
|
||||
$result .= $1;
|
||||
$code = $2;
|
||||
$string = $3;
|
||||
if ($code eq 'd') {
|
||||
$result .= sprintf("%d",shift(@tmp));
|
||||
}
|
||||
elsif ($code eq '.') {
|
||||
$tmp = shift(@tmp);
|
||||
if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
|
||||
if ($online) {
|
||||
++$tmp, $after .= $TC{'up'} if $TC{'up'};
|
||||
}
|
||||
else {
|
||||
++$tmp, $after .= $TC{'bc'};
|
||||
}
|
||||
}
|
||||
$result .= sprintf("%c",$tmp);
|
||||
$online = !$online;
|
||||
}
|
||||
elsif ($code eq '+') {
|
||||
$result .= sprintf("%c",shift(@tmp)+ord($string));
|
||||
$string = substr($string,1,99);
|
||||
$online = !$online;
|
||||
}
|
||||
elsif ($code eq 'r') {
|
||||
($code,$tmp) = @tmp;
|
||||
@tmp = ($tmp,$code);
|
||||
$online = !$online;
|
||||
}
|
||||
elsif ($code eq '>') {
|
||||
($code,$tmp,$string) = unpack("CCa99",$string);
|
||||
if ($tmp[$[] > $code) {
|
||||
$tmp[$[] += $tmp;
|
||||
}
|
||||
}
|
||||
elsif ($code eq '2') {
|
||||
$result .= sprintf("%02d",shift(@tmp));
|
||||
$online = !$online;
|
||||
}
|
||||
elsif ($code eq '3') {
|
||||
$result .= sprintf("%03d",shift(@tmp));
|
||||
$online = !$online;
|
||||
}
|
||||
elsif ($code eq 'i') {
|
||||
($code,$tmp) = @tmp;
|
||||
@tmp = ($code+1,$tmp+1);
|
||||
}
|
||||
else {
|
||||
return "OOPS";
|
||||
}
|
||||
}
|
||||
$result . $string . $after;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,83 +0,0 @@
|
|||
;# timelocal.pl
|
||||
;#
|
||||
;# Usage:
|
||||
;# $time = timelocal($sec,$min,$hours,$mday,$mon,$year);
|
||||
;# $time = timegm($sec,$min,$hours,$mday,$mon,$year);
|
||||
|
||||
;# These routines are quite efficient and yet are always guaranteed to agree
|
||||
;# with localtime() and gmtime(). We manage this by caching the start times
|
||||
;# of any months we've seen before. If we know the start time of the month,
|
||||
;# we can always calculate any time within the month. The start times
|
||||
;# themselves are guessed by successive approximation starting at the
|
||||
;# current time, since most dates seen in practice are close to the
|
||||
;# current date. Unlike algorithms that do a binary search (calling gmtime
|
||||
;# once for each bit of the time value, resulting in 32 calls), this algorithm
|
||||
;# calls it at most 6 times, and usually only once or twice. If you hit
|
||||
;# the month cache, of course, it doesn't call it at all.
|
||||
|
||||
;# timelocal is implemented using the same cache. We just assume that we're
|
||||
;# translating a GMT time, and then fudge it when we're done for the timezone
|
||||
;# and daylight savings arguments. The timezone is determined by examining
|
||||
;# the result of localtime(0) when the package is initialized. The daylight
|
||||
;# savings offset is currently assumed to be one hour.
|
||||
|
||||
CONFIG: {
|
||||
package timelocal;
|
||||
|
||||
local($[) = 0;
|
||||
@epoch = localtime(0);
|
||||
$tzmin = $epoch[2] * 60 + $epoch[1]; # minutes east of GMT
|
||||
if ($tzmin > 0) {
|
||||
$tzmin = 24 * 60 - $tzmin; # minutes west of GMT
|
||||
$tzmin -= 24 * 60 if $epoch[5] == 70; # account for the date line
|
||||
}
|
||||
|
||||
$SEC = 1;
|
||||
$MIN = 60 * $SEC;
|
||||
$HR = 60 * $MIN;
|
||||
$DAYS = 24 * $HR;
|
||||
$YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0;
|
||||
1;
|
||||
}
|
||||
|
||||
sub timegm {
|
||||
package timelocal;
|
||||
|
||||
local($[) = 0;
|
||||
$ym = pack(C2, @_[5,4]);
|
||||
$cheat = $cheat{$ym} || &cheat;
|
||||
$cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAYS;
|
||||
}
|
||||
|
||||
sub timelocal {
|
||||
package timelocal;
|
||||
|
||||
local($[) = 0;
|
||||
$time = &main'timegm + $tzmin*$MIN;
|
||||
@test = localtime($time);
|
||||
$time -= $HR if $test[2] != $_[2];
|
||||
$time;
|
||||
}
|
||||
|
||||
package timelocal;
|
||||
|
||||
sub cheat {
|
||||
$year = $_[5];
|
||||
$month = $_[4];
|
||||
die "Month out of range 0..11 in ctime.pl\n" if $month > 11;
|
||||
$guess = $^T;
|
||||
@g = gmtime($guess);
|
||||
$year += $YearFix if $year < $epoch[5];
|
||||
while ($diff = $year - $g[5]) {
|
||||
$guess += $diff * (363 * $DAYS);
|
||||
@g = gmtime($guess);
|
||||
}
|
||||
while ($diff = $month - $g[4]) {
|
||||
$guess += $diff * (27 * $DAYS);
|
||||
@g = gmtime($guess);
|
||||
}
|
||||
$g[3]--;
|
||||
$guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAYS;
|
||||
$cheat{$ym} = $guess;
|
||||
}
|
||||
1;
|
||||
|
|
@ -1,104 +0,0 @@
|
|||
;# $Header: /home/cvs/386BSD/ports/lang/perl/lib/validate.pl,v 1.1.1.1 1993/08/23 21:29:51 nate Exp $
|
||||
|
||||
;# The validate routine takes a single multiline string consisting of
|
||||
;# lines containing a filename plus a file test to try on it. (The
|
||||
;# file test may also be a 'cd', causing subsequent relative filenames
|
||||
;# to be interpreted relative to that directory.) After the file test
|
||||
;# you may put '|| die' to make it a fatal error if the file test fails.
|
||||
;# The default is '|| warn'. The file test may optionally have a ! prepended
|
||||
;# to test for the opposite condition. If you do a cd and then list some
|
||||
;# relative filenames, you may want to indent them slightly for readability.
|
||||
;# If you supply your own "die" or "warn" message, you can use $file to
|
||||
;# interpolate the filename.
|
||||
|
||||
;# Filetests may be bunched: -rwx tests for all of -r, -w and -x.
|
||||
;# Only the first failed test of the bunch will produce a warning.
|
||||
|
||||
;# The routine returns the number of warnings issued.
|
||||
|
||||
;# Usage:
|
||||
;# require "validate.pl";
|
||||
;# $warnings += do validate('
|
||||
;# /vmunix -e || die
|
||||
;# /boot -e || die
|
||||
;# /bin cd
|
||||
;# csh -ex
|
||||
;# csh !-ug
|
||||
;# sh -ex
|
||||
;# sh !-ug
|
||||
;# /usr -d || warn "What happened to $file?\n"
|
||||
;# ');
|
||||
|
||||
sub validate {
|
||||
local($file,$test,$warnings,$oldwarnings);
|
||||
foreach $check (split(/\n/,$_[0])) {
|
||||
next if $check =~ /^#/;
|
||||
next if $check =~ /^$/;
|
||||
($file,$test) = split(' ',$check,2);
|
||||
if ($test =~ s/^(!?-)(\w{2,}\b)/$1Z/) {
|
||||
$testlist = $2;
|
||||
@testlist = split(//,$testlist);
|
||||
}
|
||||
else {
|
||||
@testlist = ('Z');
|
||||
}
|
||||
$oldwarnings = $warnings;
|
||||
foreach $one (@testlist) {
|
||||
$this = $test;
|
||||
$this =~ s/(-\w\b)/$1 \$file/g;
|
||||
$this =~ s/-Z/-$one/;
|
||||
$this .= ' || warn' unless $this =~ /\|\|/;
|
||||
$this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || do valmess('$2','$1')/;
|
||||
$this =~ s/\bcd\b/chdir (\$cwd = \$file)/g;
|
||||
eval $this;
|
||||
last if $warnings > $oldwarnings;
|
||||
}
|
||||
}
|
||||
$warnings;
|
||||
}
|
||||
|
||||
sub valmess {
|
||||
local($disposition,$this) = @_;
|
||||
$file = $cwd . '/' . $file unless $file =~ m|^/|;
|
||||
if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) {
|
||||
$neg = $1;
|
||||
$tmp = $2;
|
||||
$tmp eq 'r' && ($mess = "$file is not readable by uid $>.");
|
||||
$tmp eq 'w' && ($mess = "$file is not writable by uid $>.");
|
||||
$tmp eq 'x' && ($mess = "$file is not executable by uid $>.");
|
||||
$tmp eq 'o' && ($mess = "$file is not owned by uid $>.");
|
||||
$tmp eq 'R' && ($mess = "$file is not readable by you.");
|
||||
$tmp eq 'W' && ($mess = "$file is not writable by you.");
|
||||
$tmp eq 'X' && ($mess = "$file is not executable by you.");
|
||||
$tmp eq 'O' && ($mess = "$file is not owned by you.");
|
||||
$tmp eq 'e' && ($mess = "$file does not exist.");
|
||||
$tmp eq 'z' && ($mess = "$file does not have zero size.");
|
||||
$tmp eq 's' && ($mess = "$file does not have non-zero size.");
|
||||
$tmp eq 'f' && ($mess = "$file is not a plain file.");
|
||||
$tmp eq 'd' && ($mess = "$file is not a directory.");
|
||||
$tmp eq 'l' && ($mess = "$file is not a symbolic link.");
|
||||
$tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO).");
|
||||
$tmp eq 'S' && ($mess = "$file is not a socket.");
|
||||
$tmp eq 'b' && ($mess = "$file is not a block special file.");
|
||||
$tmp eq 'c' && ($mess = "$file is not a character special file.");
|
||||
$tmp eq 'u' && ($mess = "$file does not have the setuid bit set.");
|
||||
$tmp eq 'g' && ($mess = "$file does not have the setgid bit set.");
|
||||
$tmp eq 'k' && ($mess = "$file does not have the sticky bit set.");
|
||||
$tmp eq 'T' && ($mess = "$file is not a text file.");
|
||||
$tmp eq 'B' && ($mess = "$file is not a binary file.");
|
||||
if ($neg eq '!') {
|
||||
$mess =~ s/ is not / should not be / ||
|
||||
$mess =~ s/ does not / should not / ||
|
||||
$mess =~ s/ not / /;
|
||||
}
|
||||
print stderr $mess,"\n";
|
||||
}
|
||||
else {
|
||||
$this =~ s/\$file/'$file'/g;
|
||||
print stderr "Can't do $this.\n";
|
||||
}
|
||||
if ($disposition eq 'die') { exit 1; }
|
||||
++$warnings;
|
||||
}
|
||||
|
||||
1;
|
||||
File diff suppressed because it is too large
Load diff
|
|
@ -1,191 +0,0 @@
|
|||
Article 484 of comp.lang.perl:
|
||||
Xref: netlabs comp.lang.perl:484 comp.lang.c:983 alt.sources:134
|
||||
Path: netlabs!psinntp!iggy.GW.Vitalink.COM!lll-winken!sun-barr!cronkite.Central.Sun.COM!spdev!texsun!convex!tchrist
|
||||
From: tchrist@convex.com (Tom Christiansen)
|
||||
Newsgroups: comp.lang.perl,comp.lang.c,alt.sources
|
||||
Subject: pstruct -- a C structure formatter; AKA c2ph, a C to perl header translator
|
||||
Keywords: C perl tranlator
|
||||
Message-ID: <1991Jul25.081021.8104@convex.com>
|
||||
Date: 25 Jul 91 08:10:21 GMT
|
||||
Sender: usenet@convex.com (news access account)
|
||||
Followup-To: comp.lang.perl
|
||||
Organization: CONVEX Computer Corporation, Richardson, Tx., USA
|
||||
Lines: 1208
|
||||
Nntp-Posting-Host: pixel.convex.com
|
||||
|
||||
Once upon a time, I wrote a program called pstruct. It was a perl
|
||||
program that tried to parse out C structures and display their member
|
||||
offsets for you. This was especially useful for people looking at
|
||||
binary dumps or poking around the kernel.
|
||||
|
||||
Pstruct was not a pretty program. Neither was it particularly robust.
|
||||
The problem, you see, was that the C compiler was much better at parsing
|
||||
C than I could ever hope to be.
|
||||
|
||||
So I got smart: I decided to be lazy and let the C compiler parse the C,
|
||||
which would spit out debugger stabs for me to read. These were much
|
||||
easier to parse. It's still not a pretty program, but at least it's more
|
||||
robust.
|
||||
|
||||
Pstruct takes any .c or .h files, or preferably .s ones, since that's
|
||||
the format it is going to massage them into anyway, and spits out
|
||||
listings like this:
|
||||
|
||||
struct tty {
|
||||
int tty.t_locker 000 4
|
||||
int tty.t_mutex_index 004 4
|
||||
struct tty * tty.t_tp_virt 008 4
|
||||
struct clist tty.t_rawq 00c 20
|
||||
int tty.t_rawq.c_cc 00c 4
|
||||
int tty.t_rawq.c_cmax 010 4
|
||||
int tty.t_rawq.c_cfx 014 4
|
||||
int tty.t_rawq.c_clx 018 4
|
||||
struct tty * tty.t_rawq.c_tp_cpu 01c 4
|
||||
struct tty * tty.t_rawq.c_tp_iop 020 4
|
||||
unsigned char * tty.t_rawq.c_buf_cpu 024 4
|
||||
unsigned char * tty.t_rawq.c_buf_iop 028 4
|
||||
struct clist tty.t_canq 02c 20
|
||||
int tty.t_canq.c_cc 02c 4
|
||||
int tty.t_canq.c_cmax 030 4
|
||||
int tty.t_canq.c_cfx 034 4
|
||||
int tty.t_canq.c_clx 038 4
|
||||
struct tty * tty.t_canq.c_tp_cpu 03c 4
|
||||
struct tty * tty.t_canq.c_tp_iop 040 4
|
||||
unsigned char * tty.t_canq.c_buf_cpu 044 4
|
||||
unsigned char * tty.t_canq.c_buf_iop 048 4
|
||||
struct clist tty.t_outq 04c 20
|
||||
int tty.t_outq.c_cc 04c 4
|
||||
int tty.t_outq.c_cmax 050 4
|
||||
int tty.t_outq.c_cfx 054 4
|
||||
int tty.t_outq.c_clx 058 4
|
||||
struct tty * tty.t_outq.c_tp_cpu 05c 4
|
||||
struct tty * tty.t_outq.c_tp_iop 060 4
|
||||
unsigned char * tty.t_outq.c_buf_cpu 064 4
|
||||
unsigned char * tty.t_outq.c_buf_iop 068 4
|
||||
(*int)() tty.t_oproc_cpu 06c 4
|
||||
(*int)() tty.t_oproc_iop 070 4
|
||||
(*int)() tty.t_stopproc_cpu 074 4
|
||||
(*int)() tty.t_stopproc_iop 078 4
|
||||
struct thread * tty.t_rsel 07c 4
|
||||
|
||||
etc.
|
||||
|
||||
|
||||
Actually, this was generated by a particular set of options. You can control
|
||||
the formatting of each column, whether you prefer wide or fat, hex or decimal,
|
||||
leading zeroes or whatever.
|
||||
|
||||
All you need to be able to use this is a C compiler than generates
|
||||
BSD/GCC-style stabs. The -g option on native BSD compilers and GCC
|
||||
should get this for you.
|
||||
|
||||
To learn more, just type a bogus option, like -\?, and a long usage message
|
||||
will be provided. There are a fair number of possibilities.
|
||||
|
||||
If you're only a C programmer, than this is the end of the message for you.
|
||||
You can quit right now, and if you care to, save off the source and run it
|
||||
when you feel like it. Or not.
|
||||
|
||||
|
||||
|
||||
But if you're a perl programmer, then for you I have something much more
|
||||
wondrous than just a structure offset printer.
|
||||
|
||||
You see, if you call pstruct by its other incybernation, c2ph, you have a code
|
||||
generator that translates C code into perl code! Well, structure and union
|
||||
declarations at least, but that's quite a bit.
|
||||
|
||||
Prior to this point, anyone programming in perl who wanted to interact
|
||||
with C programs, like the kernel, was forced to guess the layouts of the C
|
||||
strutures, and then hardwire these into his program. Of course, when you
|
||||
took your wonderfully to a system where the sgtty structure was laid out
|
||||
differently, you program broke. Which is a shame.
|
||||
|
||||
We've had Larry's h2ph translator, which helped, but that only works on
|
||||
cpp symbols, not real C, which was also very much needed. What I offer
|
||||
you is a symbolic way of getting at all the C structures. I've couched
|
||||
them in terms of packages and functions. Consider the following program:
|
||||
|
||||
#!/usr/bin/perl
|
||||
|
||||
require 'syscall.ph';
|
||||
require 'sys/time.ph';
|
||||
require 'sys/resource.ph';
|
||||
|
||||
$ru = "\0" x &rusage'sizeof();
|
||||
|
||||
syscall(&SYS_getrusage, &RUSAGE_SELF, $ru) && die "getrusage: $!";
|
||||
|
||||
@ru = unpack($t = &rusage'typedef(), $ru);
|
||||
|
||||
$utime = $ru[ &rusage'ru_utime + &timeval'tv_sec ]
|
||||
+ ($ru[ &rusage'ru_utime + &timeval'tv_usec ]) / 1e6;
|
||||
|
||||
$stime = $ru[ &rusage'ru_stime + &timeval'tv_sec ]
|
||||
+ ($ru[ &rusage'ru_stime + &timeval'tv_usec ]) / 1e6;
|
||||
|
||||
printf "you have used %8.3fs+%8.3fu seconds.\n", $utime, $stime;
|
||||
|
||||
|
||||
As you see, the name of the package is the name of the structure. Regular
|
||||
fields are just their own names. Plus the follwoing accessor functions are
|
||||
provided for your convenience:
|
||||
|
||||
struct This takes no arguments, and is merely the number of first-level
|
||||
elements in the structure. You would use this for indexing
|
||||
into arrays of structures, perhaps like this
|
||||
|
||||
|
||||
$usec = $u[ &user'u_utimer
|
||||
+ (&ITIMER_VIRTUAL * &itimerval'struct)
|
||||
+ &itimerval'it_value
|
||||
+ &timeval'tv_usec
|
||||
];
|
||||
|
||||
sizeof Returns the bytes in the structure, or the member if
|
||||
you pass it an argument, such as
|
||||
|
||||
&rusage'sizeof(&rusage'ru_utime)
|
||||
|
||||
typedef This is the perl format definition for passing to pack and
|
||||
unpack. If you ask for the typedef of a nothing, you get
|
||||
the whole structure, otherwise you get that of the member
|
||||
you ask for. Padding is taken care of, as is the magic to
|
||||
guarantee that a union is unpacked into all its aliases.
|
||||
Bitfields are not quite yet supported however.
|
||||
|
||||
offsetof This function is the byte offset into the array of that
|
||||
member. You may wish to use this for indexing directly
|
||||
into the packed structure with vec() if you're too lazy
|
||||
to unpack it.
|
||||
|
||||
typeof Not to be confused with the typedef accessor function, this
|
||||
one returns the C type of that field. This would allow
|
||||
you to print out a nice structured pretty print of some
|
||||
structure without knoning anything about it beforehand.
|
||||
No args to this one is a noop. Someday I'll post such
|
||||
a thing to dump out your u structure for you.
|
||||
|
||||
|
||||
The way I see this being used is like basically this:
|
||||
|
||||
% h2ph <some_include_file.h > /usr/lib/perl/tmp.ph
|
||||
% c2ph some_include_file.h >> /usr/lib/perl/tmp.ph
|
||||
% install
|
||||
|
||||
It's a little tricker with c2ph because you have to get the includes right.
|
||||
I can't know this for your system, but it's not usually too terribly difficult.
|
||||
|
||||
The code isn't pretty as I mentioned -- I never thought it would be a 1000-
|
||||
line program when I started, or I might not have begun. :-) But I would have
|
||||
been less cavalier in how the parts of the program communicated with each
|
||||
other, etc. It might also have helped if I didn't have to divine the makeup
|
||||
of the stabs on the fly, and then account for micro differences between my
|
||||
compiler and gcc.
|
||||
|
||||
Anyway, here it is. Should run on perl v4 or greater. Maybe less.
|
||||
|
||||
|
||||
--tom
|
||||
|
||||
|
||||
File diff suppressed because it is too large
Load diff
|
|
@ -1,29 +0,0 @@
|
|||
/* $RCSfile: EXTERN.h,v $$Revision: 1.1.1.1 $$Date: 1994/09/10 06:27:34 $
|
||||
*
|
||||
* Copyright (c) 1991, Larry Wall
|
||||
*
|
||||
* You may distribute under the terms of either the GNU General Public
|
||||
* License or the Artistic License, as specified in the README file.
|
||||
*
|
||||
* $Log: EXTERN.h,v $
|
||||
* Revision 1.1.1.1 1994/09/10 06:27:34 gclarkii
|
||||
* Initial import of Perl 4.046 bmaked
|
||||
*
|
||||
* Revision 1.1.1.1 1993/08/23 21:29:33 nate
|
||||
* PERL!
|
||||
*
|
||||
* Revision 4.0.1.1 91/06/07 10:10:32 lwall
|
||||
* patch4: new copyright notice
|
||||
*
|
||||
* Revision 4.0 91/03/20 00:58:26 lwall
|
||||
* 4.0 baseline.
|
||||
*
|
||||
*/
|
||||
|
||||
#undef EXT
|
||||
#define EXT extern
|
||||
|
||||
#undef INIT
|
||||
#define INIT(x)
|
||||
|
||||
#undef DOINIT
|
||||
Some files were not shown because too many files have changed in this diff Show more
Loading…
Reference in a new issue