search.pl

UNIX下perl实现代码

		warn "$0: warning, can't underline-safe ``$regex''.\n";
	     } else {
		$regex = join($underline_glue, split(//, $regex));
	     }
	  }

	  ## If nothing special in the regex, just use index...
	  ## is quite a bit faster.
	  if (($iflag eq '') && ($words == 0) &&
			$regex !~ m/[?*+{}()\\.|^\$[]/)
	  {
	      push(@regex_tests, "(index(\$_, q+$regex+)>=0)");

	  } else {
	      $regex =~ s#[\$\@\/]\w#\\$&#;
	      if ($words) {
		  if ($regex =~ m/\|/) {
		      ## could be dangerous -- see if we can wrap in parens.
		      if ($regex =~ m/\\\d/) {
			  warn "warning: -w and a | in a regex is dangerous.\n"
		      } else {
			  $regex = join($regex, '(', ')');
		      }
		  }
		  $regex = join($regex, '\b', '\b');
	      }
	      $CAN_USE_FAST_LISTONLY = 0 if substr($regex, "[^") >= 0;
	      push(@regex_tests, "m/$regex/$iflag$mflag");
	  }

	  ## If we're done, but still have @extra to do, get set for that.
	  if (@ARGV == 0 && @extra) {
	      @ARGV = @extra;   ## now deal with the extra stuff.
	      $underlineOK = 0; ## but no more of this.
	      undef @extra;     ## or this.
	  }
      }
      if (@regex_tests) {
	  $REGEX_TEST = join('||', @regex_tests);
	  ## print STDERR $REGEX_TEST, "\n"; exit;
      } else {
	  ## must be doing -find -- just give something syntactically correct.
	  $REGEX_TEST = 1;
      }
  }

  ##
  ## Make sure we can read the first item(s).
  ##
  foreach $start (@todo) {
      $! = 2, die qq/$0: can't stat "$start"\n/
	  unless ($dev,$inode) = (stat($start))[$STAT_DEV,$STAT_INODE];

      if (defined $dir_done{"$dev,$inode"}) {
	  ## ignore the repeat.
	  warn(qq/ignoring "$start" (same as "$dir_done{"$dev,$inode"}").\n/)
		if $VERBOSE;
	  next;
      }

      ## if -xdev was given, remember the device.
      $xdev{$dev} = 1 if $XDEV;

      ## Note that we won't want to do it again
      $dir_done{"$dev,$inode"} = $start;
  }
}


##
## See the comment above the __END__ above the 'sub dodir' below.
##
sub import_program
{
    sub bad {
	print STDERR "$0: internal error (@_)\n";
	exit 2;
    }

    ## Read from data, up to next __END__. This will be &dodir.
    local($/) = "\n__END__";
    $prog = <DATA>;
    close(DATA);

    $prog =~ s/\beval\b//g;       ## remove any 'eval'

    ## Inline uppercase $-variables by their current values.
    if ($] >= 5) {
	$prog =~ s/\$([A-Z][A-Z0-9_]{2,}\b)/
		    &bad($1) if !defined ${$main::{$1}}; ${$main::{$1}};/eg;
    } else {
	$prog =~ s/\$([A-Z][A-Z0-9_]{2,}\b)/local(*VAR) = $_main{$1};
		    &bad($1) if !defined $VAR; $VAR;/eg;
    }

    eval $prog;  ## now do it. This will define &dodir;
    $!=2, die "$0 internal error: $@\n" if $@;
}

###########################################################################

##
## Read the .search file:
##    Blank lines and lines that are only #-comments ignored.
##    Newlines may be escaped to create long lines
##    Other lines are directives.
##
##    A directive may begin with an optional tag in the form <...>
##    Things inside the <...> are evaluated as with:
##	   <(this || that) && must>
##    will be true if
##       -xmust -xthis   or   -xmust -xthat
##    were specified on the command line (order doesn't matter, though)
##    A directive is not done if there is a tag and it's false.
##    Any characters but whitespace and &|()>,! may appear after an -x
##    (although "-xdev" is special).  -xmust,this is the same as -xmust -xthis.
##    Something like -x~ would make <~> true, and <!~> false.
##
##    Directives are in the form:
##      option: STRING
##	magic : NUMBYTES : EXPR
##
##    With option:
##      The STRING is parsed like a Bourne shell command line, and the
##      options are used as if given on the command line.
##      No comments are allowed on 'option' lines.
##	Examples:
##	    # skip objects and libraries
##	    option: -skip '.o .a'
##	    # skip emacs *~ and *# files, unless -x~ given:
##	    <!~> option: -skip '~ #'
##
##    With magic:
##	EXPR can be pretty much any perl (comments allowed!).
##      If it evaluates to true for any particular file, it is skipped.
##      The only info you'll have about a file is the variable $H, which
##      will have at least the first NUMBYTES of the file (less if the file
##      is shorter than that, of course, and maybe more). You'll also have
##      any variables you set in previous 'magic' lines.
##	Examples:
##	    magic: 6 : ($x6 = substr($H, 0, 6)) eq 'GIF87a'
##	    magic: 6 :  $x6                     eq 'GIF89a'
##
##          magic: 6 : (($x6 = substr($H, 0, 6)) eq 'GIF87a' ## old gif \
##		                         || $x6  eq 'GIF89a' ## new gif
##	(the above two sets are the same)
##	    ## Check the first 32 bytes for "binarish" looking bytes.
##	    ## Don't blindly dump on any high-bit set, as non-ASCII text
##	    ## often has them set. \x80 and \xff seem to be special, though.
##	    ## Require two in a row to not get things like perl's $^T.
##	    ## This is known to get *.Z, *.gz, pkzip, *.elc and about any
##	    ## executable you'll find.
##	    magic: 32 : $H =~ m/[\x00-\x06\x10-\x1a\x1c-\x1f\x80\xff]{2}/
##
sub read_rc
{
    local($file, $show) = @_;
    local($line_num, $ln, $tag) = 0;
    local($use_default, @default) = 0;

    { package magic; $^W= 0; } ## turn off warnings for when we run EXPR's

    unless (open(RC, "$file")) {
	$use_default=1;
	$file = "<internal default startup file>";
	## no RC file -- use this default.
	@default = split(/\n/,<<'--------INLINE_LITERAL_TEXT');
            magic: 32 : $H =~ m/[\x00-\x06\x10-\x1a\x1c-\x1f\x80\xff]{2}/
	    option: -skip '.a .COM .elc .EXE .gz .o .pbm .xbm .dvi'
	    option: -iskip '.tarz .zip .z .lzh .jpg .jpeg .gif .uu'
	    <!~> option: -skip '~ #'
--------INLINE_LITERAL_TEXT
    }

    ##
    ## Make an eval error pretty.
    ##
    sub clean_eval_error {
	local($_) = @_;
	s/ in file \(eval\) at line \d+,//g; ## perl4-style error
	s/ at \(eval \d+\) line \d+,//g;     ## perl5-style error
	$_ = $` if m/\n/;                    ## remove all but first line
	"$_\n";
    }

    print "reading RC file: $file\n" if $show;

    while (defined($_ = ($use_default ? shift(@default) : <RC>))) {
	$ln = ++$line_num;			     ## note starting line num.
        $_ .= <RC>, $line_num++ while s/\\\n?$/\n/;  ## allow continuations
	next if /^\s*(#.*)?$/;          ## skip blank or comment-only lines.
        $do = '';
	
	## look for an initial <...> tag.
	if (s/^\s*<([^>]*)>//) {
	    ## This simple s// will make the tag ready to eval.
	    ($tag = $msg = $1) =~
		s/[^\s&|(!)]+/
			$seen_opt{$&}=1;         ## note seen option
			"defined(\$opt{q>$&>})"  ## (q>> is safe quoting here)
		/eg;
	    
	    ## see if the tag is true or not, abort this line if not.
	    $dothis = (eval $tag);
	    $!=2, die "$file $ln <$msg>: $_".&clean_eval_error($@) if $@;

	    if ($show) {
	        $msg =~ s/[^\s&|(!)]+/-x$&/;
	        $msg =~ s/\s*!\s*/ no /g;
	        $msg =~ s/\s*&&\s*/ and /g;
	        $msg =~ s/\s*\|\|\s*/ or /g;
		$msg =~ s/^\s+//; $msg =~ s/\s+$//;
		$do = $dothis ? "(doing because $msg)" :
				"(do if $msg)";
	    } elsif (!$dothis) {
	        next;
	    }
	}

	if (m/^\s*option\s*:\s*/) {
	    next if $all && !$show; ## -all turns off these checks;
	    local($_) = $';
            s/\n$//;
	    local($orig) = $_;
	    print " $do option: $_\n" if $show;
	    local($0) = "$0 ($file)"; ## for any error message.
	    local(@ARGV);
	    local($this);
	    ##
	    ## Parse $_ as a Bourne shell line -- fill @ARGV
	    ##
	    while (length) {
		if (s/^\s+//) {
		    push(@ARGV, $this) if defined $this;
		    undef $this;
		    next;
		}
		$this = '' if !defined $this;
		$this .= $1 while s/^'([^']*)'// ||
				  s/^"([^"]*)"// ||
				  s/^([^'"\s\\]+)//||
				  s/^(\\[\D\d])//;
		die "$file $ln: error parsing $orig at $_\n" if m/^\S/;
	    }
	    push(@ARGV, $this) if defined $this;
	    &check_args;
	    die qq/$file $ln: unused arg "@ARGV".\n/ if @ARGV;
	    next;
	}

	if (m/^\s*magic\s*:\s*(\d+)\s*:\s*/) {
	    next if $all && !$show; ## -all turns off these checks;
	    local($bytes, $check) = ($1, $');

	    if ($show) {
		$check =~ s/\n?$/\n/;
		print " $do contents: $check";
	    }
	    ## Check to make sure the thing at least compiles.
	    eval  "package magic; (\$H = '1'x \$main'bytes) && (\n$check\n)\n";
	    $! = 2, die "$file $ln: ".&clean_eval_error($@) if $@;

	    $HEADER_BYTES = $bytes if $bytes > $HEADER_BYTES;
	    push(@magic_tests, "(\n$check\n)");
	    next;
	}
	$! = 2, die "$file $ln: unknown command\n";
    }
    close(RC);
}

sub message
{
    if (!$STDERR_IS_TTY) {
	print STDERR $_[0], "\n";
    } else {
	local($text) = @_;
	$thislength = length($text);
	if ($thislength >= $last_message_length) {
	    print STDERR $text, "\r";
	} else {
	    print STDERR $text, ' 'x ($last_message_length-$thislength),"\r";
	}	
	$last_message_length = $thislength;
    }
}

sub clear_message
{
    print STDERR ' ' x $last_message_length, "\r" if $last_message_length;
    $vv_print = $vv_size = $last_message_length = 0;
}

##
## Output a copy of this program with comments, extra whitespace, and
## the trailing man page removed. On an ultra slow machine, such a copy
## might load faster (but I can't tell any difference on my machine).
##
sub strip {
    seek(DATA, 0, 0) || die "$0: can't reset internal pointer.\n";
    while(<DATA>) {
      print, next if /INLINE_LITERAL_TEXT/.../INLINE_LITERAL_TEXT/;
      ## must mention INLINE_LITERAL_TEXT on this line!
      s/\#\#.*|^\s+|\s+$//; ## remove cruft
      last if $_ eq '.00;';
      next if ($_ eq '') || ($_ eq "'di'") || ($_ eq "'ig00'");
      s/\$stripped=0;/\$stripped=1;/;
      s/\s\s+/ /;  ## squish multiple whitespaces down to one.
      print $_, "\n";
    }
    exit(0);
}

##
## Just to shut up -w. Never executed.
##
sub dummy {

    1 || &dummy || &dir_done || &bad || &message || $NEXT_DIR_ENTRY ||
    $DELAY || $VV_SIZE || $VV_PRINT_COUNT || $STDERR_SCREWS_STDOUT ||
    @files || @files || $magic'H || $magic'H || $xdev{''} || &clear_message;

}

##
## If the following __END__ is in place, what follows will be
## inlined when the program first starts up. Any $ variable name
## all in upper case, specifically, any string matching
##	\$([A-Z][A-Z0-9_]{2,}\b
## will have the true value for that variable inlined. Also, any 'eval' is
## removed
##
## The idea is that when the whole thing is then eval'ed to define &dodir,
## the perl optimizer will make all the decisions that are based upon
## command-line options (such as $VERBOSE), since they'll be inlined as
## constants
##
## Also, and here's the big win, the tests for matching the regex, and a
## few others, are all inlined. Should be blinding speed here.
##
## See the read from <DATA> above for where all this takes place.
## But all-in-all, you *want* the __END__ here. Comment it out only for
## debugging....
##

__END__

##
## Given a directory, check all "appropriate" files in it.
## Shove any subdirectories into the global @todo, so they'll be done
## later.
##
## Be careful about adding any upper-case variables, as they are subject
## to being inlined. See comments above the __END__ above.
##
sub dodir
{
  local($dir) = @_;
  $dir =~ s,/+$,,; ## remove any trailing slash.
  unless (opendir(DIR, "$dir/.")) {
      &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
      warn qq($0: can't opendir "$dir/".\n);
      return;
  }

  if ($VERBOSE) {
      &message($dir);
      $vv_print = $vv_size = 0;
  }

  @files = sort readdir(DIR) if $DO_SORT;

  while (defined($name = eval $NEXT_DIR_ENTRY))
  {
    next if $name eq '.' || $name eq '..'; ## never follow these.

    ## create full relative pathname.
    $file = $dir eq '.' ? $name : "$dir/$name";

    ## if link and skipping them, do so.
    if ($NOLINKS && -l $file) {
	warn qq/skip (symlink): $file\n/ if $WHY;
	next;
    }

    ## skip things unless files or directories
    unless (-f $file || -d _) {
	if ($WHY) {
	    $why = (-S _ && "socket")       ||
		   (-p _ && "pipe")         ||
		   (-b _ && "block special")||
		   (-c _ && "char special") || "somekinda special";
	    warn qq/skip ($why): $file\n/;
	}
	next;
    }

    ## skip things we can't read
    unless (-r _) {
	if ($WHY) {
	    $why = (-l $file) ? "follow" : "read";
	    warn qq/skip (can't $why): $file\n/;
	}
	next;
    }

    ## skip things that are empty
    unless (-s _ || -d _) {
	warn qq/skip (empty): $file\n/ if $WHY;
	next;
    }

    ## Note file device & inode. If -xdev, skip if appropriate.
    ($dev, $inode) = (stat(_))[$STAT_DEV, $STAT_INODE];
    if ($XDEV && defined $xdev{$dev}) {
	warn qq/skip (other device): $file\n/ if $WHY;
	next;
    }
    $id = "$dev,$inode";

    ## special work for a directory
    if (-d _) {
	## Do checks for directory file endings.
	if ($DO_DSKIP_TEST && (eval $DSKIP_TEST)) {
	    warn qq/skip (-dskip): $file\n/ if $WHY;
	    next;
	}
	## do checks for -name/-regex/-path tests
	if ($DO_DGLOB_TESTS && !(eval $DGLOB_TESTS)) {
	    warn qq/skip (dirname): $file\n/ if $WHY;
	    next;
	}

	## _never_ redo a directory
	if (defined $dir_done{$id} and $^O ne 'MSWin32') {
	    warn qq/skip (did as "$dir_done{$id}"): $file\n/ if $WHY;
	    next;
	}
	$dir_done{$id} = $file;     ## mark it done.
	unshift(@todo, $file);	    ## add to the list to do.
	next;
    }
    if ($WHY == 0  && $VERBOSE > 1) {
      if ($VERBOSE>2||$vv_print++>$VV_PRINT_COUNT||($vv_size+=-s _)>$VV_SIZE){
	  &message($file);
	  $vv_print = $vv_size = 0;
      }
    }

    ## do time-related tests
    if ($NEWER || $OLDER) {
	$_ = (stat(_))[$STAT_MTIME];
	if ($NEWER && $_ < $NEWER) {
	    warn qq/skip (too old): $file\n/ if $WHY;
	    next;
	}
	if ($OLDER && $_ > $OLDER) {
	    warn qq/skip (too new): $file\n/ if $WHY;
	    next;
	}
    }

    ## do checks for file endings
    if ($DO_SKIP_TEST && (eval $SKIP_TEST)) {
	warn qq/skip (-skip): $file\n/ if $WHY;
	next;
    }