view release on metacpan or  search on metacpan

lib/AtExit.pm  view on Meta::CPAN

sub new {
    ## Determine if we were called via an object-ref or a classname
    my $this = shift;
    my $class = ref($this) || $this;

    ## Bless ourselves into the desired class and perform any initialization
    my $self = {
                 'EXIT_SUBS' => [],
                 'EXITING'   => 0,
                 'IGNORE_WHEN_EXITING' => 1
               };
    bless $self, $class;
    $self->atexit(@_)  if @_;
    return $self;
}

sub exit_subs {
    ## If called as an object, get the object-ref
    my $self = (@_  and  ref $_[0]) ? shift : \%EXIT_ATTRS;

    return  $self->{EXIT_SUBS};
}

sub is_exiting {
    ## If called as an object, get the object-ref
    my $self = (@_  and  ref $_[0]) ? shift : \%EXIT_ATTRS;

    return  $self->{EXITING};
}

sub ignore_when_exiting {
    ## If called as an object, get the object-ref
    my $self = (@_  and  ref $_[0]) ? shift : \%EXIT_ATTRS;

    ## Discard the class-name if its the first arg
    unless ($self  or  @_ == 0) {
       local  $_  = $_[0];
       shift  if (defined $_  and  $_  and  /[A-Za-z_]/);
    }

    $self->{IGNORE_WHEN_EXITING} = shift  if @_;
    return  $self->{IGNORE_WHEN_EXITING};
}

sub atexit {
    ## If called as an object, get the object-ref
    local $_ = ref $_[0];
    my $self = ($_ and $_ ne 'CODE') ? shift : \%EXIT_ATTRS;

    ## Get the remaining arguments
    my ($exit_sub, @args) = @_;

    return  0  if ($self->{EXITING}  and  $self->{IGNORE_WHEN_EXITING});

    unless (ref $exit_sub) {
       ## Caller gave us a sub name instead of a sub reference.
       ## Need to make sure we have the callers package prefix
       ## prepended if one wasn't given.
       my $pkg = '';
       $pkg = (caller)[0] . "::"  unless $exit_sub =~ /::/o;

       ## Now turn the sub name into a hard sub reference.
       $exit_sub = eval "\\&$pkg$exit_sub";
       undef $exit_sub  if ($@);
    }
    return  0  unless (defined $exit_sub) && (ref($exit_sub) eq 'CODE');

    ## If arguments were given, wrap the invocation up in a closure
    my $subref = (@args > 0) ? sub { &$exit_sub(@args); } : $exit_sub;

    ## Now put this sub-ref on the queue and return what we just registered
    unshift(@{ $self->{EXIT_SUBS} }, $subref);
    return  $subref;
}

sub rmexit {
    ## If called as an object, get the object-ref
    local $_ = ref $_[0];
    my $self = ($_ and $_ ne 'CODE') ? shift : \%EXIT_ATTRS;

    ## Get remaining arguments
    my @subrefs = @_;

    ## Unregister each sub in the given list.
    ##   [ I suppose I could come up with a faster way to do this than
    ##     doing a separate iteration for each argument, but I wont
    ##     worry about that just yet. ]
    ##
    my ($unregistered, $i) = (0, 0);
    my $exit_subs = $self->{EXIT_SUBS};
    if (@subrefs == 0) {
        ## Remove *all* exit-handlers
        $unregistered = scalar(@$exit_subs);
        $exit_subs = $self->{EXIT_SUBS} = [];
    }
    else {
        my $subref;
        foreach $subref (@subrefs) {
            next unless (ref($subref) eq 'CODE');
            ## Iterate over the queue and remove the first match
            for ($i = 0; $i < @$exit_subs; ++$i) {
                if ($subref == $exit_subs->[$i]) {
                    splice(@$exit_subs, $i, 1);
                    ++$unregistered;
                    last;
                }
            }
        }
    }
    return  $unregistered;
}

sub do_atexit {
    ## If called as an object, get the object-ref
    my $self = (@_  and  ref $_[0]) ? shift : \%EXIT_ATTRS;

    $self->{EXITING} = 1;

    ## Handle atexit() stuff in reverse order of registration
    my $exit_subs = $self->{EXIT_SUBS};