File Coverage

blib/lib/HiPi/Class.pm
Criterion Covered Total %
statement 38 93 40.8
branch 0 12 0.0
condition n/a
subroutine 12 29 41.3
pod 0 13 0.0
total 50 147 34.0


line stmt bran cond sub pod time code
1             ###############################################################################
2             # Distribution : HiPi Modules for Raspberry Pi
3             # File : lib/HiPi/Class.pm
4             # Description : Base HiPi class module
5             # Copyright : Copyright (c) 2013-2018 Mark Dootson
6             # License : This is free software; you can redistribute it and/or modify it under
7             # the same terms as the Perl 5 programming language system itself.
8             #########################################################################################
9              
10             package HiPi::Class;
11              
12             ###############################################################################
13              
14 1     1   370 use strict;
  1         2  
  1         25  
15 1     1   4 use warnings;
  1         1  
  1         23  
16 1     1   6 use parent qw( Exporter );
  1         1  
  1         15  
17 1     1   68 use HiPi;
  1         2  
  1         347  
18              
19             our $VERSION ='0.80';
20              
21             #-------------------------------------------------------------------
22             # On Exit Handling
23             #-------------------------------------------------------------------
24              
25             sub register_exit_method {
26 0     0 0 0 my($self, $method) = @_;
27 0         0 HiPi->register_exit_method($self, $method);
28             }
29              
30             sub unregister_exit_method {
31 0     0 0 0 my ($self) = @_;
32 0         0 HiPi->unregister_exit_method( $self);
33             }
34              
35             sub DESTROY {
36 0     0   0 my $self = shift;
37 0         0 HiPi->call_registered_exit_method( $self );
38             }
39              
40             #-------------------------------------------------------------------
41             # Object Constructor
42             #-------------------------------------------------------------------
43              
44             sub new {
45 0     0 0 0 my ( $class, %params ) = @_;
46 0         0 my $self = bless {'__hipi_instance_data' => {} }, $class;
47 0         0 return $self->init_hipi_object( %params );
48             }
49              
50             #-------------------------------------------------------------------
51             # We can also inherit as a mixin.
52             # Note that internally datanames are always lower case so we
53             # can have accessors styled GetSomeThing and SetSomeThing but
54             # these will point to a data member named 'something'.
55             # We could create all of the accessors below and these would
56             # all point at $obj->{__hipi_instance_data}->{'something'}
57             #
58             # GetSomeThing()
59             # SetSomeThing($val)
60             # get_something()
61             # set_something($val)
62             # something()
63             # something($val)
64             # SomeThing()
65             # SomeThing($val)
66             #-------------------------------------------------------------------
67              
68             sub init_hipi_object {
69 0     0 0 0 my ($self, %params) = @_;
70 0         0 foreach my $key (sort keys( %params ) ) {
71 0         0 my $dataname = lc($key);
72 0         0 $self->{__hipi_instance_data}->{$dataname} = $params{$key};
73             }
74 0         0 return $self;
75             }
76              
77             #-------------------------------------------------------------------
78             # Accessors
79             #-------------------------------------------------------------------
80              
81 39     39 0 369 sub create_accessors { shift->create_dual_accessors( @_ ); }
82              
83             #-----------------------------------
84             # create_get_accessors
85             # get_method()
86             #-----------------------------------
87              
88             sub create_get_accessors {
89 1     1   8 no strict 'refs';
  1         1  
  1         159  
90 0     0 0 0 my $package = shift;
91 0         0 foreach my $method ( @_ ) {
92 0         0 my $lcmethod = lc($method);
93 0 0       0 my $getmethod = ( $lcmethod eq $method ) ? qq(get_${method}) : qq(Get${method});
94 0         0 *{"${package}::${getmethod}"} = sub {
95 0     0   0 return $_[0]->{__hipi_instance_data}->{$lcmethod};
96 0         0 };
97             }
98             }
99              
100             #-----------------------------------
101             # create_set_accessors
102             # set_method($val)
103             #-----------------------------------
104              
105             sub create_set_accessors {
106 1     1   6 no strict 'refs';
  1         2  
  1         178  
107 0     0 0 0 my $package = shift;
108 0         0 foreach my $method ( @_ ) {
109 0         0 my $lcmethod = lc($method);
110 0 0       0 my $setmethod = ( $lcmethod eq $method ) ? qq(set_${method}) : qq(Set${method});
111 0         0 *{"${package}::${setmethod}"} = sub {
112 0     0   0 return $_[0]->{__hipi_instance_data}->{$lcmethod} = $_[1];
113 0         0 };
114             }
115             }
116              
117             #-----------------------------------
118             # create_both_accessors
119             # get_method()
120             # set_method($val)
121             #-----------------------------------
122              
123             sub create_both_accessors {
124 0     0 0 0 my ($package, @args) = @_;
125 0         0 $package->create_get_accessors( @args );
126 0         0 $package->create_set_accessors( @args );
127             }
128              
129             #-----------------------------------
130             # create_dual_accessors
131             # method()
132             # method($val)
133             #-----------------------------------
134              
135             sub create_dual_accessors {
136 1     1   7 no strict 'refs';
  1         1  
  1         134  
137 39     39 0 106 my $package = shift;
138 39         130 foreach my $method ( @_ ) {
139 174         337 my $lcmethod = lc($method);
140 174         750 *{"${package}::${method}"} = sub {
141 0 0   0   0 return $_[0]->{__hipi_instance_data}->{$lcmethod} = $_[1] if @_ == 2;
142 0         0 return $_[0]->{__hipi_instance_data}->{$lcmethod};
143 174         477 };
144             }
145             }
146              
147             #-----------------------------------
148             # create_ro_accessors
149             # method()
150             #-----------------------------------
151              
152             sub create_ro_accessors {
153 1     1   6 no strict 'refs';
  1         2  
  1         101  
154 13     13 0 53 my $package = shift;
155 13         57 foreach my $method ( @_ ) {
156 100         167 my $lcmethod = lc($method);
157 100         443 *{"${package}::${method}"} = sub {
158 0     0     return $_[0]->{__hipi_instance_data}->{$lcmethod};
159 100         257 };
160             }
161             }
162              
163             #-----------------------------------
164             # create_asym_accessors
165             # IsEnabled()
166             # Enable($val)
167             #-----------------------------------
168              
169             sub create_asym_accessors {
170 1     1   7 no strict 'refs';
  1         1  
  1         386  
171 0     0 0   my $package = shift;
172 0           foreach my $method ( @_ ) {
173 0           my $dataname = lc($method->{read});
174 0           my $readmethod = $method->{read};
175 0           *{"${package}::${readmethod}"} = sub {
176 0     0     return $_[0]->{__hipi_instance_data}->{$dataname};
177 0           };
178 0 0         if( my $writemethod = $method->{write} ) {
179 0           *{"${package}::${writemethod}"} = sub {
180 0     0     return $_[0]->{__hipi_instance_data}->{$dataname} = $_[1];
181 0           };
182             }
183             }
184             }
185              
186             #------------------------------------
187             # Some naughty procs to access by val
188             # name as we allow data without
189             # accessors in $obj initialisation.
190             # This removes the temptation to
191             # do $obj->{data}->{$name} and adds
192             # some name checking at least if we
193             # really must do this.
194             #------------------------------------
195              
196             sub get_hipi_object_data {
197 0     0 0   my($self, $valname) = @_;
198 0           my $dataname = lc($valname);
199 0 0         if(exists($self->{__hipi_instance_data}->{$dataname})) {
200 0           return $self->{__hipi_instance_data}->{$dataname};
201             } else {
202 0           die qq(There is no class data member named $valname);
203             }
204             }
205              
206             sub set_hipi_object_data {
207 0     0 0   my($self, $valname, $val) = @_;
208 0           my $dataname = lc($valname);
209 0 0         if(exists($self->{__hipi_instance_data}->{$dataname})) {
210 0           return $self->{__hipi_instance_data}->{$dataname} = $val;
211             } else {
212 0           die qq(There is no class data member named $valname);
213             }
214             }
215              
216             1;
217              
218             __END__