Log-Contextual-0.006000/0000755000175000017500000000000012212224472013272 5ustar frewfrewLog-Contextual-0.006000/Changes0000644000175000017500000000554312212224365014575 0ustar frewfrewRevision history for Log-Contextual 0.006000 2013-09-05 - Add Log::Contextual::Easy::Default for simple LC usage (Jakob Voß) - Add Log::Contextual::Easy::Package for more different simple LC usage 0.005005 2013-08-08 - Fix minimum version of Exporter::Declare 0.005004 2013-08-08 - Dep on a newer version of Moo for multiple role composition 0.005003 2013-03-21 - Yell loudly if a user tries to use Log::Contextual::set_logger() or Log::Contextual::with_logger() (aka internals that don't work anymore) directly 0.005002 2013-02-14 (♥) - Fix RT#83267 (Tyler Riddle) 0.005001 2013-02-07 - No changes from previous dev release 0.005000_03 2013-01-16 - merge unpushed 0.004300 into master (frew--, Tyler Riddle++) 0.005000_02 2013-01-15 - add missing changelog entry (derp) 0.005000_01 2013-01-11 - significant changes in the way Log::Contexual works, but the upshot of it is that Log::Contextual is now much less global than before, and applications using Log::Contextual can guard against modules using set_logger (or something like that) and changing their logger. See the new Log::Contextual::Role::Router for more information 0.004300 2012-10-03 - add a way to set default import tags 0.004202 2012-08-04 - correct the caller_level passed into coderef, and document "both" uses of caller_level 0.004201 2012-07-21 - The smallest pod fix ever 0.004200 2012-07-20 - Improve information passed to logger coderef - Significant doc improvements - Fix warning in test suite in Perl 5.16 0.004100 2012-03-29 - Log::Contextual::WarnLogger now supports customized log levels via the 'levels' constructor argument (Karen Etheridge) 0.004001 2011-08-15 - Fix version of Exporter::Declare that we dep on 0.004000 2011-08-06 - Support Log::Contextual subclasses for default import options - Allow custom log levels 0.00305 2011-07-27 - Fix regression that caused D* subs to dumper even if the log level was off 0.00304 2010-07-31 - Add $package_UPTO environment variable for WarnLogger 0.00303 2010-07-10 - Fix broken Log::Log4perl test 0.00302 2010-07-08 - Add Log::Contextual::TeeLogger - Add levels_upto (RT58558) - Use Log::Log4perl 1.29 to clean up caller stuff 0.00301 2010-07-08 [deleted due to missing the TeeLogger] 0.00300 2010-06-03 - Add -package_logger import option 0.00202 2010-05-23 - Fix a bug that caused Dlog and friends not to work with a default 0.00201 2010-03-04 - I left a needed file for testing out of the MANIFEST; fixing :-/ 0.00200 2010-03-03 - add example for Log::Dispatchouli since it works nicely now - make Log::Log4perl work out of the box - Added WarnLogger for libraries - Warn if set_logger is called more than once - Fix tiny POD errors 0.00101 2010-02-21 - Fix tests to not need use lib (incorrect test failures) 0.00100 2010-02-20 - initial release Log-Contextual-0.006000/MANIFEST0000644000175000017500000000170312212224466014427 0ustar frewfrewChanges inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Log/Contextual.pm lib/Log/Contextual/Easy/Default.pm lib/Log/Contextual/Easy/Package.pm lib/Log/Contextual/Role/Router.pm lib/Log/Contextual/Role/Router/SetLogger.pm lib/Log/Contextual/Role/Router/WithLogger.pm lib/Log/Contextual/Router.pm lib/Log/Contextual/SimpleLogger.pm lib/Log/Contextual/TeeLogger.pm lib/Log/Contextual/WarnLogger.pm Makefile.PL MANIFEST This list of files META.yml t/arg.t t/base.t t/caller.t t/default_import.t t/default_logger.t t/dlog.t t/easy.t t/eg.t t/lib/BaseLogger.pm t/lib/DefaultImportLogger.pm t/lib/My/Module.pm t/lib/My/Module2.pm t/lib/TestExporter.pm t/lib/TestRouter.pm t/log.t t/log4perl.conf t/log4perl.t t/package_logger.t t/router_api.t t/rt83267.t t/simplelogger.t t/warnlogger.t Log-Contextual-0.006000/Makefile.PL0000644000175000017500000000050412201043655015243 0ustar frewfrewuse 5.006; use inc::Module::Install 0.91; use strict; use warnings FATAL => 'all'; perl_version '5.006'; all_from 'lib/Log/Contextual.pm'; requires 'Data::Dumper::Concise'; requires 'Exporter::Declare' => 0.111; requires 'Carp'; requires 'Scalar::Util'; requires 'Moo' => 1.003000; test_requires 'Test::Fatal'; WriteAll; Log-Contextual-0.006000/t/0000755000175000017500000000000012212224472013535 5ustar frewfrewLog-Contextual-0.006000/t/rt83267.t0000644000175000017500000000065512107312504014764 0ustar frewfrewuse strict; use warnings; use Test::More 'no_plan'; #bug report does not include a case where Log::Contextual is #brought in via 'use' #try to import a single log function but do not include any tags BEGIN { require Log::Contextual; Log::Contextual->import('log_info'); } eval { log_info { "test" }; }; like( $@, qr/^ no logger set! you can't try to log something without a logger!/, 'Got correct error' ); Log-Contextual-0.006000/t/dlog.t0000644000175000017500000000243612107307757014667 0ustar frewfrewuse strict; use warnings; use Log::Contextual::SimpleLogger; use Test::More 'no_plan'; my $var_log; my $var; my @levels = qw(debug trace warn info error fatal); BEGIN { $var_log = Log::Contextual::SimpleLogger->new({ levels => [qw(trace debug info warn error fatal)], coderef => sub { $var = shift } }) } use Log::Contextual qw{:dlog}, -logger => $var_log; for my $level (@levels) { my @foo = main->can("Dlog_$level")->(sub { "Look ma, data: $_" }, qw{frew bar baz}); ok( eq_array(\@foo, [qw{frew bar baz}]), "Dlog_$level passes data through correctly" ); is( $var, qq([$level] Look ma, data: "frew"\n"bar"\n"baz"\n), "Output for Dlog_$level is correct" ); my $bar = main->can("DlogS_$level") ->(sub { "Look ma, data: $_" }, [qw{frew bar baz}]); ok( eq_array($bar, [qw{frew bar baz}]), 'DlogS_trace passes data through correctly' ); is( $var, qq([$level] Look ma, data: [\n "frew",\n "bar",\n "baz"\n]\n), "Output for DlogS_$level is correct" ); @foo = main->can("Dlog_$level")->(sub { "nothing: $_" }, ()); ok(eq_array(\@foo, []), "Dlog_$level passes nothing through correctly"); is($var, "[$level] nothing: ()\n", "Output for Dlog_$level is correct"); } Log-Contextual-0.006000/t/caller.t0000644000175000017500000000213412107307757015177 0ustar frewfrewuse strict; use warnings; use Log::Contextual::SimpleLogger; use Test::More qw(no_plan); use Log::Contextual qw(:log set_logger); my $var; my @caller_info; my $var_log = Log::Contextual::SimpleLogger->new({ levels => [qw(trace debug info warn error fatal)], coderef => sub { chomp($_[0]); $var = "$_[0] at $caller_info[1] line $caller_info[2].\n" } }); my $warn_faker = sub { my ($package, $args) = @_; @caller_info = caller($args->{caller_level}); $var_log }; set_logger($warn_faker); log_debug { 'test log_debug' }; is($var, "[debug] test log_debug at " . __FILE__ . " line " . (__LINE__- 2) . ".\n", 'fake warn'); logS_debug { 'test logS_debug' }; is( $var, "[debug] test logS_debug at " . __FILE__ . " line " . (__LINE__- 3) . ".\n", 'fake warn' ); logS_debug { 'test Dlog_debug' }; is( $var, "[debug] test Dlog_debug at " . __FILE__ . " line " . (__LINE__- 3) . ".\n", 'fake warn' ); logS_debug { 'test DlogS_debug' }; is( $var, "[debug] test DlogS_debug at " . __FILE__ . " line " . (__LINE__- 3) . ".\n", 'fake warn' ); Log-Contextual-0.006000/t/lib/0000755000175000017500000000000012212224472014303 5ustar frewfrewLog-Contextual-0.006000/t/lib/TestExporter.pm0000644000175000017500000000020312107307757017317 0ustar frewfrewpackage TestExporter; use Moo; use TestRouter; extends 'Log::Contextual'; sub router { our $Router ||= TestRouter->new } 1; Log-Contextual-0.006000/t/lib/DefaultImportLogger.pm0000644000175000017500000000072712107307757020601 0ustar frewfrewpackage DefaultImportLogger; use base 'Log::Contextual'; use Log::Contextual::SimpleLogger; my $logger = DumbLogger2->new; sub default_import { ':log' } sub arg_levels { $_[1] || [qw(lol wut zomg)] } sub arg_logger { $_[1] || $logger } package DumbLogger2; our $var; sub new { bless {}, 'DumbLogger2' } sub is_wut { 1 } sub wut { $var = "[wut] $_[1]\n" } sub is_lol { 1 } sub lol { $var = "[lol] $_[1]\n" } sub is_zomg { 1 } sub zomg { $var = "[zomg] $_[1]\n" } 1; Log-Contextual-0.006000/t/lib/BaseLogger.pm0000644000175000017500000000107712107307757016673 0ustar frewfrewpackage BaseLogger; use base 'Log::Contextual'; use Log::Contextual::SimpleLogger; my $logger = DumbLogger2->new; sub arg_levels { $_[1] || [qw(lol wut zomg)] } sub arg_logger { $_[1] || $logger } sub router { our $Router_Instance ||= do { require Log::Contextual::Router; Log::Contextual::Router->new } } package DumbLogger2; our $var; sub new { bless {}, 'DumbLogger2' } sub is_wut { 1 } sub wut { $var = "[wut] $_[1]\n" } sub is_lol { 1 } sub lol { $var = "[lol] $_[1]\n" } sub is_zomg { 1 } sub zomg { $var = "[zomg] $_[1]\n" } 1; Log-Contextual-0.006000/t/lib/TestRouter.pm0000644000175000017500000000075312107307757017001 0ustar frewfrewpackage TestRouter; use Moo; use Log::Contextual::SimpleLogger; with 'Log::Contextual::Role::Router'; has captured => (is => 'ro', default => sub { {} }); sub before_import { my ($self, %export_info) = @_; $self->captured->{before_import} = \%export_info; } sub after_import { my ($self, %export_info) = @_; $self->captured->{after_import} = \%export_info; } sub handle_log_request { my ($self, %message_info) = @_; $self->captured->{message} = \%message_info; } 1; Log-Contextual-0.006000/t/lib/My/0000755000175000017500000000000012212224472014670 5ustar frewfrewLog-Contextual-0.006000/t/lib/My/Module2.pm0000644000175000017500000000034012212217151016526 0ustar frewfrewpackage My::Module2; use Log::Contextual::Easy::Package; sub log { Dlog_fatal { $_ } DlogS_error { $_ } logS_warn { $_[0] } logS_info { $_[0] } log_debug { $_[0] } log_trace { $_[0] } 'xxx'; } 1; Log-Contextual-0.006000/t/lib/My/Module.pm0000644000175000017500000000033712212217151016452 0ustar frewfrewpackage My::Module; use Log::Contextual::Easy::Default; sub log { Dlog_fatal { $_ } DlogS_error { $_ } logS_warn { $_[0] } logS_info { $_[0] } log_debug { $_[0] } log_trace { $_[0] } 'xxx'; } 1; Log-Contextual-0.006000/t/log4perl.conf0000644000175000017500000000100312107307721016130 0ustar frewfrew############################################################ # A simple root logger with a Log::Log4perl::Appender::File # file appender in Perl. ############################################################ log4perl.rootLogger=ERROR, LOGFILE log4perl.appender.LOGFILE=Log::Log4perl::Appender::File log4perl.appender.LOGFILE.filename=myerrs.log log4perl.appender.LOGFILE.mode=append log4perl.appender.LOGFILE.layout=PatternLayout log4perl.appender.LOGFILE.layout.ConversionPattern=file:%F line:%L method:%M - %m%n Log-Contextual-0.006000/t/log4perl.t0000644000175000017500000000160012107307757015462 0ustar frewfrewuse strict; use warnings; use Test::More; if ( eval <<'EOE' require Log::Log4perl; die if $Log::Log4perl::VERSION < 1.29; 1 EOE ) { plan tests => 2; } else { plan skip_all => 'Log::Log4perl 1.29 not installed' } use FindBin; unlink 'myerrs.log' if -e 'myerrs.log'; Log::Log4perl->init("$FindBin::Bin/log4perl.conf"); use Log::Contextual qw( :log set_logger ); set_logger(Log::Log4perl->get_logger); my @elines; push @elines, __LINE__ and log_error { 'err FIRST' }; sub foo { push @elines, __LINE__ and log_error { 'err SECOND' }; } foo(); open my $log, '<', 'myerrs.log'; my @datas = <$log>; close $log; is $datas[0], "file:t/log4perl.t line:$elines[0] method:main:: - err FIRST\n", 'file and line work with Log4perl'; is $datas[1], "file:t/log4perl.t line:$elines[1] method:main::foo - err SECOND\n", 'file and line work with Log4perl in a sub'; unlink 'myerrs.log'; Log-Contextual-0.006000/t/easy.t0000644000175000017500000000321312212217151014656 0ustar frewfrewuse strict; use warnings; use Test::More; use lib 't/lib'; use My::Module; # makes use of Log::Contextual::Easy::Default; use My::Module2; # makes use of Log::Contextual::Easy::Package; # capture logging messages of My::Module, mapping "[...] xxx" to "...$sep" sub logshort($$) { my ($cap, $sep) = @_; sub { local $_ = shift; s/^\[(.+)\] (xxx|"xxx")\n$/$1$sep/; $$cap .= $_; } } # capture warnings my ($cap_warn, $cap_with, $cap_set); local $SIG{__WARN__} = logshort \$cap_warn, '!'; { My::Module::log(); My::Module2::log(); is($cap_warn, undef, 'no logging by default'); } { local $ENV{MY_MODULE_UPTO} = 'info'; local $ENV{MY_MODULE2_UPTO} = 'info'; My::Module::log(); My::Module2::log(); is($cap_warn, "info!warn!error!fatal!info!warn!error!fatal!", 'WarnLogger enabled via ENV'); $cap_warn = ''; } { use Log::Contextual::SimpleLogger; use Log::Contextual qw(with_logger set_logger); set_logger( Log::Contextual::SimpleLogger->new({ levels => [qw(info warn error)], coderef => logshort \$cap_set, '/' }) ); my $with_logger = Log::Contextual::SimpleLogger->new({ levels => [qw(trace info fatal)], coderef => logshort \$cap_with, '|' }); with_logger $with_logger => sub { My::Module::log(); My::Module2::log(); # will not be overridden }; is($cap_with, 'trace|info|fatal|', 'with_logger'); My::Module::log(); My::Module2::log(); # will not be overridden is($cap_set, 'info/warn/error/', 'set_logger'); is($cap_warn, '', 'no warnings if with_logger or set_logger'); } done_testing; Log-Contextual-0.006000/t/package_logger.t0000644000175000017500000000301112107307757016662 0ustar frewfrewuse strict; use warnings; use Log::Contextual qw{:log with_logger set_logger}; use Log::Contextual::SimpleLogger; use Test::More qw(no_plan); my $var1; my $var2; my $var3; my $var_logger1 = Log::Contextual::SimpleLogger->new({ levels => [qw(trace debug info warn error fatal)], coderef => sub { $var1 = shift }, }); my $var_logger2; BEGIN { $var_logger2 = Log::Contextual::SimpleLogger->new({ levels => [qw(trace debug info warn error fatal)], coderef => sub { $var2 = shift }, }) } my $var_logger3; BEGIN { $var_logger3 = Log::Contextual::SimpleLogger->new({ levels => [qw(trace debug info warn error fatal)], coderef => sub { $var3 = shift }, }) } { package J; use Log::Contextual qw{:dlog :log with_logger set_logger}, -package_logger => $var_logger3; sub foo { log_debug { 'bar' }; } sub bar { Dlog_debug { "bar: $_" } 'frew'; } } { package K; use Log::Contextual qw{:log with_logger set_logger}, -package_logger => $var_logger2; sub foo { log_debug { 'foo' }; } } J::foo; K::foo; is($var2, "[debug] foo\n", 'package_logger works for one package'); is($var3, "[debug] bar\n", 'package_logger works for both packages'); J::bar; is($var3, qq([debug] bar: "frew"\n), 'package_logger works for one package'); $var2 = ''; $var1 = ''; set_logger($var_logger1); K::foo; is($var1, q(), '... and set_logger does not win'); is($var2, "[debug] foo\n", '... and package_logger still gets the value'); Log-Contextual-0.006000/t/default_import.t0000644000175000017500000000136312107307757016756 0ustar frewfrewuse strict; use warnings; use lib 't/lib'; use DefaultImportLogger; use Test::More qw(no_plan); my @levels = qw(lol wut zomg); VANILLA: { for (@levels) { main->can("log_$_")->(sub { 'fiSMBoC' }); is( $DumbLogger2::var, "[$_] fiSMBoC\n", "$_ works"); my @vars = main->can("log_$_")->(sub { 'fiSMBoC: ' . $_[1] }, qw{foo bar baz}); is( $DumbLogger2::var, "[$_] fiSMBoC: bar\n", "log_$_ works with input"); ok( eq_array(\@vars, [qw{foo bar baz}]), "log_$_ passes data through correctly"); my $val = main->can("logS_$_")->(sub { 'fiSMBoC: ' . $_[0] }, 'foo'); is( $DumbLogger2::var, "[$_] fiSMBoC: foo\n", "logS_$_ works with input"); is( $val, 'foo', "logS_$_ passes data through correctly"); } } Log-Contextual-0.006000/t/default_logger.t0000644000175000017500000000274012107307757016723 0ustar frewfrewuse strict; use warnings; use Log::Contextual qw{:log with_logger set_logger}; use Log::Contextual::SimpleLogger; use Test::More qw(no_plan); my $var1; my $var2; my $var3; my $var_logger1 = Log::Contextual::SimpleLogger->new({ levels => [qw(trace debug info warn error fatal)], coderef => sub { $var1 = shift }, }); my $var_logger2; BEGIN { $var_logger2 = Log::Contextual::SimpleLogger->new({ levels => [qw(trace debug info warn error fatal)], coderef => sub { $var2 = shift }, }) } my $var_logger3; BEGIN { $var_logger3 = Log::Contextual::SimpleLogger->new({ levels => [qw(trace debug info warn error fatal)], coderef => sub { $var3 = shift }, }) } { package J; use Log::Contextual qw{:dlog :log with_logger set_logger}, -default_logger => $var_logger3; sub foo { log_debug { 'bar' }; } sub bar { Dlog_debug { "bar: $_" } 'frew'; } } { package K; use Log::Contextual qw{:log with_logger set_logger}, -default_logger => $var_logger2; sub foo { log_debug { 'foo' }; } } J::foo; K::foo; is($var2, "[debug] foo\n", 'default_logger works for one package'); is($var3, "[debug] bar\n", 'default_logger works for both packages'); J::bar; is($var3, qq([debug] bar: "frew"\n), 'default_logger works for one package'); $var2 = ''; set_logger($var_logger1); K::foo; is($var2, q(), '... but set_logger wins'); is($var1, "[debug] foo\n", '... and gets the value'); Log-Contextual-0.006000/t/base.t0000644000175000017500000000156712107307757014660 0ustar frewfrewuse strict; use warnings; use lib 't/lib'; use BaseLogger qw{:log with_logger set_logger}; use Test::More qw(no_plan); my @levels = qw(lol wut zomg); VANILLA: { for (@levels) { main->can("log_$_")->(sub { 'fiSMBoC' }); is($DumbLogger2::var, "[$_] fiSMBoC\n", "$_ works"); my @vars = main->can("log_$_")->(sub { 'fiSMBoC: ' . $_[1] }, qw{foo bar baz}); is($DumbLogger2::var, "[$_] fiSMBoC: bar\n", "log_$_ works with input"); ok( eq_array(\@vars, [qw{foo bar baz}]), "log_$_ passes data through correctly" ); my $val = main->can("logS_$_")->(sub { 'fiSMBoC: ' . $_[0] }, 'foo'); is($DumbLogger2::var, "[$_] fiSMBoC: foo\n", "logS_$_ works with input"); is($val, 'foo', "logS_$_ passes data through correctly"); } } ok(!eval { Log::Contextual->import; 1 }, 'Blank Log::Contextual import dies'); Log-Contextual-0.006000/t/warnlogger.t0000644000175000017500000000636412107307757016115 0ustar frewfrewuse strict; use warnings; use Log::Contextual::WarnLogger; use Log::Contextual qw{:log set_logger} => -logger => Log::Contextual::WarnLogger->new({env_prefix => 'FOO'}); use Test::More qw(no_plan); my $l = Log::Contextual::WarnLogger->new({env_prefix => 'BAR'}); { local $ENV{BAR_TRACE} = 0; local $ENV{BAR_DEBUG} = 1; local $ENV{BAR_INFO} = 0; local $ENV{BAR_WARN} = 0; local $ENV{BAR_ERROR} = 0; local $ENV{BAR_FATAL} = 0; ok(!$l->is_trace, 'is_trace is false on WarnLogger'); ok($l->is_debug, 'is_debug is true on WarnLogger'); ok(!$l->is_info, 'is_info is false on WarnLogger'); ok(!$l->is_warn, 'is_warn is false on WarnLogger'); ok(!$l->is_error, 'is_error is false on WarnLogger'); ok(!$l->is_fatal, 'is_fatal is false on WarnLogger'); } { local $ENV{BAR_UPTO} = 'TRACE'; ok($l->is_trace, 'is_trace is true on WarnLogger'); ok($l->is_debug, 'is_debug is true on WarnLogger'); ok($l->is_info, 'is_info is true on WarnLogger'); ok($l->is_warn, 'is_warn is true on WarnLogger'); ok($l->is_error, 'is_error is true on WarnLogger'); ok($l->is_fatal, 'is_fatal is true on WarnLogger'); } { local $ENV{BAR_UPTO} = 'warn'; ok(!$l->is_trace, 'is_trace is false on WarnLogger'); ok(!$l->is_debug, 'is_debug is false on WarnLogger'); ok(!$l->is_info, 'is_info is false on WarnLogger'); ok($l->is_warn, 'is_warn is true on WarnLogger'); ok($l->is_error, 'is_error is true on WarnLogger'); ok($l->is_fatal, 'is_fatal is true on WarnLogger'); } { local $ENV{FOO_TRACE} = 0; local $ENV{FOO_DEBUG} = 1; local $ENV{FOO_INFO} = 0; local $ENV{FOO_WARN} = 0; local $ENV{FOO_ERROR} = 0; local $ENV{FOO_FATAL} = 0; ok( eval { log_trace { die 'this should live' }; 1 }, 'trace does not get called' ); ok( !eval { log_debug { die 'this should die' }; 1 }, 'debug gets called' ); ok( eval { log_info { die 'this should live' }; 1 }, 'info does not get called' ); ok( eval { log_warn { die 'this should live' }; 1 }, 'warn does not get called' ); ok( eval { log_error { die 'this should live' }; 1 }, 'error does not get called' ); ok( eval { log_fatal { die 'this should live' }; 1 }, 'fatal does not get called' ); } { local $ENV{FOO_TRACE} = 1; local $ENV{FOO_DEBUG} = 1; local $ENV{FOO_INFO} = 1; local $ENV{FOO_WARN} = 1; local $ENV{FOO_ERROR} = 1; local $ENV{FOO_FATAL} = 1; my $cap; local $SIG{__WARN__} = sub { $cap = shift }; log_debug { 'frew' }; is($cap, "[debug] frew\n", 'WarnLogger outputs to STDERR correctly'); log_trace { 'trace' }; is($cap, "[trace] trace\n", 'trace renders correctly'); log_debug { 'debug' }; is($cap, "[debug] debug\n", 'debug renders correctly'); log_info { 'info' }; is($cap, "[info] info\n", 'info renders correctly'); log_warn { 'warn' }; is($cap, "[warn] warn\n", 'warn renders correctly'); log_error { 'error' }; is($cap, "[error] error\n", 'error renders correctly'); log_fatal { 'fatal' }; is($cap, "[fatal] fatal\n", 'fatal renders correctly'); } Log-Contextual-0.006000/t/eg.t0000644000175000017500000000375612107307757014343 0ustar frewfrewuse strict; use warnings; use Log::Contextual::SimpleLogger; use Test::More qw(no_plan); use Log::Contextual qw(:log set_logger); my ($var1, $var2, $var3); my $complex_dispatcher = do { my $l1 = Log::Contextual::SimpleLogger->new({ levels => [qw(trace debug info warn error fatal)], coderef => sub { $var1 = shift }, }); my $l2 = Log::Contextual::SimpleLogger->new({ levels => [qw(trace debug info warn error fatal)], coderef => sub { $var2 = shift }, }); my $l3 = Log::Contextual::SimpleLogger->new({ levels => [qw(trace debug info warn error fatal)], coderef => sub { $var3 = shift }, }); my %registry = ( -logger => $l3, A1 => { -logger => $l1, lol => $l2, }, A2 => {-logger => $l2}, ); sub { my ($package, $info) = @_; my $logger = $registry{'-logger'}; if (my $r = $registry{$package}) { $logger = $r->{'-logger'} if $r->{'-logger'}; my (undef, undef, undef, $sub) = caller($info->{caller_level} + 1); $sub =~ s/^\Q$package\E:://g; $logger = $r->{$sub} if $r->{$sub}; } return $logger; } }; set_logger $complex_dispatcher; log_debug { '1.var3' }; is($var3, "[debug] 1.var3\n", "default logger works"); $var3 = ''; A1::lol(); A1::rofl(); is($var2, "[debug] 1.var2\n", "default package logger works"); is($var1, "[debug] 1.var1\n", "package::sub logger works"); $var1 = ''; $var2 = ''; A2::foo(); is($var2, "[debug] 2.var2\n", "only default package logger works"); $var2 = ''; A3::squint(); is($var3, "[debug] 2.var3\n", "global default logger works"); BEGIN { package A1; use Log::Contextual ':log'; sub lol { log_debug { '1.var2' } } sub rofl { log_debug { '1.var1' } } package A2; use Log::Contextual ':log'; sub foo { log_debug { '2.var2' } } package A3; use Log::Contextual ':log'; sub squint { log_debug { '2.var3' } } } Log-Contextual-0.006000/t/arg.t0000644000175000017500000000161412107307757014510 0ustar frewfrewuse strict; use warnings; use Log::Contextual::SimpleLogger; use Test::More 'no_plan'; my $var_log; my $var; my @levels = qw(debug trace warn info error fatal); BEGIN { $var_log = Log::Contextual::SimpleLogger->new({ levels => [qw(trace debug info warn error fatal)], coderef => sub { $var = shift } }) } use Log::Contextual qw{ :log :dlog}, -logger => $var_log; my @args = qw(fizz buzz fizzbuzz); for my $level (@levels) { for my $prefix (qw(log logS Dlog DlogS)) { my $original = local $_ = "don't tread on me"; my $method_name = "${prefix}_${level}"; my $ref = __PACKAGE__->can($method_name) or die "no ref found for method $method_name"; $ref->(sub { "$method_name" }, @args); ok($_ eq $original, "\$_ was not disturbed by $method_name"); ok($var eq "[$level] $method_name\n", "log argument was correct"); } } Log-Contextual-0.006000/t/simplelogger.t0000644000175000017500000000541212107307757016430 0ustar frewfrewuse strict; use warnings; use File::Temp; use Log::Contextual::SimpleLogger; use Log::Contextual qw{:log set_logger} => -logger => Log::Contextual::SimpleLogger->new({levels => [qw{debug}]}); use Test::More qw(no_plan); my $l = Log::Contextual::SimpleLogger->new({levels => [qw{debug}]}); ok(!$l->is_trace, 'is_trace is false on SimpleLogger'); ok($l->is_debug, 'is_debug is true on SimpleLogger'); ok(!$l->is_info, 'is_info is false on SimpleLogger'); ok(!$l->is_warn, 'is_warn is false on SimpleLogger'); ok(!$l->is_error, 'is_error is false on SimpleLogger'); ok(!$l->is_fatal, 'is_fatal is false on SimpleLogger'); ok( eval { log_trace { die 'this should live' }; 1 }, 'trace does not get called' ); ok( !eval { log_debug { die 'this should die' }; 1 }, 'debug gets called' ); ok( eval { log_info { die 'this should live' }; 1 }, 'info does not get called' ); ok( eval { log_warn { die 'this should live' }; 1 }, 'warn does not get called' ); ok( eval { log_error { die 'this should live' }; 1 }, 'error does not get called' ); ok( eval { log_fatal { die 'this should live' }; 1 }, 'fatal does not get called' ); { my $tempfile = File::Temp->new(UNLINK => 1, TEMPLATE => 'stderrXXXXXX'); my $fn = fileno($tempfile); open(STDERR, ">&$fn") or die $!; log_debug { 'frew' }; my $out = do { local @ARGV = $tempfile; <> }; is($out, "[debug] frew\n", 'SimpleLogger outputs to STDERR correctly'); } my $response; my $l2 = Log::Contextual::SimpleLogger->new({ levels => [qw{trace debug info warn error fatal}], coderef => sub { $response = $_[0] }, }); { local $SIG{__WARN__} = sub { }; # do this just to hide warning for tests set_logger($l2); } log_trace { 'trace' }; is($response, "[trace] trace\n", 'trace renders correctly'); log_debug { 'debug' }; is($response, "[debug] debug\n", 'debug renders correctly'); log_info { 'info' }; is($response, "[info] info\n", 'info renders correctly'); log_warn { 'warn' }; is($response, "[warn] warn\n", 'warn renders correctly'); log_error { 'error' }; is($response, "[error] error\n", 'error renders correctly'); log_fatal { 'fatal' }; is($response, "[fatal] fatal\n", 'fatal renders correctly'); log_debug {'line 1', 'line 2'}; is($response, "[debug] line 1\nline 2\n", 'multiline log renders correctly'); my $u = Log::Contextual::SimpleLogger->new({levels_upto => 'debug'}); ok(!$u->is_trace, 'is_trace is false on SimpleLogger'); ok($u->is_debug, 'is_debug is true on SimpleLogger'); ok($u->is_info, 'is_info is true on SimpleLogger'); ok($u->is_warn, 'is_warn is true on SimpleLogger'); ok($u->is_error, 'is_error is true on SimpleLogger'); ok($u->is_fatal, 'is_fatal is true on SimpleLogger'); Log-Contextual-0.006000/t/log.t0000644000175000017500000000530312107307757014517 0ustar frewfrewuse strict; use warnings; use Log::Contextual qw{:log with_logger set_logger}; use Log::Contextual::SimpleLogger; use Test::More qw(no_plan); my @levels = qw(debug trace warn info error fatal); my $var1; my $var2; my $var3; my $var_logger1 = Log::Contextual::SimpleLogger->new({ levels => [qw(trace debug info warn error fatal)], coderef => sub { $var1 = shift }, }); my $var_logger2 = Log::Contextual::SimpleLogger->new({ levels => [qw(trace debug info warn error fatal)], coderef => sub { $var2 = shift }, }); my $var_logger3 = Log::Contextual::SimpleLogger->new({ levels => [qw(trace debug info warn error fatal)], coderef => sub { $var3 = shift }, }); SETLOGGER: { set_logger(sub { $var_logger3 }); log_debug { 'set_logger' }; is($var3, "[debug] set_logger\n", 'set logger works'); } SETLOGGERTWICE: { my $foo; local $SIG{__WARN__} = sub { $foo = shift }; set_logger(sub { $var_logger3 }); like( $foo, qr/set_logger \(or -logger\) called more than once! This is a bad idea! at/, 'set_logger twice warns correctly' ); } WITHLOGGER: { with_logger sub { $var_logger2 } => sub { with_logger $var_logger1 => sub { log_debug { 'nothing!' } }; log_debug { 'frew!' }; }; is($var1, "[debug] nothing!\n", 'inner scoped logger works'); is($var2, "[debug] frew!\n", 'outer scoped logger works'); } SETWITHLOGGER: { with_logger $var_logger1 => sub { log_debug { 'nothing again!' }; # do this just so the following set_logger won't warn local $SIG{__WARN__} = sub { }; set_logger(sub { $var_logger3 }); log_debug { 'this is a set inside a with' }; }; is( $var1, "[debug] nothing again!\n", 'inner scoped logger works after using set_logger' ); is($var3, "[debug] this is a set inside a with\n", 'set inside with works'); log_debug { 'frioux!' }; is( $var3, "[debug] frioux!\n", q{set_logger's logger comes back after scoped logger} ); } VANILLA: { for (@levels) { main->can("log_$_")->(sub { 'fiSMBoC' }); is($var3, "[$_] fiSMBoC\n", "$_ works"); my @vars = main->can("log_$_")->(sub { 'fiSMBoC: ' . $_[1] }, qw{foo bar baz}); is($var3, "[$_] fiSMBoC: bar\n", "log_$_ works with input"); ok( eq_array(\@vars, [qw{foo bar baz}]), "log_$_ passes data through correctly" ); my $val = main->can("logS_$_")->(sub { 'fiSMBoC: ' . $_[0] }, 'foo'); is($var3, "[$_] fiSMBoC: foo\n", "logS_$_ works with input"); is($val, 'foo', "logS_$_ passes data through correctly"); } } ok(!eval { Log::Contextual->import; 1 }, 'Blank Log::Contextual import dies'); Log-Contextual-0.006000/t/router_api.t0000644000175000017500000000251612107307757016112 0ustar frewfrewuse strict; use warnings; use Test::More; use lib 't/lib'; use TestExporter qw(:log), -logger => 'logger value', -default_logger => 'default logger value', -package_logger => 'package logger value'; my @test_args = qw( some argument values ); log_info { "Ignored value" } @test_args; my $results = TestExporter->router->captured; my %export_info = ( exporter => 'TestExporter', target => 'main', arguments => { logger => 'logger value', default_logger => 'default logger value', package_logger => 'package logger value' }, ); my %message_info = ( exporter => 'TestExporter', caller_package => 'main', caller_level => 1, message_level => 'info', message_args => \@test_args, ); is_deeply($results->{before_import}, \%export_info, 'before_import() values are correct'); is_deeply($results->{after_import}, \%export_info, 'after_import() values are correct'); #can't really compare the sub ref value so make sure it exists and is the right type #and remove it for the later result check my $message_block = delete $results->{message}->{message_sub}; is(ref $message_block, 'CODE', 'handle_log_request() got a sub ref for the message generator'); is_deeply($results->{message}, \%message_info, 'handle_log_request() other values are correct'); done_testing; Log-Contextual-0.006000/META.yml0000644000175000017500000000131112212224464014540 0ustar frewfrew--- abstract: 'Simple logging interface with a contextual log' author: - "frew - Arthur Axel \"fREW\" Schmidt " build_requires: ExtUtils::MakeMaker: 6.59 Test::Fatal: 0 configure_requires: ExtUtils::MakeMaker: 6.59 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.06' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 module_name: Log::Contextual name: Log-Contextual no_index: directory: - inc - t requires: Carp: 0 Data::Dumper::Concise: 0 Exporter::Declare: 0.111 Moo: 1.003 Scalar::Util: 0 perl: 5.6.0 resources: license: http://dev.perl.org/licenses/ version: 0.006000 Log-Contextual-0.006000/lib/0000755000175000017500000000000012212224472014040 5ustar frewfrewLog-Contextual-0.006000/lib/Log/0000755000175000017500000000000012212224472014561 5ustar frewfrewLog-Contextual-0.006000/lib/Log/Contextual/0000755000175000017500000000000012212224472016707 5ustar frewfrewLog-Contextual-0.006000/lib/Log/Contextual/WarnLogger.pm0000644000175000017500000001402612107307757021332 0ustar frewfrewpackage Log::Contextual::WarnLogger; use strict; use warnings; use Carp 'croak'; my @default_levels = qw( trace debug info warn error fatal ); # generate subs to handle the default levels # anything else will have to be handled by AUTOLOAD at runtime { for my $level (@default_levels) { no strict 'refs'; my $is_name = "is_$level"; *{$level} = sub { my $self = shift; $self->_log($level, @_) if $self->$is_name; }; *{$is_name} = sub { my $self = shift; return 1 if $ENV{$self->{env_prefix} . '_' . uc $level}; my $upto = $ENV{$self->{env_prefix} . '_UPTO'}; return unless $upto; $upto = lc $upto; return $self->{level_num}{$level} >= $self->{level_num}{$upto}; }; } } our $AUTOLOAD; sub AUTOLOAD { my $self = $_[0]; (my $name = our $AUTOLOAD) =~ s/.*:://; return if $name eq 'DESTROY'; # extract the log level from the sub name my ($is, $level) = $name =~ m/^(is_)?(.+)$/; my $is_name = "is_$level"; no strict 'refs'; *{$level} = sub { my $self = shift; $self->_log($level, @_) if $self->$is_name; }; *{$is_name} = sub { my $self = shift; my $prefix_field = $self->{env_prefix} . '_' . uc $level; return 1 if $ENV{$prefix_field}; # don't log if the variable specifically says not to return 0 if defined $ENV{$prefix_field} and not $ENV{$prefix_field}; my $upto_field = $self->{env_prefix} . '_UPTO'; my $upto = $ENV{$upto_field}; if ($upto) { $upto = lc $upto; croak "Unrecognized log level '$upto' in \$ENV{$upto_field}" if not defined $self->{level_num}{$upto}; return $self->{level_num}{$level} >= $self->{level_num}{$upto}; } # if we don't recognize this level and nothing says otherwise, log! return 1 if not $self->{custom_levels}; }; goto &$AUTOLOAD; } sub new { my ($class, $args) = @_; my $levels = $args->{levels}; croak 'invalid levels specification: must be non-empty arrayref' if defined $levels and (ref $levels ne 'ARRAY' or !@$levels); my $custom_levels = defined $levels; $levels ||= [@default_levels]; my %level_num; @level_num{@$levels} = (0 .. $#{$levels}); my $self = bless { levels => $levels, level_num => \%level_num, custom_levels => $custom_levels, }, $class; $self->{env_prefix} = $args->{env_prefix} or die 'no env_prefix passed to Log::Contextual::WarnLogger->new'; return $self; } sub _log { my $self = shift; my $level = shift; my $message = join("\n", @_); $message .= "\n" unless $message =~ /\n$/; warn "[$level] $message"; } 1; __END__ =head1 NAME Log::Contextual::WarnLogger - Simple logger for libraries using Log::Contextual =head1 SYNOPSIS package My::Package; use Log::Contextual::WarnLogger; use Log::Contextual qw( :log ), -default_logger => Log::Contextual::WarnLogger->new({ env_prefix => 'MY_PACKAGE', levels => [ qw(debug info notice warning error critical alert emergency) ], }); # warns '[info] program started' if $ENV{MY_PACKAGE_TRACE} is set log_info { 'program started' }; # no-op because info is not in levels sub foo { # warns '[debug] entered foo' if $ENV{MY_PACKAGE_DEBUG} is set log_debug { 'entered foo' }; ... } =head1 DESCRIPTION This module is a simple logger made for libraries using L. We recommend the use of this logger as your default logger as it is simple and useful for most users, yet users can use L to override your choice of logger in their own code thanks to the way L works. =head1 METHODS =head2 new Arguments: C<< Dict[ env_prefix => Str, levels => List ] $conf >> my $l = Log::Contextual::WarnLogger->new({ env_prefix => 'BAR' }); or: my $l = Log::Contextual::WarnLogger->new({ env_prefix => 'BAR', levels => [ 'level1', 'level2' ] }); Creates a new logger object where C defines what the prefix is for the environment variables that will be checked for the log levels. The log levels may be customized, but if not defined, these are used: =over 4 =item trace =item debug =item info =item warn =item error =item fatal =back For example, if C is set to C the following environment variables will be used: FREWS_PACKAGE_UPTO FREWS_PACKAGE_TRACE FREWS_PACKAGE_DEBUG FREWS_PACKAGE_INFO FREWS_PACKAGE_WARN FREWS_PACKAGE_ERROR FREWS_PACKAGE_FATAL Note that C is a convenience variable. If you set C<< FOO_UPTO=TRACE >> it will enable all log levels. Similarly, if you set it to C only fatal will be enabled. =back =head2 $level Arguments: C<@anything> All of the following six methods work the same. The basic pattern is: sub $level { my $self = shift; warn "[$level] " . join qq{\n}, @_; if $self->is_$level; } =head3 trace $l->trace( 'entered method foo with args ' join q{,}, @args ); =head3 debug $l->debug( 'entered method foo' ); =head3 info $l->info( 'started process foo' ); =head3 warn $l->warn( 'possible misconfiguration at line 10' ); =head3 error $l->error( 'non-numeric user input!' ); =head3 fatal $l->fatal( '1 is never equal to 0!' ); If different levels are specified, appropriate functions named for your custom levels work as you expect. =head2 is_$level All of the following six functions just return true if their respective environment variable is enabled. =head3 is_trace say 'tracing' if $l->is_trace; =head3 is_debug say 'debuging' if $l->is_debug; =head3 is_info say q{info'ing} if $l->is_info; =head3 is_warn say 'warning' if $l->is_warn; =head3 is_error say 'erroring' if $l->is_error; =head3 is_fatal say q{fatal'ing} if $l->is_fatal; If different levels are specified, appropriate is_$level functions work as you would expect. =head1 AUTHOR See L =head1 COPYRIGHT See L =head1 LICENSE See L =cut Log-Contextual-0.006000/lib/Log/Contextual/Role/0000755000175000017500000000000012212224472017610 5ustar frewfrewLog-Contextual-0.006000/lib/Log/Contextual/Role/Router.pm0000644000175000017500000001226412107307757021446 0ustar frewfrewpackage Log::Contextual::Role::Router; use Moo::Role; requires 'before_import'; requires 'after_import'; requires 'handle_log_request'; 1; __END__ =head1 NAME Log::Contextual::Role::Router - Abstract interface between loggers and logging code blocks =head1 SYNOPSIS package MyApp::Log::Router; use Moo; use Log::Contextual::SimpleLogger; with 'Log::Contextual::Role::Router'; has logger => (is => 'lazy'); sub _build_logger { return Log::Contextual::SimpleLogger->new({ levels_upto => 'debug' }); } sub before_import { my ($self, %export_info) = @_; my $exporter = $export_info{exporter}; my $target = $export_info{target}; print STDERR "Package '$target' will import from '$exporter'\n"; } sub after_import { my ($self, %export_info) = @_; my $exporter = $export_info{exporter}; my $target = $export_info{target}; print STDERR "Package '$target' has imported from '$exporter'\n"; } sub handle_log_request { my ($self, %message_info) = @_; my $log_code_block = $message_info{message_sub}; my $args = $message_info{message_args}; my $log_level_name = $message_info{message_level}; my $logger = $self->logger; my $is_active = $logger->can("is_${log_level_name}"); return unless defined $is_active && $logger->$is_active; my $log_message = $log_code_block->(@$args); $logger->$log_level_name($log_message); } package MyApp::Log::Contextual; use Moo; use MyApp::Log::Router; extends 'Log::Contextual'; #This example router is a singleton sub router { our $Router ||= MyApp::Log::Router->new } package main; use strict; use warnings; use MyApp::Log::Contextual qw(:log); log_info { "Hello there" }; =head1 DESCRIPTION Log::Contextual has three parts =over 4 =item Export manager and logging method generator These tasks are handled by the C package. =item Logger selection and invocation The logging functions generated and exported by Log::Contextual call a method on an instance of a log router object which is responsible for invoking any loggers that should get an opportunity to receive the log message. The C class implements the set_logger() and with_logger() functions as well as uses the arg_ prefixed functions to configure itself and provide the standard C logger selection API. =item Log message formatting and output The logger objects themselves accept or reject a log message at a certain log level with a guard method per level. If the logger is going to accept the log message the router is then responsible for executing the log message code block and passing the generated message to the logging object's log method. =back =head1 METHODS =over 4 =item before_import($self, %import_info) =item after_import($self, %import_info) These two required methods are called with identical arguments at two different places during the import process. The before_import() method is invoked prior to the logging subroutines being exported into the target package and after_import() is called when the export is completed but before control returns to the package that imported the API. The arguments are passed as a hash with the following keys: =over 4 =item exporter This is the name of the package that has been imported. It can also be 'Log::Contextual' itself. In the case of the synopsis the value for exporter would be 'MyApp::Log::Contextual'. =item target This is the package name that is importing the logging API. In the case of the synopsis the value would be 'main'. =item arguments This is a hash reference containing the configuration values that were provided for the import. The key is the name of the configuration item that was specified without the leading hyphen ('-'). For instance if the logging API is imported as follows use Log::Contextual qw( :log ), -logger => Custom::Logger->new({ levels => [qw( debug )] }); then $import_info{arguments}->{logger} would contain that instance of Custom::Logger. =back =item handle_log_request($self, %message_info) This method is called by C when a log event happens. The arguments are passed as a hash with the following keys =over 4 =item exporter This is the name of the package that created the logging methods used to generate the log event. =item caller_package This is the name of the package that the log event has happened inside of. =item caller_level This is an integer that contains the value to pass to caller() that will provide information about the location the log event was created at. =item log_level This is the name of the log level associated with the log event. =item message_sub This is the message generating code block associated with the log event passed as a subref. If the logger accepts the log request the router should execute the subref to create the log message and then pass the message as a string to the logger. =item message_args This is an array reference that contains the arguments given to the message generating code block. When invoking the message generator it will almost certainly be expecting these argument values as well. =back =back =head1 SEE ALSO =over 4 =item C =back Log-Contextual-0.006000/lib/Log/Contextual/Role/Router/0000755000175000017500000000000012212224472021070 5ustar frewfrewLog-Contextual-0.006000/lib/Log/Contextual/Role/Router/WithLogger.pm0000644000175000017500000000014112107307757023510 0ustar frewfrewpackage Log::Contextual::Role::Router::WithLogger; use Moo::Role; requires 'with_logger'; 1; Log-Contextual-0.006000/lib/Log/Contextual/Role/Router/SetLogger.pm0000644000175000017500000000013712107307757023335 0ustar frewfrewpackage Log::Contextual::Role::Router::SetLogger; use Moo::Role; requires 'set_logger'; 1; Log-Contextual-0.006000/lib/Log/Contextual/SimpleLogger.pm0000644000175000017500000000710112107307757021650 0ustar frewfrewpackage Log::Contextual::SimpleLogger; use strict; use warnings; { for my $name (qw( trace debug info warn error fatal )) { no strict 'refs'; *{$name} = sub { my $self = shift; $self->_log($name, @_) if ($self->{$name}); }; *{"is_$name"} = sub { my $self = shift; return $self->{$name}; }; } } sub new { my ($class, $args) = @_; my $self = bless {}, $class; $self->{$_} = 1 for @{$args->{levels}}; $self->{coderef} = $args->{coderef} || sub { print STDERR @_ }; if (my $upto = $args->{levels_upto}) { my @levels = (qw( trace debug info warn error fatal )); my $i = 0; for (@levels) { last if $upto eq $_; $i++ } for ($i .. $#levels) { $self->{$levels[$_]} = 1 } } return $self; } sub _log { my $self = shift; my $level = shift; my $message = join("\n", @_); $message .= "\n" unless $message =~ /\n$/; $self->{coderef}->(sprintf("[%s] %s", $level, $message)); } 1; __END__ =head1 NAME Log::Contextual::SimpleLogger - Super simple logger made for playing with Log::Contextual =head1 SYNOPSIS use Log::Contextual::SimpleLogger; use Log::Contextual qw( :log ), -logger => Log::Contextual::SimpleLogger->new({ levels => [qw( debug )]}); log_info { 'program started' }; # no-op because info is not in levels sub foo { log_debug { 'entered foo' }; ... } =head1 DESCRIPTION This module is a simple logger made mostly for demonstration and initial experimentation with L. We recommend you use a real logger instead. For something more serious but not overly complicated, take a look at L. =head1 METHODS =head2 new Arguments: C<< Dict[ levels => Optional[ArrayRef[Str]], levels_upto => Level, coderef => Optional[CodeRef], ] $conf >> my $l = Log::Contextual::SimpleLogger->new({ levels => [qw( info warn )], coderef => sub { print @_ }, # the default prints to STDERR }); or my $l = Log::Contextual::SimpleLogger->new({ levels_upto => 'debug', coderef => sub { print @_ }, # the default prints to STDERR }); Creates a new SimpleLogger object with the passed levels enabled and optionally a C may be passed to modify how the logs are output/stored. C enables all the levels upto and including the level passed. Levels may contain: trace debug info warn error fatal =head2 $level Arguments: C<@anything> All of the following six methods work the same. The basic pattern is: sub $level { my $self = shift; print STDERR "[$level] " . join qq{\n}, @_; if $self->is_$level; } =head3 trace $l->trace( 'entered method foo with args ' join q{,}, @args ); =head3 debug $l->debug( 'entered method foo' ); =head3 info $l->info( 'started process foo' ); =head3 warn $l->warn( 'possible misconfiguration at line 10' ); =head3 error $l->error( 'non-numeric user input!' ); =head3 fatal $l->fatal( '1 is never equal to 0!' ); =head2 is_$level All of the following six functions just return true if their respective level is enabled. =head3 is_trace say 'tracing' if $l->is_trace; =head3 is_debug say 'debuging' if $l->is_debug; =head3 is_info say q{info'ing} if $l->is_info; =head3 is_warn say 'warning' if $l->is_warn; =head3 is_error say 'erroring' if $l->is_error; =head3 is_fatal say q{fatal'ing} if $l->is_fatal; =head1 AUTHOR See L =head1 COPYRIGHT See L =head1 LICENSE See L =cut Log-Contextual-0.006000/lib/Log/Contextual/TeeLogger.pm0000644000175000017500000000627212107307757021144 0ustar frewfrewpackage Log::Contextual::TeeLogger; use strict; use warnings; { for my $name (qw( trace debug info warn error fatal )) { no strict 'refs'; *{$name} = sub { my $self = shift; foreach my $logger (@{$self->{loggers}}) { $logger->$name(@_); } }; my $is_name = "is_${name}"; *{$is_name} = sub { my $self = shift; foreach my $logger (@{$self->{loggers}}) { return 1 if $logger->$is_name(@_); } return 0; }; } } sub new { my ($class, $args) = @_; my $self = bless {}, $class; ref($self->{loggers} = $args->{loggers}) eq 'ARRAY' or die "No loggers passed to tee logger"; return $self; } 1; __END__ =head1 NAME Log::Contextual::TeeLogger - Output to more than one logger =head1 SYNOPSIS use Log::Contextual::SimpleLogger; use Log::Contextual::TeeLogger; use Log::Contextual qw( :log ), -logger => Log::Contextual::TeeLogger->new({ loggers => [ Log::Contextual::SimpleLogger->new({ levels => [ 'debug' ] }), Log::Contextual::SimpleLogger->new({ levels => [ 'info' ], coderef => sub { print @_ }, }), ]}); ## docs below here not yet edited log_info { 'program started' }; # no-op because info is not in levels sub foo { log_debug { 'entered foo' }; ... } =head1 DESCRIPTION This module is a simple logger made mostly for demonstration and initial experimentation with L. We recommend you use a real logger instead. For something more serious but not overly complicated, take a look at L. =head1 METHODS =head2 new Arguments: C<< Dict[ levels => ArrayRef[Str], coderef => Optional[CodeRef] ] $conf >> my $l = Log::Contextual::SimpleLogger->new({ levels => [qw( info warn )], coderef => sub { print @_ }, # the default prints to STDERR }); Creates a new SimpleLogger object with the passed levels enabled and optionally a C may be passed to modify how the logs are output/stored. Levels may contain: trace debug info warn error fatal =head2 $level Arguments: C<@anything> All of the following six methods work the same. The basic pattern is: sub $level { my $self = shift; print STDERR "[$level] " . join qq{\n}, @_; if $self->is_$level; } =head3 trace $l->trace( 'entered method foo with args ' join q{,}, @args ); =head3 debug $l->debug( 'entered method foo' ); =head3 info $l->info( 'started process foo' ); =head3 warn $l->warn( 'possible misconfiguration at line 10' ); =head3 error $l->error( 'non-numeric user input!' ); =head3 fatal $l->fatal( '1 is never equal to 0!' ); =head2 is_$level All of the following six functions just return true if their respective level is enabled. =head3 is_trace say 'tracing' if $l->is_trace; =head3 is_debug say 'debuging' if $l->is_debug; =head3 is_info say q{info'ing} if $l->is_info; =head3 is_warn say 'warning' if $l->is_warn; =head3 is_error say 'erroring' if $l->is_error; =head3 is_fatal say q{fatal'ing} if $l->is_fatal; =head1 AUTHOR See L =head1 COPYRIGHT See L =head1 LICENSE See L =cut Log-Contextual-0.006000/lib/Log/Contextual/Easy/0000755000175000017500000000000012212224472017610 5ustar frewfrewLog-Contextual-0.006000/lib/Log/Contextual/Easy/Default.pm0000644000175000017500000000263612212217151021535 0ustar frewfrewpackage Log::Contextual::Easy::Default; use base 'Log::Contextual'; sub arg_default_logger { if ($_[1]) { return $_[1]; } else { require Log::Contextual::WarnLogger; my $package = uc(caller(3)); $package =~ s/::/_/g; return Log::Contextual::WarnLogger->new({env_prefix => $package}); } } sub default_import { qw(:dlog :log ) } 1; __END__ =head1 NAME Log::Contextual::Easy::Default - Import all logging methods with WarnLogger as default =head1 SYNOPSIS In your module: package My::Module; use Log::Contextual::Easy::Default; log_debug { "your message" }; Dlog_trace { $_ } @vars; In your program: use My::Module; # enable warnings $ENV{MY_MODULE_UPTO}="TRACE"; # or use a specific logger with set_logger / with_logger =head1 DESCRIPTION By default, this module enables a L with C based on the module's name that uses Log::Contextual::Easy. The logging levels are set to C C, C, C, C, and C (in this order) and all logging functions (L, L, L, and L) are exported. For what C<::Default> implies, see L. =head1 SEE ALSO =over 4 =item L =item L =back Log-Contextual-0.006000/lib/Log/Contextual/Easy/Package.pm0000644000175000017500000000265512212217151021505 0ustar frewfrewpackage Log::Contextual::Easy::Package; use base 'Log::Contextual'; sub arg_package_logger { if ($_[1]) { return $_[1]; } else { require Log::Contextual::WarnLogger; my $package = uc(caller(3)); $package =~ s/::/_/g; return Log::Contextual::WarnLogger->new({env_prefix => $package}); } } sub default_import { qw(:dlog :log ) } 1; __END__ =head1 NAME Log::Contextual::Easy::Package - Import all logging methods with WarnLogger as default package logger =head1 SYNOPSIS In your module: package My::Module; use Log::Contextual::Easy::Package; log_debug { "your message" }; Dlog_trace { $_ } @vars; In your program: use My::Module; # enable warnings $ENV{MY_MODULE_UPTO}="TRACE"; # or use a specific logger with set_logger / with_logger =head1 DESCRIPTION By default, this module enables a L with C based on the module's name that uses Log::Contextual::Easy. The logging levels are set to C C, C, C, C, and C (in this order) and all logging functions (L, L, L, and L) are exported. For what C<::Package> implies, see L. =head1 SEE ALSO =over 4 =item L =item L =back Log-Contextual-0.006000/lib/Log/Contextual/Router.pm0000644000175000017500000000656312107307757020552 0ustar frewfrewpackage Log::Contextual::Router; use Moo; use Scalar::Util 'blessed'; with 'Log::Contextual::Role::Router', 'Log::Contextual::Role::Router::SetLogger', 'Log::Contextual::Role::Router::WithLogger'; eval { require Log::Log4perl; die if $Log::Log4perl::VERSION < 1.29; Log::Log4perl->wrapper_register(__PACKAGE__) }; has _default_logger => ( is => 'ro', default => sub { {} }, init_arg => undef, ); has _package_logger => ( is => 'ro', default => sub { {} }, init_arg => undef, ); has _get_logger => ( is => 'ro', default => sub { {} }, init_arg => undef, ); sub before_import { } sub after_import { my ($self, %import_info) = @_; my $exporter = $import_info{exporter}; my $target = $import_info{target}; my $config = $import_info{arguments}; if (my $l = $exporter->arg_logger($config->{logger})) { $self->set_logger($l); } if (my $l = $exporter->arg_package_logger($config->{package_logger})) { $self->_set_package_logger_for($target, $l); } if (my $l = $exporter->arg_default_logger($config->{default_logger})) { $self->_set_default_logger_for($target, $l); } } sub with_logger { my $logger = $_[1]; if (ref $logger ne 'CODE') { die 'logger was not a CodeRef or a logger object. Please try again.' unless blessed($logger); $logger = do { my $l = $logger; sub { $l } } } local $_[0]->_get_logger->{l} = $logger; $_[2]->(); } sub set_logger { my $logger = $_[1]; if (ref $logger ne 'CODE') { die 'logger was not a CodeRef or a logger object. Please try again.' unless blessed($logger); $logger = do { my $l = $logger; sub { $l } } } warn 'set_logger (or -logger) called more than once! This is a bad idea!' if $_[0]->_get_logger->{l}; $_[0]->_get_logger->{l} = $logger; } sub _set_default_logger_for { my $logger = $_[2]; if (ref $logger ne 'CODE') { die 'logger was not a CodeRef or a logger object. Please try again.' unless blessed($logger); $logger = do { my $l = $logger; sub { $l } } } $_[0]->_default_logger->{$_[1]} = $logger } sub _set_package_logger_for { my $logger = $_[2]; if (ref $logger ne 'CODE') { die 'logger was not a CodeRef or a logger object. Please try again.' unless blessed($logger); $logger = do { my $l = $logger; sub { $l } } } $_[0]->_package_logger->{$_[1]} = $logger } sub get_loggers { my ($self, %info) = @_; my $package = $info{caller_package}; my $log_level = $info{message_level}; my $logger = ( $_[0]->_package_logger->{$package} || $_[0]->_get_logger->{l} || $_[0]->_default_logger->{$package} || die q( no logger set! you can't try to log something without a logger! )); $info{caller_level}++; $logger = $logger->($package, \%info); return $logger if $logger ->${\"is_${log_level}"}; return (); } sub handle_log_request { my ($self, %message_info) = @_; my $generator = $message_info{message_sub}; my $args = $message_info{message_args}; my $log_level = $message_info{message_level}; $message_info{caller_level}++; foreach my $logger ($self->get_loggers(%message_info)) { $logger->$log_level($generator->(@$args)); } } 1; Log-Contextual-0.006000/lib/Log/Contextual.pm0000644000175000017500000004713112212224365017254 0ustar frewfrewpackage Log::Contextual; use strict; use warnings; our $VERSION = '0.006000'; $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases my @levels = qw(debug trace warn info error fatal); use Exporter::Declare; use Exporter::Declare::Export::Generator; use Data::Dumper::Concise; use Scalar::Util 'blessed'; my @dlog = ((map "Dlog_$_", @levels), (map "DlogS_$_", @levels)); my @log = ((map "log_$_", @levels), (map "logS_$_", @levels)); eval { require Log::Log4perl; die if $Log::Log4perl::VERSION < 1.29; Log::Log4perl->wrapper_register(__PACKAGE__) }; # ____ is because tags must have at least one export and we don't want to # export anything but the levels selected sub ____ { } exports ('____', @dlog, @log, qw( set_logger with_logger ) ); export_tag dlog => ('____'); export_tag log => ('____'); import_arguments qw(logger package_logger default_logger); sub router { our $Router_Instance ||= do { require Log::Contextual::Router; Log::Contextual::Router->new } } sub default_import { my ($class) = shift; die 'Log::Contextual does not have a default import list'; () } sub arg_logger { $_[1] } sub arg_levels { $_[1] || [qw(debug trace warn info error fatal)] } sub arg_package_logger { $_[1] } sub arg_default_logger { $_[1] } sub before_import { my ($class, $importer, $spec) = @_; my $router = $class->router; my $exports = $spec->exports; my %router_args = ( exporter => $class, target => $importer, arguments => $spec->argument_info ); my @tags = $class->default_import($spec) if $spec->config->{default}; for (@tags) { die "only tags are supported for defaults at this time" unless $_ =~ /^:(.*)$/; $spec->config->{$1} = 1; } $router->before_import(%router_args); if ($exports->{'&set_logger'}) { die ref($router) . " does not support set_logger()" unless $router->does('Log::Contextual::Role::Router::SetLogger'); $spec->add_export('&set_logger', sub { $router->set_logger(@_) }) } if ($exports->{'&with_logger'}) { die ref($router) . " does not support with_logger()" unless $router->does('Log::Contextual::Role::Router::WithLogger'); $spec->add_export('&with_logger', sub { $router->with_logger(@_) }) } my @levels = @{$class->arg_levels($spec->config->{levels})}; for my $level (@levels) { if ($spec->config->{log} || $exports->{"&log_$level"}) { $spec->add_export( "&log_$level", sub (&@) { my ($code, @args) = @_; $router->handle_log_request( exporter => $class, caller_package => scalar(caller), caller_level => 1, message_level => $level, message_sub => $code, message_args => \@args, ); return @args; }); } if ($spec->config->{log} || $exports->{"&logS_$level"}) { $spec->add_export( "&logS_$level", sub (&@) { my ($code, @args) = @_; $router->handle_log_request( exporter => $class, caller_package => scalar(caller), caller_level => 1, message_level => $level, message_sub => $code, message_args => \@args, ); return $args[0]; }); } if ($spec->config->{dlog} || $exports->{"&Dlog_$level"}) { $spec->add_export( "&Dlog_$level", sub (&@) { my ($code, @args) = @_; my $wrapped = sub { local $_ = (@_ ? Data::Dumper::Concise::Dumper @_ : '()'); &$code; }; $router->handle_log_request( exporter => $class, caller_package => scalar(caller), caller_level => 1, message_level => $level, message_sub => $wrapped, message_args => \@args, ); return @args; }); } if ($spec->config->{dlog} || $exports->{"&DlogS_$level"}) { $spec->add_export( "&DlogS_$level", sub (&$) { my ($code, $ref) = @_; my $wrapped = sub { local $_ = Data::Dumper::Concise::Dumper($_[0]); &$code; }; $router->handle_log_request( exporter => $class, caller_package => scalar(caller), caller_level => 1, message_level => $level, message_sub => $wrapped, message_args => [$ref], ); return $ref; }); } } } sub after_import { my ($class, $importer, $spec) = @_; my %router_args = ( exporter => $class, target => $importer, arguments => $spec->argument_info ); $class->router->after_import(%router_args); } for (qw(set with)) { no strict 'refs'; my $sub = "${_}_logger"; *{"Log::Contextual::$sub"} = sub { die "$sub is no longer a direct sub in Log::Contextual. " . 'Note that this feature was never tested nor documented. ' . "Please fix your code to import $sub instead of trying to use it directly" } } 1; __END__ =head1 NAME Log::Contextual - Simple logging interface with a contextual log =head1 SYNOPSIS use Log::Contextual qw( :log :dlog set_logger with_logger ); use Log::Contextual::SimpleLogger; use Log::Log4perl ':easy'; Log::Log4perl->easy_init($DEBUG); my $logger = Log::Log4perl->get_logger; set_logger $logger; log_debug { 'program started' }; sub foo { my $minilogger = Log::Contextual::SimpleLogger->new({ levels => [qw( trace debug )] }); my @args = @_; with_logger $minilogger => sub { log_trace { 'foo entered' }; my ($foo, $bar) = Dlog_trace { "params for foo: $_" } @args; # ... log_trace { 'foo left' }; }; } foo(); Beginning with version 1.008 L also works out of the box with C: use Log::Contextual qw( :log :dlog set_logger ); use Log::Dispatchouli; my $ld = Log::Dispatchouli->new({ ident => 'slrtbrfst', to_stderr => 1, debug => 1, }); set_logger $ld; log_debug { 'program started' }; =head1 DESCRIPTION Major benefits: =over 2 =item * Efficient The logging functions take blocks, so if a log level is disabled, the block will not run: # the following won't run if debug is off log_debug { "the new count in the database is " . $rs->count }; Similarly, the C prefixed methods only C the input if the level is enabled. =item * Handy The logging functions return their arguments, so you can stick them in the middle of expressions: for (log_debug { "downloading:\n" . join qq(\n), @_ } @urls) { ... } =item * Generic C is an interface for all major loggers. If you log through C you will be able to swap underlying loggers later. =item * Powerful C chooses which logger to use based on L<< user defined Cs|/LOGGER CODEREF >>. Normally you don't need to know this, but you can take advantage of it when you need to later =item * Scalable If you just want to add logging to your extremely basic application, start with L and then as your needs grow you can switch to L or L or L or whatever else. =back This module is a simple interface to extensible logging. It exists to abstract your logging interface so that logging is as painless as possible, while still allowing you to switch from one logger to another. It is bundled with a really basic logger, L, but in general you should use a real logger instead of that. For something more serious but not overly complicated, try L (see L for example.) =head1 A WORK IN PROGRESS This module is certainly not complete, but we will not break the interface lightly, so I would say it's safe to use in production code. The main result from that at this point is that doing: use Log::Contextual; will die as we do not yet know what the defaults should be. If it turns out that nearly everyone uses the C<:log> tag and C<:dlog> is really rare, we'll probably make C<:log> the default. But only time and usage will tell. =head1 IMPORT OPTIONS See L for information on setting these project wide. =head2 -logger When you import this module you may use C<-logger> as a shortcut for L, for example: use Log::Contextual::SimpleLogger; use Log::Contextual qw( :dlog ), -logger => Log::Contextual::SimpleLogger->new({ levels => [qw( debug )] }); sometimes you might want to have the logger handy for other stuff, in which case you might try something like the following: my $var_log; BEGIN { $var_log = VarLogger->new } use Log::Contextual qw( :dlog ), -logger => $var_log; =head2 -levels The C<-levels> import option allows you to define exactly which levels your logger supports. So the default, C<< [qw(debug trace warn info error fatal)] >>, works great for L, but it doesn't support the levels for L. But supporting those levels is as easy as doing use Log::Contextual -levels => [qw( debug info notice warning error critical alert emergency )]; =head2 -package_logger The C<-package_logger> import option is similar to the C<-logger> import option except C<-package_logger> sets the logger for the current package. Unlike L, C<-package_logger> cannot be overridden with L. package My::Package; use Log::Contextual::SimpleLogger; use Log::Contextual qw( :log ), -package_logger => Log::Contextual::WarnLogger->new({ env_prefix => 'MY_PACKAGE' }); If you are interested in using this package for a module you are putting on CPAN we recommend L for your package logger. =head2 -default_logger The C<-default_logger> import option is similar to the C<-logger> import option except C<-default_logger> sets the B logger for the current package. Basically it sets the logger to be used if C is never called; so package My::Package; use Log::Contextual::SimpleLogger; use Log::Contextual qw( :log ), -default_logger => Log::Contextual::WarnLogger->new({ env_prefix => 'MY_PACKAGE' }); =head1 SETTING DEFAULT IMPORT OPTIONS Eventually you will get tired of writing the following in every single one of your packages: use Log::Log4perl; use Log::Log4perl ':easy'; BEGIN { Log::Log4perl->easy_init($DEBUG) } use Log::Contextual -logger => Log::Log4perl->get_logger; You can set any of the import options for your whole project if you define your own C subclass as follows: package MyApp::Log::Contextual; use base 'Log::Contextual'; use Log::Log4perl ':easy'; Log::Log4perl->easy_init($DEBUG) sub arg_default_logger { $_[1] || Log::Log4perl->get_logger } sub arg_levels { [qw(debug trace warn info error fatal custom_level)] } sub default_import { ':log' } # or maybe instead of default_logger sub arg_package_logger { $_[1] } # and almost definitely not this, which is only here for completeness sub arg_logger { $_[1] } Note the C<< $_[1] || >> in C. All of these methods are passed the values passed in from the arguments to the subclass, so you can either throw them away, honor them, die on usage, or whatever. To be clear, if you define your subclass, and someone uses it as follows: use MyApp::Log::Contextual -default_logger => $foo, -levels => [qw(bar baz biff)]; Your C method will get C<$foo> and your C will get C<[qw(bar baz biff)]>; Additionally, the C method is what happens if a user tries to use your subclass with no arguments. The default just dies, but if you'd like to change the default to import a tag merely return the tags you'd like to import. So the following will all work: sub default_import { ':log' } sub default_import { ':dlog' } sub default_import { qw(:dlog :log ) } See L for an example of a subclass of C that makes use of default import options. =head1 FUNCTIONS =head2 set_logger my $logger = WarnLogger->new; set_logger $logger; Arguments: L C will just set the current logger to whatever you pass it. It expects a C, but if you pass it something else it will wrap it in a C for you. C is really meant only to be called from a top-level script. To avoid foot-shooting the function will warn if you call it more than once. =head2 with_logger my $logger = WarnLogger->new; with_logger $logger => sub { if (1 == 0) { log_fatal { 'Non Logical Universe Detected' }; } else { log_info { 'All is good' }; } }; Arguments: L, C C sets the logger for the scope of the C C<$to_execute>. As with L, C will wrap C<$returning_logger> with a C if needed. =head2 log_$level Import Tag: C<:log> Arguments: C C functions all work the same except that a different method is called on the underlying C<$logger> object. The basic pattern is: sub log_$level (&@) { if ($logger->is_$level) { $logger->$level(shift->(@_)); } @_ } Note that the function returns it's arguments. This can be used in a number of ways, but often it's convenient just for partial inspection of passthrough data my @friends = log_trace { 'friends list being generated, data from first friend: ' . Dumper($_[0]->TO_JSON) } generate_friend_list(); If you want complete inspection of passthrough data, take a look at the L functions. Which functions are exported depends on what was passed to L. The default (no C<-levels> option passed) would export: =over 2 =item log_trace =item log_debug =item log_info =item log_warn =item log_error =item log_fatal =back =head2 logS_$level Import Tag: C<:log> Arguments: C This is really just a special case of the L functions. It forces scalar context when that is what you need. Other than that it works exactly same: my $friend = logS_trace { 'I only have one friend: ' . Dumper($_[0]->TO_JSON) } friend(); See also: L. =head2 Dlog_$level Import Tag: C<:dlog> Arguments: C All of the following six functions work the same as their L brethren, except they return what is passed into them and put the stringified (with L) version of their args into C<$_>. This means you can do cool things like the following: my @nicks = Dlog_debug { "names: $_" } map $_->value, $frew->names->all; and the output might look something like: names: "fREW" "fRIOUX" "fROOH" "fRUE" "fiSMBoC" Which functions are exported depends on what was passed to L. The default (no C<-levels> option passed) would export: =over 2 =item Dlog_trace =item Dlog_debug =item Dlog_info =item Dlog_warn =item Dlog_error =item Dlog_fatal =back =head2 DlogS_$level Import Tag: C<:dlog> Arguments: C Like L, these functions are a special case of L. They only take a single scalar after the C<$returning_message> instead of slurping up (and also setting C) all the C<@args> my $pals_rs = DlogS_debug { "pals resultset: $_" } $schema->resultset('Pals')->search({ perlers => 1 }); =head1 LOGGER CODEREF Anywhere a logger object can be passed, a coderef is accepted. This is so that the user can use different logger objects based on runtime information. The logger coderef is passed the package of the caller the caller level the coderef needs to use if it wants more caller information. The latter is in a hashref to allow for more options in the future. Here is a basic example of a logger that exploits C to reproduce the output of C with a logger: my @caller_info; my $var_log = Log::Contextual::SimpleLogger->new({ levels => [qw(trace debug info warn error fatal)], coderef => sub { chomp($_[0]); warn "$_[0] at $caller_info[1] line $caller_info[2].\n" } }); my $warn_faker = sub { my ($package, $args) = @_; @caller_info = caller($args->{caller_level}); $var_log }; set_logger($warn_faker); log_debug { 'test' }; The following is an example that uses the information passed to the logger coderef. It sets the global logger to C<$l3>, the logger for the C package to C<$l1>, except the C method in C which uses the C<$l2> logger and lastly the logger for the C package to C<$l2>. Note that it increases the caller level as it dispatches based on where the caller of the log function, not the log function itself. my $complex_dispatcher = do { my $l1 = ...; my $l2 = ...; my $l3 = ...; my %registry = ( -logger => $l3, A1 => { -logger => $l1, lol => $l2, }, A2 => { -logger => $l2 }, ); sub { my ( $package, $info ) = @_; my $logger = $registry{'-logger'}; if (my $r = $registry{$package}) { $logger = $r->{'-logger'} if $r->{'-logger'}; my (undef, undef, undef, $sub) = caller($info->{caller_level} + 1); $sub =~ s/^\Q$package\E:://g; $logger = $r->{$sub} if $r->{$sub}; } return $logger; } }; set_logger $complex_dispatcher; =head1 LOGGER INTERFACE Because this module is ultimately pretty looking glue (glittery?) with the awesome benefit of the Contextual part, users will often want to make their favorite logger work with it. The following are the methods that should be implemented in the logger: is_trace is_debug is_info is_warn is_error is_fatal trace debug info warn error fatal The first six merely need to return true if that level is enabled. The latter six take the results of whatever the user returned from their coderef and log them. For a basic example see L. =head1 LOG ROUTING In between the loggers and the log functions is a log router that is responsible for finding a logger to handle the log event and passing the log information to the logger. This relationship is described in the documentation for C. C and packages that extend it will by default share a router singleton that implements the with_logger() and set_logger() functions and also respects the -logger, -package_logger, and -default_logger import options with their associated default value functions. The router singleton is available as the return value of the router() function. Users of Log::Contextual may overload router() to return instances of custom log routers that could for example work with loggers that use a different interface. =head1 AUTHOR frew - Arthur Axel "fREW" Schmidt =head1 CONTRIBUTORS =encoding utf8 triddle - Tyler Riddle voj - Jakob Voß =head1 DESIGNER mst - Matt S. Trout =head1 COPYRIGHT Copyright (c) 2012 the Log::Contextual L and L as listed above. =head1 LICENSE This library is free software and may be distributed under the same terms as Perl 5 itself. =cut Log-Contextual-0.006000/inc/0000755000175000017500000000000012212224472014043 5ustar frewfrewLog-Contextual-0.006000/inc/Module/0000755000175000017500000000000012212224472015270 5ustar frewfrewLog-Contextual-0.006000/inc/Module/Install.pm0000644000175000017500000003013512212224463017236 0ustar frewfrew#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.06'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. Log-Contextual-0.006000/inc/Module/Install/0000755000175000017500000000000012212224472016676 5ustar frewfrewLog-Contextual-0.006000/inc/Module/Install/Win32.pm0000644000175000017500000000340312212224463020136 0ustar frewfrew#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; Log-Contextual-0.006000/inc/Module/Install/Base.pm0000644000175000017500000000214712212224463020112 0ustar frewfrew#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 Log-Contextual-0.006000/inc/Module/Install/Makefile.pm0000644000175000017500000002743712212224463020766 0ustar frewfrew#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 Log-Contextual-0.006000/inc/Module/Install/Fetch.pm0000644000175000017500000000462712212224463020276 0ustar frewfrew#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Log-Contextual-0.006000/inc/Module/Install/Can.pm0000644000175000017500000000615712212224463017746 0ustar frewfrew#line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 236 Log-Contextual-0.006000/inc/Module/Install/Metadata.pm0000644000175000017500000004327712212224463020771 0ustar frewfrew#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Log-Contextual-0.006000/inc/Module/Install/WriteAll.pm0000644000175000017500000000237612212224463020767 0ustar frewfrew#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1;