=head1 NAME

CFX5::ExitRoutines - Tidy-ups and Signal Handling

=head1 SYNOPSIS

This module deals with tidying up after ourselves.

=cut

package CFX5::ExitRoutines;

use strict;

use vars qw($CVSVersion);
$CVSVersion='$Id$ ';

use Exporter;
use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS);

@ISA=qw(Exporter);
@EXPORT_OK=qw(enable_signal_traps disable_signal_traps default_signal_traps
	      push_tidyup pop_tidyup remove_tidyup);

use CFX5::Output qw(:all);

=head1 EXPORT TAGS

=over

=item :signal

Imports the signal-handling routines.

=item :tidyup

Imports the Cpush_tidyup> and C<pop_tidyup> routines.

=back

=cut

%EXPORT_TAGS = (
    signal => [qw(enable_signal_traps disable_signal_traps 
		  default_signal_traps)],
    tidyup => [qw(push_tidyup pop_tidyup remove_tidyup)],
);

=head1 SIGNAL FUNCTIONS

=head2 enable_signal_traps

Set up the standard informative traps, and make sure we run tidyups if
the user presses Ctrl-C etc. This function is normally called by the
standard initialisation code (at compile-time), and under most
circumstances should not be required by the user.

=cut

sub enable_signal_traps {
    sub signal_msg_HUP {
	_abort "User logged out before $CFX5::Output::Prog finished.";
    }
    sub signal_msg_INT {
	_abort "$CFX5::Output::Prog was interrupted by the user.";
    }
    sub signal_msg_TERM {
	_abort "$CFX5::Output::Prog was killed by the user.";
    }

    $SIG{HUP}=\&signal_msg_HUP;
    $SIG{INT}=\&signal_msg_INT;
    $SIG{TERM}=\&signal_msg_TERM;

    return 1;
}

enable_signal_traps();
# unless $^O eq "MSWin32";

=head2 disable_signal_traps

This is not normally a user-callable function, but may be useful under
some circumstances. It sets the signals which we normally catch and
abort on to be ignored. By default, this is done while we tidy up at
the end of a run, to prevent an impatient user from interrupting the
tidy-up process.

Tidyup routines which really truly want to be interruptible can use
C<default_signal_traps> at the beginning of the function to restore
the native handling (using C<enable_signal_traps> is probably not a
good idea), and C<disable_signal_traps> at the end to restore the
normal handling. If you do this, be careful about calling your tidyup
routine from within the program body!

=cut

# IMPORTANT NOTE: Installing or querying handlers for some signals
# will cause Perl for Win32 to die with an access violation:
#    ABRT
#    STOP
#    BREAK

sub disable_signal_traps {
  $SIG{HUP}='IGNORE';
  $SIG{INT}='IGNORE';
  $SIG{TERM}='IGNORE';
  
  return 1;
}

disable_signal_traps() if $^O eq "MSWin32";

=head2 default_signal_traps

Restore the default handling of the errors which we normally trap.

=cut

sub default_signal_traps {
  $SIG{HUP}='DEFAULT';
  $SIG{INT}='DEFAULT';
  $SIG{TERM}='DEFAULT';
  
  return 1;
}

=head1 TIDYUP MANIPULATION

=head2 push_tidyup

Add a routine to the list of things to do when tidying up. These
routines are run when the Perl interpreter exits normally, but not
when it is interrupted by a signal (see C<init_signal_traps>) or
replaced by execing another program.

The argument(s) should be reference(s) to C<sub>s to call.

Routines are run latest-first.

=cut

use vars qw(@TidyUpRoutines);
BEGIN {
  @TidyUpRoutines=();
}

sub push_tidyup {
  unshift @TidyUpRoutines, @_;
  return 1;
}

=head2 pop_tidyup

Remove the latest routine added to the tidyup stack by
C<push_tidyup>. Returns the routine reference, so you can do

    &{pop_tidyup()}();

at the end of a block to tidy up after yourself before carrying on.

=cut

sub pop_tidyup {
    shift @TidyUpRoutines;
}

=head2 remove_tidyup

  do_this_now() if remove_tidyup(\&do_this_now);

Remove the named subroutine from the tidyup stack. Return value is the number
of times the reference was encountered in the stack.

This is useful if a function I<must> be called on exit, so it is pushed
onto the stack early on, but then can/should be run early after the script
has done its stuff.

=cut

sub remove_tidyup {
  my $sub=shift;
  my $cnt=0;
  
  # I hope I can compare references like this ... should be OK ... note that
  # since $cnt starts at 0, ++$cnt is always true ...
  @TidyUpRoutines = grep { ! ( $_ eq $sub and ++$cnt ) } @TidyUpRoutines;

  $cnt;
}

=head1 DEFAULT TIDYUP FUNCTIONS

These functions are run at exit for all scripts; there should be a way
of stopping this, but currently there isn't. They are not exportable,
and should probably not be called directly anyway.

=head2 Run tidyup routines

This C<END> block is executed when the interpreter exits. It calls the
routines registered with C<push_tidyup> in latest-first order. The
routines are called with one parameter, which is the error message
causing the exit (or the last error message seen if we're exiting via
C<exit_if_error>), or undefined if there is no error.

Note that this is no longer an C<END> block, as they don't work with
the compiler. It is still provided via END, but we also overload the
global C<exit> function to run the tidyups.

=cut

sub run_tidyups {
  my $c;
  for $c (@TidyUpRoutines) {
      &$c($CFX5::Output::LastError);
  }
  @TidyUpRoutines=();
}

sub END { run_tidyups(); }

sub my_exit {
  _debug("Running tidyups ...");
  run_tidyups();
  my $rv=$_[0];
  _debug("undefined rv"),$rv=2 unless defined $rv;
  _debug("Exiting: $rv from [", join(", ",map { defined $_ ? $_ : '(undef)' } @_), "]");
  CORE::exit($rv);
}

*CORE::GLOBAL::exit = \&my_exit;

1;
