File Coverage

blib/lib/NoSQL/PL2SQL/Perldata.pm
Criterion Covered Total %
statement 9 67 13.4
branch 0 42 0.0
condition 0 15 0.0
subroutine 3 8 37.5
pod 0 5 0.0
total 12 137 8.7


line stmt bran cond sub pod time code
1             package NoSQL::PL2SQL::Perldata ;
2              
3 2     2   3026 use 5.008009;
  2         6  
  2         89  
4 2     2   10 use strict;
  2         3  
  2         74  
5 2     2   11 use warnings;
  2         3  
  2         2416  
6              
7             require Exporter;
8              
9             our @ISA = qw(Exporter);
10              
11             # Items to export into callers namespace by default. Note: do not export
12             # names by default without a very good reason. Use EXPORT_OK instead.
13             # Do not simply export all your public functions/methods/constants.
14              
15             # This allows declaration use NoSQL::PL2SQL::Perldata ':all';
16             # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
17             # will save memory.
18             our %EXPORT_TAGS = ( 'all' => [ qw() ] ) ;
19              
20             our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ) ;
21              
22             our @EXPORT = qw() ;
23              
24             our $VERSION = '0.03';
25              
26              
27             # Preloaded methods go here.
28              
29             sub refto {
30 0     0 0   my $self = shift ;
31 0           my $key = shift ;
32 0           my $o = $self->{$key} ;
33              
34 0           my $refto = $o->{refto} ;
35 0 0 0       return $refto? refto( $self, $refto ) || $refto: '' ;
36             }
37              
38             sub lastitem {
39 0     0 0   my $self = shift ;
40 0           my $key = shift ;
41 0           my $o = $self->{$key} ;
42 0 0         return [ refto => $key ] unless $o->{refto} ;
43              
44 0           my $ii = $key ;
45 0           for ( my $i = $o->{refto} ; $i ; $i = $self->{ $i }->{item} ) {
46 0           $ii = $i ;
47             }
48              
49 0           return [ item => $ii ] ;
50             }
51              
52             sub descendants {
53 0     0 0   my $self = shift ;
54 0           my $key = shift ;
55 0           my $o = $self->{$key} ;
56              
57 0           my $nosiblings = shift ;
58 0           my @out = () ;
59              
60 0 0 0       push @out, descendants( $self, $o->{item} )
61             if $o->{item} && ! $nosiblings ;
62 0 0 0       push @out, descendants( $self, $o->{refto} )
63             if $o->{refto} && $o->{reftype} ne 'scalarref' ;
64 0           return ( @out, $key ) ;
65             }
66              
67             sub fetchextract {
68 0     0 0   my $sqlobject = shift ;
69 0           my $self = $sqlobject->{perldata} ;
70 0           my $key = shift ;
71 0           my @nvpflag = @_ ;
72 0           my $o = $self->{$key} ;
73 0           my @out = () ;
74 0           my $out ;
75              
76 0 0         @out = fetchextract( $sqlobject, $o->{item}, @nvpflag )
77             if $o->{item} ;
78 0           my @inner = () ;
79              
80 0 0         return @out if $o->{deleted} ;
81 0           my $item = item( $self, $o ) ;
82              
83 0 0         if ( grep $item->[0] eq $_, qw( item scalar ) ) {
    0          
    0          
    0          
84 0           $out = bless { data => $item->[1],
85             top => $key,
86             reftype => 'item' }, $sqlobject->package ;
87 0           map { $out->{$_} = $sqlobject->{$_} }
  0            
88             @NoSQL::PL2SQL::members ;
89 0 0         return @out, ( @nvpflag? $o->{ $nvpflag[0] }: () ), $out ;
90             }
91             elsif ( $item->[0] eq 'hashref' ) {
92 0           tie my( %out ), $sqlobject, $key ;
93 0           $out = \%out ;
94             }
95             elsif ( $item->[0] eq 'arrayref' ) {
96 0           tie my( @out ), $sqlobject, $key ;
97 0           $out = \@out ;
98             }
99             elsif ( $item->[0] eq 'scalarref' ) {
100 0           tie my( $refout ), $sqlobject, $key, $item->[1] ;
101 0           $out = \$refout ;
102             }
103             else {
104             ## Never supposed to hit this
105 0           warn "Unknown: " .$key ;
106             }
107              
108 0 0         bless $out, $o->{blesstype} if $o->{blesstype} ;
109 0 0         return @out, ( @nvpflag? $o->{ $nvpflag[0] }: () ), $out ;
110             }
111              
112             sub item {
113 0     0 0   my $self = shift ;
114 0           my $o = shift ;
115              
116 0 0         $o = $self->{$o} unless ref $o ;
117              
118 0 0         return [ item => undef ] unless $o->{defined} ;
119              
120 0 0         return [ $o->{reftype}, undef ] unless
121             grep $_ eq $o->{reftype},
122             qw( item scalar scalarref string ) ;
123              
124 0           my $rv = [ $o->{reftype} ] ;
125 0 0         $rv->[1] = $o->{intdata} *1 if defined $o->{intdata} ;
126 0 0         $rv->[1] = $o->{floatdata} *1.0 if defined $o->{floatdata} ;
127 0 0         $rv->[1] = $o->{stringdata} if defined $o->{stringdata} ;
128 0 0 0       warn $rv->[1] = $o->{stringrepr} if @$rv == 1 && ! $o->{refto} ;
129              
130 0 0 0       $rv->[1] .= item( $self, $o->{chainedstring} )->[1]
131             if defined $o->{stringdata} && $o->{chainedstring} ;
132 0           return $rv ;
133             }
134              
135             1;
136             __END__