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

#
# $Id: 96_tksoap.t,v 1.2 2005/02/03 00:05:55 eserte Exp $
# Author: Slaven Rezic
#

# Another nice cookie with this test script: access the routopedia db:
#     perl -Mblib lib/WE/Server/SOAP.pm -port 12345 
#     perl -I ~/src/bbbike/routopedia/lib/ -MRoutopedia::DB -Mblib t/96_tksoap.t -proxy http://localhost:12345 -doit -rootdir ~/src/bbbike/routopedia/data/

use strict;

use Safe;

use FindBin;
use WE::Obj;
use WE::Util::LangString qw(langstring);

BEGIN {
    if (!eval q{
	use Test::More;
        use Tk;
	use Tk::Tree;
	use Tk::NoteBook;
	use Tk::ObjEditor;
	use SOAP::Lite;
	1;
    }) {
	print "# tests only work with installed Test::More, Tk, Tk::Tree, Tk::NoteBook, Tk::ObjEditor and SOAP::Lite modules\n";
	print "1..1\n";
	print "ok 1\n";
	exit;
    }
}

my $tests = 6;
plan tests => $tests;

use Getopt::Long;

my $doit;
my $proxy = "http://localhost:8123/";
my $rootdir = "$FindBin::RealBin/test";
my $user = "motu";
my $password = "utom";
if (!GetOptions("doit" => \$doit,
		"proxy=s" => \$proxy,
		"rootdir=s" => \$rootdir,
		"user=s" => \$user,
		"password=s" => \$password,
	       )) {
    die "usage: $0 [-doit] [-proxy http://server:port] [-rootdir dir] [-user user] [-password password]";
}

SKIP: {
    skip("Test only work with -doit option", $tests) if !$doit;

    WE::Obj->use_classes(qw/:all/);

    # XXX start server automatically!
    my $uri   = "WE_Sample/Root";
    my $uri2  = "WE/DB/Obj";

    warn <<EOF;

   If you have failures in this script, then please make sure that a
   SOAP proxy is running. Start the proxy with:

      perl -Mblib lib/WE/Server/SOAP.pm <portnumber>

   Then restart the test script with

      perl -Mblib $0 -doit -proxy http://localhost:<portnumber>

EOF

    my $soap = SOAP::Lite->proxy($proxy);
    $soap->uri($uri) if $uri;
    is(defined $soap, 1, "SOAP::Lite object defined");

    my $soap2 = SOAP::Lite->proxy($proxy);
    $soap2->uri($uri2) if $uri2;
    is(defined $soap2, 1, "Other URI also OK");

    my $rootdb = $soap->call
	('new',
	 -rootdir => $rootdir,
	 -connect => 0,
	 -locking => 1)->result;
    #my $rootdb = $soap->call('get_db' => 'WE_Sample::Root', 'sample-eserte');
    is(ref $rootdb, 'WE_Sample::Root', "Got root object");

    is($soap->call('login' => $rootdb,
		   $user, $password)->result, 1, "login success");

    my $objdb = $soap->call('ObjDB' => $rootdb)->result;
    is(ref $objdb, 'WE::DB::Obj', "ObjDB ok");

    my $root_obj = $soap2->call('root_object' => $objdb)->result;
    
    my $mw = MainWindow->new;
    foreach my $w (qw/Tree ObjEditor Text ROText/) {
	$mw->optionAdd("*$w*background", "white");
    }

    my $tree = $mw->Scrolled("Tree", -scrollbars => "osoe",
			     -drawbranch => 1,
			    )->packAdjust(qw/-fill both -expand 1 -side left/);
    traverse_tree_slow($root_obj, "");
    $tree->autosetmode(1);

    use vars qw($popup_entry $popup_id $popup_menu);
    my $real_tree = $tree->Subwidget("scrolled");
    $popup_menu = $real_tree->Menu(-tearoff => 0,
				   -disabledforeground => "darkblue");
    $popup_menu->command(-label => "File:",
			 -state => "disabled");
    #XXX Add code is very rough...
    $popup_menu->command
	(-label => "Add empty document",
	 -command => sub {
	     my $pid = _get_parent_or_self($popup_id);
	     $soap2->call('insert_doc' => $objdb,
			  -Title => "New empty document",
			  -parent => $pid);
	     $soap2->call(flush => $objdb);
	     refresh_current_subtree($popup_entry);
	 });
    $popup_menu->command
	(-label => "Add document/image",
	 -command => sub {
	     my $pid = _get_parent_or_self($popup_id);
	     my $file = $tree->getOpenFile;
	     return unless (defined $file and -r $file);
	     use File::Basename;
	     my $title = basename($file);
	     $soap2->call('insert_doc' => $objdb,
			  -file => $file,
			  -Title => $title,
			  -parent => $pid);
	     $soap2->call(flush => $objdb);
	     refresh_current_subtree($popup_entry);
	 });
    $popup_menu->command
	(-label => "Add folder",
	 -command => sub {
	     my $pid = _get_parent_or_self($popup_id);
	     $soap2->call('insert_folder' => $objdb,
			  -Title => "New folder",
			  -parent => $pid);
	     $soap2->call(flush => $objdb);
	     refresh_current_subtree($popup_entry);
	 });
    $popup_menu->command
	(-label => "Delete",
	 -command => sub {
	     return unless $mw->messageBox(-message => "Are you sure?",
					   -icon => 'question',
					   -type => 'YesNo') =~ /yes/i;
	     my $pid = $soap2->call('parent_ids' => $objdb, $popup_id)->result;
	     $soap2->call(unlink => $objdb, $popup_id, $pid);
	     $soap2->call(flush => $objdb);
	     refresh_current_subtree($popup_entry);
	 });
    $popup_menu->separator;
    $popup_menu->command(-label => "Refresh tree",
			 -command => sub {
			     $tree->delete("all");
			     traverse_tree_slow($root_obj,''); # XXX re-fetch root too
			     #$tree->autosetmode(1);
			 });
    if ($real_tree->can("menu") &&
	$real_tree->can("PostPopupMenu") && $Tk::VERSION >= 800) {
	$real_tree->menu($popup_menu);
	$real_tree->Tk::bind('<3>' => sub {
				 my $w = $_[0];
				 my $e = $w->XEvent;
				 $popup_entry = $w->GetNearest($e->y, 0);
				 return unless defined $popup_entry;
				 my $title = $tree->entrycget($popup_entry, '-text');
				 $popup_id = $tree->entrycget($popup_entry, '-data');
				 $popup_menu->entryconfigure(0, -label => $title);
				 $w->PostPopupMenu($e->X, $e->Y);
			     });
    }
    my $objed;
    my $act_obj;
    my $stored_obj;
    $tree->configure
	(-command => sub {
	     my $entry = $_[0];
	     my $id = $tree->entrycget($entry, '-data');
	     $act_obj = $soap2->call('get_object' => $objdb, $id)->result;
	     make_objeditor();
	 });

    sub _get_parent_or_self {
	my($oid) = @_;
	my $obj = $soap2->call(get_object => $objdb, $oid)->result;
	if (!$obj) {
	    die "Can't get object by id $oid";
	}
	return $obj->Id if ($obj->is_folder);
	my $pid = $soap2->call('parent_ids' => $objdb, $oid)->result;
	$pid;
    }

    sub make_objeditor {
	if (Tk::Exists($objed)) {
	    $objed->destroy;
	}
	$objed = $mw->Frame->pack(qw/-fill both -expand 1 -side left/);
	my $bf = $objed->Frame->pack(qw/-fill x/);
	$bf->Button(-text => 'Cancel',
		    -command => sub {
			$objed->destroy;
		    })->pack(-side => 'left');
	my $get_content;
	$bf->Button(-text => 'Save',
		    -command => sub {
			use Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->Dumpxs([$act_obj],[]);	# XXX
			$soap2->call('replace_object' => $objdb, $act_obj);
			if ($get_content) {
			    my $new_content = $get_content->();
			    $soap2->call('replace_content' => $objdb,
					 $act_obj->Id, $new_content);
			}
			$soap2->call(flush => $objdb);
			$objed->destroy;
		    })->pack(-side => 'left');
	if (1) {
	    $bf->Button(-text => 'Save stored object',
			-command => sub {
			    use Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->Dumpxs([$stored_obj],[]); # XXX
			    $soap2->call('store_stored_obj' => $objdb, $stored_obj);
			    $soap2->call(flush => $objdb);
			    $objed->destroy;
			})->pack(-side => 'left');
	}
	my $nb = $objed->NoteBook->pack(qw/-fill both -expand 1/);;
	my $p1 = $nb->add("Attributes", -label => "Attributes");
	$p1->ObjEditor(caller => $act_obj,
		       direct => 1,
		      )->pack(qw/-fill both -expand 1/);

	if ($act_obj->is_doc) {
	    my $p2 = $nb->add("Content", -label => "Content");
	    my $content = $soap2->call('content' => $objdb, $act_obj->Id)->result;
	    if ($act_obj->ContentType eq 'application/x-perl') {
		my $c = new Safe;
		my $perl_obj = $c->reval($content);
		if ($perl_obj) {
		    $p2->ObjEditor(caller => $perl_obj,
				   direct => 1,
				  )->pack(qw/-fill both -expand 1/);
		    $get_content = sub {
			use Data::Dumper;
			my $dd = new Data::Dumper([$perl_obj],['outdata']);
			$dd->Indent(0);
			$dd->Dump;
		    };
		}
	    } elsif ($act_obj->ContentType =~ /^text\//) {
		my $txt = $p2->Scrolled("Text", -scrollbars => "osoe"
				       )->pack(qw/-fill both -expand 1/);
		$txt->insert("end", $content);
		$get_content = sub {
		    $txt->get("1.0", "end - 1c");
		};
	    } elsif ($act_obj->ContentType =~ /^image\/(.*)/) {
		my $subtype = $1;
		use MIME::Base64;
		eval {
		    if ($subtype eq 'jpeg') {
			require Tk::JPEG;
		    } elsif ($subtype eq 'png') {
			require Tk::PNG;
		    } elsif ($subtype eq 'tiff') {
			require Tk::TIFF;
		    }
		    my $p = $mw->Photo(-data => encode_base64($content));
		    my $l = $p2->Label(-text => langstring($act_obj->Title),
				       -image => $p)->pack(qw/-fill both -expand 1/);
		    #	    $p->delete; # XXX !!!!!
		    # no saving for now...
		}; warn $@ if $@;
	    } else {
		my $txt = $p2->Scrolled("ROText", -scrollbars => "osoe"
				       )->pack(qw/-fill both -expand 1/);
		$txt->insert("end", $content);
		# no saving
	    }
	}

	undef $stored_obj;
	if (1) {
	    my $p3 = $nb->add("Storedobject", -label => "Stored object");
	    $stored_obj = $soap2->call('get_stored_obj' => $objdb, $act_obj->Id)->result;
	    if ($stored_obj) {
		$p3->ObjEditor(caller => $stored_obj,
			       direct => 1,
			      )->pack(qw/-fill both -expand 1/);
	    }
	}
    }

    sub traverse_tree_slow {
	my($obj, $parententry) = @_;
	#warn "$obj $parententry";
	my $entry = ($parententry eq '' ? '' : $parententry . ".") . $obj->Id;
	$tree->add($entry, -itemtype => 'imagetext',
		   $obj->is_folder
		   ? (-image => $mw->Getimage('folder'))
		   : (-image => $mw->Getimage('file')),
		   -text => langstring($obj->Title), -data => $obj->Id);
	my $s = $soap2->call('children' => $objdb, $obj->Id);
	my(@children) = ($s->result, $s->paramsout);
	#use Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->Dumpxs([\@children],[]); # XXX
	foreach my $cobj (@children) {
	    traverse_tree_slow($cobj, $entry);
	}
    }

    sub traverse_tree {		# fast, but does not work anymore?!
	my($obj, $parententry) = @_;
	my $fast_tree = $soap2->call(fast_tree => $objdb, $obj->Id)->result;
	_traverse_tree_fast($fast_tree, $parententry);
    }

    sub _traverse_tree_fast {
	my($t, $parententry) = @_;
	my $entry;
	foreach my $obj (@$t) {
	    if (UNIVERSAL::isa($obj,'HASH')) {
		$entry = ($parententry eq '' ? '' : $parententry . ".") . $obj->{Id};
		$tree->add($entry, -itemtype => 'imagetext',
			   $obj->{'isFolder'}
			   ? (-image => $mw->Getimage('folder'))
			   : (-image => $mw->Getimage('file')),
			   -text => langstring($obj->{Title}), -data => $obj->{Id});
	    } else {
		_traverse_tree_fast($obj, $entry);
	    }
	}
    }

    sub refresh_current_subtree {
	$tree->delete("all");
	traverse_tree($root_obj); # XXX re-fetch root too
	$tree->autosetmode(1);
	#XXX
	return;
	my($entry) = @_;
	(my $parent_entry = $entry) =~ s/\.[^\.]+$//;
	(my $parent_parent_entry = $parent_entry) =~ s/\.[^\.]+$//;
	my $id = $tree->entrycget($parent_entry, '-data');
	my $obj = $soap2->call(get_object => $objdb, $id)->result;
	$tree->delete("entry", $parent_entry);
	warn "deleted $parent_entry, new under $parent_parent_entry";
	traverse_tree($obj, $parent_parent_entry);
    }

    Tk::MainLoop();
    pass("Tk OK");
}

__END__
