package Modules::Prof;

BEGIN {
	use Exporter;
	@ISA = qw(Exporter);
	@EXPORT = qw(&time_point);
}

my %conf = (
	'profile'	=> 1,
	'warnings'	=> 1
);

my %time_start = ();
my %time_stop  = ();

my %commands = (
	'start' 		=> 'cmd_time_start',
	'stop'  		=> 'cmd_time_stop',
	'print_close' 	=> 'cmd_time_print_close',
	'stop_print' 	=> 'cmd_time_stop_print',	
);

sub configure(%) {
	my (%new_conf) = @_;
	foreach my $param (keys %new_conf) {
		$conf{$param} = $new_conf{$param};
	}
	return 1;
}

sub time_point($;@) {
	@caller = caller;
	my ($cmd, @args) = @_;
	
	return 1 unless $conf{'profile'};	# do nothing

	unless (exists $commands{$cmd}) {
		&prof_warn("Not existent command '$cmd' was called.");
		return 0;
	}
	my $ret = &{$commands{$cmd}}(@args);
	@caller = ();
	return $ret;
}

sub cmd_time_start($) {
	my ($mark) = @_;
	
	if (exists $time_start{$mark}) {
		&prof_warn("Redefining start-timepoint '$mark' ($time_start{$mark}).");	
	}
	$time_start{$mark} = time;
	return 1;
}

sub cmd_time_stop($) {
	my ($mark) = @_;
	
	if (exists $time_stop{$mark}) {
		&prof_warn("Redefining stop-timepoint '$mark' ($time_stop{$mark}).");	
	}
	unless (exists $time_start{$mark}) {
		&prof_warn("No matching start-timepoint '$mark' found.");	
	}
	$time_stop{$mark} = time;
	return 1;
}

sub cmd_time_close($) {
	my ($mark) = @_;

	unless (exists $time_start{$mark}) {
		&prof_warn("Closing not existent start-timepoint '$mark'.");	
	}
	unless (exists $time_stop{$mark}) {
		&prof_warn("Closing not existent stop-timepoint '$mark'.");	
	}
	
	delete ($time_start{$mark});
	delete ($time_stop{$mark});
	return 1;
}

sub cmd_time_print_close($$) {
	my ($mark, $msg) = @_;
	
	unless (exists $time_start{$mark}) {
		&prof_warn("No start-timepoint '$mark' found.");	
	}
	unless (exists $time_stop{$mark}) {
		&cmd_time_stop($mark);			# autoclosing timepoint
	}
	my $timestr = sprintf "%8d sec", $time_stop{$mark} - $time_start{$mark};
	chomp $msg;			# drop end of line if any
	$msg =~ s/<time>/$timestr/;
	print STDERR $msg."\n";
	
	return &cmd_time_close($mark);
}

sub prof_warn($) {
	my ($msg) = @_;
	my (@pkg, $file, $line) = @caller;
	print STDERR "PROFILE WARNING at package $pkg, file $file, line $line: $msg\n";
	return 1;
}

1;