#!/usr/bin/perl -w

##############################################################################
#
# A Perl script to convert STDIN or filename arguments to MUSH output.
#
# It doesn't care whether you give it filename(s) on the command line,
# redirect input to it, or if it's in a pipeline, it just does it.  This
# is due to the fact that perl rules of course. :) Enjoy!
#
# - Original idea by Cecil.  None of the original code exists any more.
#
# Copyright (C)  1999, 2001, 2004 Christian J. Robinson.
# 
# This program is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 2 of the License, or (at your option)
# any later version.
# 
# This program is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
# FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for
# more details.
# 
# Comments, questions or bug reports can be sent to infynity@onewest.net
# Make sure to say that your message is regarding the attr program.
# Also, I wouldn't mind knowing how you got a copy.
#
##############################################################################
#
# $Id: attr,v 1.16 2004/11/24 08:13:16 infynity Exp $
#
# $Log: attr,v $
# Revision 1.16  2004/11/24 08:13:16  infynity
# Option to strip raw ANSI color codes. Ignored if --ansi is used.
#
# Revision 1.15  2004/10/03 10:23:32  infynity
# Pipe-fork to gather clipboard data, otherwise -f -c causes problems.
#
# Revision 1.14  2004/10/02 05:55:32  infynity
# *** empty log message ***
#
# Revision 1.13  2004/08/28 07:39:40  infynity
# Tweaks.
#
# Revision 1.12  2004/08/27 20:37:51  infynity
# Slight escaping bug.
#
# Revision 1.11  2004/08/27 20:21:21  infynity
# Option to translate raw ANSI color codes to MUX %c-codes.
#
# Revision 1.10  2001/04/08 12:54:37  infynity
# TODO update
#
# Revision 1.9  2001/04/08 12:39:04  infynity
# --fromclipboard / -f option to read the data from the current selection.
#
# Revision 1.8  2000/11/13 03:24:57  infynity
# Email address change, again.
#
# Revision 1.7  2000/11/03 05:20:13  infynity
# Email address change.
#
# Revision 1.6  2000/10/13 16:48:34  infynity
# Silence warning when bringing in Tk code.
#
# Revision 1.5  2000/08/17 12:35:17  infynity
# Totals weren't printed and the nonewline option didn't work if the -c option was used.
#
# Revision 1.4  2000/07/27 15:17:39  infynity
# --nonewline option.
#
# Revision 1.3  1999/09/23 09:09:34  infynity
# strip option can be provided twice to strip leading whitespace as well.
#
# oneline option can take an argument
#
# Revision 1.2  1999/09/16 13:54:32  infynity
# Fixed selection handling.
#
# Revision 1.1  1999/08/22 09:43:35  infynity
# Initial revision
#
##############################################################################
#
# TODO:  Options to prevent certain translations?
#
##############################################################################


use strict;
use Getopt::Long;

my (@saveARGV, %opts, $nOchars, $nIchars, $clipdata, $alldata);

sub error;
sub read_from_clipboard;
sub translate_ansi($);
sub usage(;$);

Getopt::Long::config qw(bundling);
GetOptions(\%opts,
	"ansi|translate_ansi|translate-ansi|A",
	"strip_ansi|strip-ansi|x",
	"fromclipboard|from_clipboard|from-clipboard|f",
	"clipboard|c",
	"noerrors|no_errors|no-errors|e",
	"oneline|one_line|one-line|o:s",
	"readall|read_all|read-all|a",
	"nonewline|no_newline|no-newline|n",
	"strip|stripwhitespace|strip_whitespace|strip-whitespace|s"
		=> sub{++$opts{'strip'};},
	"totals|showtotals|show_totals|show-totals|t",
	"help|h",
) or usage(1);

usage(0) if ($opts{'help'});

if ($opts{'clipboard'} || $opts{'fromclipboard'})
{
	{ # Suppress a warning, 'cause it doesn't matter here:
		local $SIG{'__WARN__'} = sub { 1; };

		eval{require Tk;}
			or die "Clipboard/fromclipboard option provided, but Tk library not available.\n";
	}

	$opts{'readall'} = 1;
}

if ($opts{'fromclipboard'})
{
	$clipdata = read_from_clipboard;
} elsif (scalar(@ARGV))
{
	@saveARGV = @ARGV;
	@ARGV = ();

	foreach my $file (@saveARGV)
	{
		SWITCH: {

			# Do some file testing:
			(! -e $file) && do
			{
				error ("ERROR: File '$file' does not exist.\n");
				last SWITCH;
			};
			(! -r $file) && do
			{
				error ("ERROR: File '$file' is not readable.\n");
				last SWITCH;
			};

			# 'Default' value of the switch:
			push (@ARGV, $file);
		}
	}

	exit (1) if (!scalar(@ARGV));
}

$alldata = '';

while ($_ = $clipdata ? $clipdata : scalar(<>))
{
	$nIchars += length; # Count the size of the input.  Then process it:

	s/[ \t]+$// if defined($opts{'strip'});
	s/^[ \t]+// if (defined($opts{'strip'}) && $opts{'strip'} > 1);

	s/([\\\{\}\(\)\%])/\\$1/go; # Escape some characters.
	s/\t/\%t/go; # Convert tabs to something MUSH/MUX won't eat.
	s/\ /\%b/go; # Convert spaces to something MUSH/MUX won't eat.
	s/\r//go;    # Eat up ^M's.

	# Convert ANSI color codes to something MUX understands:
	if (defined $opts{'ansi'})
	{
		s/\033\[(\d+(?:;\d+)*)m/translate_ansi($1)/ge;
		s/\033\[m/%cn/go;
	} elsif (defined $opts{'strip_ansi'}) {
		s/\033\[(?:\d+(?:;\d+)*)*m//go;
	}

	s/([\[\]])/\\$1/go; # Escape some more characters.

	# Convert newlines to something MUSH/MUX won't eat:
	if (defined $opts{'oneline'})
	{
		s/\n/$opts{oneline}/go;
	} else {
		s/\n/\%r/go;
	}

	if ($opts{'readall'})
	{
		$alldata .= $_;
	} else {
		print; # Output converted line.
	}

	$nOchars += length; # Count the size of the output.

	# Exit the loop if we grabbed the data from the clipboard:
	last if $clipdata;
}

# If all data is read before output, newline/oneline handling still needs to
# be done:
if ($opts{'readall'})
{
	if (defined $opts{'oneline'})
	{
		# \Q ... \E to prevent the oneline option from becoming a regular
		# expression:
		$alldata =~ s/\Q$opts{oneline}\E$// if $opts{'nonewline'};
	} else {
		$alldata =~ s/%r$// if $opts{'nonewline'};
	}

	# Recompute the number of output characters, it may have changed at this
	# point:
	$nOchars = length $alldata;
}

CLIP: {
if ($opts{'clipboard'})
{
	fork and last CLIP;

	my $mw = new MainWindow;
	$mw->withdraw;
	$mw->update;
	$mw->SelectionOwn(-command => sub{$mw->destroy; CORE::exit 0;});
	$mw->SelectionHandle(sub{substr($alldata, $_[0], $_[1]);});
	$mw->MainLoop;
} else {
	print $alldata if ($opts{'readall'} && $nOchars);

	# Prevents overwriting of the last line of output:
	print "\n" if ($nOchars && (-t STDOUT || $opts{'totals'}));
}
}

print <<"EOF" if ($opts{'totals'});
Number of characters input:  $nIchars
Number of characters output: $nOchars
EOF

sub read_from_clipboard
{
	my ($data, $mw, $pid);

	# Do a pipe-fork because for some reason PerlTk can't handle me invoking it
	# twice to do clipboard operations (-f -c fails without this).

	pipe (READFH, WRITEFH) or die "Can't open a pipe: $!\n";

	if ($pid = fork)
	{
		close(WRITEFH);
		local $/;  # Turn "slurp" mode on.
		$data = <READFH>;
		close(READFH);
	} else {
		close(READFH);

		# Autoflush the write handle:
		select WRITEFH; $| = 1; select STDOUT;

		$mw = new MainWindow;
		$mw->withdraw;
		$mw->update;

		$data = $mw->SelectionGet;
		print WRITEFH $data or die "$!";

		# I would like to avoid doing this, for the possible --clipboard option
		# code, but I fork() there, and that screws things up:
		$mw->destroy;
		undef $mw;

		close(WRITEFH);

		exit 0;
	}

	return $data;
}

sub translate_ansi($)
{
	my $ret = '';
	my $code_string = shift;
	my @codes = split(';', $code_string);

	my %ansi_code_list = (
		0 => '%cn',
		1 => '%ch',
		4 => '%cu',
		5 => '%cf',
		7 => '%ci',

		30 => '%cx',  40 => '%cX',
		31 => '%cr',  41 => '%cR',
		32 => '%cg',  42 => '%cG',
		33 => '%cy',  43 => '%cY',
		34 => '%cb',  44 => '%cB',
		35 => '%cm',  45 => '%cM',
		36 => '%cc',  46 => '%cC',
		37 => '%cw',  47 => '%cW',
	);


	foreach my $code (@codes)
	{
		$code =~ s/^0(\d)$/$1/;
		$ret .= $ansi_code_list{$code};
	}

	$ret;
}

sub error
{
	print STDERR @_ unless ($opts{'noerrors'});
}

sub usage(;$)
{
	my $rval = shift;
	my $pager = ($ENV{'PAGER'} ? $ENV{'PAGER'} : 'less');
	my $where;

	# Don't 'use' this, 'cause we only want it if we hit this code:
	require File::Basename;
	my $BaseName = File::Basename::basename($0);

	my %usage = (
		'--fromclipboard, --from_clipboard, --from-clipboard, -f' => "
  Read the input from the current selection.  (Needs the Perl/Tk module.)",

		'--clipboard, -c' => "
  Don't print the output data, but start a background daemon that owns the
  selection with the data until another application takes the selection.
  (This implies the --readall option.)  (Needs the Perl/Tk module.)",

		'--oneline, --one_line, --one-line, -o  [replace]' => "
  Newlines are stripped, causing the result to be a \"single line\" of data.
  Nothing is substituted in its place unless [replace] is provided.
  (Note that [replace] is not MUSH/MUX escaped, that's your job, and you may
  want to provide spaces around [replace].)",

		'--readall, --read_all, --read-all, -a' => "
  Read all input before outputting.  This doesn't make sense unless you don't
  provide filenames on the command line.  Hit control-d to end input.",

		'--nonewline, --no_newline, --no-newline, -n' => "
  This removes the last %r (or [replace] provided to the -o option) from the
  end of the output.
  (Due to a sort of \"race\" condition, this option is meaningless without the
   -a or -c option.)",

		'--ansi, --translate_ansi, --translate-ansi, -A' => "
  Translate raw ANSI color codes to something MUX can understand.  (These
  don't work for many versions of MUSH).",

		'--strip_ansi, --strip-ansi, -x' => "
  Strip raw ANSI color codes from the input.  This option is ignored if
  --ansi is used.",

		'--strip, --stripwhitespace, --strip_whitespace, --strip-whitespace, -s' => "
  Strip trailing spaces and tabs off each line before processing.
  Provide this option again and it'll strip leading whitespace as well.",

		'--totals, --showtotals, --show_totals, --show-totals, -t' => "
  Print the number of characters input and output when exiting.",

		'--noerrors, --no_errors, --no-errors, -e' => "
  Don't print errors.",
	);

	if ($rval)
	{
		$where = *STDERR;
		print $where "\nUsage: $BaseName [options] [files]\nOptions:\n";
		foreach my $key (sort {lc($a) cmp lc($b)} keys %usage)
		{
			print $where "  $key\n";
		}

		print $where "\n  --help, -h   Shows a more verbose help and exits.\n",
	} else {
		#$where = *STDOUT;
		require IO::File;
		$where = new IO::File "| $pager";
		print $where <<"EOF";
Usage: $BaseName [options] [files]

Reads data from the specified files, or standard input, and processes it to
something suitable for MUSH/MUXes.

Options:
EOF
		foreach my $key (sort {lc($a) cmp lc($b)} keys %usage)
		{
			print $where "$key" . $usage{$key} . "\n\n";
		}

		print $where "--help, -h\n  Show this help and exit.",
	}

	exit $rval;
}

# vim:ts=2:sw=2:ai:fo=croq2:tw=77:nu: