1package Log::Dispatch::Base;
2
3use strict;
4use warnings;
5
6use Carp ();
7use Log::Dispatch::Vars
8    qw( %CanonicalLevelNames %LevelNamesToNumbers @OrderedLevels );
9use Scalar::Util qw( refaddr );
10
11our $VERSION = '2.70';
12
13## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
14sub _level_as_number {
15    my $self  = shift;
16    my $level = shift;
17
18    my $level_name = $self->level_is_valid($level);
19    return unless $level_name;
20
21    return $LevelNamesToNumbers{$level_name};
22}
23## use critic
24
25sub level_is_valid {
26    shift;
27    my $level = shift;
28
29    if ( !defined $level ) {
30        Carp::croak('Logging level was not provided');
31    }
32
33    if ( $level =~ /\A[0-9]+\z/ && $level <= $#OrderedLevels ) {
34        return $OrderedLevels[$level];
35    }
36
37    return $CanonicalLevelNames{$level};
38}
39
40## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
41sub _apply_callbacks {
42    my $self = shift;
43    my %p    = @_;
44
45    my $msg = delete $p{message};
46    for my $cb ( @{ $self->{callbacks} } ) {
47        $msg = $cb->( message => $msg, %p );
48    }
49
50    return $msg;
51}
52
53sub add_callback {
54    my $self  = shift;
55    my $value = shift;
56
57    Carp::carp("given value $value is not a valid callback")
58        unless ref $value eq 'CODE';
59
60    $self->{callbacks} ||= [];
61    push @{ $self->{callbacks} }, $value;
62
63    return;
64}
65
66sub remove_callback {
67    my $self = shift;
68    my $cb   = shift;
69
70    Carp::carp("given value $cb is not a valid callback")
71        unless ref $cb eq 'CODE';
72
73    my $cb_id = refaddr $cb;
74    $self->{callbacks}
75        = [ grep { refaddr $_ ne $cb_id } @{ $self->{callbacks} } ];
76
77    return;
78}
79
801;
81
82# ABSTRACT: Code shared by dispatch and output objects.
83
84__END__
85
86=pod
87
88=encoding UTF-8
89
90=head1 NAME
91
92Log::Dispatch::Base - Code shared by dispatch and output objects.
93
94=head1 VERSION
95
96version 2.70
97
98=head1 SYNOPSIS
99
100  use Log::Dispatch::Base;
101
102  ...
103
104  @ISA = qw(Log::Dispatch::Base);
105
106=head1 DESCRIPTION
107
108Unless you are me, you probably don't need to know what this class
109does.
110
111=for Pod::Coverage .*
112
113=head1 SUPPORT
114
115Bugs may be submitted at L<https://github.com/houseabsolute/Log-Dispatch/issues>.
116
117I am also usually active on IRC as 'autarch' on C<irc://irc.perl.org>.
118
119=head1 SOURCE
120
121The source code repository for Log-Dispatch can be found at L<https://github.com/houseabsolute/Log-Dispatch>.
122
123=head1 AUTHOR
124
125Dave Rolsky <autarch@urth.org>
126
127=head1 COPYRIGHT AND LICENSE
128
129This software is Copyright (c) 2020 by Dave Rolsky.
130
131This is free software, licensed under:
132
133  The Artistic License 2.0 (GPL Compatible)
134
135The full text of the license can be found in the
136F<LICENSE> file included with this distribution.
137
138=cut
139