Profile::Log - collect loggable application profiling stats

 use Profile::Log;

 ...

 sub event_processor {
     my $timer = Profile::Log->new() if PROFILE;

     do_something();
     $timer->did("minor") if PROFILE > 1;

     $timer->mark("parallel") if PROFILE;
     do_parallel_things();

     wait_for_thing1();
     $timer->did("thing1", "parallel") if PROFILE;

     wait_for_thing2();
     $timer->did("thing2", "parallel") if PROFILE;

     finish_up();
     $timer->did("finish") if PROFILE > 1;

     # this module does not handle logging itself.
     print LOG $timer->logline if PROFILE;
 }

 # later... available processing methods
 my $timer = Profile::Log->new($log_line);
 print $timer->zero;  # profile start time
 print $timer->end;   # profile stop time

 # ... t.b.c. ...

 0=12:34:56.123504; tot=0.504; minor: 0.020; m0:parallel=0.000; \
    m0:thing1=0.450; m0:thing2=0.454; finish: 0.030

 0=12:34:56.123504; tot=0.504; m0:parallel=0.020; \
    m0:thing1=0.450; m0:thing2=0.454

 my $timer = Profile::Log->new() if PROFILE;

 my $loaded_timer = Profile::Log->new($log_line);

  Mon DD HH:MM:SS hostname ...

package Profile::Log;

use strict;
use warnings;

use Carp;

use Time::HiRes qw(gettimeofday tv_interval);
use YAML qw(LoadFile Dump);
use List::Util qw(reduce);
use Scalar::Util qw(blessed);

our $VERSION = "0.02";

our $config;

sub import {
    my $package = shift;
    my ($caller_package, $filename) = caller;
    if ( defined &{$caller_package."::PROFILE"} ) {
	print STDERR (__PACKAGE__.": bypassing auto-config for "
		      ."$filename ($caller_package) - PROFILE already"
		      ." defined\n")
	    if $ENV{PROFILE_LOG_DEBUG};
    } else {
	$filename =~ s{.*/}{};
	$config ||= do {
	    my $config_file = ($ENV{PROFILE_LOG_CONFIG} ||
			       "$ENV{HOME}/.profilerc.yml");
	    if ( -e $config_file ) {
		print STDERR __PACKAGE__.": loading settings from $config_file\n"
		    if $ENV{PROFILE_LOG_DEBUG};
		LoadFile $config_file
	    } else {
		{};
	    }
	};

	#print STDERR "Config is: ".Dump($config);
	#print STDERR "stuff is: ".Dump({caller_package => $caller_package,
	#filename => $filename });

	my %import_config;
	if ( $config->{modules} and $config->{modules}{$caller_package} ) {
	    %import_config = %{ $config->{modules}{$caller_package} };
	}
	if ( $config->{files} and $config->{files}{$filename} ) {
	    %import_config = (%import_config,
			      %{ $config->{files}{$filename} });
	}

	my $profiling = $import_config{profile} || 0;
	print STDERR (__PACKAGE__.": profiling level for $filename "
		      ."($caller_package) is $profiling\n")
	    if $ENV{PROFILE_LOG_DEBUG};

	no strict 'refs';
	*{$caller_package."::PROFILE"} = sub() {
	    $profiling;
	};
    }
}

sub new {
    my $class = shift;
    if ( @_ ) {
	my $logline = shift;
 	my ($state);
	my $self = bless { t => [], mc => 0 }, $class;
	my $time;
	my @marks;
	while ( $logline =~ m{\G([^=]+)=([^;]*)(?:;\s+)?}g ) {
	    my ($k, $v) = ($1, $2);
	    if ( !$state and $k ne "0" ) {
		$self->{tag}{$k}=$v;
	    }
	    elsif ( !$state and $k eq "0" ) {
		$v =~ m{(\d+):(\d+):(\d+)\.(\d+)};
		$self->{0} = to_local([ (reduce { $a * 60 + $b } $1, $2, $3),
					$4 * 10**(6-length($4)) ]);
		$time = $self->{0};
		$state = "tot";
	    } elsif ( $state eq "tot" ) {
		$self->{Z} = time_add($time,[0,$v*1e6]);
		$state = "times"
	    } elsif ( $state eq "times" ) {
		push @{ $self->{t} }, $k, $v;
		if ( $k =~ m{m(\d+):(.*)} ) {
		    my ($m, $label) = ($1, $2);
		    if ( $m >= $self->{mc} ) {
			$marks[$m] = $label;
			$time = $self->{m}{$label}
			    = time_add($time, [0,$v*1e6]);
			$self->{mc}++;
		    } else {
			$time = time_add($self->{m}{$marks[$m]},
					 [0,$v*1e6]);
		    }
		} else {
		    $time = time_add($time,[0,$v*1e6]);
		}
	    }
	}
	return $self;
    }
    else {
    my @now = gettimeofday;
    return bless { 0 => \@now,
		   l => [@now],
		   m => {},
		   mc => 0,
		   t => [],
		 }, $class;
    }
}

sub new_from_syslog {
    my $class = shift;
    my $line = shift;

    my ($syslog_line, $logline)
	= ($line =~ m{^(.*?)(\S[^=\s]*=[^;]*;\s.*)$})
	    or return undef;
    my $self = $class->new($logline);
    $self->add_syslog($syslog_line);
    return $self;
}

# this is a bit of a hack - a version of timelocal for syslog dates
my $timelocal_ready;
our %mon;
our ($y,$m,$d);
sub syslog_timelocal {
    my $syslog_date = shift;
    my ($sec, $min, $hour, $mday, $monname) = reverse
	( $syslog_date =~ m{^(\w+) \s+ (\d+) \s+ (\d+):(\d+):(\d+)}x );

    unless ( $timelocal_ready ) {
	no strict 'refs';
	require I18N::Langinfo;
	require Time::Local;
	for my $mon ( 1..12 ) {
	    my $mname = lc(&I18N::Langinfo::langinfo
			   (&{"I18N::Langinfo::ABMON_$mon"}));
	    $mon{$mname} = $mon-1;
	}
	($y, $m, $d) = (localtime(time()))[5,4,3];
	$timelocal_ready = 1;
    }
    # if the month is greater than today, assume it's last year.
    my $mon = $mon{lc($monname)};
    #kill 2, $$;
    my $year = ($mon > $m) ? $y-1 : $y;
    return Time::Local::timelocal($sec, $min, $hour,
				  $mday, $mon, $year);
}

sub add_syslog {
    my $self = shift;
    my $syslog_header = shift;

    if ( my ($syslog_date, $hostname, $process, $comment)
	 = ( $syslog_header =~
	     m{^(\w+ \s+ \d+ \s+ \d+:\d+:\d+) \s+ # syslog date
	       	       (\w+) \s+                         # hostname
	       	       (?: (\S+?) (?:\[\d+\])? : \s* )?  # process name, PID
	       	       (?: (\S.*?) \s* )? $                   # extra comment
	   	   }x )) {

	$self->tag("hostname" => $hostname);
	$self->tag("process" => $process);
	$self->tag("comment" => $comment) if $comment;

	if ( $self->{0}[0] < 7 * 86400 ) {
	    # we set the top half of the 0 to the month and day *not later
	    # than* the syslog time.
	    my $syslog_localtime = syslog_timelocal($syslog_date);
	    my $self_time = $self->{0}[0] % 86400;

	    my @local_syslog = localtime($syslog_localtime);
	    my @local_self   = localtime($self_time);

	    my $proposed_time = Time::Local::timelocal
		(@local_self[0,1,2],@local_syslog[3,4,5]);

	    if ( $proposed_time > $syslog_localtime ) {
		# must be the previous day
		$syslog_localtime -= 86400;
		@local_syslog = localtime($syslog_localtime);
		$proposed_time = Time::Local::timelocal
		    (@local_self[0,1,2],@local_syslog[3,4,5]);
	    }

	    my $old_time = $self->{0}[0];
	    my ($old_diff) = ($self->{Z}[0] - $self->{0}[0]) % 86400;
	    $self->{0}[0] = $proposed_time;
	    $self->{Z}[0] = $proposed_time + $old_diff;
	    if ( $self->{m} ) {
		my $to_add = ($proposed_time - $old_time);
		while ( my ($mark, $t) = each %{$self->{m}} ) {
		    $t->[0] += $to_add;
		}
	    }
	}
    }
}

my $tz_offset;
sub to_local {
    my $t = shift;
    # FIXME - non-hour aligned timezones like NZ-CHAT
    $t->[0] -= ($tz_offset ||= ((localtime(0))[2])) * 3600;
    $t->[0] %= 86400 if $t->[0] < 0;
    $t;
}

sub time_add {
    my $t1 = shift;
    my $t2 = shift;
    my $usec = $t1->[1] + $t2->[1];
    return [ $t1->[0] + $t2->[0] + int($usec / 1e6),
	     $usec % 1e6 ];
}

sub did {
    my $self = shift;
    my $event = shift;
    $event !~ m{\s} or croak "event must not contain whitespace";
    my $t0;
    if ( @_ ) {
	my $mark = shift;
	$t0 = $self->{m}{$mark};
	$event = "m$t0->[2]:$event";
    } else {
	$t0 = $self->{l};
    }
    my $now = [gettimeofday];
    push @{ $self->{t} }, ($event => tv_interval($t0, $now));
    $self->{l} = $now;
}

sub mark {
    my $self = shift;
    my $mark = shift;
    $mark !~ m{\s} or croak "mark must not contain whitespace";
    # this is a touch naughty - hang extra information on the nice
    # handy array there (Time::HiRes doesn't care)
    my $m;
    $self->{m}{$mark}=[gettimeofday, ($m=$self->{mc}++)];
    $self->did("m$m:$mark");
}

sub logline {
    my $self = shift;
    my $final = ($self->{Z}||=[gettimeofday]);

    my @ts;

    @ts = map { "$_=$self->{tag}{$_}" } sort keys %{ $self->{tag} }
	if $self->{tag};

    push @ts, ("0=".$self->getTimeStamp($self->{0}),
	       "tot=".$self->getInterval($self->{0}, $final));
    my $l = $self->{t};

    # collect rounding errors along the way, fudge onto the next value
    # so they don't accumulate.  ie, if one task takes 0.4074s, and
    # the next 0.0011s, they will be displayed as 0.407 and 0.002
    my $re = 0;
    for ( my $i = 0; $i < $#$l; $i += 2 ) {
	my $delta = $l->[$i+1] + $re;
	my $ms;
	# very short deltas might end up negative - so add the error
	# to the next value instead.
	if ( $delta < 0 ) {
	    ($ms, my $extra) = getInterval($l->[$i+1]);
	    $re += $extra;
	} else {
	    ($ms, $re) = getInterval($delta);
	}
	push @ts, "$l->[$i]=$ms";
    }
    return join ("; ", @ts);
}

sub tag {
    my $self = shift;
    my $title = shift;
    $title !~ m{[\s=;]}
	or croak("tag name must not contain whitespace, equals symbol"
		 ." or semicolon");
    if ( @_ ) {
	my $value = shift;
	$self->{tag}{$title}=$value;
    }
    else {
	return $self->{tag}{$title};
    }
}

sub tags {
    my $self = shift;

    return keys %{ $self->{tag} };
}

sub zero {
    my $self = shift;
    return $self->{0}[0] % 86400 + $self->{0}[1] / 1e6;
}

sub zero_t {
    my $self = shift;
    return @{ $self->{0} }
}

sub diff {
    my $a = shift;
    my $b = shift;

    my @a = $a->zero;
    my @b = $b->zero;

    # Profile::Log objects don't need fully qualified dates; if the
    # date value is too small, then compare by seconds only, in the
    # closest half of the day.
    if ( $a[0] > 10*86400 and $b[0] > 10*86400 ) {
	return $a[0] - $b[0] + ( $a[0] - $b[0] ) / 1e6;
    } else {
	my $diff = ( ($a[0] - $b[0]) % 86400
		     + ( $a[0] - $b[0] ) / 1e6);
	$diff += 86400 if $diff < -86400/2;
	$diff -= 86400 if $diff >  86400/2;
	return $diff;
    }
}

use overload
    'cmp' => \&diff,
    'fallback' => 1;

sub end {
    my $self = shift;
    my $z = $self->{Z}||=[gettimeofday];
    return $z->[0] % 86400 + $z->[1] / 1e6;
}

sub end_t {
    my $self = shift;
    my $z = $self->{Z}||=[gettimeofday];
    return @$z;
}

sub marks {
    my $self = shift;
    my @marks = (0, sort { tv_interval($self->{m}{$a}, $self->{m}{$b})
		       } keys %{ $self->{m}||{} });
    wantarray ? @marks : \@marks;
}

sub iter {
    my $self = shift;

    my $i = -1;

    my $cue = 0;
    my @m = ();

    my $it = sub {
	$cue += $self->{t}[2*$i+1]
	    unless $i == -1 or $i*2+1 > ($#{$self->{t}});
	$i++;
	if ( $i*2 <= ($#{$self->{t}})
	     and $self->{t}[2*$i] =~ m/^m(\d+)/ ) {
	    if ( exists $m[$1] ) {
		$cue = $m[$1];
	    } else {
		$m[$1] = $cue;
	    }
	}
    };

    my $iter = sub {
	my $method = shift;
	if ( $method eq "next" ) {
	    $it->();
	    if ( 2*$i < $#{$self->{t}} ) {
		return $self->{t}[2*$i];
	    }
	    elsif ( 2*$i == $#{$self->{t}}+1 ) {
		return "Z";
	    }
	    else {
	    }
	}
	elsif ( $method eq "start" ) {
	    return $cue;
	}
	elsif ( $method eq "length" ) {
	    return 0 if $i == -1;
	    return scalar getInterval(($self->end - $self->zero) - $cue)
		if 2*$i == $#{$self->{t}}+1;
	    return $self->{t}[2*$i+1]+0;
	}
	elsif ( $method eq "name" ) {
	    return 0 if $i == -1;
	    return "Z" if 2*$i == $#{$self->{t}}+1;
	    return $self->{t}[2*$i];
	}
    };
    return $iter;
}

sub mark_iter {
    my $self = shift;
    my $mark = shift || 0;
    my ($t0, $m);
    if ( $mark ne "0" ) {
	($m) = (map { m/^m(\d+):/; $1 }
		grep /^m\d+:\Q$mark\E/,
		@{ $self->{t} });
	croak("no such mark '$mark' in Profile::Log object (marks: "
	      .join(" ",keys %{ $self->{m}||{} }).")")
	    unless defined $m;
    }

    my $all_iter = $self->iter();

    my $iter = sub {
	my $method = shift;
	if ( $method eq "next" ) {
	    my $x;
	    do { $x = $all_iter->("next") } until
		(!$x or
		 !defined($m) && $all_iter->("name") !~ m/^m\d+:/
		 or
		 defined($m) && $all_iter->("name") =~ m/^m(\d+):/);
	    return $x;
	}
	elsif ( $method eq "name" ) {
	    my $name = $all_iter->("name");
	    $name =~ s{m\d+:}{};
	    return $name;
	}
	else {
	    return $all_iter->($method);
	}
    };

    $iter->("next") if defined($m);

    return $iter;
}

sub getTimeStamp {
    shift if blessed $_[0];
    my $when = shift || [ gettimeofday ];
    my ($endSeconds, $endMicroseconds) = @$when;
    my ($sec, $min, $hour) = localtime($endSeconds);

    return sprintf "%.2d:%.2d:%.2d.%.3d", $hour,$min,$sec,
	($endMicroseconds/1e3);
}

sub getInterval {
    shift if blessed $_[0];
    my $elapsed;
    if ( @_ == 2 or ref $_[0] ) {
	$elapsed = tv_interval(@_);
    } else {
	$elapsed = shift;
    }
    # only return milliseconds.
    my $fmt = sprintf("%.3f", $elapsed);
    return ( wantarray ? ($fmt, ($elapsed - $fmt)) : $fmt );
}

1;