File Coverage

blib/lib/Trinket/DataType.pm
Criterion Covered Total %
statement 42 43 97.6
branch 8 12 66.6
condition n/a
subroutine 13 14 92.8
pod 0 2 0.0
total 63 71 88.7


line stmt bran cond sub pod time code
1             ###########################################################################
2             ### Trinket::DataType
3             ###
4             ### Default object datatype handler
5             ###
6             ### $Id: Object.pm,v 1.3 2001/02/19 20:01:53 deus_x Exp $
7             ###
8             ### TODO:
9             ###
10             ###
11             ###########################################################################
12              
13             package Trinket::DataType;
14              
15             BEGIN {
16 3     3   9 our $VERSION = "0.0";
17 3         147 our @ISA = qw( Exporter );
18             }
19              
20 3     3   17 use strict;
  3         6  
  3         92  
21 3     3   15 use Trinket::Object;
  3         5  
  3         745  
22 3     3   19 use Carp qw(cluck);
  3         5  
  3         441  
23              
24             sub install_methods {
25 3     3   19 no strict 'refs';
  3         11  
  3         98  
26 3     3   15 no warnings;
  3         29  
  3         850  
27            
28 14     14 0 31 my ($pkg, $self, $name) = @_;
29              
30 14 50       40 my $class = ref($self) ? ref($self) : $self;
31            
32 14 100       151 if (!UNIVERSAL::can($class, "get_".$name) ) {
33 12         49 *{$class."::get_".$name} = sub {
34 865     865   6301 return ($pkg)->get($_[0], $name, @_[1..scalar(@_)]);
35 12         56 };
36             }
37 14 100       92 if (!UNIVERSAL::can($class, "set_".$name) ) {
38 13         58 *{$class."::set_".$name} = sub {
39 846     846   4720 return ($pkg)->set($_[0], $name, @_[1..scalar(@_)]);
40 13         43 };
41             }
42             }
43              
44             sub uninstall_methods {
45 3     3   18 no strict 'refs';
  3         6  
  3         80  
46 3     3   14 no warnings;
  3         3  
  3         742  
47              
48 2     2 0 4 my ($pkg, $self, $name) = @_;
49              
50 2 50       7 my $class = ref($self) ? ref($self) : $self;
51              
52 2 50       14 if (UNIVERSAL::can($class, "set_".$name) ) {
53 2         8 *{$class."::set_".$name} = sub {
54 2     2   354 die "No such property '$name' to set for $self";
55 2         10 };
56             }
57 2 50       15 if (UNIVERSAL::can($class, "get_".$name) ) {
58 2         9 *{$class."::get_".$name} = sub {
59 0     0     die "No such property '$name' to get for $self";
60 2         7 };
61             }
62             }
63              
64             1;
65              
66             __END__