package CGI::Auto;

use warnings;
use strict;

use IO::Socket::UNIX;
use constant SOCKET_FILE => '/tmp/cgiauto.socket';
use Data::Dumper;

## no encoding;
##use encoding "utf8";

use CGI qw{:standard :cgi-lib};
my %pred_tohtml;
BEGIN{
 %pred_tohtml=(
   txt     => sub{ pre($_[0])},
   table   => sub{ my ($txt,$a)=@_;
       my $fs = $a->{fs} || qr{\s*:\s*};
       my $rs = $a->{rs} || qr{\n};
       my $h  = $a->{th} ? (ref $a->{th} ? Tr(th($a->{th})): $a->{th}):"";  ## header
       my $tabop = {-border=>"1pt",-width => "95%"};
       table($tabop,$h,Tr( [ map { td( [split(/$fs/,$_)] ) } split (/$rs/,$txt)]))},
   items         => sub{ ul(li([split(/\n/,$_[0])])) },
   enumeration   => sub{ ol(li([split(/\n/,$_[0])])) },
   html          => sub{ $_[0] },
  );
}

=head1 NAME

CGI::Auto - CGI from a unix command

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.02';


=head1 SYNOPSIS

    use CGI::Auto;

    CGI::Auto::auto(title => "Proverbs",
                  command => "grep [%s(pattern)] /home/jj/prov.dic");

    CGI::Auto::auto(title => "Test upload file and wc",
                command   => "wc [%f(e2)]",
                dir       => "/tmp",
	            tohtml    => "table",
                th        => ["", "Lines","Words","Chars","Filename"],
                fs        => qr{\s+});

    CGI::Auto::auto(
                command => "grep [%o(op)] [%s(pattern)] /home/jj/prov.dic"
                -op => [ ignore_case => "-i",
                         not_containing => "-v"]);

    CGI::Auto::auto(
      command  => "grep [%o(option)] [%s(pattern)] proverb.dic"
                   . "| grep -w [%c(tipo)]"
                   . "| /usr/local/bin/tabproj -fs=':' 1",
      -option  => [ ignore_case    => "-i",
                    not_containing => "-v", "full_word" => "-w"],
      -tipo    => [ "ridle"      => "ridle",
                    "proverbs"   => "prov"],)  


=head1 EXPORT

A list of functions that can be exported.  You can delete this section
if you don't export anything, such as for a purely object-oriented module.


=head1 Type of input fields

 [%s(name)]   string

 [%f(file)]   file uploading

 [%c(destination)]   choice by radio buttons
    -destination  => [ France => "FR", Portugal => "PT]

 [%o(opt)]   select a set of options
    -opt  => [ ignore_case    => "-i","full_word" => "-w"]

=head1 FUNCTIONS

  command|make    
     ex:      command => "grep -i [%s(pattern)] [%f(file)]",
     Command returns  utf8-encoded output   

  latin1
     use   "latin1 => 1"    if command's output is latin
  
  ?title 
     title of the page

  ?dir ={ work, download[/tmp/__auto$$/], url_down },
  ?email ={from,type='link|attach'}, (defaults to link)
  ?output = filename | [filename*]
  ?args = id->{type["textfield"],label[id],prototype["string"]},

  ?tohtml = sub{ ...}
      function to  process the output 

  ?scrap  --> bocado de html em vez de full page
  ?type -> batch | undef

  auto(command =>"grep -i [%s(pattern)] [%f(file)]");


=head2 Page content

The page generated by CGI::Auto::auto(... ) has the following structure
(values default to "" if not provided)

  -begin                  
  title                  
  description           

  for each input field:

    -field_before
    field
    -field_after

  submit
  -end

=head2 auto

 CGI::Auto::auto(title => "Portuguese Proverbs",
    command     => "grep [%s(pattern)] /home/jj/prov.dic",
    description => "Grep in action!",
    tohtml      => "items",
 );

=head3 tohtml

 tohtml => (items | enumeration | table | html | sub{ ... })
 
Table may have extra C<fs> or C<rs> ou C<th> (headers).

 tohtml => "table",
    fs  => qr{\s*=\s*},
    th  => ["name","age"],   or...  
                             th  => Tr(th(["name","age"])),

=cut

sub auto {
    my %a = @_;

    my $mimeout  =  1         if exists($a{mimetype}) && param();
    $a{scrap} =  1            if $mimeout;
    $a{type}  = "batch"       if exists($a{email});

    # title is optional. by default, empty.
    $a{title} ||= "";
    $a{type}  ||= "";

    if($mimeout) {
##      binmode(STDOUT,":utf8");
      print header(-type=>$a{mimetype}) ;
    } else {
      binmode(STDOUT,":utf8");
      print header(-charset=>'utf-8'), start_html($a{title}) unless $a{scrap};
    }

    my ($com, $arg, $fields,$outfiles) = _proc2args(%a);
    my $com_r;

    push(@$fields, ["email".textfield("_email").br,50,"email"]) 
       if exists($a{email});

    # XXX - Rever o uso do url() no caso de ser um form embutido
    _mkform($fields,%a) unless $mimeout;

    # XXX - FIXME : just to start...
    # XXX - /!\ DANGER!!! /!\
    if (param()) {
        if ($a{type} eq "batch") {
            print "Your request was recorded in a job queue.";
            print "When it finish you will receive a notification email.";
            if ($a{web_publish} && $a{local_publish}) {
                print _download_text(
                                     {%a, 
                                      output_file => (@$outfiles==1 ?  $outfiles->[0]: $outfiles)});
            }
            my $server_feed = `ps ax`; 
            if(_is_server_runing()){
               print h5("Server OK") if $a{debug}; 
               _ask_server( {
                  %a,
                  command => $com,
                  output_file => (@$outfiles==1 ? $outfiles->[0]: $outfiles),
                  (exists($a{email}{from})?(email_from => $a{email}{from}):()),
                  email_to => param("_email"),
                  ($a{debug}?(debug => 1 ):()),
                  (($a{email}{type} and $a{email}{type} eq "attach")?
                  (email_attach => 1) : ()),
                          });
            } else { 
               print h5("Server is not Running") if $a{debug};
               print h2("Error: server is not running");
            }
        }
        else {
            print h5($a{command}, br, $com) if $a{debug};

            open(F,"-|",$com) or warn("problems with $com\n");
            binmode(F,":utf8") unless $a{latin1};
            $com_r=join("",<F>); 
            close F;

            if ($mimeout) {
                print $com_r;
            } elsif (ref $a{tohtml}) {
                print $a{tohtml}->($com_r);
            } elsif( defined $pred_tohtml{$a{tohtml}}) {
                print $pred_tohtml{$a{tohtml}}->($com_r,\%a);
            } else {
                print pre($com_r);
            }
            print h5("Error:" ,$!, $@) if $a{debug} && ($! or $@);
        }
    }
    print end_html unless $a{scrap};
}

sub _is_server_runing{
 my $server_feed = `ps ax`; 
 $server_feed =~ /\bcgi-auto-server\b/;
}

sub _mkform { my ($fields,%a) = @_;

    print $a{-begin}        if $a{-begin};
    print h3($a{title})     if $a{title} ;
    print $a{description}   if $a{description} && !param() ;

    print start_multipart_form, "\n"; 
    for my $f ( sort {$a->[1] <=> $b->[1]} @$fields) {
        print $a{"-$f->[2]_before"} if $a{"-$f->[2]_before"};
        print "$f->[0]\n";
        print $a{"-$f->[2]_after"} if $a{"-$f->[2]_after"};
    }
    print submit("submit","\x{21B4}"), end_form, p;
    print $a{-end} if $a{-end};
}

sub _ask_server {
    my $hash = shift;
    print h5(pre(Dumper($hash))) if $hash->{debug};
    $Data::Dumper::Indent = 0;
    
    my $socket = IO::Socket::UNIX->new(Type => SOCK_DGRAM,
                                       Peer => SOCKET_FILE);
    $socket->send(Dumper($hash));
    $socket->close;
}

sub _download_text {
  my $x = shift;
  my $email_body = $x->{email_body} 
                 || <<"EOTEXT";
<p>When it ends, you can download the final files from
[% web_publish %]/[% output_file %]
</p>
<p>Note that it might get removed if you do not download it for
seven days.</p>
EOTEXT

    $email_body =~ s/\[%\s*output_file\s*%\]/_fname($x->{output_file})/ge;
    $email_body =~ s/\[%\s*([^ %]+)\s*%\]/$x->{$1} || ""/ge;
    $email_body =~ s!(http://\S+)!<a href="$1">$1</a>!g;
    
    return $email_body;
}

sub _fname{
 my $a = shift;
 $a =~ s!.*/!!;
 $a
}

sub _proc2args{
    my %a = @_;
    my $c = $a{command};
    my @args = ();
    my $fields = [];     ## form fields contents
    my $outfiles = $a{output} || [];   ## output files
    my $pars = Vars();
    my $dir= $a{dir} || "/tmp";

    for (keys %$pars){
       if($pars->{$_} =~ /\'/){print "Error: ' not allowd in arguments\n";die;}
    }

    for ($c) {
        ### search for patterns ([%s(name)])
        # XXX - /!\ DANGER /!\ -- TESTAR ' DENTRO DO COMANDO
        s{\[%(\w+)(?:#(\d+))?\((.*?)\)\]}{ 
          push(@args,[$1,$3,($2||50)]); 
          if   ($1 eq "s"){ $pars->{$3} ? "'$pars->{$3}'" : "''" }             ##string
          elsif($1 eq "f"){ _tmpfile($3,$dir,"IN") }                           ##fileupload
          elsif($1 eq "of" or $1 eq "outfile"){ _tmpfile($3,$dir,"OUT") }      ##output file
          elsif($1 eq "o"){ no warnings;  $pars->{$3} =~ y/\x{00}/ / ; $pars->{$3} || "" }   ##options
          elsif($1 eq "c"){ $pars->{$3} || "" }                                ##choice
        }ge;
    }

    for my $z (@args) {
        if ($z->[0] eq "s") { ## String
            push(@$fields, ["$z->[1] ". textfield($z->[1]).br  ,$z->[2],$z->[1]] );
        }
        if ($z->[0] eq "of" or $z->[0] eq "outfile") { ## output file 
            push(@$outfiles, _tmpfile($z->[1],$dir,"OUT"));
        }
        if ($z->[0] eq "f") { ## file upload
            push(@$fields, ["$z->[1] ". filefield($z->[1]).br  ,$z->[2],$z->[1]] );
            _saveuploadedfile($z->[1],$dir) if $pars->{$z->[1]};
        }
        if ($z->[0] eq "o") { ## comand options   TESTING
            (print "Error: '-$z->[1]' options definition missing\n" and die) unless $a{"-$z->[1]"};
            my @vt  = @{$a{"-$z->[1]"}};
            my $aux= 1;
            my $v =  [ grep {$aux = not $aux} @vt ] ;
            my $ls = +{reverse @vt};
            push(@$fields, map{[$_,$z->[2],$z->[1]]} checkbox_group(-columns=>8,-name=>$z->[1], -values=>$v, -labels=>$ls));
        }
        if ($z->[0] eq "c") { ## comand options   TESTING
            (print "Error: '-$z->[1]' choice definition missing\n" and die) unless $a{"-$z->[1]"};
            my @vt  = @{$a{"-$z->[1]"}};
            my $aux= 1;
            my $v =  [ grep {$aux = not $aux} @vt ] ;
            my $ls = +{reverse @vt};
            #push(@$fields, popup_menu(-name=>$z->[1], -values=>$v, -labels=>$ls));
            push(@$fields, map{[$_,$z->[2],$z->[1]]} radio_group(-columns=>8,-name=>$z->[1], -values=>$v, -labels=>$ls));
        }
    }
    return ($c, \@args, $fields,$outfiles);
}

sub _tmpfile{
  my ($name,$dir,$i_o)=@_;
  $i_o="IN" unless $i_o;
  my $ext;
  if($i_o eq "IN"){ 
    $ext = param($name);
    ($ext and $ext =~ s/.*\.//) or $ext = "no-ext-provided"; } 
  elsif($name =~ m/(.*)\.(.*)/){ $name = $1; $ext=$2}
  else                         { $ext = "no-ext-provided"}  
  mkdir "$dir"     unless -d "$dir";
  mkdir "$dir/IN"  unless -d "$dir/IN";
  mkdir "$dir/OUT" unless -d "$dir/OUT";
  "$dir/$i_o/$name-$$.$ext";
}
  

sub _saveuploadedfile{
  my ($name, $dir) = @_;
  my $buffer;
  my $fh = upload($name);
#  binmode($fh);
#  print pre(Dumper({ fh => $fh })),"\n\n";
  my $tmp = _tmpfile($name, $dir);
  local $/;
  undef $/;
  open (OUTFILE,">:raw",$tmp) or die("cant crete tmp file ($tmp)\n");
  print OUTFILE <$fh>;
  close OUTFILE;

#  open OUTFILE, ">", "$tmp";
#  while (read($fh,$buffer,1024)) {
#     print OUTFILE $buffer;
#  }
#  close OUTFILE;
  $tmp
}

sub _log {
  
}

=head1 AUTHOR

Alberto Simoes, C<< <ambs at di.uminho.pt> >>
J.Joao Almeida, C<< <jj at di.uminho.pt> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-cgi-auto at
rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CGI-Auto>.  I will be
notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc CGI::Auto

You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CGI-Auto>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/CGI-Auto>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/CGI-Auto>

=item * Search CPAN

L<http://search.cpan.org/dist/CGI-Auto/>

=back


=head1 ACKNOWLEDGEMENTS


=head1 COPYRIGHT & LICENSE

Copyright 2009-2010 Projecto Natura.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


 ######## STRUCT SPECS ################################################
 #     FIELD    |OBRIG| DESCRIPTION                                   #
 #----=---------------------------------------------------------------#
 # command      | SIM | Command                                       #
 # output_file  | SIM | String or ArrayRef with files                 #
 #              |     | If ArrayRef, zip and put to download          #
 # local_publish| NAO | Where to put the files to downloadn           #
 # web_publish  | NAO | URL of the files to download                  #
 # work_dir     | NAO | Working dir (def: /tmp)                       #
 # email_to     | SIM | Email to send the results                     #
 # email_from   | NAO | Email's From                                  #
 # email_subject| NAO | Subject                                       #
 # email_body   | NAO | email template; var from this table           #
 #              |     | [% web_publish %] and similar are interpolated#
 # email_attach | NAO | Boolean. Defaults to false.                   #
 # content_type | NAO | defaults to 'text/plain' or zip...            #
 ######################################################################

=cut

1; # End of CGI::Auto