File Coverage

blib/lib/Log/Any/App.pm

Criterion	Covered	Total	%
statement	487	604	80.6
branch	156	252	61.9
condition	25	47	53.1
subroutine	44	50	88.0
pod	1	1	100.0
total	713	954	74.7

package Log::Any::App;

our $DATE = '2016-03-16'; # DATE
our $VERSION = '0.53'; # VERSION

# i need this to run on centos 5.x. otherwise all my other servers are debian
# 5.x and 6.x+ (perl 5.010).
use 5.008000;
use strict;
use warnings;

use File::Path qw(make_path);
use File::Spec;
use Log::Any::IfLOG;
use Log::Any::Adapter;

use vars qw($dbg_ctx);

our %PATTERN_STYLES = (
    plain             => '%m',
    plain_nl          => '%m%n',
    script_short      => '[%r] %m%n',
    script_long       => '[%d] %m%n',
    daemon            => '[pid %P] [%d] %m%n',
    syslog            => '[pid %p] %m',
);
for (keys %PATTERN_STYLES) {
    $PATTERN_STYLES{"cat_$_"} = "[cat %c]$PATTERN_STYLES{$_}";
    $PATTERN_STYLES{"loc_$_"} = "[loc %l]$PATTERN_STYLES{$_}";
}

my $init_args;
our $init_called;
my $is_daemon;

# poor man's version of 5.10's //
sub _ifdef {
    my $def = pop @_;
    for (@_) {
        return $_ if defined($_);
    }
    $def;
}

# j=as json (except the last default)
sub _ifdefj {
    require JSON::MaybeXS;

    my $def = pop @_;
    for (@_) {
        return JSON::MaybeXS::decode_json($_) if defined($_);
    }
    $def;
}

sub init {
    return if $init_called++;

    $is_daemon = undef;

    my ($args, $caller) = @_;
    $caller ||= caller();

    my $spec = _parse_opts($args, $caller);
    if ($spec->{log} && $spec->{init}) {
        _init_log4perl($spec);
        if ($ENV{LOG_ENV}) {
           my $log_main = Log::Any->get_logger(category => 'main');
           $log_main->tracef("Environment variables: %s", \%ENV);
       }
    }
    $spec;
}

sub _gen_appender_config {
    my ($ospec, $apd_name, $filter) = @_;

    my $name = $ospec->{name};
    my $class;
    my $params = {};
    if ($name =~ /^dir/i) {
        $class = "Log::Dispatch::Dir";
        $params->{dirname}   = $ospec->{path};
        $params->{filename_pattern} = $ospec->{filename_pattern};
        $params->{max_size}  = $ospec->{max_size} if $ospec->{max_size};
        $params->{max_files} = $ospec->{histories}+1 if $ospec->{histories};
        $params->{max_age}   = $ospec->{max_age} if $ospec->{max_age};
    } elsif ($name =~ /^file/i) {
        $class = "Log::Dispatch::FileWriteRotate";
        my ($dir, $prefix) = $ospec->{path} =~ m!(.+)/(.+)!;
        $dir ||= "."; $prefix ||= $ospec->{path};
        $params->{dir}         = $dir;
        $params->{prefix}      = $prefix;
        $params->{suffix}      = $ospec->{suffix};
        $params->{size}        = $ospec->{max_size};
        $params->{period}      = $ospec->{period};
        $params->{histories}   = $ospec->{histories};
        $params->{buffer_size} = $ospec->{buffer_size};
    } elsif ($name =~ /^screen/i) {
        $class = "Log::Log4perl::Appender::" .
            ($ospec->{color} ? "ScreenColoredLevels" : "Screen");
        $params->{stderr}  = $ospec->{stderr} ? 1:0;
        $params->{"color.WARN"} = "bold blue"; # blue on black is so unreadable
    } elsif ($name =~ /^syslog/i) {
        $class = "Log::Dispatch::Syslog";
        $params->{mode}     = 'append';
        $params->{ident}    = $ospec->{ident};
        $params->{facility} = $ospec->{facility};
    } elsif ($name =~ /^unixsock/i) {
        $class = "Log::Log4perl::Appender::Socket::UNIX";
        $params->{Socket} = $ospec->{path};
    } elsif ($name =~ /^array/i) {
        $class = "Log::Dispatch::ArrayWithLimits";
        $params->{array}     = $ospec->{array};
        $params->{max_elems} = $ospec->{max_elems};
    } else {
        die "BUG: Unknown appender type: $name";
    }

    join(
        "",
        "log4perl.appender.$apd_name = $class\n",
        (map { "log4perl.appender.$apd_name.$_ = $params->{$_}\n" }
             grep {defined $params->{$_}} keys %$params),
        "log4perl.appender.$apd_name.layout = PatternLayout\n",
        "log4perl.appender.$apd_name.layout.ConversionPattern = $ospec->{pattern}\n",
        ($filter ? "log4perl.appender.$apd_name.Filter = $filter\n" : ""),
    );
}

sub _lit {
    require Data::Dump;
    Data::Dump::dump(shift);
}

sub _gen_l4p_config {
    my ($spec) = @_;

    my @otypes = qw(file dir screen syslog unixsock array);

    # we use a custom perl code to implement filter_* specs.
    my @fccode;
    push @fccode, 'my %p = @_';
    push @fccode, 'my $str';
    for my $ospec (map { @{ $spec->{$_} } } @otypes) {
        if (defined $ospec->{filter_text}) {
            push @fccode, '$str = '._lit($ospec->{filter_text});
            push @fccode, 'return 0 if $p{name} eq '._lit($ospec->{name}).
                ' && index($_, $str) == -1';
        }
        if (defined $ospec->{filter_no_text}) {
            push @fccode, '$str = '._lit($ospec->{filter_no_text});
            push @fccode, 'return 0 if $p{name} eq '._lit($ospec->{name}).
                ' && index($_, $str) > -1';
        }
        if (defined $ospec->{filter_citext}) {
            push @fccode, '$str = '._lit($ospec->{filter_citext});
            push @fccode, 'return 0 if $p{name} eq '._lit($ospec->{name}).
                ' && !/\Q$str/io';
        }
        if (defined $ospec->{filter_no_citext}) {
            push @fccode, '$str = '._lit($ospec->{filter_no_citext});
            push @fccode, 'return 0 if $p{name} eq '._lit($ospec->{name}).
                ' && /\Q$str/io';
        }
        if (defined $ospec->{filter_re}) {
            push @fccode, '$str = '._lit($ospec->{filter_re});
            push @fccode, 'return 0 if $p{name} eq '._lit($ospec->{name}).
                ' && $_ !~ ' . (ref($ospec->{filter_re}) eq 'Regexp' ? '$str' : 'qr/$str/o');
        }
        if (defined $ospec->{filter_no_re}) {
            push @fccode, '$str = '._lit($ospec->{filter_no_re});
            push @fccode, 'return 0 if $p{name} eq '._lit($ospec->{name}).
                ' && $_ =~ ' . (ref($ospec->{filter_re}) eq 'Regexp' ? '$str' : 'qr/$str/o');
        }
    }
    push @fccode, "1";
    my $fccode = join "; ", @fccode;

    my $filters_str = join(
        "",
        "log4perl.filter.FilterCustom = sub { $fccode }\n",
        "\n",
        "log4perl.filter.FilterOFF0 = Log::Log4perl::Filter::LevelRange\n",
        "log4perl.filter.FilterOFF0.LevelMin = TRACE\n",
        "log4perl.filter.FilterOFF0.LevelMax = FATAL\n",
        "log4perl.filter.FilterOFF0.AcceptOnMatch = false\n",
        "\n",
        "log4perl.filter.FilterOFF = Log::Log4perl::Filter::Boolean\n",
        "log4perl.filter.FilterOFF.logic = FilterOFF0 && FilterCustom\n",
        map {join(
            "",
            "log4perl.filter.Filter${_}0 = Log::Log4perl::Filter::LevelRange\n",
            "log4perl.filter.Filter${_}0.LevelMin = $_\n",
            "log4perl.filter.Filter${_}0.LevelMax = FATAL\n",
            "log4perl.filter.Filter${_}0.AcceptOnMatch = true\n",
            "\n",
            "log4perl.filter.Filter$_ = Log::Log4perl::Filter::Boolean\n",
            "log4perl.filter.Filter$_.logic = Filter${_}0 && FilterCustom\n",
            "\n",
        )} qw(FATAL ERROR WARN INFO DEBUG), # TRACE
    );

    my %levels; # key = output name; value = { cat => level, ... }
    my %cats;   # list of categories
    my %ospecs; # key = oname; this is just a shortcut to get ospec

    # 1. list all levels for each category and output
    for my $ospec (map { @{ $spec->{$_} } } @otypes) {
        my $oname = $ospec->{name};
        $ospecs{$oname} = $ospec;
        $levels{$oname} = {};
        my %seen_cats;
        if ($ospec->{category_level}) {
            while (my ($cat0, $level) = each %{ $ospec->{category_level} }) {
                my @cat = _extract_category($ospec, $cat0);
                for my $cat (@cat) {
                    next if $seen_cats{$cat}++;
                    $cats{$cat}++;
                    $levels{$oname}{$cat} = $level;
                }
            }
        }
        if ($spec->{category_level}) {
            while (my ($cat0, $level) = each %{ $spec->{category_level} }) {
                my @cat = _extract_category($ospec, $cat0);
                for my $cat (@cat) {
                    next if $seen_cats{$cat}++;
                    $cats{$cat}++;
                    $levels{$oname}{$cat} = $level;
                }
            }
        }
        my @cat = _extract_category($ospec);
        for my $cat (@cat) {
            next if $seen_cats{$cat}++;
            $cats{$cat}++;
            $levels{$oname}{$cat} = $ospec->{level};
        }
    }
    #print Dumper \%levels; exit;

    my $find_olevel = sub {
        my ($oname, $cat) = @_;
        my $olevel = $levels{$oname}{''};
        my @c = split /\./, $cat;
        for (my $i=0; $i<@c; $i++) {
            my $c = join(".", @c[0..$i]);
            if ($levels{$oname}{$c}) {
                $olevel = $levels{$oname}{$c};
            }
        }
        $olevel;
    };

    # 2. determine level for each category (which is the minimum level of all
    # appenders for that category)
    my %cat_configs; # key = cat, value = [catlevel, apdname, ...]
    my $add_str = '';
    my $apd_str = '';
    for my $cat0 (sort {$a cmp $b} keys %cats) {
        $add_str .= "log4perl.additivity.$cat0 = 0\n" unless $cat0 eq '';
        my @cats = ($cat0);
        # since we don't use additivity, we need to add supercategories ourselves
        while ($cat0 =~ s/\.[^.]+$//) { push @cats, $cat0 }
        for my $cat (@cats) {
            my $cat_level;
            for my $oname (keys %levels) {
                my $olevel = $find_olevel->($oname, $cat);
                next unless $olevel;
                $cat_level = _ifdef($cat_level, $olevel);
                $cat_level = _min_level($cat_level, $olevel);
            }
            $cat_configs{$cat} = [uc($cat_level)];
            #next if $cat_level eq 'off';
        }
    }
    #print Dumper \%cat_configs; exit;

    # 3. add appenders for each category
    my %generated_appenders; # key = apdname, just a memory hash
    for my $cat (keys %cat_configs) {
        my $cat_level = $cat_configs{$cat}[0];
        for my $oname (keys %levels) {
            my $ospec = $ospecs{$oname};
            my $olevel = $find_olevel->($oname, $cat);
            #print "D:oname=$oname, cat=$cat, olevel=$olevel, cat_level=$cat_level\n";
            my $apd_name;
            my $filter;
            if ($olevel ne $cat_level &&
                    _min_level($olevel, $cat_level) eq $cat_level) {
                # we need to filter the appender, since the category level is
                # lower than the output level
                $apd_name = $oname . "_" . uc($olevel);
                $filter = "Filter".uc($olevel);
            } else {
                $apd_name = $oname;
                $filter = "FilterCustom";
            }
            unless ($generated_appenders{$apd_name}++) {
                $apd_str .= _gen_appender_config($ospec, $apd_name, $filter).
                    "\n";
            }
            push @{ $cat_configs{$cat} }, $apd_name;
        }
    }
    #print Dumper \%cat_configs; exit;

    # 4. write out log4perl category line
    my $cat_str = '';
    for my $cat (sort {$a cmp $b} keys %cat_configs) {
        my $l = $cat eq '' ? '' : ".$cat";
        $cat_str .= "log4perl.logger$l = ".join(", ", @{ $cat_configs{$cat} })."\n";
    }

    join(
        "",
        "# filters\n", $filters_str,
        "# categories\n", $cat_str, $add_str, "\n",
        "# appenders\n", $apd_str,
    );
}

sub _init_log4perl {
    require Log::Log4perl;

    my ($spec) = @_;

    # create intermediate directories for dir
    for (@{ $spec->{dir} }) {
        my $dir = _dirname($_->{path});
        make_path($dir) if length($dir) && !(-d $dir);
    }

    # create intermediate directories for file
    for (@{ $spec->{file} }) {
        my $dir = _dirname($_->{path});
        make_path($dir) if length($dir) && !(-d $dir);
    }

    my $config_str = _gen_l4p_config($spec);
    if ($spec->{dump}) {
        require Data::Dump;
        print "Log::Any::App configuration:\n",
            Data::Dump::dump($spec);
        print "Log4perl configuration: <
    }

    Log::Log4perl->init(\$config_str);
    Log::Any::Adapter->set('Log4perl');
}

sub _basename {
    my $path = shift;
    my ($vol, $dir, $file) = File::Spec->splitpath($path);
    $file;
}

sub _dirname {
    my $path = shift;
    my ($vol, $dir, $file) = File::Spec->splitpath($path);
    $dir;
}

# we separate args and opts, because we need to export logger early
# (BEGIN), but configure logger in INIT (to be able to detect
# existence of other modules).

sub _parse_args {
    my ($args, $caller) = @_;
    $args = _ifdef($args, []); # if we don't import(), we never get args

    my $i = 0;
    while ($i < @$args) {
        my $arg = $args->[$i];
        do { $i+=2; next } if $arg =~ /^-(\w+)$/;
        if ($arg eq '$log') {
            _export_logger($caller);
        } else {
            die "Unknown arg '$arg', valid arg is '\$log' or -OPTS";
        }
        $i++;
    }
}

sub _parse_opts {
    require File::HomeDir;

    my ($args, $caller) = @_;
    $args = _ifdef($args, []); # if we don't import(), we never get args
    _debug("parse_opts: args = [".join(", ", @$args)."]");

    my $i = 0;
    my %opts;
    while ($i < @$args) {
        my $arg = $args->[$i];
        do { $i++; next } unless $arg =~ /^-(\w+)$/;
        my $opt = $1;
        die "Missing argument for option $opt" unless $i++ < @$args-1;
        $arg = $args->[$i];
        $opts{$opt} = $arg;
        $i++;
    }

    my $spec = {};

    $spec->{log} = _ifdef($ENV{LOG}, 1);
    if (defined $opts{log}) {
        $spec->{log} = $opts{log};
        delete $opts{log};
    }
    # exit as early as possible if we are not doing any logging
    goto END_PARSE_OPTS unless $spec->{log};

    $spec->{name} = _basename($0);
    if (defined $opts{name}) {
        $spec->{name} = $opts{name};
        delete $opts{name};
    }

    $spec->{level_flag_paths} = [File::HomeDir->my_home, "/etc"];
    if (defined $opts{level_flag_paths}) {
        $spec->{level_flag_paths} = $opts{level_flag_paths};
        delete $opts{level_flag_paths};
    }

    $spec->{level} = _set_level("", "", $spec);
    if (!$spec->{level} && defined($opts{level})) {
        $spec->{level} = _check_level($opts{level}, "-level");
        _debug("Set general level to $spec->{level} (from -level)");
    } elsif (!$spec->{level}) {
        $spec->{level} = "warn";
        _debug("Set general level to $spec->{level} (default)");
    }
    delete $opts{level};

    $spec->{category_alias} = _ifdefj($ENV{LOG_CATEGORY_ALIAS}, {});
    if (defined $opts{category_alias}) {
        die "category_alias must be a hashref"
            unless ref($opts{category_alias}) eq 'HASH';
        $spec->{category_alias} = $opts{category_alias};
        delete $opts{category_alias};
    }

    if (defined $opts{category_level}) {
        die "category_level must be a hashref"
            unless ref($opts{category_level}) eq 'HASH';
        $spec->{category_level} = {};
        for (keys %{ $opts{category_level} }) {
            $spec->{category_level}{$_} =
                _check_level($opts{category_level}{$_}, "-category_level{$_}");
        }
        delete $opts{category_level};
    }

    $spec->{init} = 1;
    if (defined $opts{init}) {
        $spec->{init} = $opts{init};
        delete $opts{init};
    }

    $spec->{daemon} = 0;
    if (defined $opts{daemon}) {
        $spec->{daemon} = $opts{daemon};
        _debug("setting is_daemon=$opts{daemon} (from daemon option)");
        $is_daemon = $opts{daemon};
        delete $opts{daemon};
    }

    $spec->{dump} = $ENV{LOGANYAPP_DEBUG};
    if (defined $opts{dump}) {
        $spec->{dump} = 1;
        delete $opts{dump};
    }

    $spec->{filter_text} = $ENV{LOG_FILTER_TEXT};
    if (defined $opts{filter_text}) {
        $spec->{filter_text} = $opts{filter_text};
        delete $opts{filter_text};
    }
    $spec->{filter_no_text} = $ENV{LOG_FILTER_NO_TEXT};
    if (defined $opts{filter_no_text}) {
        $spec->{filter_no_text} = $opts{filter_no_text};
        delete $opts{filter_no_text};
    }
    $spec->{filter_citext} = $ENV{LOG_FILTER_CITEXT};
    if (defined $opts{filter_citext}) {
        $spec->{filter_citext} = $opts{filter_citext};
        delete $opts{filter_citext};
    }
    $spec->{filter_no_citext} = $ENV{LOG_FILTER_NO_CITEXT};
    if (defined $opts{filter_no_citext}) {
        $spec->{filter_no_citext} = $opts{filter_no_citext};
        delete $opts{filter_no_citext};
    }
    $spec->{filter_re} = $ENV{LOG_FILTER_RE};
    if (defined $opts{filter_re}) {
        $spec->{filter_re} = $opts{filter_re};
        delete $opts{filter_re};
    }
    $spec->{filter_no_re} = $ENV{LOG_FILTER_NO_RE};
    if (defined $opts{filter_no_re}) {
        $spec->{filter_no_re} = $opts{filter_no_re};
        delete $opts{filter_no_re};
    }

    $spec->{file} = [];
    _parse_opt_file($spec, _ifdef($opts{file}, ($0 ne '-e' ? 1:0)));
    delete $opts{file};

    $spec->{dir} = [];
    _parse_opt_dir($spec, _ifdef($opts{dir}, 0));
    delete $opts{dir};

    $spec->{screen} = [];
    _parse_opt_screen($spec, _ifdef($opts{screen}, !_is_daemon()));
    delete $opts{screen};

    $spec->{syslog} = [];
    _parse_opt_syslog($spec, _ifdef($opts{syslog}, _is_daemon()));
    delete $opts{syslog};

    $spec->{unixsock} = [];
    _parse_opt_unixsock($spec, _ifdef($opts{unixsock}, 0));
    delete $opts{unixsock};

    $spec->{array} = [];
    _parse_opt_array($spec, _ifdef($opts{array}, 0));
    delete $opts{array};

    if (keys %opts) {
        die "Unknown option(s) ".join(", ", keys %opts)." Known opts are: ".
            "log, name, level, category_level, category_alias, dump, init, ".
                "filter_{,no_}{text,citext,re}, file, dir, screen, syslog, ".
                    "unixsock, array";
    }

  END_PARSE_OPTS:
    #use Data::Dump; dd $spec;
    $spec;
}

sub _is_daemon {
    if (defined $is_daemon) { return $is_daemon }
    if (defined $main::IS_DAEMON) {
        $is_daemon = $main::IS_DAEMON;
        _debug("Setting is_daemon=$main::IS_DAEMON (from \$main::IS_DAEMON)");
        return $main::IS_DAEMON;
    }

    for (
        "App/Daemon.pm",
        "Daemon/Easy.pm",
        "Daemon/Daemonize.pm",
        "Daemon/Generic.pm",
        "Daemonise.pm",
        "Daemon/Simple.pm",
        "HTTP/Daemon.pm",
        "IO/Socket/INET/Daemon.pm",
        #"Mojo/Server/Daemon.pm", # simply loading Mojo::UserAgent will load this too
        "MooseX/Daemonize.pm",
        "Net/Daemon.pm",
        "Net/Server.pm",
        "Proc/Daemon.pm",
        "Proc/PID/File.pm",
        "Win32/Daemon/Simple.pm") {
        if ($INC{$_}) {
            _debug("setting is_daemon=1 (from existence of module $_)");
            $is_daemon = 1;
            return 1;
        }
    }
    _debug("setting is_daemon=0 (no indication that we are a daemon)");
    $is_daemon = 0;
    0;
}

sub _parse_opt_OUTPUT {
    my (%args) = @_;
    my $kind = $args{kind};
    my $default_sub = $args{default_sub};
    my $postprocess = $args{postprocess};
    my $spec = $args{spec};
    my $arg = $args{arg};

    return unless $arg;

    if (!ref($arg) || ref($arg) eq 'HASH') {
        my $name = uc($kind).(@{ $spec->{$kind} }+0);
        local $dbg_ctx = $name;
        push @{ $spec->{$kind} }, $default_sub->($spec);
        $spec->{$kind}[-1]{name} = $name;
        if (!ref($arg)) {
            # leave every output parameter as is
        } else {
            for my $k (keys %$arg) {
                for ($spec->{$kind}[-1]) {
                    exists($_->{$k}) or die "Invalid $kind argument: $k, please".
                        " only specify one of: " . join(", ", sort keys %$_);
                    $_->{$k} = $k eq 'level' ?
                        _check_level($arg->{$k}, "-$kind") : $arg->{$k};
                    _debug("Set level of $kind to $_->{$k} (spec)")
                        if $k eq 'level';
                }
            }
        }
        $spec->{$kind}[-1]{main_spec} = $spec;
        _set_pattern($spec->{$kind}[-1], $kind);
        $postprocess->(spec => $spec, ospec => $spec->{$kind}[-1])
            if $postprocess;
    } elsif (ref($arg) eq 'ARRAY') {
        for (@$arg) {
            _parse_opt_OUTPUT(%args, arg => $_);
        }
    } else {
        die "Invalid argument for -$kind, ".
            "must be a boolean or hashref or arrayref";
    }
}

sub _set_pattern_style {
    my ($x) = @_;
    ($ENV{LOG_SHOW_LOCATION} ? 'loc_':
         $ENV{LOG_SHOW_CATEGORY} ? 'cat_':'') . $x;
}

sub _default_file {
    require File::HomeDir;

    my ($spec) = @_;
    my $level = _set_level("file", "file", $spec);
    if (!$level) {
        $level = $spec->{level};
        _debug("Set level of file to $level (general level)");
    }
    return {
        level => $level,
        category_level => _ifdefj($ENV{FILE_LOG_CATEGORY_LEVEL},
                                  $ENV{LOG_CATEGORY_LEVEL},
                                  $spec->{category_level}),
        path => $> ? File::Spec->catfile(File::HomeDir->my_home, "$spec->{name}.log") :
            "/var/log/$spec->{name}.log", # XXX and on Windows?
        max_size => undef,
        histories => undef,
        period => undef,
        buffer_size => undef,
        category => '',
        pattern_style => _set_pattern_style('daemon'),
        pattern => undef,

        filter_text      => _ifdef($ENV{FILE_LOG_FILTER_TEXT}, $spec->{filter_text}),
        filter_no_text   => _ifdef($ENV{FILE_LOG_FILTER_NO_TEXT}, $spec->{filter_no_text}),
        filter_citext    => _ifdef($ENV{FILE_LOG_FILTER_CITEXT}, $spec->{filter_citext}),
        filter_no_citext => _ifdef($ENV{FILE_LOG_FILTER_NO_CITEXT}, $spec->{filter_no_citext}),
        filter_re        => _ifdef($ENV{FILE_LOG_FILTER_RE}, $spec->{filter_re}),
        filter_no_re     => _ifdef($ENV{FILE_LOG_FILTER_NO_RE}, $spec->{filter_no_re}),
    };
}

sub _parse_opt_file {
    my ($spec, $arg) = @_;

    if (!ref($arg) && $arg && $arg !~ /^(1|yes|true)$/i) {
        $arg = {path => $arg};
    }

    _parse_opt_OUTPUT(
        kind => 'file', default_sub => \&_default_file,
        spec => $spec, arg => $arg,
        postprocess => sub {
            my (%args) = @_;
            my $spec  = $args{spec};
            my $ospec = $args{ospec};
            if ($ospec->{path} =~ m!/$!) {
                my $p = $ospec->{path};
                $p .= "$spec->{name}.log";
                _debug("File path ends with /, assumed to be dir, ".
                           "final path becomes $p");
                $ospec->{path} = $p;
            }
        },
    );
}

sub _default_dir {
    require File::HomeDir;

    my ($spec) = @_;
    my $level = _set_level("dir", "dir", $spec);
    if (!$level) {
        $level = $spec->{level};
        _debug("Set level of dir to $level (general level)");
    }
    return {
        level => $level,
        category_level => _ifdefj($ENV{DIR_LOG_CATEGORY_LEVEL},
                                   $ENV{LOG_CATEGORY_LEVEL},
                                   $spec->{category_level}),
        path => $> ? File::Spec->catfile(File::HomeDir->my_home, "log", $spec->{name}) :
            "/var/log/$spec->{name}", # XXX and on Windows?
        max_size => undef,
        max_age => undef,
        histories => undef,
        category => '',
        pattern_style => _set_pattern_style('plain'),
        pattern => undef,
        filename_pattern => undef,

        filter_text      => _ifdef($ENV{DIR_LOG_FILTER_TEXT}, $spec->{filter_text}),
        filter_no_text   => _ifdef($ENV{DIR_LOG_FILTER_NO_TEXT}, $spec->{filter_no_text}),
        filter_citext    => _ifdef($ENV{DIR_LOG_FILTER_CITEXT}, $spec->{filter_citext}),
        filter_no_citext => _ifdef($ENV{DIR_LOG_FILTER_NO_CITEXT}, $spec->{filter_no_citext}),
        filter_re        => _ifdef($ENV{DIR_LOG_FILTER_RE}, $spec->{filter_re}),
        filter_no_re     => _ifdef($ENV{DIR_LOG_FILTER_NO_RE}, $spec->{filter_no_re}),
    };
}

sub _parse_opt_dir {
    my ($spec, $arg) = @_;

    if (!ref($arg) && $arg && $arg !~ /^(1|yes|true)$/i) {
        $arg = {path => $arg};
    }

    _parse_opt_OUTPUT(
        kind => 'dir', default_sub => \&_default_dir,
        spec => $spec, arg => $arg,
    );
}

sub _default_screen {
    my ($spec) = @_;
    my $level = _set_level("screen", "screen", $spec);
    if (!$level) {
        $level = $spec->{level};
        _debug("Set level of screen to $level (general level)");
    }
    return {
        color => _ifdef($ENV{COLOR}, (-t STDOUT)),
        stderr => 1,
        level => $level,
        category_level => _ifdefj($ENV{SCREEN_LOG_CATEGORY_LEVEL},
                                   $ENV{LOG_CATEGORY_LEVEL},
                                   $spec->{category_level}),
        category => '',
        pattern_style => _set_pattern_style(
            $ENV{LOG_ELAPSED_TIME_IN_SCREEN} ? 'script_short' : 'plain_nl'),
        pattern => undef,

        filter_text      => _ifdef($ENV{SCREEN_LOG_FILTER_TEXT}, $spec->{filter_text}),
        filter_no_text   => _ifdef($ENV{SCREEN_FILTER_NO_TEXT}, $spec->{filter_no_text}),
        filter_citext    => _ifdef($ENV{SCREEN_FILTER_CITEXT}, $spec->{filter_citext}),
        filter_no_citext => _ifdef($ENV{SCREEN_FILTER_NO_CITEXT}, $spec->{filter_no_citext}),
        filter_re        => _ifdef($ENV{SCREEN_FILTER_RE}, $spec->{filter_re}),
        filter_no_re     => _ifdef($ENV{SCREEN_FILTER_NO_RE}, $spec->{filter_no_re}),
    };
}

sub _parse_opt_screen {
    my ($spec, $arg) = @_;
    _parse_opt_OUTPUT(
        kind => 'screen', default_sub => \&_default_screen,
        spec => $spec, arg => $arg,
    );
}

sub _default_syslog {
    my ($spec) = @_;
    my $level = _set_level("syslog", "syslog", $spec);
    if (!$level) {
        $level = $spec->{level};
        _debug("Set level of syslog to $level (general level)");
    }
    return {
        level => $level,
        category_level => _ifdefj($ENV{SYSLOG_LOG_CATEGORY_LEVEL},
                                   $ENV{LOG_CATEGORY_LEVEL},
                                   $spec->{category_level}),
        ident => $spec->{name},
        facility => 'daemon',
        pattern_style => _set_pattern_style('syslog'),
        pattern => undef,
        category => '',

        filter_text      => _ifdef($ENV{SYSLOG_LOG_FILTER_TEXT}, $spec->{filter_text}),
        filter_no_text   => _ifdef($ENV{SYSLOG_FILTER_NO_TEXT}, $spec->{filter_no_text}),
        filter_citext    => _ifdef($ENV{SYSLOG_FILTER_CITEXT}, $spec->{filter_citext}),
        filter_no_citext => _ifdef($ENV{SYSLOG_FILTER_NO_CITEXT}, $spec->{filter_no_citext}),
        filter_re        => _ifdef($ENV{SYSLOG_FILTER_RE}, $spec->{filter_re}),
        filter_no_re     => _ifdef($ENV{SYSLOG_FILTER_NO_RE}, $spec->{filter_no_re}),
    };
}

sub _parse_opt_syslog {
    my ($spec, $arg) = @_;
    _parse_opt_OUTPUT(
        kind => 'syslog', default_sub => \&_default_syslog,
        spec => $spec, arg => $arg,
    );
}

sub _default_unixsock {
    require File::HomeDir;

    my ($spec) = @_;
    my $level = _set_level("unixsock", "unixsock", $spec);
    if (!$level) {
        $level = $spec->{level};
        _debug("Set level of unixsock to $level (general level)");
    }
    return {
        level => $level,
        category_level => _ifdefj($ENV{UNIXSOCK_LOG_CATEGORY_LEVEL},
                                  $ENV{LOG_CATEGORY_LEVEL},
                                  $spec->{category_level}),
        path => $> ? File::Spec->catfile(File::HomeDir->my_home, "$spec->{name}-log.sock") :
            "/var/run/$spec->{name}-log.sock", # XXX and on Windows?
        category => '',
        pattern_style => _set_pattern_style('daemon'),
        pattern => undef,

        filter_text      => _ifdef($ENV{UNIXSOCK_LOG_FILTER_TEXT}, $spec->{filter_text}),
        filter_no_text   => _ifdef($ENV{UNIXSOCK_LOG_FILTER_NO_TEXT}, $spec->{filter_no_text}),
        filter_citext    => _ifdef($ENV{UNIXSOCK_LOG_FILTER_CITEXT}, $spec->{filter_citext}),
        filter_no_citext => _ifdef($ENV{UNIXSOCK_LOG_FILTER_NO_CITEXT}, $spec->{filter_no_citext}),
        filter_re        => _ifdef($ENV{UNIXSOCK_LOG_FILTER_RE}, $spec->{filter_re}),
        filter_no_re     => _ifdef($ENV{UNIXSOCK_LOG_FILTER_NO_RE}, $spec->{filter_no_re}),
    };
}

sub _parse_opt_unixsock {
    my ($spec, $arg) = @_;

    if (!ref($arg) && $arg && $arg !~ /^(1|yes|true)$/i) {
        $arg = {path => $arg};
    }

    _parse_opt_OUTPUT(
        kind => 'unixsock', default_sub => \&_default_unixsock,
        spec => $spec, arg => $arg,
        postprocess => sub {
            my (%args) = @_;
            my $spec  = $args{spec};
            my $ospec = $args{ospec};
            if ($ospec->{path} =~ m!/$!) {
                my $p = $ospec->{path};
                $p .= "$spec->{name}-log.sock";
                _debug("Unix socket path ends with /, assumed to be dir, ".
                           "final path becomes $p");
                $ospec->{path} = $p;
            }

            # currently Log::Log4perl::Appender::Socket::UNIX *connects to an
            # existing and listening* Unix socket and prints log to it. we are
            # *not* creating a listening unix socket where clients can connect
            # and see logs. to do that, we'll need a separate thread/process
            # that listens to unix socket and stores (some) log entries and
            # display it to users when they connect and request them.
            #
            #if ($ospec->{create} && !(-e $ospec->{path})) {
            #    _debug("Creating Unix socket $ospec->{path} ...");
            #    require IO::Socket::UNIX::Util;
            #    IO::Socket::UNIX::Util::create_unix_socket(
            #        $ospec->{path});
            #}
        },
    );
}

sub _default_array {
    my ($spec) = @_;
    my $level = _set_level("array", "array", $spec);
    if (!$level) {
        $level = $spec->{level};
        _debug("Set level of array to $level (general level)");
    }
    return {
        level => $level,
        category_level => _ifdefj($ENV{ARRAY_LOG_CATEGORY_LEVEL},
                                  $ENV{LOG_CATEGORY_LEVEL},
                                  $spec->{category_level}),
        array => [],
        max_elems => undef,
        category => '',
        pattern_style => _set_pattern_style('script_long'),
        pattern => undef,

        filter_text      => _ifdef($ENV{ARRAY_LOG_FILTER_TEXT}, $spec->{filter_text}),
        filter_no_text   => _ifdef($ENV{ARRAY_LOG_FILTER_NO_TEXT}, $spec->{filter_no_text}),
        filter_citext    => _ifdef($ENV{ARRAY_LOG_FILTER_CITEXT}, $spec->{filter_citext}),
        filter_no_citext => _ifdef($ENV{ARRAY_LOG_FILTER_NO_CITEXT}, $spec->{filter_no_citext}),
        filter_re        => _ifdef($ENV{ARRAY_LOG_FILTER_RE}, $spec->{filter_re}),
        filter_no_re     => _ifdef($ENV{ARRAY_LOG_FILTER_NO_RE}, $spec->{filter_no_re}),
    };
}

sub _parse_opt_array {
    my ($spec, $arg) = @_;

    _parse_opt_OUTPUT(
        kind => 'array', default_sub => \&_default_array,
        spec => $spec, arg => $arg,
    );
}

sub _set_pattern {
    my ($s, $name) = @_;
    _debug("Setting $name pattern ...");
    unless (defined($s->{pattern})) {
        die "BUG: neither pattern nor pattern_style is defined ($name)"
            unless defined($s->{pattern_style});
        die "Unknown pattern style for $name `$s->{pattern_style}`, ".
            "use one of: ".join(", ", keys %PATTERN_STYLES)
            unless defined($PATTERN_STYLES{ $s->{pattern_style} });
        $s->{pattern} = $PATTERN_STYLES{ $s->{pattern_style} };
        _debug("Set $name pattern to `$s->{pattern}` ".
                   "(from style `$s->{pattern_style}`)");
    }
}

sub _extract_category {
    my ($ospec, $c) = @_;
    my $c0 = _ifdef($c, $ospec->{category});
    my @res;
    if (ref($c0) eq 'ARRAY') { @res = @$c0 } else { @res = ($c0) }
    # replace alias with real value
    for (my $i=0; $i<@res; $i++) {
        my $c1 = $res[$i];
        my $a = $ospec->{main_spec}{category_alias}{$c1};
        next unless defined($a);
        if (ref($a) eq 'ARRAY') {
            splice @res, $i, 1, @$a;
            $i += (@$a-1);
        } else {
            $res[$i] = $a;
        }
    }
    for (@res) {
        s/::/./g;
        # $_ = lc; # XXX do we need this?
    }
    @res;
}

sub _cat2apd {
    my $cat = shift;
    $cat =~ s/[^A-Za-z0-9_]+/_/g;
    $cat;
}

sub _check_level {
    my ($level, $from) = @_;
    $level =~ /^(off|fatal|error|warn|info|debug|trace)$/i
        or die "Unknown level (from $from): $level";
    lc($1);
}

sub _set_level {
    my ($prefix, $which, $spec) = @_;
    #use Data::Dump; dd $spec;
    my $p_ = $prefix ? "${prefix}_" : "";
    my $P_ = $prefix ? uc("${prefix}_") : "";
    my $F_ = $prefix ? ucfirst("${prefix}_") : "";
    my $pd = $prefix ? "${prefix}-" : "";
    my $pr = $prefix ? qr/$prefix(_|-)/ : qr//;
    my ($level, $from);

    my @label2level =([trace=>"trace"], [debug=>"debug"],
                      [verbose=>"info"], [quiet=>"error"]);

    _debug("Setting ", ($which ? "level of $which" : "general level"), " ...");
  SET:
    {
        if ($INC{"App/Options.pm"}) {
            my $key;
            for (qw/log_level loglevel/) {
                $key = $p_ . $_;
                _debug("Checking \$App::options{$key}: ", _ifdef($App::options{$key}, "(undef)"));
                if ($App::options{$key}) {
                    $level = _check_level($App::options{$key}, "\$App::options{$key}");
                    $from = "\$App::options{$key}";
                    last SET;
                }
            }
            for (@label2level) {
                $key = $p_ . $_->[0];
                _debug("Checking \$App::options{$key}: ", _ifdef($App::options{$key}, "(undef)"));
                if ($App::options{$key}) {
                    $level = $_->[1];
                    $from = "\$App::options{$key}";
                    last SET;
                }
            }
        }

        my $i = 0;
        _debug("Checking \@ARGV ...");
        while ($i < @ARGV) {
            my $arg = $ARGV[$i];
            $from = "cmdline arg $arg";
            if ($arg =~ /^--${pr}log[_-]?level=(.+)/) {
                _debug("\$ARGV[$i] looks like an option to specify level: $arg");
                $level = _check_level($1, "ARGV $arg");
                last SET;
            }
            if ($arg =~ /^--${pr}log[_-]?level$/ and $i < @ARGV-1) {
                _debug("\$ARGV[$i] and \$ARGV[${\($i+1)}] looks like an option to specify level: $arg ", $ARGV[$i+1]);
                $level = _check_level($ARGV[$i+1], "ARGV $arg ".$ARGV[$i+1]);
                last SET;
            }
            for (@label2level) {
                if ($arg =~ /^--${pr}$_->[0](=(1|yes|true))?$/i) {
                    _debug("\$ARGV[$i] looks like an option to specify level: $arg");
                    $level = $_->[1];
                    last SET;
                }
            }
            $i++;
        }

        for (qw/LOG_LEVEL LOGLEVEL/) {
            my $key = $P_ . $_;
            _debug("Checking environment variable $key: ", _ifdef($ENV{$key}, "(undef)"));
            if ($ENV{$key}) {
                $level = _check_level($ENV{$key}, "ENV $key");
                $from = "\$ENV{$key}";
                last SET;
            }
        }
        for (@label2level) {
            my $key = $P_ . uc($_->[0]);
            _debug("Checking environment variable $key: ", _ifdef($ENV{$key}, "(undef)"));
            if ($ENV{$key}) {
                $level = $_->[1];
                $from = "\$ENV{$key}";
                last SET;
            }
        }

        for my $dir (@{$spec->{level_flag_paths}}) {
            for (@label2level) {
                my $filename = "$dir/$spec->{name}." . $P_ . "log_level";
                my $exists = -f $filename;
                my $content;
                if ($exists) {
                    open my($f), $filename;
                    $content = <$f>;
                    chomp($content) if defined($content);
                    close $f;
                }
                _debug("Checking level flag file content $filename: ",
                       (defined($content) ? $content : "(undef)"));
                if (defined $content) {
                    $level = _check_level($content,
                                          "level flag file $filename");
                    $from = $filename;
                    last SET;
                }

                $filename = "$dir/$spec->{name}." . $P_ . uc($_->[0]);
                $exists = -e $filename;
                _debug("Checking level flag file $filename: ",
                       ($exists ? "EXISTS" : 0));
                if ($exists) {
                    $level = $_->[1];
                    $from = $filename;
                    last SET;
                }
            }
        }

        no strict 'refs';
        for ("${F_}Log_Level", "${P_}LOG_LEVEL", "${p_}log_level",
             "${F_}LogLevel",  "${P_}LOGLEVEL",  "${p_}loglevel") {
            my $varname = "main::$_";
            _debug("Checking variable \$$varname: ", _ifdef($$varname, "(undef)"));
            if ($$varname) {
                $from = "\$$varname";
                $level = _check_level($$varname, "\$$varname");
                last SET;
            }
        }
        for (@label2level) {
            for my $varname (
                "main::$F_" . ucfirst($_->[0]),
                "main::$P_" . uc($_->[0])) {
                _debug("Checking variable \$$varname: ", _ifdef($$varname, "(undef)"));
                if ($$varname) {
                    $from = "\$$varname";
                    $level = $_->[1];
                    last SET;
                }
            }
        }
    }

    _debug("Set ", ($which ? "level of $which" : "general level"), " to $level (from $from)") if $level;
    return $level;
}

# return the lower level (e.g. _min_level("debug", "INFO") -> INFO
sub _min_level {
    my ($l1, $l2) = @_;
    my %vals = (OFF=>99,
                FATAL=>6, ERROR=>5, WARN=>4, INFO=>3, DEBUG=>2, TRACE=>1);
    $vals{uc($l1)} > $vals{uc($l2)} ? $l2 : $l1;
}

sub _export_logger {
    my ($caller) = @_;
    my $log_for_caller = Log::Any->get_logger(category => $caller);
    my $varname = "$caller\::log";
    no strict 'refs';
    *$varname = \$log_for_caller;
}

sub _debug {
    return unless $ENV{LOGANYAPP_DEBUG};
    print $dbg_ctx, ": " if $dbg_ctx;
    print @_, "\n";
}

sub import {
    my ($self, @args) = @_;
    my $caller = caller();
    _parse_args(\@args, $caller);
    $init_args = \@args;
}

{
    no warnings;
    # if we are loaded at run-time, it's too late to run INIT blocks, so user
    # must call init() manually. but sometimes this is what the user wants. so
    # shut up perl warning.
    INIT {
        my $caller = caller();
        init($init_args, $caller);
    }
}

1;
# ABSTRACT: An easy way to use Log::Any in applications

__END__