diff --git a/Changes b/Changes index a14c501..59908b0 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,9 @@ Revision history for PGObject-Util-DBMethod +1.1.0 + 2015-06-06 + Up to version 1.1.0, rewritten as text generation/compile/install + 1.00.001 2014-02-24 Bumped up required Perl version from 5.6 to 5.8 diff --git a/lib/PGObject/Util/DBMethod.pm b/lib/PGObject/Util/DBMethod.pm index 7c40a7e..d8f566b 100644 --- a/lib/PGObject/Util/DBMethod.pm +++ b/lib/PGObject/Util/DBMethod.pm @@ -12,11 +12,11 @@ the PGObject Framework =head1 VERSION -Version 1.00.001 +Version 1.1.0 =cut -our $VERSION = '1.00.001'; +our $VERSION = '1.1.0'; =head1 SYNOPSIS @@ -63,7 +63,7 @@ Special arguments are: =over -=item arg_lit +=item args It set must point to a hashref. Used to allow mapping of function arguments to arg hash elements. If this is set then funcname, funcschema, etc, cannot be @@ -88,42 +88,74 @@ object. =cut +my %code = ( + intro => ' + sub { + my ($self, @args) = @_; + my %dbargs = @args unless $default_args{arg_list}; + for (keys %default_args ){ + $dbargs{$_} = $default_args{$_} unless defined $dbargs{$_}; + } + for (keys %{$default_args{args}}){ + $dbargs{args}->{$_} = $default_args{args}->{$_} + unless defined $dbargs{args}->{$_}; + }', + args => { + args => '', + arg_list => ' + my @arglist = @args; + my @argnames = @{$default_args{arg_list}}; + $dbargs{args} = { map { ($_, shift @arglist) } + @argnames };', + default => ' + my $dbargs = {@args};', # copy + }, + arg_precedence => { + strict => ' + $dbargs{$_} = $default_args{$_} + for grep {$_ ne "args"} keys %default_args; + $dbargs{args}->{$_} = $default_args{args}->{$_} + for keys %{$default_args{args}};', + default => '', + }, + run => ' + my @results = $self->call_dbmethod(%dbargs);', + returns => { + objects => ' + @results = map { $self->new($_) } @results;', + merged_back => ' + _merge($self, $results[0]); + @results = ($results[0]);', + default => '', + }, + final => ' + return wantarray ? @results : shift @results; + }', +); + sub dbmethod { my $name = shift; - my %defaultargs = @_; + my %default_args = @_; my ($target) = caller; - - my $coderef = sub { - my $self = shift @_; - my %args; - if ($defaultargs{arg_list}){ - %args = ( args => _process_args($defaultargs{arg_list}, @_) ); - } else { - %args = @_; - } - for my $key (keys %{$defaultargs{args}}){ - $args{args}->{$key} = $defaultargs{args}->{$key} - unless $args{args}->{$key} or $defaultargs{strict_args}; - $args{args}->{$key} = $defaultargs{args}->{$key} - if $defaultargs{strict_args}; - } - for my $key(keys %defaultargs){ - next if grep(/^$key$/, qw(strict_args args returns_objects)); - $args{$key} = $defaultargs{$key} if $defaultargs{$key}; - } - my @results = $self->call_dbmethod(%args); - if ($defaultargs{returns_objects}){ - for my $ref(@results){ - $ref = "$target"->new(%$ref); - } - } - if ($defaultargs{merge_back}){ - _merge($self, shift @results); - return $self; - } - return shift @results unless wantarray; - return @results; - }; + my $returns; + my @arg_opts = qw(args arg_list); + my ($args) = grep { $default_args{$_} } @arg_opts; + $args ||= 'default'; + if ($default_args{returns_objects}){ + $returns = 'objects'; + } elsif ($default_args{merge_back}) { + $returns = 'merged_back'; + } else { + $returns = 'default'; + } + my $arg_prec = $default_args{strict_args} ? 'strict' : 'default'; + my $codestr = join '', + $code{intro}, $code{args}->{$args}, + $code{arg_precedence}->{$arg_prec}, $code{run}, + $code{returns}->{$returns}, $code{final}; + warn $codestr if $ENV{PGOBJECT_DEBUG}; + local $@ = undef; + my $coderef = eval $codestr || die $@; no strict 'refs'; *{"${target}::${name}"} = $coderef; } diff --git a/t/01-dbmethod.t b/t/01-dbmethod.t index b161a54..fecd8cb 100644 --- a/t/01-dbmethod.t +++ b/t/01-dbmethod.t @@ -10,7 +10,7 @@ sub call_dbmethod { sub new { my ($self) = shift @_; - my %args = @_; + my %args = ref $_[0]? %{$_[0]} : @_; $self = \%args if %args; $self ||= {}; bless $self; @@ -103,12 +103,15 @@ is($ref->{args}->{foo}, 1, 'no strict arg test, foo arg correctly set'); isa_ok($ref, 'PGOTest', 'Return reference is blessed'); ok $ref = $test->mergetest(args => {id2 => 1}), 'merge test successfully returned'; + is $test->{funcname}, 'foo', 'merge test merged funcname'; is $test->{funcschema}, 'foo2', 'merge test merged funcschema'; is $test->{args}->{id2}, 1, 'Merged args id2'; is $test->{args}->{id}, 1, 'Merged args id from arg'; -ok(($ref) = $test->arglisttest(1), 'Arg List Test returned results.'); +ok(($ref) = $test->arglisttest(2), 'Arg List Test returned results.'); +use Data::Dumper; +diag(Dumper($ref, $test)); is($ref->{funcname}, 'foo', 'no strict arg test, funcname correctly set'); is($ref->{funcschema}, 'foo', 'no strict arg test, funcschema correctly set'); -is($ref->{args}->{id}, 1, 'no strict arg test, id arg correctly set'); +is($ref->{args}->{id}, 2, 'no strict arg test, id arg correctly set');