package CGIutils;

use strict;
use warnings;

# $Id: CGIutils.pm 20478 2007-04-24 16:29:36Z mca $
our $VSN = (qw$Revision: 20478 $)[1];

# Assume the caller has used SangerPaths if this was necessary.

### Various modules that aren't present on cbi1 or are not used often
### enough to justify always loading them.  They are require()d when
### necessary.
#
# use SangerWeb;
# use JSON;
# use Data::Dumper;

use CGI qw(escapeHTML);

use Exporter 'import';
our %EXPORT_TAGS =
  (all => [qw[ json_call html_json_calls htmlDumper
		IS_LIVE set_DBlogs_for_IS_LIVE
		plaintext_stdout dprof_ensure
		]]);
our @EXPORT_OK = @{ $EXPORT_TAGS{all} };



=head1 NAME

CGIutils - small tools for CGI / mod_perl scripts

=head1 SYNOPSIS

 ### For L<SangerWeb> WRAPPER CLASS
 use CGIutils;

 my %actions = ( "" => \&default_page,
                 query => \&query_page,
                 debug_dump => \&CGIutils::dumpenv_action );
 my %sw_args = ( title => "Demo page",
                 stylesheet => "../main.css" );

 CGIutils->main(\%actions, \%sw_args);
 # request is now handled and reply sent

 # default_page() and query_page() should not print anything, but
 # return a list of scalars which are the HTML of the resulting page.

 ### For IS_LIVE constant flag and use of local DBlogs file
 use CGIutils qq( IS_LIVE set_DBlogs_for_IS_LIVE );
 if (!IS_LIVE) { push @html_output, "<p>We're on devel server</p>" }

 set_DBlogs_for_IS_LIVE();
 require WrapDBI;
 my $dbh = WrapDBI->connect('snpreport', {RaiseError => 1});

 ### For serious debugging
 use CGIutils 'plaintext_stdout';
 BEGIN { plaintext_stdout() }

 ### For profiling
 use CGIutils 'dprof_ensure';
 BEGIN { dprof_ensure() }

=head1 DESCRIPTION

As a class, this is a wrapper on L<SangerWeb> which provides dispatch
to an assortment of CODErefs by use of the C<action> CGI parameter,
plus convenient ways to get hold of the reevant SangerWeb object
during the handling of a query.

There are also some utility functions.

=head1 TRAPPING WARNINGS

A work in progress...  this little mess

  { my @warn;
    $SIG{__WARN__} = sub { push @warn, "@_" };
    sub SangerWeb::footer { die join "\n  ", "Warnings:", @warn if @warn }
  }

won't work with CGIutils::main but it's a start.

=head1 SangerWeb WRAPPER OBJECT

=head2 new()

A normal constructor, providing the usual OO style.

=cut


sub new {
    my ($proto) = @_;
    my $class = ref($proto) || $proto;
    my $self = bless { htmlish => 1 }, $class;
    return $self;
}


# a private global, for use with "local" in object methods
our $_threaded = undef;

=head2 _getCurrent()

Class method.  Return the object which is currently threaded in a
method of this class, or C<undef> if no method of this class is
running.

=cut

sub _getCurrent { return $_threaded }


=head2 _obtainCurrent()

Class or object method.  Find and return an instance of this class,
using the first available of

=over 4

=item

The object on which the method was invoked, if any.

=item

The currently threaded object within the class, as returned by
C<_getCurrent>, if any.

=item

A new object, as returned by C<new>.

=back

It is expected that the called will be a public method in this class,
and that it will do

 my ($called, @args) = @_;
 my $self = $called->_obtainCurrent();
 local $_threaded = $self;

In this way a class method may operate on whichever object is
"currently in use", but the called doesn't have to bother with passing
that object around.

=cut

sub _obtainCurrent {
    my ($called) = @_;
    return ref($called) ? $called : ($called->_getCurrent || $called->new);
}


=head2 needCurrent()

Class or object method.  Find and return an instance of this class,
either the object on which the method was called or the one returned
by C<_getCurrent>.

Dies if neither of these routes provided an object.

=cut

sub needCurrent {
    my ($called) = @_;
    my $self = ref($called) ? $called : $called->_getCurrent;
    die "Method needed a current object but had none" unless $self;
    return $self;
}


=head2 main(\%actions, $sw_args)

Class or object method - operates via C<_obtainCurrent>.

Does "everything" for you.  Call it at the start of a request.  Don't
print anything to C<STDOUT> in the rest of the code.

Generates and outputs data, under control of the query parameter
C<action> and the mandatory argument C<%actions>.  Adds the
L<SangerWeb> header when necessary, then prints to web client.

The optional C<$sw_args> parameter is used to initialise the SangerWeb
object.  See also C<SWconf_add> below, which this function calls.

Possible actions are passed as HASHref to C<%actions>,
 key = action name
 value = CODEref of output generator.

The appropriate CODE to run is looked up by the requested C<$action>,
taking the empty string as the default.

CODE is called with one parameter, which is the L<CGI> object.  CODE
should return a list of data, this will all be printed to the client
between header and footer - unless they are cancelled.

This list of data is printed to STDOUT, and should therefore be HTML
or whatever content-type has been otherwise arranged.  Since v1.11,
instances of L<CGIutils::Output> (code stuck on the end of this
module) may be included too, these are pulled out in order.

XXX: document CGIutils::Output and its subclasses, and use of ARRAYref

=cut

sub main {
    my ($called, $actions, $sw_args) = @_;

    my $self = $called->_obtainCurrent;
    local $_threaded = $self;

    $self->{actions} = $actions;
    $self->SWconf_add($sw_args) if $sw_args;

    # my $prof        = Website::Utilities::Profiler->new;
    my $cgi         = $self->cgi();
    my $action      = $cgi->param('action') || "";

    # Collect all output, then print() it when we know we succeeded.
    # If we error, we'll be glad we didn't already cause "200 OK"
    # status.

    # Find the relevant CODE to call for this $action
    my $code = $actions->{$action};
    if (!$code) {
	my $method = $cgi->request_method;
	die "Unknown action '$action', method=$method";
    }

    # We have CODE to run.  Call it with the $cgi.  Collect the output.
    my @out = $code->($cgi);

    if ($self->htmlish) {
	my $sw = $self->sangerweb();
	# Use SangerWeb to generate <head> and <body> elements.
	# Add to top and bottom of existing output.

	# Pass additional configuration to existing $sw
	unshift @out, $sw->header( $self->_SWconf_take() );
	# push @out, qq(<pre id="profiler">DEBUGGING ), $util->prof->report(), qq(</pre>\n);
	push @out, $sw->footer();

    } else {
	# This action generates its own headers.  Avoid using
	# SangerWeb or generating content-type header.

    }


#  die "oops"; # this works as expected when CGI::Carp is in use

    # Send everything in one go, with support for sending dribbles of
    # newlines to keep the connection alive etc.
    CGIutils::Output->print_all(\*STDOUT, @out);
}


=head2 sangerweb()

Class or object method - operates via C<needCurrent>.

Return the L<SangerWeb> object in use by this object, creating one if
necessary.

=cut

sub sangerweb {
    my $called = shift;
    my $self = $called->needCurrent();
    local $_threaded = $self;

    require SangerWeb;
    return $self->{sangerweb} ||= SangerWeb->new( $self->_SWconf_take() );
}


=head2 cgi()

Class or object method - operates via C<needCurrent>.

Return the L<CGI> object in use by this object, taken via the
C<sangerweb> method.

=cut

sub cgi {
    my $called = shift;
    return $called->sangerweb()->cgi();
}


=head2 SWconf_add(@conf)

Class or object method - operates via C<needCurrent>.

Add to the current object's L<SangerWeb> instance the given
configuration.

@conf may be a list of key/value pairs, or one HASHref as you might
otherwise pass to L<SangerWeb> methods C<new>, C<header> or C<footer>.

Key/value pairs accumulate and are passed to the C<header> call after
content has been generated by the action code, within C<main>,
provided C<SWconf_add> is called before C<main> finishes.  Config
given before C<main> is called, or after it returns, will be ignored.

=cut

sub SWconf_add {
    my ($called, @args) = @_;
    return if !@args; # nothing to do

    my $self = $called->needCurrent();
    local $_threaded = $self;

    # Turn HASHref into array of key/value
    @args = %{ $args[0] } if @args == 1 && ref($args[0]) eq 'HASH';

    my $swconf = $self->{_SWconf} ||= {};
    while (my ($k, $v) = splice @args, 0, 2) {
	$swconf->{$k} = $v;
    }
}

sub _SWconf_take { # private object method
    my $self = shift;
    return( delete $self->{_SWconf} || {} );
}


=head2 htmlish

Class or object method - operates via C<needCurrent>.

Get or set the flag telling whether this request should be server with
L<SangerWeb> content-type, headers and footers.

 CGIutils->htmlish(0); # indicate that the action will generate its own

Set the flag when called with one parameter (a boolean).

Returns the flag in all cases.

=cut

sub htmlish {
    my ($called, @args) = @_;
    my $self = $called->needCurrent();
    local $_threaded = $self;

    if (@args) { # set
	$self->{htmlish} = $args[0];
    }

    return $self->{htmlish};
}

=head1 SEE ALSO

=over

=item

L<Apache::Singleton> or L<Class::Singleton>

=item

L<Aspect::Library::Wormhole>

=item

Roger (rmp)'s L<eps::util> and L<tracking::util> modules.

=back

=head1 AUTHOR

mca@sanger.ac.uk

=cut


#============================================================================

=head1 HTML AND CGI UTILITIES

These subroutines are exportable, either by name or via the :all tag.

 use CGIutils ':all';

=head2 json_call($funcName, @args)

Return text of a Javascript statement which calls $funcName passing
@args.

e.g. the Perl subroutine call
 my %data = ( hash => "value" );
 json_call("poke_it", "stick", \%data);

returns a Perl string containing the Javascript statement
 poke_it("stick", {"hash":"value"});

This string can be passed to the Javascript C<eval()> when it finds
its way into the web page.  It represents the call of the requested
function, using the same data structures (scalar, array or hash) but
encoded in JS.

=cut

sub json_call {
    my ($funcName, @args) = @_;
    require JSON;

    for (my $i=0; $i<@args; $i++) {
	# convert perl array, hash or scalar to Javascript notation
	$args[$i] = (ref($args[$i])
		     ? JSON::objToJson($args[$i])
		     : JSON::Converter->valueToJson($args[$i]));
    }
    my $js_call = $funcName."(".(join ", ", @args).");\n";

    return $js_call;
}


=head2 html_json_calls(@calls)

Where
 @calls = ( [ $funcName, @args ], ... );

Each item in @calls should be a string or ARRAYref.  Strings are
assumed to be the output of C<json_call>.  Arrays will be dereferenced
and passed to C<json_call>.

Returns one string of HTML, which when loaded will make all the calls.
Includes no exception handling (cf. JS C<process_loaded> function in
L<ExoSeq/web-files/ExoCheck/stacker-check.js>).

=cut

sub html_json_calls {
    my @calls = @_;

    # Build the JS call notation
    my @json;
    foreach my $C (@calls) {
	if (!ref($C)) {
	    push @json, $C; # already a JS string
	} elsif (ref($C) eq 'ARRAY') {
	    push @json, json_call(@$C);
	} else {
	    die "Invalid item $C";
	}
    }

    # Build and return HTML form
    return join "\n",
      (qq{<script type="text/javascript">}, @json, qq{</script>},
       qq{<noscript><div class=error><h1>Javascript required</h1></div></noscript>\n});
}


=head2 htmlDumper([ $var ], [ "var" ])

Small wrapper on L<Data::Dumper>, returns one HTML string containing a
dump of all the given data in a C<E<lt>pre class=datadumperE<gt>>
element.

=cut

sub htmlDumper {
    my ($data, $labels) = @_;  #  direct parameters for Data::Dumper

    require Data::Dumper;
    my $D = Data::Dumper->new($data, $labels);
    $D->Quotekeys(0)->Indent(1)->Sortkeys(1);
    my $H = escapeHTML(scalar $D->Dump);
    return "<pre class=datadumper>$H</pre>\n";
}


=head2 IS_LIVE constant

This is rather Sanger-specific.  The constant is defined true/false
based on the presence and value of $ENV{dev} , which is provided by
the Apache setup for intweb and external www.

Originally the compilation of this module failed if it looked like
$ENV{dev} has not been configured.  This has been postponed (allowing
you to avoid testing the unconfigured value) by provided IS_LIVE
as a normal subroutine instead of a constant.

(Hopefully that will allow webpublish to avoid triggering the failure:
it doesn't make an intweb-like %ENV)

=cut

{
    my $compiletime_dev = $ENV{dev};
    my $compiletime_hxfh = $ENV{HTTP_X_FORWARDED_HOST};

    sub IS_LIVE() {
	warn "Detected use of IS_LIVE under webpublish - best to avoid this in BEGIN blocks"
	  unless IS_LIVE_sane();

	die 'Script relies on $ENV{dev} for database choice,
 so you must modify it to run outside intweb'
	  unless defined $compiletime_hxfh
	    && $compiletime_hxfh =~ /^intweb/;
	return ($compiletime_dev ? 0 : 1);
    }

    my $compiletime_webpublishing =
      ($ENV{SCRIPT_FILENAME} =~ m{cgi-bin/wpserver});

    sub IS_LIVE_sane() {
	return (not $compiletime_webpublishing);
    }
}


=head2 set_DBlogs_for_IS_LIVE()

Based on the value of C<IS_LIVE>, configure L<WrapDBI> to use a DBlogs
file in the same directory as the script C<$0>, when we're not live;
or leave the default if we are live.

This code makes various checks to ensure the setting will take effect,
and that the DBlogs file is present if and only if we do want it.
When conditions are wrong it will die with a (hopefully) useful
message.

This relies on the useful property of the L<webpublish> program, that
it will B<not> publish a DBlogs file contained in a cgi-bin directory.

Currently takes no arguments, but could be extended to make debugging
easier.

If it detects that it is running under webpublish, it will set
WRAPDBI_TEST_CONFIG to the name of a file which doesn't exist.

=cut

sub set_DBlogs_for_IS_LIVE() {
    # Check that presence/absence of our local DBlogs file is as
    # expected
    my $local_dblog = $0;
    $local_dblog =~ s{/[^/]+$}{/DBlogs};
    # could accept a parameter to indicate a relative file location?

    # The following is somewhat conservative.  We prefer to kill the
    # program rather than risk running with a dodgy mixture of
    # dev/live setup.

    # WrapDBI only takes notice of that when it is first compiled.
    # If we find the module is already loaded we are too late
    # setting it - bail out.
    die "Oops - called too late to configure DBlogs.
Call set_DBlogs_for_IS_LIVE in a BEGIN block before 'use WrapDBI', or without a BEGIN block and before 'require WrapDBI'"
      if $INC{"WrapDBI.pm"};

    if (not IS_LIVE_sane) {
	# Hack for the sole benefit of webpublish: whether we're live
	# or dev is undefined, so point DBlogs at an empty file.
	require File::Temp;
	my ($fh, $fn) = File::Temp::tempfile("/tmp/DBlogs-CGIutils-webpub.XXXXXX", UNLINK => 1);
	print $fh "# temporary and null database list for CGIutils\n";
	close $fh;
	warn "webpublish mode: setting WRAPDBI_TEST_CONFIG=$fn (empty)\n";
	$ENV{WRAPDBI_TEST_CONFIG} = $fn;
	# It's now safe to call set_DBlogs_for_IS_LIVE inside a BEGIN
	# block, and still pass the webpublish "perl -c" check.
	# Trying to open a WrapDBI connection will fail: DBlogs file
	# is empty.

    } elsif (IS_LIVE xor -f $local_dblog) {
	# Local DBlogs file is (either present or absent) as expected,
	# based on IS_LIVE.

	# Use it if we're not live.
	if (!IS_LIVE) {
	    $ENV{WRAPDBI_TEST_CONFIG} = $local_dblog;
	}
	# when live, we inherit from parent; not sure if this is the Right Thing

    } else {
	my $size = -s $local_dblog;
	$size = (defined $size ? "$size bytes" : "absent");
	die "Unexpected presence/absence of DBlogs file $local_dblog ($size) with IS_LIVE=".IS_LIVE;
    }
}


#============================================================================

=head1 BUILT-IN ACTIONS

=head2 dumpenv_action($cgi)

Code suitable for passing among %actions to C<CGIutils-E<gt>main>.
Returns HTML showing gory details of the query.

This is debug code.  It is not exported, use it by full name in
package.  It may display other possibly-useful info in future.

=cut

sub dumpenv_action {
    my $cgi = shift;

    return ($cgi->Dump,
	    htmlDumper([ \@INC, \%INC, \%ENV ],
		       [qw[ *INC *INC *ENV ]]));
}

=head1 PROFILER CONTROL AND DEBUGGING

=head2 dprof_ensure()

An importable symbol to restart your CGI under L<Devel::DProf>.

  use CGIutils qw( plaintext_stdout dprof_ensure );
  BEGIN { plaintext_stdout(); dprof_ensure() }

The subroutine may take some arguments later.

You may need to C<delete $ENV{PATH}> in the BEGIN block, for taint
mode.  Also it will refuse to work if it's not on a 'dev' site.

It works nicely after a call to C<plaintext_stdout()> although you
will get a spare C<Content-type: text/plain> header on the second run
making three including the original from the CGI script.

Tells you where it stashed the F<tmon.out> output when it starts.
Currently this goes to F</nfs/WWWdev/THINGUMMY_docs/htdocs/tmp/dprof/>
per Roger's instructions in [[SIRT:26177]], they can be fetched from
http://intwebdev.sanger.ac.uk/tmp/dprof/ .

There is not yet a record in the output file or its filename of the
parameters used for the query, but there probably should be.

Before the restart, this call will C<exec> us again or die trying, it
does not return.  After the restart it merely prints a message.

Here's a little Makefile for making the "-Sr" output files after a few
runs.  It works when placed in the parent of F<dprof/> but it should
be stored elsewhere.

 HERE=dprof
 TMONS=$(wildcard $(HERE)/tmon.*.out)
 CHEWED=$(TMONS:.out=.out.Sr.txt) $(TMONS:.out=.out.S.txt)

 all: $(CHEWED)

 tmon.%.out.Sr.txt: tmon.%.out
	 dprofpp -Sr $< > $@.new 2>&1
	 mv $@.new $@

 tmon.%.out.S.txt: tmon.%.out
	 dprofpp -S $< > $@.new 2>&1
	 mv $@.new $@

 .PHONY: parallel

 parallel:
	 ssh seq1a "cd `pwd` && make -j 4"

=cut

sub dprof_ensure {
    if ($INC{"Devel/DProf.pm"}) {
	warn "Running under &dprof_ensure...\n";
    } else {
	die "Don't profile the live site!" unless $ENV{dev};
	_dprof_restart();
    }
}


=head2 plaintext_stdout()

An importable symbole to cause all STDOUT and STDERR from your script
to go to the browser as plain text.  Useful when you've given up
trying to make L<CGI::Carp> work properly and your code won't compile.

  use CGIutils 'plaintext_stdout';
  BEGIN { plaintext_stdout() }

Alternatively the raw form with no dependencies is

  BEGIN { $| = 1; print "Content-type: text/plain\n\n"; open STDERR, ">&STDOUT" or print "Can't dup STDOUT: $!"; }

Put it in the script as early as possible.

=cut

sub plaintext_stdout {
    $| = 1;
    print "Content-type: text/plain\n\n";
    open STDERR, ">&STDOUT" or print "Carrying on anyway: Can't dup STDOUT: $!\n";
}


sub _dprof_restart {
    my $SAFE = qr{[-_a-zA-Z0-9./]};

    # Find out what we have
    my ($perl) = ($^X =~ m{^(/$SAFE+)$})
      or die "Can't untaint perl exe path from $^X with $SAFE";
    my ($script) = ($0 =~ m{^(/$SAFE+)$})
      or die "Can't untaint perl script path from $0 with $SAFE";
    my ($progdir) = ($0 =~ m{^(/$SAFE+)/[^/]+$})
      or die "Can't generate current directory from $0 with $SAFE";

    # Make sure we have somewhere to put the output
#    my $outdir = "$progdir/dprofs";
    my $outdir = __dprofdir();

    # Make sure we're not chasing our tail
    if (exists $ENV{PERL_DPROF_OUT_FILE_NAME}) {
	my @mods = sort keys %INC;
	die "PERL_DPROF_OUT_FILE_NAME already set, did I fail to detect Devel::DProf among (@mods) ?";
    }
    die 'Already in "perl -d" mode according to $^D' if $^D;

    # Set up dprof
    my $now = time();
    my $myapp = $script;
    $myapp =~ s{^/GPFS/data\w*/WWW\w*/}{};
    $myapp =~ s{[^-\w]+}{_}g;

    $ENV{PERL_DPROF_OUT_FILE_NAME} = "$outdir/tmon.$myapp.$now.$$.out";
    warn "PERL_DPROF_OUT_FILE_NAME=$ENV{PERL_DPROF_OUT_FILE_NAME}\n";

    # Run the script again
    die "Wasn't expecting ARGV (@ARGV) for this CGI script" if @ARGV;

    my @cmd = ($perl,
	       (${^TAINT} ? ("-T") : ()),
	       "-d:DProf",
	       $script);
    warn "exec(@cmd)\n";
    exec @cmd
      or die "exec(@cmd) failed: $!";
}


# Find dprof storage directory: ensure it exists and clean old files
sub __dprofdir {
    # We get called early, possibly before SangerWeb is loaded.  When
    # we're just about to exec, time used here doesn't come into the
    # profile.  We must avoid instantiating SW else we may lose POST
    # input, it will have to cope with being a class method.
    require SangerWeb;

    my $tmpdir = SangerWeb->document_root.'/tmp';
    warn "Note: $tmpdir is (normally?) a symlink,\n you can't read it via /nfs/WWWdev\n see http://intwebdev.sanger.ac.uk/tmp/dprof/\n ";

    # Ensure the outdir exists
    my $outdir = "$tmpdir/dprof";
    if (! -d $outdir) {
	if (mkdir $outdir and chmod 0777, $outdir) {
	    warn "*** Made dprof output directory $outdir\n";
	    open my $fh, ">", "$outdir/README.txt";
	    my ($p, $f, $l) = (__PACKAGE__, __FILE__, __LINE__);
	    print $fh <<TEXT;
Directory created for stashing Devel::DProf output
using package $p &_dprof_restart
at $f:$l
TEXT
	    close $fh;
	} else {
	    die "dprof output directory $outdir: doesn't exist, can't create ($!)";
	}
    } elsif (! -w $outdir) {
	die "dprof output directory $outdir is not writable";
    }

    # Clean out the $outdir
    opendir my $dirh, $outdir or die "Can't scan $outdir: $!";
    while (my $leaf = readdir $dirh) {
	next unless $leaf =~ m{^(tmon\..*\.out)$};
	my $fn = "$outdir/$1";
	if (-M $fn > 1) {
	    warn "Cleanup: unlink($fn)";
	    unlink $fn
	      or warn "Failed to tidy up old $fn: $!\n";
	}
    }
    closedir $dirh;

    return $outdir;
}



package CGIutils::Output;

sub new {
    my $proto = shift;
    my $self = bless {}, ref($proto) || $proto;
    my @left = $self->_init(@_);
    die __PACKAGE__." new: args left over (@left)" if @left;
    return $self;
}

sub _init { die "Abstract instantiated" }
sub take_output { die "Abstract has no data" }

sub print_all {
    my ($self, $fh, @data) = @_;

    # can be used as a class method with @data
    unshift @data, $self if ref($self);

    while (@data) {
	my $item = shift @data;
	if (!defined $item) {
	    # a no-op
	} elsif (!ref($item)) {
	    # raw output
	    print $fh $item or die "$self\->print_all:  $!";
	} elsif (ref($item) eq 'ARRAY') {
	    unshift @data, @$item;
	    # continues printing inside the array
	} elsif (UNIVERSAL::isa($item, __PACKAGE__)) {
	    my @out = $item->take_output;
	    unshift @data, $item if @out; # there may be more to come, so leave it on the pile
	    unshift @data, @out; # stuff we need to print
	} else {
	    die "$self\->print_all: don't know what to do with $item";
	}
    }
}


package CGIutils::List;
use base 'CGIutils::Output';

sub _init {
    my ($self, @items) = @_;
    $self->{_items} = \@items;
}

sub take_output {
    my $items = $_[0]->{_items};
    return @$items ? shift @$items : ();
}


package CGIutils::Delayed;
use base 'CGIutils::Output';

sub _init {
    my ($self, $code, @more) = @_;
    die "Need CODEref to make $self" unless ref($code) eq 'CODE';
    $self->{_code} = $code;
    return @more;
}

sub take_output {
    my $code = $_[0]->{_code};
    my @out = $code->();
    return @out;
}

1;
