#!/usr/bin/perl -w
# -*- perl -*-

#
# $Id: we_shell,v 1.13 2005/01/31 22:29:57 eserte Exp $
# Author: Slaven Rezic
#
# Copyright (C) 2004 Slaven Rezic. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Mail: eserte@users.sourceforge.net
# WWW:  http://www.sf.net/projects/we-framework
#

use strict;
use FindBin;

use Getopt::Long;
use Term::ReadLine;
use Term::ReadKey ();
use Text::ParseWords qw(shellwords);
use POSIX qw(strftime);
use File::Spec;
use File::Temp qw(tempfile);
use Data::Dumper;

my %opt;
my $lang;

use WE::DB;
use WE::DB::Info;
use WE::Util::LangString qw(langstring);
use WE::Util::Date qw(isodate2epoch);

my $info = WE::DB::Info->new;
$info->load;
%opt = $info->getopt;

if (!GetOptions(\%opt,
		"rootclass=s",
		"lang=s",
		"lock!",
		"connect!",
		'inc|I=s@',
		"debug!",
	       )) {
    require Pod::Usage;
    Pod::Usage::pod2usage(2);
}

$opt{rootclass} = "WE_Singlesite::Root" if !defined $opt{rootclass};
$lang = $opt{lang} || "en";
$opt{lock} = 0 if !defined $opt{lock};
$opt{connect} = 0 if !defined $opt{connect};

my $debug = $opt{debug};

my $datadir   = shift || ".";

if ($opt{inc}) {
    unshift @INC, @{$opt{inc}};
}	

eval q{use } . $opt{rootclass};
die $@ if $@;

my $root = $opt{rootclass}->new(-rootdir => $datadir,
				-locking => $opt{lock},
				-connect => $opt{connect},
			       )
    or die "Can't create $opt{rootclass} object";
my $objdb = $root->ObjDB;
my $rootclass = $opt{rootclass};

my $cwd_name;
my $cwd_obj;
_update_cwd($objdb->root_object);

my $term = Term::ReadLine->new("we_shell");
my $OUT = $term->OUT || \*STDOUT;
$term->Attribs->{'completion_function'} = \&_complete;

my @quit_commands = qw(exit quit);
my @commands      = qw(ls cd chlang echo meta less more help
		       rm vi objeditor mkdir versions
		       fsck user
		       login logout id grep chown);
# This is for commands which have a same-named function in perl.
my %command_exceptions = map{($_,1)} qw(grep mkdir chown);
my $quit_commands = "^(" . join("|", map { quotemeta $_ } @quit_commands) . ")\$";
$quit_commands = qr($quit_commands);
my $commands      = "^(" . join("|", map { quotemeta $_ } @commands) . ")\$";
$commands = qr($commands);

print "Use help for a list of available commands.\n";

while (defined(my $l = $term->readline("$cwd_name> "))) {
    my @args = shellwords($l);
    my $cmd = shift @args;
    if (defined $cmd && $cmd !~ /^\s*$/) {
	if ($cmd =~ $quit_commands) {
	    last;
	} elsif ($cmd =~ $commands) {
	    eval {
		no strict 'refs';
		if (exists $command_exceptions{$cmd}) {
		    $cmd = $cmd . "_";
		}
		&{$cmd}(@args);
	    };
	    warn $@ if $@;
	} else {
	    warn "Unknown command $cmd\n";
	}
	$term->addhistory($l);
    }
}

sub help {
    print <<EOF;
Implemented commands:
ls        - list objects (documents and folders)
cd        - change current folder
echo      - echo command line (useful for globbing tests)
fsck      - run we_fsck script
user      - run we_user script
chlang    - change default language
meta      - show object meta information
more/less - show object content in a pager
rm        - delete objects
vi        - edit object content
objeditor - call graphical object editor (needs Tk::ObjEditor)
mkdir	  - create a new folder
chown	  - change owner
versions  - show versions
grep	  - search for meta data and/or content
login	  - login as user
logout    - logout
id        - print current user
help      - this help
exit/quit - exit we_shell
EOF
}

sub ls {
    local @ARGV = @_;
    Getopt::Long::Configure("bundling");
    my %opt;
    if (!GetOptions(\%opt, "a", "l", "r")) {
	warn "usage: ls [-alr]";
	return;
    }
    if (@ARGV) {
	warn "File argument NYI";
	return;
    }

    if ($opt{r}) {
	_run_we_script("we_dump",
		       "-root", $cwd_obj->Id,
		       "-class", $rootclass,
		       $datadir,
		      );
	return;
    }

    my @children = $objdb->children($cwd_obj);
    if ($opt{l}) {
	no warnings; # $user etc.
	print join "\n", map {
	    my $file_type = $_->is_folder ? "d" : "-";
	    my $id        = $_->Id;
	    my $user      = substr($_->Owner, 0, 8);
	    my $size      = 0; # NYI
	    my $modtime   = strftime "%x", localtime isodate2epoch($_->TimeModified);
	    my $title     = langstring($_->Title, $lang);
	    sprintf "%s %4d %-8s %6d %-12s %s",
		$file_type, $id, $user, $size, $modtime, $title;
	} @children;
    } else {
	print join "\n", map { langstring($_->Title, $lang) } @children;
    }
    print "\n";
}

sub cd {
    local @ARGV = @_;
    Getopt::Long::Configure("bundling");
    my %opt;
    if (!GetOptions(\%opt) || !@ARGV) {
	warn "usage: cd folder";
	return;
    }
    my $folder = $ARGV[0];
    if ($folder eq '..') {
	if ($cwd_obj->Id eq $objdb->root_object->Id) {
	    # noop
	} else {
	    _update_cwd(($objdb->parents($cwd_obj))[0]);
	}
    } else {
	if ($folder !~ /^\d+$/) {
	    $folder = _id_by_title($folder);
	    if (!defined $folder) {
		warn "Unknown folder";
		return;
	    }
	}
	my $new_cwd = $objdb->get_object($folder);
	if (!$new_cwd) {
	    warn "No folder object with id $folder";
	    return;
	}
	if (!$new_cwd->is_folder) {
	    warn "The object with id $folder is not a folder";
	    return;
	}
	_update_cwd($new_cwd);
    }
}

sub rm {
    local @ARGV = @_;
    Getopt::Long::Configure("bundling", "no_ignore_case");
    my %opt;
    if (!GetOptions(\%opt, "r", "f", "v", "F") || !@ARGV) {
	warn "usage: rm [-rfFv] object ...";
	return;
    }
    my @objects_in_cwd = (_ids_in_cwd(), _objects_in_cwd());
    @ARGV = map { _do_globbing($_, @objects_in_cwd) } @ARGV;
    for my $id (@ARGV) {
	my $obj = $objdb->get_object($id);
	if (!$obj) {
	    warn "Can't get object with id $id.\n";
	    next;
	}
	if ($obj->is_folder && !$opt{r}) {
	    warn "Can't remove folder if -r is not set.\n";
	    next;
	}
	if (!$opt{f}) {
	    my $title = langstring($obj->Title, $lang);
	    if (!defined $title) {
		$title = "with id $id";
	    }
	    print STDERR "Remove object " . $title . " (y/N)? ";
	    chomp(my $yn = <STDIN>);
	    next if ($yn !~ /^y/i);
	}
	my @args;
	if ($opt{F}) {
	    push @args, -links => "unhandled";
	}
	if ($opt{v}) {
	    print STDERR "Unlink " . langstring($obj->Title, $lang) . "...\n";
	}
	$objdb->unlink($id, $cwd_obj->Id, @args);
    }
    if ($opt{F}) {
	warn "Please run fsck in near future...\n";
    }
}

sub echo {
    local @ARGV = @_;
    my @objects_in_cwd = (_ids_in_cwd(), _objects_in_cwd());
    my @objects = map { _do_globbing($_, @objects_in_cwd) } @ARGV;
    print "@objects\n";
}

sub fsck {
    if ($opt{lock}) {
	warn <<EOF;
fsck does not work on a locked database. Please restart the shell without the
-lock option.
EOF
	return;
    }
    # XXX supply rootclass! and other arguments
    my @I = map { "-I$_" } @INC;
    system("$^X", @I, File::Spec->catfile($FindBin::RealBin, "we_fsck"),
	   $datadir);
}

sub user {
    local @ARGV = @_;
    _run_we_script("we_user",  -rootdir => $datadir, @ARGV);
#XXX del:
#     my @I = map { "-I$_" } @INC;
#     my @cmd = ("$^X", @I, File::Spec->catfile($FindBin::RealBin, "we_user"),
# 	       -rootdir => $datadir, @ARGV);
#     #warn "@cmd\n";
#     system @cmd;
#     #if ($?) { warn "@cmd returned $?" }
}

sub chlang {
    local @ARGV = @_;
    if (@ARGV == 0) {
	print "$lang\n";
    } elsif (@ARGV == 1) {
	$lang = $ARGV[0];
    } else {
	warn "usage: chlang [lang]";
    }
}

sub meta {
    local @ARGV = @_;
    my @objects_in_cwd = (_ids_in_cwd(), _objects_in_cwd());
    @ARGV = map { _do_globbing($_, @objects_in_cwd) } @ARGV;
    for my $id (@ARGV) {
	my $obj = $objdb->get_object($id);
	print Data::Dumper->new([$obj], ["obj"])->Indent(1)->Useqq(1)->Dump, "\n";
    }
}

sub _content_to_tempfile {
    local @ARGV = @_;
    my @objects_in_cwd = (_ids_in_cwd(), _objects_in_cwd());
    @ARGV = map { _do_globbing($_, @objects_in_cwd) } @ARGV;
    my($fh, $file) = tempfile(UNLINK => 1, SUFFIX => ".txt");
    for my $id (@ARGV) {
	if (@ARGV > 1) {
	    print $fh "*** $id ***\n";
	}
	my $obj_content = eval { $objdb->content($id) };
	if ($@) {
	    die "Object has no content, original error was: $@";
	}
	print $fh $obj_content;
    }
    close $fh;
    $file;
}

sub more {
    my $f = _content_to_tempfile(@_);
    system("more", $f);
    unlink $f;
}

sub less {
    my $f = _content_to_tempfile(@_);
    system("less", $f);
    unlink $f;
}

sub versions {
    local @ARGV = @_;
    my @objects_in_cwd = (_ids_in_cwd(), _objects_in_cwd());
    @ARGV = map { _do_globbing($_, @objects_in_cwd) } @ARGV;
    if (@ARGV != 1) {
	warn "usage: versions object";
	return;
    }
    my $id = shift @ARGV;
    my $obj = $objdb->get_object($id);
    if (!$obj) {
	warn "Can't get object with id $id.\n";
	return;
    }
    my @version_ids = $objdb->version_ids($id);
    print join(" ", @version_ids), "\n";
}

sub vi {
    local @ARGV = @_;
    Getopt::Long::Configure("no_bundling");
    my %opt;
    if (!GetOptions(\%opt, "meta")) {
	warn "usage: vi [-meta] object\n";
	return;
    }
    if ($opt{meta}) {
	warn "-meta NYI!";
	return;
    }
    my @objects_in_cwd = (_ids_in_cwd(), _objects_in_cwd());
    @ARGV = map { _do_globbing($_, @objects_in_cwd) } @ARGV;
    if (@ARGV != 1) {
	# XXX do not duplicate usage
	warn "Usage: vi [-meta] object\n";
	return;
    }
    my $contentdb = $root->ContentDB;
    my $id = $ARGV[0];
    my $filename = $contentdb->filename($id);
    my($fh, $tempfile) = tempfile();
    require File::Copy;
    File::Copy::cp($filename, $tempfile) or do {
	warn "Can't make backup in $tempfile: $!";
	undef $tempfile;
    };
    system("vi", $filename);
    require File::Compare;
    if ($tempfile) {
	if (File::Compare::compare($filename, $tempfile) == 0) {
	    unlink $tempfile;
	} else {
	    warn "Created backup in $tempfile.\n";
	}
    }
}

sub objeditor {
    local @ARGV = @_;
    my $objid = shift @ARGV;
    if (!defined $objid) {
	warn "usage: objeditor objid\n";
	return;
    }
    eval {
	require Tk;
	require Tk::ObjEditor;
	require Storable;
	my $mw = MainWindow->new();
	local $Storable::forgive_me = $Storable::forgive_me = 1; # peacify -w
	my $obj = Storable::dclone($objdb->get_object($objid));
	$mw->ObjEditor(caller => $obj,
		       direct => 1)->pack(-fill => "both", -expand => 1);
	$mw->update; # XXX?
	my $f = $mw->Frame->pack(-fill => "x");
	my $weiter = 0;
	$f->Button(-text => "Ok", -command => sub { $weiter = +1 })->pack(-side => "left");
	$f->Button(-text => "Cancel", -command => sub { $weiter = -1 })->pack(-side => "left");
	$mw->OnDestroy(sub { $weiter = -1 });
	$mw->waitVariable(\$weiter);
	if ($weiter == 1) {
	    $objdb->_store_obj($obj);
	}
	$mw->destroy if Tk::Exists($mw);
    };
    warn $@ if $@;
}

sub mkdir_ {
    local @ARGV = @_;
    if (!@ARGV) {
	warn "Usage: mkdir folder [folder ...]\n";
	return;
    }
    for my $folder (@ARGV) {
	my %args = (-parent => $cwd_obj,
		    -Title => $folder,
		   );
	my $obj = eval { $objdb->insert_folder(%args) };
	if ($@) {
	    warn "While creating $folder: $@";
	} elsif ($obj) {
	    warn "$folder created\n";
	}
    }
}

sub chown_ {
    local @ARGV = @_;
    if (@ARGV < 2) {
	warn "Usage: chown user object ...\n";
	return;
    }
    my $user = shift @ARGV;
    my @objects_in_cwd = (_ids_in_cwd()); # XXX not yet: , _objects_in_cwd());
    @ARGV = map { _do_globbing($_, @objects_in_cwd) } @ARGV;
    for my $obj_id (@ARGV) {
	my $obj = $objdb->get_object($obj_id);
	$obj->Owner($user);
	$objdb->replace_object($obj);
    }
}

sub login {
    local @ARGV = @_;
    my($user, $password);
    if (@ARGV) {
	$user = shift @ARGV;
    }
    if (@ARGV) {
	warn "Usage: login [username]\n";
	return;
    }
    if (!defined $user || $user eq '') {
	$user = $term->readline("Username: ");
    }
    if (!defined $user || $user eq '') {
	warn "No username given\n";
	return;
    }

    # XXX No password check for now...
    print STDERR "Password: ";
    Term::ReadKey::ReadMode('noecho');
    chomp($password = Term::ReadKey::ReadLine(0));
    Term::ReadKey::ReadMode('normal');

    my $success = $root->identify($user, $password);
    if (!$success) {
	warn "Password mismatch";
	return;
    }

    print "You're logged in as <$user>.\n";
    1;
}

sub logout {
    $root->CurrentUser(undef);
    print "You're not logged anymore.\n";
    1;
}

sub id {
    if (defined $root->CurrentUser) {
	print "You're logged in as <" . $root->CurrentUser . ">.\n";
    } else {
	print "You're not logged in.\n";
    }
}

sub grep_ {
    local @ARGV = @_;
    Getopt::Long::Configure("no_bundling");
    my %opt;
    if (!GetOptions(\%opt, "meta", "content", "r", "i")) {
	warn "usage: grep [-meta] [-content] [-r] [-t] term object ...\n";
	return;
    }
    if (!$opt{meta} && !$opt{content}) {
	$opt{content} = 1;
    }
    my $term = shift @ARGV;
    eval {
	if ($opt{i}) {
	    $term = qr{^(.*$term.*)$}im;
	} else {
	    $term = qr{^(.*$term.*)$}m;
	}
    };
    if ($@) {
	warn "Wrong regexp in pattern <$term>: $@";
	return;
    }
    my @objects_in_cwd = _ids_in_cwd();
    @ARGV = map { _do_globbing($_, @objects_in_cwd) } @ARGV;
    my @objects;
    if ($opt{content}) {
	@objects = map { _recursive_without_dirs($_) } @ARGV;
    } else {
	@objects = map { _recursive_with_dirs($_) } @ARGV;
    }
    my @res;
    for my $obj (@objects) {
	my $add_match = sub {
	    my($content) = @_;
	    if ($content =~ $term) {
		push @res, [$obj, $1];
		1;
	    } else {
		0;
	    }
	};
	my $added;
	if ($opt{meta}) {
	    require Data::Dumper;
	    $added = $add_match->(Data::Dumper->new([$obj],['o'])->Indent(1)->Dumper);
	}
	if ($opt{content} && !$added) {
	    $add_match->($objdb->content($obj->Id));
	}
    }
    for my $res (@res) {
	my($res_obj, $match_line) = @$res;
	printf "%s\t%s: %s\n", $res_obj->Id, langstring($res_obj->Title, $lang), $match_line;
    }
}

######################################################################
# Helpers

sub _run_we_script {
    my(@args) = @_;
    my $prog = shift @args;
    my @I = map { "-I$_" } @INC;
    my @cmd = ("$^X", @I, File::Spec->catfile($FindBin::RealBin, $prog),
	       @args);
    warn "@cmd\n" if $debug;
    system @cmd;
    if ($?) { warn "@cmd returned $?\n" }
}

sub _recursive_without_dirs {
    my($id) = @_;
    my @res_o;
    my $o = $objdb->get_object($id);
    if ($o->is_folder) {
	for my $child_id ($objdb->children_ids($o)) {
	    push @res_o, _recursive_without_dirs($child_id);
	}
    } else {
	push @res_o, $o;
    }
    @res_o;
}

sub _recursive_with_dirs {
    my($id) = @_;
    my @res_o;
    my $o = $objdb->get_object($id);
    if (!$o) {
	warn "No object for id $id, maybe fsck is needed?\n";
	return;
    }
    push @res_o, $o;
    if ($o->is_folder) {
	for my $child_id ($objdb->children_ids($o)) {
	    push @res_o, _recursive_with_dirs($child_id);
	}
    }
    @res_o;
}

sub _complete {
    my $pat = $_[1];
    if ($pat =~ /^(\S+)\s+(.*)/) {
	# doc/folder completion
	my $cmd = $1;
	my $doc_or_folder_pattern = $2;
	if ($doc_or_folder_pattern =~ /\s(\S+)$/) {
	    $doc_or_folder_pattern = $1;
	}
	my @docs_and_folders;
	if ($cmd eq 'cd') {
	    @docs_and_folders = (_folders_in_cwd(), _folder_ids_in_cwd());
	} else {
	    @docs_and_folders = (_objects_in_cwd(), _ids_in_cwd());
	}
	map { _escape($_) } grep { index($_, $doc_or_folder_pattern) >= 0 } @docs_and_folders;
    } else {
	# command completion
	# escape not necessary here --- no commands with spaces etc.
	grep { index($_, $pat) >= 0 } (@quit_commands, @commands);
    }
}

sub _escape {
    my $string = shift;
    if ($string =~ /\s/) {
	qq{"$string"};
    } else {
	$string;
    }
}

sub _do_globbing {
    my($pattern, @objects) = @_;
    my $rx = glob2regex($pattern);
    my @hits = grep { /$rx/ } @objects;
    if (@hits == 0) {
	$pattern;
    } else {
	@hits;
    }
}

sub _folders_in_cwd {
    map { langstring($_->Title, $lang) }
    grep { $_->is_folder }
    $objdb->children($cwd_obj);
}
sub _objects_in_cwd {
    map { langstring($_->Title, $lang) } $objdb->children($cwd_obj);
}
sub _folder_ids_in_cwd {
    map { $_->Id }
    grep { $_->is_folder }
    $objdb->children($cwd_obj);
}
sub _ids_in_cwd {
    $objdb->children_ids($cwd_obj);
}
sub _update_cwd {
    $cwd_obj  = shift;
    $cwd_name = langstring($cwd_obj->Title, $lang);
}
sub _id_by_title {
    my $title = shift;
    for my $obj ($objdb->children($cwd_obj)) {
	if ($title eq langstring($obj->Title, $lang)) {
	    return $obj->Id;
	}
    }
    undef;
}

# This is taken from
# http://wuarchive.wustl.edu/mirrors/NetBSD/NetBSD-current/pkgsrc/pkgtools/pkglint/files/lintpkgsrc.pl
sub glob2regex
    {
    my($glob) = @_;
    my(@chars, $in_alt);
    my($regex);

    @chars = split(//, $glob);
    while (defined($_ = shift @chars))
	{
	if ($_ eq '*')
	    { $regex .= '.*'; }
	elsif ($_ eq '?')
	    { $regex .= '.'; }
	elsif ($_ eq '+')
	    { $regex .= '.'; }
	elsif ($_ eq '\\+')
	    { $regex .= $_ . shift @chars; }
	elsif ($_ eq '.' || $_ eq '|' )
	    { $regex .= quotemeta; }
	elsif ($_ eq '{' )
	    { $regex .= '('; ++$in_alt; }
	elsif ($_ eq '}' )
	    {
	    if (!$in_alt)		# Error
		{ return undef; }
	    $regex .= ')';
	    --$in_alt;
	    }
	elsif ($_ eq ','  && $in_alt)
	    { $regex .= '|'; }
	else
	    { $regex .= $_; }
	}
    if ($in_alt)			# Error
	{ return undef; }
    if ($regex eq $glob)
	{ return(''); }
    if ($opt{D})
	{ print "glob2regex: $glob -> $regex\n"; }
    '^'.$regex.'$';
    }

__END__

=head1 NAME

we_shell - a simple interactive shell for accessing the web.editor databases

=head1 SYNOPSIS

     we_shell [-rootclass class] [-lang language] [-lock] [-connect] [datadir]

=head1 DESCRIPTION

C<-datadir> is optional, otherwise the current directory will be used.

Set C<-connect> for a persistent connection to the berkeley db to
speed some operations up.

=head1 EXAMPLE

Calling C<we_shell> with a special root class is somewhat complicated
(I hope the we_data meta file will come some day...):

    cd .../we_data
    # only if needed, and use the /bin/sh syntax if appropriate
    setenv PERL5LIB ../lib
    we_shell -rootclass WE_myproject::Root .

=head1 AUTHOR

Slaven Rezic

=head1 SEE ALSO

=cut
