File Coverage

blib/lib/DBIx/dbMan.pm
Criterion Covered Total %
statement 21 162 12.9
branch 0 52 0.0
condition 0 41 0.0
subroutine 7 14 50.0
pod 0 8 0.0
total 28 277 10.1


line stmt bran cond sub pod time code
1             package DBIx::dbMan;
2              
3             =comment
4              
5             dbMan 0.46
6             (c) Copyright 1999-2018 by Milan Sorm, sorm@is4u.cz
7             All rights reserved.
8              
9             This software provides some functionality in database managing
10             (SQL console).
11              
12             This program is free software; you can redistribute it and/or modify it
13             under the same terms as Perl itself.
14              
15             =cut
16              
17 2     2   1136 use strict;
  2         9  
  2         58  
18 2     2   811 use DBIx::dbMan::Config; # configuration handling package
  2         6  
  2         74  
19 2     2   855 use DBIx::dbMan::Lang; # I18N package - EXPERIMENTAL
  2         5  
  2         69  
20 2     2   948 use DBIx::dbMan::DBI; # dbMan DBI interface package
  2         6  
  2         77  
21 2     2   20 use DBIx::dbMan::MemPool; # dbMan memory management system package
  2         5  
  2         48  
22 2     2   1323 use Data::Dumper;
  2         13701  
  2         4388  
23              
24             our $VERSION = '0.46';
25              
26             # constructor, arguments are hash of style -option => value, stored in internal attributes hash
27             sub new {
28 1     1 0 60 my $class = shift;
29 1         6 my $obj = bless { @_ }, $class;
30 1         4 return $obj;
31             }
32              
33             # main loop of dbMan life-cycle, called from exe file
34             sub start {
35 0     0 0   my $obj = shift; # main dbMan core object
36              
37 0   0       $obj->{ -trace } = $ENV{ DBMAN_TRACE } || 0; # standard extension tracing activity - DISABLED
38              
39             # what interface exe file want ??? making package name from it
40 0           my $interface = $obj->{ -interface };
41 0           $interface = 'DBIx/dbMan/Interface/' . $interface . '.pm';
42              
43             # we try to require interface package - found in @INC, syntax check,
44             # load it by require instead of use because we know only filename
45 0           eval { require $interface; };
  0            
46 0 0         if ( $@ ) { # if something goes wrong
47 0           $interface =~ s/\//::/g;
48 0           $interface =~ s/\.pm$//;
49              
50             # bad information for user :-(
51 0           print STDERR "Can't locate interface module $interface\n";
52 0           return; # see you later...
53             }
54              
55             # making class name from interface package filename
56 0           $interface =~ s/\//::/g;
57 0           $interface =~ s/\.pm$//;
58              
59             # creating memory management object - mempool
60 0           $obj->{ mempool } = new DBIx::dbMan::MemPool;
61              
62             # creating configuration object
63 0           $obj->{ config } = new DBIx::dbMan::Config;
64              
65             # creating I18N specifics object with configuration object as argument
66 0           $obj->{ lang } = new DBIx::dbMan::Lang -config => $obj->{ config };
67              
68             # creating loaded interface object, all objects as arguments
69             # included dbMan core object
70             $obj->{ interface } = $interface->new(
71             -config => $obj->{ config },
72 0           -lang => $obj->{ lang }, -mempool => $obj->{ mempool }, -core => $obj
73             );
74              
75             # we have interface now, we can produce messages and errors by object
76             # method $obj->{interface}->print('what we can say to user...')
77              
78             # dbMan interface, please introduce us to our user (welcome message, splash etc.)
79 0           $obj->{ interface }->hello();
80              
81             # creating dbMan DBI object - encapsulation of DBI with multiple connections
82             # support, configuration, interface and mempool as arguments
83             $obj->{ dbi } = new DBIx::dbMan::DBI -config => $obj->{ config },
84 0           -interface => $obj->{ interface }, -mempool => $obj->{ mempool };
85              
86             # looking for and loading all extensions
87 0           $obj->load_extensions;
88              
89             # we say to the interface that extensions are loaded and menu can be build
90 0           $obj->{ interface }->rebuild_menu();
91              
92             # main loop derived by interface - get_action & handle_action calling cycle
93             # NOT CALLED if we are in $main::TEST mode (tested initialization from make test)
94 0 0 0       $obj->{ interface }->loop() unless defined $main::TEST && $main::TEST;
95              
96             # unloading all loaded extensions
97 0           $obj->unload_extensions;
98              
99             # close all opened DBI connections by dbMan DBI object
100 0           $obj->{ dbi }->close_all();
101              
102             # dbMan interface, please say good bye to our user...
103 0           $obj->{ interface }->goodbye();
104              
105             # test result OK if we are in $main::TEST mode (tested initialization from make test)
106 0 0 0       $main::TEST_RESULT = 1 if defined $main::TEST && $main::TEST;
107              
108             # program must correctly exit if we want 'test ok' for make test' tests
109 0 0         exit if $main::TEST_RESULT;
110             }
111              
112             # looking for and loading extensions
113             sub load_extensions {
114 0     0 0   my $obj = shift; # main dbMan core object
115              
116 0           $obj->{ extensions } = []; # currently loaded extensions = no extensions
117              
118             # 1st phase : candidate searching algorithm
119 0           my %candidates = (); # what are my candidates for extensions ?
120 0           for my $dir ( $obj->extensions_directories ) { # all extensions directories
121 0           opendir D, $dir; # search in directory
122 0           for ( grep /\.pm$/, readdir D ) { # for each found package
123 0           eval { require "$dir/$_"; }; # try to require
  0            
124 0 0         next if $@; # not candidate if fail
125 0           s/\.pm$//; # make class name from filename
126 0           my $candidate = "DBIx::dbMan::Extension::" . $_;
127              
128             # search for extension version limit (class method) - low and high
129 0           my ( $low, $high ) = ( '', '' );
130 0           eval { ( $low, $high ) = $candidate->for_version(); };
  0            
131              
132             # not candidate if our version isn't between low and high
133             # we must delete filename from include list
134 0 0 0       if ( ( $low and $VERSION < $low ) or ( $high and $VERSION > $high ) ) { delete $INC{ "$dir/$_.pm" }; next; }
  0   0        
  0   0        
135              
136             # fetching identification from extension (class method)
137 0           my $id = '';
138 0           eval { $id = $candidate->IDENTIFICATION(); };
  0            
139              
140             # not candidate if identification not specified
141 0 0 0       unless ( $id or $@ ) { delete $INC{ "$dir/$_.pm" }; next; }
  0            
  0            
142              
143             # parsing identification AUTHOR-MODULE-VERSION
144 0           my ( $ident, $ver ) = ( $id =~ /^(.*)-(.*)$/ );
145              
146             # not candidate if AUTHOR-MODULE isn't overloaded
147 0 0         if ( $ident eq '000001-000001' ) { delete $INC{ "$dir/$_.pm" }; next; }
  0            
  0            
148              
149             # deleting filename from include list
150 0           delete $INC{ "$dir/$_.pm" };
151              
152             # not candidate if exist this identification with same or higher version
153 0 0 0       next if exists $candidates{ $ident } && $candidates{ $ident }->{ -ver } >= $ver;
154              
155             # save candidate to candidates list
156 0           $candidates{ $ident } = { -file => "$dir/$_.pm", -candidate => $candidate, -ver => $ver };
157             }
158              
159 0           closedir D; # close searched directory
160             }
161              
162             # 2nd phase : candidate loading algorithm
163 0           my %extensions = (); # all objects of extensions
164              
165 0           $obj->{ extension_iterator } = 0; # randomize iterator
166 0           for my $candidate ( keys %candidates ) { # for each candidate
167 0           my $ext = undef; # undefined extension
168 0           eval { # try require file and create object
169 0           require $candidates{ $candidate }->{ -file };
170              
171             # object pass all five instances of base objects as argument
172             $ext = $candidates{ $candidate }->{ -candidate }->new(
173             -config => $obj->{ config },
174             -interface => $obj->{ interface },
175             -dbi => $obj->{ dbi },
176             -core => $obj,
177             -mempool => $obj->{ mempool }
178 0           );
179              
180 0 0         die unless $ext->load_ok();
181             };
182 0 0 0       if ( defined $ext and not $@ ) { # successful loading ?
183 0           my $preference = 0; # standard preference level
184 0           eval { $preference = $ext->preference(); }; # trying to fetch preference
  0            
185              
186             # sorting criteria are: preference, random iterator
187             # saving sort criteria for later using
188 0           $ext->{ '___sort_criteria___' } = $preference . '_' . $obj->{ extension_iterator };
189              
190             # save instance of object to hash indexed by preference
191 0           $extensions{ $preference . '_' . $obj->{ extension_iterator } } = $ext;
192              
193 0           ++$obj->{ extension_iterator }; # increase random iterator
194             }
195             }
196              
197             # 3rd phase : building candidates list sorted by preference (for action handling)
198 0           for (
199             sort { # sorting criteria - first time by preference, second time loading order
200 0           my ( $fa, $sa, $fb, $sb ) = split /_/, $a . '_' . $b;
201 0 0         ( $fa == $fb ) ? ( $sa <=> $sb ) : ( $fb <=> $fa );
202             } keys %extensions
203             ) { # for all loaded extensions
204              
205             # save extension into sorted list
206 0           push @{ $obj->{ extensions } }, $extensions{ $_ };
  0            
207              
208             # call init() for initializing extension (all extensions in correct order)
209 0           $extensions{ $_ }->init();
210             }
211              
212             # all extensions are loaded and sorted by preference into $obj->{extensions} list
213             }
214              
215             # unloading all extensions
216             sub unload_extensions {
217 0     0 0   my $obj = shift; # main dbMan core object
218              
219 0           for ( @{ $obj->{ extensions } } ) { # for all extensions in standard order
  0            
220 0           $_->done(); # call done() for finalizing extension
221 0           undef $_; # destroy extension instance of object
222             }
223             }
224              
225             # produce list of all extensions directories
226             sub extensions_directories {
227 0     0 0   my $obj = shift; # main dbMan core object
228              
229             # grep criteria - only directories which contains DBIx/dbMan/Extension subfolder are wanted
230             # tested dirs are: @INC, extensions_dir configuration directive, current folder
231             # WARNING: i must call extensions_dir in list context if I want list of directories
232 0 0         return grep { -d $_ } map { my $t = $_; $t =~ s/\/$//; "$t/DBIx/dbMan/Extension" } ( @INC, ( $obj->{ config }->extensions_dir ? ( $obj->{ config }->extensions_dir ) : () ), '.' );
  0            
  0            
  0            
  0            
233             }
234              
235             # show tracing record via interface object
236             sub trace {
237 0     0 0   my ( $obj, $direction, $where, %action ) = @_; # main dbMan core object,
238             # direction string (passed to interface), extension object and action record
239              
240             # change $where to readable form
241 0           $where =~ s/=.*$//;
242 0           $where =~ s/^DBIx::dbMan::Extension:://;
243 0           my $params = '';
244 0           for ( sort keys %action ) { # for all actions
245 0 0         next if $_ eq 'action'; # action tag ignore
246 0           my $p = $action{ $_ };
247 0 0         $p = "'$p'" if $p !~ /^[-a-z0-9_.]+$/i; # stringify
248 0 0         $params .= ", " if $params;
249 0           $params .= "$_: $p"; # concat
250             }
251              
252             # change non-selected chars in $params to style
253             $params = join '', # joining transformed chars
254 0 0 0       map { ( $_ >= 32 && $_ != 255 && $_ != 127 ) ? chr : sprintf "<%02x>", $_; } unpack "C*", $params; # disassemble $params into chars
  0            
255              
256             # sending tracing report via interface object
257 0           $obj->{ interface }->trace( "$direction $where / $action{action} / $params\n" );
258             }
259              
260             # main loop for handling one action
261             sub handle_action {
262 0     0 0   my ( $obj, %action ) = @_; # main dbMan core object, action to process
263              
264 0           $action{ processed } = undef; # save signature of old action for deep recursion test
265 0           my $oldaction = \%action;
266              
267 0           for my $ext ( @{ $obj->{ extensions } } ) { # going down through all extensions in preference order
  0            
268 0           $action{ processed } = 1;
269 0 0         last if $action{ action } eq 'NONE'; # stop on NONE actions
270              
271 0           my $acts = undef;
272 0           eval { $acts = $ext->known_actions; }; # hack - which actions extension want ???
  0            
273             next
274             if $@
275             || ( defined $acts
276             && ref $acts eq 'ARRAY'
277 0 0 0       && ! grep { $_ eq $action{ action } } @$acts ); # use hacked knowledge
  0   0        
      0        
278              
279 0 0         $obj->trace( "<==", $ext, %action ) if $obj->{ -trace }; # trace if user want
280              
281 0           $action{ processed } = undef; # standard behaviour - action not processed
282 0           eval { %action = $ext->handle_action( %action ); }; # handling action
  0            
283 0 0 0       if ( $@ && $@ !~ /^Catched signal INT/ ) { # error - exception
284 0           $obj->{ interface }->error( "Exception catched: $@" );
285 0           $action{ processed } = 1;
286 0           $action{ action } = 'NONE';
287             }
288              
289 0 0         $obj->trace( "==>", $ext, %action ) if $obj->{ -trace }; # trace if user want
290              
291 0 0         last unless $action{ processed }; # action wasn't processed corectly
292             # ... prefix probably set - return to get_event (and called once again we hope)
293             }
294              
295 0           $obj->{ -deep_detected } = 0;
296              
297             # deep recursion detection
298 0 0         unless ( $action{ processed } ) {
299 0           my $newaction = \%action;
300 0 0         if ( $obj->compare_struct( $oldaction, $newaction ) ) {
301 0 0         if ( $obj->{ -deep_detected } >= 100 ) {
302 0           $obj->trace( "Deep recursion detected...\n", '- new:', %action );
303 0           $obj->trace( "", '- old:', %$oldaction );
304 0           $action{ processed } = 1;
305             }
306             else {
307 0           ++$obj->{ -deep_detected };
308             }
309             }
310             }
311              
312             # action processed correctly, good bye with modified action record
313 0           return %action;
314             }
315              
316             # return 1 if structs are identical
317             sub compare_struct {
318 0     0 0   my $obj = shift;
319 0           my ( $a, $b ) = @_;
320              
321 0           my $first = Data::Dumper->Dump( [ $a ] );
322 0           my $second = Data::Dumper->Dump( [ $b ] );
323 0           return $a eq $b;
324              
325 0           return 0;
326             }
327              
328             1; # all is O.K.