#!/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 }'

=head1 OPTIONS

=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 Output options

=over

=item B<-c>

Show counts only (suppress percentages).

=item B<-p>

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

=item B<-t>

Show total count after all item counts.

=item B<-x>

Print output in hexadecimal.

=item B<-a>

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

=item B<-s> I<opts>

Output sort options. Options may include:

	r - reverse sort (default is ascending)
	a - sort alphabetically (default is by count, then alpha)
	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 -P.

=item B<-P>

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

=back

=head2 Input options

=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<-/>.

=item B<-/> I<sep>

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

=back

=head2 Transform options

=over

=item B<-d> I<delim>

Delimiter for B<-f>. Default: /\\s+/ aka whitespace. This can be a fixed
string or a regular expression (if enclosed in //, with optional /i
modifier). This option does nothing without B<-f>.

=item B<-f> I<field>

Consider only this (B<-d> delimiter separated) field.

=item B<-b> I<range>

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.

=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<-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.

=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

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

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.

B<-b> is like the B<-b> or B<-c> option to cut(1) (depending on whether B<-B> is
set). It 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 to end of record (-1 = last)
	-M-N   from Mth-to-last byte/characters to Nth-to-last

...except that cut allows many ranges separated by commas, while B<bkt>
B<-b> only allows a single range.

B<-d> is like the the -d option to cut(1), except that the delimiter can
be multiple characters. Also, the delimiter is treated as a regular
expression if it's at least 3 characters long *and* enclosed in I<//>. The
/i modifier is supported, but none of the other /x regex modifiers are.

B<-f> like cut's B<-f>, except that it only allows a single field number (not
a list), which is indexed starting from 1 (same as cut)... or a negative
number, meaning the Nth field from the right (-1 = rightmost). Also
unlike cut, B<-f> and B<-b> may be combined (B<-f> is applied first).

The B<-f> B<-b> B<-i> B<-w> B<-W> B<-n> B<-e>I<code> B<-k> options will
be processed 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>).

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 (like perl's own B<-e> option). 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.

=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 -e 'next unless /^\</' channelname.log

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

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, -f2 -b1-3

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%

=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);
}

# 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:L', \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 $substrarg;
if(defined $opt{b}) {
	for($opt{b}) {
		/^(\d+)$/ && do        { $substrarg = "$1 - 1, 1" };
		/^(\d+)-$/ && do       { $substrarg = "$1 - 1" };
		/^-(\d+)$/ && do       { $substrarg = "0, $1" };
		/^(\d+)-(\d+)$/ && do  { $substrarg = "$1 - 1, " . ($2 - $1 + 1) };
		/^-(\d+)-$/ && do      { $substrarg = "$1"; };
		/^-(\d+)-(\d+)$/ && do { $substrarg = "$1, " . ($2 - $1); };
	}
	die "$SELF: invalid -b argument\n" unless $substrarg;
}

# -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);
if($opt{s}) {
	for(split "", $opt{s}) {
		/r/ && do { $revsort++;   };
		/f/ && do { $foldsort++;  };
		/a/ && do { $alphasort++; };
		/([^rfa])/ && do {
			warn "$SELF: ignoring unknown sort option '$1'\n"; };
	}
}

# 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($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>) {
		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($substrarg) { # set via $opt{b}
			no warnings qw/substr/;
			eval "\$_ = substr(\$_, $substrarg)";
			$_ = "" 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};

		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 $_;

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

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

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";
	}
}

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

# done reading & counting all input, show the results.
for(sort { eval $sortcode } keys %counts) {
	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);