From: Peter Rabbitson Date: Wed, 21 May 2014 13:15:04 +0000 (+0200) Subject: Swap CAG with Moo, lazify a lot of the profile selection X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c54740ba9963ea408e5b8d0dd8e8cb8fc4886dc6;p=scpubgit%2FQ-Branch.git Swap CAG with Moo, lazify a lot of the profile selection There should be zero functional changes --- diff --git a/Makefile.PL b/Makefile.PL index 308d657..03135ac 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -17,14 +17,14 @@ dynamic_config 0; requires 'List::Util' => 0; requires 'Scalar::Util' => 0; -requires 'Class::Accessor::Grouped' => 0.10005; +requires 'Moo' => 1.004002; +requires 'Hash::Merge' => 0.12; requires 'Getopt::Long::Descriptive' => 0.091; -requires 'Hash::Merge' => 0.12; -test_requires "Test::More" => 0.92; -test_requires "Test::Exception" => 0; +test_requires "Test::More" => 0.88; +test_requires "Test::Exception" => 0.31; test_requires "Test::Warn" => 0; -test_requires "Test::Deep" => '0.101'; +test_requires "Test::Deep" => 0.101; test_requires "Storable" => 0; # for cloning in tests no_index package => 'DBIx::Class::Storage::Debug::PrettyPrint'; diff --git a/lib/SQL/Abstract/Tree.pm b/lib/SQL/Abstract/Tree.pm index decc5ed..d9b67f9 100644 --- a/lib/SQL/Abstract/Tree.pm +++ b/lib/SQL/Abstract/Tree.pm @@ -1,38 +1,22 @@ package SQL::Abstract::Tree; +# DO NOT edit away without talking to riba first, he will just put it back +# BEGIN pre-Moo2 import block +BEGIN { + require warnings; + my $initial_fatal_bits = (${^WARNING_BITS}||'') & $warnings::DeadBits{all}; + local $ENV{PERL_STRICTURES_EXTRA} = 0; + require Moo; Moo->import; + require Sub::Quote; Sub::Quote->import('quote_sub'); + ${^WARNING_BITS} &= ( $initial_fatal_bits | ~ $warnings::DeadBits{all} ); +} +# END pre-Moo2 import block + use strict; use warnings; no warnings 'qw'; -use Carp; - -use Hash::Merge qw//; - -use base 'Class::Accessor::Grouped'; -__PACKAGE__->mk_group_accessors( simple => qw( - newline indent_string indent_amount colormap indentmap fill_in_placeholders - placeholder_surround -)); - -my $merger = Hash::Merge->new; - -$merger->specify_behavior({ - SCALAR => { - SCALAR => sub { $_[1] }, - ARRAY => sub { [ $_[0], @{$_[1]} ] }, - HASH => sub { $_[1] }, - }, - ARRAY => { - SCALAR => sub { $_[1] }, - ARRAY => sub { $_[1] }, - HASH => sub { $_[1] }, - }, - HASH => { - SCALAR => sub { $_[1] }, - ARRAY => sub { [ values %{$_[0]}, @{$_[1]} ] }, - HASH => sub { Hash::Merge::_merge_hashes( $_[0], $_[1] ) }, - }, -}, 'SQLA::Tree Behavior' ); +use Carp; my $op_look_ahead = '(?: (?= [\s\)\(\;] ) | \z)'; my $op_look_behind = '(?: (?<= [\,\s\)\(] ) | \A )'; @@ -196,18 +180,33 @@ my %indents = ( first => 1, ); -my %profiles = ( - console => { - fill_in_placeholders => 1, - placeholder_surround => ['?/', ''], - indent_string => ' ', - indent_amount => 2, - newline => "\n", - colormap => {}, - indentmap => \%indents, - - eval { require Term::ANSIColor } - ? do { + +has [qw( + newline indent_string indent_amount fill_in_placeholders placeholder_surround +)] => (is => 'ro'); + +has [qw( indentmap colormap )] => ( is => 'ro', default => quote_sub('{}') ); + +# class global is in fact desired +my $merger; + +sub BUILDARGS { + my $class = shift; + my $args = ref $_[0] eq 'HASH' ? $_[0] : {@_}; + + if (my $p = delete $args->{profile}) { + my %extra_args; + if ($p eq 'console') { + %extra_args = ( + fill_in_placeholders => 1, + placeholder_surround => ['?/', ''], + indent_string => ' ', + indent_amount => 2, + newline => "\n", + colormap => {}, + indentmap => \%indents, + + ! ( eval { require Term::ANSIColor } ) ? () : do { my $c = \&Term::ANSIColor::color; my $red = [$c->('red') , $c->('reset')]; @@ -252,74 +251,79 @@ my %profiles = ( offset => $green, } ); - } : (), - }, - console_monochrome => { - fill_in_placeholders => 1, - placeholder_surround => ['?/', ''], - indent_string => ' ', - indent_amount => 2, - newline => "\n", - colormap => {}, - indentmap => \%indents, - }, - html => { - fill_in_placeholders => 1, - placeholder_surround => ['', ''], - indent_string => ' ', - indent_amount => 2, - newline => "
\n", - colormap => { - select => ['' , ''], - 'insert into' => ['' , ''], - update => ['' , ''], - 'delete from' => ['' , ''], - - set => ['', ''], - from => ['' , ''], - - where => ['' , ''], - values => ['', ''], - - join => ['' , ''], - 'left join' => ['',''], - on => ['' , ''], - - 'group by' => ['', ''], - having => ['', ''], - 'order by' => ['', ''], - - skip => ['', ''], - first => ['', ''], - limit => ['', ''], - offset => ['', ''], - - 'begin work' => ['', ''], - commit => ['', ''], - rollback => ['', ''], - savepoint => ['', ''], - 'rollback to savepoint' => ['', ''], - 'release savepoint' => ['', ''], - }, - indentmap => \%indents, - }, - none => { - colormap => {}, - indentmap => {}, - }, -); - -sub new { - my $class = shift; - my $args = shift || {}; - - my $profile = delete $args->{profile} || 'none'; + }, + ); + } + elsif ($p eq 'console_monochrome') { + %extra_args = ( + fill_in_placeholders => 1, + placeholder_surround => ['?/', ''], + indent_string => ' ', + indent_amount => 2, + newline => "\n", + indentmap => \%indents, + ); + } + elsif ($p eq 'html') { + %extra_args = ( + fill_in_placeholders => 1, + placeholder_surround => ['', ''], + indent_string => ' ', + indent_amount => 2, + newline => "
\n", + colormap => { map { + (my $class = $_) =~ s/\s+/-/g; + ( $_ => [ qq||, '' ] ) + } ( + keys %indents, + qw(commit rollback savepoint), + 'begin work', 'rollback to savepoint', 'release savepoint', + ) }, + indentmap => \%indents, + ); + } + elsif ($p eq 'none') { + # nada + } + else { + croak "No such profile '$p'"; + } - die "No such profile '$profile'!" unless exists $profiles{$profile}; + # see if we got any duplicates and merge if needed + if (scalar grep { exists $args->{$_} } keys %extra_args) { + # heavy-duty merge + $args = ($merger ||= do { + require Hash::Merge; + my $m = Hash::Merge->new; + + $m->specify_behavior({ + SCALAR => { + SCALAR => sub { $_[1] }, + ARRAY => sub { [ $_[0], @{$_[1]} ] }, + HASH => sub { $_[1] }, + }, + ARRAY => { + SCALAR => sub { $_[1] }, + ARRAY => sub { $_[1] }, + HASH => sub { $_[1] }, + }, + HASH => { + SCALAR => sub { $_[1] }, + ARRAY => sub { [ values %{$_[0]}, @{$_[1]} ] }, + HASH => sub { Hash::Merge::_merge_hashes( $_[0], $_[1] ) }, + }, + }, 'SQLA::Tree Behavior' ); + + $m; + })->merge(\%extra_args, $args ); - my $data = $merger->merge( $profiles{$profile}, $args ); + } + else { + $args = { %extra_args, %$args }; + } + } - bless $data, $class + $args; } sub parse { diff --git a/xt/91podcoverage.t b/xt/91podcoverage.t index a5a463b..427f0cb 100644 --- a/xt/91podcoverage.t +++ b/xt/91podcoverage.t @@ -29,6 +29,7 @@ my $exceptions = { puke/ ] }, + 'SQL::Abstract::Tree' => { ignore => [qw(BUILDARGS)] }, 'SQL::Abstract::Test' => { skip => 1 }, 'DBIx::Class::Storage::Debug::PrettyPrint' => { skip => 1 }, };