PerlDancer · mikkoi · Jan 25, 2026
diff --git a/cpanfile b/cpanfile
@@ -77,6 +77,7 @@ recommends 'Type::Tiny::XS';
 recommends 'URL::Encode::XS';
 recommends 'YAML::XS';
 recommends 'Unicode::UTF8';
+recommends 'Log::Any';
 
 suggests 'Fcntl';
 suggests 'MIME::Types';
@@ -92,6 +93,7 @@ test_requires 'Test::Fatal';
 test_requires 'Test::More';
 test_requires 'Test::More', '0.92';
 test_requires 'Test::Exception';
+test_requires 'Log::Any';
 
 author_requires 'Test::NoTabs';
 author_requires 'Test::Pod';

diff --git a/lib/Dancer2/Core/Role/Logger.pm b/lib/Dancer2/Core/Role/Logger.pm
@@ -43,6 +43,12 @@ has log_format => (
     default => sub {'[%a:%P] %L @%T> %m in %f l. %l'},
 );
 
+has caller_stack_size => (
+    is      => 'rw',
+    isa     => Int,
+    default => sub { 9; },
+);
+
 my $_levels = {
 
     # levels < 0 are for core only
@@ -75,7 +81,6 @@ sub format_message {
     $message = Encode::encode( $self->auto_encoding_charset, $message )
       if $self->auto_encoding_charset;
 
-    my @stack = caller(8);
     my $request = $self->request;
     my $config = $self->config;
 
@@ -93,22 +98,7 @@ sub format_message {
         }
     };
 
-    my $chars_mapping = {
-        a => sub { $self->app_name },
-        t => sub { POSIX::strftime( "%d/%b/%Y %H:%M:%S", localtime(time) ) },
-        T => sub { POSIX::strftime( "%Y-%m-%d %H:%M:%S", localtime(time) ) },
-        u => sub { POSIX::strftime( "%d/%b/%Y %H:%M:%S", gmtime(time) ) },
-        U => sub { POSIX::strftime( "%Y-%m-%d %H:%M:%S", gmtime(time) ) },
-        P => sub {$$},
-        L => sub {$level},
-        m => sub {$message},
-        f => sub { $stack[1] || '-' },
-        l => sub { $stack[2] || '-' },
-        h => sub {
-            ( $request && ( $request->remote_host || $request->address ) ) || '-'
-        },
-        i => sub { ( $request && $request->id ) || '-' },
-    };
+    my $chars_mapping = $self->map_chars_to_subs($level, $message, );
 
     my $char_mapping = sub {
         my $char = shift;
@@ -133,6 +123,29 @@ sub format_message {
     return $fmt . "\n";
 }
 
+sub map_chars_to_subs {
+    my ( $self, $level, $message, $caller_delta ) = @_;
+    my @stack = caller($self->caller_stack_size + ($caller_delta // 0));
+    my $request = $self->request;
+    return {
+        a => sub { $self->app_name },
+        t => sub { POSIX::strftime( "%d/%b/%Y %H:%M:%S", localtime(time) ) },
+        T => sub { POSIX::strftime( "%Y-%m-%d %H:%M:%S", localtime(time) ) },
+        u => sub { POSIX::strftime( "%d/%b/%Y %H:%M:%S", gmtime(time) ) },
+        U => sub { POSIX::strftime( "%Y-%m-%d %H:%M:%S", gmtime(time) ) },
+        P => sub {$$},
+        L => sub {$level},
+        m => sub {$message},
+        p => sub { $stack[0] || '-' }, # package
+        f => sub { $stack[1] || '-' }, # filepath
+        l => sub { $stack[2] || '-' }, # line number
+        h => sub {
+            ( $request && ( $request->remote_host || $request->address ) ) || '-'
+        },
+        i => sub { ( $request && $request->id ) || '-' },
+    };
+};
+
 sub _serialize {
     my @vars = @_;
 
@@ -226,6 +239,10 @@ Log messages as B<error>.
 
 Provides a common message formatting.
 
+=method map_chars_to_subs
+
+Returns a hashref which has all the items needed for message formatting.
+
 =attr auto_encoding_charset
 
 Charset to use when writing a message.
@@ -282,6 +299,10 @@ timer
 
 message
 
+=item %p
+
+package name that emit the message
+
 =item %f
 
 file name that emit the message

diff --git a/lib/Dancer2/Logger/Log/Any.pm b/lib/Dancer2/Logger/Log/Any.pm
@@ -0,0 +1,119 @@
+package Dancer2::Logger::Log::Any;
+# ABSTRACT: Log::Any logger with support for structured logging
+
+use Moo;
+
+with 'Dancer2::Core::Role::Logger';
+
+use Dancer2::Core::Types qw/ Str InstanceOf /;
+
+has category => (
+  is => 'ro',
+  isa => Str
+);
+has _logger => (
+    is => 'ro',
+    lazy => 1,
+    isa => InstanceOf[ 'Log::Any::Proxy' ],
+    required => 1,
+    default => sub {
+        my ($self) = @_;
+        my %category = $self->category ? ( category => $self->category ) : ();
+        {
+            local $@ = undef;
+            eval { use Log::Any; 1; };
+            if( $@ ) {
+                warn 'Failed to use Log::Any. Have you installed it?';
+            }
+        }
+        return Log::Any->get_logger( %category ); 
+    },
+);
+sub log {
+    my ( $self, $level, $message, $data ) = @_;
+    $level = 'trace' if $level eq 'core';
+    $data = \(%{ $message }, %{ $data }), $message = q{} if( ref $message );
+    my $map = $self->map_chars_to_subs($level, $message, -1);
+    my %info = (
+        app_name => $map->{a}->(),
+        package => $map->{p}->(),
+        file => $map->{f}->(),
+        line => $map->{l}->(),
+        remote => $map->{h}->(),
+        request_id => $map->{i}->(),
+    );
+    $data->{ $_ } = $info{ $_ } foreach (keys %info);
+    $self->_logger->$level( $message ne q{} ? $message : (), $data );
+}
+
+# Create logging methods: core, debug, info, warning and error.
+#
+foreach my $level ( qw( core debug info warning error ) ) {
+    no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
+    no warnings 'redefine'; ## no critic (TestingAndDebugging::ProhibitNoWarnings)
+    *$level = sub {
+        my ( $self, @args ) = @_;
+        if( ref $args[-1] eq 'HASH' ) {
+            $self->_should($level) and $self->log( $level, _serialize(@args[0..($#args-1)]), $args[-1] );
+        } else {
+            $self->_should($level) and $self->log( $level, _serialize(@args) );
+        }
+    };
+}
+
+1;
+
+__END__
+
+=head1 DESCRIPTION
+
+This is a logging engine that allows you to print logging messages
+to any L<Log::Any::Adapter>. It supports
+L<structured logging|https://metacpan.org/pod/Log::Any::Proxy#Logging-Structured-Data>.
+
+=head USAGE
+
+See CONFIGURATION.
+
+You also need to configure a L<Log::Any::Adapter>. You can do this in your
+F<bin/app.psgi> or in any package you read in (C<use ...>):
+
+    use Log::Any::Adapter;
+    Log::Any::Adapter->set('Stdout');
+
+=head1 CONFIGURATION
+
+The setting C<logger> should be set to C<Log::Any> in order to use this logging
+engine in a Dancer2 application.
+
+In your Dancer2 config:
+
+    logger: 'Log::Any'
+    engines:
+        logger:
+            'Log::Any':
+                category: app-api
+
+If you omit the category setting, C<Log::Any> will use the name of
+this class as the category.
+
+=head1 METHODS
+
+=method log
+
+Writes the log messages to any or all L<Log::Any::Adapter>s.
+
+=method core debug info warning error
+
+Use these in Dancer2 to log to the wanted level.
+
+=head1 CAVEAT
+
+This package requires L<Log::Any> installed.
+It uses it lazily, loading it only at the point when it is needed.
+
+=head1 SEE ALSO
+
+L<Dancer2::Core::Role::Logger>
+
+C<Log::Any>, C<Log::Any::Adapter>
diff --git a/t/logger_log_any.t b/t/logger_log_any.t
@@ -0,0 +1,124 @@
+use Test::More;
+use strict;
+use warnings;
+
+subtest 'logger Log::Any' => sub {
+    use Dancer2;
+    use File::Temp qw/tempdir/;
+    my $dir = tempdir( CLEANUP => 1 );
+
+    set engines => {
+        logger => {
+            'Log::Any' => {
+                category  => 'app-web',
+            }
+        }
+    };
+    set logger  => 'Log::Any';
+    my $logfile = File::Spec->catfile($dir, 'test');
+    use Log::Any::Adapter;
+    Log::Any::Adapter->set('File', $logfile);
+
+    my $str = "Logging through Log::Any::Adapter::File";
+    info $str;
+
+    open my $log_file, '<', $logfile;
+    my $txt = <$log_file>;
+
+    like( $txt, qr/^\[[^\]]+\] $str/, 'Logged string matches');
+    my ($hash) = $txt =~ m/^\[[^\]]+\] $str (\{.*\})$/;
+    my $h = eval "$hash "; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+    is_deeply $h, {
+        app_name => "main",
+        file => __FILE__,
+        line => 23,
+        package => "main",
+        remote => "-",
+        request_id => "-"
+    }, 'Info structure matches';
+
+    done_testing;
+};
+
+subtest 'logger Log::Any with context' => sub {
+    use Dancer2;
+    use File::Temp qw/tempdir/;
+    my $dir = tempdir( CLEANUP => 1 );
+
+    set engines => {
+        logger => {
+            'Log::Any' => {
+                category  => 'app-web',
+            }
+        }
+    };
+    set logger  => 'Log::Any';
+    my $logfile = File::Spec->catfile($dir, 'test');
+    use Log::Any::Adapter;
+    Log::Any::Adapter->set('File', $logfile);
+
+    my $str = "Logging also context through Log::Any::Adapter::File";
+    info $str, { seq => 1, trx => 0, critical => 'Yes'  };
+
+    open my $log_file, '<', $logfile;
+    my $txt = <$log_file>;
+
+    like( $txt, qr/^\[[^\]]+\] $str/, 'Logged string matches');
+    my ($hash) = $txt =~ m/^\[[^\]]+\] $str (\{.*\})$/;
+    my $h = eval "$hash "; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+    is_deeply $h, {
+        app_name => "main",
+        file => __FILE__,
+        line => 61,
+        package => "main",
+        remote => "-",
+        request_id => "-",
+        seq => 1,
+        trx => 0,
+        critical => 'Yes',
+    }, 'Info structure matches';
+
+    done_testing;
+};
+
+subtest 'logger Log::Any with complex message and context' => sub {
+    use Dancer2;
+    use File::Temp qw/tempdir/;
+    my $dir = tempdir( CLEANUP => 1 );
+
+    set engines => {
+        logger => {
+            'Log::Any' => {
+                category  => 'app-web',
+            }
+        }
+    };
+    set logger  => 'Log::Any';
+    my $logfile = File::Spec->catfile($dir, 'test');
+    use Log::Any::Adapter;
+    Log::Any::Adapter->set('File', $logfile);
+
+    my $str = "Logging also context through Log::Any::Adapter::File";
+    info $str, 'more', 'parts', { seq => 2, critical => 'No'  };
+
+    open my $log_file, '<', $logfile;
+    my $txt = <$log_file>;
+
+    like( $txt, qr/^\[[^\]]+\] ${str}moreparts/, 'Logged string matches');
+    my ($hash) = $txt =~ m/^\[[^\]]+\] ${str}moreparts (\{.*\})$/;
+    my $h = eval "$hash "; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+    is_deeply $h, {
+        app_name => "main",
+        file => __FILE__,
+        line => 102,
+        package => "main",
+        remote => "-",
+        request_id => "-",
+        seq => 2,
+        critical => 'No',
+    }, 'Info structure matches';
+
+    done_testing;
+};
+
+done_testing;