#!perl
#

use strict;
use warnings;

package Log::Any::Adapter::Carp;

our ($VERSION) = '1.01';
our (@CARP_NOT) = ( __PACKAGE__, 'Log::Any::Proxy' );

use Scalar::Util qw(reftype);
use Log::Any::Adapter::Util 1;

use parent 'Log::Any::Adapter::Base';

sub init {
    my ($self) = @_;
    my $i = 1;
    my $callpack;
    my $logger;

    do { $callpack = caller( $i++ ) } while $callpack =~ /^Log::Any::/;

    $self->{log_level} = 'trace' unless exists $self->{log_level};
    $self->{log_level} =
      Log::Any::Adapter::Util::numeric_level( $self->{log_level} )
      unless $self->{log_level} =~ /^\d+$/;

    if ( $self->{no_trace} ) {
        $self->{send_msg} = sub {
            my $text = shift || '';
            $text .= "\n" unless $text =~ /\n$/;
            warn $text;
        };
    }
    elsif ( $self->{skip_packages}
        and reftype( $self->{skip_packages} ) eq 'REGEXP' )
    {
        my $skipadd = '|^Log::Any::|^Carp::Clan::'
          . ( $self->{skip_me} ? "|^$callpack\$" : '' );
        my $skipre = qr/$self->{skip_packages}$skipadd/;

        require Carp::Clan;
        {

            package Log::Any::Adapter::Carp::Clannish;
            Carp::Clan->import($skipre);
        }
        no warnings 'once';
        $self->{send_msg} =
            $self->{full_trace}
          ? *Log::Any::Adapter::Carp::Clannish::cluck
          : *Log::Any::Adapter::Carp::Clannish::carp;
    }
    else {
        require Carp;
        {

            package Log::Any::Adapter::Carp::Carpish;
            Carp->import(qw/ carp cluck /);
        }

        my @skip_pkgs;
        push @skip_pkgs, $callpack
          if $self->{skip_me};
        push @skip_pkgs, @{ $self->{skip_packages} || [] };

        my $carp =
            $self->{full_trace}
          ? *Log::Any::Adapter::Carp::Carpish::cluck
          : *Log::Any::Adapter::Carp::Carpish::carp;

        $self->{send_msg} = sub {

            # Ugh, but this is the only Carp mechanism to keep a package out
            # of the shortmess if the call is *from* it
            local %Carp::Internal;
            $Carp::Internal{$_}++ for @skip_pkgs;
            $carp->(@_);
          }
    }

}

foreach my $method ( Log::Any::Adapter::Util::logging_methods() ) {
    no strict 'refs';
    my $method_level = Log::Any::Adapter::Util::numeric_level($method);
    *{$method} = sub {
        my $self = shift;
        return if $method_level > $self->{log_level};
        $self->{send_msg}->(@_);
    };
}

foreach my $method ( Log::Any::Adapter::Util::detection_methods() ) {
    no strict 'refs';
    my $base = substr( $method, 3 );
    my $method_level = Log::Any::Adapter::Util::numeric_level($base);
    *{$method} = sub {
        return !!( $method_level <= $_[0]->{log_level} );
    };
}

1;

__END__

=head1 NAME

Log::Any::Adapter::Carp - Simple adapter for logging via warnings

=head1 SYNOPSIS

  use Log::Any::Adapter;
  # Minimal messages
  Log::Any::Adapter->set('Carp', no_trace => 1, log_level => 'warn');
  # Stack trace with every message
  Log::Any::Adapter->set('Carp', full_trace => 1, log_level => 'debug');

=head1 DESCRIPTION

This relatvely simple adapter for L<Log::Any> is in many ways similar
to the builtin L<Log::Any::Adapter::Stderr>, but instead of writing
messages directly to F<STDERR>, it uses Perl's L<perlfunc/warn>
mechanism.  This allows you to do things like generate stack traces,
or redirect the message via a C<$SIG{__WARN__}> hook, if you're using
that to handle diagnostic reporting from your application.

By default, the log message is generated by L<Carp/carp>, so will
have file and line information appended.

Log category is ignored.  Other attributes that can be used to
configure the adapter include:

=over 4

=item log_level

The minimum level of message to log.

=item no_trace

If true, do not include any traceback or location information with the
logged message.  This causes a newline to be appended to the message,
if it's not already there, and the result to be handed off to
L<perlfunc/warn>.

A true value supersedes any of the other traceback-modifying
attributes described below.

Defaults to false.

=item full_trace

If true, the logged message is output with a full stack trace via
L<Carp/cluck>.

A true value supersedes any of the other traceback-modifying
attributes except L</no_trace>.

Defaults to false.

=item skip_me

If true, this causes the package calling L<Log::Any::Adapter/set> to
be skipped when determining file and line information.  This is
probably not what you want in your application's mainline code, but
may be useful if you're using a separate logging class, or logging
messages from library.  But rememeber that the application can
override your settings if it chooses by calling
L<Log::Any::Adapter/set>.

Defaults to false.

=item skip_packages

Allows you to specify other packages to skip when L<Carp/carp> is
looking for location information.

If the value is an array reference, its contents are taken as package names
to be excluded.

If the value is a compiled regular expression, then L<Carp::Clan> is
loaded and the content are used as a pattern for excluding packages.
If L<Carp::Clan> can't be loaded, a fatal error occurs.  (Usage note:
L<Carp::Clan>'s peculiar habit of prepending to the message the name
of the function called I<from> the last skipped package may limit its
value for this particular purpose.  At a minimum, you may wish to
consider trimming off the prefix via a C<$SIG{__WARN__}> hook.)

Defaults to empty.

=back

=head2 EXPORT

None.

=head1 SEE ALSO

L<Log::Any>, L<Carp>, L<Carp::Clan>

=head1 BUGS AND CAVEATS

Are there, for certain, but have yet to be cataloged.

=head1 VERSION

version 1.01

=head1 AUTHOR

Charles Bailey <cbail@cpan.org>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2015 by Charles Bailey

This software may be used under the terms of the Artistic License or
the GNU General Public License, as the user prefers.

=head1 ACKNOWLEDGMENT

The code incorporated into this package was originally written with
United States federal funding as part of research work done by the
author at the Children's Hospital of Philadelphia.

=cut