Neues Modul FrBr::Books::Util::Locks

diff --git a/lib/FrBr/Books/Util/Locks.pm b/lib/FrBr/Books/Util/Locks.pm
new file mode 100644 (file)
index 0000000..fd942bb
--- /dev/null
+++ b/lib/FrBr/Books/Util/Locks.pm
@@ -0,0 +1,217 @@
+package FrBr::Books::Util::Locks;
+
+# $Id$
+# $URL$
+
+=head1 NAME
+
+FrBr::Books::Util::Locks
+
+=head1 DESCRIPTION
+
+Modul fuer Hilfsroutinen zum Sperren und Entsperren von Tabellen
+
+=cut
+
+#---------------------------------------------------------------------------
+
+use strict;
+use warnings;
+
+use FrBr::Common;
+
+# Export-Deklarationen
+
+BEGIN {
+
+    use Exporter();
+    our ( $VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS );
+
+    # set the version for version checking
+    $VERSION = 0.1;
+    my ($rev) = '$Revision$' =~ /(\d+)/;
+    $VERSION = sprintf( $VERSION . ".%d", $rev );
+
+    @ISA    = qw(Exporter);
+    @EXPORT = qw(
+        &lock_tables
+        &unlock_tables
+    );
+
+    #%EXPORT_TAGS = ( );     # eg: TAG => [ qw!name1 name2! ],
+
+    # your exported package globals go here,
+    # as well as any optionally exported functions
+    #@EXPORT_OK   = qw($Var1 %Hashit &func3);
+} ## end BEGIN
+
+our @EXPORT_OK;
+
+=head1 METHODS
+
+=cut
+
+#-----------------------------------------------------------------------------------
+
+=head2 lock_tables( $c, 'read' => [ 'table_1', 'table_2', 'AS', 'alias_2', ... ], 'write' => [ 'table_3', 'table_4', 'as', 'alias_4', ... ] )
+
+Sperrt Tabellen zum Lesen oder Schreiben.
+
+=cut
+
+sub lock_tables {
+
+    my $c = shift;
+    my $K = ( caller(0) )[3] . "(): ";
+
+    my $storage = $c->stash->{'storage'};    
+
+    $c->log->debug( $K . "aufgerufen." ) if $c->stash->{'debug_level'} > 2;
+
+    my $params = {};
+    if ( ref($_[0]) and ref($_[0]) eq 'HASH' ) {
+        $params = $_[0];
+    }
+    else {
+        %$params = @_;
+    }
+    $c->log->debug(  get_output_string( $K, "Uebergebene Parameter: ", $params ) ) if $c->stash->{'debug_level'} >= 2;
+
+    my $read = undef;
+    my $write = undef;
+
+    $read = $params->{'read'} if $params->{'read'} and ref( $params->{'read'} ) and ref( $params->{'read'} ) eq 'ARRAY';
+    $write = $params->{'write'} if $params->{'write'} and ref( $params->{'write'} ) and ref( $params->{'write'} ) eq 'ARRAY';
+
+    unless ( $read or $write ) {
+        $c->log->debug( $K . "Ungueltige Parameteruebergabe." );
+        return undef;
+    }
+
+    my $sql = 'LOCK TABLES ';
+    my @Tables;
+
+    if ( $read ) {
+        my @A = @$read;
+        my $last_table;
+        while ( @A ) {
+            my $cur = shift @A;
+            if ( lc($cur) eq 'as' ) {
+                unless ( $last_table and @A ) {
+                    $c->log->debug( $K . "Ungueltige Parameteruebergabe." );
+                    return undef;
+                }
+                my $alias = shift @A;
+                push @Tables, "`" . $last_table . "` AS `" . $alias . "` READ";
+                $last_table = undef;
+            }
+            else {
+                if ( $last_table ) {
+                    push @Tables, "`" . $last_table . "` READ";
+                }
+                $last_table = $cur;
+            }
+        }
+        if ( $last_table ) {
+            push @Tables, "`" . $last_table . "` READ";
+        }
+    }
+
+    if ( $write ) {
+        my @A = @$write;
+        my $last_table;
+        while ( @A ) {
+            my $cur = shift @A;
+            if ( lc($cur) eq 'as' ) {
+                unless ( $last_table and @A ) {
+                    $c->log->debug( $K . "Ungueltige Parameteruebergabe." );
+                    return undef;
+                }
+                my $alias = shift @A;
+                push @Tables, "`" . $last_table . "` AS `" . $alias . "` WRITE";
+                $last_table = undef;
+            }
+            else {
+                if ( $last_table ) {
+                    push @Tables, "`" . $last_table . "` WRITE";
+                }
+                $last_table = $cur;
+            }
+        }
+        if ( $last_table ) {
+            push @Tables, "`" . $last_table . "` WRITE";
+        }
+    }
+
+    $sql .= join( ", ", @Tables );
+
+    my $save_func = sub {
+        my ( $storage, $dbh, $sql ) = @_;
+
+        if ( $storage->debug() ) {
+            my $text = $sql . "\n";
+            warn $text;
+        }
+
+        my $sth = $dbh->prepare($sql);
+        $sth->execute();
+    };
+
+    $storage->dbh_do( $save_func, $sql );
+
+    return 1;
+}
+
+#-----------------------------------------------------------------------------------
+
+=head2 unlock_tables( $c )
+
+Entsperrt Tabellen.
+
+=cut
+
+sub unlock_tables {
+
+    my $c = shift;
+    my $K = ( caller(0) )[3] . "(): ";
+
+    my $save_func = sub {
+
+        my ( $storage, $dbh ) = @_;
+
+        my $sql = 'UNLOCK TABLES';
+        if ( $storage->debug() ) {
+            my $text = $sql . "\n";
+            warn $text;
+        }
+
+        my $sth = $dbh->prepare($sql);
+        $sth->execute();
+    };
+
+    my $storage = $c->stash->{'storage'};    
+
+    $storage->dbh_do( $save_func );
+
+    return 1;
+
+}
+
+#-----------------------------------------------------------------------------------
+
+=head1 AUTHOR
+
+Frank Brehm
+
+=head1 LICENSE
+
+This library is free software, you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+1;
+
+__END__
+
+# vim: noai : ts=4 fenc=utf-8 filetype=perl expandtab :