path: root/bkt

#!/usr/bin/perl

=pod

=head1 NAME

B<bkt> - count repeats in input

=head1 SYNOPSIS

B<bkt> -h | --help

B<bkt> -[cpiwWtxaBPnkFL] [...] [-e code] [-d delim ] [-f field] [-b list]
[-o delim] [-s sortopts] [-T thresh[%]] [-/ separator] [-r recordsize]
<file> <file ...>

=head1 DESCRIPTION

B<bkt> reads input from files or standard input, optionally transforms
it according to various options, and counts like inputs. After all input
is read, a count is given for the occurrence of each input.

Given the following input:

	foo
	foo
	bar
	bar
	baz

B<bkt> will output:

	bar	2	40.0%
	baz	1	20.0%
	foo	2	40.0%

The name 'B<bkt>' comes from the concept of collecting like items in
buckets. The original plan was to name this script 'bucketize', but who
wants to type all that? Also, purely to support lazy typists, B<bkt>
implements subsets of the functionality of B<cut>(1) and B<sort>(1).

The utility of B<bkt> will be obvious, if you've written lots of
variants of:

	<shell commands> | perl -lne 's/\s.*//; $a{$_}++; END { print "$_ $a{$_}" for sort keys %a }'

The above could be written as:

	<shell commands> | bkt -f1

=head1 OPTIONS

Options that don't take arguments may be bundled: B<-BipW> is the same
as B<-B> B<-i> B<-p> B<-W>.

=head2 General Options

=over

=item B<--help>, B<-h>

Display this help message

=item B<--version>

Display version of bkt

=item B<-->

End of options. Everything after this is treated as a filename.

=back

=head2 Input Options

These options are applied to each input file when it's first opened for reading.

=over

=item B<-B>

Byte mode. By default, input is treated as characters in the encoding
specified by the current locale. B<-B> treats the input as a stream of
8-bit bytes (octets, if you like).

=item B<-r> I<recordsize>

Read input as fixed-size records. This can't be combined with B<-/>,
as it sets the value of B<$/> to a reference to its argument. See
I<perldoc -v '$/'>.

=item B<-/> I<separator>

Set value of B<$/>, perl's input record separator. Default is I<\n>.
One of B<-w> B<-W> B<-n> is highly recommended with this option. This
can't be combined with B<-r>.

=back

=head2 Transform Options

These options are applied to each record of input, in the order listed
here, before it's counted. If you haven't used B<-r> or B<-/>, a record
is a line.

The B<-f> and <-b> options can be used together, which is unlike B<cut>(1).

=over

=item B<-l> I<range>

Operate only on records numbered within the range, e.g. I<1-3> for the
first 3 records of each file, I<10-> for 10th through the end, I<15>
for only the 15th record. The starting record is optional and defaults
to 1, so I<-3> could be used for the first example. If multiple files
are given, the numbering resets to 1 at the start of each file.

=item B<-d> I<delim>

Delimiter for B<-f>. Default: /\\s+/ aka whitespace. This can be a literal
string or a regular expression (if enclosed in //, with optional /i
modifier). As a special case, I<//> alone is treated as a literal string.
This option does nothing without B<-f>. B<-d>'s argument is used with
perl's B<split>, so you might read I<perldoc -f split> to understand this.

=item B<-f> I<field>

Consider only this (B<-d> delimiter separated) field. Unlike B<cut>,
only one field may be selected (B<cut>'s lists of fields are not
supported). Also unlike B<cut>, negative field numbers can be used to
index from the rightmost field (which is numbered B<-1>).

=item B<-b> I<range>

Like B<cut -b>: Consider only a range of characters (or bytes, if B<-B>)
in each record. Example: I<1-3> for the first 3 bytes/chars of each
input record.

B<-b> supports the same types of range as cut(1):

	N      N'th byte/character, counted from 1
	N-     from N'th byte/character to end of record
	N-M    from N'th to M'th (included) byte/character
	-M     from first to M'th (included) byte/character

...plus 2 extra types:

	-M-    from Mth-to-last byte/character (included) to end of record (-1 = last)
	-M-N   from Mth-to-last byte/character to Nth-to-last (included)

...including multiple ranges separated by commas.

=item B<-i>

Case insensitive mode. Actually, lowercases all input. Use B<-sf>
instead to sort output case-insensitively.

=item B<-w>

Remove leading and trailing whitespace from input records.

=item B<-W>

Remove ALL whitespace from input records.

=item B<-n>

Remove all non-word (I<\W>) characters from input records.

=item B<-g> I<regex>

Grep for regex. Equivalent to: B<-e 'next unless /regex/'>. Remember
this is a perl-style regex, not a B<grep>(1) one.

=item B<-v> I<regex>

Grep for records not containing regex. Equivalent to: B<-e 'next if /regex/'>.

=item B<-e> I<code>

Execute perl code for each input record. The code should modify B<$_>.
Make sure you quote the argument as needed by your shell. See OPERATION
below for more information.

=item B<-k>

Skip blank records. Basically the same as B<-e 'next if $_ eq ""'>.

=item B<-F>

Word frequency count. Alias for B<-ink/' '>.

=item B<-L>

Letter frequency count. Alias for B<-inkr1>.

=back

=head2 Output Options

These options are applied after all I/O and counting is done, and
only affect how the output is printed.

=over

=item B<-c>

Show counts only (suppress percentages).

=item B<-p>

Show percentages only (suppress counts).
B<-c> and B<-p> may be combined, if you can find a use for it.

=item B<-t>

Show total count after all item counts.

=item B<-C>

Print the records themselves, instead of the counts. Allows B<bkt> to
be used as a general-purpose text manipulation tool. Mainly this option
was implemented for debugging purposes, but it might be useful for other
stuff. When B<-C> is used, B<-a> and B<-x> still work, but none of the
other output options have any effect.

=item B<-H>

Print a crude ASCII art histogram. The histogram's width is half the
width of the terminal, as reported by the COLUMNS environment variable
(or by B<tput cols>, if COLUMNS not set), so the width can be controlled
by setting COLUMNS manually.

=item B<-x>

Print output records as hexadecimal.

=item B<-a>

ASCII output: render non-ASCII characters as hex escapes.

=item B<-s> I<sortopts>

Output sort options. Options may include:

	r - reverse sort (default is ascending)
	a - sort alphabetically by record (default is by count, then alpha)
	n - sort numerically by record
	f - fold case

=item B<-T> I<thresh[%]>

Filter out results below threshold, which may be a count or a percentage, e.g. 5%.

=item B<-o> I<string>

Use string as output delimiter (default: \\t). Implies B<-P>.

=item B<-P>

Don't pad output with spaces to length of longest element.
The B<-o> option enables this as well.

=back

=head1 OPERATION

Input will be read from filenames given on the command line, or
from standard input if none given, or if the filename B<-> (hyphen) is
given. Use B<./-> to read file a real file named B<->. The input need
not be sorted. The output will always be sorted.

Each input record is chomped before any further processing.

The transform options (B<-l> B<-f> B<-b> B<-i> B<-w> B<-W> B<-n> B<-g>
B<-v> B<-e>I<code> B<-k>) will be applied to each record in the order
listed here, regardless of the order they're given on the command line. In
particular, this means the code for B<-e> will see B<$_> *after* it's
been modified by any of the other options (except B<-k>). In the case
of B<-l>, B<-g>, B<-v>, the B<-e> code will not be run for records not
matched by the options.

The code for B<-e> will run with strict disabled and warnings enabled. To
disable warnings, prefix the code with 'no warnings;'. There can only
be one B<-e> option, but it may be multiple lines of code separated with
semicolons. When the B<-e> code runs, B<$_> contains the input (possibly
tranformed by other options), and can be modified arbitratily. The B<-e>
code can filter out unwanted records by executing "next", which will
cause them to be skipped entirely. Also, if the B<-k> option is used,
the code can B<undef $_> or assign B<$_=""> to skip the current record.

The astute reader will have noticed that all the other transform options
could be written as code for B<-e>. This is correct: the other options
exist to support lazy typists such as the author.

After each record of input is read and any transform options applied
to it, I<$counts{$_}++> is executed. After all input is read, output is
generated via I<keys %counts>.

=head1 EXIT STATUS

B<bkt> exits with zero (success) status if all operations were successful,
otherwise non-zero. Currently, there are no specific non-zero exit codes
(e.g. different ones for different error types), though this may change
in the future.

If some files couldn't be read, but at least one could, the file(s)
that were readable are processed normally and the exit status will be
non-zero. This mimics the behaviour of GNU cat(1), head(1), tail(1), etc.

=head1 EXAMPLES

Show the percentage of binaries that start with each letter/number/etc,
4 different ways.

	cd /usr/bin
	ls | bkt -b1
	ls | cut -b1 | bkt
	ls | bkt -e '$_=substr($_,0,1)'
	ls | bkt -e 's,^(.).*,$1,'

--

Show percentages of lines said by each user in an irssi IRC log. Relies
on the log format having a timestamp, space, <nick> for normal lines.
Misses /me actions entirely though. Add -sr to show the most talkative
first.

	bkt -f2 -g'<' channelname.log

--

We have a directory full of scripts, a mix of perl, python, shell, etc.
How many scripts are written in each language? Skip any files that
don't start with a #! (shebang) line.

Using B<bkt> only:

   bkt -l1 -g'#!' scripts/*

Which is equivalent to:

   head -qn1 scripts/* | grep '#!' | bkt

If you wanted to make the same assumption the OS does, that a script
missing its shebang line is a #!/bin/sh script:

	bkt -l1 -e'$_="#!/bin/sh" unless /#!/' scripts/*

If some of them might be ELF executables, add "-B -v ELF" to the above.

--

Show us how many users use each shell (including stuff like /bin/false).

	bkt -d: -f-1 /etc/passwd

--

How many images of each type have we got? Ignore case, so JPG and jpg
are counted together.

	ls ~/images/*.* | bkt -i -d. -f-1

The above could have been written as:

	ls ~/images/*.* | tr A-Z a-z | cut -d. -f2 | bkt

...except it wouldn't handle filenames with multiple dots in them, like
image.01.jpg. Replacing the cut with "sed 's,.*\.,,'" would fix that,
but it's still a lot more keystrokes.

--

Plot a histogram of word lengths in a file of words:

	bkt -H -sn -e '$_=length' /usr/share/dict/words

...which should show a nice bell-curve distrubution.

--

What percentage of words in a text file are capitalized?

	bkt -n/' ' -e's/^[A-Z]+$/CAPS/ || s/^[A-Z].*$/Caps/ || s/^[a-z].*$/lower/ || next' file.txt

--

Given a CSV file with fields lastname, firstname, phonenumber:

	Blow,Joe,444-555-0123
	Showers,April,876-333-9874
   ...etc...

...to get a breakdown by area code:

   bkt -d, -f3 -b1-3 phonelist.csv

--

Suppose you have a team of people working on a large C++ or Java codebase.
By convention, TODO comments are written as:

  // TODO bob: Support non-Unicode locales

...where "bob" is the coder assigned to that TODO item. You can get
summary of these with:

  find . -name '*.c++' | xargs bkt -e 'm,//\s+TODO\s+(\w+),||next; $_=$1;'

...which might show something like:

   john   3    3.7%
   bill   18   22.2%
   jane   23   28.4%
   bob    37   45.7%

If you're more comfortable with sed than perl, you could write the
above as:

  find . -name '*.c++' | xargs sed -n 's,.*//  *TODO  *\([^:]*\):.*,\1,p' | bkt

=head1 AUTHOR

B. Watson <yalhcru@gmail.com>

=head1 LICENSE

WTFPL. See http://www.wtfpl.net/txt/copying/ for full text of license.

=head1 SEE ALSO

B<cut>(1), B<sort>(1), B<perl>(1)

=cut

# by popular demand:
use warnings;
use strict;

# I wish there were a way to do this conditionally.
# no, this didn't work: require 'open.pm'; ::open->import(':locale', ':std');
use open ":locale", ":std";

use Getopt::Std;
# this makes getopts exit after --help:
$Getopt::Std::STANDARD_HELP_VERSION++;

(our $SELF = $0) =~ s,.*/,,;
our $VERSION="0.0.1";

sub HELP_MESSAGE {
	exec "perldoc $0";
}

sub VERSION_MESSAGE {
	print "$SELF $VERSION\n";
}

sub hexify {
	my @out = ();
	push @out, sprintf("%x", ord($_)) for split "", $_[0];
	return join(" ", @out);
}

sub print_histogram {
	my $value = shift;
	my $maxval = shift;
	my $columns = shift;

	my $hist = " " x $columns;
	substr($hist, int($value / $maxval * ($columns - 1)), 1) = "*";
	print $hist;
}

# this bit of 300 baud linenoise replaces all non-ascii characters
# with {\x00} style hex escapes. best viewed with a colorful syntax
# highlighting editor (I like vim).
sub asciify {
	my $in = shift;

	$in =~
		s|
		  (                # capture to $1...
		     [^\x20-\x7e]  # anything outside the range 0x20 - 0x7e
		  )
		|                  # replace with {\xXX}:
		  "{\\x" .
		     sprintf("%02x", ord($1)) .
		  "}"
		|gex;

	return $in;
}

# sub render, sub render, but don't give yourself awaaaayyy
sub render {
	our %opt;
	my $in = shift;
	return  hexify($in) if $opt{x};
	return asciify($in) if $opt{a};
	return $in;
}

# main()
getopts('hcpiwWte:d:f:b:xao:Bs:T:P/:nkFr:Ll:g:v:CH', \our %opt);

# -h == --help
HELP_MESSAGE(), exit(0) if $opt{h};

# -F = -ink/' '
if($opt{F}) {
	$opt{'/'} = ' ';
	$opt{n} = $opt{k} = $opt{i} = 1;
}

# -L = -inkr1
if($opt{L}) {
	$opt{r} = 1;
	$opt{n} = $opt{k} = $opt{i} = 1;
}


# use an eval for -/ so we can handle escapes like \t \n \r
if(defined($opt{'/'})) {
	if(defined($opt{r})) {
		warn "$SELF: -r and -/ given; -/ ignored\n";
	} else {
		$opt{'/'} =~ s/'/\\'/g; # to allow -/"'"
		eval "\$/ = '" .  $opt{'/'} . "'";
	}
}

# -r also uses $/
if(defined($opt{r})) {
	die "$SELF: -r argument must be positive integer\n"
		unless $opt{r} =~ /^\d+$/;
	$/ = \$opt{r};
}

# -o implies -P
if(defined $opt{o}) {
	$opt{P} = 1;
} else {
	$opt{o} = "\t";
}

# -cp implies -P too
$opt{P}++ if $opt{c} && $opt{p};

# handle -d arg. we only support the /i modifier when -d/regex/.
if(defined $opt{d}) {
	if($opt{d} =~ m(^/(.+)/(i?)$)) {
		# qr/$1/$2 is a syntax error, so:
		$opt{d} = $2 ? qr/$1/i : qr/$1/;
	} else {
		$opt{d} = quotemeta($opt{d});
		$opt{d} = qr/$opt{d}/;
	}
	if(not defined($opt{f})) {
		warn "$SELF: -d given without -f, which is pointless\n";
	}
} else {
	$opt{d} = qr/\s+/;
}

# handle -b arg
our @substrargs;
if(defined $opt{b}) {
	my $s;
	for(split /,/, $opt{b}) {
		/^(\d+)$/ && do        { $s = "$1 - 1, 1" };
		/^(\d+)-$/ && do       { $s = "$1 - 1" };
		/^-(\d+)$/ && do       { $s = "0, $1" };
		/^(\d+)-(\d+)$/ && do  { $s = "$1 - 1, " . ($2 - $1 + 1) };
		/^-(\d+)-$/ && do      { $s = "$1"; };
		/^-(\d+)-(\d+)$/ && do { $s = "$1, " . ($2 - $1); };
		die "$SELF: invalid -b argument\n" unless $s;
		push @substrargs, $s;
	}
}

# handle -l arg. similar to but simpler than -b arg.
our ($startrec, $endrec);
if(defined $opt{l}) {
	for($opt{l}) {
		/^(\d+)$/ && do       { $startrec = $endrec = $1 };
		/^(\d+)-$/ && do      { $startrec = $1 };
		/^-(\d+)$/ && do      { $startrec = 1; $endrec = $1 };
		/^(\d+)-(\d+)$/ && do { $startrec = $1 ; $endrec = $2 };
		die "$SELF: invalid -l argument\n" unless $startrec;
	}
}

# -f index starts at 1, perl arrays are indexed from 0, fix (but
# don't break using -1 for rightmost field)
$opt{f}-- if defined $opt{f} && $opt{f} > 0;

# handle the various -s sub-options
our ($revsort, $foldsort, $alphasort, $numsort);
if($opt{s}) {
	for(split "", $opt{s}) {
		/r/ && do { $revsort++;   };
		/f/ && do { $foldsort++;  };
		/a/ && do { $alphasort++; };
		/n/ && do { $numsort++;   };
		/([^rfan])/ && do {
			warn "$SELF: ignoring unknown sort option '$1'\n"; };
	}
}

warn "$SELF: sort opts a and n conflict, ignoring a\n" if $alphasort && $numsort;
warn "$SELF: sort opts f and n conflict, ignoring f\n" if $foldsort && $numsort;

# construct a string of perl code to implement the sort, according
# to the options given. sorry, this is kinda ugly.
our ($a, $b, $A, $B);
$a = $revsort ? '$b' : '$a';
$b = $revsort ? '$a' : '$b';
($A, $B) = $foldsort ? ("lc $a", "lc $b") : ($a,  $b);

our $sortcode = $A .  " cmp " .  $B;
if($numsort) {
	$sortcode = "{ $A <=> $B }"
} elsif($alphasort) {
	$sortcode = "{ $sortcode }";
} else {
	$sortcode = "{ (\$counts{$a} <=> \$counts{$b}) || ($sortcode) }";
}

# the "C" locale causes lots of warnings with 'use open ":locale"'
# enabled, when reading files with non-ascii characters. Turning
# on the -B option avoids that, and causes the output to be printed
# as-is. locale(7) says LC_ALL is checked before LANG, so:
$opt{B}++ if(($ENV{LC_ALL} || $ENV{LANG}) eq 'C');

# undo the 'use open ":locale"' on STDOUT, for binary mode. This means we
# can print binary gibberish to a terminal, but that's the user's fault.
binmode \*STDOUT, ":raw" if $opt{B};

# finally done with option processing, let the main event commence.

our %counts = ();
our $total = 0;
our $longest = 0;
our $readfiles = 0;
our $badfiles = 0;

# Sadly, we can't use the magical while(<>) here to automatically iterate
# and open all the files in @ARGV, because of the -B option. We need to
# call binmode() on each filehandle after it's opened, but before anything
# gets read from it. 'use open ":bytes"' would set the default binmode,
# but I couldn't get it to work conditionally (not even with eval).

$ARGV[0] = '-' unless @ARGV;
for(@ARGV) {
	my $fh;

	if($_ eq '-') {
		$fh = \*STDIN;
	} else {
		open $fh, '<', $_ or do {
			warn "$SELF: $_: $!\n";
			$badfiles++;
			next;
		};
	}

	binmode $fh, ":raw" if $opt{B};
	$readfiles++;

	while(<$fh>) {
		next if defined $startrec && $. < $startrec;
		next if defined $endrec   && $. > $endrec;

		chomp;

		# behave like cut for -b/-f: no warnings if -f3 but only 2 fields exist,
		# or -b10 but only 9 characters exist.

		if(defined $opt{f}) {
			$_ = (split(/$opt{d}/))[$opt{f}];
			$_ = "" unless defined $_;
		}

		if(@substrargs) { # set via $opt{b}
			my $out = "";
			my $in = $_;
			no warnings qw/substr/;
			eval "\$out .= substr(\$in, $_)" for(@substrargs);
			$_ = $out;
			$_ = "" unless defined $_;
		}

		$_ = lc if $opt{i};
		s/^\s+|\s+$//g if $opt{w};
		s/\s//g if $opt{W};
		s/\W//g if $opt{n};

		next if defined $opt{g} && !/$opt{g}/o;
		next if defined $opt{v} && /$opt{v}/o;

		if($opt{e}) {
			no strict;
			no warnings qw/exiting/; # so -e code can "next" to skip a record
			eval $opt{e};
			die "$SELF: $@" if $@;
		}
		next if $opt{k} && (!defined || length == 0);
		$_ = "" unless defined $_;

		print render($_) . "\n" if $opt{C};

		$counts{$_}++;
		$total++;
	}
}

die "$SELF: couldn't read any input files\n" unless $readfiles;

# done reading & counting all input, show the results.
if(!$opt{C}) {
	if($opt{T}) {
		(my ($thresh, $pct)) = ($opt{T} =~ /^(\d+)(%?)/);
		if($thresh) {
			for(keys %counts) {
				delete $counts{$_} if
					($pct && (($counts{$_} * 100 / $total) < $thresh)) ||
					(!$pct && ($counts{$_} < $thresh));
			}
		} else {
			die "$SELF: invalid argument for -T\n";
		}
	}

	my $maxval = 0;
	if($opt{H} || !$opt{P}) {
		for(keys %counts) {
			my $l = length(render($_));
			$longest = $l if $longest < $l;
			$maxval = $counts{$_} if $counts{$_} > $maxval;
		}
	}

	my $histwidth; # TODO: parameterize
	if($opt{H}) {
		chomp($histwidth = int(($ENV{COLUMNS} || `tput cols 2>/dev/null` || 80) / 2));
	}

	# do this instead of using sort { eval $sortcode } in the loop,
	# since eval is slow.
	my $sortsub = eval "sub " . $sortcode;

	for(sort { $sortsub->() } keys %counts) {
		(print_histogram($counts{$_}, $maxval, $histwidth), print $opt{o}) if $opt{H};
		print (my $printable = render($_));
		print " " x ($longest - length($printable)) unless $opt{P};
		print $opt{o} . $counts{$_} unless $opt{p};
		printf "$opt{o}%.1f%%", ($counts{$_} * 100 / $total) unless $opt{c};
		print "\n";
	}

	if($opt{t}) {
		print "\n-- Total count: $total\n";
	}
}

# be like cat, exit with error status if any input file couldn't be
# read (even if we did successfully read others)
exit($badfiles != 0);