#!/usr/bin/perl -w

#
# dbpipeline.pm
# Copyright (C) 2007 by John Heidemann <johnh@isi.edu>
# $Id$
#
# This program is distributed under terms of the GNU general
# public license, version 2.  See the file COPYING
# in $dblibdir for details.
#

package Fsdb::Filter::dbpipeline;

=head1 NAME

dbpipeline - allow db commands to be assembled as pipelines in Perl

=head1 SYNOPSIS

    use Fsdb::Filter::dbpipeline qw(:all);
    dbpipeline(
        dbrow(qw(name test1)),
        dbroweval('_test1 += 5;')
    );

=head1 DESCRIPTION

This module makes it easy to create threaded pipelines in Perl.

By default (as with all Fsdb modules), input is from STDIN and output
to STDOUT.  Two helper functions, fromfile and tofile can grab
data from files.

Dbpipeline differs in several ways from all other Fsdb::Filter modules:
it does not have a corresponding Unix command (it is used only from
within Perl).
It does not log its presence to the output stream (this is arguably a bug,
but it doesn't actually do anything).


=head1 OPTIONS

Unlike most Fsdb modules, dbpipeline defaults to C<--autorun>.

=for comment
begin_standard_fsdb_options

This module also supports the standard fsdb options:

=over 4

=item B<-d>

Enable debugging output.

=item B<-i> or B<--input> InputSource

Read from InputSource, typically a file name, or C<-> for standard input,
or (if in Perl) a IO::Handle, Fsdb::IO or Fsdb::BoundedQueue objects.

=item B<-o> or B<--output> OutputDestination

Write to OutputDestination, typically a file name, or C<-> for standard output,
or (if in Perl) a IO::Handle, Fsdb::IO or Fsdb::BoundedQueue objects.

=item B<--autorun> or B<--noautorun>

By default, programs process automatically,
but Fsdb::Filter objects in Perl do not run until you invoke
the run() method.
The C<--(no)autorun> option controls that behavior within Perl.

=item B<--help>

Show help.

=item B<--man>

Show full manual.

=back

=for comment
end_standard_fsdb_options


=head1 SEE ALSO

L<Fsdb(3)>


=head1 CLASS FUNCTIONS

=cut

@ISA = qw(Fsdb::Filter);
($VERSION) = 2.0;

use Exporter 'import';
@EXPORT = ();
@EXPORT_OK = qw(
    dbpipeline_filter
    dbpipeline_sink
    dbpipeline_open2
    dbpipeline_close2_hash
);
# update them here, in toplevel Makefile.PL, and below in the documentation.
# and add dbpipeline to this list
# BEGIN AUTOGENERATED VARIABLE SECTION
# This next section is managed by update_modules.  DO NOT EDIT DIRECTLY.
our @modularized_db_programs = qw(
	dbcol
	dbcolcopylast
	dbcolcreate
	dbcoldefine
	dbcolhisto
	dbcolmerge
	dbcolmovingstats
	dbcolneaten
	dbcolpercentile
	dbcolrename
	dbcolscorrelate
	dbcolsplittocols
	dbcolsplittorows
	dbcolsregression
	dbcolstats
	dbcolstatscores
	dbfilealter
	dbfilediff
	dbfilepivot
	dbfilestripcomments
	dbfilevalidate
	dbformmail
	dbjoin
	dbmapreduce
	dbmerge
	dbmerge2
	dbmultistats
	dbrow
	dbrowaccumulate
	dbrowcount
	dbrowdiff
	dbroweval
	dbrowuniq
	dbrvstatdiff
	dbsort
);
our @modularized_db_converters = qw(
	cgi_to_db
	combined_log_format_to_db
	csv_to_db
	db_to_csv
	db_to_html_table
	html_table_to_db
	kitrace_to_db
	mysql_to_db
	tabdelim_to_db
	tcpdump_to_db
	xml_to_db
);
our @modularized_db_non_programs = qw(
	dbpipeline
	dbsubprocess
);
# END AUTOGENERATED VARIABLE SECTION
%EXPORT_TAGS = (all => [@EXPORT_OK, @modularized_db_programs, @modularized_db_converters, @modularized_db_non_programs]);
Exporter::export_ok_tags('all');
my %autoloadable = map { $_ => 1 } @modularized_db_programs, @modularized_db_converters, @modularized_db_non_programs;

use strict;
use threads;
use Thread::Semaphore;
use Thread::Queue;
use Carp;
use Pod::Usage;

use Fsdb::BoundedQueue;
use Fsdb::Filter;
use Fsdb::IO::Reader;
use Fsdb::IO::Writer;

#
# First off, create all the bindings we promise in EXPORT_TAGS.
# Automated via AUTOLOAD for extra coolness.
#
our $AUTOLOAD;
sub AUTOLOAD {
    my $sub = $AUTOLOAD;
    (my $localsub = $sub) =~ s/.*:://;
    die "dbpipeline: AUTOLOAD on non-autoloadable sub $sub\n"
	if (!defined($autoloadable{$localsub}));
    eval "sub $localsub { use Fsdb::Filter::$localsub; return new Fsdb::Filter::$localsub(" . '@_' . "); };\n";
    $@ and die "dbpipeline: error creating stubs: $@\n";
    goto &$sub;
}

sub DESTROY {
    # just suppress autoloading warnings
}

=head2 dbpipeline

    dbpipeline(@modules);

This shorthand-routine creates a dbpipeline object
and then I<immediately runs it>.

Thus perl code becomes nearly as terse as shell code:

    dbpipeline(
	dbcol(qw(name test1)),
	dbroweval('_test1 += 5;'),
    );

The following commands currently have shorthand aliases:

=for comment
BEGIN AUTOGENERATED DOCUMENTATION SECTION

=over

=item L<cgi_to_db(1)>

=item L<combined_log_format_to_db(1)>

=item L<csv_to_db(1)>

=item L<db_to_csv(1)>

=item L<db_to_html_table(1)>

=item L<dbcol(1)>

=item L<dbcolcopylast(1)>

=item L<dbcolcreate(1)>

=item L<dbcoldefine(1)>

=item L<dbcolhisto(1)>

=item L<dbcolmerge(1)>

=item L<dbcolmovingstats(1)>

=item L<dbcolneaten(1)>

=item L<dbcolpercentile(1)>

=item L<dbcolrename(1)>

=item L<dbcolscorrelate(1)>

=item L<dbcolsplittocols(1)>

=item L<dbcolsplittorows(1)>

=item L<dbcolsregression(1)>

=item L<dbcolstats(1)>

=item L<dbcolstatscores(1)>

=item L<dbfilealter(1)>

=item L<dbfilediff(1)>

=item L<dbfilepivot(1)>

=item L<dbfilestripcomments(1)>

=item L<dbfilevalidate(1)>

=item L<dbformmail(1)>

=item L<dbjoin(1)>

=item L<dbmapreduce(1)>

=item L<dbmerge(1)>

=item L<dbmerge2(1)>

=item L<dbmultistats(1)>

=item L<dbrow(1)>

=item L<dbrowaccumulate(1)>

=item L<dbrowcount(1)>

=item L<dbrowdiff(1)>

=item L<dbroweval(1)>

=item L<dbrowuniq(1)>

=item L<dbrvstatdiff(1)>

=item L<dbsort(1)>

=item L<html_table_to_db(1)>

=item L<kitrace_to_db(1)>

=item L<mysql_to_db(1)>

=item L<tabdelim_to_db(1)>

=item L<tcpdump_to_db(1)>

=item L<xml_to_db(1)>

=back

=for comment
END AUTOGENERATED DOCUMENTATION SECTION

and

=over 4

=item L<dbsubprocess(3)>

=back


=cut

=head2 dbpipeline_filter

    my($result_reader, $thread) = dbpipeline_filter($source, $result_reader_aref, @modules);

Set up a pipeline of @MODULES that filters data pushed through it, 
where the data comes from $SOURCE
(any L<Fsdb::Filter::parse_io_option> object,
like a Fsdb::IO::Reader object, queue, or filename).

Returns a $RESULT_READER Fsdb::IO::Reader object,
created with $RESULT_READER_AREF as options.
This reader will produce the filtered data,
and a $THREAD that must be joined to guarantee output
has completed.

=cut

sub dbpipeline_filter ($@) {
    my($pre_filter_source) = shift @_;
    my($post_filter_reader_aref) = shift @_;
    
    my $queue = new Fsdb::BoundedQueue;  # buffer from pipeline back to caller

    my $pipeline = new Fsdb::Filter::dbpipeline(
		    '--noautorun',
		    '--input' => $pre_filter_source,
		    '--output' => $queue,
		    @_);
    my $pipeline_thread = threads->new(
	sub {
	    $pipeline->setup_run_finish;
	} );
    # Next line will block until pipeline produces the header!
    my $post_filter = new Fsdb::IO::Reader(-queue => $queue, @$post_filter_reader_aref);
    return ($post_filter, $pipeline_thread);
}


=head2 dbpipeline_sink

    my($fsdb_writer, $thread) = dbpipeline_sink($writer_arguments_aref, @modules);

Set up a pipeline of @MODULES that is a data "sink", where the output
is given by a C<--output> argument, or goes to standard output (by default).
The caller generates input into the pipeline 
by writing to a newly created $FSDB_WRITER,
whose configuration is specified by the manditory first
arugment $WRITER_ARGUMENTS_AREF.
(These arguments should include the schema.)
Returns this writer, and a $THREAD that must be joined to guarantee output
has completed.

=cut

sub dbpipeline_sink ($@) {
    my($writer_aref) = shift @_;
    
    my $queue = new Fsdb::BoundedQueue;  # buffer from caller into pipeline
    my $writer = new Fsdb::IO::Writer(-queue => $queue, @$writer_aref);

    my $pipeline = new Fsdb::Filter::dbpipeline(
		    '--noautorun',
		    '--input' => $queue,
		    @_);
    my $pipeline_thread = threads->new(
	sub {
	    $pipeline->setup_run_finish;
	} );
    return ($writer, $pipeline_thread);
}

=head2 dbpipeline_open2

    my($fsdb_read_queue, $fsdb_writer, $thread) = dbpipeline_open2($writer_arguments_aref, @modules);

Set up a pipeline of @MODULES that is a data sink and source (both!).
The caller generates input into the pipeline 
by writing to a newly created $FSDB_WRITER,
whose configuration is specified by the manditory 
arugment $WRITER_ARGUMENTS_AREF.
These arguments should include the schema.)
The output of the pipeline comes out to the newly
created $FSDB_READ_QUEUE.
Returns this read queue and writer,
and a $THREAD that must be joined to guarantee output
has completed.

(Unfortunately the interface is assymetric with a read I<queue>
but a write C<Fsdb::IO> object, because C<Fsdb::IO::Reader> blocks on
input of the header.)

Like L<IPC::Open2>, with all of its pros and cons like potential deadlock.

=cut

sub dbpipeline_open2 ($@) {
    my($writer_aref) = shift @_;
    
    my $into_pipeline_queue = new Fsdb::BoundedQueue;
    my $from_pipeline_queue = new Fsdb::BoundedQueue;
    my $writer = new Fsdb::IO::Writer(-queue => $into_pipeline_queue, @$writer_aref);
    # can't make a reader here since it will block on the header
#    my $reader = new Fsdb::IO::Reader(-queue => $from_pipeline_queue, @$reader_aref);

    my $pipeline = new Fsdb::Filter::dbpipeline(
		    '--noautorun',
		    '--input' => $into_pipeline_queue,
		    '--output' => $from_pipeline_queue,
		    @_);
    my $pipeline_thread = threads->new(
	sub {
	    $pipeline->setup_run_finish;
	} );
    return ($from_pipeline_queue, $writer, $pipeline_thread);
}

=head2 dbpipeline_close2_hash

    my($href) = dbpipeline_close2_hash($fsdb_read_queue, $fsdb_writer, $thread);

Reads and returns one line of output from $FSDB_READER,
after closing $FSDB_WRITER and joining the $THREAD.

Useful, for example, to get L<dbcolstats> output cleanly.

=cut

sub dbpipeline_close2_hash ($$$) {
    my($read_queue, $writer, $thr) = @_;
    $writer->close;
    if (defined($thr)) {
	$thr->join;
    };
    my %out_hash;
    my $reader = new Fsdb::IO::Reader(-queue => $read_queue);
    $reader->error and croak "dbpipeline_close2_hash: couldn't setup reader.\n";
    $reader->read_row_to_href(\%out_hash) or croak "dbpipeline_close2_hash: no output from pipeline.\n";
    # check for eof
    my $o;
    while ($o = $reader->read_rowobj) {
	next if (!ref($o));  # comment
	# data is bad
	$o and croak "dbpipeline_close2_hash: multiple lines of output.\n";
    };
    return \%out_hash;
}



=head2 new

    $filter = new Fsdb::Filter::dbpipeline(@arguments);

=cut

sub new {
    my $class = shift @_;
    my $self = $class->SUPER::new(@_);
    bless $self, $class;
    $self->set_defaults;
    $self->parse_options(@_);
    $self->SUPER::post_new();
    return $self;
}


=head2 set_defaults

    $filter->set_defaults();

Internal: set up defaults.

=cut

sub set_defaults ($) {
    my($self) = @_;
    $self->{_modules} = [];
    $self->SUPER::set_defaults();
    $self->{_autorun} = 1;  # override superclass default
}

=head2 parse_options

    $filter->parse_options(@ARGV);

Internal: parse options

=cut

sub parse_options ($@) {
    my $self = shift @_;

    my @argv = @_;
    $self->get_options(
	\@argv,
 	'help|?' => sub { pod2usage(1); },
	'man' => sub { pod2usage(-verbose => 2); },
	'autorun!' => \$self->{_autorun},
	'close!' => \$self->{_close},
	'd|debug+' => \$self->{_debug},
	'i|input=s' => sub { $self->parse_io_option('input', @_); },
	'log!' => \$self->{_logprog},
	'o|output=s' => sub { $self->parse_io_option('output', @_); },
	) or pod2usage(2);
    push(@{$self->{_modules}}, @argv);
}

=head2 setup

    $filter->setup();

Internal: setup, parse headers.

=cut

sub setup ($) {
    my($self) = @_;

    my $last_module_i = $#{$self->{_modules}};
    die $self->{_prog} . ": no modules in pipeline.\n"
        if ($last_module_i < 0);

    # my @queues;
    #
    # Make sure module inputs are sensible
    # and link their IO together, if so.
    #
    my $prev_mod = undef;
    my $i = 1;
    my $mod;
    foreach $mod (@{$self->{_modules}}) {
	die $self->{_prog} . ": module $i isn't type Fsdb::Filter.\n"
	    if (ref($mod) !~ /^Fsdb::Filter/);
	if (defined($prev_mod)) {
	    die $self->{_prog} . ": incompatible module input and output between modules $i and " . $i+1 . ".\n"
		if ($prev_mod->info('output_type') ne $mod->info('input_type'));
	    # xxx: above is a bit too strict, since fsdbtext should match fsdb*

	    my $queue = new Fsdb::BoundedQueue;
	    $prev_mod->parse_options("--output" => $queue);
	    $mod->parse_options("--input" => $queue);
	    if ($self->{_debug}) {
		print STDERR $self->{_prog} . "threading IO with queue between modules $i and " . ($i+1) . "\n";
	    };
	    # push(@queues, $queue);   # just for yucks
	};

	$prev_mod = $mod;
	$i++;
    };
    # Pass our input and output to the first and last modules:
    if (defined($self->{_input})) {
	$self->{_modules}[0]->parse_options('--input' => $self->{_input});
	print STDERR $self->{_prog} . ": linking input to first module\n"
	    if ($self->{_debug});
    };
    if (defined($self->{_output})) {
	$self->{_modules}[$last_module_i]->parse_options('--output' => $self->{_output});
	print STDERR $self->{_prog} . ": linking output to last module\n"
	    if ($self->{_debug});
    };

    #
    # Everything benign has now happend.
    #
    # Now fork of threads for each child.
    # Ideally we would do that in run,
    # except that perl has problems when a pipe (like stdin) is
    # opened in one thread and used in another---it trys to lseek
    # and gives up when lseek fails on the pipe.
    # Sigh.  These details are all 5.8.8... maybe 5.10 fixes them?
    #
    # Setup children.
    # Block until they have completed their setup via our sempaphore.
    # Built a queue to tell us when to reap them.
    # (Assumes that threads capture all exit paths, so they do a __DIE__.)
    #
    $self->{_threads} = [];
    my $setup_error_queue = $self->{_setup_error_queue} = new Thread::Queue;
    my $death_queue = $self->{_death_queue} = new Thread::Queue;
    $self->{_live_thread_count} = 0;
    #
    # Catch OUR death and take our threads with us.
    #
    # Note that the error handling is fragile,
    # because errors are propagated as pseudo-signals.	
    # We want to BOTH clean up our children,
    # but ALSO allow them to fully run their __DIE__ handlers.
    #
    # Hence, the hacky sleep 0.1's, which are fancy yields().
    # They Work For Me, but they seem to embedd timing dependencies
    # in the code that is very undesirable.
    #
    $SIG{__DIE__} = sub {
	# First, join the joinable:
	# This step helps avoid race conditions in the thread's __DIE__ and TERM handlers.
	my @maybe_still_live = @{$self->{_threads}};;
	foreach my $try (0..1) {
	    my @join_candidates = @maybe_still_live;
	    @maybe_still_live = ();
	    foreach (@join_candidates) {
		if ($_->is_joinable()) {
		    print STDERR "dbpipeline:__DIE__ joining a thread\n" if ($self->{_debug});
		    $_->join;
		} else {
		    push (@maybe_still_live, $_);
		};
	    };
	    last if ($#maybe_still_live == -1);  # good cleanup!
	    sleep 0.05;  # give children a chance to die
	    # now try again
	};
	# Now kill the rest.
	print STDERR $self->{_prog} . ": will terminate " . ($#maybe_still_live+1) . " threads.\n"
	    if ($self->{_debug});
	foreach (@maybe_still_live) {
	    print STDERR "dbpipeline:__DIE__ detaching $_\n" if ($self->{_debug});
	    # $_->kill('KILL');
	    # Next is eval because with 5.10.0-73 and threads-1.67
	    # I started getting "Cannot detach a joined thread...".
	    # Probably a race in the above is_joinable() thing.
	    # In addition, we used to kill (see above),
	    # but kill('TERM') caused hangs,
	    # and kill('KILL') caused "no signal handler" messages.
	    # Detach should cause silent cleanup, knock-on-wood.
	    eval { $_->detach(); };
	};
	# remember they're now all gone.
	@{$self->{_threads}} = ();
    };
    my $debug = $self->{_debug};
    my $mod_num = 0;
    foreach $mod (@{$self->{_modules}}) {
	$mod_num++;
	my $mod_thread = threads->new( sub { 
	    my $setup_error_queue_released = undef;
	    # catch premature thread death and tell the pipeline as a whole
	    $SIG{__DIE__} = sub {
		my($error) = @_;
		if (!$setup_error_queue_released) {
		    $setup_error_queue->enqueue(defined($error) ? $error : 'error');
		};
		$death_queue->enqueue(threads->tid());
		
		threads->exit(undef);   # exit, returning error string
	    };
	    $SIG{'TERM'} = sub { threads->exit(); };
	    print "dbpipeline: module $mod_num setup in thread " . threads->tid() . "\n" if ($debug);
	    $mod->setup();
	    sleep(1) if ($debug > 1);
	    $setup_error_queue->enqueue(undef);   # good setup; let caller continue
	    $setup_error_queue_released = 1;
	    print "dbpipeline: module $mod_num run\n" if ($debug);
	    $mod->run; 
	    print "dbpipeline: module $mod_num finish\n" if ($debug);
	    $mod->finish;
	    $death_queue->enqueue(threads->tid());
	    return 1;
	} );
	$self->{_live_thread_count}++;
	push(@{$self->{_threads}}, $mod_thread);
	my $setup_error = $setup_error_queue->dequeue();  # block until thread has setup
	if (!defined($mod_thread)) {
	    sleep 0.1;   # give child time to clear their __DIE__ handler
	    die "thread for module #$mod_num failed to create.\n";
	};
	if ($setup_error) {
	    sleep 0.1;   # give child time to clear their __DIE__ handler
	    die "thread for module #$mod_num failed to setup with error: $setup_error\n";
	};
    };
}

=head2 run

    $filter->run();

Internal: run over all IO

=cut
sub run ($) {
    my($self) = @_;
    # wait for termination of everyone
    my $thr_num = 0;
    my $death_queue = $self->{_death_queue};
    my $debug = $self->{_debug};
    while ($self->{_live_thread_count} > 0) {
	my $dead_tid = $death_queue->dequeue();
	print STDERR "dbpipeline: thread id $dead_tid appears on death queue\n"
	    if ($debug);
	my $thr = threads->object($dead_tid);
	my $result = $thr->join;
	$self->{_live_thread_count}--;
	print STDERR "dbpipeline: thread id $dead_tid exited " . ($result ? "ok" : "FAILING"). "\n"
	    if ($debug);
    };
}

=head2 finish

    $filter->finish();

Internal: we would write a trailer, but we don't because
we depend on the last command in the pipeline to do that.
We don't actually have a valid output stream.

=cut
sub finish ($) {
    my($self) = @_;
    # do nothing, since we have no output path.
    # $self->SUPER::finish();
}

=head1 AUTHOR and COPYRIGHT

Copyright (C) 1991-2007 by John Heidemann <johnh@isi.edu>

This program is distributed under terms of the GNU general
public license, version 2.  See the file COPYING
with the distribution for details.

=cut

1;

