File Coverage

web/cgi-bin/yatt.lib/YATT/Translator/Perl/macro_dbfetch.pm
Criterion Covered Total %
statement 6 51 11.7
branch 0 24 0.0
condition 0 5 0.0
subroutine 2 3 66.6
pod 0 1 0.0
total 8 84 9.5


line stmt bran cond sub pod time code
1             package YATT::Translator::Perl::macro_dbfetch;
2 1     1   11677 use strict;
  1         2  
  1         40  
3 1     1   5 use warnings qw(FATAL all NONFATAL misc);
  1         2  
  1         863  
4             require YATT::Translator::Perl;
5              
6             YATT::Translator::Perl::make_arg_spec
7             (\ my %arg_dict, \ my @arg_order, qw(row sth table schema));
8              
9             sub macro {
10 0     0 0   my ($trans, $scope, $args) = @_;
11 0           my $orig_node = $args->clone;
12             my @hash_spec
13 0           = $trans->feed_arg_or_make_hash_of(text => $scope, $args
14             , \%arg_dict, \@arg_order
15             , my ($rowVarName
16             , $sth, $table, $schema));
17              
18 0 0         unless ($table) {
19 0           die $trans->node_error($orig_node->parent, "table= is missing");
20             }
21              
22 0           my %local;
23 0 0         my $sthVar = $sth ? node_body($sth) : 'sth';
24 0           $local{$sthVar} = $trans->create_var('scalar' => $args
25             , varname => $sthVar);
26 0           my ($loop, $else);
27 0           my $found = my $header = $args->variant_builder;
28 0           for (; $args->readable; $args->next) {
29 0 0         unless ($args->is_attribute) {
30 0           $found->add_node($args->current);
31 0           next;
32             }
33 0 0         if ($args->node_name eq 'row') { # XXX: body でも良いのでは?
    0          
34 0           $loop = $args->open;
35 0           $found = $args->variant_builder;
36             } elsif ($args->node_name eq 'else') {
37 0           $else = $args->open;
38 0           last;
39             } else {
40             }
41             }
42 0           my @columns;
43             my %inner;
44 0 0         if ($loop) {
45 0   0       for (; $loop->readable && $loop->is_primary_attribute; $loop->next) {
46 0           my ($name, $typename) = $trans->arg_name_types($loop);
47 0   0       $inner{$name} = $trans->create_var
48             ($typename || 'text', $loop, varname => $name);
49 0           my $expr = $loop->node_body;
50             # [varName => columnExpr]
51 0 0         push @columns, [$name => defined $expr ? "$expr as $name" : $name];
52             }
53             } else {
54             }
55              
56 0           my ($fetchMode, $rowVarExpr) = do {
57 0 0         if (@columns) {
58 0           (array => '('.join(", ", map {'$'.$_->[0]} @columns).')')
  0            
59             } else {
60 0 0         my $name = $rowVarName ? node_body($rowVarName) : 'row';
61 0           $local{$name} = $trans->create_var('list' => $args
62             , varname => $name);
63 0           (hashref => '$'.$name);
64             }
65             };
66              
67 0           my $loopBody = do {
68 0 0         if ($loop) {
69 0           $trans->as_block
70             ($trans->as_statement_list
71             ($trans->generate_body([\%inner, [\%local, $scope]], $loop)));
72             } else {
73 0           die "NIMPL";
74             }
75             };
76              
77             # XXX: Static check! (But, to check, quoted expression is too much!)
78 0           my $schemaExpr = $trans->default_gentype
79             (DBSchema => text => $scope, $args, $schema);
80              
81 0           my $tableExpr = $trans->faked_gentype
82             (text => $scope, $args, $table);
83              
84             my $prepare = sprintf(q|my $%s = $this->%s->to_fetch(%s, %s, %s)|
85             , $sthVar
86             , $schemaExpr
87             , $tableExpr
88             , (@columns ?
89             ('['.join(", ", map {
90 0           YATT::Translator::Perl::qparen($_->[1])
91             } @columns).']')
92             : 'undef')
93 0 0         , join(", ", map {"$_->[0] => $_->[1]"}
  0            
94             @hash_spec));
95              
96 0           my $if = sprintf(q|if (my %1$s) {%2$s; do %3$s while (%1$s); %4$s}|
97             , sprintf(q|%s = $%s->fetchrow_%s|
98             , $rowVarExpr, $sthVar, $fetchMode)
99             , $trans->as_statement_list
100             ($trans->generate_body([\%local, $scope], $header))
101             , $loopBody
102             , $trans->as_statement_list
103             ($trans->generate_body([\%local, $scope], $found))
104             );
105 0 0         $if .= " else ".$trans->as_block
106             ($trans->as_statement_list
107             ($trans->generate_body([\%local, $scope], $else))) if $else;
108              
109 0           \ "{$prepare; $if}";
110             }
111              
112             1;