File Coverage

blib/lib/MongoDBx/Tiny/Util.pm
Criterion Covered Total %
statement 57 76 75.0
branch 15 32 46.8
condition 5 12 41.6
subroutine 10 13 76.9
pod 0 6 0.0
total 87 139 62.5


line stmt bran cond sub pod time code
1             package MongoDBx::Tiny::Util;
2 2     2   13 use strict;
  2         3  
  2         113  
3 2     2   10 use warnings;
  2         6  
  2         74  
4              
5             =head1 NAME
6              
7             MongoDBx::Tiny::Util - internal implementation
8              
9             =cut
10              
11 2     2   11 use Carp qw/carp confess/;
  2         4  
  2         120  
12 2     2   12 use Data::Dumper;
  2         4  
  2         85  
13 2     2   11 use Scalar::Util qw(blessed);
  2         5  
  2         869  
14              
15             require Exporter;
16             our @ISA = qw/Exporter/;
17             our @EXPORT = qw/DEBUG
18             util_class_is_ours
19             util_guess_class
20             util_class_attr
21             util_document_class
22             util_to_oid
23             /;
24              
25             # xxx
26 0     0 0 0 sub DEBUG { $ENV{MONGODBX_TINY_DEBUG} }
27              
28             sub util_class_is_ours {
29 3     3 0 5 my $class = shift;
30              
31 3 50       8 return unless $class;
32              
33 3         6 my ($tiny,$doc) = qw(MongoDBx::Tiny MongoDBx::Tiny::Document);
34              
35 3 100       3 return $tiny if eval { $class->isa($tiny) };
  3         30  
36 2 50       3 return $doc if eval { $class->isa($doc) };
  2         11  
37 2         16 return;
38             }
39              
40             sub util_guess_class {
41             #
42             # ($class,$stat) = util_guess_class($proto)
43             #
44 3     3 0 6 my $proto = shift;
45 3   33     23 my $caller = shift || (caller(1))[0];
46              
47 3         3 my $class;
48 3         16 my $stat = {
49             ours => '',
50             object => '',
51             caller => '',
52             };
53 3 50 66     25 if (!ref $proto && ($stat->{ours} = util_class_is_ours($proto))) {
    100 66        
54 0         0 $class = $proto; # via classname class->foo
55             } elsif (blessed $proto && ($stat->{ours} = util_class_is_ours(ref $proto))) {
56 1         3 $class = ref $proto; # via object
57 1         3 $stat->{object} = ref $proto,
58             } else { # direct
59 2         4 $class = $caller;
60 2         3 $stat->{caller} = $caller;
61             }
62 3         16 return ($class,$stat);
63             }
64              
65             sub util_class_attr {
66 3     3 0 7 my ($attr,$proto,@arg) = @_;
67 3 50       11 confess "no " . $attr unless $attr;
68              
69 3         23 my ($class,$stat) = util_guess_class($proto,(caller(1))[0]);
70              
71 3 100       10 if ($stat->{caller}) {
72 2 50       6 unshift @arg, $proto if $proto;
73             }
74              
75 3         10 my $classdata = sprintf "%s::_%s",$class,$attr;
76              
77 3         4 my $val;
78             {
79 2     2   11 no strict 'refs';
  2         4  
  2         154  
  3         3  
80 3         2 $val = ${"$classdata"};
  3         11  
81             }
82              
83 3 100       9 if (@arg) {
84 2 100       4 if (scalar @arg > 1) {
85 1         1 $val = \@arg;
86             } else {
87 1         2 $val = $arg[0];
88             }
89             {
90 2     2   9 no strict 'refs';
  2         10  
  2         850  
  2         3  
91 2         3 ${"$classdata"} = $val;
  2         5  
92             }
93             }
94              
95 3         22 return $val;
96             }
97              
98             sub util_document_class {
99             # guess document class name from (collection name)
100             # $d_class = util_document_class($c_name,ref $self);
101 0 0   0 0   my $c_name = shift or confess q/no collecion name/;
102 0 0         my $base_class = shift or confess q/no base_class/;
103              
104 0           $c_name = ucfirst $c_name;
105 0           $c_name =~ s/_([a-z])/uc($1)/eg;
  0            
106 0           my $class = sprintf "%s::%s",$base_class,$c_name;
107 0           eval "require $class";
108 0 0 0       if ($@ && ! DEBUG) {
109 0           confess "load fail : $class " . $@;
110             }
111 0           return $class;
112             }
113              
114             sub util_to_oid {
115             #
116             # util_to_oid($document,'_id','foo_id','bar_id')
117             #
118 0     0 0   my $document = shift;
119 0           my @oid_fields = @_;
120 0           for (@oid_fields) {
121 0 0         if (exists $document->{$_}) {
122 0 0         if (ref $document->{$_} eq 'MongoDB::OID') {
    0          
123             #
124             } elsif( $document->{$_} =~ /\A[a-fA-F\d]{24}\z/) {
125 0           $document->{$_} = MongoDB::OID->new(value => $document->{$_});
126             }
127             }
128             }
129 0           return $document;
130             }
131              
132             1;
133             __END__
134              
135             =head1 AUTHOR
136              
137             Naoto ISHIKAWA, C<< <toona at seesaa.co.jp> >>
138              
139             =head1 LICENSE AND COPYRIGHT
140              
141             Copyright 2013 Naoto ISHIKAWA.
142              
143             This program is free software; you can redistribute it and/or modify it
144             under the terms of either: the GNU General Public License as published
145             by the Free Software Foundation; or the Artistic License.
146              
147             See http://dev.perl.org/licenses/ for more information.
148              
149              
150             =cut