#!/usr/local/bin/perl
#
# $Id: fileman 454 2014-03-02 14:28:30Z hayashi $
#
# This is a sample program of Term::ReadLine::Gnu perl module.  The
# origin is a C program in the GNU Readline Libarary manual Edition
# 2.1, "2.5.4 A Short Completion Example".  This program is under GPL.
#
# Copyright (C) 1989, 1991 Free Software Foundation, Inc.
#	Original C version
# Copyright (C) 1998 Hiroo Hayashi
#	Perl version

# fileman.c -- A tiny application which demonstrates how to use the
# GNU Readline library.  This application interactively allows users
# to manipulate files and their modes.

use strict;
use warnings;
use Term::ReadLine;

# A structure which contains information on the commands this program
# can understand.

my %commands =
    ('cd'     => { func => \&com_cd,     doc => "Change to directory DIR" },
     'delete' => { func => \&com_delete, doc => "Delete FILE" },
     'help'   => { func => \&com_help,   doc => "Display this text" },
     '?'      => { func => \&com_help,   doc => "Synonym for `help'" },
     'list'   => { func => \&com_list,   doc => "List files in DIR" },
     'ls'     => { func => \&com_list,   doc => "Synonym for `list'" },
     'pwd'    => { func => \&com_pwd,
		   doc  => "Print the current working directory" },
     'quit'   => { func => \&com_quit,   doc => "Quit using Fileman" },
     'rename' => { func => \&com_rename, doc => "Rename FILE to NEWNAME" },
     'stat'   => { func => \&com_stat, doc => "Print out statistics on FILE" },
     'view'   => { func => \&com_view, doc => "View the contents of FILE" },
    );

# The name of this program, as taken from argv[0].
my $progname = $0;

# When non-zero, this global means the user is done using this program.
my $done = 0;

my $term = initialize_readline();		# Bind our completer.
$term->MinLine(0);		## disable implict call of add_history()

# Loop reading and executing lines until the user quits.
while ($done == 0) {
    my $line = $term->readline ("FileMan: ");
    
    last unless defined $line;
    
    # Remove leading and trailing whitespace from the line.  Then, if
    # there is anything left, add it to the history list and execute
    # it.
    my $s = stripwhite($line);
    
    if ($s) {
	$term->AddHistory($s);	## normally this is done implictly
	execute_line($s);
    }
}

exit 0;

# Execute a command line.
sub execute_line {
    my $line = shift;

    my ($word, $arg) = split(' ', $line);

    my $command = find_command ($word);

    unless ($command) {
	printf STDERR "$word: No such command for FileMan.\n";
	return (-1);
    }

    # Call the function.
    return (&{$command->{func}}($arg));
}

# Look up NAME as the name of a command, and return a pointer to that
# command.  Return a NULL pointer if NAME isn't a command name.
sub find_command {
    my $name = shift;

    return $commands{$name};
}

# Strip whitespace from the start and end of STRING.  Return a pointer
# into STRING.
sub stripwhite {
    my $string = shift;
    $string =~ s/^\s*//;
    $string =~ s/\s*$//;
    return $string;
}

#/* **************************************************************** */
#/*                                                                  */
#/*                  Interface to Readline Completion                */
#/*                                                                  */
#/* **************************************************************** */

# Tell the GNU Readline library how to complete.  We want to try to
# complete on command names if this is the first word in the line, or
# on filenames if not.
sub initialize_readline
{
    # Allow conditional parsing of the ~/.inputrc file.
    my $term = new Term::ReadLine 'FileMan';

    # Tell the completer that we want a crack first.
    $term->Attribs->{attempted_completion_function} = \&fileman_completion;

    return $term;
}

# Attempt to complete on the contents of TEXT.  START and END bound
# the region of rl_line_buffer that contains the word to complete.
# TEXT is the word to complete.  We can use the entire contents of
# rl_line_buffer in case we want to do some simple parsing.  Return
# the array of matches, or NULL if there aren't any.
sub fileman_completion {
    my ($text, $line, $start, $end) = @_;

    my @matches = ();

    # If this word is at the start of the line, then it is a command
    # to complete.  Otherwise it is the name of a file in the current
    # directory.
    @matches = $term->completion_matches ($text, \&command_generator)
	if ($start == 0);

    return @matches;
}

# Generator function for command completion.  STATE lets us know
# whether to start from scratch; without any state (i.e. STATE == 0),
# then we start at the top of the list.

## Term::ReadLine::Gnu has list_completion_function similar with this
## function.  I defined new one to be compared with original C version.
{
    my $list_index;
    my @name;

    sub command_generator {
	my ($text, $state) = @_;

	# If this is a new word to complete, initialize now.  This
	# includes saving the length of TEXT for efficiency, and
	# initializing the index variable to 0.
	unless ($state) {
	    $list_index = 0;
	    @name = keys(%commands);
	}

	# Return the next name which partially matches from the
	# command list.
	while ($list_index <= $#name) {
	    $list_index++;
	    return $name[$list_index - 1]
		if ($name[$list_index - 1] =~ /^$text/);
	}
	# If no names matched, then return NULL.
	return undef;
    }
}

#/* **************************************************************** */
#/*                                                                  */
#/*                       FileMan Commands                           */
#/*                                                                  */
#/* **************************************************************** */


# List the file(s) named in arg.
sub com_list {
    my $arg = shift;
    no warnings 'uninitialized';
    return (system ("ls -FClg $arg"));
}

sub com_view {
    my $arg = shift;
    return 1 unless (valid_argument ("view", $arg));

    return (system "more $arg");
}

sub com_rename {
    too_dangerous ("rename");
    return (1);
}

sub com_stat {
    my $arg = shift;

    return (1) unless valid_argument ("stat", $arg);

    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
	$atime,$mtime,$ctime,$blksize,$blocks);

    unless (($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
	     $atime,$mtime,$ctime,$blksize,$blocks) = stat($arg)) {
	print STDERR "$arg: $!\n";
	return (1);
    }

    printf("Statistics for \`$arg\':\n");

    printf("%s has %d link%s, and is %d byte%s in length.\n", $arg,
	   $nlink, ($nlink == 1) ? "" : "s",
	   $size,  ($size == 1) ? "" : "s");
    printf("Inode Last Change at: %s\n", scalar localtime ($ctime));
    printf("      Last access at: %s\n", scalar localtime ($atime));
    printf("    Last modified at: %s\n", scalar localtime ($mtime));
    return (0);
}

sub com_delete {
    too_dangerous("delete");
    return (1);
}

# Print out help for ARG, or for all of the commands if ARG is not
# present.
sub com_help {
    my $arg = shift;
    my $printed = 0;

    if (defined $arg && $commands{$arg}) {
	printf ("%s\t\t%s.\n", $arg, $commands{$arg}->{doc});
	$printed++;
    }

    unless ($printed) {
	defined $arg && print "No commands match \`$arg\'.  Possibilties are:\n";

	foreach (sort keys(%commands)) {
	    # Print in six columns.
	    if ($printed == 6) {
		$printed = 0;
		print "\n";
            }

	    print "$_\t";
	    $printed++;
        }

	print "\n" if ($printed);

    }
    return (0);
}

# Change to the directory ARG.
sub com_cd {
    my $arg = shift;
    unless (chdir ($arg)) {
	print STDERR "$arg: $!\n";
	return 1;
    }

    com_pwd();
    return (0);
}

# Print out the current working directory.
sub com_pwd {
    my $dir = $ENV{PWD} || `pwd`;

    unless ($dir) {
	print ("Error getting pwd: $dir\n");
	return 1;
    }

    print ("Current directory is $dir\n");
    return 0;
}

# The user wishes to quit using this program.  Just set DONE non-zero.
sub com_quit {
    $done = 1;
    0;
}

# Function which tells you that you can't do this.
sub too_dangerous {
    my $caller = shift;
    printf STDERR
	("%s: Too dangerous for me to distribute.  Write it yourself.\n",
	 $caller);
}

# Return non-zero if ARG is a valid argument for CALLER, else print an
# error message and return zero.
sub valid_argument {
    my ($caller, $arg) = @_;
    if (! $arg) {
      printf STDERR ("%s: Argument required.\n", $caller);
      return (0);
    }

    return (1);
}