initial commit

.gitignore

@@ -0,0 +1,2 @@
+.build
+DBIx-Class-QueryLog-Conditional-*

.travis.yml

@@ -0,0 +1,18 @@
+language: perl
+perl:
+   - "5.18"
+   - "5.16"
+   - "5.14"
+   - "5.12"
+   - "5.10"
+   - "5.8"
+
+install:
+   - export RELEASE_TESTING=1 AUTOMATED_TESTING=1 AUTHOR_TESTING=1 HARNESS_OPTIONS=j10:c HARNESS_TIMER=1
+   - cpanm --quiet --notest Devel::Cover::Report::Coveralls
+
+script:
+   - PERL5OPT=-MDevel::Cover=-coverage,statement,branch,condition,path,subroutine prove -lrsv t
+   - cover
+after_success:
+  - cover -report coveralls

Changes

@@ -0,0 +1,4 @@
+Revision history for {{$dist->name}}
+
+{{$NEXT}}
+ - Initial Release

cpanfile

@@ -0,0 +1,10 @@
+requires 'Moo' => 1.004002;
+requires 'Sub::Name' => 0.05;
+requires 'namespace::clean' => 0.24;
+
+on test => sub {
+   requires 'Test::More' => 1.001002;
+   requires 'Test::Deep' => 0.112;
+   requires 'Test::Fatal' => 0.013;
+   requires 'aliased' => 0.31;
+};

dist.ini

@@ -0,0 +1,18 @@
+name             = DBIx-Class-QueryLog-Conditional
+author           = Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
+license          = Perl_5
+copyright_holder = Arthur Axel "fREW" Schmidt
+version          = 0.001000
+
+[NextRelease]
+[@Git]
+[@Basic]
+[GithubMeta]
+issues = 1
+
+[MetaJSON]
+[PodWeaver]
+[PkgVersion]
+[ReadmeFromPod]
+[PodSyntaxTests]
+[Prereqs::FromCPANfile]

lib/DBIx/Class/QueryLog/Conditional.pm

@@ -0,0 +1,112 @@
+package DBIx::Class::QueryLog::Conditional;
+
+# ABSTRACT: Disable QueryLogger instead of all query logging
+
+use Moo;
+use warnings NONFATAL => 'all';
+
+use Sub::Name 'subname';
+
+my @methods = qw(
+   txn_begin txn_commit txn_rollback
+   svp_begin svp_release svp_rollback
+   query_start query_end
+);
+sub _valid_logger { !$_[0]->can($_) && return 0 for @methods; 1 }
+
+use namespace::clean;
+
+has _logger => (
+   is => 'ro',
+   isa => sub { die 'not a valid logger' unless _valid_logger($_[0]) },
+   init_arg => 'logger',
+   required => 1,
+);
+
+has enabled => (
+   is => 'rw',
+   default => 1,
+);
+
+has _enabled_method => (
+   is => 'ro',
+   init_arg => 'enabled_method',
+   default => sub {
+      sub { shift->enabled }
+   },
+);
+
+for my $method (@methods) {
+   no strict 'refs';
+   *{$method} = subname $method => sub {
+      my $self = shift;
+
+      my $m = $self->_enabled_method ;
+      return unless $self->$m;
+
+      $self->_logger->$method(@_);
+   };
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 SYNOPSIS
+
+ my $ql = DBIx::Class:::QueryLog->new;
+ $schema->storage->debugobj(
+    DBIx::Class:::QueryLog::Tee->new(
+         loggers => {
+            new      => $ql,
+            original => DBIx::Class::QueryLog::Conditional->new(
+               logger => $self->storage->debugobj,
+               enabled_method => sub { $ENV{DBIC_TRACE} },
+            ),
+         },
+    ),
+ );
+ $schema->storage->debug(1);
+
+
+Now the original storageobj is enabled and disabled based on the standard env
+var.
+
+=head1 DESCRIPTION
+
+When you use L<DBIx::Class::QueryLog::Tee> you will likely find that
+suddenly you are logging everything.  Before C<::Tee> came along your
+console was inconsolable, dispondant; you never heard from it again.
+After using C<::Tee> suddenly your silent, morose query log became manic.
+It woudln't shut up!  This was not what you bargained for...
+
+C<DBIx::Class::QueryLog::Conditional> is part of The Final Equation.
+Instead of no noise, or all noise, C<::Conditional> is the bear that
+gives you just the right amount and temperature of porridge.
+
+=method C<new>
+
+Requires a C<logger> that must be a L</LOGGER>.  Can optionally take
+either C<enabled> or C<enabled_method>.
+
+C<enabled> is a simple bool, defaulting to true.
+
+C<enabled_method> is a code reference called as a method.  It defaults to
+checking L</enabled>.  A good alternate is proposed in the L</SYNOPSIS>.
+
+=method C<enabled>
+
+A simple helper attribute.  Defaults to true, can be set to false to
+turn off your logger via code.
+
+=head1 LOGGER
+
+A logger is defined as an object that has the following methods:
+
+   txn_begin txn_commit txn_rollback
+   svp_begin svp_release svp_rollback
+   query_start query_end
+
+=cut

t/basic.t

@@ -0,0 +1,107 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+use Test::Deep;
+
+use aliased 'DBIx::Class::QueryLog::Conditional';
+
+subtest instantiation => sub {
+   ok(
+      Conditional->new(logger => ValidLogger->new ),
+      'valid logger'
+   );
+   ok(
+      exception { Conditional->new(logger => InValidLogger->new ) },
+      'invalid logger',
+   );
+};
+
+subtest 'vanilla log' => sub {
+   my $a = ValidLogger->new;
+   my $tee = Conditional->new( logger => $a );
+
+   $tee->query_start('foo');
+   $tee->query_end('foo');
+
+   cmp_deeply($a->_data,
+      [ ['query_start', 'foo'], ['query_end', 'foo'] ],
+      'messages passed through correctly',
+   );
+
+   $a->reset_data;
+
+   $tee->enabled(0);
+
+   $tee->query_start('foo');
+   $tee->query_end('foo');
+
+   cmp_deeply($a->_data,
+      [],
+      'disabling logger works',
+   );
+
+};
+
+subtest 'custom log' => sub {
+   my $a = ValidLogger->new;
+   my $b = 1;
+   my $tee = Conditional->new(
+      logger => $a,
+      enabled_method => sub { $b },
+   );
+
+   $tee->query_start('foo');
+   $tee->query_end('foo');
+
+   cmp_deeply($a->_data,
+      [ ['query_start', 'foo'], ['query_end', 'foo'] ],
+      'messages passed through correctly',
+   );
+
+   $a->reset_data;
+
+   $b = 0;
+
+   $tee->query_start('foo');
+   $tee->query_end('foo');
+
+   cmp_deeply($a->_data,
+      [],
+      'disabling logger works',
+   );
+
+};
+
+done_testing;
+
+BEGIN {
+   package ValidLogger;
+   use Sub::Name 'subname';
+   use Moo;
+
+   has _data => (
+      is => 'ro',
+      lazy => 1,
+      default => sub { [] },
+      clearer => 'reset_data',
+   );
+
+   for my $m (qw(txn_begin txn_commit txn_rollback svp_begin svp_release svp_rollback query_start query_end)) {
+      no strict 'refs';
+      *{$m} = subname $m => sub { push @{shift->_data}, [$m, @_] }
+   }
+}
+
+BEGIN {
+   package InValidLogger;
+   use Sub::Name 'subname';
+   sub new { bless {}, shift }
+   for my $m (qw(txn_begin txn_commit txn_rollback svp_begin svp_release svp_rollback)) {
+      no strict 'refs';
+      *{$m} = subname $m => sub { }
+   }
+}