# -*- perl -*-

# Copyright (c) 2002 by Jeff Weisberg
# Author: Jeff Weisberg <argus @ tcp4me.com>
# Date: 2002-Apr-02 09:47 (EST)
# Function: BaseIO class
#
# $Id: BaseIO.pm,v 1.44 2005/12/04 20:52:27 jaw Exp $

# low-lovel I/O non-blocking, select-loop

package BaseIO;
use Fcntl;
use POSIX qw(:errno_h);
# use the high resolution timer if we have it, and we aren't profiling
# currently, only Service elapsed time uses it
BEGIN { eval{ require Time::HiRes; import Time::HiRes qw(time) }
	unless defined &DB::DB; }

use strict qw(refs vars);
use vars qw($doc @bytime);

my @byfile = (); 	 # objects by fd
my @byfile_dbg = ();	 # for debugging...
   @bytime = (); 	 # { time obj func args text } sorted by time
			 # - global so that Ping::start can muck around...
my $rfds   = "\0\0\0\0"; # fds that want read
my $wfds   = "\0\0\0\0"; # fds that want write
my @timeouts = (); 	 # objects sorted by timeout

my $loopdebug = 0;

$doc = {
    package => __PACKAGE__,
    file    => __FILE__,
    isa     => [ ],
    methods => {
	wantread   => {
	    descr => 'set the want read parameter',
	},
	wantwrit   => {
	    descr => 'set the want write parameter',
	},
	settimeout => {
	    descr => 'set the timeout time',
	},
	readable   => {
	    descr => 'Called once the object becomes readable',
	    attrs => ['virtual'],
	},
	writable   => {
	    descr => 'Called once the object becomes writable',
	    attrs => ['virtual'],
	},
	timeout    => {
	    descr => 'Called once the object timeouts waiting to become readable or writable',
	    attrs => ['virtual'],
	},
	add_timed_func => {
	    descr => 'Add a function to run at a specified time',
	},
	clear_timed_funcs => {
	    descr => 'remove all currently scheduled timed functions',
	},
	shutdown   => {
	    descr => 'Called to shutdown the object',
	},
    },
    fields => {
	wantread   => {
	    descr => 'This object is waiting for data to read',
	    attrs => ['internal'],
	},
	wantwrit   => {
	    descr => 'This object is waiting to output data',
	    attrs => ['internal'],
	},
	fd         => {
	    descr => 'The objects filehandle',
	    attrs => ['internal'],
	},
	type       => {
	    descr => 'descriptive name of object type, for debugging',
	},
	timeout    => {
	    descr => 'When should object should stop waiting',
	    attrs => ['internal'],
	},
	opentime => {
	    descr => 'When the file descriptor was last opened',
	    #         not cleared on close, for debugging
	},

      # baseio stats
      bios::reads    => {},
      bios::writes   => {},
      bios::timeouts => {},
      bios::timefs   => {},
      bios::inits    => {},
      bios::shuts    => {},
      bios::settos   => {},
      bios::addtfs   => {},
    },
};

################################################################
# public object methods
################################################################

sub wantread {
    my $me = shift;
    my $wm = shift;

    return unless defined $me->{fd};
    vec($rfds, fileno($me->{fd}), 1) = $wm;
    $me->{wantread} = $wm;
}

sub wantwrit {
    my $me = shift;
    my $wm = shift;

    return unless defined $me->{fd};
    vec($wfds, fileno($me->{fd}), 1) = $wm;
    $me->{wantwrit} = $wm;
}

sub settimeout {
    my $me = shift;
    my $t  = shift;
    my( %ts );

    # arg is deltaT
    # 0 removes timeout

    if( $t ){
	# make t absolute, return if unchanged
	$t += $^T;
	return if $me->{timeout} && ($t == $me->{timeout});
	$me->{timeout} = $t;

	$me->{bios}{settos} ++;
	# add, unique, sort
	push @timeouts, $me;
	foreach (@timeouts){
	    $ts{ fileno($_->{fd}) } = $_;
#	    print STDERR "$_->{type} ", ($_->can('unique') ? $_->unique() : ''),
#	    " [$_->{fd}], $_->{timeout}\n"
#		unless $_->{fd} && $_->{timeout};
	}
	@timeouts = sort { $a->{timeout} <=> $b->{timeout} } ( values %ts );
	# the astute reader is probably asking, "you go through all sorts of
	# hoops to speed up maintaining @bytime, shouldn't you be doing that
	# here as well?"
	# A: no, @bytime has lots and lots of entries, @timeouts typically
	# has only a few entries
    }else{
	# remove timeout
	return unless $me->{timeout};
	$me->{timeout} = $t;
	@timeouts = grep { $_ != $me } @timeouts;
    }
}

# initialize fd
sub baseio_init {
    my $me = shift;
    my $f  = $me->{fd};

    $me->{bios}{inits} ++;
    if( $f ){
	my $n = fileno($f);
	$me->{opentime} = $^T;
	$byfile[ $n ]     = $me;
	$byfile_dbg[ $n ] = $me;
	$me->setnbio();
    }else{
	::warning( "basio_init called on invalid fd " .
		   ($me->can('unique') ? $me->unique() : 'unknown') );
    }
}

# { time func text }
sub add_timed_func {
    my $me = shift;
    my @param = @_;
    my( $t );

    $t = { @param };
    $t->{obj} = $me;
    return unless $t->{time} && $t->{time} > $^T;

    $me->{bios}{addtfs} ++;
    # @bytime = sort { $a->{time} <=> $b->{time} } (@bytime, $t);

    # QQQ - profiler says that add_timed_func "needs to be better"
    # sort is O(n log(n)) (but in C), but the data is already sorted
    # is just finding proper spot and inserting faster - O(n) (but perl)
    # Yes - 0.0014s -> 0.0004s

    my $i = 0;
    my $tt = $t->{time};
    foreach my $x (@bytime){
	last if $x && $x->{time} > $tt;
	$i++;
    }

    if( $i && !defined($bytime[$i-1]) ){
	$bytime[$i-1] = $t;
    }else{
	splice @bytime, $i, 0, $t;
    }
}

sub clear_timed_funcs {
    my $me = shift;

    @bytime = grep { $_ && $_->{obj} != $me } @bytime;
}

# all done with fd
sub shutdown {
    my $me = shift;
    my $fd = $me->{fd};

    $me->{bios}{shuts} ++;
    $me->settimeout(0) if $me->{timeout};
    return unless $fd;
    $me->wantread(0);
    $me->wantwrit(0);
    $byfile[ fileno($fd) ] = undef;
    delete $me->{fd};
    close $fd;
}

sub recycle {
    my $me = shift;

    $me->shutdown();
    $me->clear_timed_funcs();
}

################################################################

# readable/writable/timeout should be overridden in subclasses if used
sub readable {
    my $me = shift;
    my $class = ref($me);
    
    ::warning("BUG ALERT - read from $class (output-only)! ignoring");
    -1;
}

sub writable {
    my $me = shift;
    my $class = ref($me);

    ::warning("BUG ALERT - write to $class (input-only)! ignoring");
    -1;
}

sub timeout {
    my $me = shift;
    my $class = ref($me);

    ::warning("BUG ALERT - timeout in $class (input-only)! ignoring");
    -1;
}

################################################################
# private object methods
################################################################

sub setnbio {
    my $me = shift;

    my $fh = $me->{fd};
    # QQQ - is this portable?
    fcntl($fh, F_SETFL, O_NDELAY);
}

################################################################
# class methods
################################################################

# return an anonymous filehandle
sub anon_fh {
    do { local *FILEHANDLE };
}

sub closeall {

    foreach my $x (@byfile){
	close $x->{fd} if $x->{fd};
    }
}

sub ctime { time() };

sub nfds {
    scalar grep {$_} @byfile;
}
sub maxfds {
    scalar @byfile;
}

################################################################
# private
################################################################

# return ($rfds, $wfds, $to)
# with the re-write of wantread/wantwrit this needs only find the TO
sub selectwhat {
    my( $t, $bt );

    $t = $timeouts[0]->{timeout} if( @timeouts );
    if( @bytime ){
	$bt = $bytime[0]->{time};
	$t  = $bt if( !$t || ($bt < $t) );
    }
    ($rfds, $wfds, $t);
}

# now private
# dispatch readable/writable/timeout based on values returned by select
sub dispatch {
    my $rfd = shift;
    my $wfd = shift;
    my( $i, $n, $nc, $m, $x, $xr, $xw, $rs, $ws, $ts, $fs, @hrd );

    $xr = $rfds; $xw = $wfds;
    # most fd's will not be ready, check 8 at a time
    $nc = int( (@byfile + 7) / 8 );
    for( $n=0; $n < $nc; $n++ ){

	if( vec($rfd, $n, 8) ){
	    for($i=0; $i<8; $i++){
		$m = $n * 8 + $i;
		if( vec($rfd, $m, 1) ){
		    $x = $byfile[ $m ];
		    if( $x ){
			$x->{bios}{reads} ++;
			$rs ++;
			$x->readable();
			$hrd[$m] = 1;	# to prevent warn below if object shutsdown
		    }else{
			vec($rfds, $m, 1) = 0;
			::warning( "BUG? unknown file handle $m returned from select/r - IGNORING" );
			::warning( "...fd $m was set in rfds" )
			    if vec($xr, $m, 1);
			::warning( "...perhaps by $byfile_dbg[$m]=" .
				   ($byfile_dbg[$m]->can('unique') ? 
				    $byfile_dbg[$m]->unique() : 'unknown'))
			    if $byfile_dbg[$m];
		    }
		}
	    }
	}
	
	if( vec($wfd, $n, 8) ){
	    for($i=0; $i<8; $i++){
		$m = $n * 8 + $i;
		if( vec($wfd, $m, 1) ){
		    $x = $byfile[ $m ];
		    if( $x ){
			$x->{bios}{writes} ++;
			$ws ++;
			$x->writable();
		    }elsif( $hrd[$m] ){
			# object must have shutdown during readable
			# no warn
		    }else{
			vec($wfds, $m, 1) = 0;
			::warning( "BUG? unknown file handle $m returned from select/w - IGNORING" );
			::warning( "...fd $m was set in wfds" )
			    if vec($xw, $m, 1);
			::warning( "...perhaps by $byfile_dbg[$m]=" .
				   ($byfile_dbg[$m]->can('unique') ? 
				    $byfile_dbg[$m]->unique() : 'unknown'))
			    if $byfile_dbg[$m];
		    }
		}
	    }
	}
    }

    while( ($#timeouts != -1) && ($timeouts[0]->{timeout} <= $^T) ){
	$x = shift @timeouts;
	# we can bypass settimeout(0)
	$x->{timeout} = 0;
	$x->{bios}{timeouts} ++;
	$ts ++;
	$x->timeout();
    }
    
    while( ($#bytime != -1) && (!$bytime[0] || $bytime[0]->{time} <= $^T) ){
	$x = shift @bytime;
	next unless $x;
	$x->{obj}{bios}{timefs} ++;
	$fs ++;
	$x->{func}->( $x->{obj}, $x->{args} );
    }

    print STDERR "dispatched: r=$rs, w=$ws, to=$ts, fs=$fs\n" if $loopdebug;
    # $loopdebug = 1 unless $rs + $ws + $ts + $fs;
}

# aka 'the program'
sub mainloop {
    my %param = @_;
    
    $::idletime  = 0;
    $::loopcount = 0;
    $^T = $::TIME = time();
    while(1){
	oneloop( %param );
    }
}

sub xxxmainloop {
    my %param = @_;
    my( $pt, $pl );
    
    $::idletime  = 0;
    $::loopcount = 0;
    $pt = $^T = $::TIME = time();
    while(1){
	oneloop( %param );

	if( $pt != $^T ){
	    my $dl = $::loopcount - $pl;
	    my $dt = $^T - $pt;
	    my $rl = $dl / $dt;
	    
	    if( $rl > 100 ){
		print STDERR "rl: $rl, dt: $dt, dl: $dl\n";
		$loopdebug = 1;
	    }else{
		$loopdebug = 0;
	    }
	    
	    $pl = $::loopcount;
	    $pt = $^T;
	}
    }
}

sub oneloop {
    my %param = @_;
    my( $i, $ti );
    
    # chk_schedule();
    my ($r, $w, $t) = selectwhat();
    if( $t ){
	$t -= $^T;
	$t = $param{maxperiod} if $param{maxperiod} && ($t > $param{maxperiod});
    }else{
	$t = $param{maxperiod};
    }
    $t = 1 if $t < 1;
    
    $^T = $ti = $::TIME = time();
    print STDERR "selecting: ", ::hexstr($r), ", ", ::hexstr($w), ", $t\n" if $loopdebug;
    $i = select($r, $w, undef, $t);
    print STDERR "selected:  ", ::hexstr($r), ", ", ::hexstr($w), ", $i\n" if $loopdebug;

    $^T = $::TIME = time();
    $::idletime  += $::TIME - $ti;
    $::loopcount ++;
    if( $i == -1 ){
	::sysproblem( "select failed: $!" ) unless $! == EINTR;
	return;
    }
    
    dispatch($r, $w);
    # $param{run}->() if $param{run}; # need to keep the profiler happy
    # Prog::reap();  # moved to cron - better performance if argus is busy
}

# try debugging a scheduling issue
sub chk_schedule {
    my( $lt, $er );

    foreach my $x (@bytime){
	next unless $x;
	$er = 1 if $lt && $lt > $x->{time};
	$lt = $x->{time};
    }
    if( $er ){
	print STDERR "schedule corrupt!\n";
	dump_schedule();
    }
}

sub dump_schedule {
    
    foreach my $x (@bytime){
	if( !$x ){
	    print STDERR "[] empty slot\n";
	    next;
	}
	print STDERR "[", scalar(localtime($x->{time})) , "] $x->{text}";
	if( $x->{text} eq "cron" ){
	    print STDERR " - /". ($x->{obj}{cron}{freq} ? $x->{obj}{cron}{freq} : "at") .
		" - $x->{obj}{cron}{text}";
	}
	elsif( $x->{obj}->can('unique') ){
	    print STDERR " - ", $x->{obj}->unique(), $x->{obj};
	}
	print STDERR "\n";
    }
}

# rebuild various data structures
sub janitor {
    my( @sched );

    foreach my $x (@bytime ){
	push @sched, $x if $x;
    }
    @bytime = sort {$a->{time} <=> $b->{time}} @sched;
}

################################################################
# these functions provide useful debugging info

sub cmd_filinfo {
    my $ctl = shift;

    my $tot = @byfile;
    my $act = scalar grep {defined $_} @byfile;
    
    $ctl->ok();
    $ctl->write("active: $act\n");
    $ctl->write("total:  $tot\n");
    $ctl->final();
}

sub cmd_files {
    my $ctl = shift;
    my( $i, $x );
    
    $ctl->ok();

    # fileno type [age] read/write/to uniquename
    
    for($i=0; $i<=$#byfile; $i++){
	if( $byfile[$i] && $byfile[$i]{fd} ){
	    $x = $byfile[$i];
	    $ctl->write( "$i $x->{type}  [". ($^T - $x->{opentime}) .
			 "]  $x->{wantread}/$x->{wantwrit}/" .
			 ($x->{timeout} ? $x->{timeout} - $^T: 0) );
	    $ctl->write( " " . $x->unique() ) if $x->can( 'unique' );
	    $ctl->write( "\n" );
	}
    }
    $ctl->final();
}

# What's here? the portrait of a blinking idiot,
# Presenting me a schedule! I will read it.
#   -- Shakespeare, Merchant of Venice
sub cmd_schedule {
    my $ctl = shift;
    my $param = shift;
    
    my( $x, $q, $v );
    
    $ctl->ok();
    $q = $param->{queue};
    $v = $param->{verbose};
    
    foreach $x (@bytime){
	if( !$x ){
	    $ctl->write( "[] empty slot\n" ) if $v;
	    next;
	}
	if( !$q || ($x->{text} eq "cron" && $x->{obj}{cron}{queue} eq $q) ){
	    $ctl->write( "[". scalar(localtime($x->{time})) .
			 "] $x->{text}" );
	    
	    if( $x->{text} eq "cron" ){
		$ctl->write( " - /". ($x->{obj}{cron}{freq} ? $x->{obj}{cron}{freq} : "at") .
			     " - $x->{obj}{cron}{text}");
	    }
	    elsif( $v && $x->{obj}->can('unique') ){
		$ctl->write( " - " . $x->{obj}->unique() );
	    }
	    $ctl->write("\n");
	}
    }
    $ctl->final();
}

################################################################
# initialization
################################################################

Control::command_install( 'filinfo', \&cmd_filinfo,"file info" );
Control::command_install( 'files', \&cmd_files,    "list all open file descriptors" );
Control::command_install( 'sched', \&cmd_schedule, "list all scheduled tasks" );
Doc::register( $doc );

1;
