home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / perl / scripts-convex / lqi < prev    next >
Encoding:
Text File  |  1991-08-09  |  5.9 KB  |  299 lines
  1. #!/usr/local/bin/perl
  2. #
  3. # intersect.pl  -- find intersection of lq phrases
  4. #
  5. # Tom Christiansen 
  6. # tchrist@convex.com
  7. # 8 Aug 91
  8.  
  9. $match         = '-mh';
  10. $lqprog     = 'lqshow';
  11.  
  12. sub gensym { 'gensym' . ++$gensym; };
  13. *choices = &gensym;  # init list of lists
  14.  
  15. $SIG{'INTR'} = 'INTR';
  16.  
  17. sub usage {
  18.     select(STDERR);
  19.     print <<FINIS;
  20. usage: $0 [-CAB <num>] [-v] [-q]  [-d directory] [-n] [-l | -L | -R]  
  21.     [-mp | -mh | -ma] phrase ... [ [-a | -r] phrase ... ] ...
  22.  
  23. -a    add    set of phrases
  24. -r    remove set of phrases
  25.  
  26. -A    lines of context after
  27. -B    lines of context before
  28. -C    lines of context before and after
  29.  
  30. -n    sort numerically
  31.  
  32. -q    use lqkwik instead of lqshow
  33. -v    verbose mode
  34.  
  35. -l    list filenames
  36. -L    just list base names 
  37. -R    list raw lqshow triples
  38.  
  39. -d    set LQTEXTDIR
  40.  
  41. -m[pha] lqphrase match fuzziness
  42.         p    precise
  43.         h    heuristic
  44.         a    almost anything goes
  45.  
  46. FINIS
  47.  
  48.     exit 1;
  49.  
  50. } 
  51.  
  52. $sort = "sort +2 +0n +1n";
  53.  
  54. while ($_ = shift) {
  55.     if    (/^-m[pha]$/) { $match = $_; } 
  56.     elsif (/^-q$/)     { $lqprog = 'lqkwik'; } 
  57.     elsif (/^-n$/)     { $numsort++; }
  58.     elsif (/^-R$/)     { $listonly++; $rawlist++;}
  59.     elsif (/^-v$/)     { $verbose++; }
  60.     elsif (/^-a$/)     { *choices = &gensym; } # start a new list 
  61.     elsif (/^-r$/)     { *choices = &gensym; $nand[$gensym]++; } 
  62.     elsif (/^-d(.*)$/)     { $ENV{'LQTEXTDIR'} = $1 || shift; } 
  63.     elsif (/^-l$/i)     { $listonly = 1; $shortlist = /L/; }
  64.     elsif (/^-[AB](\d*)$/) { 
  65.     $hadwin++;
  66.     y/A-Z/a-z/; # gotta pass lower case
  67.     $lqshow_opts .= ' '. $_;
  68.     $lqshow_opts .= ' ' . shift unless $1;
  69.     } 
  70.     elsif (/^-C(\d*)$/) {
  71.     $hadwin++;
  72.     $context = $1 || shift;
  73.     $lqshow_opts = "-a $context -b $context";
  74.     }
  75.     elsif (/^-(.*)/) {
  76.     warn "unknown option: $1\n";
  77.     &usage;
  78.     } 
  79.     else { 
  80.     push(@choices, $_); 
  81.     } 
  82. }
  83.  
  84. &usage unless @choices;
  85. ### finally the interesting part...
  86.  
  87. unless ($hadwin) {
  88.     &getwin;
  89.     $context = int($rows - 3)/2;
  90.     $lqshow_opts = "-a $context -b $context";
  91. } 
  92.  
  93. $func = 'adding';
  94. &read_choices(*need, 'gensym1');
  95.  
  96. @fold = @fnew;
  97. %fold = %fnew;
  98.  
  99. for ($i = 2; $i <= $gensym; $i++) {
  100.     $func = $nand[$i] ? 'subtracting' : 'adding';
  101.     &read_choices(*want, "gensym$i");
  102.     &$func(*need, *want);
  103. }
  104.  
  105. $TMP = "/tmp/inter$$";
  106. if ($numsort) { 
  107.     # too hard to make sort do this
  108.     #print STDERR "sorting the hard way..." if $verbose;
  109.     $i = 0;
  110.     for (@need) {
  111.     $i++;
  112.     s/^ /0/; # convex printf is broken
  113.     ($block, $offset, $file) = split;
  114.     push(@block, $block);
  115.     push(@offset, $offset);
  116.     $file =~ /(\d+)$/;
  117.     push(@file, $1);
  118.     } 
  119.     open (TMP, ">$TMP") || die "can't write to $TMP: $!";
  120.     print TMP @need[sort bynum $[..$#need];
  121.     #print STDERR "done\n" if $verbose;
  122. } else { 
  123.     open (TMP, "| $sort > $TMP");
  124.     for (@need) {
  125.     s/^ /0/; # convex printf is broken
  126.     print TMP;
  127.     } 
  128. }
  129. unless (close TMP) { 
  130.     warn "can't close $TMP correctly";
  131.     &done;
  132. }
  133.  
  134. $count = @need;
  135.  
  136. unless ($verbose) {
  137.     local(%seen);
  138.     for (@need) {
  139.     $fcount++ unless $seen{(split)[2]}++;
  140.     } 
  141.     print STDERR "total of $count ", &plural('match', $count);
  142.     print STDERR " in $fcount ", &plural('file',$fcount), "\n";
  143. } 
  144.  
  145.  
  146. if ($listonly) {
  147.     open (TMP, "<$TMP");
  148.     if ($rawlist) {
  149.     print while <TMP>;
  150.     } else {
  151.     while (<TMP>) {
  152.         s/.*\s(\S+)$/$1/;
  153.         $shortlist && s#.*/##;
  154.         print unless $printed{$_}++;
  155.     } 
  156.     }
  157. } else {
  158.     warn "No matches found\n", &done unless $count;
  159.     $cmd = "$lqprog ";
  160.     $cmd .= "$lqshow_opts " if $lqprog =~ /show/;
  161.     $cmd .= "-f $TMP";
  162.     warn "running: $cmd\n" if $verbose;
  163.     system $cmd;
  164. }
  165.  
  166. &done;
  167.  
  168.  
  169. ##############################################################
  170.  
  171. sub read_choices {
  172.     local(*results, *targets) = @_;
  173.     local(@pretty) = ();
  174.  
  175.     local($fcount, $count) = (0,0);
  176.  
  177.     die "no targets" unless @targets;    
  178.  
  179.     @results = ();
  180.  
  181.     for (@targets) { push (@pretty, "\"$_\""); } 
  182.     local($pretty) = join(', ', @pretty);
  183.     print STDERR "$func $pretty: " if $verbose;
  184.  
  185.     # don't let the shell get even close to touching my targets
  186.     die "can't fork: $!" unless defined ($pid = open(KID, "-|"));
  187.     unless ($pid) {
  188.     exec 'lqphrase', $match, @targets;
  189.     die "can't exec lqphrase: $!" ;
  190.     }
  191.  
  192.     @fnew = ();
  193.     %fnew = ();
  194.  
  195.     for (<KID>) {
  196.     $count++;
  197.     $file = (split)[2];
  198.     $fcount++ unless $fnew{$file}++;
  199.     next if %fold && !$fold{$file};
  200.     push(@results, $_);
  201.     push(@fnew, $file);
  202.     } 
  203.     close KID;
  204.     print STDERR "$count in $fcount\n" if $verbose;
  205.     die "No matches for $pretty\n" unless $count;
  206.     die "lqphrase exited badly" if $?;
  207. } 
  208.  
  209. sub adding {
  210.     local($mfunc) = 'add2c';
  211.     &merge;
  212. } 
  213.  
  214. sub subtracting {
  215.     local($mfunc) = 'sub2c';
  216.     &merge;
  217. } 
  218.  
  219. sub merge {
  220.     local(*a, *b) = @_;
  221.     local($_);
  222.     local(@c, *f1, *f2, *f3);
  223.     local($file);
  224.  
  225.     print STDERR  "  intersection => " if $verbose;
  226.  
  227.     &$mfunc(*a, *fold);
  228.     &$mfunc(*b, *fnew);
  229.  
  230.     %fold = %f3;
  231.     @fold = @f3;
  232.  
  233.     local($count) = 0+@c;
  234.     local($fcount) = 0;
  235.     $fcount++ while each %fold;
  236.  
  237.     print STDERR " $count in $fcount\n" if $verbose;
  238.  
  239.     @a = @c;
  240. } 
  241.  
  242. sub plural {
  243.     local($_, $number) = @_;
  244.     local($end) = 's';
  245.     return $_ if $number == 1;
  246.     if (/[cst]h$/) { $end = 'es'; } 
  247.     "$_$end";
  248. } 
  249.  
  250. sub add2c {
  251.     local(*list, *set) = @_;
  252.     local($i);
  253.  
  254.     for ($i = 0; $i < @list; $i++) {
  255.     next unless $fnew{$set[$i]} && $fold{$set[$i]};
  256.     push(@c, $list[$i]);
  257.     push(@f3, $set[$i]);
  258.     $f3{$set[$i]}++;
  259.     } 
  260. } 
  261.  
  262. sub sub2c {
  263.     local(*list, *set) = @_;
  264.     local($i);
  265.  
  266.     for ($i = 0; $i < @list; $i++) {
  267.     next if $fnew{$set[$i]};
  268.     push(@c, $list[$i]);
  269.     push(@f3, $set[$i]);
  270.     $f3{$set[$i]}++;
  271.     } 
  272. } 
  273.  
  274. sub bynum {
  275.     $file[$a]   <=> $file[$b]  ||
  276.     $block[$a]  <=> $block[$b] ||
  277.     $offset[$a] <=> $offset[$b];
  278. } 
  279.  
  280.  
  281. sub INTR {
  282.     warn "\nInterrupt!\n";
  283.     &done;
  284. } 
  285.  
  286. sub done {
  287.     #unlink $TMP;
  288.     exit;
  289. } 
  290.  
  291. sub getwin {
  292.     $TIOCGWINSZ = 0x40087468;  # should be require sys/ioctl.pl
  293.     if (ioctl(STDOUT, $TIOCGWINSZ, $winsize)) {
  294.         ($rows, $cols, $xpixel, $ypixel) = unpack('S4', $winsize);
  295.     } else {
  296.         $cols = $ENV{TERMCAP} =~ /:co#(\d+)/ ? $1 : 80;
  297.     }
  298. }
  299.