"Fossies" - the Fresh Open Source Software Archive

Member "dbMan-0.46/lib/DBIx/dbMan.pm" (10 May 2018, 13934 Bytes) of package /linux/privat/dbMan-0.46.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "dbMan.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 0.45_vs_0.46.

    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 use strict;
   18 use DBIx::dbMan::Config;     # configuration handling package
   19 use DBIx::dbMan::Lang;       # I18N package - EXPERIMENTAL
   20 use DBIx::dbMan::DBI;        # dbMan DBI interface package
   21 use DBIx::dbMan::MemPool;    # dbMan memory management system package
   22 use Data::Dumper;
   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     my $class = shift;
   29     my $obj = bless { @_ }, $class;
   30     return $obj;
   31 }
   32 
   33 # main loop of dbMan life-cycle, called from exe file
   34 sub start {
   35     my $obj = shift;    # main dbMan core object
   36 
   37     $obj->{ -trace } = $ENV{ DBMAN_TRACE } || 0;    # standard extension tracing activity - DISABLED
   38 
   39     # what interface exe file want ??? making package name from it
   40     my $interface = $obj->{ -interface };
   41     $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     eval { require $interface; };
   46     if ( $@ ) {    # if something goes wrong
   47         $interface =~ s/\//::/g;
   48         $interface =~ s/\.pm$//;
   49 
   50         # bad information for user :-(
   51         print STDERR "Can't locate interface module $interface\n";
   52         return;    # see you later...
   53     }
   54 
   55     # making class name from interface package filename
   56     $interface =~ s/\//::/g;
   57     $interface =~ s/\.pm$//;
   58 
   59     # creating memory management object - mempool
   60     $obj->{ mempool } = new DBIx::dbMan::MemPool;
   61 
   62     # creating configuration object
   63     $obj->{ config } = new DBIx::dbMan::Config;
   64 
   65     # creating I18N specifics object with configuration object as argument
   66     $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         -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     $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         -interface => $obj->{ interface }, -mempool => $obj->{ mempool };
   85 
   86     # looking for and loading all extensions
   87     $obj->load_extensions;
   88 
   89     # we say to the interface that extensions are loaded and menu can be build
   90     $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     $obj->{ interface }->loop() unless defined $main::TEST && $main::TEST;
   95 
   96     # unloading all loaded extensions
   97     $obj->unload_extensions;
   98 
   99     # close all opened DBI connections by dbMan DBI object
  100     $obj->{ dbi }->close_all();
  101 
  102     # dbMan interface, please say good bye to our user...
  103     $obj->{ interface }->goodbye();
  104 
  105     # test result OK if we are in $main::TEST mode (tested initialization from make test)
  106     $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     exit if $main::TEST_RESULT;
  110 }
  111 
  112 # looking for and loading extensions
  113 sub load_extensions {
  114     my $obj = shift;    # main dbMan core object
  115 
  116     $obj->{ extensions } = [];    # currently loaded extensions = no extensions
  117 
  118     # 1st phase : candidate searching algorithm
  119     my %candidates = ();          # what are my candidates for extensions ?
  120     for my $dir ( $obj->extensions_directories ) {    # all extensions directories
  121         opendir D, $dir;                              # search in directory
  122         for ( grep /\.pm$/, readdir D ) {             # for each found package
  123             eval { require "$dir/$_"; };              # try to require
  124             next if $@;                               # not candidate if fail
  125             s/\.pm$//;                                # make class name from filename
  126             my $candidate = "DBIx::dbMan::Extension::" . $_;
  127 
  128             # search for extension version limit (class method) - low and high
  129             my ( $low, $high ) = ( '', '' );
  130             eval { ( $low, $high ) = $candidate->for_version(); };
  131 
  132             # not candidate if our version isn't between low and high
  133             # we must delete filename from include list
  134             if ( ( $low and $VERSION < $low ) or ( $high and $VERSION > $high ) ) { delete $INC{ "$dir/$_.pm" }; next; }
  135 
  136             # fetching identification from extension (class method)
  137             my $id = '';
  138             eval { $id = $candidate->IDENTIFICATION(); };
  139 
  140             # not candidate if identification not specified
  141             unless ( $id or $@ ) { delete $INC{ "$dir/$_.pm" }; next; }
  142 
  143             # parsing identification AUTHOR-MODULE-VERSION
  144             my ( $ident, $ver ) = ( $id =~ /^(.*)-(.*)$/ );
  145 
  146             # not candidate if AUTHOR-MODULE isn't overloaded
  147             if ( $ident eq '000001-000001' ) { delete $INC{ "$dir/$_.pm" }; next; }
  148 
  149             # deleting filename from include list
  150             delete $INC{ "$dir/$_.pm" };
  151 
  152             # not candidate if exist this identification with same or higher version
  153             next if exists $candidates{ $ident } && $candidates{ $ident }->{ -ver } >= $ver;
  154 
  155             # save candidate to candidates list
  156             $candidates{ $ident } = { -file => "$dir/$_.pm", -candidate => $candidate, -ver => $ver };
  157         }
  158 
  159         closedir D;    # close searched directory
  160     }
  161 
  162     # 2nd phase : candidate loading algorithm
  163     my %extensions = ();    # all objects of extensions
  164 
  165     $obj->{ extension_iterator } = 0;    # randomize iterator
  166     for my $candidate ( keys %candidates ) {    # for each candidate
  167         my $ext = undef;                        # undefined extension
  168         eval {                                  # try require file and create object
  169             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             );
  179 
  180             die unless $ext->load_ok();
  181         };
  182         if ( defined $ext and not $@ ) {    # successful loading ?
  183             my $preference = 0;             # standard preference level
  184             eval { $preference = $ext->preference(); };    # trying to fetch preference
  185 
  186             # sorting criteria are: preference, random iterator
  187             # saving sort criteria for later using
  188             $ext->{ '___sort_criteria___' } = $preference . '_' . $obj->{ extension_iterator };
  189 
  190             # save instance of object to hash indexed by preference
  191             $extensions{ $preference . '_' . $obj->{ extension_iterator } } = $ext;
  192 
  193             ++$obj->{ extension_iterator };    # increase random iterator
  194         }
  195     }
  196 
  197     # 3rd phase : building candidates list sorted by preference (for action handling)
  198     for (
  199         sort {                                 # sorting criteria - first time by preference, second time loading order
  200             my ( $fa, $sa, $fb, $sb ) = split /_/, $a . '_' . $b;
  201             ( $fa == $fb ) ? ( $sa <=> $sb ) : ( $fb <=> $fa );
  202         } keys %extensions
  203         ) {                                    # for all loaded extensions
  204 
  205         # save extension into sorted list
  206         push @{ $obj->{ extensions } }, $extensions{ $_ };
  207 
  208         # call init() for initializing extension (all extensions in correct order)
  209         $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     my $obj = shift;    # main dbMan core object
  218 
  219     for ( @{ $obj->{ extensions } } ) {    # for all extensions in standard order
  220         $_->done();                        # call done() for finalizing extension
  221         undef $_;                          # destroy extension instance of object
  222     }
  223 }
  224 
  225 # produce list of all extensions directories
  226 sub extensions_directories {
  227     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     return grep { -d $_ } map { my $t = $_; $t =~ s/\/$//; "$t/DBIx/dbMan/Extension" } ( @INC, ( $obj->{ config }->extensions_dir ? ( $obj->{ config }->extensions_dir ) : () ), '.' );
  233 }
  234 
  235 # show tracing record via interface object
  236 sub trace {
  237     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     $where =~ s/=.*$//;
  242     $where =~ s/^DBIx::dbMan::Extension:://;
  243     my $params = '';
  244     for ( sort keys %action ) {                       # for all actions
  245         next if $_ eq 'action';                       # action tag ignore
  246         my $p = $action{ $_ };
  247         $p = "'$p'" if $p !~ /^[-a-z0-9_.]+$/i;       # stringify
  248         $params .= ", " if $params;
  249         $params .= "$_: $p";                          # concat
  250     }
  251 
  252     # change non-selected chars in $params to <hexa> style
  253     $params = join '',                                # joining transformed chars
  254         map { ( $_ >= 32 && $_ != 255 && $_ != 127 ) ? chr : sprintf "<%02x>", $_; } unpack "C*", $params;    # disassemble $params into chars
  255 
  256     # sending tracing report via interface object
  257     $obj->{ interface }->trace( "$direction $where / $action{action} / $params\n" );
  258 }
  259 
  260 # main loop for handling one action
  261 sub handle_action {
  262     my ( $obj, %action ) = @_;                                                                                # main dbMan core object, action to process
  263 
  264     $action{ processed } = undef;                                                                             # save signature of old action for deep recursion test
  265     my $oldaction = \%action;
  266 
  267     for my $ext ( @{ $obj->{ extensions } } ) {                                                               # going down through all extensions in preference order
  268         $action{ processed } = 1;
  269         last if $action{ action } eq 'NONE';                                                                  # stop on NONE actions
  270 
  271         my $acts = undef;
  272         eval { $acts = $ext->known_actions; };                                                                # hack - which actions extension want ???
  273         next
  274             if $@
  275             || ( defined $acts
  276             && ref $acts eq 'ARRAY'
  277             && ! grep { $_ eq $action{ action } } @$acts );                                                   # use hacked knowledge
  278 
  279         $obj->trace( "<==", $ext, %action ) if $obj->{ -trace };                                              # trace if user want
  280 
  281         $action{ processed } = undef;                                                                         # standard behaviour - action not processed
  282         eval { %action = $ext->handle_action( %action ); };                                                   # handling action
  283         if ( $@ && $@ !~ /^Catched signal INT/ ) {                                                                                           # error - exception
  284             $obj->{ interface }->error( "Exception catched: $@" );
  285             $action{ processed } = 1;
  286             $action{ action }    = 'NONE';
  287         }
  288 
  289         $obj->trace( "==>", $ext, %action ) if $obj->{ -trace };                                              # trace if user want
  290 
  291         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     $obj->{ -deep_detected } = 0;
  296 
  297     # deep recursion detection
  298     unless ( $action{ processed } ) {
  299         my $newaction = \%action;
  300         if ( $obj->compare_struct( $oldaction, $newaction ) ) {
  301             if ( $obj->{ -deep_detected } >= 100 ) {
  302                 $obj->trace( "Deep recursion detected...\n", '- new:', %action );
  303                 $obj->trace( "",                             '- old:', %$oldaction );
  304                 $action{ processed } = 1;
  305             }
  306             else {
  307                 ++$obj->{ -deep_detected };
  308             }
  309         }
  310     }
  311 
  312     # action processed correctly, good bye with modified action record
  313     return %action;
  314 }
  315 
  316 # return 1 if structs are identical
  317 sub compare_struct {
  318     my $obj = shift;
  319     my ( $a, $b ) = @_;
  320 
  321     my $first  = Data::Dumper->Dump( [ $a ] );
  322     my $second = Data::Dumper->Dump( [ $b ] );
  323     return $a eq $b;
  324 
  325     return 0;
  326 }
  327 
  328 1;    # all is O.K.