dslinux/user/perl/x2p EXTERN.h INTERN.h Makefile.SH a2p.c a2p.h a2p.pod a2p.y a2py.c cflags.SH find2perl.PL hash.c hash.h s2p.PL str.c str.h util.c util.h walk.c
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:02:29 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/x2p
In directory antilope:/tmp/cvs-serv17422/x2p
Added Files:
EXTERN.h INTERN.h Makefile.SH a2p.c a2p.h a2p.pod a2p.y a2py.c
cflags.SH find2perl.PL hash.c hash.h s2p.PL str.c str.h util.c
util.h walk.c
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: a2p.c ---
#ifndef lint
static const char yysccsid[] = "@(#)yaccpar 1.9 (Berkeley) 02/21/93";
#endif
#define YYBYACC 1
#define YYMAJOR 1
#define YYMINOR 9
#define yyclearin (yychar=(-1))
#define yyerrok (yyerrflag=0)
#define YYRECOVERING (yyerrflag!=0)
extern int yyparse(void);
#define YYPREFIX "yy"
#line 2 "a2p.y"
/* $RCSfile: a2p.c,v $$Revision: 1.2 $$Date: 2006-12-04 17:02:26 $
*
* Copyright (C) 1991, 1992, 1993, 1994, 1996, 1997, 1999, 2000,
* by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
[...2897 lines suppressed...]
yystate = yydgoto[yym];
#if YYDEBUG
if (yydebug)
printf("%sdebug: after reduction, shifting from state %d \
to state %d\n", YYPREFIX, *yyssp, yystate);
#endif
if (yyssp >= yyss + yystacksize - 1)
{
goto yyoverflow;
}
*++yyssp = yystate;
*++yyvsp = yyval;
goto yyloop;
yyoverflow:
yyerror("yacc stack overflow");
yyabort:
return (1);
yyaccept:
return (0);
}
--- NEW FILE: a2p.pod ---
=head1 NAME
a2p - Awk to Perl translator
=head1 SYNOPSIS
B<a2p> [I<options>] [I<filename>]
=head1 DESCRIPTION
I<A2p> takes an awk script specified on the command line (or from
standard input) and produces a comparable I<perl> script on the
standard output.
=head2 OPTIONS
Options include:
=over 5
=item B<-DE<lt>numberE<gt>>
sets debugging flags.
=item B<-FE<lt>characterE<gt>>
tells a2p that this awk script is always invoked with this B<-F>
switch.
=item B<-nE<lt>fieldlistE<gt>>
specifies the names of the input fields if input does not have to be
split into an array. If you were translating an awk script that
processes the password file, you might say:
a2p -7 -nlogin.password.uid.gid.gcos.shell.home
Any delimiter can be used to separate the field names.
=item B<-E<lt>numberE<gt>>
causes a2p to assume that input will always have that many fields.
=item B<-o>
tells a2p to use old awk behavior. The only current differences are:
=over 5
=item *
Old awk always has a line loop, even if there are no line
actions, whereas new awk does not.
=item *
In old awk, sprintf is extremely greedy about its arguments.
For example, given the statement
print sprintf(some_args), extra_args;
old awk considers I<extra_args> to be arguments to C<sprintf>; new awk
considers them arguments to C<print>.
=back
=back
=head2 "Considerations"
A2p cannot do as good a job translating as a human would, but it
usually does pretty well. There are some areas where you may want to
examine the perl script produced and tweak it some. Here are some of
them, in no particular order.
There is an awk idiom of putting int() around a string expression to
force numeric interpretation, even though the argument is always
integer anyway. This is generally unneeded in perl, but a2p can't
tell if the argument is always going to be integer, so it leaves it
in. You may wish to remove it.
Perl differentiates numeric comparison from string comparison. Awk
has one operator for both that decides at run time which comparison to
do. A2p does not try to do a complete job of awk emulation at this
point. Instead it guesses which one you want. It's almost always
right, but it can be spoofed. All such guesses are marked with the
comment "C<#???>". You should go through and check them. You might
want to run at least once with the B<-w> switch to perl, which will
warn you if you use == where you should have used eq.
Perl does not attempt to emulate the behavior of awk in which
nonexistent array elements spring into existence simply by being
referenced. If somehow you are relying on this mechanism to create
null entries for a subsequent for...in, they won't be there in perl.
If a2p makes a split line that assigns to a list of variables that
looks like (Fld1, Fld2, Fld3...) you may want to rerun a2p using the
B<-n> option mentioned above. This will let you name the fields
throughout the script. If it splits to an array instead, the script
is probably referring to the number of fields somewhere.
The exit statement in awk doesn't necessarily exit; it goes to the END
block if there is one. Awk scripts that do contortions within the END
block to bypass the block under such circumstances can be simplified
by removing the conditional in the END block and just exiting directly
from the perl script.
Perl has two kinds of array, numerically-indexed and associative.
Perl associative arrays are called "hashes". Awk arrays are usually
translated to hashes, but if you happen to know that the index is
always going to be numeric you could change the {...} to [...].
Iteration over a hash is done using the keys() function, but iteration
over an array is NOT. You might need to modify any loop that iterates
over such an array.
Awk starts by assuming OFMT has the value %.6g. Perl starts by
assuming its equivalent, $#, to have the value %.20g. You'll want to
set $# explicitly if you use the default value of OFMT.
Near the top of the line loop will be the split operation that is
implicit in the awk script. There are times when you can move this
down past some conditionals that test the entire record so that the
split is not done as often.
For aesthetic reasons you may wish to change the array base $[ from 1
back to perl's default of 0, but remember to change all array
subscripts AND all substr() and index() operations to match.
Cute comments that say "# Here is a workaround because awk is dumb"
are passed through unmodified.
Awk scripts are often embedded in a shell script that pipes stuff into
and out of awk. Often the shell script wrapper can be incorporated
into the perl script, since perl can start up pipes into and out of
itself, and can do other things that awk can't do by itself.
Scripts that refer to the special variables RSTART and RLENGTH can
often be simplified by referring to the variables $`, $& and $', as
long as they are within the scope of the pattern match that sets them.
The produced perl script may have subroutines defined to deal with
awk's semantics regarding getline and print. Since a2p usually picks
correctness over efficiency. it is almost always possible to rewrite
such code to be more efficient by discarding the semantic sugar.
For efficiency, you may wish to remove the keyword from any return
statement that is the last statement executed in a subroutine. A2p
catches the most common case, but doesn't analyze embedded blocks for
subtler cases.
ARGV[0] translates to $ARGV0, but ARGV[n] translates to $ARGV[$n]. A
loop that tries to iterate over ARGV[0] won't find it.
=head1 ENVIRONMENT
A2p uses no environment variables.
=head1 AUTHOR
Larry Wall E<lt>F<larry at wall.org>E<gt>
=head1 FILES
=head1 SEE ALSO
perl The perl compiler/interpreter
s2p sed to perl translator
=head1 DIAGNOSTICS
=head1 BUGS
It would be possible to emulate awk's behavior in selecting string
versus numeric operations at run time by inspection of the operands,
but it would be gross and inefficient. Besides, a2p almost always
guesses right.
Storage for the awk syntax tree is currently static, and can run out.
--- NEW FILE: hash.h ---
/* hash.h
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2000, 2005
* by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*/
#define FILLPCT 60 /* don't make greater than 99 */
#ifdef DOINIT
char const coeff[] = {
61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1};
#else
extern const char coeff[];
#endif
typedef struct hentry HENT;
struct hentry {
HENT *hent_next;
char *hent_key;
STR *hent_val;
int hent_hash;
};
struct htbl {
HENT **tbl_array;
int tbl_max;
int tbl_fill;
int tbl_riter; /* current root of iterator */
HENT *tbl_eiter; /* current entry of iterator */
};
STR * hfetch ( HASH *tb, char *key );
int hiterinit ( HASH *tb );
HASH * hnew ( void );
void hsplit ( HASH *tb );
bool hstore ( HASH *tb, char *key, STR *val );
--- NEW FILE: walk.c ---
/* walk.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1997, 1998, 1999,
* 2000, 2001, 2002, 2005 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*/
#include "EXTERN.h"
#include "a2p.h"
#include "util.h"
bool exitval = FALSE;
bool realexit = FALSE;
bool saw_getline = FALSE;
bool subretnum = FALSE;
bool saw_FNR = FALSE;
bool saw_argv0 = FALSE;
[...2016 lines suppressed...]
}
static void
numericize(register int node)
{
register int len;
register int type;
STR *tmpstr;
STR *tmp2str;
int numarg;
type = ops[node].ival;
len = type >> 8;
type &= 255;
if (type == OVAR && len == 1) {
tmpstr=walk(0,0,ops[node+1].ival,&numarg,P_MIN);
tmp2str = str_make("1");
hstore(symtab,tmpstr->str_ptr,tmp2str);
}
}
--- NEW FILE: a2p.y ---
%{
/* $RCSfile: a2p.y,v $$Revision: 1.2 $$Date: 2006-12-04 17:02:26 $
*
* Copyright (C) 1991, 1992, 1993, 1994, 1996, 1997, 1999, 2000,
* by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
* $Log: a2p.y,v $
* Revision 1.2 2006-12-04 17:02:26 dslinux_cayenne
* Adding fresh perl source to HEAD to branch from
*
*/
#include "INTERN.h"
#include "a2p.h"
int root;
int begins = Nullop;
int ends = Nullop;
%}
%token BEGIN END
%token REGEX
%token SEMINEW NEWLINE COMMENT
%token FUN1 FUNN GRGR
%token PRINT PRINTF SPRINTF_OLD SPRINTF_NEW SPLIT
%token IF ELSE WHILE FOR IN
%token EXIT NEXT BREAK CONTINUE RET
%token GETLINE DO SUB GSUB MATCH
%token FUNCTION USERFUN DELETE
%right ASGNOP
%right '?' ':'
%left OROR
%left ANDAND
%left IN
%left NUMBER VAR SUBSTR INDEX
%left MATCHOP
%left RELOP '<' '>'
%left OR
%left STRING
%left '+' '-'
%left '*' '/' '%'
%right UMINUS
%left NOT
%right '^'
%left INCR DECR
%left FIELD VFIELD SVFIELD
%%
program : junk hunks
{ root = oper4(OPROG,$1,begins,$2,ends); }
;
begin : BEGIN '{' maybe states '}' junk
{ begins = oper4(OJUNK,begins,$3,$4,$6); in_begin = FALSE;
$$ = Nullop; }
;
end : END '{' maybe states '}'
{ ends = oper3(OJUNK,ends,$3,$4); $$ = Nullop; }
| end NEWLINE
{ $$ = $1; }
;
hunks : hunks hunk junk
{ $$ = oper3(OHUNKS,$1,$2,$3); }
| /* NULL */
{ $$ = Nullop; }
;
hunk : patpat
{ $$ = oper1(OHUNK,$1); need_entire = TRUE; }
| patpat '{' maybe states '}'
{ $$ = oper2(OHUNK,$1,oper2(OJUNK,$3,$4)); }
| FUNCTION USERFUN '(' arg_list ')' maybe '{' maybe states '}'
{ fixfargs($2,$4,0); $$ = oper5(OUSERDEF,$2,$4,$6,$8,$9); }
| '{' maybe states '}'
{ $$ = oper2(OHUNK,Nullop,oper2(OJUNK,$2,$3)); }
| begin
| end
;
arg_list: expr_list
{ $$ = rememberargs($$); }
;
patpat : cond
{ $$ = oper1(OPAT,$1); }
| cond ',' cond
{ $$ = oper2(ORANGE,$1,$3); }
;
cond : expr
| match
| rel
| compound_cond
| cond '?' expr ':' expr
{ $$ = oper3(OCOND,$1,$3,$5); }
;
compound_cond
: '(' compound_cond ')'
{ $$ = oper1(OCPAREN,$2); }
| cond ANDAND maybe cond
{ $$ = oper3(OCANDAND,$1,$3,$4); }
| cond OROR maybe cond
{ $$ = oper3(OCOROR,$1,$3,$4); }
| NOT cond
{ $$ = oper1(OCNOT,$2); }
;
rel : expr RELOP expr
{ $$ = oper3(ORELOP,$2,$1,$3); }
| expr '>' expr
{ $$ = oper3(ORELOP,string(">",1),$1,$3); }
| expr '<' expr
{ $$ = oper3(ORELOP,string("<",1),$1,$3); }
| '(' rel ')'
{ $$ = oper1(ORPAREN,$2); }
;
match : expr MATCHOP expr
{ $$ = oper3(OMATCHOP,$2,$1,$3); }
| expr MATCHOP REGEX
{ $$ = oper3(OMATCHOP,$2,$1,oper1(OREGEX,$3)); }
| REGEX %prec MATCHOP
{ $$ = oper1(OREGEX,$1); }
| '(' match ')'
{ $$ = oper1(OMPAREN,$2); }
;
expr : term
{ $$ = $1; }
| expr term
{ $$ = oper2(OCONCAT,$1,$2); }
| expr '?' expr ':' expr
{ $$ = oper3(OCOND,$1,$3,$5); }
| variable ASGNOP cond
{
$$ = oper3(OASSIGN,$2,$1,$3);
if ((ops[$1].ival & 255) == OFLD)
lval_field = TRUE;
else if ((ops[$1].ival & 255) == OVFLD)
lval_field = TRUE;
}
;
sprintf : SPRINTF_NEW
| SPRINTF_OLD ;
term : variable
{ $$ = $1; }
| NUMBER
{ $$ = oper1(ONUM,$1); }
| STRING
{ $$ = oper1(OSTR,$1); }
| term '+' term
{ $$ = oper2(OADD,$1,$3); }
| term '-' term
{ $$ = oper2(OSUBTRACT,$1,$3); }
| term '*' term
{ $$ = oper2(OMULT,$1,$3); }
| term '/' term
{ $$ = oper2(ODIV,$1,$3); }
| term '%' term
{ $$ = oper2(OMOD,$1,$3); }
| term '^' term
{ $$ = oper2(OPOW,$1,$3); }
| term IN VAR
{ $$ = oper2(ODEFINED,aryrefarg($3),$1); }
| variable INCR
{
$$ = oper1(OPOSTINCR,$1);
if ((ops[$1].ival & 255) == OFLD)
lval_field = TRUE;
else if ((ops[$1].ival & 255) == OVFLD)
lval_field = TRUE;
}
| variable DECR
{
$$ = oper1(OPOSTDECR,$1);
if ((ops[$1].ival & 255) == OFLD)
lval_field = TRUE;
else if ((ops[$1].ival & 255) == OVFLD)
lval_field = TRUE;
}
| INCR variable
{
$$ = oper1(OPREINCR,$2);
if ((ops[$2].ival & 255) == OFLD)
lval_field = TRUE;
else if ((ops[$2].ival & 255) == OVFLD)
lval_field = TRUE;
}
| DECR variable
{
$$ = oper1(OPREDECR,$2);
if ((ops[$2].ival & 255) == OFLD)
lval_field = TRUE;
else if ((ops[$2].ival & 255) == OVFLD)
lval_field = TRUE;
}
| '-' term %prec UMINUS
{ $$ = oper1(OUMINUS,$2); }
| '+' term %prec UMINUS
{ $$ = oper1(OUPLUS,$2); }
| '(' cond ')'
{ $$ = oper1(OPAREN,$2); }
| GETLINE
{ $$ = oper0(OGETLINE); }
| GETLINE variable
{ $$ = oper1(OGETLINE,$2); }
| GETLINE '<' expr
{ $$ = oper3(OGETLINE,Nullop,string("<",1),$3);
if (ops[$3].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
| GETLINE variable '<' expr
{ $$ = oper3(OGETLINE,$2,string("<",1),$4);
if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
| term 'p' GETLINE
{ $$ = oper3(OGETLINE,Nullop,string("|",1),$1);
if (ops[$1].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
| term 'p' GETLINE variable
{ $$ = oper3(OGETLINE,$4,string("|",1),$1);
if (ops[$1].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
| FUN1
{ $$ = oper0($1); need_entire = do_chop = TRUE; }
| FUN1 '(' ')'
{ $$ = oper1($1,Nullop); need_entire = do_chop = TRUE; }
| FUN1 '(' expr ')'
{ $$ = oper1($1,$3); }
| FUNN '(' expr_list ')'
{ $$ = oper1($1,$3); }
| USERFUN '(' expr_list ')'
{ $$ = oper2(OUSERFUN,$1,$3); }
| SPRINTF_NEW '(' expr_list ')'
{ $$ = oper1(OSPRINTF,$3); }
| sprintf expr_list
{ $$ = oper1(OSPRINTF,$2); }
| SUBSTR '(' expr ',' expr ',' expr ')'
{ $$ = oper3(OSUBSTR,$3,$5,$7); }
| SUBSTR '(' expr ',' expr ')'
{ $$ = oper2(OSUBSTR,$3,$5); }
| SPLIT '(' expr ',' VAR ',' expr ')'
{ $$ = oper3(OSPLIT,$3,aryrefarg(numary($5)),$7); }
| SPLIT '(' expr ',' VAR ',' REGEX ')'
{ $$ = oper3(OSPLIT,$3,aryrefarg(numary($5)),oper1(OREGEX,$7));}
| SPLIT '(' expr ',' VAR ')'
{ $$ = oper2(OSPLIT,$3,aryrefarg(numary($5))); }
| INDEX '(' expr ',' expr ')'
{ $$ = oper2(OINDEX,$3,$5); }
| MATCH '(' expr ',' REGEX ')'
{ $$ = oper2(OMATCH,$3,oper1(OREGEX,$5)); }
| MATCH '(' expr ',' expr ')'
{ $$ = oper2(OMATCH,$3,$5); }
| SUB '(' expr ',' expr ')'
{ $$ = oper2(OSUB,$3,$5); }
| SUB '(' REGEX ',' expr ')'
{ $$ = oper2(OSUB,oper1(OREGEX,$3),$5); }
| GSUB '(' expr ',' expr ')'
{ $$ = oper2(OGSUB,$3,$5); }
| GSUB '(' REGEX ',' expr ')'
{ $$ = oper2(OGSUB,oper1(OREGEX,$3),$5); }
| SUB '(' expr ',' expr ',' expr ')'
{ $$ = oper3(OSUB,$3,$5,$7); }
| SUB '(' REGEX ',' expr ',' expr ')'
{ $$ = oper3(OSUB,oper1(OREGEX,$3),$5,$7); }
| GSUB '(' expr ',' expr ',' expr ')'
{ $$ = oper3(OGSUB,$3,$5,$7); }
| GSUB '(' REGEX ',' expr ',' expr ')'
{ $$ = oper3(OGSUB,oper1(OREGEX,$3),$5,$7); }
;
variable: VAR
{ $$ = oper1(OVAR,$1); }
| VAR '[' expr_list ']'
{ $$ = oper2(OVAR,aryrefarg($1),$3); }
| FIELD
{ $$ = oper1(OFLD,$1); }
| SVFIELD
{ $$ = oper1(OVFLD,oper1(OVAR,$1)); }
| VFIELD term
{ $$ = oper1(OVFLD,$2); }
;
expr_list
: expr
| clist
| /* NULL */
{ $$ = Nullop; }
;
clist : expr ',' maybe expr
{ $$ = oper3(OCOMMA,$1,$3,$4); }
| clist ',' maybe expr
{ $$ = oper3(OCOMMA,$1,$3,$4); }
| '(' clist ')' /* these parens are invisible */
{ $$ = $2; }
;
junk : junk hunksep
{ $$ = oper2(OJUNK,$1,$2); }
| /* NULL */
{ $$ = Nullop; }
;
hunksep : ';'
{ $$ = oper2(OJUNK,oper0(OSEMICOLON),oper0(ONEWLINE)); }
| SEMINEW
{ $$ = oper2(OJUNK,oper0(OSEMICOLON),oper0(ONEWLINE)); }
| NEWLINE
{ $$ = oper0(ONEWLINE); }
| COMMENT
{ $$ = oper1(OCOMMENT,$1); }
;
maybe : maybe nlstuff
{ $$ = oper2(OJUNK,$1,$2); }
| /* NULL */
{ $$ = Nullop; }
;
nlstuff : NEWLINE
{ $$ = oper0(ONEWLINE); }
| COMMENT
{ $$ = oper1(OCOMMENT,$1); }
;
separator
: ';' maybe
{ $$ = oper2(OJUNK,oper0(OSEMICOLON),$2); }
| SEMINEW maybe
{ $$ = oper2(OJUNK,oper0(OSNEWLINE),$2); }
| NEWLINE maybe
{ $$ = oper2(OJUNK,oper0(OSNEWLINE),$2); }
| COMMENT maybe
{ $$ = oper2(OJUNK,oper1(OSCOMMENT,$1),$2); }
;
states : states statement
{ $$ = oper2(OSTATES,$1,$2); }
| /* NULL */
{ $$ = Nullop; }
;
statement
: simple separator maybe
{ $$ = oper2(OJUNK,oper2(OSTATE,$1,$2),$3); }
| ';' maybe
{ $$ = oper2(OSTATE,Nullop,oper2(OJUNK,oper0(OSEMICOLON),$2)); }
| SEMINEW maybe
{ $$ = oper2(OSTATE,Nullop,oper2(OJUNK,oper0(OSNEWLINE),$2)); }
| compound
;
simpnull: simple
| /* NULL */
{ $$ = Nullop; }
;
simple
: expr
| PRINT expr_list redir expr
{ $$ = oper3(OPRINT,$2,$3,$4);
do_opens = TRUE;
saw_ORS = saw_OFS = TRUE;
if (!$2) need_entire = TRUE;
if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
| PRINT expr_list
{ $$ = oper1(OPRINT,$2);
if (!$2) need_entire = TRUE;
saw_ORS = saw_OFS = TRUE;
}
| PRINTF expr_list redir expr
{ $$ = oper3(OPRINTF,$2,$3,$4);
do_opens = TRUE;
if (!$2) need_entire = TRUE;
if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
| PRINTF expr_list
{ $$ = oper1(OPRINTF,$2);
if (!$2) need_entire = TRUE;
}
| BREAK
{ $$ = oper0(OBREAK); }
| NEXT
{ $$ = oper0(ONEXT); }
| EXIT
{ $$ = oper0(OEXIT); }
| EXIT expr
{ $$ = oper1(OEXIT,$2); }
| CONTINUE
{ $$ = oper0(OCONTINUE); }
| RET
{ $$ = oper0(ORETURN); }
| RET expr
{ $$ = oper1(ORETURN,$2); }
| DELETE VAR '[' expr_list ']'
{ $$ = oper2(ODELETE,aryrefarg($2),$4); }
;
redir : '>' %prec FIELD
{ $$ = oper1(OREDIR,string(">",1)); }
| GRGR
{ $$ = oper1(OREDIR,string(">>",2)); }
| '|'
{ $$ = oper1(OREDIR,string("|",1)); }
;
compound
: IF '(' cond ')' maybe statement
{ $$ = oper2(OIF,$3,bl($6,$5)); }
| IF '(' cond ')' maybe statement ELSE maybe statement
{ $$ = oper3(OIF,$3,bl($6,$5),bl($9,$8)); }
| WHILE '(' cond ')' maybe statement
{ $$ = oper2(OWHILE,$3,bl($6,$5)); }
| DO maybe statement WHILE '(' cond ')'
{ $$ = oper2(ODO,bl($3,$2),$6); }
| FOR '(' simpnull ';' cond ';' simpnull ')' maybe statement
{ $$ = oper4(OFOR,$3,$5,$7,bl($10,$9)); }
| FOR '(' simpnull ';' ';' simpnull ')' maybe statement
{ $$ = oper4(OFOR,$3,string("",0),$6,bl($9,$8)); }
| FOR '(' expr ')' maybe statement
{ $$ = oper2(OFORIN,$3,bl($6,$5)); }
| '{' maybe states '}' maybe
{ $$ = oper3(OBLOCK,oper2(OJUNK,$2,$3),Nullop,$5); }
;
%%
int yyparse (void);
#include "a2py.c"
--- NEW FILE: find2perl.PL ---
#!/usr/local/bin/perl
use Config;
use File::Basename qw(&basename &dirname);
use Cwd;
# List explicitly here the variables you want Configure to
# generate. Metaconfig only looks for shell variables, so you
# have to mention them as if they were shell variables, not
# %Config entries. Thus you write
# $startperl
# to ensure Configure will look for $Config{startperl}.
# This forces PL files to create target in same directory as PL file.
# This is so that make depend always knows where to find PL derivatives.
$origdir = cwd;
chdir dirname($0);
$file = basename($0, '.PL');
$file .= '.com' if $^O eq 'VMS';
open OUT,">$file" or die "Can't create $file: $!";
print "Extracting $file (with variable substitutions)\n";
# In this section, perl variables will be expanded during extraction.
# You can use $Config{...} to use Configure variables.
print OUT <<"!GROK!THIS!";
$Config{startperl}
eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
if \$running_under_some_shell;
(my \$perlpath = <<'/../') =~ s/\\s*\\z//;
$Config{perlpath}
/../
!GROK!THIS!
# In the following, perl variables are not expanded during extraction.
print OUT <<'!NO!SUBS!';
use strict;
use vars qw/$statdone/;
use File::Spec::Functions 'curdir';
my $startperl = "#! $perlpath -w";
#
# Modified September 26, 1993 to provide proper handling of years after 1999
# Tom Link <tml+ at pitt.edu>
# University of Pittsburgh
#
# Modified April 7, 1998 with nasty hacks to implement the troublesome -follow
# Billy Constantine <wdconsta at cs.adelaide.edu.au> <billy at smug.adelaide.edu.au>
# University of Adelaide, Adelaide, South Australia
#
# Modified 1999-06-10, 1999-07-07 to migrate to cleaner perl5 usage
# Ken Pizzini <ken at halcyon.com>
#
# Modified 2000-01-28 to use the 'follow' option of File::Find
sub tab ();
sub n ($$);
sub fileglob_to_re ($);
sub quote ($);
my @roots = ();
while ($ARGV[0] =~ /^[^-!(]/) {
push(@roots, shift);
}
@roots = (curdir()) unless @roots;
for (@roots) { $_ = quote($_) }
my $roots = join(', ', @roots);
my $find = "find";
my $indent_depth = 1;
my $stat = 'lstat';
my $decl = '';
my $flushall = '';
my $initfile = '';
my $initnewer = '';
my $out = '';
my $declaresubs = "sub wanted;\n";
my %init = ();
my ($follow_in_effect,$Skip_And) = (0,0);
my $print_needed = 1;
while (@ARGV) {
$_ = shift;
s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n";
if ($_ eq '(') {
$out .= tab . "(\n";
$indent_depth++;
next;
} elsif ($_ eq ')') {
--$indent_depth;
$out .= tab . ")";
} elsif ($_ eq 'follow') {
$follow_in_effect= 1;
$stat = 'stat';
$Skip_And= 1;
} elsif ($_ eq '!') {
$out .= tab . "!";
next;
} elsif (/^(i)?name$/) {
$out .= tab . '/' . fileglob_to_re(shift) . "/s$1";
} elsif (/^(i)?path$/) {
$out .= tab . '$File::Find::name =~ /' . fileglob_to_re(shift) . "/s$1";
} elsif ($_ eq 'perm') {
my $onum = shift;
$onum =~ /^-?[0-7]+$/
|| die "Malformed -perm argument: $onum\n";
$out .= tab;
if ($onum =~ s/^-//) {
$onum = sprintf("0%o", oct($onum) & 07777);
$out .= "((\$mode & $onum) == $onum)";
} else {
$onum =~ s/^0*/0/;
$out .= "((\$mode & 0777) == $onum)";
}
} elsif ($_ eq 'type') {
(my $filetest = shift) =~ tr/s/S/;
$out .= tab . "-$filetest _";
} elsif ($_ eq 'print') {
$out .= tab . 'print("$name\n")';
$print_needed = 0;
} elsif ($_ eq 'print0') {
$out .= tab . 'print("$name\0")';
$print_needed = 0;
} elsif ($_ eq 'fstype') {
my $type = shift;
$out .= tab;
if ($type eq 'nfs') {
$out .= '($dev < 0)';
} else {
$out .= '($dev >= 0)'; #XXX
}
} elsif ($_ eq 'user') {
my $uname = shift;
$out .= tab . "(\$uid == \$uid{'$uname'})";
$init{user} = 1;
} elsif ($_ eq 'group') {
my $gname = shift;
$out .= tab . "(\$gid == \$gid{'$gname'})";
$init{group} = 1;
} elsif ($_ eq 'nouser') {
$out .= tab . '!exists $uid{$uid}';
$init{user} = 1;
} elsif ($_ eq 'nogroup') {
$out .= tab . '!exists $gid{$gid}';
$init{group} = 1;
} elsif ($_ eq 'links') {
$out .= tab . n('$nlink', shift);
} elsif ($_ eq 'inum') {
$out .= tab . n('$ino', shift);
} elsif ($_ eq 'size') {
$_ = shift;
my $n = 'int(((-s _) + 511) / 512)';
if (s/c\z//) {
$n = 'int(-s _)';
} elsif (s/k\z//) {
$n = 'int(((-s _) + 1023) / 1024)';
}
$out .= tab . n($n, $_);
} elsif ($_ eq 'atime') {
$out .= tab . n('int(-A _)', shift);
} elsif ($_ eq 'mtime') {
$out .= tab . n('int(-M _)', shift);
} elsif ($_ eq 'ctime') {
$out .= tab . n('int(-C _)', shift);
} elsif ($_ eq 'exec') {
my @cmd = ();
while (@ARGV && $ARGV[0] ne ';')
{ push(@cmd, shift) }
shift;
$out .= tab;
if ($cmd[0] =~m#^(?:(?:/usr)?/bin/)?rm$#
&& $cmd[$#cmd] eq '{}'
&& (@cmd == 2 || (@cmd == 3 && $cmd[1] eq '-f'))) {
if (@cmd == 2) {
$out .= '(unlink($_) || warn "$name: $!\n")';
} elsif (!@ARGV) {
$out .= 'unlink($_)';
} else {
$out .= '(unlink($_) || 1)';
}
} else {
for (@cmd)
{ s/'/\\'/g }
{ local $" = "','"; $out .= "doexec(0, '@cmd')"; }
$declaresubs .= "sub doexec (\$\@);\n";
$init{doexec} = 1;
}
$print_needed = 0;
} elsif ($_ eq 'ok') {
my @cmd = ();
while (@ARGV && $ARGV[0] ne ';')
{ push(@cmd, shift) }
shift;
$out .= tab;
for (@cmd)
{ s/'/\\'/g }
{ local $" = "','"; $out .= "doexec(1, '@cmd')"; }
$declaresubs .= "sub doexec (\$\@);\n";
$init{doexec} = 1;
$print_needed = 0;
} elsif ($_ eq 'prune') {
$out .= tab . '($File::Find::prune = 1)';
} elsif ($_ eq 'xdev') {
$out .= tab . '!($File::Find::prune |= ($dev != $File::Find::topdev))'
;
} elsif ($_ eq 'newer') {
my $file = shift;
my $newername = 'AGE_OF' . $file;
$newername =~ s/\W/_/g;
$newername = '$' . $newername;
$out .= tab . "(-M _ < $newername)";
$initnewer .= "my $newername = -M " . quote($file) . ";\n";
} elsif ($_ eq 'eval') {
my $prog = shift;
$prog =~ s/'/\\'/g;
$out .= tab . "eval {$prog}";
$print_needed = 0;
} elsif ($_ eq 'depth') {
$find = 'finddepth';
next;
} elsif ($_ eq 'ls') {
$out .= tab . "ls";
$declaresubs .= "sub ls ();\n";
$init{ls} = 1;
$print_needed = 0;
} elsif ($_ eq 'tar') {
die "-tar must have a filename argument\n" unless @ARGV;
my $file = shift;
my $fh = 'FH' . $file;
$fh =~ s/\W/_/g;
$out .= tab . "tar(*$fh, \$name)";
$flushall .= "tflushall;\n";
$declaresubs .= "sub tar;\nsub tflushall ();\n";
$initfile .= "open($fh, " . quote('> ' . $file) .
qq{) || die "Can't open $fh: \$!\\n";\n};
$init{tar} = 1;
} elsif (/^(n?)cpio\z/) {
die "-$_ must have a filename argument\n" unless @ARGV;
my $file = shift;
my $fh = 'FH' . $file;
$fh =~ s/\W/_/g;
$out .= tab . "cpio(*$fh, \$name, '$1')";
$find = 'finddepth';
$flushall .= "cflushall;\n";
$declaresubs .= "sub cpio;\nsub cflushall ();\n";
$initfile .= "open($fh, " . quote('> ' . $file) .
qq{) || die "Can't open $fh: \$!\\n";\n};
$init{cpio} = 1;
} else {
die "Unrecognized switch: -$_\n";
}
if (@ARGV) {
if ($ARGV[0] eq '-o') {
{ local($statdone) = 1; $out .= "\n" . tab . "||\n"; }
$statdone = 0 if $indent_depth == 1 && exists $init{delayedstat};
$init{saw_or} = 1;
shift;
} else {
$out .= " &&" unless $Skip_And || $ARGV[0] eq ')';
$out .= "\n";
shift if $ARGV[0] eq '-a';
}
}
}
if ($print_needed) {
my $t = tab;
if ($t !~ /&&\s*$/) { $t .= '&& ' }
$out .= "\n" . $t . 'print("$name\n")';
}
print <<"END";
$startperl
eval 'exec $perlpath -S \$0 \${1+"\$@"}'
if 0; #\$running_under_some_shell
use strict;
use File::Find ();
# Set the variable \$File::Find::dont_use_nlink if you're using AFS,
# since AFS cheats.
# for the convenience of &wanted calls, including -eval statements:
use vars qw/*name *dir *prune/;
*name = *File::Find::name;
*dir = *File::Find::dir;
*prune = *File::Find::prune;
$declaresubs
END
if (exists $init{doexec}) {
print <<'END';
use Cwd ();
my $cwd = Cwd::cwd();
END
}
if (exists $init{ls}) {
print <<'END';
my @rwx = qw(--- --x -w- -wx r-- r-x rw- rwx);
my @moname = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
END
}
if (exists $init{user} || exists $init{ls} || exists $init{tar}) {
print "my (%uid, %user);\n";
print "while (my (\$name, \$pw, \$uid) = getpwent) {\n";
print ' $uid{$name} = $uid{$uid} = $uid;', "\n"
if exists $init{user};
print ' $user{$uid} = $name unless exists $user{$uid};', "\n"
if exists $init{ls} || exists $init{tar};
print "}\n\n";
}
if (exists $init{group} || exists $init{ls} || exists $init{tar}) {
print "my (%gid, %group);\n";
print "while (my (\$name, \$pw, \$gid) = getgrent) {\n";
print ' $gid{$name} = $gid{$gid} = $gid;', "\n"
if exists $init{group};
print ' $group{$gid} = $name unless exists $group{$gid};', "\n"
if exists $init{ls} || exists $init{tar};
print "}\n\n";
}
print $initnewer, "\n" if $initnewer ne '';
print $initfile, "\n" if $initfile ne '';
$flushall .= "exit;\n";
if (exists $init{declarestat}) {
$out = <<'END' . $out;
my ($dev,$ino,$mode,$nlink,$uid,$gid);
END
}
if ( $follow_in_effect ) {
$out =~ s/lstat\(\$_\)/lstat(_)/;
print <<"END";
$decl
# Traverse desired filesystems
File::Find::$find( {wanted => \\&wanted, follow => 1}, $roots);
$flushall
sub wanted {
$out;
}
END
} else {
print <<"END";
$decl
# Traverse desired filesystems
File::Find::$find({wanted => \\&wanted}, $roots);
$flushall
sub wanted {
$out;
}
END
}
if (exists $init{doexec}) {
print <<'END';
sub doexec ($@) {
my $ok = shift;
my @command = @_; # copy so we don't try to s/// aliases to constants
for my $word (@command)
{ $word =~ s#{}#$name#g }
if ($ok) {
my $old = select(STDOUT);
$| = 1;
print "@command";
select($old);
return 0 unless <STDIN> =~ /^y/;
}
chdir $cwd; #sigh
system @command;
chdir $File::Find::dir;
return !$?;
}
END
}
if (exists $init{ls}) {
print <<'INTRO', <<"SUB", <<'END';
sub sizemm {
my $rdev = shift;
sprintf("%3d, %3d", ($rdev >> 8) & 0xff, $rdev & 0xff);
}
sub ls () {
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
INTRO
\$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
SUB
my $pname = $name;
$blocks
or $blocks = int(($size + 1023) / 1024);
my $perms = $rwx[$mode & 7];
$mode >>= 3;
$perms = $rwx[$mode & 7] . $perms;
$mode >>= 3;
$perms = $rwx[$mode & 7] . $perms;
substr($perms, 2, 1) =~ tr/-x/Ss/ if -u _;
substr($perms, 5, 1) =~ tr/-x/Ss/ if -g _;
substr($perms, 8, 1) =~ tr/-x/Tt/ if -k _;
if (-f _) { $perms = '-' . $perms; }
elsif (-d _) { $perms = 'd' . $perms; }
elsif (-l _) { $perms = 'l' . $perms; $pname .= ' -> ' . readlink($_); }
elsif (-c _) { $perms = 'c' . $perms; $size = sizemm($rdev); }
elsif (-b _) { $perms = 'b' . $perms; $size = sizemm($rdev); }
elsif (-p _) { $perms = 'p' . $perms; }
elsif (-S _) { $perms = 's' . $perms; }
else { $perms = '?' . $perms; }
my $user = $user{$uid} || $uid;
my $group = $group{$gid} || $gid;
my ($sec,$min,$hour,$mday,$mon,$timeyear) = localtime($mtime);
if (-M _ > 365.25 / 2) {
$timeyear += 1900;
} else {
$timeyear = sprintf("%02d:%02d", $hour, $min);
}
printf "%5lu %4ld %-10s %3d %-8s %-8s %8s %s %2d %5s %s\n",
$ino,
$blocks,
$perms,
$nlink,
$user,
$group,
$size,
$moname[$mon],
$mday,
$timeyear,
$pname;
1;
}
END
}
if (exists $init{cpio} || exists $init{tar}) {
print <<'END';
my %blocks = ();
sub flush {
my ($fh, $varref, $blksz) = @_;
while (length($$varref) >= $blksz) {
no strict qw/refs/;
syswrite($fh, $$varref, $blksz);
substr($$varref, 0, $blksz) = '';
++$blocks{$fh};
}
}
END
}
if (exists $init{cpio}) {
print <<'INTRO', <<"SUB", <<'END';
my %cpout = ();
my %nc = ();
sub cpio {
my ($fh, $fname, $nc) = @_;
my $text = '';
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
$atime,$mtime,$ctime,$blksize,$blocks);
local (*IN);
if ( ! defined $fname ) {
$fname = 'TRAILER!!!';
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
$atime,$mtime,$ctime,$blksize,$blocks) = (0) x 13;
} else {
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
INTRO
\$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
SUB
if (-f _) {
open(IN, "./$_\0") || do {
warn "Couldn't open $fname: $!\n";
return;
}
} else {
$text = readlink($_);
$size = 0 unless defined $text;
}
}
$fname =~ s#^\./##;
$nc{$fh} = $nc;
if ($nc eq 'n') {
$cpout{$fh} .=
sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
070707,
$dev & 0777777,
$ino & 0777777,
$mode & 0777777,
$uid & 0777777,
$gid & 0777777,
$nlink & 0777777,
$rdev & 0177777,
$mtime,
length($fname)+1,
$size,
$fname);
} else {
$cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
$cpout{$fh} .= pack("SSSSSSSSLSLa*",
070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
length($fname)+1, $size,
$fname . (length($fname) & 1 ? "\0" : "\0\0"));
}
if ($text ne '') {
$cpout{$fh} .= $text;
} elsif ($size) {
my $l;
flush($fh, \$cpout{$fh}, 5120)
while ($l = length($cpout{$fh})) >= 5120;
while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
flush($fh, \$cpout{$fh}, 5120);
$l = length($cpout{$fh});
}
close IN;
}
}
sub cflushall () {
for my $fh (keys %cpout) {
cpio($fh, undef, $nc{$fh});
$cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
flush($fh, \$cpout{$fh}, 5120);
print $blocks{$fh} * 10, " blocks\n";
}
}
END
}
if (exists $init{tar}) {
print <<'INTRO', <<"SUB", <<'END';
my %tarout = ();
my %linkseen = ();
sub tar {
my ($fh, $fname) = @_;
my $prefix = '';
my $typeflag = '0';
my $linkname;
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
INTRO
\$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
SUB
local (*IN);
if ($nlink > 1) {
if ($linkname = $linkseen{$fh, $dev, $ino}) {
if (length($linkname) > 100) {
warn "$0: omitting file with linkname ",
"too long for tar output: $linkname\n";
return;
}
$typeflag = '1';
$size = 0;
} else {
$linkseen{$fh, $dev, $ino} = $fname;
}
}
if ($typeflag eq '0') {
if (-f _) {
open(IN, "./$_\0") || do {
warn "Couldn't open $fname: $!\n";
return;
}
} else {
$linkname = readlink($_);
if (defined $linkname) { $typeflag = '2' }
elsif (-c _) { $typeflag = '3' }
elsif (-b _) { $typeflag = '4' }
elsif (-d _) { $typeflag = '5' }
elsif (-p _) { $typeflag = '6' }
}
}
if (length($fname) > 100) {
($prefix, $fname) = ($fname =~ m#\A(.*?)/(.{,100})\Z(?!\n)#);
if (!defined($fname) || length($prefix) > 155) {
warn "$0: omitting file with name too long for tar output: ",
$fname, "\n";
return;
}
}
$size = 0 if $typeflag ne '0';
my $header = pack("a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155",
$fname,
sprintf("%7o ", $mode & 0777),
sprintf("%7o ", $uid & 0777777),
sprintf("%7o ", $gid & 0777777),
sprintf("%11o ", $size),
sprintf("%11o ", $mtime),
' 'x8,
$typeflag,
defined $linkname ? $linkname : '',
"ustar\0",
"00",
$user{$uid},
$group{$gid},
($rdev >> 8) & 0xff,
$rdev & 0xff,
$prefix,
);
substr($header, 148, 8) = sprintf("%7o ", unpack("%16C*", $header));
my $l = length($header) % 512;
$tarout{$fh} .= $header;
$tarout{$fh} .= "\0" x (512 - $l) if $l;
if ($size) {
flush($fh, \$tarout{$fh}, 10240)
while ($l = length($tarout{$fh})) >= 10240;
while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
my $slop = length($tarout{$fh}) % 512;
$tarout{$fh} .= "\0" x (512 - $slop) if $slop;
flush($fh, \$tarout{$fh}, 10240);
$l = length($tarout{$fh});
}
close IN;
}
}
sub tflushall () {
my $len;
for my $fh (keys %tarout) {
$len = 10240 - length($tarout{$fh});
$len += 10240 if $len < 1024;
$tarout{$fh} .= "\0" x $len;
flush($fh, \$tarout{$fh}, 10240);
}
}
END
}
exit;
############################################################################
sub tab () {
my $tabstring;
$tabstring = "\t" x ($indent_depth/2) . ' ' x ($indent_depth%2 * 4);
if (!$statdone) {
if ($_ =~ /^(?:name|print|prune|exec|ok|\(|\))/) {
$init{delayedstat} = 1;
} else {
my $statcall = '(($dev,$ino,$mode,$nlink,$uid,$gid) = '
. $stat . '($_))';
if (exists $init{saw_or}) {
$tabstring .= "(\$nlink || $statcall) &&\n" . $tabstring;
} else {
$tabstring .= "$statcall &&\n" . $tabstring;
}
$statdone = 1;
$init{declarestat} = 1;
}
}
$tabstring =~ s/^\s+/ / if $out =~ /!$/;
$tabstring;
}
sub fileglob_to_re ($) {
my $x = shift;
$x =~ s#([./^\$()+])#\\$1#g;
$x =~ s#([?*])#.$1#g;
"^$x\\z";
}
sub n ($$) {
my ($pre, $n) = @_;
$n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
$n =~ s/ 0*(\d)/ $1/;
"($pre $n)";
}
sub quote ($) {
my $string = shift;
$string =~ s/\\/\\\\/g;
$string =~ s/'/\\'/g;
"'$string'";
}
__END__
=head1 NAME
find2perl - translate find command lines to Perl code
=head1 SYNOPSIS
find2perl [paths] [predicates] | perl
=head1 DESCRIPTION
find2perl is a little translator to convert find command lines to
equivalent Perl code. The resulting code is typically faster than
running find itself.
"paths" are a set of paths where find2perl will start its searches and
"predicates" are taken from the following list.
=over 4
=item C<! PREDICATE>
Negate the sense of the following predicate. The C<!> must be passed as
a distinct argument, so it may need to be surrounded by whitespace and/or
quoted from interpretation by the shell using a backslash (just as with
using C<find(1)>).
=item C<( PREDICATES )>
Group the given PREDICATES. The parentheses must be passed as distinct
arguments, so they may need to be surrounded by whitespace and/or
quoted from interpretation by the shell using a backslash (just as with
using C<find(1)>).
=item C<PREDICATE1 PREDICATE2>
True if _both_ PREDICATE1 and PREDICATE2 are true; PREDICATE2 is not
evaluated if PREDICATE1 is false.
=item C<PREDICATE1 -o PREDICATE2>
True if either one of PREDICATE1 or PREDICATE2 is true; PREDICATE2 is
not evaluated if PREDICATE1 is true.
=item C<-follow>
Follow (dereference) symlinks. The checking of file attributes depends
on the position of the C<-follow> option. If it precedes the file
check option, an C<stat> is done which means the file check applies to the
file the symbolic link is pointing to. If C<-follow> option follows the
file check option, this now applies to the symbolic link itself, i.e.
an C<lstat> is done.
=item C<-depth>
Change directory traversal algorithm from breadth-first to depth-first.
=item C<-prune>
Do not descend into the directory currently matched.
=item C<-xdev>
Do not traverse mount points (prunes search at mount-point directories).
=item C<-name GLOB>
File name matches specified GLOB wildcard pattern. GLOB may need to be
quoted to avoid interpretation by the shell (just as with using
C<find(1)>).
=item C<-iname GLOB>
Like C<-name>, but the match is case insensitive.
=item C<-path GLOB>
Path name matches specified GLOB wildcard pattern.
=item C<-ipath GLOB>
Like C<-path>, but the match is case insensitive.
=item C<-perm PERM>
Low-order 9 bits of permission match octal value PERM.
=item C<-perm -PERM>
The bits specified in PERM are all set in file's permissions.
=item C<-type X>
The file's type matches perl's C<-X> operator.
=item C<-fstype TYPE>
Filesystem of current path is of type TYPE (only NFS/non-NFS distinction
is implemented).
=item C<-user USER>
True if USER is owner of file.
=item C<-group GROUP>
True if file's group is GROUP.
=item C<-nouser>
True if file's owner is not in password database.
=item C<-nogroup>
True if file's group is not in group database.
=item C<-inum INUM>
True file's inode number is INUM.
=item C<-links N>
True if (hard) link count of file matches N (see below).
=item C<-size N>
True if file's size matches N (see below) N is normally counted in
512-byte blocks, but a suffix of "c" specifies that size should be
counted in characters (bytes) and a suffix of "k" specifes that
size should be counted in 1024-byte blocks.
=item C<-atime N>
True if last-access time of file matches N (measured in days) (see
below).
=item C<-ctime N>
True if last-changed time of file's inode matches N (measured in days,
see below).
=item C<-mtime N>
True if last-modified time of file matches N (measured in days, see below).
=item C<-newer FILE>
True if last-modified time of file matches N.
=item C<-print>
Print out path of file (always true). If none of C<-exec>, C<-ls>,
C<-print0>, or C<-ok> is specified, then C<-print> will be added
implicitly.
=item C<-print0>
Like -print, but terminates with \0 instead of \n.
=item C<-exec OPTIONS ;>
exec() the arguments in OPTIONS in a subprocess; any occurrence of {} in
OPTIONS will first be substituted with the path of the current
file. Note that the command "rm" has been special-cased to use perl's
unlink() function instead (as an optimization). The C<;> must be passed as
a distinct argument, so it may need to be surrounded by whitespace and/or
quoted from interpretation by the shell using a backslash (just as with
using C<find(1)>).
=item C<-ok OPTIONS ;>
Like -exec, but first prompts user; if user's response does not begin
with a y, skip the exec. The C<;> must be passed as
a distinct argument, so it may need to be surrounded by whitespace and/or
quoted from interpretation by the shell using a backslash (just as with
using C<find(1)>).
=item C<-eval EXPR>
Has the perl script eval() the EXPR.
=item C<-ls>
Simulates C<-exec ls -dils {} ;>
=item C<-tar FILE>
Adds current output to tar-format FILE.
=item C<-cpio FILE>
Adds current output to old-style cpio-format FILE.
=item C<-ncpio FILE>
Adds current output to "new"-style cpio-format FILE.
=back
Predicates which take a numeric argument N can come in three forms:
* N is prefixed with a +: match values greater than N
* N is prefixed with a -: match values less than N
* N is not prefixed with either + or -: match only values equal to N
=head1 SEE ALSO
find
=cut
!NO!SUBS!
close OUT or die "Can't close $file: $!";
chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
chdir $origdir;
--- NEW FILE: hash.c ---
/* hash.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2000, 2001, 2002,
* 2005 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*/
#include <stdio.h>
#include "EXTERN.h"
#include "a2p.h"
#include "util.h"
#ifdef NETWARE
char *savestr(char *str);
#endif
STR *
hfetch(register HASH *tb, char *key)
{
register char *s;
register int i;
register int hash;
register HENT *entry;
if (!tb)
return Nullstr;
for (s=key, i=0, hash = 0;
/* while */ *s;
s++, i++, hash *= 5) {
hash += *s * coeff[i];
}
entry = tb->tbl_array[hash & tb->tbl_max];
for (; entry; entry = entry->hent_next) {
if (entry->hent_hash != hash) /* strings can't be equal */
continue;
if (strNE(entry->hent_key,key)) /* is this it? */
continue;
return entry->hent_val;
}
return Nullstr;
}
bool
hstore(register HASH *tb, char *key, STR *val)
{
register char *s;
register int i;
register int hash;
register HENT *entry;
register HENT **oentry;
if (!tb)
return FALSE;
for (s=key, i=0, hash = 0;
/* while */ *s;
s++, i++, hash *= 5) {
hash += *s * coeff[i];
}
oentry = &(tb->tbl_array[hash & tb->tbl_max]);
i = 1;
for (entry = *oentry; entry; i=0, entry = entry->hent_next) {
if (entry->hent_hash != hash) /* strings can't be equal */
continue;
if (strNE(entry->hent_key,key)) /* is this it? */
continue;
/*NOSTRICT*/
safefree(entry->hent_val);
entry->hent_val = val;
return TRUE;
}
/*NOSTRICT*/
entry = (HENT*) safemalloc(sizeof(HENT));
entry->hent_key = savestr(key);
entry->hent_val = val;
entry->hent_hash = hash;
entry->hent_next = *oentry;
*oentry = entry;
if (i) { /* initial entry? */
tb->tbl_fill++;
if ((tb->tbl_fill * 100 / (tb->tbl_max + 1)) > FILLPCT)
hsplit(tb);
}
return FALSE;
}
void
hsplit(HASH *tb)
{
const int oldsize = tb->tbl_max + 1;
register int newsize = oldsize * 2;
register int i;
register HENT **a;
register HENT **b;
register HENT *entry;
register HENT **oentry;
a = (HENT**) saferealloc((char*)tb->tbl_array, newsize * sizeof(HENT*));
memset(&a[oldsize], 0, oldsize * sizeof(HENT*)); /* zero second half */
tb->tbl_max = --newsize;
tb->tbl_array = a;
for (i=0; i<oldsize; i++,a++) {
if (!*a) /* non-existent */
continue;
b = a+oldsize;
for (oentry = a, entry = *a; entry; entry = *oentry) {
if ((entry->hent_hash & newsize) != i) {
*oentry = entry->hent_next;
entry->hent_next = *b;
if (!*b)
tb->tbl_fill++;
*b = entry;
continue;
}
else
oentry = &entry->hent_next;
}
if (!*a) /* everything moved */
tb->tbl_fill--;
}
}
HASH *
hnew(void)
{
register HASH *tb = (HASH*)safemalloc(sizeof(HASH));
tb->tbl_array = (HENT**) safemalloc(8 * sizeof(HENT*));
tb->tbl_fill = 0;
tb->tbl_max = 7;
hiterinit(tb); /* so each() will start off right */
memset(tb->tbl_array, 0, 8 * sizeof(HENT*));
return tb;
}
int
hiterinit(register HASH *tb)
{
tb->tbl_riter = -1;
tb->tbl_eiter = Null(HENT*);
return tb->tbl_fill;
}
--- NEW FILE: a2p.h ---
/* a2p.h
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
* 2000, 2001, 2002, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*/
#define VOIDUSED 1
#ifdef WIN32
#define _INC_WIN32_PERL5 /* kludge around win32 stdio layer */
#endif
#ifdef VMS
# include "config.h"
#elif defined(NETWARE)
# include "../NetWare/config.h"
#else
# include "../config.h"
#endif
#if defined(__STDC__) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus)
# define STANDARD_C 1
#endif
#ifdef WIN32
#undef USE_STDIO_PTR /* XXX fast gets won't work, must investigate */
# ifndef STANDARD_C
# define STANDARD_C
# endif
# if defined(__BORLANDC__)
# pragma warn -ccc
# pragma warn -rch
# pragma warn -sig
# pragma warn -pia
# pragma warn -par
# pragma warn -aus
# pragma warn -use
# pragma warn -csu
# pragma warn -pro
# elif defined(_MSC_VER)
# elif defined(__MINGW32__)
# endif
#endif
/* Use all the "standard" definitions? */
#if defined(STANDARD_C) && defined(I_STDLIB)
# include <stdlib.h>
#endif /* STANDARD_C */
#include <stdio.h>
#ifdef I_MATH
#include <math.h>
#endif
#ifdef I_SYS_TYPES
# include <sys/types.h>
#endif
#ifdef USE_NEXT_CTYPE
#if NX_CURRENT_COMPILER_RELEASE >= 400
#include <objc/NXCType.h>
#else /* NX_CURRENT_COMPILER_RELEASE < 400 */
#include <appkit/NXCType.h>
#endif /* NX_CURRENT_COMPILER_RELEASE >= 400 */
#else /* !USE_NEXT_CTYPE */
#include <ctype.h>
#endif /* USE_NEXT_CTYPE */
#define MEM_SIZE Size_t
#ifndef STANDARD_C
Malloc_t malloc (MEM_SIZE nbytes);
Malloc_t calloc (MEM_SIZE elements, MEM_SIZE size);
Malloc_t realloc (Malloc_t where, MEM_SIZE nbytes);
Free_t free (Malloc_t where);
#endif
#if defined(I_STRING) || defined(__cplusplus)
# include <string.h>
#else
# include <strings.h>
#endif
#if !defined(HAS_STRCHR) && defined(HAS_INDEX) && !defined(strchr)
#define strchr index
#define strrchr rindex
#endif
#ifdef I_TIME
# include <time.h>
#endif
#ifdef I_SYS_TIME
# ifdef I_SYS_TIME_KERNEL
# define KERNEL
# endif
# include <sys/time.h>
# ifdef I_SYS_TIME_KERNEL
# undef KERNEL
# endif
#endif
#ifndef MSDOS
# if defined(HAS_TIMES) && defined(I_SYS_TIMES)
# include <sys/times.h>
# endif
#endif
#ifdef DOSISH
# if defined(OS2)
# define PTHX_UNUSED
# include "../os2ish.h"
# else
# include "../dosish.h"
# endif
#else
# if defined(VMS)
# define NO_PERL_TYPEDEFS
# include "vmsish.h"
# endif
#endif
#ifndef STANDARD_C
/* All of these are in stdlib.h or time.h for ANSI C */
Time_t time();
struct tm *gmtime(), *localtime();
#if defined(OEMVS) || defined(__OPEN_VM)
char *(strchr)(), *(strrchr)();
char *(strcpy)(), *(strcat)();
#else
char *strchr(), *strrchr();
char *strcpy(), *strcat();
#endif
#endif /* ! STANDARD_C */
#ifdef VMS
# include "handy.h"
#else
# include "../handy.h"
#endif
#undef Nullfp
#define Nullfp Null(FILE*)
#define Nullop 0
#define OPROG 1
#define OJUNK 2
#define OHUNKS 3
#define ORANGE 4
#define OPAT 5
#define OHUNK 6
#define OPPAREN 7
#define OPANDAND 8
#define OPOROR 9
#define OPNOT 10
#define OCPAREN 11
#define OCANDAND 12
#define OCOROR 13
#define OCNOT 14
#define ORELOP 15
#define ORPAREN 16
#define OMATCHOP 17
#define OMPAREN 18
#define OCONCAT 19
#define OASSIGN 20
#define OADD 21
#define OSUBTRACT 22
#define OMULT 23
#define ODIV 24
#define OMOD 25
#define OPOSTINCR 26
#define OPOSTDECR 27
#define OPREINCR 28
#define OPREDECR 29
#define OUMINUS 30
#define OUPLUS 31
#define OPAREN 32
#define OGETLINE 33
#define OSPRINTF 34
#define OSUBSTR 35
#define OSTRING 36
#define OSPLIT 37
#define OSNEWLINE 38
#define OINDEX 39
#define ONUM 40
#define OSTR 41
#define OVAR 42
#define OFLD 43
#define ONEWLINE 44
#define OCOMMENT 45
#define OCOMMA 46
#define OSEMICOLON 47
#define OSCOMMENT 48
#define OSTATES 49
#define OSTATE 50
#define OPRINT 51
#define OPRINTF 52
#define OBREAK 53
#define ONEXT 54
#define OEXIT 55
#define OCONTINUE 56
#define OREDIR 57
#define OIF 58
#define OWHILE 59
#define OFOR 60
#define OFORIN 61
#define OVFLD 62
#define OBLOCK 63
#define OREGEX 64
#define OLENGTH 65
#define OLOG 66
#define OEXP 67
#define OSQRT 68
#define OINT 69
#define ODO 70
#define OPOW 71
#define OSUB 72
#define OGSUB 73
#define OMATCH 74
#define OUSERFUN 75
#define OUSERDEF 76
#define OCLOSE 77
#define OATAN2 78
#define OSIN 79
#define OCOS 80
#define ORAND 81
#define OSRAND 82
#define ODELETE 83
#define OSYSTEM 84
#define OCOND 85
#define ORETURN 86
#define ODEFINED 87
#define OSTAR 88
#ifdef DOINIT
char *opname[] = {
"0",
"PROG",
"JUNK",
"HUNKS",
"RANGE",
"PAT",
"HUNK",
"PPAREN",
"PANDAND",
"POROR",
"PNOT",
"CPAREN",
"CANDAND",
"COROR",
"CNOT",
"RELOP",
"RPAREN",
"MATCHOP",
"MPAREN",
"CONCAT",
"ASSIGN",
"ADD",
"SUBTRACT",
"MULT",
"DIV",
"MOD",
"POSTINCR",
"POSTDECR",
"PREINCR",
"PREDECR",
"UMINUS",
"UPLUS",
"PAREN",
"GETLINE",
"SPRINTF",
"SUBSTR",
"STRING",
"SPLIT",
"SNEWLINE",
"INDEX",
"NUM",
"STR",
"VAR",
"FLD",
"NEWLINE",
"COMMENT",
"COMMA",
"SEMICOLON",
"SCOMMENT",
"STATES",
"STATE",
"PRINT",
"PRINTF",
"BREAK",
"NEXT",
"EXIT",
"CONTINUE",
"REDIR",
"IF",
"WHILE",
"FOR",
"FORIN",
"VFLD",
"BLOCK",
"REGEX",
"LENGTH",
"LOG",
"EXP",
"SQRT",
"INT",
"DO",
"POW",
"SUB",
"GSUB",
"MATCH",
"USERFUN",
"USERDEF",
"CLOSE",
"ATAN2",
"SIN",
"COS",
"RAND",
"SRAND",
"DELETE",
"SYSTEM",
"COND",
"RETURN",
"DEFINED",
"STAR",
"89"
};
#else
extern char *opname[];
#endif
EXT int mop INIT(1);
union u_ops {
int ival;
char *cval;
};
#if defined(iAPX286) || defined(M_I286) || defined(I80286) /* 80286 hack */
#define OPSMAX (64000/sizeof(union u_ops)) /* approx. max segment size */
#else
#define OPSMAX 50000
#endif /* 80286 hack */
EXT union u_ops ops[OPSMAX];
typedef struct string STR;
typedef struct htbl HASH;
#include "str.h"
#include "hash.h"
/* A string is TRUE if not "" or "0". */
#define True(val) (tmps = (val), (*tmps && !(*tmps == '0' && !tmps[1])))
EXT char *Yes INIT("1");
EXT char *No INIT("");
#define str_get(str) (Str = (str), (Str->str_pok ? Str->str_ptr : str_2ptr(Str)))
EXT STR *Str;
#define GROWSTR(pp,lp,len) if (*(lp) < (len)) growstr(pp,lp,len)
/* Prototypes for things in a2p.c */
int aryrefarg ( int arg );
int bl ( int arg, int maybe );
void dump ( int branch );
int fixfargs ( int name, int arg, int prevargs );
int fixrargs ( char *name, int arg, int prevargs );
void fixup ( STR *str );
int numary ( int arg );
int oper0 ( int type );
int oper1 ( int type, int arg1 );
int oper2 ( int type, int arg1, int arg2 );
int oper3 ( int type, int arg1, int arg2, int arg3 );
int oper4 ( int type, int arg1, int arg2, int arg3, int arg4 );
int oper5 ( int type, int arg1, int arg2, int arg3, int arg4, int arg5 );
void putlines ( STR *str );
void putone ( void );
int rememberargs ( int arg );
char * scannum ( char *s );
char * scanpat ( char *s );
int string ( char *ptr, int len );
void yyerror ( char *s );
int yylex ( void );
EXT int line INIT(0);
EXT FILE *rsfp;
EXT char buf[2048];
EXT char *bufptr INIT(buf);
EXT STR *linestr INIT(Nullstr);
EXT char tokenbuf[2048];
EXT int expectterm INIT(TRUE);
#ifdef DEBUGGING
EXT int debug INIT(0);
EXT int dlevel INIT(0);
#define YYDEBUG 1
extern int yydebug;
#else
# ifndef YYDEBUG
# define YYDEBUG 0
# endif
#endif
EXT STR *freestrroot INIT(Nullstr);
EXT STR str_no;
EXT STR str_yes;
EXT bool do_split INIT(FALSE);
EXT bool split_to_array INIT(FALSE);
EXT bool set_array_base INIT(FALSE);
EXT bool saw_RS INIT(FALSE);
EXT bool saw_OFS INIT(FALSE);
EXT bool saw_ORS INIT(FALSE);
EXT bool saw_line_op INIT(FALSE);
EXT bool in_begin INIT(TRUE);
EXT bool do_opens INIT(FALSE);
EXT bool do_fancy_opens INIT(FALSE);
EXT bool lval_field INIT(FALSE);
EXT bool do_chop INIT(FALSE);
EXT bool need_entire INIT(FALSE);
EXT bool absmaxfld INIT(FALSE);
EXT bool saw_altinput INIT(FALSE);
EXT bool nomemok INIT(FALSE);
EXT char const_FS INIT(0);
EXT char *namelist INIT(Nullch);
EXT char fswitch INIT(0);
EXT bool old_awk INIT(0);
EXT int saw_FS INIT(0);
EXT int maxfld INIT(0);
EXT int arymax INIT(0);
EXT char *nameary[100];
EXT STR *opens;
EXT HASH *symtab;
EXT HASH *curarghash;
#define P_MIN 0
#define P_LISTOP 5
#define P_COMMA 10
#define P_ASSIGN 15
#define P_COND 20
#define P_DOTDOT 25
#define P_OROR 30
#define P_ANDAND 35
#define P_OR 40
#define P_AND 45
#define P_EQ 50
#define P_REL 55
#define P_UNI 60
#define P_FILETEST 65
#define P_SHIFT 70
#define P_ADD 75
#define P_MUL 80
#define P_MATCH 85
#define P_UNARY 90
#define P_POW 95
#define P_AUTO 100
#define P_MAX 999
EXT int an;
--- NEW FILE: util.c ---
/* util.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1999,
* 2000, 2001, 2005 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*/
#include "EXTERN.h"
#include "a2p.h"
#include "INTERN.h"
#include "util.h"
#include <stdarg.h>
#define FLUSH
static const char nomem[] = "Out of memory!\n";
/* paranoid version of malloc */
Malloc_t
safemalloc(MEM_SIZE size)
{
Malloc_t ptr;
/* malloc(0) is NASTY on some systems */
ptr = malloc(size ? size : 1);
#ifdef DEBUGGING
if (debug & 128)
fprintf(stderr,"0x%lx: (%05d) malloc %ld bytes\n",(unsigned long)ptr,
an++,(long)size);
#endif
if (ptr != Nullch)
return ptr;
else {
fputs(nomem,stdout) FLUSH;
exit(1);
}
/*NOTREACHED*/
return 0;
}
/* paranoid version of realloc */
Malloc_t
saferealloc(Malloc_t where, MEM_SIZE size)
{
Malloc_t ptr;
/* realloc(0) is NASTY on some systems */
ptr = realloc(where, size ? size : 1);
#ifdef DEBUGGING
if (debug & 128) {
fprintf(stderr,"0x%lx: (%05d) rfree\n",(unsigned long)where,an++);
fprintf(stderr,"0x%lx: (%05d) realloc %ld bytes\n",(unsigned long)ptr,an++,(long)size);
}
#endif
if (ptr != Nullch)
return ptr;
else {
fputs(nomem,stdout) FLUSH;
exit(1);
}
/*NOTREACHED*/
return 0;
}
/* safe version of free */
Free_t
safefree(Malloc_t where)
{
#ifdef DEBUGGING
if (debug & 128)
fprintf(stderr,"0x%lx: (%05d) free\n",(unsigned long)where,an++);
#endif
free(where);
}
/* copy a string up to some (non-backslashed) delimiter, if any */
char *
cpytill(register char *to, register char *from, register int delim)
{
for (; *from; from++,to++) {
if (*from == '\\') {
if (from[1] == delim)
from++;
else if (from[1] == '\\')
*to++ = *from++;
}
else if (*from == delim)
break;
*to = *from;
}
*to = '\0';
return from;
}
char *
cpy2(register char *to, register char *from, register int delim)
{
for (; *from; from++,to++) {
if (*from == '\\')
*to++ = *from++;
else if (*from == '$')
*to++ = '\\';
else if (*from == delim)
break;
*to = *from;
}
*to = '\0';
return from;
}
/* return ptr to little string in big string, NULL if not found */
char *
instr(char *big, char *little)
{
register char *t, *s, *x;
for (t = big; *t; t++) {
for (x=t,s=little; *s; x++,s++) {
if (!*x)
return Nullch;
if (*s != *x)
break;
}
if (!*s)
return t;
}
return Nullch;
}
/* copy a string to a safe spot */
char *
savestr(char *str)
{
register char * const newaddr = (char *) safemalloc((MEM_SIZE)(strlen(str)+1));
(void)strcpy(newaddr,str);
return newaddr;
}
/* grow a static string to at least a certain length */
void
growstr(char **strptr, int *curlen, int newlen)
{
if (newlen > *curlen) { /* need more room? */
if (*curlen)
*strptr = (char *) saferealloc(*strptr,(MEM_SIZE)newlen);
else
*strptr = (char *) safemalloc((MEM_SIZE)newlen);
*curlen = newlen;
}
}
void
fatal(const char *pat,...)
{
#if defined(HAS_VPRINTF)
va_list args;
va_start(args, pat);
vfprintf(stderr,pat,args);
va_end(args);
#else
fprintf(stderr,pat,a1,a2,a3,a4);
#endif
exit(1);
}
#if defined(DARWIN)
__private_extern__ /* warn() conflicts with libc */
#endif
void
warn(const char *pat,...)
{
#if defined(HAS_VPRINTF)
va_list args;
va_start(args, pat);
vfprintf(stderr,pat,args);
va_end(args);
#else
fprintf(stderr,pat,a1,a2,a3,a4);
#endif
}
--- NEW FILE: str.c ---
/* str.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1999,
* 2001, 2002, 2005 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*/
#include "EXTERN.h"
#include "a2p.h"
#include "util.h"
void
str_numset(register STR *str, double num)
{
str->str_nval = num;
str->str_pok = 0; /* invalidate pointer */
str->str_nok = 1; /* validate number */
}
char *
str_2ptr(register STR *str)
{
register char *s;
if (!str)
return "";
GROWSTR(&(str->str_ptr), &(str->str_len), 24);
s = str->str_ptr;
if (str->str_nok) {
sprintf(s,"%.20g",str->str_nval);
while (*s) s++;
}
*s = '\0';
str->str_cur = s - str->str_ptr;
str->str_pok = 1;
#ifdef DEBUGGING
if (debug & 32)
fprintf(stderr,"0x%lx ptr(%s)\n",(unsigned long)str,str->str_ptr);
#endif
return str->str_ptr;
}
void
str_sset(STR *dstr, register STR *sstr)
{
if (!sstr)
str_nset(dstr,No,0);
else if (sstr->str_nok)
str_numset(dstr,sstr->str_nval);
else if (sstr->str_pok)
str_nset(dstr,sstr->str_ptr,sstr->str_cur);
else
str_nset(dstr,"",0);
}
void
str_nset(register STR *str, register char *ptr, register int len)
{
GROWSTR(&(str->str_ptr), &(str->str_len), len + 1);
memcpy(str->str_ptr,ptr,len);
str->str_cur = len;
*(str->str_ptr+str->str_cur) = '\0';
str->str_nok = 0; /* invalidate number */
str->str_pok = 1; /* validate pointer */
}
void
str_set(register STR *str, register char *ptr)
{
register int len;
if (!ptr)
ptr = "";
len = strlen(ptr);
GROWSTR(&(str->str_ptr), &(str->str_len), len + 1);
memcpy(str->str_ptr,ptr,len+1);
str->str_cur = len;
str->str_nok = 0; /* invalidate number */
str->str_pok = 1; /* validate pointer */
}
void
str_ncat(register STR *str, register char *ptr, register int len)
{
if (!(str->str_pok))
str_2ptr(str);
GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1);
memcpy(str->str_ptr+str->str_cur, ptr, len);
str->str_cur += len;
*(str->str_ptr+str->str_cur) = '\0';
str->str_nok = 0; /* invalidate number */
str->str_pok = 1; /* validate pointer */
}
void
str_scat(STR *dstr, register STR *sstr)
{
if (!(sstr->str_pok))
str_2ptr(sstr);
if (sstr)
str_ncat(dstr,sstr->str_ptr,sstr->str_cur);
}
void
str_cat(register STR *str, register char *ptr)
{
register int len;
if (!ptr)
return;
if (!(str->str_pok))
str_2ptr(str);
len = strlen(ptr);
GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1);
memcpy(str->str_ptr+str->str_cur, ptr, len+1);
str->str_cur += len;
str->str_nok = 0; /* invalidate number */
str->str_pok = 1; /* validate pointer */
}
STR *
str_new(int len)
{
register STR *str;
if (freestrroot) {
str = freestrroot;
freestrroot = str->str_link.str_next;
}
else {
str = (STR *) safemalloc(sizeof(STR));
memset((char*)str,0,sizeof(STR));
}
if (len)
GROWSTR(&(str->str_ptr), &(str->str_len), len + 1);
return str;
}
/* make str point to what nstr did */
void
str_free(register STR *str)
{
if (!str)
return;
if (str->str_len)
str->str_ptr[0] = '\0';
str->str_cur = 0;
str->str_nok = 0;
str->str_pok = 0;
str->str_link.str_next = freestrroot;
freestrroot = str;
}
int
str_len(register STR *str)
{
if (!str)
return 0;
if (!(str->str_pok))
str_2ptr(str);
if (str->str_len)
return str->str_cur;
else
return 0;
}
char *
str_gets(register STR *str, register FILE *fp)
{
#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
/* Here is some breathtakingly efficient cheating */
register char *bp; /* we're going to steal some values */
register int cnt; /* from the stdio struct and put EVERYTHING */
register STDCHAR *ptr; /* in the innermost loop into registers */
register char newline = '\n'; /* (assuming at least 6 registers) */
int i;
int bpx;
#if defined(VMS)
/* An ungetc()d char is handled separately from the regular
* buffer, so we getc() it back out and stuff it in the buffer.
*/
i = getc(fp);
if (i == EOF) return Nullch;
*(--((*fp)->_ptr)) = (unsigned char) i;
(*fp)->_cnt++;
#endif
cnt = FILE_cnt(fp); /* get count into register */
str->str_nok = 0; /* invalidate number */
str->str_pok = 1; /* validate pointer */
if (str->str_len <= cnt) /* make sure we have the room */
GROWSTR(&(str->str_ptr), &(str->str_len), cnt+1);
bp = str->str_ptr; /* move these two too to registers */
ptr = (STDCHAR*)FILE_ptr(fp);
for (;;) {
while (--cnt >= 0) {
if ((*bp++ = *ptr++) == newline) {
if (bp <= str->str_ptr || bp[-2] != '\\')
goto thats_all_folks;
else {
line++;
bp -= 2;
}
}
}
FILE_cnt(fp) = cnt; /* deregisterize cnt and ptr */
FILE_ptr(fp) = (void*)ptr; /* LHS STDCHAR* cast non-portable */
i = getc(fp); /* get more characters */
cnt = FILE_cnt(fp);
ptr = (STDCHAR*)FILE_ptr(fp); /* reregisterize cnt and ptr */
bpx = bp - str->str_ptr; /* prepare for possible relocation */
GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + cnt + 1);
bp = str->str_ptr + bpx; /* reconstitute our pointer */
if (i == newline) { /* all done for now? */
*bp++ = i;
goto thats_all_folks;
}
else if (i == EOF) /* all done for ever? */
goto thats_all_folks;
*bp++ = i; /* now go back to screaming loop */
}
thats_all_folks:
FILE_cnt(fp) = cnt; /* put these back or we're in trouble */
FILE_ptr(fp) = (void*)ptr; /* LHS STDCHAR* cast non-portable */
*bp = '\0';
str->str_cur = bp - str->str_ptr; /* set length */
#else /* USE_STDIO_PTR && STDIO_PTR_LVALUE && STDIO_CNT_LVALUE */
/* The big, slow, and stupid way */
static char buf[4192];
if (fgets(buf, sizeof buf, fp) != Nullch)
str_set(str, buf);
else
str_set(str, No);
#endif /* USE_STDIO_PTR && STDIO_PTR_LVALUE && STDIO_CNT_LVALUE */
return str->str_cur ? str->str_ptr : Nullch;
}
STR *
str_make(char *s)
{
register STR *str = str_new(0);
str_set(str,s);
return str;
}
--- NEW FILE: INTERN.h ---
/* INTERN.h
*
* Copyright (C) 1993, 1994, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*/
#undef EXT
#define EXT
#undef INIT
#define INIT(x) = x
#define DOINIT
--- NEW FILE: util.h ---
/* util.h
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1999, 2000, 2005
* by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*/
/* is the string for makedir a directory name or a filename? */
#define fatal Myfatal
#define MD_DIR 0
#define MD_FILE 1
#ifdef SETUIDGID
int eaccess();
#endif
char * cpy2 ( char *to, char *from, int delim );
char * cpytill ( char *to, char *from, int delim );
void growstr ( char **strptr, int *curlen, int newlen );
char * instr ( char *big, char *little );
char * savestr ( char *str );
void fatal ( const char *pat, ... );
void warn ( const char *pat, ... );
int prewalk ( int numit, int level, int node, int *numericptr );
Malloc_t safemalloc (MEM_SIZE nbytes);
Malloc_t saferealloc (Malloc_t where, MEM_SIZE nbytes);
Free_t safefree (Malloc_t where);
--- NEW FILE: cflags.SH ---
case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
elif test -f ../../config.sh; then TOP=../..;
elif test -f ../../../config.sh; then TOP=../../..;
elif test -f ../../../../config.sh; then TOP=../../../..;
else
echo "Can't find config.sh."; exit 1
fi
. $TOP/config.sh
;;
esac
: This forces SH files to create target in same directory as SH file.
: This is so that make depend always knows where to find SH derivatives.
case "$0" in
*/cflags.SH) cd `expr X$0 : 'X\(.*\)/'` ;;
cflags.SH) ;;
*) case `pwd` in
*/x2p) ;;
*) if test -d x2p; then cd x2p
else echo "Can't figure out where to write output."; exit 1
fi;;
esac;;
esac
echo "Extracting x2p/cflags (with variable substitutions)"
: This section of the file will have variable substitutions done on it.
: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
: Protect any dollar signs and backticks that you do not want interpreted
: by putting a backslash in front. You may delete these comments.
rm -f cflags
$spitshell >cflags <<!GROK!THIS!
!GROK!THIS!
: In the following dollars and backticks do not need the extra backslash.
$spitshell >>cflags <<'!NO!SUBS!'
case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
elif test -f ../../config.sh; then TOP=../..;
elif test -f ../../../config.sh; then TOP=../../..;
elif test -f ../../../../config.sh; then TOP=../../../..;
else
echo "Can't find config.sh."; exit 1
fi
. $TOP/config.sh
;;
esac
case "X$1" in
Xoptimize=*|X"optimize=*")
eval "$1"
shift
;;
esac
also=': '
case $# in
1) also='echo 1>&2 " CCCMD = "'
esac
case $# in
0) set *.c; echo "The current C flags are:" ;;
esac
set `echo "$* " | sed -e 's/\.[oc] / /g' -e 's/\.obj / /g' -e "s/\\$obj_ext / /g"`
for file do
case "$#" in
1) ;;
*) echo $n " $file.c $c" ;;
esac
: allow variables like str_cflags to be evaluated
eval 'eval ${'"${file}_cflags"'-""}'
: or customize here
case "$file" in
a2p) ;;
a2py) ;;
hash) ;;
str) ;;
util) ;;
walk) ;;
*) ;;
esac
ccflags="`echo $ccflags | sed -e 's/-DMULTIPLICITY//'`"
echo "$cc -c $ccflags $optimize"
eval "$also "'"$cc -c $ccflags $optimize"'
. $TOP/config.sh
done
!NO!SUBS!
chmod 755 cflags
$eunicefix cflags
--- NEW FILE: a2py.c ---
/* a2py.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
* 2000, 2001, 2002, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*/
#if defined(OS2) || defined(WIN32) || defined(NETWARE)
#if defined(WIN32)
#include <io.h>
#endif
#if defined(NETWARE)
#include "../netware/clibstuf.h"
#endif
#include "../patchlevel.h"
#endif
#include "util.h"
[...1276 lines suppressed...]
numargs = fixrargs(name,ops[arg+3].ival,numargs);
}
else {
char *tmpbuf = (char *) safemalloc(strlen(name) + (sizeof(prevargs) * 3) + 5);
sprintf(tmpbuf,"%s:%d",name,prevargs);
str = hfetch(curarghash,tmpbuf);
safefree(tmpbuf);
if (str && strEQ(str->str_ptr,"*")) {
if (type == OVAR || type == OSTAR) {
ops[arg].ival &= ~255;
ops[arg].ival |= OSTAR;
}
else
fatal("Can't pass expression by reference as arg %d of %s\n",
prevargs+1, name);
}
numargs = prevargs + 1;
}
return numargs;
}
--- NEW FILE: Makefile.SH ---
case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
elif test -f ../../config.sh; then TOP=../..;
elif test -f ../../../config.sh; then TOP=../../..;
elif test -f ../../../../config.sh; then TOP=../../../..;
else
echo "Can't find config.sh."; exit 1
fi
. $TOP/config.sh
;;
esac
: This forces SH files to create target in same directory as SH file.
: This is so that make depend always knows where to find SH derivatives.
case "$0" in
*/Makefile.SH) cd `expr X$0 : 'X\(.*\)/'` ;;
Makefile.SH) ;;
*) case `pwd` in
*/x2p) ;;
*) if test -d x2p; then cd x2p
else echo "Can't figure out where to write output."; exit 1
fi;;
esac;;
esac
echo "Extracting x2p/Makefile (with variable substitutions)"
rm -f Makefile
cat >Makefile <<!GROK!THIS!
# $RCSfile: Makefile.SH,v $$Revision: 1.2 $$Date: 2006-12-04 17:02:26 $
#
# $Log: Makefile.SH,v $
# Revision 1.2 2006-12-04 17:02:26 dslinux_cayenne
# Adding fresh perl source to HEAD to branch from
#
CC = $cc
BYACC = $byacc
LDFLAGS = $ldflags
# XXX Perl malloc temporarily unusable (declaration collisions with stdlib.h)
#mallocsrc = $mallocsrc
#mallocobj = $mallocobj
shellflags = $shellflags
libs = $perllibs
$make_set_make
# grrr
SHELL = $sh
# These variables may need to be manually set for non-Unix systems.
AR = $ar
EXE_EXT = $_ext
LIB_EXT = $_a
OBJ_EXT = $_o
PATH_SEP = $p_
FIRSTMAKEFILE = $firstmakefile
# how to tr(anslate) newlines
TRNL = '$trnl'
OPTIMIZE = $optimize
.SUFFIXES: .c \$(OBJ_EXT)
!GROK!THIS!
cat >>Makefile <<'!NO!SUBS!'
REALPERL = ../perl
CCCMD = `sh $(shellflags) cflags "optimize='$(OPTIMIZE)'" $@`
public = a2p$(EXE_EXT) s2p find2perl
private =
manpages = a2p.man s2p.man
util =
sh = Makefile.SH cflags.SH
shextract = Makefile cflags
pl = find2perl.PL s2p.PL
plextract = find2perl s2p
plexe = find2perl.exe s2p.exe
plc = find2perl.c s2p.c
plm = a2p.loadmap
addedbyconf = $(shextract) $(plextract)
h = EXTERN.h INTERN.h ../config.h ../handy.h hash.h a2p.h str.h util.h
c = hash.c $(mallocsrc) str.c util.c walk.c
obj = hash$(OBJ_EXT) $(mallocobj) str$(OBJ_EXT) util$(OBJ_EXT) walk$(OBJ_EXT)
lintflags = -phbvxac
.c$(OBJ_EXT):
$(CCCMD) -DPERL_FOR_X2P $*.c
all: $(public) $(private) $(util)
@echo " "
compile: all
$(REALPERL) -I../lib ../utils/perlcc -I .. -L .. $(plextract) -v -log ../compilelog;
a2p$(EXE_EXT): $(obj) a2p$(OBJ_EXT)
$(CC) -o a2p $(LDFLAGS) $(obj) a2p$(OBJ_EXT) $(libs)
# I now supply a2p.c with the kits, so the following section is
# used only if you force byacc to run by saying
# make run_byacc
# byacc 1.8.2 or 1.9 are recommended.
run_byacc: FORCE
@ echo Expect many shift/reduce and reduce/reduce conflicts
$(BYACC) a2p.y
rm -f a2p.c
sed -e 's/(yyn = yydefred\[yystate\])/((yyn = yydefred[yystate]))/' \
-e 's/(yys = getenv("YYDEBUG"))/((yys = getenv("YYDEBUG")))/' \
-e 's/^yyerrlab://' \
-e 's/^ goto yyerrlab;//' \
-e 's/^yynewerror://' \
-e 's/^ goto yynewerror;//' \
-e 's|^static char yysccsid\(.*\)|/* static char yysccsid\1 */|' \
< y.tab.c > a2p.c
FORCE:
# We don't want to regenerate a2p.c, but it might appear out-of-date
# after a patch is applied or a new distribution is made.
a2p.c: a2p.y
- at sh -c true
a2p$(OBJ_EXT): a2p.c a2py.c a2p.h EXTERN.h util.h INTERN.h \
../handy.h ../config.h str.h hash.h
$(CCCMD) a2p.c
clean:
rm -f a2p$(EXE_EXT) psed *$(OBJ_EXT) $(plexe) $(plc) $(plm)
realclean: clean
-rmdir .depending
rm -f core $(addedbyconf) all malloc.c
rm -f $(FIRSTMAKEFILE) $(FIRSTMAKEFILE).old makefile.old
veryclean: realclean
rm -f *~ *.orig
# The following lint has practically everything turned on. Unfortunately,
# you have to wade through a lot of mumbo jumbo that can't be suppressed.
# If the source file has a /*NOSTRICT*/ somewhere, ignore the lint message
# for that spot.
lint:
lint $(lintflags) $(defs) $(c) > a2p.fuzz
depend: $(mallocsrc) ../makedepend
sh ../makedepend MAKE=$(MAKE)
clist:
echo $(c) | tr ' ' $(TRNL) >.clist
hlist:
echo $(h) | tr ' ' $(TRNL) >.hlist
shlist:
echo $(sh) | tr ' ' $(TRNL) >.shlist
# These should be automatically generated
$(plextract):
../miniperl -I../lib $@.PL
find2perl: find2perl.PL
s2p: s2p.PL
malloc.c: ../malloc.c
rm -f malloc.c
sed <../malloc.c >malloc.c \
-e 's/"EXTERN.h"/"..\/EXTERN.h"/' \
-e 's/"perl.h"/"..\/perl.h"/' \
-e 's/my_exit/exit/' \
-e 's/MUTEX_[A-Z_]*(&PL_malloc_mutex);//'
# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
$(obj):
@ echo "You haven't done a "'"make depend" yet!'; exit 1
makedepend: depend
!NO!SUBS!
$eunicefix Makefile
case `pwd` in
*SH)
$rm -f ../Makefile
$ln Makefile ../Makefile
;;
esac
rm -f $firstmakefile
--- NEW FILE: EXTERN.h ---
/* EXTERN.h
*
* Copyright (C) 1991, 1992, 1993, 1994, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*/
#undef EXT
#define EXT extern
#undef INIT
#define INIT(x)
#undef DOINIT
--- NEW FILE: str.h ---
/* str.h
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2000, 2005
* by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*/
struct string {
char * str_ptr; /* pointer to malloced string */
double str_nval; /* numeric value, if any */
int str_len; /* allocated size */
int str_cur; /* length of str_ptr as a C string */
union {
STR *str_next; /* while free, link to next free str */
} str_link;
char str_pok; /* state of str_ptr */
char str_nok; /* state of str_nval */
};
#define Nullstr Null(STR*)
/* the following macro updates any magic values this str is associated with */
#define STABSET(x) (x->str_link.str_magic && stabset(x->str_link.str_magic,x))
EXT STR **tmps_list;
EXT long tmps_max INIT(-1);
char * str_2ptr ( STR *str );
void str_cat ( STR *str, char *ptr );
void str_free ( STR *str );
char * str_gets ( STR *str, FILE *fp );
int str_len ( STR *str );
STR * str_make ( char *s );
void str_ncat ( STR *str, char *ptr, int len );
STR * str_new ( int len );
void str_nset ( STR *str, char *ptr, int len );
void str_numset ( STR *str, double num );
void str_scat ( STR *dstr, STR *sstr );
void str_set ( STR *str, char *ptr );
void str_sset ( STR *dstr, STR *sstr );
--- NEW FILE: s2p.PL ---
#!/usr/bin/perl
use Config;
use File::Basename qw(&basename &dirname);
use Cwd;
use subs qw(link);
sub link { # This is a cut-down version of installperl:link().
my($from,$to) = @_;
my($success) = 0;
eval {
CORE::link($from, $to)
? $success++
: ($from =~ m#^/afs/# || $to =~ m#^/afs/#)
? die "AFS" # okay inside eval {}
: die "Couldn't link $from to $to: $!\n";
};
if ($@) {
[...2025 lines suppressed...]
distribute, and sell this program (and any modified variants) in any
way you wish, provided you do not restrict others from doing the same.
=cut
!NO!SUBS!
close OUT or die "Can't close $file: $!";
chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
unlink 'psed';
print "Linking $file to psed.\n";
if (defined $Config{d_link}) {
link $file, 'psed';
} else {
unshift @INC, '../lib';
require File::Copy;
File::Copy::syscopy('s2p', 'psed');
}
exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
chdir $origdir;
More information about the dslinux-commit
mailing list