package OIE::Debug::OnTheFly;

# Copyright (C) 2007  Nick Urbanik <nicku@nicku.org>

# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.

# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.

# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

use 5.006001;
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = (
    'debug' => [ qw( if_debug debug note touch_file $debug ) ],
     init   => [ qw( logfile base_dir ) ],
);

use POSIX qw(strftime);
use File::Spec;
use Carp;

our @EXPORT_OK = map @$_, values %EXPORT_TAGS;

our $VERSION = 'dummy';

my $SELF = $0;
for ( $SELF ) { s{.*/}{}; s{\.pl$}{} }

my $base = File::Spec->rel2abs( $0 );
for ( $base ) { s{/[^/]*$}{}; s{/script$}{}; s{/bin$}{}; }

( my $MODULENAME = $base ) =~ s{.*/}{};

my $logfile;

sub logfile {
    $logfile = shift || "/var/log/$MODULENAME/$SELF.log";
    ( my $logdir = $logfile ) =~ s{/[^/]*$}{};
    mkdir $logdir or warn "Cannot mkdir '$logdir'\n" unless -d $logdir;
    return $logfile;
}

sub base_dir {
    $base = shift || $base;
    return $base;
}

# "our" so can be set by GetOptions as well as on the fly:
our $debug;

sub if_debug {
    $debug = -f "$base/debug" || -f "$base/debug.$SELF";
}

sub note {
    my @msg = @_;
    $msg[ -1 ] =~ s{[\n\r ]*$}{};
    my $timestamp_pid = strftime "%F %T \[$$]: ", localtime;
    $msg[ 0 ] = "$timestamp_pid$msg[ 0 ]";
    s{[\n\r]}{\n$timestamp_pid}msg foreach @msg;

    logfile unless $logfile;
    open my $log_fh, '>>', $logfile or warn "Cannot open '$logfile': $!";
    print $log_fh @msg, "\n" or warn "Cannot write '", @msg, "' to '$logfile': $!";
    close $log_fh or warn "Cannot close '$logfile': $!";
    return 1;
}

sub debug {
    return unless $debug;
    goto &note;
}

# The die and warn handlers are disabled while they run (p. 655 of Cookbook 2e),
# so we don't death spiral calling warn from note.
$SIG{__WARN__} = sub {
    note "WARNING:\n", Carp::longmess, @_;
    warn @_;
};

$SIG{__DIE__} = sub {
    note "TERMINATING:\n", Carp::longmess, @_;
    die @_;
};

# This is called just before calling exit at the end of a successful
# run.  Failure causes the program to die before calling this.
# Monitord from CVS module ose_md runs with plugin from CVS module
# ose_md_soe file_check to send a Nagios alert if the age of the file
# is too great.

sub touch_file {
    my ( $file_to_touch ) = @_;
    ( my $dir = $file_to_touch ) =~ s{(.*)/[^/]+$}{$1}xms;
    mkdir $dir, 0700 or die "CANNOT MAKE DIRECTORY '$dir': $!"
        unless -d $dir;
    open my $fh, '>', $file_to_touch
        or die "Unable to open '$file_to_touch': $!";
    close $fh or die "Unable to close '$file_to_touch': $!";
    debug "Touched $file_to_touch indicating success\n";
}

1;

__END__

=head1 NAME

OIE::Debug::OnTheFly - Perl extension supporting on-the-fly debugging.

=head1 SYNOPSIS

  use OIE::Debug::OnTheFly qw{ :debug };

  if_debug;

  debug "Here is ", "a debugging message ",
        "put in log if debugging enabled\n";
  note  "Here is ", "a message ",
        "put in log unconditionally\n";
  warn  "WARNING: Here is ", "a warning message\n",
        "always goes into log, and warns to stderr\n";
  die   "ERROR: Here is ", "a terminating message\n";

  # Will create directory /home/dhcp/var if it doesn't exist:
  touch_file "/home/dhcp/var/aggregator_ok";

=head1 DESCRIPTION

Provides on-the-fly debugging.

Takes the safe route of opening and closing the log with each message.
Do not call B<note> a thousand times every second :-)

I<base_dir> is the name of the directory where the C<debug> or
C<debug.>I<appname> file is touched to turn on debugging.  It is either
the directory where the executable is, or else if the directory is
C<scipts> or C<bin>, then C<$base> is the parent of the C<bin> or
C<scripts> directory containing the executable.  To obtain this,
progressively the application name, then '/scripts', then '/bin' are
removed from the path of the command name.

Touch a file I<base_dir>C</debug> to debug all applications in C<$base> or
C<$base/bin> that use this module.

touch a file C<$base/debug.>I<appname> to debug a program I<appname>
or I<appname.pl> in C<$base> or C<$base/bin>.

You can also set the variable B<$OIE::Debug::OnTheFly::debug>
externally (perhaps using C<Getopt::Long>) to enable logging by
B<debug> statements.

Logs appear as a file C</var/log/>I<modulename>/I<appname>C<.log>

If you don't like that, set the logfile using B<logfile>.  You can
also set the I<base_dir> using B<base_dir>.  See below.

Every line in a log entry is prefixed by a date/time stamp and [$$].

Newlines are preserved in log entries; trailing newlines are replaced
by a single newline.

All of B<note>, B<debug>, B<note>, B<warn> and B<die> take a list of
strings, as print does.

B<note> writes to the log unconditionally.

B<debug> writes to the log if $debug is defined, either through
B<if_debug> being called when a C<$base/debug> or
C<$base/debug.>I<appname> file exists, or by being set externally,
perhaps with C<Getopt::Long>.

B<warn> is a __WARN__ handler that writes its arguments to the log,
then prints a stack trace to the log, then calls C<warn>.

B<die> is a __DIE__ handler that writes its arguments to the log,
then prints a stack trace to the log, then calls C<die>.

B<logfile> can be called to specify a different logfile, or with no
argument, to obtain the current value of the logfile name.  The
optional parameter is the full pathname of the log file.  Call
B<logfile> before calling B<if_debug>.

B<base_dir> can specify a different directory in which the C<debug> or
C<debug.>I<appname> file is checked for by B<if_debug>.  B<base_dir>
returns the current value of this directory.  If no parameter is
given, then it will not change the current value.

To specify a new I<base_dir>, you need to specify a I<logfile_path>
also.  It is not necessary to call B<init> unless you want to change
either of these from the default.

B<touch_file> is useful for monitoring using the
file_change module, which alarms if the given file is older than a
configured age.

B<touch_file> is called just before calling exit at the end of a
successful run.  Failure causes the program to die before calling
this.  Monitord from CVS module C<ose_md> runs with plugin from CVS
module C<ose_md_soe> C<file_check> to send a Nagios alert if the age
of the file is too great.

B<touch_file> will attempt to create the directory component of its
argument if it doesn't exist.

Call B<if_debug> during some regular processing so that the presence
of the debug file can be tested for with appropriate frequency, if the
on-the-fly enabling of debugging is desired.  Otherwise simply set the
$debug value using something like Getopt::Long.

=head3 Cleaning Up

Use logrotate(8).

You might wish to remove older debug files automatically:

 crontab_include => {
     # Turn off debugging if untouched for 48 hrs
     "$_path.*debug\*" => "0 * * * * root find $_path -maxdepth 1 -type f -name 'debug*' -mmin +2880 -print0 | xargs -0r rm -f",
 }

=head2 EXPORT

None by default.

the B<:debug> tag is available, which exports 
if_debug debug note touch_file $debug

The B<:init> tag is available, which exports
logfile base_dir

=head1 SEE ALSO

A few ideas came from Iain's C<dslenforce> script in the C<hsdenforce>
CVS module.

=head1 AUTHOR

Nick Urbanik, E<lt>nick.urbanik@optusnet.com.auE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2007 by Nick Urbanik

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.8 or,
at your option, any later version of Perl 5 you may have available.

=cut