File Coverage

web/cgi-bin/yatt.lib/YATT/Util/VarExporter.pm
Criterion Covered Total %
statement 77 83 92.7
branch 14 24 58.3
condition 11 24 45.8
subroutine 17 18 94.4
pod 0 7 0.0
total 119 156 76.2


line stmt bran cond sub pod time code
1             package YATT::Util::VarExporter;
2 2     2   19646 use strict;
  2         6  
  2         78  
3 2     2   13 use warnings qw(FATAL all NONFATAL misc);
  2         3  
  2         126  
4              
5 2     2   11 use base qw(YATT::Class::Configurable);
  2         4  
  2         224  
6 2     2   12 use YATT::Fields qw(pages);
  2         4  
  2         21  
7              
8 2     2   13 use YATT::Util::Symbol;
  2         5  
  2         2029  
9              
10             sub import {
11 1     1   2 my $pack = shift;
12 1         2 my $callpack = caller;
13 1         5 my $self = $pack->new(@_);
14 1         4 $self->register_into($callpack);
15             # $callpack に cache を作り、かつ、 import を作る
16             }
17              
18             sub new {
19 1     1 0 7 my MY $self = shift->SUPER::new;
20 1         6 while (my ($page, $vars) = splice @_, 0, 2) {
21 1         7 $self->{pages}{$page} = $vars;
22             }
23             $self
24 1         3 }
25              
26             sub register_into {
27 1     1 0 3 (my MY $self, my $pkg) = @_;
28 1         6 MY->add_isa($pkg, MY);
29 1         2 *{globref($pkg, '_CACHE')} = \ $self;
  1         4  
30 1         5 *{globref($pkg, 'find_vars')} = sub {
31 0     0   0 shift->instance->find_vars(@_);
32 1         4 };
33 1         5 *{globref($pkg, 'import')} = sub {
34 1     1   3 my $callpack = caller;
35 1         5 my MY $self = shift->instance;
36 1         5 $self->export_to($callpack, @_);
37 1         5 };
38             }
39              
40             sub instance {
41 2     2 0 5 my ($mypkg) = @_;
42 2         3 ${*{globref($mypkg, '_CACHE')}{SCALAR}};;
  2         4  
  2         7  
43             }
44              
45             sub export_to {
46 1     1 0 3 (my MY $self, my ($destpkg, $page, $failok)) = @_;
47 1 50 33     7 my $vars = $self->find_vars($page ||= $self->page_name)
      33        
48             or $failok or die "No such page: $page";
49              
50 1         4 foreach my $name (keys %$vars) {
51 3         7 my $value = $vars->{$name};
52 3 100 66     30 if ($failok and ref $value and UNIVERSAL::can($value, 'varname')
      66        
      66        
53             and UNIVERSAL::can($value, 'value')) {
54             # For $failok case (== from yatt)
55 1         6 my $glob = globref($destpkg, $value->varname($name));
56 1 50       5 (*$glob) = map {ref $_ ? $_ : \ $_} $value->value;
  1         7  
57             } else {
58 2         7 my $glob = globref($destpkg, $name);
59 2         5 *$glob = do {
60 2 50 33     10 if (not ref $value or ref $value eq 'ARRAY' or ref $value eq 'HASH') {
      33        
61 2         3 \ $value
62             } else {
63 0         0 $value;
64             }
65             };
66             # 関数の場合は、関数だけでなく、スカラ変数にも入れておく。
67 2 50       160 *$glob = \ $value if ref $value eq 'CODE';
68             }
69             }
70             }
71              
72             sub find_vars {
73 2 50   2 0 12 my MY $self = ref $_[0] ? shift : shift->instance();
74 2         4 my ($page, $varname) = @_;
75 2 50       8 my $page_vars = $self->{pages}{$page}
76             or return;
77 2 50       7 unless (defined $varname) {
78 2         11 $page_vars;
79             } else {
80 0         0 $page_vars->{$varname};
81             }
82             }
83              
84             # YATT 固有で良いよね。
85              
86             sub build_scope_for {
87 1     1 0 3 my ($mypkg, $gen, $page) = @_;
88 1         6 my MY $self = $mypkg->instance;
89 1         4 my $vars = $self->find_vars($page);
90 1         2 my %scope;
91 1         5 foreach my $name (keys %$vars) {
92 3         9 my $value = $vars->{$name};
93 3         4 my $type = do {
94 3 100 33     22 unless (ref $value) {
    50          
    50          
    50          
95 2         10 $gen->t_text;
96             } elsif (ref $value eq 'ARRAY') {
97 0         0 $gen->t_list
98             } elsif (ref $value eq 'CODE') {
99 0         0 $gen->t_code
100             } elsif (UNIVERSAL::can($value, 'varname')
101             and UNIVERSAL::can($value, 'value')) {
102 1         5 $gen->t_html;
103             } else {
104 0         0 $gen->t_scalar;
105             }
106             };
107 3         22 $scope{$name} = $type->new(varname => $name);
108             }
109 1         7 \%scope;
110             }
111              
112             sub as_html {
113 1     1 0 4 my ($text) = @_;
114 1         9 bless \ $text, 'YATT::Util::VarExporter::html';
115             }
116              
117             package
118             YATT::Util::VarExporter::html;
119 2     2   13 use overload '""' => 'value';
  2         4  
  2         27  
120 1     1   2 sub varname {shift; 'html_'. shift}
  1         4  
121 1     1   3 sub value {${shift()}}
  1         37  
122              
123             1;