From 9027e869281da25df309e63a0ea40bc01749fd96 Mon Sep 17 00:00:00 2001 From: Rene Krenn Date: Wed, 23 Mar 2016 13:33:08 +0100 Subject: [PATCH] MT#18663 row bulk processing framework WIP initial commit .gitignore .percriticrc - doesn't work no critic per file Change-Id: If46efa9a6b008861d3e7a527c47715743fef2579 --- .gitignore | 25 + .perlcriticrc | 57 + Array.pm | 384 ++++++ AttachmentDownloader.pm | 266 ++++ ConnectorPool.pm | 239 ++++ DSSorter.pm | 186 +++ Dao/master/accounting/cdr.pm | 0 Dao/master/billing/contract_balances.pm | 105 ++ Dao/mr28/accounting/cdr.pm | 0 Dao/mr28/billing/contract_balances.pm | 105 ++ Downloaders/IMAPAttachmentDownloader.pm | 183 +++ Globals.pm | 299 +++++ LoadCLIConfig.pm | 32 + LoadConfig.pm | 199 +++ LogError.pm | 592 +++++++++ Logging.pm | 607 +++++++++ Mail.pm | 625 +++++++++ NoSqlConnector.pm | 6 + Projects/t/test_connectors.pl | 235 ++++ Projects/t/test_service.pl | 347 +++++ RandomString.pm | 287 +++++ Serialization.pm | 213 +++ Service.pm | 293 +++++ Service/TestService.pm | 97 ++ ServiceProxy.pm | 507 ++++++++ SqlConnector.pm | 872 +++++++++++++ SqlConnectors/CSVDB.pm | 833 ++++++++++++ SqlConnectors/MySQLDB.pm | 534 ++++++++ SqlConnectors/OracleDB.pm | 532 ++++++++ SqlConnectors/PostgreSQLDB.pm | 536 ++++++++ SqlConnectors/SQLServerDB.pm | 527 ++++++++ SqlConnectors/SQLiteDB.pm | 609 +++++++++ SqlConnectors/SQLiteVarianceAggregate.pm | 67 + SqlRecord.pm | 1504 ++++++++++++++++++++++ Table.pm | 236 ++++ Utils.pm | 787 +++++++++++ 36 files changed, 12926 insertions(+) create mode 100644 .gitignore create mode 100644 .perlcriticrc create mode 100644 Array.pm create mode 100755 AttachmentDownloader.pm create mode 100644 ConnectorPool.pm create mode 100644 DSSorter.pm create mode 100644 Dao/master/accounting/cdr.pm create mode 100644 Dao/master/billing/contract_balances.pm create mode 100644 Dao/mr28/accounting/cdr.pm create mode 100644 Dao/mr28/billing/contract_balances.pm create mode 100755 Downloaders/IMAPAttachmentDownloader.pm create mode 100644 Globals.pm create mode 100644 LoadCLIConfig.pm create mode 100644 LoadConfig.pm create mode 100644 LogError.pm create mode 100644 Logging.pm create mode 100644 Mail.pm create mode 100644 NoSqlConnector.pm create mode 100755 Projects/t/test_connectors.pl create mode 100755 Projects/t/test_service.pl create mode 100644 RandomString.pm create mode 100755 Serialization.pm create mode 100755 Service.pm create mode 100755 Service/TestService.pm create mode 100755 ServiceProxy.pm create mode 100644 SqlConnector.pm create mode 100644 SqlConnectors/CSVDB.pm create mode 100644 SqlConnectors/MySQLDB.pm create mode 100644 SqlConnectors/OracleDB.pm create mode 100644 SqlConnectors/PostgreSQLDB.pm create mode 100644 SqlConnectors/SQLServerDB.pm create mode 100644 SqlConnectors/SQLiteDB.pm create mode 100644 SqlConnectors/SQLiteVarianceAggregate.pm create mode 100644 SqlRecord.pm create mode 100644 Table.pm create mode 100644 Utils.pm diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..b6ee144 --- /dev/null +++ b/.gitignore @@ -0,0 +1,25 @@ +*.log +*.html +*.htm +*.tar +*.gz +*.tar.gz +*.bak +*.csv +*.xls +*.xlsx +*.sql +*.db +*.msg +*.komodoproject +*.kpf +*.MAC +.gitattributes + +#/uml +#/html +#/mails +#/log +#/backup +#/csv +#/db \ No newline at end of file diff --git a/.perlcriticrc b/.perlcriticrc new file mode 100644 index 0000000..a8105aa --- /dev/null +++ b/.perlcriticrc @@ -0,0 +1,57 @@ +verbose = %f line %l col %c\n [%s] %p (%e) = %m\n %r\n + # the ouput format, another nice one is 8, the [%s] is the severity +severity = 3 +theme = security || (pbp && bugs) || cosmetic || sipwise + +[Documentation::RequirePodSections] +add_themes = sipwise +lib_sections = NAME | DESCRIPTION | LICENSE | AUTHOR +# let's keep this simple for now + +[Bangs::ProhibitCommentedOutCode] +commentedcoderegex = \$(?!Id)[A-Za-z_].*=/ +add_themes = sipwise +# should not trigger on the RCS variable + +[Perl::Critic::Policy::Tics::ProhibitLongLines] +add_themes = sipwise +base_max = 100 +hard_max = 160 +pct_allowed = 50 +# terminal width + +[InputOutput::RequireCheckedSyscalls] +add_themes = sipwise +functions = :builtins +exclude_functions = print + +[-Modules::RequireExplicitInclusion] +# we dont want this + +[BuiltinFunctions::ProhibitStringyEval] +allow_includes = 0 +# use Module::Runtime for includes + +[TestingAndDebugging::RequireUseStrict] +equivalent_modules = strictures Sipwise::Base HTML::FormHandler::Moose Mojo::Base + +[TestingAndDebugging::RequireUseWarnings] +equivalent_modules = strictures Sipwise::Base HTML::FormHandler::Moose Mojo::Base + +##### Other exclusions +# not: only relevant with perlcritic 1.117-2 from wheezy, +[-Miscellanea::RequireRcsKeywords] + +[-Subroutines::RequireFinalReturn] +[-CodeLayout::ProhibitHashBarewords] +# meh, it's super annoying +[-Lax::ProhibitStringyEval::ExceptForRequire] +# already covered through BuiltinFunctions::ProhibitStringyEval::allow_includes +[-ControlStructures::ProhibitPostfixControls] +[-ControlStructures::ProhibitUnlessBlocks] +[-RegularExpressions::RequireLineBoundaryMatching] +[-RegularExpressions::RequireDotMatchAnything] +[-ValuesAndExpressions::ProhibitEmptyQuotes] +[-ValuesAndExpressions::ProhibitNoisyQuotes] +[-References::ProhibitDoubleSigils] +[-ValuesAndExpressions::RequireNumberSeparators] diff --git a/Array.pm b/Array.pm new file mode 100644 index 0000000..0ee4583 --- /dev/null +++ b/Array.pm @@ -0,0 +1,384 @@ +package Array; +use strict; + +## no critic + +use Table; + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw( + mergearrays + removeduplicates + itemcount + grouparray + reversearray + contains + arrayeq + mapeq + seteq + setcontains + filter + getroundrobinitem + getrandomitem + array_to_map); + +sub mergearrays { + + my ($array_ptr1,$array_ptr2) = @_; + my @result = (); + if (defined $array_ptr1 and ref $array_ptr1 eq 'ARRAY') { + foreach my $element (@$array_ptr1) { + push @result,$element; + } + } + if (defined $array_ptr2 and ref $array_ptr2 eq 'ARRAY') { + foreach my $element (@$array_ptr2) { + push @result,$element; + } + } + return \@result; + +} + +sub removeduplicates { + + my ($array_ptr,$case_insensitive) = @_; + my @result = (); + if (defined $array_ptr and ref $array_ptr eq 'ARRAY') { + + foreach my $element (@$array_ptr) { + if (not contains($element,\@result,$case_insensitive)) { + push @result,$element; + } + } + } + return \@result; + +} + +sub itemcount { + + my ($item,$array_ptr,$case_insensitive) = @_; + my $itemcount = 0; + if (defined $array_ptr and ref $array_ptr eq 'ARRAY') { + if ($case_insensitive) { + foreach my $element (@$array_ptr) { + if (lc($element) eq lc($item)) { + $itemcount += 1; + } + } + } else { + foreach my $element (@$array_ptr) { + if ($element eq $item) { + $itemcount += 1; + } + } + } + } + return $itemcount; + +} + +sub grouparray { + + my ($array_ptr,$case_insensitive) = @_; + my $result = new Table(); + my $reducedarray = removeduplicates($array_ptr,$case_insensitive); + my $sort_occurencecount_desc; + if ($case_insensitive) { + $sort_occurencecount_desc = sub { + + return ((lc($Table::b->[1]) <=> lc($Table::a->[1])) or (lc($Table::a->[0]) cmp lc($Table::b->[0]))); + + }; + } else { + $sort_occurencecount_desc = sub { + + return (($Table::b->[1] <=> $Table::a->[1]) or ($Table::a->[0] cmp $Table::b->[0])); + + }; + } + foreach my $element (@$reducedarray) { + $result->addrow_ref([$element,itemcount($element,$array_ptr,$case_insensitive)]); + } + $result->sortrows($sort_occurencecount_desc); + return $result; + +} + +sub reversearray { + + my ($array_ptr) = @_; + my @result = (); + if (defined $array_ptr and ref $array_ptr eq 'ARRAY') { + my $ubound = (scalar @$array_ptr) - 1; + for (my $i = $ubound; $i >= 0; $i -= 1) { + $result[$i] = $array_ptr->[$ubound - $i]; + } + } + return \@result; + +} + +sub contains { + + my ($item,$array_ptr,$case_insensitive) = @_; + my $result = 0; + if (defined $array_ptr and ref $array_ptr eq 'ARRAY') { + if ($case_insensitive) { + foreach my $element (@$array_ptr) { + if (lc($element) eq lc($item)) { + $result = 1; + last; + } + } + } else { + foreach my $element (@$array_ptr) { + if ($element eq $item) { + $result = 1; + last; + } + } + } + } + return $result; + +} + +sub arrayeq { + + my ($array_ptr1,$array_ptr2,$case_insensitive) = @_; + my $ubound1; + my $ubound2; + if (defined $array_ptr1 and ref $array_ptr1 eq 'ARRAY') { + $ubound1 = (scalar @$array_ptr1) - 1; + } else { + $ubound1 = -1; + } + if (defined $array_ptr2 and ref $array_ptr2 eq 'ARRAY') { + $ubound2 = (scalar @$array_ptr2) - 1; + } else { + $ubound2 = -1; + } + my $result = 1; + if ($ubound1 != $ubound2) { + return 0; + } else { + if ($case_insensitive) { + for (my $i = 0; $i <= $ubound1; $i += 1) { + if (lc($array_ptr1->[$i]) ne lc($array_ptr2->[$i])) { + return 0; + } + } + } else { + for (my $i = 0; $i <= $ubound1; $i += 1) { + if ($array_ptr1->[$i] ne $array_ptr2->[$i]) { + return 0; + } + } + } + } + + return 1; + +} + +sub seteq { + + my ($array_ptr1,$array_ptr2,$case_insensitive) = @_; + my $ubound1; + my $ubound2; + if (defined $array_ptr1 and ref $array_ptr1 eq 'ARRAY') { + $ubound1 = (scalar @$array_ptr1) - 1; + } else { + $ubound1 = -1; + } + if (defined $array_ptr2 and ref $array_ptr2 eq 'ARRAY') { + $ubound2 = (scalar @$array_ptr2) - 1; + } else { + $ubound2 = -1; + } + # every element of array1 must be existent in array2 ... + for (my $i = 0; $i <= $ubound1; $i += 1) { + if (not contains($array_ptr1->[$i],$array_ptr2,$case_insensitive)) { + return 0; + } + } + # ... and every element of array2 must be existent in array1 + for (my $i = 0; $i <= $ubound2; $i += 1) { + if (not contains($array_ptr2->[$i],$array_ptr1,$case_insensitive)) { + return 0; + } + } + + return 1; + +} + +sub setcontains { + + my ($array_ptr1,$array_ptr2,$case_insensitive) = @_; + my $ubound1; + if (defined $array_ptr1 and ref $array_ptr1 eq 'ARRAY') { + $ubound1 = (scalar @$array_ptr1) - 1; + } else { + $ubound1 = -1; + } + # every element of array1 must be existent in array2: + for (my $i = 0; $i <= $ubound1; $i += 1) { + if (not contains($array_ptr1->[$i],$array_ptr2,$case_insensitive)) { + return 0; + } + } + + return 1; + +} + +sub filter { + + my ($array_ptr1,$array_ptr2,$case_insensitive) = @_; + my $ubound1; + my $ubound2; + if (defined $array_ptr1 and ref $array_ptr1 eq 'ARRAY') { + $ubound1 = (scalar @$array_ptr1) - 1; + } else { + return []; + } + if (defined $array_ptr2 and ref $array_ptr2 eq 'ARRAY') { + $ubound2 = (scalar @$array_ptr2) - 1; + } else { + return $array_ptr1; + } + my @result = (); + # every element of array1 must be existent in array2 ... + for (my $i = 0; $i <= $ubound1; $i += 1) { + if (contains($array_ptr1->[$i],$array_ptr2,$case_insensitive)) { + push @result,$array_ptr1->[$i]; + } + } + + return \@result; + +} + +sub getroundrobinitem { + + my ($array_ptr,$recentindex) = @_; + if (defined $array_ptr and ref $array_ptr eq 'ARRAY') { + my $size = (scalar @$array_ptr); + if ($size == 1) { + return (@{$array_ptr}[0],0); + } elsif ($size > 1) { + if (not defined $recentindex or $recentindex < 0) { + $recentindex = -1; + } + my $newindex = ($recentindex + 1) % $size; + return (@{$array_ptr}[$newindex],$newindex); + } + } + return (undef,undef); + +} + +sub getrandomitem { + + my ($array_ptr) = @_; + if (defined $array_ptr and ref $array_ptr eq 'ARRAY') { + my $size = (scalar @$array_ptr); + if ($size == 1) { + return (@{$array_ptr}[0],0); + } elsif ($size > 1) { + my $newindex = int(rand($size)); + return (@{$array_ptr}[$newindex],$newindex); + } + } + return (undef,undef); + +} + +sub array_to_map { + + my ($array_ptr,$get_key_code,$get_value_code,$mode) = @_; + my $map = {}; + my @keys = (); + my @values = (); + if (defined $array_ptr and ref $array_ptr eq 'ARRAY') { + if (defined $get_key_code and ref $get_key_code eq 'CODE') { + if (not (defined $get_value_code and ref $get_value_code eq 'CODE')) { + $get_value_code = sub { return shift; }; + } + $mode = lc($mode); + if (not ($mode eq 'group' or $mode eq 'first' or $mode eq 'last')) { + $mode = 'group'; + } + foreach my $item (@$array_ptr) { + my $key = &$get_key_code($item); + if (defined $key) { + my $value = &$get_value_code($item); + if (defined $value) { + if (not exists $map->{$key}) { + if ($mode eq 'group') { + $map->{$key} = [ $value ]; + } else { + $map->{$key} = $value; + } + push(@keys,$key); + } else { + if ($mode eq 'group') { + push(@{$map->{$key}}, $value); + } elsif ($mode eq 'last') { + $map->{$key} = $value; + } + } + push(@values,$value); + } + } + } + } + } + return ($map,\@keys,\@values); + +} + +sub mapeq { + my ($map_prt1,$map_prt2,$case_insensitive) = @_; + my $key_count1; + my $key_count2; + if (defined $map_prt1 and ref $map_prt1 eq 'HASH') { + $key_count1 = (scalar keys %$map_prt1); + } else { + $key_count1 = 0; + } + if (defined $map_prt2 and ref $map_prt2 eq 'HASH') { + $key_count2 = (scalar keys %$map_prt2); + } else { + $key_count2 = 0; + } + if ($key_count1 != $key_count2) { + return 0; #print "they don't have the same number of keys\n"; + } else { + my %cmp = map { $_ => 1 } keys %$map_prt1; + if ($case_insensitive) { + for my $key (keys %$map_prt2) { + last unless exists $cmp{$key}; + last unless $map_prt1->{$key} eq $map_prt2->{$key}; + delete $cmp{$key}; + } + } else { + for my $key (keys %$map_prt2) { + last unless exists $cmp{$key}; + last unless lc($map_prt1->{$key}) eq lc($map_prt2->{$key}); + delete $cmp{$key}; + } + } + if (%cmp) { + return 0; #print "they don't have the same keys or values\n"; + } else { + return 1; #print "they have the same keys or values\n"; + } + } +} + +1; \ No newline at end of file diff --git a/AttachmentDownloader.pm b/AttachmentDownloader.pm new file mode 100755 index 0000000..a20f5e3 --- /dev/null +++ b/AttachmentDownloader.pm @@ -0,0 +1,266 @@ +# retrieve files from emails + +## no critic + +package AttachmentDownloader; +use strict; + +use Logging qw( + getlogger + attachmentdownloaderdebug + attachmentdownloaderinfo +); +use LogError qw( + fileerror + attachmentdownloadererror + attachmentdownloaderwarn +); + +use Email::MIME; +use Email::MIME::Attachment::Stripper; +use URI::Find; +#use File::Fetch; +#use LWP::Simple; +use LWP::UserAgent; +use HTTP::Request; +#use HTTP::Cookies; + +use Utils qw(kbytes2gigs changemod); + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw( + $attachment_no_match + $attachment_match + $attachment_found +); + +our $attachment_no_match = 0; +our $attachment_match = 1; +our $attachment_found = 2; + +my $logger = getlogger(__PACKAGE__); + +sub new { + + my ($class,$derived_class,@params) = @_; + my $self = bless {}, $derived_class; + $self->{download_urls} = 0; + $self->setup(@params); + return $self; + +} + +sub setup { + + my $self = shift; + my (@params) = @_; + notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger); + +} + +sub logout { + + my $self = shift; + my (@params) = @_; + notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger); + +} + +sub download { + + my $self = shift; + my ($filedir) = @_; + notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger); + +} + +sub _process_message { + + my $self = shift; + my ($subject,$message_string,$filedir,$files_saved) = @_; + + + #if (length($message_string)) { + + attachmentdownloaderinfo('processing message "' . $subject . '"',$logger); + + my $parsed = Email::MIME->new($message_string); + + my $found = ($self->{download_urls} ? $self->_process_bodies($parsed,$subject,$filedir,$files_saved) : 0); + $found = $self->_process_attachments($parsed,$subject,$filedir,$files_saved) if !$found; + + + + + #} + + return $found; + + +} + +sub _process_attachments { + my ($self,$parsed,$subject,$filedir,$files_saved) = @_; + + my $found = 0; + + my $stripper = Email::MIME::Attachment::Stripper->new($parsed, (force_filename => 1)); + + my @attachments = $stripper->attachments(); + + foreach my $attachment (@attachments) { + $attachment->{subject} = $subject; + $attachment->{size} = length($attachment->{payload}); + $attachment->{match} = undef; + if (defined $self->{checkfilenamecode} and ref $self->{checkfilenamecode} eq 'CODE') { + my $match = &{$self->{checkfilenamecode}}($attachment); + if ($match == $attachment_no_match) { + attachmentdownloaderinfo('attachment ' . $attachment->{filename} . ' (' . kbytes2gigs(int($attachment->{size} / 1024), undef, 1) . ' ' . $attachment->{content_type} . ') skipped',$logger); + next; + } elsif ($match == $attachment_found) { + attachmentdownloaderinfo('attachment ' . $attachment->{filename} . ' (' . kbytes2gigs(int($attachment->{size} / 1024), undef, 1) . ' ' . $attachment->{content_type} . ') found',$logger); + $found = 1; + } elsif ($match == $attachment_match) { + attachmentdownloaderinfo('attachment ' . $attachment->{filename} . ' (' . kbytes2gigs(int($attachment->{size} / 1024), undef, 1) . ' ' . $attachment->{content_type} . ') matched',$logger); + } else { + attachmentdownloaderwarn('attachment ' . $attachment->{filename} . ' (' . kbytes2gigs(int($attachment->{size} / 1024), undef, 1) . ' ' . $attachment->{content_type} . ') - unknown match, skipped',$logger); + next; + } + } + + _save_file($attachment,$filedir,$files_saved); + + + } + return $found; +} + +sub _save_file { + + my ($attachment,$filedir,$files_saved) = @_; + my $filepath = $filedir . $attachment->{filename}; + + unlink $filepath; + + local *ATTACHMENTFILE; + if (not open (ATTACHMENTFILE,'>' . $filepath)) { + fileerror('cannot open file ' . $filepath . ': ' . $!,$logger); + return; # $files_saved; + } + binmode(ATTACHMENTFILE); + print ATTACHMENTFILE $attachment->{payload}; + + close(ATTACHMENTFILE); + changemod($filepath); + + push(@$files_saved,{ saved => $filepath, match => $attachment->{match} }); + + attachmentdownloaderinfo('attachment saved: ' . $filepath,$logger); +} + +sub _process_bodies { + + my ($self,$parsed,$subject,$filedir,$files_saved) = @_; + + my $found = 0; + + $parsed->walk_parts(sub { + my ($part) = @_; + return if $found; + if ((scalar $part->subparts) > 0) { + foreach my $subpart ($part->subparts) { + if (!$found) { + $found = $self->_process_body($subpart,$subject,$found,$filedir,$files_saved); + } else { + last; + } + } + } else { + $found = $self->_process_body($part,$subject,$found,$filedir,$files_saved); + } + }); + + return $found; +} + +sub _process_body { + my ($self,$part,$subject,$found,$filedir,$files_saved) = @_; + + if ($part->content_type =~ m/text\//i) { + my %uris; + my $finder = URI::Find->new(sub { + my ($uri,$orig_uri) = @_; + my $url = $uri->as_string; + if ($url =~ /^http/i) { + $uris{$url} = undef; + } + }); + my $body = $part->body; + $finder->find(\$body); + if ((scalar keys %uris) > 0) { + foreach my $uri (sort keys %uris) { + my $attachment = _download_file($uri); + if ($attachment) { + $attachment->{subject} = $subject; + $attachment->{size} = length($attachment->{payload}); + $attachment->{match} = undef; + + if (defined $self->{checkfilenamecode} and ref $self->{checkfilenamecode} eq 'CODE') { + my $match = &{$self->{checkfilenamecode}}($attachment); + if ($match == $attachment_no_match) { + attachmentdownloaderinfo('attachment ' . $attachment->{filename} . ' (' . kbytes2gigs(int($attachment->{size} / 1024), undef, 1) . ' ' . $attachment->{content_type} . ') skipped',$logger); + next; + } elsif ($match == $attachment_found) { + attachmentdownloaderinfo('attachment ' . $attachment->{filename} . ' (' . kbytes2gigs(int($attachment->{size} / 1024), undef, 1) . ' ' . $attachment->{content_type} . ') found',$logger); + $found = 1; + } elsif ($match == $attachment_match) { + attachmentdownloaderinfo('attachment ' . $attachment->{filename} . ' (' . kbytes2gigs(int($attachment->{size} / 1024), undef, 1) . ' ' . $attachment->{content_type} . ') matched',$logger); + } else { + attachmentdownloaderwarn('attachment ' . $attachment->{filename} . ' (' . kbytes2gigs(int($attachment->{size} / 1024), undef, 1) . ' ' . $attachment->{content_type} . ') - unknown match, skipped',$logger); + next; + } + } + + _save_file($attachment,$filedir,$files_saved); + } + } + } else { + attachmentdownloaderinfo("no urls for download found in part '" . $part->content_type . "'",$logger); + } + } + + return $found; +} + +sub _download_file { # .. dropbox links and the like + my ($uri) = @_; + my $ua = LWP::UserAgent->new; + $ua->timeout(10); + $ua->ssl_opts( + verify_hostname => 0, + ); + $ua->cookie_jar({}); + my $request = HTTP::Request->new('GET', $uri); + attachmentdownloaderinfo('downloading ' . $uri,$logger); + my $response = $ua->request($request); + if ($response->code == 200) { + my $attachment = {}; + $attachment->{uri} = $uri; + $attachment->{payload} = $response->decoded_content( charset => 'none' ); + #$attachment->{size} = $response->header('content-length'); # -s $attachment->{payload}; + ($attachment->{filename}) = ($response->header('Content-Disposition') =~ m/"([^"]+)"/); + return $attachment; + } else { + attachmentdownloaderwarn('downloading ' . $uri . ' failed',$logger); + } + return undef; +} + +sub DESTROY { + + my $self = shift; + $self->logout(); +} + +1; \ No newline at end of file diff --git a/ConnectorPool.pm b/ConnectorPool.pm new file mode 100644 index 0000000..824f69f --- /dev/null +++ b/ConnectorPool.pm @@ -0,0 +1,239 @@ +package ConnectorPool; +use strict; + +## no critic + +use Globals qw( + $system_abbreviation + $system_instance + + $accounting_databasename + $accounting_username + $accounting_password + $accounting_host + $accounting_port + + $billing_databasename + $billing_username + $billing_password + $billing_host + $billing_port + +); + + +use Logging qw(getlogger); +use LogError qw(dbclustererror dbclusterwarn); #nodumpdbset + +use SqlConnectors::MySQLDB; +#use SqlConnectors::OracleDB; +#use SqlConnectors::PostgreSQLDB; +#use SqlConnectors::SQLiteDB qw($staticdbfilemode +# cleanupdbfiles); +#use SqlConnectors::CSVDB; +#use SqlConnectors::SQLServerDB; + +use SqlRecord qw(cleartableinfo); + +use Utils qw(threadid); + +use Array qw( + filter + mergearrays + getroundrobinitem + getrandomitem +); + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw( + get_accounting_db + accounting_db_tableidentifier + + get_billing_db + billing_db_tableidentifier + + destroy_dbs +); + +my $connectorinstancenameseparator = '_'; + +my $logger = getlogger(__PACKAGE__); + +# thread connector pools: +my $sql_dbs = {}; + +sub register_sql_db { + my ($class,$name) = @_; + my $registered = 0; + if (!exists $sql_connectors->{$class}) { + $sql_connectors->{$class} = {}; + } + if (!exists $sql_connectors->{$class}->{$name}) { + $sql_connectors->{$class}->{$name} = {}; + $registered = 1; + } + return $registered; +} + +sub get_sql_db { + my ($instance_name,$reconnect) = @_; +} + +my $accounting_dbs = {}; +my $billing_dbs = {}; + + +sub get_accounting_db { + + my ($instance_name,$reconnect) = @_; + my $name = _get_connectorinstancename($instance_name); #threadid(); #shift; + if (not defined $accounting_dbs->{$name}) { + $accounting_dbs->{$name} = SqlConnectors::MySQLDB->new($instance_name); #$name); + if (not defined $reconnect) { + $reconnect = 1; + } + } + if ($reconnect) { + $accounting_dbs->{$name}->db_connect($accounting_databasename,$accounting_username,$accounting_password,$accounting_host,$accounting_port); + } + return $accounting_dbs->{$name}; + +} + +sub accounting_db_tableidentifier { + + my ($get_target_db,$tablename) = @_; + my $target_db = (ref $get_target_db eq 'CODE') ? &$get_target_db() : $get_target_db; + return $target_db->getsafetablename(SqlConnectors::MySQLDB::get_tableidentifier($tablename,$accounting_databasename)); + +} + + +sub get_billing_db { + + my ($instance_name,$reconnect) = @_; + my $name = _get_connectorinstancename($instance_name); #threadid(); #shift; + if (not defined $billing_dbs->{$name}) { + $billing_dbs->{$name} = SqlConnectors::MySQLDB->new($instance_name); #$name); + if (not defined $reconnect) { + $reconnect = 1; + } + } + if ($reconnect) { + $billing_dbs->{$name}->db_connect($billing_databasename,$billing_username,$billing_password,$billing_host,$billing_port); + } + return $billing_dbs->{$name}; + +} + +sub billing_db_tableidentifier { + + my ($get_target_db,$tablename) = @_; + my $target_db = (ref $get_target_db eq 'CODE') ? &$get_target_db() : $get_target_db; + return $target_db->getsafetablename(SqlConnectors::MySQLDB::get_tableidentifier($tablename,$billing_databasename)); + +} + + +sub _get_connectorinstancename { + my ($name) = @_; + my $instance_name = threadid(); + if (length($name) > 0) { + $instance_name .= $connectorinstancenameseparator . $name; + } + return $instance_name; +} + +sub destroy_dbs { + + my $name; + + + foreach $name (keys %$accounting_dbs) { + cleartableinfo($accounting_dbs->{$name}); + undef $accounting_dbs->{$name}; + delete $accounting_dbs->{$name}; + } + + foreach $name (keys %$billing_dbs) { + cleartableinfo($billing_dbs->{$name}); + undef $billing_dbs->{$name}; + delete $billing_dbs->{$name}; + } + +} + + +sub _get_cluster_db { # oracle RAC and the like ... + + my ($cluster,$instance_name,$reconnect) = @_; + #if ((defined $cluster) and ref $cluster ne 'HASH') { + my $node = undef; + my $tid = threadid(); + if ((not defined $cluster->{scheduling_vars}) or ref $cluster->{scheduling_vars} ne 'HASH') { + $cluster->{scheduling_vars} = {}; + } + my $scheduling_vars = $cluster->{scheduling_vars}; + if ((not defined $scheduling_vars->{$tid}) or ref $scheduling_vars->{$tid} ne 'HASH') { + $scheduling_vars->{$tid} = {}; + } + $scheduling_vars = $scheduling_vars->{$tid}; + my $nodes; + if (not defined $scheduling_vars->{nodes}) { + $nodes = {}; + foreach my $node (@{$cluster->{nodes}}) { + if (defined $node and ref $node eq 'HASH') { + if ($node->{active}) { + $nodes->{$node->{label}} = $node; + } + } else { + dbclustererror($cluster->{name},'node configuration error',$logger); + } + } + $scheduling_vars->{nodes} = $nodes; + } else { + $nodes = $scheduling_vars->{nodes}; + } + my @active_nodes = @{$nodes}{sort keys(%$nodes)}; #hash slice + if (defined $cluster->{scheduling_code} and ref $cluster->{scheduling_code} eq 'CODE') { + my $cluster_instance_name; + if (length($instance_name) > 0) { + $cluster_instance_name = $cluster->{name} . $connectorinstancenameseparator . $instance_name; + } else { + $cluster_instance_name = $cluster->{name}; + } + ($node,$scheduling_vars->{node_index}) = &{$cluster->{scheduling_code}}(\@active_nodes,$scheduling_vars->{node_index}); + if (defined $node) { + my $get_db = $node->{get_db}; + if (defined $get_db and ref $get_db eq 'CODE') { + my $db = undef; + eval { + $db = &{$get_db}($cluster_instance_name,$reconnect,$cluster); + }; + if ($@) { + dbclusterwarn($cluster->{name},'node ' . $node->{label} . ' inactive',$logger); + delete $nodes->{$node->{label}}; + return _get_cluster_db($cluster,$instance_name,$reconnect); + } else { + #$db->cluster($cluster); + return $db; + } + } else { + dbclustererror($cluster->{name},'node ' . $node->{label} . ' configuration error',$logger); + delete $nodes->{$node->{label}}; + return _get_cluster_db($cluster,$instance_name,$reconnect); + } + } + } else { + dbclustererror($cluster->{name},'scheduling configuration error',$logger); + return undef; + } + + #} + dbclustererror($cluster->{name},'cannot switch to next active node',$logger); + return undef; + +} + +1; \ No newline at end of file diff --git a/DSSorter.pm b/DSSorter.pm new file mode 100644 index 0000000..dfa6b9f --- /dev/null +++ b/DSSorter.pm @@ -0,0 +1,186 @@ +package DSSorter; +use strict; + +## no critic + +# guarantee stability, regardless of algorithm +use sort 'stable'; + +use Logging qw(getlogger); +use LogError qw(sortconfigerror); + +use Table; + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(sort_by_config_ids + sort_by_configs); + +my $logger = getlogger(__PACKAGE__); + +sub new { + + my $class = shift; + my $self = {}; + $self->{sortconfig} = Table->new(); + bless($self,$class); + return $self; + +} + +sub add_sorting { + + my $self = shift; + my ($sorting_id,$numeric,$dir,$memberchain) = @_; + + if (defined $memberchain and ref $memberchain eq 'ARRAY') { + my @fieldnames = @$memberchain; + if ((scalar @fieldnames) > 0) { + $self->{sortconfig}->addrow_nodupe($numeric,$dir,@fieldnames); + } + } else { + sortconfigerror($sorting_id,'chain of object members undefined/invalid',$logger); + } + +} + +sub clear_sorting { + + my $self = shift; + $self->{sortconfig}->clear(); + +} + +sub sort_array { + + my $self = shift; + my $array_ptr = shift; + + my $sortconfig = $self->{sortconfig}; + + my $sorter = sub ($$) { + + my $a = shift; + my $b = shift; + + my $result = 0; + + for (my $i = 0; $i < $sortconfig->rowcount(); $i++) { + + my $j = 2; + my $membername = $sortconfig->element($i,$j); + my $item_a = ($a ? $a->{$membername} : undef); + my $item_b = ($b ? $b->{$membername} : undef); + $j++; + $membername = $sortconfig->element($i,$j); + while (defined $membername) { + + $item_a = ($item_a ? $item_a->{$membername} : undef); + $item_b = ($item_b ? $item_b->{$membername} : undef); + $j++; + $membername = $sortconfig->element($i,$j); + + } + + $result = ($result or + + ( + + $sortconfig->element($i,0) ? + ($item_a <=> $item_b) : ($item_a cmp $item_b) + + ) * $sortconfig->element($i,1) + + ); + + } + + return $result; + + }; + my @sorted = (); + + if (defined $array_ptr and ref $array_ptr eq 'ARRAY') { + @sorted = sort $sorter @$array_ptr; + } + + return \@sorted; + +} + +sub sort_by_config_ids { + + my ($array_ptr,$sortings,$sortingconfigurations) = @_; + if (defined $array_ptr and ref $array_ptr eq 'ARRAY') { + if (defined $sortings and ref $sortings eq 'ARRAY') { + if (defined $sortingconfigurations and + ref $sortingconfigurations eq 'HASH') { + my @sorting_ids = @$sortings; + if ((scalar @sorting_ids) > 0) { + my $sorter = DSSorter->new(); + foreach my $sorting_id (@sorting_ids) { + my $sc = $sortingconfigurations->{$sorting_id}; + if (defined $sc and ref $sc eq 'HASH') { + $sorter->add_sorting($sorting_id, + $sc->{numeric}, + $sc->{dir}, + $sc->{memberchain}); + } else { + sortconfigerror($sorting_id, + 'missing/invalid sorting configuration', + $logger); + } + } + return $sorter->sort_array($array_ptr); + } + } else { + sortconfigerror(undef, + 'missing/invalid sorting configurations', + $logger); + } + } + return $array_ptr; + } else { + return []; + } + +} + +sub sort_by_configs { + + my ($array_ptr,$sortingconfigurations) = @_; + if (defined $array_ptr and ref $array_ptr eq 'ARRAY') { + + if (defined $sortingconfigurations and + ref $sortingconfigurations eq 'ARRAY') { + + my @scs = @$sortingconfigurations; + if ((scalar @scs) > 0) { + my $sorter = DSSorter->new(); + my $sorting_id = -1; + foreach my $sc (@scs) { + #my $sc = $sortingconfigurations->{$sorting_id}; + if (defined $sc and ref $sc eq 'HASH') { + $sorter->add_sorting($sorting_id, + $sc->{numeric}, + $sc->{dir}, + $sc->{memberchain}); + } else { + sortconfigerror($sorting_id, + 'invalid sorting configuration', + $logger); + } + $sorting_id -= 1; + } + return $sorter->sort_array($array_ptr); + } + + } + return $array_ptr; + } else { + return []; + } + +} + +1; \ No newline at end of file diff --git a/Dao/master/accounting/cdr.pm b/Dao/master/accounting/cdr.pm new file mode 100644 index 0000000..e69de29 diff --git a/Dao/master/billing/contract_balances.pm b/Dao/master/billing/contract_balances.pm new file mode 100644 index 0000000..60bb285 --- /dev/null +++ b/Dao/master/billing/contract_balances.pm @@ -0,0 +1,105 @@ + +package billing::contract_balances; +use strict; + +## no critic + +use File::Basename; +use Cwd; +use lib Cwd::abs_path(File::Basename::dirname(__FILE__) . '/../'); + +use Logging qw(getlogger); + +use ConnectorPool qw(get_billing_db + billing_db_tableidentifier); + +use SqlRecord qw(checktableinfo); + +require Exporter; +our @ISA = qw(Exporter SqlRecord); +our @EXPORT_OK = qw( +XX +backoffice_client_byboclientid + sync_table + drop_table + + check_local_table + check_source_table); + +my $logger = getlogger(__PACKAGE__); + +my $tablename = 'contract_balances'; +my $get_db = \&get_billing_db; +my $get_tablename = \&billing_db_tableidentifier; + +my $expected_fieldnames = [ + 'id', + 'contract_id', + 'cash_balance', + 'cash_balance_interval', + 'free_time_balance', + 'free_time_balance_interval', + 'topup_count', + 'timely_topup_count', + 'start', + 'end', + 'invoice_id', + 'underrun_profiles', + 'underrun_lock', +]; + +sub new { + + my $class = shift; + my $self = SqlRecord->new($get_db, + gettablename(), + $expected_fieldnames); + + bless($self,$class); + + copy_row($self,shift,$expected_fieldnames); + + return $self; + +} + + +sub buildrecords_fromrows { + + my ($rows,$load_recursive) = @_; + + my @records = (); + my $record; + + if (defined $rows and ref $rows eq 'ARRAY') { + foreach my $row (@$rows) { + $record = __PACKAGE__->new($row); + + # transformations go here ... + + push @records,$record; + } + } + + return \@records; + +} + +sub gettablename { + + my $db = &$get_local_db(); + return &$get_tablename($db,$tablename); + +} + +sub check_table { + + my $db = &$get_local_db(); + + return checktableinfo($get_db, + gettablename(), + $expected_fieldnames); + +} + +1; \ No newline at end of file diff --git a/Dao/mr28/accounting/cdr.pm b/Dao/mr28/accounting/cdr.pm new file mode 100644 index 0000000..e69de29 diff --git a/Dao/mr28/billing/contract_balances.pm b/Dao/mr28/billing/contract_balances.pm new file mode 100644 index 0000000..eab64d8 --- /dev/null +++ b/Dao/mr28/billing/contract_balances.pm @@ -0,0 +1,105 @@ + +package mr28::billing::contract_balances; +use strict; + +## no critic + +use File::Basename; +use Cwd; +use lib Cwd::abs_path(File::Basename::dirname(__FILE__) . '/../'); + +use Logging qw(getlogger); + +use ConnectorPool qw(get_billing_db + billing_db_tableidentifier); + +use SqlRecord qw(checktableinfo); + +require Exporter; +our @ISA = qw(Exporter SqlRecord); +our @EXPORT_OK = qw( +XX +backoffice_client_byboclientid + sync_table + drop_table + + check_local_table + check_source_table); + +my $logger = getlogger(__PACKAGE__); + +my $tablename = 'contract_balances'; +my $get_db = \&get_billing_db; +my $get_tablename = \&billing_db_tableidentifier; + +my $expected_fieldnames = [ + 'id', + 'contract_id', + 'cash_balance', + 'cash_balance_interval', + 'free_time_balance', + 'free_time_balance_interval', + 'topup_count', + 'timely_topup_count', + 'start', + 'end', + 'invoice_id', + 'underrun_profiles', + 'underrun_lock', +]; + +sub new { + + my $class = shift; + my $self = SqlRecord->new($get_db, + gettablename(), + $expected_fieldnames); + + bless($self,$class); + + copy_row($self,shift,$expected_fieldnames); + + return $self; + +} + + +sub buildrecords_fromrows { + + my ($rows,$load_recursive) = @_; + + my @records = (); + my $record; + + if (defined $rows and ref $rows eq 'ARRAY') { + foreach my $row (@$rows) { + $record = __PACKAGE__->new($row); + + # transformations go here ... + + push @records,$record; + } + } + + return \@records; + +} + +sub gettablename { + + my $db = &$get_local_db(); + return &$get_tablename($db,$tablename); + +} + +sub check_table { + + my $db = &$get_local_db(); + + return checktableinfo($get_db, + gettablename(), + $expected_fieldnames); + +} + +1; \ No newline at end of file diff --git a/Downloaders/IMAPAttachmentDownloader.pm b/Downloaders/IMAPAttachmentDownloader.pm new file mode 100755 index 0000000..7ffc498 --- /dev/null +++ b/Downloaders/IMAPAttachmentDownloader.pm @@ -0,0 +1,183 @@ +package Downloaders::IMAPAttachmentDownloader; +use strict; + +## no critic + +use File::Basename; +use Cwd; +use lib Cwd::abs_path(File::Basename::dirname(__FILE__) . '/../'); + +use Logging qw( + getlogger + attachmentdownloaderdebug + attachmentdownloaderinfo +); +use LogError qw( + fileerror + attachmentdownloadererror + attachmentdownloaderwarn +); + +use Utils qw(kbytes2gigs changemod); + +use IO::Socket::SSL; +use Mail::IMAPClient; +use MIME::Base64; +#use GSSAPI; +#use Authen::SASL::Perl; +#use Authen::SASL::Perl::GSSAPI; +#use Authen::SASL qw(Perl); + +require Exporter; +our @ISA = qw(Exporter AttachmentDownloader); +our @EXPORT_OK = qw(); + +my $logger = getlogger(__PACKAGE__); + +sub new { + + my $class = shift; + my ($server,$ssl,$user,$pass,$foldername,$checkfilenamecode,$download_urls) = @_; + my $self = AttachmentDownloader->new($class,$server,$ssl,$user,$pass,$foldername,$checkfilenamecode,$download_urls); + attachmentdownloaderdebug('IMAP attachment downloader object created',$logger); + return $self; + +} + +sub logout { + my $self = shift; + if (defined $self->{imap}) { + if ($self->{imap}->logout()) { + attachmentdownloaderinfo('IMAP logout successful',$logger); + } else { + attachmentdownloaderwarn($@,$logger); + } + $self->{imap} = undef; + } +} + +sub setup { + + my $self = shift; + my ($server,$ssl,$user,$pass,$foldername,$checkfilenamecode,$download_urls) = @_; #,$mimetypes) = @_; + + $self->logout(); + + attachmentdownloaderdebug('IMAP attachment downloader setup - ' . $server . ($ssl ? ' (SSL)' : ''),$logger); + + $self->{server} = $server; + $self->{ssl} = $ssl; + $self->{foldername} = $foldername; + #$self->{mimetypes} = $mimetypes; + $self->{checkfilenamecode} = $checkfilenamecode; + #$self->{imap} = undef; + $self->{download_urls} = $download_urls; + + #* OK The Microsoft Exchange IMAP4 service is ready. + #a1 capability + #* CAPABILITY IMAP4 IMAP4rev1 AUTH=NTLM AUTH=GSSAPI AUTH=PLAIN STARTTLS UIDPLUS CHILDREN IDLE NAMESPACE LITERAL+ + + my %opts = ( + User => $user, + Password => $pass, + Uid => 1, + Peek => 1, # don't set \Seen flag) + Debug => 0, + IgnoreSizeErrors => 1, + Authmechanism => 'LOGIN', + #Authmechanism => 'NTLM', #'DIGEST-MD5', # DIGEST-MD5 'LOGIN', #CRAM-MD5 NTLM + ); + + if ($ssl) { + $opts{Socket} = IO::Socket::SSL->new( + Proto => 'tcp', + PeerAddr => $server, + PeerPort => 993, + ) or attachmentdownloadererror($@,$logger); + } else { + $opts{Server} = $server; + } + + my $imap = Mail::IMAPClient->new(%opts) or attachmentdownloadererror($@,$logger); + + #eval { + #my ($gss_api_step, $sasl, $conn, $cred) = (0, undef, undef, GSSAPI::Cred); + #$imap->authenticate('GSSAPI', sub { + # $gss_api_step++; + # if ($gss_api_step == 1) { + # $sasl = Authen::SASL->new( + # mechanism => 'GSSAPI', + # debug => 1, + # callback => { pass => $pass, + # user => $user, + # } + # ); + # $conn = $sasl->client_new('imap', $server); + # my $mesg = $conn->client_start() or attachmentdownloadererror($@,$logger); + # print "mesg $gss_api_step: " . $mesg; + # return encode_base64($mesg, ''); + # } else { + # my $mesg = $conn->client_step(decode_base64($_[0])); + # print "mesg $gss_api_step: " . $mesg; + # return encode_base64($mesg, ''); + # } + # }); + #}; + if ($@) { + attachmentdownloadererror($@,$logger); + } else { + attachmentdownloaderinfo('IMAP login successful',$logger); + } + + $imap->select($foldername) or attachmentdownloadererror('cannot select ' . $foldername . ': ' . $imap->LastError,$logger); #'folder ' . $foldername . ' not found: ' + attachmentdownloaderdebug('folder ' . $foldername . ' selected',$logger); + + $self->{imap} = $imap; + +} + +sub download { + + my $self = shift; + my $filedir = shift; + + my @files_saved = (); + my $message_count = 0; + + if (defined $self->{imap}) { + + attachmentdownloaderinfo('searching messages from folder ' . $self->{foldername},$logger); + + my $found = 0; + + my $message_ids = $self->{imap}->search('ALL'); + if (defined $message_ids and ref $message_ids eq 'ARRAY') { + foreach my $id (@$message_ids) { + attachmentdownloadererror('invalid message id ' . $id,$logger) unless $id =~ /\A\d+\z/; + my $message_string = $self->{imap}->message_string($id) or attachmentdownloadererror($@,$logger); + + $found |= $self->_process_message($self->{imap}->subject($id),$message_string,$filedir,\@files_saved); + $message_count++; + + if ($found) { + last; + } + } + } else { + if ($@) { + attachmentdownloadererror($@,$logger); + } + } + + if (scalar @files_saved == 0) { + attachmentdownloaderwarn('IMAP download complete - ' . $message_count . ' messages found, but no matching attachments saved',$logger); + } else { + attachmentdownloaderinfo('IMAP attachment download complete - ' . scalar @files_saved . ' files saved',$logger); + } + } + + return \@files_saved; + +} + +1; \ No newline at end of file diff --git a/Globals.pm b/Globals.pm new file mode 100644 index 0000000..52b0138 --- /dev/null +++ b/Globals.pm @@ -0,0 +1,299 @@ +package Globals; +use strict; + +## no critic + +use 5.8.8; + +use threads; # as early as possible... +use threads::shared; + +use Time::HiRes qw(time); + +use Tie::IxHash; + +use Cwd 'abs_path'; +use File::Basename qw(dirname); + +use Utils qw( + get_ipaddress + get_hostfqdn + get_cpucount + $chmod_umask); + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw( + $system_name + $system_version + $system_abbreviation + $system_instance + $system_instance_label + $local_ip + $local_fqdn + $application_path + $appstartsecs + $enablemultithreading + $root_threadid + $cpucount + + $cells_transfer_memory_limit + $LongReadLen_limit + $defer_indexes + + $accounting_databasename + $accounting_username + $accounting_password + $accounting_host + $accounting_port + + $billing_databasename + $billing_username + $billing_password + $billing_host + $billing_port + + $csv_path + + + $local_db_path + $emailenable + $erroremailrecipient + $warnemailrecipient + $completionemailrecipient + $successemailrecipient + $mailfilepath + + $ismsexchangeserver + $sender_address + $smtp_server + $smtpuser + $smtppasswd + $writefiles + $tpath + + $logfile_path + $fileloglevel + $screenloglevel + $emailloglevel +$mailprog +$mailtype + + + $defaultconfig + + update_mainconfig + log_mainconfig + + + $chmod_umask + + @jobservers + $jobnamespace + + + + ); + + +#set process umask for open and mkdir calls: +umask oct($chmod_umask); + +# general constants +our $system_name = 'Sipwise Bulk Processor Framework'; +our $system_version = '0.0.1'; #keep this filename-save +our $system_abbreviation = 'bpf'; #keep this filename-, dbname-save +our $system_instance = 'initial'; #'test'; #'2014'; #dbname-save 0-9a-z_ +our $system_instance_label = 'test'; + +our $local_ip = get_ipaddress(); +our $local_fqdn = get_hostfqdn(); +our $application_path = get_applicationpath(); +#my $remotefilesystem = "MSWin32"; +our $system_username = 'system'; + + +our $enablemultithreading; +if ($^O eq 'MSWin32') { + $enablemultithreading = 1; # tested ok with windows. +} else { + $enablemultithreading = 1; # oel 5.4 perl 5.8.8 obvoisly not ok. +} + +our $cpucount = get_cpucount(); + +our $root_threadid = 0; #threadid() . ''; #0 +our $cells_transfer_memory_limit = 10000000; #db fields +our $defer_indexes = 1; +#http://docstore.mik.ua/orelly/linux/dbi/ch06_01.htm +our $LongReadLen_limit = 128*1024; #longest LOB field size in bytes + +our $appstartsecs = Time::HiRes::time(); + + + + +our $accounting_databasename = 'accounting'; +our $accounting_username = 'root'; +our $accounting_password = ''; +our $accounting_host = '127.0.0.1'; +our $accounting_port = '3306'; + +our $billing_databasename = 'accounting'; +our $billing_username = 'root'; +our $billing_password = ''; +our $billing_host = '127.0.0.1'; +our $billing_port = '3306'; + + +# csv +our $csv_path = $application_path . 'csv/'; +#mkdir $csv_path; + +# logging +our $logfile_path = $application_path . 'log/'; +#mkdir $logfile_path; + +our $fileloglevel = 'OFF'; #'DEBUG'; +our $screenloglevel = 'OFF'; #'DEBUG'; + +our $emailloglevel = 'OFF'; #'INFO'; + + + + + + +# local db setup +our $local_db_path = $application_path . 'db/'; +#mkdir $local_db_path; + + + + + +# email setup +#set emailenable and writefiles to 0 during development with IDE that perform +#on-the-fly compilation during typing +our $emailenable = 0; # globally enable email sending +our $mailfilepath = $application_path . 'mails/'; # emails can be saved (logged) as message files to this folder +#mkdir $mailfilepath; +our $writefiles = 0; # save emails + +our $erroremailrecipient = ''; #'rkrenn@sipwise.com'; +our $warnemailrecipient = ''; #'rkrenn@sipwise.com'; +our $completionemailrecipient = ''; +our $successemailrecipient = ''; + +our $mailprog = "/usr/sbin/sendmail"; # linux only +our $mailtype = 1; #0 .. mailprog, 1 .. socket, 2 .. Net::SMTP + + +our $ismsexchangeserver = 0; # smtp server is a ms exchange server +our $smtp_server = '10.146.1.17'; # smtp sever ip/hostname +our $smtpuser = 'WORKGROUP\rkrenn'; +our $smtppasswd = 'xyz'; +our $sender_address = 'donotreply@sipwise.com'; + + + +#service layer: +our @jobservers = ('127.0.0.1:4730'); +#our $jobnamespace = $system_abbreviation . '-' . $system_version . '-' . $local_fqdn . '-' . $system_instance; +our $jobnamespace = $system_abbreviation . '-' . $system_version . '-' . $system_instance; + + + +# test directory +our $tpath = $application_path . 't/'; +#mkdir $tpath; + + + +our $defaultconfig = 'default.cfg'; + + +sub update_mainconfig { + + my ($config,$configfile, + $split_tuplecode, + $parse_floatcode, + $configurationwarncode, + $configurationerrorcode, + $configlogger) = @_; + + if (defined $config) { + + + # databases - dsp + $accounting_host = $config->{accounting_host} if exists $config->{accounting_host}; + $accounting_port = $config->{accounting_port} if exists $config->{accounting_port}; + $accounting_databasename = $config->{accounting_databasename} if exists $config->{accounting_databasename}; + $accounting_username = $config->{accounting_username} if exists $config->{accounting_username}; + $accounting_password = $config->{accounting_password} if exists $config->{accounting_password}; + + $billing_host = $config->{billing_host} if exists $config->{billing_host}; + $billing_port = $config->{billing_port} if exists $config->{billing_port}; + $billing_databasename = $config->{billing_databasename} if exists $config->{billing_databasename}; + $billing_username = $config->{billing_username} if exists $config->{billing_username}; + $billing_password = $config->{billing_password} if exists $config->{billing_password}; + + + $enablemultithreading = $config->{enablemultithreading} if exists $config->{enablemultithreading}; + $cells_transfer_memory_limit = $config->{cells_transfer_memory_limit} if exists $config->{cells_transfer_memory_limit}; + $defer_indexes = $config->{defer_indexes} if exists $config->{defer_indexes}; + + + if (defined $split_tuplecode and ref $split_tuplecode eq 'CODE') { + @jobservers = &$split_tuplecode($config->{jobservers}) if exists $config->{jobservers}; + } else { + @jobservers = ($config->{jobservers}) if exists $config->{jobservers}; + } + + if (defined $parse_floatcode and ref $parse_floatcode eq 'CODE') { + + } + + + $emailenable = $config->{emailenable} if exists $config->{emailenable}; + $erroremailrecipient = $config->{erroremailrecipient} if exists $config->{erroremailrecipient}; + $warnemailrecipient = $config->{warnemailrecipient} if exists $config->{warnemailrecipient}; + $completionemailrecipient = $config->{completionemailrecipient} if exists $config->{completionemailrecipient}; + $successemailrecipient = $config->{successemailrecipient} if exists $config->{successemailrecipient}; + + $ismsexchangeserver = $config->{ismsexchangeserver} if exists $config->{ismsexchangeserver}; + $smtp_server = $config->{smtp_server} if exists $config->{smtp_server}; + $smtpuser = $config->{smtpuser} if exists $config->{smtpuser}; + $smtppasswd = $config->{smtppasswd} if exists $config->{smtppasswd}; + + $fileloglevel = $config->{fileloglevel} if exists $config->{fileloglevel}; + $screenloglevel = $config->{screenloglevel} if exists $config->{screenloglevel}; + $emailloglevel = $config->{emailloglevel} if exists $config->{emailloglevel}; + + return 1; + + } + return 0; + +} + +sub log_mainconfig { + + my ($logconfigcode,$configlogger) = @_; + if (defined $logconfigcode and ref $logconfigcode eq 'CODE') { + &$logconfigcode($system_name . ' ' . $system_version . ' (' . $system_instance_label . ') [' . $local_fqdn . ']',$configlogger); + &$logconfigcode('application path ' . $application_path,$configlogger); + &$logconfigcode($cpucount . ' cpu(s), multithreading ' . ($enablemultithreading ? 'enabled' : 'disabled'),$configlogger); + } + +} + + +sub get_applicationpath { + + return dirname(abs_path(__FILE__)) . '/'; + +} + +1; + diff --git a/LoadCLIConfig.pm b/LoadCLIConfig.pm new file mode 100644 index 0000000..2ca1e48 --- /dev/null +++ b/LoadCLIConfig.pm @@ -0,0 +1,32 @@ +package LoadCLIConfig; +use strict; + +## no critic + +use Getopt::Long; +use Globals qw($defaultconfig); +use LoadConfig qw(load_config); + +my $configfile; +my $arg = shift @ARGV; +if (defined $arg) { + $configfile = $arg; +} else { + $configfile = $defaultconfig; +} + +my $configfile = $defaultconfig; + + + GetOptions ("host=s" => \$host, + "port=i" => \$port, + "file=s" => \$output_filename, + "dir=s" => \$output_dir, + "user=s" => \$user, + "pass=s" => \$pass, + "period=s" => \$period, + 'verbose+' => \$verbose) or fatal("Error in command line arguments"); + +load_config($configfile); + +1; \ No newline at end of file diff --git a/LoadConfig.pm b/LoadConfig.pm new file mode 100644 index 0000000..9af7b26 --- /dev/null +++ b/LoadConfig.pm @@ -0,0 +1,199 @@ +package LoadConfig; +use strict; + +## no critic + +use Globals qw( + $application_path + update_mainconfig + log_mainconfig +); + +use Logging qw( + getlogger + mainconfigurationloaded + configinfo + init_log4perl +); + +use LogError qw( + fileerror + yamlerror + configurationwarn + configurationerror + parameterdefinedtwice +); + +use YAML::Tiny; +use Utils qw(format_number); + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw( + $loadedmainconfigfile + load_config +); + +our $loadedmainconfigfile; + +my $tuplesplitpattern = join('|',(quotemeta(','), + quotemeta(';'), + quotemeta('/') + ) + ); + +my $logger = getlogger(__PACKAGE__); + +sub load_config { + + my ($configfile,$process_code,$configtype) = @_; + + my $data; + if (defined $configfile) { + if (-e $configfile) { + $data = _parse_config($file,$configtype); + } else { + $configfile = $application_path . $configfile; + if (-e $configfile) { + $data = _parse_config($configfile,$configtype); + } else { + fileerror('cannot find config file ' . $configfile,$logger); + } + } + } else { + configurationerror('no config file specified',$logger); + } + + if ('CODE' eq ref $process_code) { + my $result = @$process_code($data); + configinfo('configuration file ' . $configfile . ' loaded',$logger); + return $result; + } else { + if (update_mainconfig($data,$configfile, + \&split_tuple, + \&format_number, + \&configurationwarn, + \&configurationerror, + $logger)) { + $loadedmainconfigfile = $configfile; + mainconfigurationloaded($configfile,$logger); + return 1; + } + log_mainconfig(\&configinfo,$logger); + return 0; + } + +} + +sub _parse_config { + my ($file,$configtype) = @_; + my $data; + if (defined $configtype) { + if ($configtype == 1) { + $data = _parse_yaml_config($file); + } else { + $data = _parse_simple_config($file); + } + } else { + $data = _parse_simple_config($file); + } + return $data; +} + +sub split_tuple { + + my $token = shift; + return split(/$tuplesplitpattern/,$token); + +} + +#sub parse_float { +# +# my ($value) = @_; +# my $output = $value; +# if (index($output,",") > -1) { +# $output =~ s/,/\./g; +# } +# $output = sprintf("%f",$output); +# #$output =~ s/0+$//g; +# #$output =~ s/\.$//g; +# #if ($output =~ /\..+/) { +# # $output =~ s/0+$//g; +# # $output =~ s/\.$//g; +# #} +# if (index($output,".") > -1) { +# $output =~ s/0+$//g; +# $output =~ s/\.$//g; +# } +# return $output; +# +#} + +sub _parse_simple_config { + + my $file = shift; + + my $config = {}; + local *CF; + + if (not open (CF, '<' . $file)) { + fileerror('parse simple config - cannot open file ' . $file . ': ' . $!,$logger); + return $config; + } + + read(CF, my $data, -s $file); + close(CF); + + my @lines = split(/\015\012|\012|\015/,$data); + my $count = 0; + + foreach my $line(@lines) { + $count++; + + next if($line =~ /^\s*#/); + next if($line !~ /^\s*\S+\s*=.*$/); + + #my $cindex = index($line,'#'); + #if ($cindex >= 0) { + # $line = substr($line,0,$cindex); + #} + + my ($key,$value) = split(/=/,$line,2); + + # Remove whitespaces at the beginning and at the end + + $key =~ s/^\s+//g; + $key =~ s/\s+$//g; + $value =~ s/^\s+//g; + $value =~ s/\s+$//g; + + if (exists $config->{$key}) { + parameterdefinedtwice('parse simple config - parameter ' . $key . ' defined twice in line ' . $count . ' of configuration file ' . $file,$logger); + } + + $config->{$key} = $value; + #print $key . "\n"; + } + + return $config; + +} + +sub _parse_yaml_config { + + my $file = shift; + + my $yaml = undef; + eval { + $yaml = YAML::Tiny->read($file); + }; + if ($@) { + yamlerror('parse yaml config - error reading file ' . $file . ': ' . $!,$logger); + return $yaml; + } + + return $yaml; + +} + +1; \ No newline at end of file diff --git a/LogError.pm b/LogError.pm new file mode 100644 index 0000000..da759b9 --- /dev/null +++ b/LogError.pm @@ -0,0 +1,592 @@ +package LogError; +use strict; + +## no critic + +#use threads 1.72; # qw(running); +#use threads::shared; + +#use LoadConfig; +use Globals qw( + $system_version + $erroremailrecipient + $warnemailrecipient + $successemailrecipient + $completionemailrecipient + $appstartsecs + $root_threadid +); + +use Mail qw( + send_message + send_email + $signature + wrap_mailbody + $lowpriority + $normalpriority +); +use Utils qw( + threadid + create_guid + getscriptpath + timestamp + secs_to_years +); + +use POSIX qw(ceil locale_h); +setlocale(LC_NUMERIC, 'C'); + +use Time::HiRes qw(time); + +use Carp qw(carp cluck croak confess); + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw( + notimplementederror + dberror + dbwarn + fieldnamesdiffer + transferzerorowcount + processzerorowcount + deleterowserror + + tabletransferfailed + tableprocessingfailed + + fileerror + filewarn + + yamlerror + + parameterdefinedtwice + emailwarn + configurationwarn + configurationerror + + sortconfigerror + + xls2csverror + xls2csvwarn + + serviceerror + servicewarn + + webarchivexls2csverror + webarchivexls2csvwarn + + dbclustererror + dbclusterwarn + + success + completion +); + +my $erroremailsubject = 'error: module '; +my $warnemailsubject = 'warning: module '; +my $successmailsubject = 'success: module '; +my $completionmailsubject = 'completed: module '; + +sub success { + + my ($message,$attachments,$logger) = @_; + + if (length($message) == 0) { + $message = 'success'; + } + + my $appexitsecs = Time::HiRes::time(); + #$message .= "\n\n" . sprintf("%.2f",$appexitsecs - $appstartsecs) . ' seconds'; + $message .= "\n\n" . 'time elapsed: ' . secs_to_years(ceil($appexitsecs - $appstartsecs)); + + if (defined $logger) { + $logger->info($message); + } + + if (threadid() == $root_threadid) { + if (length($successemailrecipient) > 0 and defined $logger) { + my $email = { + to => $successemailrecipient, + #cc => 'rkrenn@sipwise.com', + #bcc => '', + #return_path => undef, + priority => $lowpriority, + #sender_name => 'Rene K.', + #from => 'rkrenn@sipwise.com', + subject => $successmailsubject . $logger->{category}, + body => getscriptpath() . ":\n\n" . wrap_mailbody($message) . "\n\n" . $signature, + guid => create_guid() + }; + + my ($mailresult,$mailresultmessage) = send_email($email,$attachments,\&fileerror,\&emailwarn); + } + + } + +} + +sub completion { + + my ($message,$attachments,$logger) = @_; + + if (length($message) == 0) { + $message = 'completed'; + } + + my $appexitsecs = Time::HiRes::time(); + #$message .= "\n\n" . sprintf("%.2f",$appexitsecs - $appstartsecs) . ' seconds'; + $message .= "\n\n" . 'time elapsed: ' . secs_to_years(ceil($appexitsecs - $appstartsecs)); + + if (defined $logger) { + $logger->info($message); + } + + if (threadid() == $root_threadid) { + if (length($completionemailrecipient) > 0 and defined $logger) { + my $email = { + to => $completionemailrecipient, + #cc => 'rkrenn@sipwise.com', + #bcc => '', + #return_path => undef, + priority => $normalpriority, + #sender_name => 'Rene K.', + #from => 'rkrenn@sipwise.com', + subject => $completionmailsubject . $logger->{category}, + body => getscriptpath() . ":\n\n" . wrap_mailbody($message) . "\n\n" . $signature, + guid => create_guid() + }; + + my ($mailresult,$mailresultmessage) = send_email($email,$attachments,\&fileerror,\&emailwarn); + } + + #exit(0); + } + +} + +sub warning { + + my ($message,$logger,$sendemail) = @_; + + if (threadid() == $root_threadid) { + if ($sendemail and length($warnemailrecipient) > 0 and defined $logger) { + my ($mailresult,$mailresultmessage) = send_message($warnemailrecipient,$warnemailsubject . $logger->{category},getscriptpath() . ":\n\n" . wrap_mailbody($message) . "\n\n" . $signature,\&fileerror,\&emailwarn); + } + carp($message); + #warn($message); + } else { + carp($message); + #warn($message); + } + +} + +sub terminate { + + my ($message,$logger) = @_; + + if (threadid() == $root_threadid) { + + my $appexitsecs = Time::HiRes::time(); + #$message .= "\n\n" . sprintf("%.2f",$appexitsecs - $appstartsecs) . ' seconds'; + $message .= "\n\n" . 'time elapsed: ' . secs_to_years(ceil($appexitsecs - $appstartsecs)); + + if (length($erroremailrecipient) > 0 and defined $logger) { + my ($mailresult,$mailresultmessage) = send_message($erroremailrecipient,$erroremailsubject . $logger->{category},getscriptpath() . ":\n\n" . wrap_mailbody($message) . "\n\n" . $signature,\&fileerror,\&emailwarn); + } + croak($message); # confess... + #die($message); + } else { + + croak($message); + #die($message); + } + +} + +#sub registerthread { +# +# my $thrlogger = shift; +# $registered_tids{threads->tid()} = 1; +# $SIG{'DIE'} = sub { +# +# print "signal\n"; +# my $tid = threads->tid(); +# my $message = '[' . $tid . '] aborting'; +# if (defined $thrlogger) { +# $thrlogger->error('[' . $tid . '] aborting'); +# } +# unregisterthread($tid); +# #threads->exit(); +# croak($message); +# }; +# +#} +# +#sub unregisterthread { +# +# my $tid = shift; +# if (!defined $tid) { +# $tid = threads->tid(); +# } +# delete $registered_tids{$tid}; +# +#} + +#sub terminatethreads { +# +# # Loop through all the threads +# foreach my $thr (threads->list()) { +# # Don't join the main thread or ourselves +# if ($thr->tid != 0 && !threads::equal($thr,threads->self)) { +# $thr->kill('DIE'); #->detach(); +# } +# } +# +#} + +sub notimplementederror { + + my ($message, $logger) = @_; + if (defined $logger) { + $logger->error($message); + } + + terminate($message, $logger); + #terminatethreads(); + #die(); + +} + +sub dberror { + + my ($db, $message, $logger) = @_; + $message = _getconnectorinstanceprefix($db) . _getconnectidentifiermessage($db,$message); + if (defined $logger) { + $logger->error($message); + } + + terminate($message, $logger); + #terminatethreads(); + #die(); + +} + +sub dbwarn { + + my ($db, $message, $logger) = @_; + $message = _getconnectorinstanceprefix($db) . _getconnectidentifiermessage($db,$message); + if (defined $logger) { + $logger->warn($message); + } + + #die(); + warning($message, $logger, 1); + +} + +sub fieldnamesdiffer { + + my ($db,$tablename,$expectedfieldnames,$fieldnamesfound,$logger) = @_; + my $message = _getconnectorinstanceprefix($db) . 'wrong table fieldnames (v ' . $system_version . '): [' . $db->connectidentifier() . '].' . $tablename . ":\nexpected: " . ((defined $expectedfieldnames) ? join(', ',@$expectedfieldnames) : '') . "\nfound: " . ((defined $fieldnamesfound) ? join(', ',@$fieldnamesfound) : ''); + if (defined $logger) { + $logger->error($message); + } + + terminate($message, $logger); + #terminatethreads(); + #die(); + +} + +sub dbclustererror { + + my ($clustername,$message,$logger) = @_; + $message = 'database cluster ' . $clustername . ': ' . $message; + if (defined $logger) { + $logger->error($message); + } + + terminate($message, $logger); + +} + +sub dbclusterwarn { + + my ($clustername,$message,$logger) = @_; + $message = 'database cluster ' . $clustername . ': ' . $message; + if (defined $logger) { + $logger->warn($message); + } + + #die(); + warning($message, $logger, 1); + +} + +sub transferzerorowcount { + + my ($db,$tablename,$target_db,$targettablename,$numofrows,$logger) = @_; + my $message = _getconnectorinstanceprefix($db) . '[' . $db->connectidentifier() . '].' . $tablename . ' has 0 rows'; + if (defined $logger) { + $logger->error($message); + } + + terminate($message, $logger); + #terminatethreads(); + #die(); + +} + +sub processzerorowcount { + + my ($db,$tablename,$numofrows,$logger) = @_; + my $message = '[' . $db->connectidentifier() . '].' . $tablename . ' has 0 rows'; + if (defined $logger) { + $logger->error($message); + } + + terminate($message, $logger); + #terminatethreads(); + #die(); + +} + +sub deleterowserror { + + my ($db,$tablename,$message,$logger) = @_; + $message = _getconnectorinstanceprefix($db) . '[' . $db->connectidentifier() . '].' . $tablename . ' - ' . $message; + if (defined $logger) { + $logger->error($message); + } + + terminate($message, $logger); + #terminatethreads(); + #die(); + +} + +sub tabletransferfailed { + + my ($db,$tablename,$target_db,$targettablename,$numofrows,$logger) = @_; + my $message = _getconnectorinstanceprefix($db) . 'table transfer failed: [' . $db->connectidentifier() . '].' . $tablename . ' > ' . $targettablename; + if (defined $logger) { + $logger->error($message); + } + terminate($message, $logger); + +} + +sub tableprocessingfailed { + + my ($db,$tablename,$numofrows,$logger) = @_; + my $message = 'table processing failed: [' . $db->connectidentifier() . '].' . $tablename; + if (defined $logger) { + $logger->error($message); + } + terminate($message, $logger); + +} + +sub fileerror { + + my ($message, $logger) = @_; + if (defined $logger) { + $logger->error($message); + } + + terminate($message, $logger); + #terminatethreads(); + #die(); + +} + +sub yamlerror { + + my ($message, $logger) = @_; + if (defined $logger) { + $logger->error($message); + } + + terminate($message, $logger); + #terminatethreads(); + #die(); + +} + +sub xls2csverror { + + my ($message, $logger) = @_; + if (defined $logger) { + $logger->error($message); + } + + terminate($message, $logger); + #terminatethreads(); + #die(); + +} + +sub webarchivexls2csverror { + + my ($message, $logger) = @_; + if (defined $logger) { + $logger->error($message); + } + + terminate($message, $logger); + #terminatethreads(); + #die(); + +} + +sub filewarn { + + my ($message, $logger) = @_; + if (defined $logger) { + $logger->warn($message); + } + + #die(); + warning($message, $logger, 1); +} + + +sub xls2csvwarn { + + my ($message, $logger) = @_; + if (defined $logger) { + $logger->warn($message); + } + + warning($message, $logger, 1); +} + +sub webarchivexls2csvwarn { + + my ($message, $logger) = @_; + if (defined $logger) { + $logger->warn($message); + } + + warning($message, $logger, 1); +} + +sub parameterdefinedtwice { + + my ($message,$logger) = @_; + if (defined $logger) { + $logger->warn($message); + } + warning($message, $logger, 1); +} + +sub emailwarn { + + my ($message, $errormsg, $response, $logger) = @_; + if (defined $logger) { + if (length($response) > 0) { + $logger->warn($message . ': ' . $errormsg . ' \'' . $response . '\''); + } else { + $logger->warn($message . ': ' . $errormsg); + } + } + + warning($message, $logger, 0); + +} + +sub configurationwarn { + + my ($configfile,$message,$logger) = @_; + $message = 'configuration file ' . $configfile . ': ' . $message; + if (defined $logger) { + $logger->warn($message); + } + warning($message, $logger, 0); + +} + +sub configurationerror { + + my ($configfile,$message,$logger) = @_; + $message = 'configuration file ' . $configfile . ': ' . $message; + if (defined $logger) { + $logger->error($message); + } + + terminate($message, $logger); + +} + +sub sortconfigerror { + + my ($identifier,$message,$logger) = @_; + + if (defined $identifier) { + $message = 'sort configuration (' . $identifier . '): ' . $message; + } else { + $message = 'sort configuration: ' . $message; + } + if (defined $logger) { + $logger->error($message); + } + + terminate($message, $logger); + +} + +sub serviceerror { + + my ($service, $message, $logger) = @_; + $message = '[' . $service->{tid} . '] ' . $service->identifier() . ' - ' . $message; + if (defined $logger) { + $logger->error($message); + } + + terminate($message, $logger); + +} + +sub servicewarn { + + my ($service, $message, $logger) = @_; + $message = '[' . $service->{tid} . '] ' . $service->identifier() . ' - ' . $message; + if (defined $logger) { + $logger->warn($message); + } + + #die(); + warning($message, $logger, 1); + +} + +sub _getconnectorinstanceprefix { + my ($db) = @_; + my $instancestring = $db->instanceidentifier(); + if (length($instancestring) > 0) { + if ($db->{tid} != $root_threadid) { + return '[' . $db->{tid} . '/' . $instancestring . '] '; + } else { + return '[' . $instancestring . '] '; + } + } elsif ($db->{tid} != $root_threadid) { + return '[' . $db->{tid} . '] '; + } + return ''; +} + +sub _getconnectidentifiermessage { + my ($db,$message) = @_; + my $result = $db->connectidentifier(); + my $connectidentifier = $db->_connectidentifier(); + if (length($result) > 0 and defined $db->cluster and length($connectidentifier) > 0) { + $result .= '->' . $connectidentifier; + } + if (length($result) > 0) { + $result .= ' - '; + } + return $result . $message; +} + +1; \ No newline at end of file diff --git a/Logging.pm b/Logging.pm new file mode 100644 index 0000000..e13dcd6 --- /dev/null +++ b/Logging.pm @@ -0,0 +1,607 @@ +# a verbose logging module + +package Logging; +use strict; + +## no critic + +#use threads; +#use Table; + +use Globals qw( + $root_threadid + $logfile_path + $fileloglevel + $emailloglevel + $screenloglevel + log_mainconfig + $enablemultithreading +); + +use Log::Log4perl qw(get_logger); + +use Utils qw(timestampdigits datestampdigits changemod chopstring trim); +use Array qw (contains); +#use Mail qw(send_message); +#require Mail; + +require Exporter; +our @ISA = qw(Exporter); + +our @EXPORT_OK = qw( + getlogger + abortthread + cleanuplogfiles + + emailinfo + emaildebug + dbdebug + dbinfo + + attachmentdownloaderdebug + attachmentdownloaderinfo + + fieldnamesaquired + primarykeycolsaquired + tableinfoscleared + tabletransferstarted + tableprocessingstarted + rowtransferstarted + texttablecreated + temptablecreated + indexcreated + primarykeycreated + tabletruncated + tabledropped + rowtransferred + rowskipped + rowinserted + rowupdated + rowsdeleted + totalrowsdeleted + rowinsertskipped + rowupdateskipped + tabletransferdone + tableprocessingdone + rowtransferdone + fetching_rows + writing_rows + processing_rows + + mainconfigurationloaded + configinfo + init_log4perl + $currentlogfile + $attachmentlogfile + cleanupinfo + + xls2csvinfo + tablethreadingdebug + + tablefixed + servicedebug + serviceinfo +); + +my $logfileextension = '.log'; + +our $currentlogfile; +our $weblogfile; +our $attachmentlogfile; + +#eval { + init_log4perl(); +#}; + +sub createlogfile { + + my ($logfile,$fileerrorcode,$logger) = @_; + local *LOGFILE; + if (not open (LOGFILE,'>' . $logfile)) { + if (defined $fileerrorcode and ref $fileerrorcode eq 'CODE') { + &$fileerrorcode('cannot create log file ' . $logfile . ': ' . $!,$logger); + } + } + close(LOGFILE); + changemod($logfile); + +} + +sub init_log4perl { + + $currentlogfile = $logfile_path . timestampdigits() . $logfileextension; + createlogfile($currentlogfile); + $attachmentlogfile = $logfile_path . 'email_' . timestampdigits() . $logfileextension; + createlogfile($attachmentlogfile); + $weblogfile = $logfile_path . 'web_' . datestampdigits() . $logfileextension; + createlogfile($weblogfile); + + # log configuration + my $conf = "log4perl.logger = DEBUG, FileApp, ScreenApp, MailAttApp\n" . + + "log4perl.appender.FileApp = Log::Log4perl::Appender::File\n" . + "log4perl.appender.FileApp.umask = 0\n" . + "log4perl.appender.FileApp.syswite = 1\n" . + 'log4perl.appender.FileApp.Threshold = ' . $fileloglevel . "\n" . + "log4perl.appender.FileApp.mode = append\n" . + 'log4perl.appender.FileApp.filename = ' . $currentlogfile . "\n" . + "log4perl.appender.FileApp.create_at_logtime = 1\n" . + "log4perl.appender.FileApp.layout = PatternLayout\n" . + 'log4perl.appender.FileApp.layout.ConversionPattern = %d> %m%n' . "\n\n" . + + "log4perl.appender.MailAttApp = Log::Log4perl::Appender::File\n" . + "log4perl.appender.MailApp.umask = 0\n" . + "log4perl.appender.MailApp.syswite = 1\n" . + 'log4perl.appender.MailAttApp.Threshold = ' . $emailloglevel . "\n" . + "log4perl.appender.MailAttApp.mode = append\n" . + 'log4perl.appender.MailAttApp.filename = ' . $attachmentlogfile . "\n" . + "log4perl.appender.MailAttApp.create_at_logtime = 1\n" . + "log4perl.appender.MailAttApp.layout = Log::Log4perl::Layout::SimpleLayout\n" . + 'log4perl.appender.MailAttApp.layout.ConversionPattern = %d> %m%n' . "\n\n" . + + "log4perl.appender.ScreenApp = Log::Log4perl::Appender::Screen\n" . + #"log4perl.appender.ScreenApp = Log::Log4perl::Appender::ScreenColoredLevels\n" . + 'log4perl.appender.ScreenApp.Threshold = ' . $screenloglevel . "\n" . + "log4perl.appender.ScreenApp.stderr = 0\n" . + "log4perl.appender.ScreenApp.layout = Log::Log4perl::Layout::SimpleLayout\n" . + 'log4perl.appender.ScreenApp.layout.ConversionPattern = %d> %m%n'; + + # Initialize logging behaviour + Log::Log4perl->init( \$conf ); +} + +#my $loglogger; +#eval { +# $loglogger = get_logger(__PACKAGE__); +#}; +my $loglogger = get_logger(__PACKAGE__); + +sub getlogger { + + my $package = shift; + #my $newlogger; + #eval { + # $newlogger = get_logger($package); + #}; + #if (defined $loglogger and defined $newlogger) { + # $loglogger->debug('logger for category ' . $package . ' created'); + #} + my $newlogger = get_logger($package); + $loglogger->debug('logger for category ' . $package . ' created'); + return $newlogger; + +} + +sub cleanuplogfiles { + + my ($fileerrorcode,$filewarncode,@remaininglogfiles) = @_; + my $rlogfileextension = quotemeta($logfileextension); + local *LOGDIR; + if (not opendir(LOGDIR, $logfile_path)) { + if (defined $fileerrorcode and ref $fileerrorcode eq 'CODE') { + &$fileerrorcode('cannot opendir ' . $logfile_path . ': ' . $!,$loglogger); + return; + } + } + my @files = grep { /$rlogfileextension$/ && -f $logfile_path . $_} readdir(LOGDIR); + closedir LOGDIR; + foreach my $file (@files) { + #print $file; + my $filepath = $logfile_path . $file; + #print $filepath . "\n"; + #print $remaininglogfiles[0] . "\n\n"; + if (not contains($filepath,\@remaininglogfiles)) { + if ((unlink $filepath) == 0) { + if (defined $filewarncode and ref $filewarncode eq 'CODE') { + &$filewarncode('cannot remove ' . $filepath . ': ' . $!,$loglogger); + } + } + } + } + +} + +sub emailinfo { + + my ($message, $logger) = @_; + if (defined $logger) { + $logger->info($message); + } + +} + +sub emaildebug { + + my ($message, $logger) = @_; + if (defined $logger) { + $logger->debug($message); + } + +} + +sub dbdebug { + + my ($db, $message, $logger) = @_; + if (defined $logger) { + $logger->debug(_getconnectorinstanceprefix($db) . _getconnectidentifiermessage($db,$message)); + } + + #die(); + +} + +sub dbinfo { + + my ($db, $message, $logger) = @_; + if (defined $logger) { + $logger->info(_getconnectorinstanceprefix($db) . _getconnectidentifiermessage($db,$message)); + } + + #die(); + +} + +sub attachmentdownloaderdebug { + + my ($message, $logger) = @_; + if (defined $logger) { + $logger->debug($message); + } + +} + +sub attachmentdownloaderinfo { + + my ($message, $logger) = @_; + if (defined $logger) { + $logger->info($message); + } + +} + +sub xls2csvinfo { + + my ($message, $logger) = @_; + if (defined $logger) { + $logger->info($message); + } + +} + +sub fieldnamesaquired { + + my ($db,$tablename,$logger) = @_; + if (defined $logger) { + $logger->info(_getconnectorinstanceprefix($db) . 'fieldnames aquired and OK: [' . $db->connectidentifier() . '].' . $tablename); + } + +} + +sub primarykeycolsaquired { + + my ($db,$tablename,$keycols,$logger) = @_; + if (defined $logger) { + $logger->info(_getconnectorinstanceprefix($db) . 'primary key columns aquired for [' . $db->connectidentifier() . '].' . $tablename . ': ' . ((defined $keycols and scalar @$keycols > 0) ? join(', ',@$keycols) : '')); + } + +} + +sub tableinfoscleared { + + my ($db,$logger) = @_; + if (defined $logger) { + $logger->info(_getconnectorinstanceprefix($db) . 'table infos cleared for ' . $db->connectidentifier()); + } + +} + +sub tabletransferstarted { + + my ($db,$tablename,$target_db,$targettablename,$numofrows,$logger) = @_; + if (defined $logger) { + $logger->info(_getconnectorinstanceprefix($db) . 'table transfer started: [' . $db->connectidentifier() . '].' . $tablename . ' > ' . $targettablename . ': ' . $numofrows . ' row(s)'); + } + +} + +sub tableprocessingstarted { + + my ($db,$tablename,$numofrows,$logger) = @_; + if (defined $logger) { + $logger->info('table processing started: [' . $db->connectidentifier() . '].' . $tablename . ': ' . $numofrows . ' row(s)'); + } + +} + +sub tablethreadingdebug { + + my ($message,$logger) = @_; + if (defined $logger) { + $logger->debug($message); + } + +} + +sub rowtransferstarted { + + my ($db,$tablename,$target_db,$targettablename,$numofrows,$logger) = @_; + if (defined $logger) { + $logger->info(_getconnectorinstanceprefix($db) . 'row transfer started: [' . $db->connectidentifier() . '].' . $tablename . ' > ' . $targettablename . ': ' . $numofrows . ' row(s)'); + } + +} + +sub texttablecreated { + + my ($db,$tablename,$logger) = @_; + if (defined $logger) { + $logger->info(_getconnectorinstanceprefix($db) . 'text table created: ' . $tablename); + } + +} + +sub indexcreated { + + my ($db,$tablename,$indexname,$logger) = @_; + if (defined $logger) { + $logger->info(_getconnectorinstanceprefix($db) . 'index created: ' . $indexname . ' on ' . $tablename); + } + +} + +sub primarykeycreated { + + my ($db,$tablename,$keycols,$logger) = @_; + if (defined $logger and (defined $keycols and scalar @$keycols > 0)) { + $logger->info(_getconnectorinstanceprefix($db) . 'primary key created: ' . join(', ',@$keycols) . ' on ' . $tablename); + } + +} + +sub temptablecreated { + + my ($db,$tablename,$logger) = @_; + if (defined $logger) { + $logger->info(_getconnectorinstanceprefix($db) . 'temporary table created: ' . $tablename); + } + +} + +sub tabletruncated { + + my ($db,$tablename,$logger) = @_; + if (defined $logger) { + $logger->info(_getconnectorinstanceprefix($db) . 'table truncated: ' . $tablename); + } + +} + +sub tabledropped { + + my ($db,$tablename,$logger) = @_; + if (defined $logger) { + $logger->info(_getconnectorinstanceprefix($db) . 'table dropped: ' . $tablename); + } + +} + +sub rowtransferred { + + my ($db,$tablename,$target_db,$targettablename,$i,$numofrows,$logger) = @_; + if (defined $logger) { + $logger->debug(_getconnectorinstanceprefix($db) . 'row ' . $i . '/' . $numofrows . ' transferred'); + } + +} + +sub rowskipped { + + my ($db,$tablename,$target_db,$targettablename,$i,$numofrows,$logger) = @_; + if (defined $logger) { + $logger->info(_getconnectorinstanceprefix($db) . 'row ' . $i . '/' . $numofrows . ' skipped'); + } + +} + +sub rowinserted { + + my ($db,$tablename,$logger) = @_; + if (defined $logger) { + $logger->debug(_getconnectorinstanceprefix($db) . 'row inserted'); + } + +} + +sub rowupdated { + + my ($db,$tablename,$logger) = @_; + if (defined $logger) { + $logger->debug(_getconnectorinstanceprefix($db) . 'row updated'); + } + +} + +sub rowsdeleted { + + my ($db,$tablename,$rowcount,$initial_rowcount,$logger) = @_; + if (defined $logger) { + if (defined $initial_rowcount) { + $logger->debug(_getconnectorinstanceprefix($db) . $rowcount . ' of ' . $initial_rowcount . ' row(s) deleted'); + } else { + $logger->debug(_getconnectorinstanceprefix($db) . $rowcount . ' row(s) deleted'); + } + } + +} + +sub totalrowsdeleted { + + my ($db,$tablename,$rowcount_total,$initial_rowcount,$logger) = @_; + if (defined $logger) { + $logger->info(_getconnectorinstanceprefix($db) . $rowcount_total . ' of ' . $initial_rowcount . ' row(s) deleted from [' . $db->connectidentifier() . '].' . $tablename); + } + +} + +sub rowinsertskipped { + + my ($db,$tablename,$logger) = @_; + if (defined $logger) { + $logger->info(_getconnectorinstanceprefix($db) . 'row insert skipped'); + } + +} + +sub rowupdateskipped { + + my ($db,$tablename,$logger) = @_; + if (defined $logger) { + $logger->info(_getconnectorinstanceprefix($db) . 'row update skipped'); + } + +} + +sub tabletransferdone { + + my ($db,$tablename,$target_db,$targettablename,$numofrows,$logger) = @_; + if (defined $logger) { + $logger->info(_getconnectorinstanceprefix($db) . 'table transfer done: [' . $db->connectidentifier() . '].' . $tablename . ' > ' . $targettablename . ': ' . $numofrows . ' row(s)'); + } + +} + +sub tablefixed { + + my ($target_db,$targettablename,$statement,$logger) = @_; + if (defined $logger) { + $logger->info(_getconnectorinstanceprefix($target_db) . 'table fix applied to ' . $targettablename . ': ' . chopstring(trim($statement),90)); + } + +} + +sub tableprocessingdone { + + my ($db,$tablename,$numofrows,$logger) = @_; + if (defined $logger) { + $logger->info('table processing done: [' . $db->connectidentifier() . '].' . $tablename . ': ' . $numofrows . ' row(s)'); + } + +} + +sub rowtransferdone { + + my ($db,$tablename,$target_db,$targettablename,$numofrows,$logger) = @_; + if (defined $logger) { + $logger->info(_getconnectorinstanceprefix($db) . 'row transfer done: [' . $db->connectidentifier() . '].' . $tablename . ' > ' . $targettablename . ': ' . $numofrows . ' row(s)'); + } + +} + +sub fetching_rows { + + my ($db,$tablename,$start,$blocksize,$totalnumofrows,$logger) = @_; + if (defined $logger) { + $logger->info(_getconnectorinstanceprefix($db) . 'fetching rows from [' . $db->connectidentifier() . '].' . $tablename . ': ' . ($start + 1) . '-' . ($start + $blocksize) . ' of ' . $totalnumofrows); + } + +} + +sub writing_rows { + + my ($db,$tablename,$start,$blocksize,$totalnumofrows,$logger) = @_; + if (defined $logger) { + $logger->info(_getconnectorinstanceprefix($db) . 'writing rows to ' . $tablename . ': ' . ($start + 1) . '-' . ($start + $blocksize) . ' of ' . $totalnumofrows); + } + +} + +sub processing_rows { + + my ($tid, $start,$blocksize,$totalnumofrows,$logger) = @_; + if (defined $logger) { + $logger->info(($enablemultithreading ? '[' . $tid . '] ' : '') . 'processing rows: ' . ($start + 1) . '-' . ($start + $blocksize) . ' of ' . $totalnumofrows); + } + +} + +sub mainconfigurationloaded { + + my ($configfile,$logger) = @_; + if (defined $logger) { + $logger->info('system configuration file ' . $configfile . ' loaded'); + } + log_mainconfig(\&configinfo,$logger); + +} + +sub configinfo { + + my ($message,$logger) = @_; + if (defined $logger) { + $logger->info($message); + } + +} + +sub cleanupinfo { + + my ($message,$logger) = @_; + if (defined $logger) { + $logger->info($message); + } + +} + +sub servicedebug { + + my ($service, $message, $logger) = @_; + if (defined $logger) { + $message = '[' . $service->{tid} . '] ' . $service->identifier() . ' - ' . $message; + $logger->debug($message); + } + + #die(); + +} + +sub serviceinfo { + + my ($service, $message, $logger) = @_; + if (defined $logger) { + $message = '[' . $service->{tid} . '] ' . $service->identifier() . ' - ' . $message; + $logger->info($message); + } + + #die(); + +} + +sub _getconnectorinstanceprefix { + my ($db) = @_; + my $instancestring = $db->instanceidentifier(); + if (length($instancestring) > 0) { + if ($db->{tid} != $root_threadid) { + return '[' . $db->{tid} . '/' . $instancestring . '] '; + } else { + return '[' . $instancestring . '] '; + } + } elsif ($db->{tid} != $root_threadid) { + return '[' . $db->{tid} . '] '; + } + return ''; +} + +sub _getconnectidentifiermessage { + my ($db,$message) = @_; + my $result = $db->connectidentifier(); + my $connectidentifier = $db->_connectidentifier(); + if (length($result) > 0 and defined $db->cluster and length($connectidentifier) > 0) { + $result .= '->' . $connectidentifier; + } + if (length($result) > 0) { + $result .= ' - '; + } + return $result . $message; +} + +1; \ No newline at end of file diff --git a/Mail.pm b/Mail.pm new file mode 100644 index 0000000..df1153f --- /dev/null +++ b/Mail.pm @@ -0,0 +1,625 @@ +# mail module: sending emails with attachments + +package Mail; +#BEGIN { $INC{Mail} ||= __FILE__ }; +use strict; + +## no critic + +#require Logging; +use Logging qw( +getlogger +emailinfo +emaildebug); +#use LogError qw(fileerror); +#use LogWarn qw(emailwarn); + +#use LoadConfig; +use Globals qw( + $system_name + $system_instance_label + $system_version + $local_fqdn + $mailfilepath + $emailenable + $mailprog + $mailtype + + $ismsexchangeserver + $sender_address + $smtp_server + $smtpuser + $smtppasswd + $writefiles +); + +use Utils qw(trim file_md5 create_guid wrap_text changemod); + +use File::Basename; +#use File::Temp qw(tempfile tempdir); +use MIME::Base64; +use MIME::Lite; + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw( + send_message + send_email + wrap_mailbody + $signature + $normalpriority + $lowpriority + $highpriority + cleanupmsgfiles +); + +my $wordwrapcolumns = 72; #linebreak/wrap columns + +our $signature = "--\n" . $system_name . ' ' . $system_version . ' (' . $system_instance_label . ")\n[" . $local_fqdn . ']'; # a nice email signature + +my $msgextension = '.msg'; + +our $normalpriority = 0; +our $lowpriority = 1; +our $highpriority = 2; + +my %msmailpriority = ( + $normalpriority => 'Normal', + $lowpriority => 'Low', + $highpriority => 'High'); + +# sample email data structure: +#my $message = { +# to => 'rkrenn@sipwise.com', +# cc => 'rkrenn@alumni.tugraz.at', +# bcc => '', +# return_path => '', +# priority => $normalpriority, +# sender_name => 'Rene Krenn', +# from => 'rkrenn@sipwise.com', +# subject => 'subject...', +# body => wrap_mailbody('test.......'), +# guid => create_guid() +#}; + + +my $mailsentsuccessfully = 1; + +my $mailingdisabled = 0; + +my $smtpserveripinvalid = -11; +my $smtpsocketcreatefailed = -12; +my $smtpserverconnectfailed = -13; +my $smtpprotocolerrorinitial = -14; +my $smtpprotocolerrorehlo = -15; #list auth options - esmtp +my $smtpnoauthloginavailable = -16; +my $smtpprotocolerrorlogin = -17; #start login +my $smtpprotocolerroruser = -18; +my $smtpprotocolerrorpass = -19; +my $smtpprotocolerrorhelo = -20; #normal smtp - no auth +my $mailrecipientundefined = -21; +my $smtpprotocolerrorfrom = -20; +my $smtpprotocolerrorrcpt = -22; +my $smtpprotocolerrordata = -23; + + +my $smtpnetfatalerror = -24; +my $smtpprotocolerrordataaccepted = -25; + + +my $mailprogpipeerror = -26; +my $writemailfileerror = -27; + +my $errorcreatingmimemail = -30; +my $errorcreatingfileattachment = -32; +my $attachmentfilenotexistent = -31; + + + +my $mailerr_messages = { + $mailsentsuccessfully => 'MailSentSuccessfully', + $mailingdisabled => 'MailingDisabled', + + $smtpserveripinvalid => 'SMTPServerIPInvalid', + $smtpsocketcreatefailed => 'SMTPSocketCreateFailed', + $smtpserverconnectfailed => 'SMTPServerConnectFailed', + $smtpprotocolerrorinitial => 'SMTPProtocolErrorInitial', + $smtpprotocolerrorehlo => 'SMTPProtocolErrorEhlo', + $smtpnoauthloginavailable => 'SMTPNoAuthLoginAvailable', + $smtpprotocolerrorlogin => 'SMTPProtocolErrorLogin', + $smtpprotocolerroruser => 'SMTPProtocolErrorUser', + $smtpprotocolerrorpass => 'SMTPProtocolErrorPass', + $smtpprotocolerrorhelo => 'SMTPProtocolErrorHelo', + $smtpprotocolerrorfrom => 'SMTPProtocolErrorFrom', + $smtpprotocolerrorrcpt => 'SMTPProtocolErrorRcpt', + $smtpprotocolerrordata => 'SMTPProtocolErrorData', + + $smtpnetfatalerror => 'SMTPNetFatalError', + $smtpprotocolerrordataaccepted => 'SMTPProtocolErrorDataAccepted', + + $mailprogpipeerror => 'MailProgPipeError', + + $writemailfileerror => 'WriteMailFileError', + + $mailrecipientundefined => 'MailRecipientUndefined', + $errorcreatingmimemail => 'ErrorCreatingMIMEMail', + $errorcreatingfileattachment => 'ErrorCreatingFileAttachment', + + $attachmentfilenotexistent => 'AttachmentFileNotExistent', + +}; + +my $logger = getlogger(__PACKAGE__); + +# email body wordwrapping: +sub wrap_mailbody { + + return wrap_text(shift,$wordwrapcolumns); + +} + +# send an email +# $mailmessage parameter is a email data structure +# $filepaths is an arrayref with filenames to attach +sub send_mail_with_attachments { + + my ($mailmessage,$filepaths,$fileerrorcode, $emailwarncode) = @_; + + my @filestocleanup = (); + + my $message = $mailmessage->{body}; + $message =~ s/^\./\.\./gm; + $message =~ s/\r\n/\n/g; + + my $to = cleanrcpts($mailmessage->{to}); + my $cc = cleanrcpts($mailmessage->{cc}); + my $bcc = cleanrcpts($mailmessage->{bcc}); + my $returnpath = preparemailaddress($mailmessage->{return_path}); + my $priority = $msmailpriority{$mailmessage->{priority}}; + + my $mime_mail = MIME::Lite->new( + From => '"' . $mailmessage->{sender_name} . '" <' . preparemailaddress($mailmessage->{from}) . '>', + Sender => $system_name, + Type => 'multipart/mixed', + Encoding => 'binary', + Subject => $mailmessage->{subject} + ) or return $errorcreatingmimemail; + + $mime_mail->add('Message-ID' => '<' . $mailmessage->{guid} . '@' . $local_fqdn . '>'); + $mime_mail->add('X-Mailer' => $system_name . ' Plaintext Mailer'); + + if (defined $to and $to ne '') { + $mime_mail->add('To' => $to); + } + if (defined $cc and $cc ne '') { + $mime_mail->add('Cc' => $cc); + } + if (defined $bcc and $bcc ne '') { + $mime_mail->add('Bcc' => $bcc); + } + if (defined $returnpath and $returnpath ne '') { + $mime_mail->add('Return-Path' => '<' . $returnpath . '>'); + } + if (defined $priority and $priority ne '') { + $mime_mail->add('Importance' => $priority); + } + + $mime_mail->attr('content-type.charset' => 'UTF8'); + + $mime_mail->attach( + Type => 'TEXT', + Data => $message + ); + + if (defined $filepaths and ref $filepaths eq 'ARRAY') { + + my @attachmentfilepaths = @$filepaths; + + for (my $i = 0; $i < scalar @attachmentfilepaths; $i++) { + my $attachmentfilepath = $attachmentfilepaths[$i]; + if (-e $attachmentfilepath) { + my $filesize = -s $attachmentfilepath; + #push @filestocleanup,$attachmentfilepath; + if ($filesize > 0) { + $mime_mail->attach( + Id => file_md5($attachmentfilepath,$fileerrorcode,$logger), + Type => 'AUTO', + Filename => basename($attachmentfilepath), + Length => $filesize, + Encoding => 'base64', + Disposition => 'attachment', + ReadNow => 1, + Path => $attachmentfilepath + ) or return flushtempfiles($errorcreatingfileattachment,\@filestocleanup); + } + } else { + return flushtempfiles($attachmentfilenotexistent,\@filestocleanup); + } + } + + } + + return flushtempfiles(send_smtp(preparemailaddress($mailmessage->{from}), mergercpts(($mailmessage->{to},$mailmessage->{cc},$mailmessage->{bcc})), $mime_mail->as_string(),$fileerrorcode, $emailwarncode),\@filestocleanup); + +} + +sub flushtempfiles { + + my ($errorcode,$filestocleanup) = @_; + foreach my $filetocleanup (@$filestocleanup) { + unlink $filetocleanup; + } + return $errorcode; + +} + +sub send_simple_mail { + + my ($to, $subject, $messagebody, $from, $from_name, $return_path,$fileerrorcode, $emailwarncode) = @_; + + my $message = $messagebody; + $message =~ s/^\./\.\./gm; + $message =~ s/\r\n/\n/g; + $message =~ s/<\/*b>//g; + + my $crlf = "\n"; + if ($ismsexchangeserver) { + $crlf = "\r\n"; + } + + my $fromemail = preparemailaddress($from); + my $returnpath = preparemailaddress($return_path); + + my $data = 'From: '; + if (defined $from_name and $from_name ne '') { + $data .= '"' . $from_name . '" '; + } + if (defined $fromemail and $fromemail ne '') { + $data .= '<' . $fromemail . '>' . $crlf; + } else { + $data .= '<' . $sender_address . '>' . $crlf; + } + $data .= 'Subject: ' . $subject . $crlf; + $data .= 'To: ' . cleanrcpts($to) . $crlf; + $data .= 'X-Mailer: ' . $system_name . ' Plaintext Mailer' . $crlf; + if (defined $returnpath and $returnpath ne '') { + $data .= 'Return-Path: <' . $returnpath . '>' . $crlf; + } + $data .= $message; + + return send_smtp($from, $to, $data,$fileerrorcode, $emailwarncode); + +} + +sub send_smtp { + + my ($from, $to, $data, $fileerrorcode, $emailwarncode) = @_; + + my $fromemail = preparemailaddress($from); + + if (!$to) { + return $mailrecipientundefined; + } + + my $crlf = "\n"; + if ($ismsexchangeserver) { + $crlf = "\r\n"; + } + + local *MAIL; + + if ($mailtype == 1) { + + use Socket; + + my($proto) = (getprotobyname('tcp'))[2]; + my($port) = (getservbyname('smtp', 'tcp'))[2]; + my($smtpaddr) = ($smtp_server =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/) ? pack('C4',$1,$2,$3,$4) : (gethostbyname($smtp_server))[4]; + + if (!defined($smtpaddr)) { return $smtpserveripinvalid; } + if (!socket(MAIL, AF_INET, SOCK_STREAM, $proto)) { return $smtpsocketcreatefailed; } + if (!connect(MAIL, pack('Sna4x8', AF_INET, $port, $smtpaddr))) { return $smtpserverconnectfailed; } + + my($oldfh) = select(MAIL); + $| = 1; + select($oldfh); + + $_ = ; + if (/^[45]/) { + close(MAIL); + return $smtpprotocolerrorinitial; + } + + if (defined $smtpuser and $smtpuser ne '') { + + #use MIME::Base64; + print MAIL 'ehlo ' . $smtp_server . "\r\n"; + + my $authloginavailable = 0; + while () { + if (/^[45]/) { + close(MAIL); + return $smtpprotocolerrorehlo; + } elsif (/auth.login/gi) { #auth login available + $authloginavailable = ($authloginavailable or 1); + } elsif (/ok/gi) { + last; + } + } + if ($authloginavailable == 0) { + close(MAIL); + return $smtpnoauthloginavailable; + } + + print MAIL "auth login\r\n"; + $_ = ; + if (/^[45]/) { + close(MAIL); + return $smtpprotocolerrorlogin; + } + + print MAIL encode_base64($smtpuser,'') . "\r\n"; + $_ = ; + if (/^[45]/) { + close(MAIL); + return $smtpprotocolerroruser; + } + + print MAIL encode_base64($smtppasswd,'') . "\r\n"; + $_ = ; + #emaildebug($_,$logger); + if (/^[45]/) { + close(MAIL); + return $smtpprotocolerrorpass; #auth unsuccessful + } + + } else { + + print MAIL 'helo ' . $smtp_server . "\r\n"; + $_ = ; + if (/^[45]/) { + close(MAIL); + return $smtpprotocolerrorhelo; + } + + } + + print MAIL 'mail from: <' . $fromemail . ">\r\n"; + $_ = ; + if (/^[45]/) { + close(MAIL); + return $smtpprotocolerrorfrom; + } + + foreach (splitrcpts($to)) { + print MAIL 'rcpt to: <' . $_ . ">\r\n"; + $_ = ; + if (/^[45]/) { + close(MAIL); + return $smtpprotocolerrorrcpt; + } + } + + print MAIL "data\r\n"; + $_ = ; + if (/^[45]/) { + close(MAIL); + return $smtpprotocolerrordata; + } + #print MAIL "123"; + #print MAIL $crlf . '.' . $crlf; + #$_ = ; + + } elsif ($mailtype == 0) { + if (not open(MAIL,"| $mailprog -t")) { + emailwarn('problem with pipe to ' . $mailprog . ': ' . $!,$logger); + return $mailprogpipeerror; + } + } + + if ($mailtype == 2) { + eval { + use Net::SMTP; + my $smtp; + if (not $smtp = Net::SMTP->new($smtp_server, Debug => 0)) { + #emailwarn('unable to create Net::SMTP object - ' . $smtp_server); + #if (defined $emailwarncode and ref $emailwarncode eq 'CODE') { + # &$emailwarncode('unable to create Net::SMTP object - ' . $smtp_server); + #} + die('unable to create Net::SMTP object - ' . $smtp_server); + } else { + $smtp->mail($fromemail); + if (defined $smtpuser and $smtpuser ne '') { + $smtp->auth($smtpuser,$smtppasswd); + } + $smtp->to($to); + $smtp->data(); + $smtp->datasend($data); + $smtp->dataend(); + $smtp->quit(); + } + }; + if ($@) { + #emailwarn('Net::SMTP fatal error: ' . $@); + if (defined $emailwarncode and ref $emailwarncode eq 'CODE') { + &$emailwarncode('Net::SMTP fatal error: ' . $@); + } + return $smtpnetfatalerror; + } + return 1; + } else { + + print MAIL $data; + print MAIL $crlf . '.' . $crlf; + #print MAIL "\n.\n"; #$crlf . '.' . $crlf; + + if ($mailtype == 1) { + $_ = ; + emaildebug($_,$logger); + if (/^[45]/) { + close(MAIL); + return $smtpprotocolerrordataaccepted; + } + } + + print MAIL "quit\r\n"; + + if ($mailtype == 1) { + $_ = ; + } + + close(MAIL); + + } + + if ($writefiles) { + foreach my $rcpt (splitrcpts($to)) { + my $fileindex = 0; + my $emailfile = $mailfilepath . $rcpt . '.' . $fileindex . $msgextension; + while (-e $emailfile) { + $fileindex += 1; + $emailfile = $mailfilepath . $rcpt . '.' . $fileindex . $msgextension; + } + local *MAILFILE; + if (not open (MAILFILE,'>' . $emailfile)) { + #fileerror('cannot open file ' . $emailfile . ': ' . $!,$logger); + if (defined $fileerrorcode and ref $fileerrorcode eq 'CODE') { + &$fileerrorcode('cannot open file ' . $emailfile . ': ' . $!,$logger); + } + return $writemailfileerror; + } + print MAILFILE $data; + close(MAILFILE); + changemod($emailfile); + } + } + + return $mailsentsuccessfully ; + +} + +sub cleanupmsgfiles { + + my ($fileerrorcode,$filewarncode) = @_; + my $rmsgextension = quotemeta($msgextension); + local *MAILDIR; + if (not opendir(MAILDIR, $mailfilepath)) { + #fileerror('cannot opendir ' . $mailfilepath . ': ' . $!,$logger); + if (defined $fileerrorcode and ref $fileerrorcode eq 'CODE') { + &$fileerrorcode('cannot opendir ' . $mailfilepath . ': ' . $!,$logger); + } + return; + } + my @files = grep { /$rmsgextension$/ && -f $mailfilepath . $_ } readdir(MAILDIR); + closedir MAILDIR; + foreach my $file (@files) { + my $filepath = $mailfilepath . $file; + if ((unlink $filepath) == 0) { + #filewarn('cannot remove ' . $filepath . ': ' . $!,$logger); + if (defined $filewarncode and ref $filewarncode eq 'CODE') { + &$filewarncode('cannot remove ' . $filepath . ': ' . $!,$logger); + } + } + } + +} + +sub preparemailaddress { + + my ($emailaddress) = @_; + my $cleanedemailaddress = trim($emailaddress); + $cleanedemailaddress =~ s/^.*$//g; + return $cleanedemailaddress; + +} + +sub splitrcpts { + + my ($rcptemails) = @_; + my @rcptemails_arr = (); + foreach my $rcptemail (split(/;|,/, $rcptemails)) { + my $cleanedemailaddress = preparemailaddress($rcptemail); + if (defined $cleanedemailaddress and $cleanedemailaddress ne '') { + push @rcptemails_arr,$cleanedemailaddress; + } + } + return @rcptemails_arr; + +} + +sub cleanrcpts { + + my ($rcptemails) = @_; + if (defined $rcptemails and $rcptemails ne '') { + return '<' . join('>, <',splitrcpts($rcptemails)) . '>'; + } + +} + +sub mergercpts { + + my (@rcptemails) = @_; + return join(',',splitrcpts(join(',',@rcptemails))); + +} + +sub send_message { + + my ($to, $subject, $message,$fileerrorcode, $emailwarncode) = @_; + my $errormsg = $mailingdisabled; + if ($emailenable) { + $errormsg = send_simple_mail($to,$subject,$message,$sender_address,$system_name, $sender_address,$fileerrorcode, $emailwarncode); + if ($errormsg != $mailsentsuccessfully ) { + #emailwarn('error sending email to ' . $to . ' via ' . $smtp_server . ' (' . $errorcode . ')',$_,$logger); + if (defined $emailwarncode and ref $emailwarncode eq 'CODE') { + &$emailwarncode('error sending email to ' . $to . ' via ' . $smtp_server,$mailerr_messages->{$errormsg},$_,$logger); + } + } else { + emailinfo('email sent to ' . $to . ' via ' . $smtp_server,$logger); + } + } + return $errormsg; + +} + +sub send_email { + + my ($email,$attachments,$fileerrorcode, $emailwarncode) = @_; + my $errormsg = $mailingdisabled; + if ($emailenable and defined $email) { + if (not exists $email->{return_path} or not defined $email->{return_path}) { + $email->{return_path} = $sender_address; + } + + if (not exists $email->{priority} or not defined $email->{priority}) { + $email->{priority} = $normalpriority; + } + + if (not exists $email->{sender_name} or not defined $email->{sender_name}) { + $email->{sender_name} = $system_name; + } + + if (not exists $email->{from} or not defined $email->{from}) { + $email->{from} = $sender_address; + } + + if (not exists $email->{guid} or not defined $email->{guid}) { + $email->{guid} = create_guid(); + } + + $errormsg = send_mail_with_attachments($email,$attachments,$fileerrorcode, $emailwarncode); + if ($errormsg != $mailsentsuccessfully ) { + #emailwarn('error sending email to ' . mergercpts(($email->{to},$email->{cc},$email->{bcc})) . ' via ' . $smtp_server . ' (' . $errorcode . ')',$_,$logger); + if (defined $emailwarncode and ref $emailwarncode eq 'CODE') { + &$emailwarncode('error sending email to ' . mergercpts(($email->{to},$email->{cc},$email->{bcc})) . ' via ' . $smtp_server,$mailerr_messages->{$errormsg},$_,$logger); + } + } else { + emailinfo('email sent to ' . mergercpts(($email->{to},$email->{cc},$email->{bcc})) . ' via ' . $smtp_server,$logger); + } + } + return $errormsg; + +} + +1; \ No newline at end of file diff --git a/NoSqlConnector.pm b/NoSqlConnector.pm new file mode 100644 index 0000000..3f2e1f6 --- /dev/null +++ b/NoSqlConnector.pm @@ -0,0 +1,6 @@ +package NoSqlConnector; +use strict; + +## no critic + +1; \ No newline at end of file diff --git a/Projects/t/test_connectors.pl b/Projects/t/test_connectors.pl new file mode 100755 index 0000000..b31ae19 --- /dev/null +++ b/Projects/t/test_connectors.pl @@ -0,0 +1,235 @@ +# mysql, oracle, mssql, .. matrix db interconnection test + +use strict; + +## no critic + +use LoadCLIConfig; + +use ConnectorPool qw( + destroy_dbs + get_sqlserver_test_db + get_postgres_test_db + get_oracle_test_db + get_mysql_test_db + get_csv_test_db + get_sqlite_test_db +); + +use Test::Unit::Procedural; + +use test::csv_table; +use test::mysql_table; +use test::oracle_table; +use test::postgres_table; +use test::sqlite_table; +use test::sqlserver_table; + +my $sort_config = [ { numeric => 1, + dir => 1, + column => 'column1', + }, + { numeric => 1, + dir => -1, + memberchain => 'column2', + }, + ]; + +sub set_up { + + +} + + +sub test_sync_tables_to_sqlite { + + test::sqlserver_table::sync_table(\&get_sqlite_test_db); + test::postgres_table::sync_table(\&get_sqlite_test_db); + test::oracle_table::sync_table(\&get_sqlite_test_db); + test::sqlite_table::sync_table(\&get_sqlite_test_db); + test::csv_table::sync_table(\&get_sqlite_test_db); + test::mysql_table::sync_table(\&get_sqlite_test_db); + +} + +sub test_sync_tables_to_mysql { + + test::sqlserver_table::sync_table(\&get_mysql_test_db); + test::postgres_table::sync_table(\&get_mysql_test_db); + test::oracle_table::sync_table(\&get_mysql_test_db); + test::sqlite_table::sync_table(\&get_mysql_test_db); + test::csv_table::sync_table(\&get_mysql_test_db); + test::mysql_table::sync_table(\&get_mysql_test_db); + +} + +sub test_sync_tables_to_postgres { + + test::sqlserver_table::sync_table(\&get_postgres_test_db); + test::postgres_table::sync_table(\&get_postgres_test_db); + test::oracle_table::sync_table(\&get_postgres_test_db); + test::sqlite_table::sync_table(\&get_postgres_test_db); + test::csv_table::sync_table(\&get_postgres_test_db); + test::mysql_table::sync_table(\&get_postgres_test_db); + +} + +sub test_sync_tables_to_oracle { + + test::sqlserver_table::sync_table(\&get_oracle_test_db); + test::postgres_table::sync_table(\&get_oracle_test_db); + test::oracle_table::sync_table(\&get_oracle_test_db); + test::sqlite_table::sync_table(\&get_oracle_test_db); + test::csv_table::sync_table(\&get_oracle_test_db); + test::mysql_table::sync_table(\&get_oracle_test_db); + +} + +sub test_sync_tables_to_sqlserver { + + test::sqlserver_table::sync_table(\&get_sqlserver_test_db); + test::postgres_table::sync_table(\&get_sqlserver_test_db); + test::oracle_table::sync_table(\&get_sqlserver_test_db); + test::sqlite_table::sync_table(\&get_sqlserver_test_db); + test::csv_table::sync_table(\&get_sqlserver_test_db); + test::mysql_table::sync_table(\&get_sqlserver_test_db); + +} + +sub test_sync_tables_to_csv { + + test::sqlserver_table::sync_table(\&get_csv_test_db); + test::postgres_table::sync_table(\&get_csv_test_db); + test::oracle_table::sync_table(\&get_csv_test_db); + test::sqlite_table::sync_table(\&get_csv_test_db); + test::csv_table::sync_table(\&get_csv_test_db); + test::mysql_table::sync_table(\&get_csv_test_db); + +} + +sub test_select_source_sqlserver { + + my $result = test::sqlserver_table::test_table_source_select('column1 is not null',2,3,$sort_config); + assert((scalar @$result) == 1,'source query failed'); + +} + +sub test_select_source_postgres { + + my $result = test::postgres_table::test_table_source_select('column1 is not null',2,3,$sort_config); + assert((scalar @$result) == 1,'source query failed'); + +} + +sub test_select_source_oracle { + + my $result = test::oracle_table::test_table_source_select('column1 is not null',0,1,$sort_config); + assert((scalar @$result) == 1,'source query failed'); + +} + +sub test_select_source_sqlite { + + my $result = test::sqlite_table::test_table_source_select('column1 is not null',2,3,$sort_config); + assert((scalar @$result) == 1,'source query failed'); + +} + +sub test_select_source_csv { + + my $result = test::csv_table::test_table_source_select('column1 is not null',2,1,$sort_config); + assert((scalar @$result) == 1,'source query failed'); + +} + +sub test_select_source_mysql { + + my $result = test::mysql_table::test_table_source_select('column1 is not null',2,1,$sort_config); + assert((scalar @$result) == 1,'source query failed'); + +} + +sub test_select_local { + $ConnectorPool::test_db = 'sqlserver'; + _table_local_selects(); + $ConnectorPool::test_db = 'postgres'; + _table_local_selects(); + $ConnectorPool::test_db = 'oracle'; + _table_local_selects(); + $ConnectorPool::test_db = 'sqlite'; + _table_local_selects(); + $ConnectorPool::test_db = 'mysql'; + _table_local_selects(); + $ConnectorPool::test_db = 'csv'; + _table_local_selects(); + + $ConnectorPool::test_db = 'mysql'; +} +sub _table_local_selects { + my $result = test::sqlserver_table::test_table_local_select('column1 is not null',2,1,$sort_config); + assert((scalar @$result) == 1,'local query failed'); + $result = test::postgres_table::test_table_local_select('column1 is not null',2,1,$sort_config); + assert((scalar @$result) == 1,'source query failed'); + $result = test::oracle_table::test_table_local_select('column1 is not null',2,1,$sort_config); + assert((scalar @$result) == 1,'local query failed'); + $result = test::sqlite_table::test_table_local_select('column1 is not null',2,1,$sort_config); + assert((scalar @$result) == 1,'source query failed'); + $result = test::csv_table::test_table_local_select('column1 is not null',2,1,$sort_config); + assert((scalar @$result) == 1,'source query failed'); + $result = test::mysql_table::test_table_source_select('column1 is not null',2,1,$sort_config); + assert((scalar @$result) == 1,'source query failed'); +} + +sub test_select_source_temp_sqlserver { + + my $result = test::sqlserver_table::test_table_source_select_temptable('column1 is not null',2,3,$sort_config); + assert((scalar @$result) == 1,'source query failed'); + +} + +sub test_select_source_temp_postgres { + + my $result = test::postgres_table::test_table_source_select_temptable('column1 is not null',2,3,$sort_config); + assert((scalar @$result) == 1,'source query failed'); + +} + +sub test_select_source_temp_oracle { + + for (my $i = 0; $i < 10; $i++) { + my $result = test::oracle_table::test_table_source_select_temptable('column1 is not null',0,1,$sort_config); + assert((scalar @$result) == 1,'source query failed'); + } + +} + +sub test_select_source_temp_sqlite { + + my $result = test::sqlite_table::test_table_source_select_temptable('column1 is not null',2,3,$sort_config); + assert((scalar @$result) == 1,'source query failed'); + +} + +#not supported +#sub test_select_source_temp_csv { +# +# +#} + +sub test_select_source_temp_mysql { + + my $result = test::mysql_table::test_table_source_select_temptable('column1 is not null',2,1,$sort_config); + assert((scalar @$result) == 1,'source query failed'); + +} + +sub tear_down { + +} + +create_suite(); +run_suite(); + +destroy_dbs(); + +exit; \ No newline at end of file diff --git a/Projects/t/test_service.pl b/Projects/t/test_service.pl new file mode 100755 index 0000000..09ce996 --- /dev/null +++ b/Projects/t/test_service.pl @@ -0,0 +1,347 @@ +# gearman service layer test + +use strict; + +## no critic + +use LoadCLIConfig; + +use Logging; + +use Test::Unit::Procedural; + +use Service::TestService; +use ServiceProxy qw(new_async_do); + +use Serialization qw( + $format_xml + $format_yaml + $format_json + $format_php + $format_perl +); + +my $service1; +my $service2; +my $service3; + + my $service = test::TestService->new(); + my $proxy = ServiceProxy->new(); + #$service1 = test::TestService->new(); + #$service2 = test::TestService->new(); + #$service3 = test::TestService->new(); + + +sub set_up { + + #set_project(yearmonth2projecttag($download_year,$download_month)); +# $service = test::TestService->new(); +# $proxy = ServiceProxy->new(); + +} + + +sub test_roundtrip_do { + + my $data = {}; + + for (my $i = 0; $i < 10; $i++) { + $data->{$i} = 'roundtrip test ' . $i; + my $input = [ $data, $i ]; + my $output = $proxy->do('roundtrip',\&on_error,$input); + print $output->[0]->{$output->[1]} . "\n"; + assert($output->[0]->{$output->[1]} eq $data->{$i},'service do roundtrip failed'); + } + +} + +sub test_roundtrip_json { + $service->stop(); + $service->{serialization_format} = $format_json; + $proxy->{serialization_format} = $format_json; + $service->start(); + + my $data = {}; + + for (my $i = 0; $i < 10; $i++) { + $data->{$i} = 'roundtrip test ' . $i; + my $input = [ $data, $i ]; + my $output = $proxy->do('roundtrip',\&on_error,$input); + print $output->[0]->{$output->[1]} . "\n"; + assert($output->[0]->{$output->[1]} eq $data->{$i},'service do roundtrip failed'); + } + $service->stop(); + $service->{serialization_format} = undef; + $proxy->{serialization_format} = undef; + $service->start(); +} + +sub test_roundtrip_yaml { + $service->stop(); + $service->{serialization_format} = $format_yaml; + $proxy->{serialization_format} = $format_yaml; + $service->start(); + + my $data = {}; + + for (my $i = 0; $i < 10; $i++) { + $data->{$i} = 'roundtrip test ' . $i; + my $input = [ $data, $i ]; + my $output = $proxy->do('roundtrip',\&on_error,$input); + print $output->[0]->{$output->[1]} . "\n"; + assert($output->[0]->{$output->[1]} eq $data->{$i},'service do roundtrip failed'); + } + $service->stop(); + $service->{serialization_format} = undef; + $proxy->{serialization_format} = undef; + $service->start(); +} + +sub Xtest_roundtrip_php { + $service->stop(); + $service->{serialization_format} = $format_php; + $proxy->{serialization_format} = $format_php; + $service->start(); + + my $data = {}; + + for (my $i = 0; $i < 10; $i++) { + $data->{$i} = 'roundtrip test ' . $i; + my $input = [ $data, $i ]; + my $output = $proxy->do('roundtrip',\&on_error,$input); + print $output->[0]->{$output->[1]} . "\n"; + assert($output->[0]->{$output->[1]} eq $data->{$i},'service do roundtrip failed'); + } + $service->stop(); + $service->{serialization_format} = undef; + $proxy->{serialization_format} = undef; + $service->start(); +} + +sub test_roundtrip_xml { + $service->stop(); + $service->{serialization_format} = $format_xml; + $proxy->{serialization_format} = $format_xml; + $service->start(); + + my $data = {}; + + for (my $i = 0; $i < 10; $i++) { + $data->{$i} = 'roundtrip test ' . $i; + my $input = [ $data, $i ]; + my $output = $proxy->do('roundtrip',\&on_error,$input); + print $output->[0]->{$output->[1]} . "\n"; + assert($output->[0]->{$output->[1]} eq $data->{$i},'service do roundtrip failed'); + } + $service->stop(); + $service->{serialization_format} = undef; + $proxy->{serialization_format} = undef; + $service->start(); +} + +sub test_roundtrip_perl { + $service->stop(); + $service->{serialization_format} = $format_perl; + $proxy->{serialization_format} = $format_perl; + $service->start(); + + my $data = {}; + + for (my $i = 0; $i < 10; $i++) { + $data->{$i} = 'roundtrip test ' . $i; + my $input = [ $data, $i ]; + my $output = $proxy->do('roundtrip',\&on_error,$input); + print $output->[0]->{$output->[1]} . "\n"; + assert($output->[0]->{$output->[1]} eq $data->{$i},'service do roundtrip failed'); + } + $service->stop(); + $service->{serialization_format} = undef; + $proxy->{serialization_format} = undef; + $service->start(); +} + +sub test_noop_do { + + #my $data = {}; + + for (my $i = 0; $i < 10; $i++) { + #$data->{$i} = 'roundtrip test ' . $i; + #my $input = [ $data, $i ]; + my $output = $proxy->do('noop',\&on_error); + #print $output->[0]->{$output->[1]} . "\n"; + assert(!defined $output,'service do noop failed'); + } + +} + +sub test_exception_do { + + #my $data = {}; + + for (my $i = 0; $i < 10; $i++) { + #$data->{$i} = 'roundtrip test ' . $i; + #my $input = [ $data, $i ]; + my $exception = undef; + my $output = $proxy->do('exception',sub { $exception = shift; }); + #print $output->[0]->{$output->[1]} . "\n"; + assert(length($exception) > 0,'service do exception failed'); + } + +} + +sub test_sleep_roundtrip_do { + + my $proxy = ServiceProxy->new(undef,1.5); + + my $data = {}; + + for (my $i = 0; $i < 10; $i++) { + $data->{$i} = 'sleep roundtrip test ' . $i; + my $input = [ $data, $i ]; + my $output = $proxy->do('sleeproundtrip',\&on_error,1,$input); + print $output->[0]->{$output->[1]} . "\n"; + assert($output->[0]->{$output->[1]} eq $data->{$i},'service do sleep roundtrip failed'); + } + +} + +sub test_sleep_roundtrip_do_async1 { + + #my $service = test::TestService->new(); + my $proxy = ServiceProxy->new(); + + my $data = {}; + my $output = undef; + + for (my $i = 0; $i < 3; $i++) { + $data->{$i} = 'roundtrip test ' . $i; + my $input = [ $data, $i ]; + if ($i > 0) { + $proxy->wait(3); + print $output->[0]->{$output->[1]} . "\n"; + assert($output->[0]->{$output->[1]} eq $data->{$i - 1},'service do async roundtrip failed'); + $output = undef; + } + assert($proxy->do_async('sleeproundtrip',sub { $output = shift; },\&on_error,2,$input),'service do async failed'); + + } + #$proxy->wait(); + +} + +sub test_sleep_roundtrip_do_async2 { + + my $data = {}; + my @proxies = (); + + my $on_complete = sub { my $output = shift; + print $output->[0]->{$output->[1]} . "\n"; + #assert($output->[0]->{$output->[1]} eq $data->{$i},'service do async roundtrip failed'); + }; + + for (my $i = 0; $i < 10; $i++) { + $data->{$i} = 'roundtrip test ' . $i; + my $input = [ $data, $i ]; + #if ($i > 0) { + # $proxy->wait(); + # print $output->[0]->{$output->[1]} . "\n"; + #assert($output->[0]->{$output->[1]} eq $data->{$i - 1},'service do async roundtrip failed'); + # $output = undef; + #} + #my $proxy; + #if ($i % 3 == 0) { + # $proxy = $proxy1; + #} elsif ($i % 3 == 1) { + # $proxy = $proxy2; + #} elsif ($i % 3 == 1) { + # $proxy = $proxy3; + #} + + my $proxy = new_async_do('sleeproundtrip', $on_complete, \&on_error, 0, $input); #, + #sub { + #print shift . "\n"; + ##assert(0,'on_error: ' . shift); + #}, + #0,$input); + assert(defined $proxy,'proxy not created'); + #$proxy->wait(); + push(@proxies, $proxy); + + } + + + + #undef @proxies; + #$service->stop(); + #$proxy->wait(); + +} + +sub test_exception_do_async { + + my $data = {}; + my @proxies = (); + + my $on_error = sub { my $exception = shift; + print $exception . "\n"; + assert(length($exception) > 0,'service do async roundtrip failed'); + }; + + for (my $i = 0; $i < 10; $i++) { + $data->{$i} = 'roundtrip test ' . $i; + my $input = [ $data, $i ]; + #if ($i > 0) { + # $proxy->wait(); + # print $output->[0]->{$output->[1]} . "\n"; + #assert($output->[0]->{$output->[1]} eq $data->{$i - 1},'service do async roundtrip failed'); + # $output = undef; + #} + #my $proxy; + #if ($i % 3 == 0) { + # $proxy = $proxy1; + #} elsif ($i % 3 == 1) { + # $proxy = $proxy2; + #} elsif ($i % 3 == 1) { + # $proxy = $proxy3; + #} + + my $proxy = new_async_do('sleeproundtrip', undef, $on_error, 0, $input); #, + #sub { + #print shift . "\n"; + ##assert(0,'on_error: ' . shift); + #}, + #0,$input); + assert(defined $proxy,'proxy not created'); + #$proxy->wait(); + push(@proxies, $proxy); + + } + + + + #undef @proxies; + #$service->stop(); + #$proxy->wait(); + +} + +sub on_error { + print shift . "\n"; + #assert(0,'on_error: ' . shift); +} + +sub tear_down { + +#undef $service; +#undef $proxy; + +} + +create_suite(); +run_suite(); + +#destroy_dbs(); +undef $service; +undef $proxy; + +exit; \ No newline at end of file diff --git a/RandomString.pm b/RandomString.pm new file mode 100644 index 0000000..85cbd6c --- /dev/null +++ b/RandomString.pm @@ -0,0 +1,287 @@ +package RandomString; +use strict; + +## no critic + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw( + check_passwordstring + createsalt + createpassworddummy + createtmpstring + + $passwordokmessage + $passwordtooshortviolationmessage + $passwordtoolongviolationmessage + $passwordinvalidcharfoundviolationmessage + $passwordcharacterminoccurenceviolationmessage + $passwordcharactermaxoccurenceviolationmessage + + $smallletterscharacterclass + $capitalletterscharacterclass + $digitscharacterclass + $umlautscharacterclass + $altsymbolscharacterclass + $symbolscharacterclass + + $characterclasses +); + +our $maxpasswordlength = 30; +#our $maxpasswordfieldsize = 36; +our $minpasswordlength = 6; +our $saltlength = 8; +our $passworddummylength = 8; + +our $smallletterscharacterclass = 1; +our $capitalletterscharacterclass = 2; +our $digitscharacterclass = 3; +our $umlautscharacterclass = 4; +our $altsymbolscharacterclass = 5; +our $symbolscharacterclass = 6; + +our $characterclasses = { $smallletterscharacterclass => ['a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z'], + $capitalletterscharacterclass => ['A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z'], + $digitscharacterclass => ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9'], + $umlautscharacterclass => ['�', '�', '�', '�', '�', '�', '�'], + $altsymbolscharacterclass => ['�','�','@','~'], + $symbolscharacterclass => ['^','�','!','"','�','$','%','&','/','{','(','[',']',')','}','=','?','\\','�','`','+','*','-','#','\'','-','_','.',':',';','|','<','>'] + }; + +my $passworddummycharacterset = [$smallletterscharacterclass,$digitscharacterclass]; +my $passwordcharacterset = [$smallletterscharacterclass,$capitalletterscharacterclass,$digitscharacterclass,$umlautscharacterclass,$altsymbolscharacterclass,$symbolscharacterclass]; +my $saltcharacterset = [$smallletterscharacterclass,$capitalletterscharacterclass,$digitscharacterclass]; +my $tmpcharacterset = [$capitalletterscharacterclass,$digitscharacterclass]; + +my $passworddummycharacterminoccurences = { + $smallletterscharacterclass => 0, + $digitscharacterclass => 0}; +my $passworddummycharactermaxoccurences = { + $smallletterscharacterclass => $maxpasswordlength, + $digitscharacterclass => $maxpasswordlength}; +my $passwordcharacterminoccurences = { + $smallletterscharacterclass => 0, + $capitalletterscharacterclass => 0, + $digitscharacterclass => 0, + $umlautscharacterclass => 0, + $altsymbolscharacterclass => 0, + $symbolscharacterclass => 0}; +my $passwordcharactermaxoccurences = { + $smallletterscharacterclass => $maxpasswordlength, + $capitalletterscharacterclass => $maxpasswordlength, + $digitscharacterclass => $maxpasswordlength, + $umlautscharacterclass => $maxpasswordlength, + $altsymbolscharacterclass => $maxpasswordlength, + $symbolscharacterclass => $maxpasswordlength}; +my $saltcharacterminoccurences = { + $smallletterscharacterclass => 2, + $capitalletterscharacterclass => 2, + $digitscharacterclass => 2}; +my $saltcharactermaxoccurences = { + $smallletterscharacterclass => $saltlength, + $capitalletterscharacterclass => $saltlength, + $digitscharacterclass => $saltlength}; +my $tmpcharacterminoccurences = {}; +my $tmpcharactermaxoccurences = {}; + +our $passwordokmessage = 1; +our $passwordtooshortviolationmessage = -1; +our $passwordtoolongviolationmessage = -2; +our $passwordinvalidcharfoundviolationmessage = -3; +our $passwordcharacterminoccurenceviolationmessage = -4; +my $passwordcharacterminoccurenceviolationmessages = { + $smallletterscharacterclass => 'PasswordCharacterMinOccurenceViolation1Message', + $capitalletterscharacterclass => 'PasswordCharacterMinOccurenceViolation2Message', + $digitscharacterclass => 'PasswordCharacterMinOccurenceViolation3Message', + $umlautscharacterclass => 'PasswordCharacterMinOccurenceViolation4Message', + $altsymbolscharacterclass => 'PasswordCharacterMinOccurenceViolation5Message', + $symbolscharacterclass => 'PasswordCharacterMinOccurenceViolation6Message'}; +our $passwordcharactermaxoccurenceviolationmessage = -5; +my $passwordcharactermaxoccurenceviolationmessages = { + $smallletterscharacterclass => 'PasswordCharacterMaxOccurenceViolation1Message', + $capitalletterscharacterclass => 'PasswordCharacterMaxOccurenceViolation2Message', + $digitscharacterclass => 'PasswordCharacterMaxOccurenceViolation3Message', + $umlautscharacterclass => 'PasswordCharacterMaxOccurenceViolation4Message', + $altsymbolscharacterclass => 'PasswordCharacterMaxOccurenceViolation5Message', + $symbolscharacterclass => 'PasswordCharacterMaxOccurenceViolation6Message'}; +my $passwordviolationmessages = { + $passwordokmessage => 'PasswordOKMessage', + $passwordtooshortviolationmessage => 'PasswordTooShortViolationMessage', + $passwordtoolongviolationmessage => 'PasswordTooLongViolationMessage', + $passwordinvalidcharfoundviolationmessage => 'PasswordInvalidCharFoundViolationMessage', + $passwordcharacterminoccurenceviolationmessage => '', + $passwordcharactermaxoccurenceviolationmessage => ''}; + +sub randstring { + + my ($lengthofstring,$characterclasses_ref,$characterset_ref,$minoccurences_ref,$maxoccurences_ref) = @_; + + my $output = ''; + + if ($lengthofstring > 0) { + + my %classesusedcount = (); + my %classesrequiredcount = (); + my $classesrequiredcountsum = 0; + + my @characterset = @$characterset_ref; + + foreach my $characterclassid (@characterset) { + + if (exists $minoccurences_ref->{$characterclassid}) { + $classesrequiredcount{$characterclassid} = $minoccurences_ref->{$characterclassid}; + $classesrequiredcountsum += $minoccurences_ref->{$characterclassid}; + } else { + $classesrequiredcount{$characterclassid} = 0; + } + $classesusedcount{$characterclassid} = 0; + + } + + for (my $i = 0; $i < $lengthofstring; $i += 1) { + + my %availablerandcharacters = (); + my @currentcharacterset = (); + my $charactersleft = $lengthofstring - $i; + + foreach my $characterclassid (@characterset) { + + if ($classesrequiredcountsum >= $charactersleft) { + if (exists $minoccurences_ref->{$characterclassid} and + $classesrequiredcount{$characterclassid} > 0) { + + my @characters = @{$characterclasses_ref->{$characterclassid}}; + my $characterindex = int(rand($#characters + 1) + 1); + $availablerandcharacters{$characterclassid} = $characters[$characterindex - 1]; + push @currentcharacterset,$characterclassid; + + } + } else { + if ((!exists $maxoccurences_ref->{$characterclassid}) or + (exists $maxoccurences_ref->{$characterclassid} and + $classesusedcount{$characterclassid} < $maxoccurences_ref->{$characterclassid})) { + + my @characters = @{$characterclasses_ref->{$characterclassid}}; + my $characterindex = int(rand($#characters + 1) + 1); + $availablerandcharacters{$characterclassid} = $characters[$characterindex - 1]; + push @currentcharacterset,$characterclassid; + + } + } + } + + my $charactersetclassindex = int(rand(scalar @currentcharacterset) + 1); + my $characterclassid = $currentcharacterset[$charactersetclassindex - 1]; + $classesrequiredcount{$characterclassid}--; + if (exists $minoccurences_ref->{$characterclassid}) { + $classesrequiredcountsum--; + } + + $classesusedcount{$characterclassid}++; + + $output .= $availablerandcharacters{$characterclassid}; + + } + } + + return $output; + +} + +sub check_passwordstring { + + my ($password) = @_; + + if (length($password) < $minpasswordlength) { + return ($passwordtooshortviolationmessage, + $passwordviolationmessages->{$passwordtooshortviolationmessage}); + } elsif (length($password) > $maxpasswordlength) { + return ($passwordtoolongviolationmessage, + $passwordviolationmessages->{$passwordtoolongviolationmessage}); + } + + my $validcharcount = 0; + + foreach my $characterclassid (@$passwordcharacterset) { + + my @characters = @{$characterclasses->{$characterclassid}}; + my $occurencecount = 0; + + foreach my $character (@characters) { + $occurencecount += _substringoccurence($password,$character); + } + + $validcharcount += $occurencecount; + + if (exists $passwordcharacterminoccurences->{$characterclassid} and + $occurencecount < $passwordcharacterminoccurences->{$characterclassid}) { + return ($passwordcharacterminoccurenceviolationmessage, + $passwordcharacterminoccurenceviolationmessages->{$characterclassid}); + } elsif (exists $passwordcharactermaxoccurences->{$characterclassid} and + $occurencecount > $passwordcharactermaxoccurences->{$characterclassid}) { + return ($passwordcharactermaxoccurenceviolationmessage, + $passwordcharactermaxoccurenceviolationmessages->{$characterclassid}); + } + + } + + if ($validcharcount < length($password)) { + return ($passwordinvalidcharfoundviolationmessage, + $passwordviolationmessages->{$passwordinvalidcharfoundviolationmessage}); + } + + return ($passwordokmessage, + $passwordviolationmessages->{$passwordokmessage}); + +} + +sub _substringoccurence { + my ($inputstring,$substring) = @_; + my $result = 0; + my $position = 0; + my $posincrement = length($substring); + if ($posincrement > 0) { + do { + $position = index($inputstring,$substring,$position); + if ($position >= 0) { + $result += 1; + $position += $posincrement; + } + } while ($position >= 0); + } + return $result; +} + +sub createsalt { + + return randstring($saltlength, + $characterclasses, + $saltcharacterset, + $saltcharacterminoccurences, + $saltcharactermaxoccurences); + +} + +sub createpassworddummy { + + return randstring($passworddummylength, + $characterclasses, + $passworddummycharacterset, + $passworddummycharacterminoccurences, + $passworddummycharactermaxoccurences); + +} + +sub createtmpstring { + + my $lengthofstring = shift; + return randstring($lengthofstring, + $characterclasses, + $tmpcharacterset, + $tmpcharacterminoccurences, + $tmpcharactermaxoccurences); + +} + +1; \ No newline at end of file diff --git a/Serialization.pm b/Serialization.pm new file mode 100755 index 0000000..0d5dec0 --- /dev/null +++ b/Serialization.pm @@ -0,0 +1,213 @@ +package Serialization; +use strict; + +## no critic + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw( + serialize + deserialize + serialize_storable + deserialize_storable + serialize_xml + deserialize_xml + serialize_yaml + deserialize_yaml + serialize_json + deserialize_json + serialize_php + deserialize_php + serialize_perl + deserialize_perl + serialize_storable_base64 + deserialize_storable_base64 + + $format_xml + $format_yaml + $format_json + $format_php + $format_perl + $format_storable_base64 +); + #$format_storable + +#our $format_storable = 0; +our $format_xml = 1; +our $format_yaml = 2; +our $format_json = 3; +our $format_php = 4; +our $format_perl = 5; +our $format_storable_base64 = 6; + +use MIME::Base64 qw(encode_base64 decode_base64); + +#http://blogs.perl.org/users/steven_haryanto/2010/09/comparison-of-perl-serialization-modules.html +use Storable; # qw( nfreeze thaw ); + +use JSON::XS; # qw(encode_json decode_json); + +use Data::Dump; # qw(dump); +$Data::Dump::INDENT = ' '; +$Data::Dump::TRY_BASE64 = 0; + +#use YAML::Syck qw(Dump Load); +#$YAML::Syck::ImplicitTyping = 1; + +use YAML::XS; # qw(Dump Load); +$YAML::XS::UseCode = 0; +$YAML::XS::DumpCode = 0; +$YAML::XS::LoadCode = 0; +$YAML::XS::QuoteNumericStrings = 1; + +use XML::Dumper 0.81; +my $errorcontext = undef; #undef to disable +my $protocolencoding = 'ISO-8859-1'; + +use PHP::Serialization; #qw(serialize unserialize); + +#encrypted: +#use Data::Serializer; +#my $serializer = Data::Serializer->new(); +#$serializer = Data::Serializer->new( +# serializer => 'Storable', +# digester => 'MD5', +# cipher => 'DES', +# secret => 'my secret', +# compress => 1, +# ); + +#$serialized = $obj->serialize({a => [1,2,3],b => 5}); +#$deserialized = $obj->deserialize($serialized); + + +sub serialize { + my ($input_ref,$format) = @_; + if ($format == $format_xml) { + return serialize_xml($input_ref); + } elsif ($format == $format_yaml) { + return serialize_yaml($input_ref); + } elsif ($format == $format_json) { + return serialize_json($input_ref); + } elsif ($format == $format_php) { + return serialize_php($input_ref); + } elsif ($format == $format_perl) { + return serialize_perl($input_ref); + } elsif ($format == $format_storable_base64) { + return serialize_storable_base64($input_ref); + } else { #$format_storable + return serialize_storable($input_ref); + } +} + +sub deserialize { + my ($input_ref,$format) = @_; + if ($format == $format_xml) { + return deserialize_xml($input_ref); + } elsif ($format == $format_yaml) { + return deserialize_yaml($input_ref); + } elsif ($format == $format_json) { + return deserialize_json($input_ref); + } elsif ($format == $format_php) { + return deserialize_php($input_ref); + } elsif ($format == $format_perl) { + return deserialize_perl($input_ref); + } elsif ($format == $format_storable_base64) { + return deserialize_storable_base64($input_ref); + } else { #$format_storable + return deserialize_storable($input_ref); + } +} + +sub serialize_storable { + my $input_ref = shift; + return Storable::nfreeze($input_ref); +} +sub deserialize_storable { + my $input_ref = shift; + return Storable::thaw($input_ref); +} + +sub serialize_storable_base64 { + my $input_ref = shift; + return encode_base64(Storable::nfreeze($input_ref),''); +} +sub deserialize_storable_base64 { + my $input_ref = shift; + return Storable::thaw(decode_base64($input_ref)); +} + +sub _get_xml_dumper { + my $xml_dumper; + my %xml_parser_params = (); + if ($errorcontext) { + $xml_parser_params{ErrorContext} = $errorcontext; + #$xml_dumper = XML::Dumper->new(ErrorContext => $errorcontext,ProtocolEncoding => $protocolencoding); + #} else { + #$xml_dumper = XML::Dumper->new(ProtocolEncoding => $protocolencoding); + } + $xml_parser_params{ProtocolEncoding} = $protocolencoding; + $xml_dumper = XML::Dumper->new(%xml_parser_params); + #$xml_dumper->{xml_parser_params} = \%xml_parser_params; + $xml_dumper->dtd(); + + return $xml_dumper; +} + +sub serialize_xml { + my $input_ref = shift; + return _get_xml_dumper()->pl2xml($input_ref); +} + +sub deserialize_xml { + my $input_ref = shift; + return _get_xml_dumper()->xml2pl($input_ref); +} + +sub serialize_json { + my $input_ref = shift; + return JSON::XS::encode_json($input_ref); +} + +sub deserialize_json { + my $input_ref = shift; + return JSON::XS::decode_json($input_ref); +} + +sub serialize_yaml { + my $input_ref = shift; + return YAML::XS::Dump($input_ref); +} + +sub deserialize_yaml { + my $input_ref = shift; + return YAML::XS::Load($input_ref); +} + + +sub serialize_php { + my $input_ref = shift; + return PHP::Serialization::serialize($input_ref); +} + +sub deserialize_php { + my $input_ref = shift; + return PHP::Serialization::unserialize($input_ref); +} + +sub serialize_perl { + my $input_ref = shift; + return Data::Dump::dump($input_ref); +} + +sub deserialize_perl { + my $input_ref = shift; + my $data = eval $input_ref; + if ($@) { + die($@); + } else { + return $data; + } +} + +1; \ No newline at end of file diff --git a/Service.pm b/Service.pm new file mode 100755 index 0000000..fd12039 --- /dev/null +++ b/Service.pm @@ -0,0 +1,293 @@ +# service layer backend + +package Service; +use strict; + +## no critic + +use threads qw(yield); +use threads::shared; + +use Globals qw( + @jobservers + $jobnamespace +); + +use Logging qw( + getlogger + servicedebug + serviceinfo +); +use LogError qw( + serviceerror + servicewarn + notimplementederror +); + +use Utils qw(threadid); +use Serialization qw(serialize deserialize); + +use Encode qw(encode_utf8); + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(); #get_tableidentifier); + +my $logger = getlogger(__PACKAGE__); + +use Gearman::Worker; +#use Time::HiRes qw(usleep); +use Time::HiRes qw(sleep); + +my $sleep_secs_default = 0.1; # = 0.1; + +my $instance_counts = {}; + +sub new { + + #my $class = shift; + #my $self = bless {}, $class; + my ($class,$functions,$derived_class,$serialization_format,$no_autostart) = @_; + my $self = bless {}, $derived_class; + + $self->{worker} = undef; + $self->{functions} = $functions; + #$self->_register_functions(); + + my $running = 0; + $self->{running_ref} = share($running); + $self->{thread} = undef; + $self->{create_tid} = threadid(); + $self->{tid} = $self->{create_tid}; + $self->{worker_tid} = undef; + $self->{sleep_secs} = $sleep_secs_default; + $self->{serialization_format} = $serialization_format; + + my $identifier = ref $self; + my $instance_count; + if (exists $instance_counts->{$identifier}) { + $instance_count = $instance_counts->{$identifier}; + } else { + $instance_count = 0; + } + $self->{instance} = $instance_count; + $instance_count++; + $instance_counts->{$identifier} = $instance_count; + + if (not $no_autostart) { + $self->start(); + } + + #$self = share($self); + #autostart?? + + return $self; + +} + +sub identifier { + my $self = shift; + return (ref $self) . '(' . $self->{instance} . ')'; +} + +sub _register_functions { + + my $self = shift; + my $functions = $self->{functions}; + + if (defined $functions and ref $functions eq 'HASH') { + my $count = 0; + foreach my $name (keys %$functions) { + my $code = $functions->{$name}; + if (defined $code and ref $code eq 'CODE') { + $self->{worker}->register_function($name, + sub { + #servicedebug($self,(ref $self) . ' connector destroyed',$logger); + #my $resultref = serialize(&$code(deserialize($_[0]->argref()))); + #servicedebug($self,(ref $self) . ' connector destroyed',$logger); + servicedebug($self,'invoking \'' . $name . '\', args length: ' . length(encode_utf8($_[0]->arg())),$logger); + my $arg = deserialize($_[0]->arg(),$self->{serialization_format}); + my (@ret) = &$code(@$arg); + my $result = serialize(\@ret,$self->{serialization_format}); + servicedebug($self,'returning from \'' . $name . '\', result length: ' . length(encode_utf8($result)),$logger); + #$_[0]->set_status($numerator, $denominator);??? + return $result; + } + ); + servicedebug($self,'function \'' . $name . '\' registered',$logger); + $count++; + } else { + servicewarn($self,'cannot register function ' . $name,$logger); + } + } + serviceinfo($self,$count . ' functions registered at job servers ' . join(',',@jobservers),$logger); + } else { + serviceerror($self,'no functions to register',$logger); + } + +} + +sub _unregister_functions { + + my $self = shift; + my $functions = $self->{functions}; + + if (defined $functions and ref $functions eq 'HASH') { + my $count = 0; + foreach my $name (keys %$functions) { + $self->{worker}->unregister_function($name); + servicedebug($self,'function \'' . $name . '\' unregistered',$logger); + $count++; + } + serviceinfo($self,$count . ' functions unregistered from job servers ' . join(',',@jobservers),$logger); + } else { + serviceerror($self,'no functions to unregister',$logger); + } + +} + +sub _worker { + + my $context = shift; + #my $tid = threadid(); + my $service = $context->{service}; + #${$context->{service}->{tid_ref}} = $tid; + $service->{worker_tid} = threadid(); + $service->{tid} = $service->{worker_tid}; + servicedebug($service,'worker thread ' . $service->{worker_tid} . ' started',$logger); + my $running_ref = $service->{running_ref}; + + my $stop_if = sub { + lock($running_ref); + #print join ',',@_ . "\n"; + if (not $$running_ref) { + servicedebug($service,'shutting down work and worker thread ' . $service->{worker_tid} . ' ...',$logger); + return 1; + } else { + return 0; + } + }; + + my %worker_opts = (on_start => sub { $service->_on_start(@_); }, + on_complete => sub { $service->_on_complete(@_); }, + on_fail => sub { $service->_on_fail(@_); }, + stop_if => $stop_if ); + + $service->{worker} = Gearman::Worker->new(( job_servers => \@jobservers, + prefix => $jobnamespace)); + $service->_register_functions(); + + while (not &$stop_if()) { + $service->{worker}->work(%worker_opts); + if ($service->{sleep_secs} > 0) { + sleep($service->{sleep_secs}); + } else { + yield(); + } + } + $service->_unregister_functions(); + #servicedebug($service,'worker thread ' . $service->{worker_tid} . ' shutting down',$logger); + #threads->exit(); +} + +sub start { + + my $self = shift; + if ($self->_is_create_thread()) { + my $running_ref = $self->{running_ref}; + my $startup = 0; + { + lock($running_ref); + if (not $$running_ref) { + $$running_ref = 1; + $startup = 1; + } + } + if ($startup) { + servicedebug($self,'starting worker thread ...',$logger); + $self->{thread} = threads->create(\&_worker, + + { service => $self, + #logger => $logger, + } + + ); + #$self->{worker_tid} = $self->{thread}->tid(); + } else { + servicewarn($self,'worker thread already running?',$logger); + } + + } + +} + +sub stop { + + my $self = shift; + if ($self->_is_create_thread()) { + my $running_ref = $self->{running_ref}; + my $shutdown = 0; + { + lock($running_ref); + if ($$running_ref) { + $$running_ref = 0; + $shutdown = 1; + } + } + if ($shutdown) { + servicedebug($self,'stopping worker thread ...',$logger); + $self->{thread}->join(); + $self->{thread} = undef; + $self->{worker_tid} = undef; + servicedebug($self,'worker thread joined',$logger); + } else { + servicewarn($self,'thread already stopped',$logger); + } + } + +} + +sub _on_start { + my $self = shift; + if ($self->_is_worker_thread()) { + servicedebug($self,'on_start',$logger); + } +} + +sub _on_complete { + my $self = shift; + if ($self->_is_worker_thread()) { + servicedebug($self,'on_complete',$logger); + } +} + +sub _on_fail { + my $self = shift; + if ($self->_is_worker_thread()) { + servicedebug($self,'on_fail',$logger); + } +} + +sub DESTROY { + + my $self = shift; + #print "DESTROY is worker: " . $self->_is_worker_thread() . "\n"; + if ($self->_is_create_thread()) { + servicedebug($self,'destroying service ...',$logger); + $self->stop(); + servicedebug($self,(ref $self) . ' service destroyed',$logger); + } + +} + +sub _is_worker_thread { + my $self = shift; + return (defined $self->{worker_tid} and $self->{worker_tid} == threadid()); +} + +sub _is_create_thread { + my $self = shift; + return $self->{create_tid} == threadid(); +} + +1; \ No newline at end of file diff --git a/Service/TestService.pm b/Service/TestService.pm new file mode 100755 index 0000000..b1cf5da --- /dev/null +++ b/Service/TestService.pm @@ -0,0 +1,97 @@ +package Service::TestService; +use strict; + +## no critic + +use File::Basename; +use Cwd; +use lib Cwd::abs_path(File::Basename::dirname(__FILE__) . '/../'); + +use Logging qw(getlogger servicedebug); + +use Service; + +#use test::csv_table; # qw(test_table_bycolumn1); +#use test::mysql_table; +#use test::oracle_table; +#use test::postgres_table; +#use test::sqlite_table; +#use test::sqlserver_table; + +use Utils; # qw(create_guid); + +require Exporter; +our @ISA = qw(Exporter Service); +our @EXPORT_OK = qw( + roundtrip + sleep_seconds + noop + exception +); + +my $logger = getlogger(__PACKAGE__); + +my $functions = { + create_uuid => \&Utils::create_guid, + roundtrip => \&roundtrip, + noop => \&noop, + exception => \&exception, + sleeproundtrip => \&sleep_roundtrip, + #test_csv_table_bycolumn1 => \&test::csv_table::test_table_bycolumn1, + #test_mysql_table_bycolumn1 => \&test::mysql_table::test_table_bycolumn1, + #test_oracle_table_bycolumn1 => \&test::oracle_table::test_table_bycolumn1, + #test_postgres_table_bycolumn1 => \&test::postgres_table::test_table_bycolumn1, + #test_sqlite_table_bycolumn1 => \&test::sqlite_table::test_table_bycolumn1 +}; + +sub new { + + #my $class = shift; + #my $self = Service->new($functions,$class); + + #bless($self,$class); + + #return $self; + + my $self = Service->new($functions,@_); + servicedebug($self,__PACKAGE__ . ' service created',$logger); + return $self; + +} + +sub roundtrip { + return @_; + #my (@in) = @_; + ##my $error = 1/0; + #return @in; +} + +sub sleep_roundtrip { + sleep(shift); + return @_; +} + +sub noop { + +} + +sub exception { + return 1/0; +} + +#sub _on_start { +# my $self = shift; +# print "_on_start\n"; +#} + +#sub _on_complete { +# my $self = shift; +# print "_on_complete\n"; +#} + +#sub _on_fail { +# my $self = shift; +# print "_on_fail\n"; +#} + +1; \ No newline at end of file diff --git a/ServiceProxy.pm b/ServiceProxy.pm new file mode 100755 index 0000000..b9a16dd --- /dev/null +++ b/ServiceProxy.pm @@ -0,0 +1,507 @@ +# service layer backend + +package ServiceProxy; +use strict; + +## no critic + +use threads qw(yield); +use threads::shared; # qw(shared_clone); +use Thread::Queue; + +use Time::HiRes qw(sleep); + +use Globals qw( + @jobservers + $jobnamespace +); + +use Logging qw( + getlogger + servicedebug + serviceinfo +); +use LogError qw( + serviceerror + servicewarn + notimplementederror +); + +use Utils qw(threadid); +use Serialization qw(serialize deserialize); +use Encode qw(encode_utf8); + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(new_async_do new_do); + +my $logger = getlogger(__PACKAGE__); + +use Gearman::Client; +#sub RECEIVE_EXCEPTIONS { +# print "RECEIVE_EXCEPTIONS"; +# return 1; +#} +use Gearman::Task; + +my $timeout_secs_default = 0; +#my $try_timeout_secs_default = 0; +my $retry_count_default = 0; +my $high_priority_default = 0; + +my $block_destroy_default = 1; + +my $poll_interval_secs = 0.1; + +my $instance_count = 0; + +sub new { + + my $class = shift; + my $self = bless {}, $class; + my ($serialization_format,$timeout_secs,$block_destroy) = @_; + + $self->{serialization_format} = $serialization_format; + $self->{client} = undef; + + $self->{timeout_secs} = ((defined $timeout_secs) ? $timeout_secs : $timeout_secs_default); + #$self->{try_timeout_secs} = $try_timeout_secs_default; + $self->{retry_count} = $retry_count_default; + $self->{high_priority} = $high_priority_default; + + $self->{block_destroy} = ((defined $block_destroy) ? $block_destroy : $block_destroy_default); + + $self->{arg} = undef; + #my $ret = undef; + $self->{ret} = undef; # = share($ret); + $self->{function} = undef; + #my $exception = undef; + $self->{exception} = undef; #share($exception); + $self->{on_error} = undef; + + $self->{on_complete} = undef; + $self->{on_fail} = undef; + $self->{on_status} = undef; + + my $async_running = 0; + $self->{async_running_ref} = share($async_running); + $self->{thread} = undef; + $self->{create_tid} = threadid(); + $self->{tid} = $self->{create_tid}; + $self->{wait_tid} = undef; + $self->{queue} = undef; + + $self->{instance} = $instance_count; + $instance_count++; + + #$self->{taskset} = undef; + #$self->{task} = undef; + + servicedebug($self,'service proxy created, job servers ' . join(',',@jobservers),$logger); + + return $self; + +} + +sub identifier { + my $self = shift; + return '(' . $self->{instance} . ') ' . (length($self->{function}) > 0 ? '\'' . $self->{function} . '\'' : __PACKAGE__); +} + +sub new_async_do { + #my ($function_name,$on_complete,$on_error,@args) = @_; + #my $serialization_format = shift; + #my $timeout_secs = shift; + #my $block_destroy = shift; + my $proxy = __PACKAGE__->new(); #$serialization_format,$timeout_secs,$block_destroy); + if ($proxy->do_async(@_)) { + return $proxy; + } + return undef; +} +sub new_do { + #my ($function_name,$on_complete,$on_error,@args) = @_; + #my $serialization_format = shift; + #my $timeout_secs = shift; + #my $block_destroy = shift; + my $proxy = __PACKAGE__->new(); #$serialization_format,$timeout_secs,$block_destroy); + return $proxy->do(@_); +} + +sub do_async { + my $self = shift; + my ($function_name,$on_complete,$on_error,@args) = @_; + + if ($self->_check_async_running($on_error,'do_async \'' . $function_name . '\' failed because do_async \'' . $self->{function} . '\' is waiting',1)) { + return 0; + } + + $self->{client} = undef; + + $self->{function} = $function_name; + $self->{ret} = undef; + $self->{exception} = undef; + + #$self->{taskset} = undef; + #$self->{task} = undef; + #$self->{thread} = undef; + #$self->{wait_tid} = undef; + + $self->{on_error} = $on_error; + $self->{on_complete} = $on_complete; + $self->{on_fail} = undef; + $self->{on_status} = undef; + + my $arg = serialize(\@args,$self->{serialization_format}); + $self->{arg} = \$arg; + + #if (not defined $self->{queue}) { + $self->{queue} = Thread::Queue->new(); + #} + + servicedebug($self,'start waiting do_async \'' . $function_name . '\', args length: ' . length(encode_utf8($arg)),$logger); + $self->{thread} = threads->create(\&_wait_thread, + + { proxy => $self, + #logger => $logger, + } + + ); + #$self->{wait_tid} = $self->{thread}->tid(); + #$self->{thread}->detach(); + + return 1; +} + +sub _get_task_opts { + my $self = shift; + return { + on_complete => undef, + on_fail => undef, + on_retry => undef, + on_status => undef, + on_exception => undef, + retry_count => $self->{retry_count}, + high_priority => $self->{high_priority}, + #timeout => $self->{timeout_secs} + }; +} + +sub _wait_thread { + + my $context = shift; + #my $tid = threadid(); + #${$context->{proxy}->{tid_ref}} = $tid; + my $proxy = $context->{proxy}; + #$proxy->{create_tid} = undef; + $proxy->{wait_tid} = threadid(); + $proxy->{tid} = $proxy->{wait_tid}; + servicedebug($proxy,'wait thread tid ' . $proxy->{tid} . ' started',$logger); + my $async_running_ref = $proxy->{async_running_ref}; + + my $task_opts = $proxy->_get_task_opts(); + $task_opts->{on_complete} = sub { $proxy->_on_complete(@_); }; + $task_opts->{on_fail} = sub { $proxy->_on_fail(@_); }; + $task_opts->{on_retry} = sub { $proxy->_on_retry(@_); }; + $task_opts->{on_status} = sub { $proxy->_on_status(@_); }; + $task_opts->{on_exception} = sub { $proxy->_on_exception(@_); }; + + $proxy->{client} = Gearman::Client->new(( job_servers => \@jobservers, + prefix => $jobnamespace, + exceptions => 1)); + + my $task = Gearman::Task->new($proxy->{function}, $proxy->{arg}, $task_opts); + if ($proxy->{timeout_secs} > 0) { + $task->timeout($proxy->{timeout_secs}); + } + #$proxy->{task} = $task; + + my $task_set = $proxy->{client}->new_task_set(); + #$proxy->{taskset} = $task_set; + $task_set->add_task($task); + + local $SIG{'KILL'} = sub { + servicedebug($proxy,'kill signal received, exiting wait thread tid ' . $proxy->{tid} . ' ...',$logger); + #{ + # lock $async_running_ref; + # $$async_running_ref = 0; + #} + threads->exit(); + + }; + + servicedebug($proxy,'start waiting (do_async) ...',$logger); + $task_set->wait(timeout => $task->timeout); + #return wantarray ? @{$self->{ret}} : $self->{ret}->[0]; + { + lock $async_running_ref; + $$async_running_ref = 0; + } + + servicedebug($proxy,'shutting down wait thread tid ' . $proxy->{tid} . ' ...',$logger); + #threads->exit(); +} + +sub do { + my $self = shift; + my ($function_name,$on_error,@args) = @_; + + if ($self->_check_async_running($on_error,'do \'' . $function_name . '\' failed because do_async \'' . $self->{function} . '\' is waiting',0)) { + return undef; + } + + $self->{function} = $function_name; + $self->{ret} = undef; + $self->{exception} = undef; + + #$self->{taskset} = undef; + #$self->{task} = undef; + #$self->{thread} = undef; + #$self->{wait_tid} = undef; + #$self->{queue} = undef; + + $self->{on_error} = $on_error; + $self->{on_complete} = undef; + $self->{on_fail} = undef; + $self->{on_status} = undef; + + my $arg = serialize(\@args,$self->{serialization_format}); + $self->{arg} = \$arg; + + my $task_opts = $self->_get_task_opts(); + $task_opts->{on_complete} = sub { $self->_on_complete(@_); }; + $task_opts->{on_fail} = sub { $self->_on_fail(@_); }; + $task_opts->{on_retry} = sub { $self->_on_retry(@_); }; + $task_opts->{on_status} = sub { $self->_on_status(@_); }; + $task_opts->{on_exception} = sub { $self->_on_exception(@_); }; + + $self->{client} = Gearman::Client->new(( job_servers => \@jobservers, + prefix => $jobnamespace, + exceptions => 1)); + + my $task = Gearman::Task->new($function_name, \$arg, $task_opts); + #$self->{task} = $task; + if ($self->{timeout_secs} > 0) { + $task->timeout($self->{timeout_secs}); + } + + my $task_set = $self->{client}->new_task_set(); + #$self->{taskset} = $task_set; + $task_set->add_task($task); + + servicedebug($self,'start waiting do \'' . $function_name . '\', args length: ' . length(encode_utf8($arg)),$logger); + $task_set->wait(timeout => $task->timeout); + return wantarray ? @{$self->{ret}} : $self->{ret}->[0]; + +} + +sub _enqueue_event { + my $self = shift; + my ($event,$args) = @_; + my $packet = {event => $event, + args => $args}; + $self->{queue}->enqueue($packet); + servicedebug($self,'event ' . $event . ' enqueued, ' . $self->{queue}->pending() . ' event(s) pending',$logger); +} + +sub _on_complete { + my $self = shift; + my $result_ref = shift; + if ($self->_is_wait_thread()) { + $self->_enqueue_event('_on_complete',[$result_ref]); + } elsif ($self->_is_create_thread()) { + my $result = $$result_ref; + $self->{ret} = deserialize($result,$self->{serialization_format}); + servicedebug($self,'on_complete event received, result length: ' . length(encode_utf8($result)),$logger); + if (defined $self->{on_complete} and ref $self->{on_complete} eq 'CODE') { + &{$self->{on_complete}}(@{$self->{ret}}); + } + } + + +} + +sub _on_fail { + my $self = shift; + if ($self->_is_wait_thread()) { + $self->_enqueue_event('_on_fail'); + } elsif ($self->_is_create_thread()) { + servicedebug($self,'on_fail event received',$logger); + if (defined $self->{on_fail} and ref $self->{on_fail} eq 'CODE') { + &{$self->{on_fail}}(); + } + } +} + +sub _on_retry { + my $self = shift; + if ($self->_is_wait_thread()) { + $self->_enqueue_event('_on_retry'); + } elsif ($self->_is_create_thread()) { + servicedebug($self,'on_retry event received',$logger); + if (defined $self->{on_retry} and ref $self->{on_retry} eq 'CODE') { + &{$self->{on_retry}}(); + } + } +} + +sub _on_status { + my $self = shift; + my ($numerator, $denominator) = @_; + if ($self->_is_wait_thread()) { + $self->_enqueue_event('_on_status',[$numerator, $denominator]); + } elsif ($self->_is_create_thread()) { + servicedebug($self,'on_status event received: ' . $numerator . '/' . $denominator,$logger); + if (defined $self->{on_status} and ref $self->{on_status} eq 'CODE') { + &{$self->{on_status}}($numerator, $denominator); + } + } +} + +sub _on_exception { + my $self = shift; + my $exception = shift; + $self->{exception} = $exception; + if ($self->_is_wait_thread()) { + $self->_enqueue_event('_on_exception',[$exception]); + #${$self->{async_running_ref}} = 0; + } elsif ($self->_is_create_thread()) { + if (defined $self->{on_error} and ref $self->{on_error} eq 'CODE') { + servicedebug($self,'on_exception event received: ' . $exception,$logger); + &{$self->{on_error}}($exception); + } else { + servicewarn($self,'on_exception event received: ' . $exception,$logger); + } + } +} + +sub _check_async_running { + my $self = shift; + my ($on_error,$message,$async_running) = @_; + if ($self->_is_create_thread()) { + my $async_running_ref = $self->{async_running_ref}; + lock $async_running_ref; + if ($$async_running_ref) { + if (defined $on_error and ref $on_error eq 'CODE') { + servicedebug($self,$message,$logger); + &$on_error($message); + } elsif (length($message) > 0) { + servicewarn($self,$message,$logger); + } + return 1; + } elsif ($async_running) { + $$async_running_ref = 1; + } + #} else { + # servicewarn($self,$message,$logger); + } + return 0; +} + +sub _get_stop_wait_thread { + my $self = shift; + my $timeout_secs = shift; + my $async_running; + { + my $async_running_ref = $self->{async_running_ref}; + lock $async_running_ref; + $async_running = $$async_running_ref; + } + if ((not $async_running and $self->{queue}->pending() == 0) or (defined $timeout_secs and $timeout_secs <= 0)) { + servicedebug($self,'stop waiting now (' . + ($async_running ? 'wait thread running' : 'wait thread not running') .', '. + $self->{queue}->pending() . ' event(s) queued, ' . + ((defined $timeout_secs) ? 'timeout in ' . sprintf('%.1f',$timeout_secs) . 'secs' : 'no timeout') . ')' + ,$logger); + return 1; + } + return 0; +} + +sub wait { + my $self = shift; + my $timeout_secs = shift; + if ($self->_is_create_thread()) { #$self->_check_async_running()) { + while (not $self->_get_stop_wait_thread($timeout_secs)) { + my $packet = $self->{queue}->dequeue_nb(); + if (defined $packet) { + my $event = $packet->{event}; + servicedebug($self,'event ' . $event . ' dequeued, ' . $self->{queue}->pending() . ' event(s) pending',$logger); + $self->$event(@{$packet->{args}}); + yield(); + } else { + if (defined $timeout_secs) { + $timeout_secs -= $poll_interval_secs; + } + sleep $poll_interval_secs; + } + } + my $killtread = 0; + { + my $async_running_ref = $self->{async_running_ref}; + lock $async_running_ref; + $killtread = ($$async_running_ref and (defined $timeout_secs and $timeout_secs <= 0)); + if ($killtread) { + servicedebug($self,'wait timeout exceeded (' . sprintf('%.1f',$timeout_secs) . '), killing wait thread ...',$logger); + $self->{thread}->kill('KILL')->detach(); + $$async_running_ref = 0; + } + } + if (not $killtread) { + $self->{thread}->join(); + servicedebug($self,'wait thread joined',$logger); + } + ##if ($self->{thread}) { + # if ($killtread) { + # servicedebug($self,'killing thread XX',$logger); + # $self->{thread}->kill('KILL')->detach(); + # } else { + # $self->{thread}->join(); + # servicedebug($self,'thread joined',$logger); + # } + ##} + $self->{queue} = undef; + $self->{thread} = undef; + $self->{wait_tid} = undef; + + #if ($killtread) { + # #servicedebug($self,'killing thread XX',$logger); + # #$self->{thread}->kill('KILL')->detach(); + #} else { + # $self->{thread}->join(); + # servicedebug($self,'thread joined',$logger); + #} + #$self->{queue} = undef; + #$self->{thread} = undef; + ##$self->{wait_tid} = undef; + #} + #} else { + # print "INGORE WAIT??????????\n"; + } +} + +sub DESTROY { + + my $self = shift; + if ($self->_is_create_thread()) { + servicedebug($self,'destroying proxy ...',$logger); + if ($self->{block_destroy}) { + $self->wait($self->{timeout_secs} > 0 ? $self->{timeout_secs} : undef); + } else { + $self->_check_async_running(undef,'do_async \'' . $self->{function} . '\' is still waiting'); + } + servicedebug($self,'proxy destroyed',$logger); + } +} + +sub _is_wait_thread { + my $self = shift; + return (defined $self->{wait_tid} and $self->{wait_tid} == threadid()); +} + +sub _is_create_thread { + my $self = shift; + return $self->{create_tid} == threadid(); +} + +1; \ No newline at end of file diff --git a/SqlConnector.pm b/SqlConnector.pm new file mode 100644 index 0000000..54266ec --- /dev/null +++ b/SqlConnector.pm @@ -0,0 +1,872 @@ +package SqlConnector; +use strict; + +## no critic + +use threads; +use threads::shared; + +use Globals qw($enablemultithreading); + +use Logging qw( + getlogger + dbdebug + dbinfo); +use LogError qw( + dberror + dbwarn + notimplementederror + sortconfigerror); + +use DBI; + +use Utils qw(threadid); +use Array qw(arrayeq); +use RandomString qw(createtmpstring); + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(get_tableidentifier); + +my $logger = getlogger(__PACKAGE__); + +my $temptable_randomstringlength = 4; + +sub new { + + my $class = shift; + my $self = bless {}, $class; + my $instanceid = shift; + my $cluster = shift; + + $self->{drh} = undef; + $self->{dbh} = undef; + + $self->{instanceid} = $instanceid; + $self->{tid} = threadid(); + + $self->{sth} = undef; + $self->{query} = undef; + $self->{params} = undef; + + $self->{temp_tables} = []; + + $self->{cluster} = $cluster; + + return $self; + +} + +sub _gettemptablename { + my $self = shift; + my $temp_tablename = 'TMP_TBL_' . $self->{tid} . '_'; + if (length($self->{instanceid}) > 0) { + $temp_tablename .= $self->{instanceid} . '_'; + } + $temp_tablename .= createtmpstring($temptable_randomstringlength); #$self->{temp_table_count}; + return $temp_tablename; +} + +sub instanceidentifier { + my $self = shift; + + $self->{instanceid} = shift if @_; + return $self->{instanceid}; + +} + +sub cluster { + my $self = shift; + $self->{cluster} = shift if @_; + return $self->{cluster}; +} + +sub _connectidentifier { + + my $self = shift; + notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger); + return undef; + +} + +sub connectidentifier { + my $self = shift; + my $cluster = $self->{cluster}; + if (defined $cluster) { + return $cluster->{name}; + } else { + $self->_connectidentifier(); + } +} + +sub tableidentifier { + + my $self = shift; + my $tablename = shift; + my (@params) = @_; + + notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger); + return undef; + +} + +sub columnidentifier { + + my $self = shift; + my $columnname = shift; + my (@params) = @_; + + notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger); + return undef; + +} + +sub get_tableidentifier { + + my ($tablename,@params) = @_; + + notimplementederror(__PACKAGE__ . ': ' . (caller(0))[3] . ' not implemented',$logger); + return undef; + +} + +sub getsafetablename { + + # make a table name (identifier) string save for use within create table statements + # of this rdbms connector. + my $self = shift; + my ($tableidentifier) = @_; #shift; + $tableidentifier =~ s/[^0-9a-z_]/_/gi; + return $tableidentifier; + +} + +sub _extract_indexcols { + + my $self = shift; + my $indexcols = shift; + if (defined $indexcols and ref $indexcols eq 'ARRAY') { + my @blankcols = map { local $_ = $_; s/\s*\(\d+\).*$//g; $_; } @$indexcols; + return \@blankcols; + } else { + return []; + } + +} + +sub vacuum { + + my $self = shift; + my $tablename = shift; + notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger); + +} + +sub paginate_sort_query { + my $self = shift; + my $statement = shift; + my $offset = shift; + my $limit = shift; + my $sortingconfigurations = shift; + + my $orderby = $self->_orderby_columns($sortingconfigurations); + if (length($orderby) > 0) { + $statement .= ' ORDER BY ' . $orderby; + } + if (defined $offset and defined $limit) { + $statement .= ' LIMIT ' . $offset . ', ' . $limit; + } + return $statement; + +} + +sub _force_numeric_column { + my $self = shift; + my $column = shift; + notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger); +} + +sub _orderby_columns { + + my $self = shift; + my $sortingconfigurations = shift; + + my @orderby = (); + if (defined $sortingconfigurations) { + foreach my $sc (@$sortingconfigurations) { + if (defined $sc and ref $sc eq 'HASH') { + my $columnname = ((exists $sc->{memberchain}) ? $sc->{memberchain} : $sc->{column}); + if (ref $columnname eq 'ARRAY') { + $columnname = $columnname->[0]; + } + if (length($columnname) > 0) { + $columnname = $self->columnidentifier($columnname); + my $orderby_column; + if ($sc->{numeric}) { + $orderby_column = $self->_force_numeric_column($columnname); + } else { + $orderby_column = $columnname; + } + if (!defined $sc->{dir} or $sc->{dir} > 0) { + $orderby_column .= ' ASC'; + } else { + $orderby_column .= ' DESC'; + } + push(@orderby,$orderby_column); + } else { + sortconfigerror(undef,'sort column required',$logger); + } + } else { + sortconfigerror(undef,'invalid sorting configuration',$logger); + } + } + } + return join(', ',@orderby); + +} + +sub getdatabases { + + my $self = shift; + + notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger); + return []; + +} + +sub _createdatabase { + + my $self = shift; + my ($databasename) = @_; + + notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger); + return []; + +} + +sub db_connect { + + my $self = shift; + + my (@params) = @_; + + if (defined $self->{dbh}) { + $self->_db_disconnect(); + } + + # child class will do the connect stuff... + +} + +sub db_disconnect { + my $self = shift; + #my $tid = threadid(); + my $cluster = $self->{cluster}; + if (defined $cluster) { + dbdebug($self,'disconnecting database cluster ' . $cluster->{name},$logger); + foreach my $node (@{$cluster->{nodes}}) { + if ($node->{active}) { + my $node_db = &{$node->{get_db}}($self->{instanceid},0); + $node_db->_db_disconnect(); + } + } + #$cluster->{scheduling_vars} = {}; + } else { + $self->_db_disconnect(); + } +} + +sub _db_disconnect { + + my $self = shift; + + # since this is also called from DESTROY, no die() here! + + $self->db_finish(); + + if (defined $self->{dbh}) { + + #cleartableinfo($self); + #dbdebug($self,'disconnecting' . ((defined $self->{cluster}) ? ' ' . $self->_connectidentifier() : ''),$logger); + dbdebug($self,'disconnecting',$logger); + + foreach my $temp_tablename (@{$self->{temp_tables}}) { + #if ($self->table_exists($temp_tablename)) { + $self->drop_table($temp_tablename); + #} + } + $self->{temp_tables} = []; + + $self->{dbh}->disconnect() or dbwarn($self,'error disconnecting: ' . $self->{dbh}->errstr(),$logger); + $self->{dbh} = undef; + + dbinfo($self,'disconnected',$logger); + #dbinfo($self,((defined $self->{cluster}) ? $self->_connectidentifier() . ' ' : '') . 'disconnected',$logger); + + } + + # further disconect code follows in child classes.... + +} + +sub is_connected { + + my $self = shift; + return (defined $self->{dbh}); + +} + +sub getfieldnames { + + my $self = shift; + my $tablename = shift; + + notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger); + return []; + +} + +sub getprimarykeycols { + + my $self = shift; + my $tablename = shift; + + notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger); + return []; + +} + +sub create_temptable { + + my $self = shift; + my $select_stmt = shift; + my $indexes = shift; + + notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger); + return ''; + +} + +sub create_primarykey { + + my $self = shift; + my ($tablename,$keycols,$fieldnames) = @_; + + notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger); + return 0; + +} +sub create_indexes { + + my $self = shift; + my ($tablename,$indexes,$keycols) = @_; + + notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger); + return 0; + +} + +sub create_texttable { + + my $self = shift; + my ($tablename,$fieldnames,$keycols,$indexes,$truncate,$defer_indexes) = @_; + + notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger); + return 0; + +} + +sub truncate_table { + + my $self = shift; + my $tablename = shift; + + notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger); + +} + +sub table_exists { + + my $self = shift; + my $tablename = shift; + + notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger); + return 0; + +} + +sub drop_table { + + my $self = shift; + my $tablename = shift; + + notimplementederror((ref $self) . ': ' . (caller(0))[3] . ' not implemented',$logger); + +} + +sub _prepare_error { + + my $self = shift; + my $query = shift; + dberror($self,"failed to prepare:\n" . $query . "\nDBI error:\n" . $self->{dbh}->errstr(),$logger); + +} + +sub _execute_error { + + my $self = shift; + my $query = shift; + my $sth = shift; + my $errstr; + if (defined $sth) { + $errstr = $sth->errstr(); + } else { + $errstr = $self->{dbh}->errstr(); + } + dberror($self,"failed to execute:\n" . $query . "\nparameters:\n". join(', ', @_) . "\nDBI error:\n" . $errstr,$logger); + +} +sub _fetch_error { + + my $self = shift; + my $query = shift; + my $sth = shift; + my $operation = shift; + my $index = shift; + my $errstr; + if (defined $sth) { + $errstr = $sth->errstr(); + } else { + $errstr = $self->{dbh}->errstr(); + } + dberror($self,'failed with ' . $operation . ":\n" . $query . "\n" . ((defined $index) ? 'column index: ' . $index . "\n" : '') . "parameters:\n". join(', ', @_) . "\nDBI error:\n" . $errstr,$logger); + +} + +# This method executes a SQL query that doesn't return any data. The +# query may contain placeholders, that will be replaced by the elements +# in @params during execute(). The method will die if any error occurs +# and return whatever DBI's execute() returned. +sub db_do { + + my $self = shift; + my $query = shift; + + my $result = 0; + + if (defined $self->{dbh}) { + dbdebug($self,'db_do: ' . $query . "\nparameters:\n" . join(', ', @_),$logger); + my $sth = $self->{dbh}->prepare($query) or $self->_prepare_error($query); + $result = $sth->execute(@_) or $self->_execute_error($query,$sth,@_); + } + + return $result; + +} + +# get the first value of the first row of data that is returned from the +# database. Returns undef if no data is found. +sub db_get_value { + + my $self = shift; + my $query = shift; + + my $row = undef; + + if (defined $self->{dbh}) { + + dbdebug($self,'db_get_value: ' . $query . "\nparameters:\n" . join(', ', @_),$logger); + my $sth = $self->{dbh}->prepare($query) or $self->_prepare_error($query); + $sth->execute(@_) or $self->_execute_error($query,$sth,@_); + + $row = $sth->fetchrow_arrayref(); + $self->_fetch_error($query,$sth,'fetchrow_arrayref',undef,@_) if !defined $row and $sth->err(); + $sth->finish(); + + } + + return ((defined $row) ? $$row[0] : undef); + +} + +# get a reference to the first row of data that is returned from the database. +# (I.e. whatever is returned by DBI's fetchrow_hashref().) +sub db_get_row { + + my $self = shift; + my $query = shift; + + my $row = []; + + if (defined $self->{dbh}) { + + dbdebug($self,'db_get_row: ' . $query . "\nparameters:\n" . join(', ', @_),$logger); + my $sth = $self->{dbh}->prepare($query) or $self->_prepare_error($query); + $sth->execute(@_) or $self->_execute_error($query,$sth,@_); + + $row = $sth->fetchrow_hashref(); + $self->_fetch_error($query,$sth,'fetchrow_hashref',undef,@_) if !defined $row and $sth->err(); + $sth->finish(); + + } + + return $row; + +} + +# get a reference to an array containing the first value of every data row that +# is returned from the database like DBI's selectcol_arrayref() does. +sub db_get_col { + + my $self = shift; + my $query = shift; + + my $col = []; + + if (defined $self->{dbh}) { + + dbdebug($self,'db_get_col: ' . $query . "\nparameters:\n" . join(', ', @_),$logger); + my $sth = $self->{dbh}->prepare($query) or $self->_prepare_error($query); + + $col = $self->{dbh}->selectcol_arrayref($sth, undef, @_); + #die "Failed to selectcol_arrayref:\n$query\nDBI error:". $sth->errstr() if !defined $col and $sth->err(); + $self->_fetch_error($query,$sth,'selectcol_arrayref',undef,@_) if !defined $col and $sth->err(); + $sth->finish(); + + } + + return $col; + +} + +# get all data that is returned from the database. (I.e. a reference to an +# array containing entries returned by DBI's fetchrow_hashref().) +sub db_get_all_arrayref { + + my $self = shift; + my $query = shift; + + my @rows = (); + + if (defined $self->{dbh}) { + + dbdebug($self,'db_get_all_arrayref: ' . $query . "\nparameters:\n" . join(', ', @_),$logger); + my $sth = $self->{dbh}->prepare($query) or $self->_prepare_error($query); + $sth->execute(@_) or $self->_execute_error($query,$sth,@_); + + while (my $row = $sth->fetchrow_hashref()) { + $self->_fetch_error($query,$sth,'fetchrow_hashref',undef,@_) if $sth->err(); + push @rows, $row; + } + $sth->finish(); + + } + + return \@rows; + +} + +# get a reference to a hash containing a hashreference for each row, like DBI's +# fetchall_hashref() does. +sub db_get_all_hashref { + + my $self = shift; + my $query = shift; + my $index = shift; + + my $result = {}; + + if (defined $self->{dbh}) { + + dbdebug($self,'db_get_all_hashref: ' . $query . "\nparameters:\n" . join(', ', @_),$logger); + my $sth = $self->{dbh}->prepare($query) or $self->_prepare_error($query); + $sth->execute(@_) or $self->_execute_error($query,$sth,@_); + + $result = $sth->fetchall_hashref($index); + $self->_fetch_error($query,$sth,'fetchall_hashref',$index,@_) if $sth->err(); + $sth->finish(); + + } + + return $result; + +} + +# get a reference to a hash that is composed of the key_column as keys and the +# value_column as values. +sub db_get_mapref { + + my $self = shift; + my $query = shift; + my $index = shift; + my $value = shift; + + my $result = {}; + + if (defined $self->{dbh}) { + + dbdebug($self,'db_get_mapref: ' . $query . "\nparameters:\n" . join(', ', @_),$logger); + my $sth = $self->{dbh}->prepare($query) or $self->_prepare_error($query); + $sth->execute(@_) or $self->_execute_error($query,$sth,@_); + + my $rows = $sth->fetchall_hashref($index); + #die "Failed to fetchall_hashref:\n$query\nDBI error:". $sth->errstr() if $sth->err(); + $self->_fetch_error($query,$sth,'fetchall_hashref',$index,@_) if $sth->err(); + + foreach my $key (keys %$rows) { + $result->{$key} = $$rows{$key}{$value}; + } + $sth->finish(); + + return $result; + + } + + return $result; + +} + +sub db_begin { + + my $self = shift; + if (defined $self->{dbh}) { + dbdebug($self,'db_begin',$logger); + $self->{dbh}->begin_work() or dberror($self, "failed with begin_transaction \nDBI error:\n" . $self->{dbh}->errstr(),$logger); + + if ($self->{dbh}->{AutoCommit}) { + dbwarn($self,'autocommit was not disabled',$logger); + } + + } + +} + +sub db_commit { + + my $self = shift; + if (defined $self->{dbh}) { + dbdebug($self,'db_commit',$logger); + #komodo workaround: + my @wa = $self->{dbh}->commit() or dberror($self, "failed to commit changes\nDBI error:\n" . $self->{dbh}->errstr(),$logger); #remove dberror for debugging + } + +} + +sub db_rollback { + + my $self = shift; + if (defined $self->{dbh}) { + dbdebug($self,'db_rollback',$logger); + $self->{dbh}->rollback() or dberror($self, "failed to rollback changes\nDBI error:\n" . $self->{dbh}->errstr(),$logger); + } + +} + +sub db_quote { + + my $self = shift; + my $value = shift; + + my $result = $value; + + if (defined $self->{dbh}) { + $result = $self->{dbh}->quote($value) or dberror($self, "failed to quote value\nDBI error:\n" . $self->{dbh}->errstr(),$logger); + } + return $result; + +} + +sub DESTROY { + + my $self = shift; + + # perl threads works like a fork, each thread owns a shalow? copy + # of the entire current context, at the moment it starts. + # due to this, if the thread is finished, perl gc will invoke destructors + # on the thread's scope elements, that potentially contains connectors from + # the main tread. it will actually attempt destroy them (disconect, etc.) + # this is a problem with destructors that change object state like this one + # + # to avoid this, we perform destruction tasks only if the destructing tid + # is the same as the creating one: + + if ($self->{tid} == threadid()) { + $self->_db_disconnect(); + delete $self->{drh}; + dbdebug($self,(ref $self) . ' connector destroyed',$logger); + #} else { + # print "NOT destroyed\n"; + } + +} + +sub lock_tables { + + my $self = shift; + my $tablestolock = shift; + + $self->db_begin(); + +} + +sub unlock_tables { + + my $self = shift; + + $self->db_commit(); + +} + +sub db_do_begin { + + my $self = shift; + my $query = shift; + my $tablename = shift; + my $lock = shift; + + #notimplementederror('db_do_begin',$logger); + + if (defined $self->{dbh} and not defined $self->{sth} and length($tablename) > 0) { + + if ($lock) { + $self->lock_tables({ $tablename => 'WRITE' }); + } + + dbdebug($self,'db_do_begin: ' . $query,$logger); + $self->{sth} = $self->{dbh}->prepare($query) or $self->_prepare_error($query); + $self->{query} = $query; + $self->{params} = []; + + } + + +} + +sub db_do_rowblock { + + my $self = shift; + my $rows = shift; + + #notimplementederror('db_do_rowblock',$logger); + + if (defined $self->{dbh} and defined $self->{sth} and defined $rows and ref $rows eq 'ARRAY') { + + #dberror($self,'test error',$logger); + #mysqldbdebug($self,"db_do_rowblock\nrows:\n" . (scalar @$rows),$logger); + #mysqldbdebug($self,'db_do_rowblock: ' . $self->{query} . "\nparameters:\n" . join(', ', @_),$logger); + foreach my $row (@$rows) { + dbdebug($self,'db_do_rowblock: ' . $self->{query} . "\nparameters:\n" . join(', ', @$row),$logger); + $self->{sth}->execute(@$row) or $self->_execute_error($self->{query},$self->{sth},@$row); + $self->{params} = $row; + } + + } + +} + +sub db_get_begin { + + my $self = shift; + my $query = shift; + my $tablename = shift; + my $lock = shift; + + if (defined $self->{dbh} and not defined $self->{sth} and length($tablename) > 0) { + + #eval { $self->lock_tables({ $tablename => 'WRITE' }); }; + if ($lock) { + $self->lock_tables({ $tablename => 'WRITE' }); + } + + dbdebug($self,'db_get_begin: ' . $query . "\nparameters:\n" . join(', ', @_),$logger); + $self->{sth} = $self->{dbh}->prepare($query) or $self->_prepare_error($query); + $self->{sth}->execute(@_) or $self->_execute_error($query,$self->{sth},@_); + $self->{query} = $query; + $self->{params} = \@_; + + } + +} + +sub multithreading_supported { + + my $self = shift; + return 0; + +} + +sub db_get_rowblock { + + my $self = shift; + my $max_rows = shift; + + if ($enablemultithreading) { + + #my $rows : shared = []; + my @rows :shared = (); + #my $rows = &share([]); # beware of '&' here!!!! + #my $rows = shared_clone({}); + + if (defined $self->{dbh} and defined $self->{sth}) { + + dbdebug($self,'db_get_rowblock: ' . $self->{query} . "\nparameters:\n" . join(', ', @{$self->{params}}),$logger); + + foreach (@{$self->{sth}->fetchall_arrayref(undef, $max_rows)}) { + my @row : shared = @{$_}; + push @rows, \@row; + } + + + $self->_fetch_error($self->{query},$self->{sth},'db_get_rowblock',undef,@{$self->{params}}) if $self->{sth}->err(); + + } + + #share(@rows); + return \@rows; + #return $rows; + #return \@rows; + + } else { + + my $rows = []; + + if (defined $self->{dbh} and defined $self->{sth}) { + + dbdebug($self,'db_get_rowblock: ' . $self->{query} . "\nparameters:\n" . join(', ', @{$self->{params}}),$logger); + $rows = $self->{sth}->fetchall_arrayref(undef, $max_rows); + $self->_fetch_error($self->{query},$self->{sth},'db_get_rowblock',undef,@{$self->{params}}) if $self->{sth}->err(); + + } + + return $rows; + + } + +} + +sub db_finish { + + my $self = shift; + my $unlock = shift; + + # since this is also called from DESTROY, no die() here! + + if (defined $self->{dbh} and defined $self->{sth}) { + + dbdebug($self,'db_finish',$logger); + + $self->{sth}->finish(); + $self->{sth} = undef; + + if ($unlock) { + $self->unlock_tables(); + } + + $self->{query} = undef; + $self->{params} = undef; + + } + +} + +1; \ No newline at end of file diff --git a/SqlConnectors/CSVDB.pm b/SqlConnectors/CSVDB.pm new file mode 100644 index 0000000..37a83d9 --- /dev/null +++ b/SqlConnectors/CSVDB.pm @@ -0,0 +1,833 @@ +package SqlConnectors::CSVDB; +use strict; + +## no critic + +use File::Basename; +use Cwd; +use lib Cwd::abs_path(File::Basename::dirname(__FILE__) . '/../'); + +use Globals qw( + $LongReadLen_limit + $csv_path); + +use Logging qw( + getlogger + dbdebug + dbinfo + xls2csvinfo + texttablecreated + indexcreated + tabletruncated + tabledropped); + +use LogError qw( + dberror + dbwarn + fieldnamesdiffer + fileerror + filewarn + xls2csverror + xls2csvwarn); + +use Array qw(contains setcontains); + +use Utils qw(makedir changemod chopstring); + +use SqlConnector; + +use DBI; +use DBD::CSV 0.26; +use File::Path qw(remove_tree); +use Locale::Recode; +use Spreadsheet::ParseExcel; +use Spreadsheet::ParseExcel::FmtUnicode; +use Excel::Reader::XLSX; +use Text::CSV_XS; +use File::Basename; +use MIME::Parser; +use HTML::PullParser qw(); +use HTML::Entities qw(decode_entities); +use IO::Uncompress::Unzip qw(unzip $UnzipError); + +use DateTime::Format::Excel; + +require Exporter; +our @ISA = qw(Exporter SqlConnector); +our @EXPORT_OK = qw( + cleanupcvsdirs + xlsbin2csv + xlsxbin2csv + sanitize_column_name + sanitize_spreadsheet_name + excel_to_timestamp + excel_to_date + get_tableidentifier + $csvextension); + +our $csvextension = '.csv'; + +my $default_csv_config = { eol => "\r\n", + sep_char => ';', + quote_char => '"', + escape_char => '"', + }; + +my @TABLE_TAGS = qw(table tr td); + +my $LongReadLen = $LongReadLen_limit; #bytes +my $LongTruncOk = 0; + +my $logger = getlogger(__PACKAGE__); + +my $lock_do_chunk = 0; +my $lock_get_chunk = 0; + +my $invalid_excel_spreadsheet_chars_pattern = '[' . quotemeta('[]:*?/\\') . ']'; + +sub sanitize_spreadsheet_name { #Invalid character []:*?/\ in worksheet name + my $spreadsheet_name = shift; + $spreadsheet_name =~ s/$invalid_excel_spreadsheet_chars_pattern//g; + return chopstring($spreadsheet_name,31); #Sheetname eventually inconsistent etc. must be <= 31 chars +} + +sub sanitize_column_name { + my $column_name = shift; + $column_name =~ s/\W/_/g; + return $column_name; +} + +sub excel_to_date { + my $excel_date_value = shift; + if ($excel_date_value > 0) { + my $datetime = DateTime::Format::Excel->parse_datetime($excel_date_value); + return $datetime->ymd('-'); # prints 1992-02-28 + } + return undef; +} + +sub excel_to_timestamp { + my $excel_datetime_value = shift; + if ($excel_datetime_value > 0) { + my $datetime = DateTime::Format::Excel->parse_datetime($excel_datetime_value); + return $datetime->ymd('-') . ' ' . $datetime->hms(':'); + } + return undef; +} + +sub new { + + my $class = shift; + + my $self = SqlConnector->new(@_); + + $self->{db_dir} = undef; + $self->{f_dir} = undef; + $self->{csv_tables} = undef; + $self->{files} = undef; + + $self->{drh} = DBI->install_driver('CSV'); + + bless($self,$class); + + dbdebug($self,__PACKAGE__ . ' connector created',$logger); + + return $self; + +} + +sub _connectidentifier { + + my $self = shift; + return $self->{f_dir}; + +} + +sub tableidentifier { + + my $self = shift; + my $tablename = shift; + return $tablename; + +} + +sub columnidentifier { + + my $self = shift; + my $columnname = shift; + + return sanitize_column_name($columnname); #actually happens automatically by dbd::csv + +} + +sub get_tableidentifier { + + my ($tablename,$db_dir) = @_; + if (defined $db_dir) { + return $db_dir . '.' . $tablename; + } else { + return $tablename; + } + +} + +sub getsafetablename { + + my $self = shift; + my $tableidentifier = shift; + return lc($self->SUPER::getsafetablename($tableidentifier)); + +} + +sub getdatabases { + + my $self = shift; + + local *DBDIR; + if (not opendir(DBDIR, $csv_path)) { + fileerror('cannot opendir ' . $csv_path . ': ' . $!,$logger); + return []; + } + my @dirs = grep { $_ ne '.' && $_ ne '..' && -d $csv_path . $_ } readdir(DBDIR); + closedir DBDIR; + my @databases = (); + foreach my $dir (@dirs) { + push @databases,$dir; + } + return \@databases; + +} + +sub _createdatabase { + + my $self = shift; + my ($db_dir) = @_; + + my $f_dir; # = _get_f_dir($db_dir); + if (length($db_dir) > 0) { + $f_dir = $csv_path . $db_dir . '/'; + } else { + $f_dir = $csv_path; + } + + dbinfo($self,'opening csv folder',$logger); + + #mkdir $f_dir; + makedir($f_dir); + + local *DBDIR; + if (not opendir(DBDIR, $f_dir)) { + fileerror('cannot opendir ' . $f_dir . ': ' . $!,$logger); + return; + } + closedir DBDIR; + + changemod($f_dir); + + return $f_dir; +} + +sub db_connect { + + my $self = shift; + + my ($db_dir,$csv_tables) = @_; + + $self->SUPER::db_connect($db_dir,$csv_tables); + + $self->{db_dir} = $db_dir; + $self->{csv_tables} = $csv_tables; + $self->{f_dir} = $self->_createdatabase($db_dir); + + my $dbh_config = { + f_schema => undef, + #f_lock => 0, n/a in 0.26 yet? + cvs_eol => $default_csv_config->{eol}, + cvs_sep_char => $default_csv_config->{sep_char}, + cvs_quote_char => $default_csv_config->{quote_char}, + cvs_escape_char => $default_csv_config->{escape_char}, + PrintError => 0, + RaiseError => 0, + }; + my $usetabledef = 0; + if (defined $csv_tables and ref $csv_tables eq 'HASH') { + $usetabledef = 1; + } else { + $dbh_config->{f_dir} = $self->{f_dir}; + $dbh_config->{f_ext} = $csvextension . '/r'; + } + + my $dbh = DBI->connect ('dbi:CSV:','','',$dbh_config) or + dberror($self,'error connecting: ' . $self->{drh}->errstr(),$logger); + + $dbh->{InactiveDestroy} = 1; + + $dbh->{LongReadLen} = $LongReadLen; + $dbh->{LongTruncOk} = $LongTruncOk; + + $self->{dbh} = $dbh; + + if ($usetabledef) { + my @files = (); + foreach my $tablename (keys %$csv_tables) { + $dbh->{csv_tables}->{$tablename} = $csv_tables->{$tablename}; + push @files,$csv_tables->{$tablename}->{file}; + dbinfo($self,'using ' . $csv_tables->{$tablename}->{file},$logger); + } + $self->{files} = \@files; + } else { + my @tablenames = $self->_list_tables(); + foreach my $tablename (@tablenames) { + $dbh->{csv_tables}->{$tablename} = { eol => $default_csv_config->{eol}, + sep_char => $default_csv_config->{sep_char}, + quote_char => $default_csv_config->{quote_char}, + escape_char => $default_csv_config->{escape_char}, + } + } + } + + dbinfo($self,'connected',$logger); + +} + + +sub _list_tables { + my $self = shift; + my @table_list; + + eval { + @table_list = map { local $_ = $_; s/^\.\///g; $_; } $self->{dbh}->func('list_tables'); + }; + if ($@) { + my @tables; + eval { + @tables = $self->{dbh}->func("get_avail_tables") or return; + }; + if ($@) { + dberror($self,'error listing csv tables: ' . $@,$logger); + } else { + foreach my $ref (@tables) { + if (defined $ref) { + if (ref $ref eq 'ARRAY') { + push @table_list, $ref->[2]; + #} else { + # push @table_list, $ref; + } + } + } + } + } + + return @table_list; #removeduplicates(\@table_list); +} + +sub _db_disconnect { + + my $self = shift; + + $self->SUPER::_db_disconnect(); + +} + +sub vacuum { + + my $self = shift; + my $tablename = shift; + +} + +sub cleanupcvsdirs { + + my (@remainingdbdirs) = @_; + local *DBDIR; + if (not opendir(DBDIR, $csv_path)) { + fileerror('cannot opendir ' . $csv_path . ': ' . $!,$logger); + return; + } + my @dirs = grep { $_ ne '.' && $_ ne '..' && -d $csv_path . $_ } readdir(DBDIR); + closedir DBDIR; + my @remainingdbdirectories = (); + foreach my $dirname (@remainingdbdirs) { + push @remainingdbdirectories,$csv_path . $dirname . '/'; + } + foreach my $dir (@dirs) { + #print $file; + my $dirpath = $csv_path . $dir . '/'; + if (not contains($dirpath,\@remainingdbdirectories)) { + if (remove_tree($dirpath) == 0) { + filewarn('cannot remove ' . $dirpath . ': ' . $!,$logger); + } + } + } + +} + +sub getfieldnames { + + my $self = shift; + my $tablename = shift; + + my $fieldnames = []; + + if (defined $self->{dbh}) { + + my $query = 'SELECT * FROM ' . $self->tableidentifier($tablename) . ' LIMIT 1'; + dbdebug($self,'getfieldnames: ' . $query,$logger); + my $sth = $self->{dbh}->prepare($query) or $self->_prepare_error($query); + $sth->execute() or $self->_execute_error($query,$sth,()); + $fieldnames = $sth->{NAME}; + $sth->finish(); + + } + + return $fieldnames; + +} + +sub getprimarykeycols { + + my $self = shift; + my $tablename = shift; + return []; + +} + +sub create_primarykey { + + my $self = shift; + my ($tablename,$keycols,$fieldnames) = @_; + + return 0; +} +sub create_indexes { + + my $self = shift; + my ($tablename,$indexes,$keycols) = @_; + + return 0; +} + +sub _gettablefilename { + + my $self = shift; + my $tablename = shift; + return $self->{f_dir} . $tablename . $csvextension; + +} + +sub create_texttable { + + my $self = shift; + my ($tablename,$fieldnames,$keycols,$indexes,$truncate) = @_; + + if (length($tablename) > 0 and defined $fieldnames and ref $fieldnames eq 'ARRAY') { + + my $created = 0; + if ($self->table_exists($tablename) == 0) { + + if (not exists $self->{dbh}->{csv_tables}->{$tablename}) { + $self->{dbh}->{csv_tables}->{$tablename} = { eol => $default_csv_config->{eol}, + sep_char => $default_csv_config->{sep_char}, + quote_char => $default_csv_config->{quote_char}, + escape_char => $default_csv_config->{escape_char}, + }; + } + + my $statement = 'CREATE TABLE ' . $self->tableidentifier($tablename) . ' ('; + $statement .= join(' TEXT, ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$fieldnames) . ' TEXT'; + $statement .= ')'; + + $self->db_do($statement); + + changemod($self->_gettablefilename($tablename)); + + texttablecreated($self,$tablename,$logger); + + $created = 1; + } else { + my $fieldnamesfound = $self->getfieldnames($tablename); + if (not setcontains($fieldnames,$fieldnamesfound,1)) { + fieldnamesdiffer($self,$tablename,$fieldnames,$fieldnamesfound,$logger); + return 0; + } + } + + if (not $created and $truncate) { + $self->truncate_table($tablename); + } + return 1; + } else { + return 0; + } + +} + +sub multithreading_supported { + + my $self = shift; + return 0; + +} + +sub truncate_table { + + my $self = shift; + my $tablename = shift; + + $self->db_do('DELETE FROM ' . $self->tableidentifier($tablename)); + tabletruncated($self,$tablename,$logger); + +} + +sub table_exists { + + my $self = shift; + my $tablename = shift; + + if (defined $self->{dbh}) { + my @tables = $self->_list_tables(); + return contains($tablename,\@tables); + } + + return undef; + +} + +sub drop_table { + + my $self = shift; + my $tablename = shift; + + if ($self->table_exists($tablename) > 0) { + $self->db_do('DROP TABLE ' . $self->tableidentifier($tablename)); + delete $self->{dbh}->{csv_tables}->{$tablename}; + tabledropped($self,$tablename,$logger); + return 1; + } + return 0; + +} + +sub db_begin { + + my $self = shift; + if (defined $self->{dbh}) { + dbdebug($self, "transactions not supported",$logger); + } + +} + +sub db_commit { + + my $self = shift; + if (defined $self->{dbh}) { + dbdebug($self, "transactions not supported",$logger); + } + +} + +sub db_rollback { + + my $self = shift; + if (defined $self->{dbh}) { + dbdebug($self, "transactions not supported",$logger); + } + +} + +sub db_do_begin { + + my $self = shift; + my $query = shift; + my $tablename = shift; + + $self->SUPER::db_do_begin($query,$tablename,$lock_do_chunk,@_); + +} + +sub db_get_begin { + + my $self = shift; + my $query = shift; + my $tablename = shift; + + $self->SUPER::db_get_begin($query,$tablename,$lock_get_chunk,@_); + +} + +sub db_finish { + + my $self = shift; + + $self->SUPER::db_finish($lock_do_chunk | $lock_get_chunk); + +} + +sub xlsbin2csv { + + my ($inputfile,$outputfile,$worksheetname,$sourcecharset) = @_; + + return _convert_xlsbin2csv($inputfile, + $worksheetname, + $sourcecharset, + $outputfile, + 'UTF-8', + $default_csv_config->{quote_char}, + $default_csv_config->{escape_char}, + $default_csv_config->{sep_char}, + $default_csv_config->{eol}); + +} + +sub _convert_xlsbin2csv { + + my ($SourceFilename,$worksheet,$SourceCharset,$DestFilename,$DestCharset,$quote_char,$escape_char,$sep_char,$eol) = @_; + + my $csvlinecount = 0; + + xls2csvinfo('start converting ' . $SourceFilename . ' (worksheet ' . $worksheet . ') to ' . $DestFilename . ' ...',$logger); + + $SourceCharset = 'UTF-8' unless $SourceCharset; + $DestCharset = $SourceCharset unless $DestCharset; + + xls2csvinfo('reading ' . $SourceFilename . ' as ' . $SourceCharset,$logger); + + my $XLS = new IO::File; + if (not $XLS->open('<' . $SourceFilename)) { + fileerror('cannot open file ' . $SourceFilename . ': ' . $!,$logger); + return 0; + } + + my $Formatter = Spreadsheet::ParseExcel::FmtUnicode->new(Unicode_Map => $SourceCharset); + + my $parser = Spreadsheet::ParseExcel->new(); + my $Book = $parser->parse($XLS,$Formatter); #$SourceFilename + + if ( !defined $Book ) { + xls2csverror($parser->error(),$logger); + #die $parser->error(), ".\n"; + $XLS->close(); + return 0; + } + + #my $Book = Spreadsheet::ParseExcel::Workbook->Parse($XLS, $Formatter) or xls2csverror('can\'t read spreadsheet',$logger); + + my $Sheet; + if ($worksheet) { + + #my $test = $Book->GetContent(); + + $Sheet = $Book->Worksheet($worksheet); + if (not defined $Sheet) { + xls2csverror('invalid spreadsheet',$logger); + return 0; + } + #unless ($O{'q'}) + #{ + # print qq|Converting the "$Sheet->{Name}" worksheet.\n|; + #} + xls2csvinfo('converting the ' . $Sheet->{Name} . ' worksheet',$logger); + } else { + ($Sheet) = @{$Book->{Worksheet}}; + if ($Book->{SheetCount}>1) { + #print qq|Multiple worksheets found. Will convert the "$Sheet->{Name}" worksheet.\n|; + xls2csvinfo('multiple worksheets found, converting ' . $Sheet->{Name},$logger); + } + } + + unlink $DestFilename; + local *CSV; + if (not open(CSV,'>' . $DestFilename)) { + fileerror('cannot open file ' . $DestFilename . ': ' . $!,$logger); + $XLS->close(); + return 0; + } + binmode CSV; + + my $Csv = Text::CSV_XS->new({ + 'quote_char' => $quote_char, + 'escape_char' => $escape_char, + 'sep_char' => $sep_char, + 'binary' => 1, + }); + + my $Recoder; + if ($DestCharset) { + $Recoder = Locale::Recode->new(from => $SourceCharset, to => $DestCharset); + } + + for (my $Row = $Sheet->{MinRow}; defined $Sheet->{MaxRow} && $Row <= $Sheet->{MaxRow}; $Row++) { + my @Row; + for (my $Col = $Sheet->{MinCol}; defined $Sheet->{MaxCol} && $Col <= $Sheet->{MaxCol}; $Col++) { + my $Cell = $Sheet->{Cells}[$Row][$Col]; + + my $Value = ""; + if ($Cell) { + $Value = $Cell->Value; + if ($Value eq 'GENERAL') { + # Sometimes numbers are read incorrectly as "GENERAL". + # In this case, the correct value should be in ->{Val}. + $Value = $Cell->{Val}; + } + if ($DestCharset) { + $Recoder->recode($Value); + } + } + + # We assume the line is blank if there is nothing in the first column. + last if $Col == $Sheet->{MinCol} and !$Value; + + push(@Row,$Value); + } + + next unless @Row; + + my $Status = $Csv->combine(@Row); + + if (!defined $Status) { + xls2csvwarn('csv error: ' . $Csv->error_input(),$logger); + } + + if (defined $Status) { + print CSV $Csv->string(); + if ($Row < $Sheet->{MaxRow}) { + print CSV $eol; + } + $csvlinecount++; + } + } + + close CSV; + $XLS->close; + + xls2csvinfo($csvlinecount . ' line(s) converted',$logger); + + return $csvlinecount; + +} + +sub xlsxbin2csv { + + my ($inputfile,$outputfile,$worksheetname) = @_; + + return _convert_xlsxbin2csv($inputfile, + $worksheetname, + $outputfile, + 'UTF-8', + $default_csv_config->{quote_char}, + $default_csv_config->{escape_char}, + $default_csv_config->{sep_char}, + $default_csv_config->{eol}); + +} + +sub _convert_xlsxbin2csv { + my ($SourceFilename,$worksheet,$DestFilename,$DestCharset,$quote_char,$escape_char,$sep_char,$eol) = @_; + + my $csvlinecount = 0; + + xls2csvinfo('start converting ' . $SourceFilename . ' (worksheet ' . $worksheet . ') to ' . $DestFilename . ' ...',$logger); + + + my $XLS = new IO::File; + if (not $XLS->open('<' . $SourceFilename)) { + fileerror('cannot open file ' . $SourceFilename . ': ' . $!,$logger); + return 0; + } else { + $XLS->close(); + } + + #my $Formatter = Spreadsheet::ParseExcel::FmtUnicode->new(Unicode_Map => $SourceCharset); + + my $reader = Excel::Reader::XLSX->new(); + my $workbook = $reader->read_file($SourceFilename); #->parse($XLS,$Formatter); #$SourceFilename + + my $SourceCharset = $workbook->{_reader}->encoding(); + $DestCharset = $SourceCharset unless $DestCharset; + + xls2csvinfo('reading ' . $SourceFilename . ' as ' . $SourceCharset,$logger); + + if ( !defined $workbook ) { + xls2csverror($reader->error(),$logger); + #die $parser->error(), ".\n"; + #$XLS->close(); + return 0; + } + + #my $Book = Spreadsheet::ParseExcel::Workbook->Parse($XLS, $Formatter) or xls2csverror('can\'t read spreadsheet',$logger); + + my $sheet; + if ($worksheet) { + + #my $test = $Book->GetContent(); + + $sheet = $workbook->worksheet($worksheet); + if (not defined $sheet) { + xls2csverror('invalid spreadsheet',$logger); + return 0; + } + #unless ($O{'q'}) + #{ + # print qq|Converting the "$Sheet->{Name}" worksheet.\n|; + #} + xls2csvinfo('converting the ' . $sheet->name() . ' worksheet',$logger); + } else { + $sheet = $workbook->worksheet(0); + if (@{$workbook->worksheets()} > 1) { + #print qq|Multiple worksheets found. Will convert the "$Sheet->{Name}" worksheet.\n|; + xls2csvinfo('multiple worksheets found, converting ' . $sheet->name(),$logger); + } + } + + unlink $DestFilename; + local *CSV; + if (not open(CSV,'>' . $DestFilename)) { + fileerror('cannot open file ' . $DestFilename . ': ' . $!,$logger); + #$XLS->close(); + return 0; + } + binmode CSV; + + my $csv = Text::CSV_XS->new({ + 'quote_char' => $quote_char, + 'escape_char' => $escape_char, + 'sep_char' => $sep_char, + 'binary' => 1, + }); + + my $Recoder; + if ($DestCharset) { + $Recoder = Locale::Recode->new(from => $SourceCharset, to => $DestCharset); + } + + while ( my $row = $sheet->next_row() ) { + + foreach my $value ($row->values()) { + $Recoder->recode($value); + } + + my $status = $csv->combine($row->values()); + + if (!defined $status) { + xls2csvwarn('csv error: ' . $csv->error_input(),$logger); + } + + if (defined $status) { + if ($row->row_number() > 0) { + print CSV $eol; + } + print CSV $csv->string(); + $csvlinecount++; + } + } + + close CSV; + #$XLS->close; + + xls2csvinfo($csvlinecount . ' line(s) converted',$logger); + + return $csvlinecount; + +} + +1; \ No newline at end of file diff --git a/SqlConnectors/MySQLDB.pm b/SqlConnectors/MySQLDB.pm new file mode 100644 index 0000000..40eacde --- /dev/null +++ b/SqlConnectors/MySQLDB.pm @@ -0,0 +1,534 @@ +package SqlConnectors::MySQLDB; +use strict; + +## no critic + +use File::Basename; +use Cwd; +use lib Cwd::abs_path(File::Basename::dirname(__FILE__) . '/../'); + +use Globals qw($LongReadLen_limit); +use Logging qw( + getlogger + dbinfo + dbdebug + texttablecreated + temptablecreated + indexcreated + primarykeycreated + tabletruncated + tabledropped); +use LogError qw(dberror fieldnamesdiffer); + +use DBI; +use DBD::mysql 4.014; + +use Array qw(arrayeq itemcount contains setcontains); + +use SqlConnector; + +require Exporter; +our @ISA = qw(Exporter SqlConnector); +our @EXPORT_OK = qw(get_tableidentifier); + +my $defaulthost = '127.0.0.1'; +my $defaultport = '3306'; +my $defaultusername = 'root'; +my $defaultpassword = ''; +my $defaultdatabasename = 'test'; + +my $varcharsize = 256; + +my $texttable_charset = 'latin1'; +my $texttable_collation = 'latin1_swedish_ci'; +my $default_texttable_engine = 'MyISAM'; #InnoDB'; # ... provide transactions y/n? + +my $session_charset = 'latin1'; + +my $LongReadLen = $LongReadLen_limit; #bytes +my $LongTruncOk = 0; + +my $logger = getlogger(__PACKAGE__); + +my $lock_do_chunk = 1; +my $lock_get_chunk = 0; + +my $serialization_level = ''; #'SERIALIZABLE' + +sub new { + + my $class = shift; + + my $self = SqlConnector->new(@_); + + $self->{host} = undef; + $self->{port} = undef; + $self->{databasename} = undef; + $self->{username} = undef; + $self->{password} = undef; + + $self->{drh} = DBI->install_driver('mysql'); + + bless($self,$class); + + dbdebug($self,__PACKAGE__ . ' connector created',$logger); + + return $self; + +} + +sub _connectidentifier { + + my $self = shift; + if (defined $self->{databasename}) { + return $self->{username} . '@' . $self->{host} . ':' . $self->{port} . '.' . $self->{databasename}; + } else { + return undef; + } + +} + +sub tableidentifier { + + my $self = shift; + my $tablename = shift; + + if (defined $self->{databasename}) { + return '`' . $self->{databasename} . '`.`' . $tablename . '`'; + } else { + return '`' . $tablename . '`'; + } + +} + +sub columnidentifier { + + my $self = shift; + my $columnname = shift; + + return '`' . $columnname . '`'; + +} + +sub get_tableidentifier { + + my ($tablename,$databasename) = @_; + + if (defined $databasename) { + return $databasename . '.' . $tablename; + } else { + return $tablename; + } + +} + +sub getsafetablename { + + my $self = shift; + my $tableidentifier = shift; + + return lc($self->SUPER::getsafetablename($tableidentifier)); + +} + +sub _force_numeric_column { + my $self = shift; + my $column = shift; + return '(' . $column . ' + 0.0)'; +} + +sub getdatabases { + + my $self = shift; + + my @dbs = $self->{drh}->func($self->{host}, + $self->{port}, + $self->{username}, + $self->{password}, + '_ListDBs') or + dberror($self,'error listing databases: ' . $self->{drh}->errstr(),$logger); + + return \@dbs; + +} + +sub _createdatabase { + + my $self = shift; + my ($databasename) = @_; + + if ($self->{drh}->func('createdb', + $databasename, + 'host=' . $self->{host} . ';port=' . $self->{port}, + $self->{username}, + $self->{password}, + 'admin')) { + dbinfo($self,'database \'' . $databasename . '\' created',$logger); + } +} + +sub db_connect { + + my $self = shift; + + my ($databasename,$username,$password,$host,$port) = @_; + + $self->SUPER::db_connect($databasename,$username,$password,$host,$port); + + $host = $defaulthost if (not $host); + $port = $defaultport if (not $port); + $databasename = $defaultdatabasename if (not $databasename); + $username = $defaultusername if (not $username); + $password = $defaultpassword if (not $password); + + $self->{host} = $host; + $self->{port} = $port; + $self->{databasename} = $databasename; + $self->{username} = $username; + $self->{password} = $password; + + if (not contains($databasename,$self->getdatabases(),0)) { + $self->_createdatabase($databasename); + } + + dbdebug($self,'connecting',$logger); + + my $dbh = DBI->connect( + 'dbi:mysql:database=' . $databasename . ';host=' . $host . ';port=' . $port,$username,$password, + { + PrintError => 0, + RaiseError => 0, + AutoCommit => 1, + #AutoCommit => 0, + } + ) or dberror($self,'error connecting: ' . $self->{drh}->errstr(),$logger); + + $dbh->{InactiveDestroy} = 1; + + $dbh->{LongReadLen} = $LongReadLen; + $dbh->{LongTruncOk} = $LongTruncOk; + + $self->{dbh} = $dbh; + + my $server_version = substr($self->db_get_all_hashref('SHOW VARIABLES LIKE \'version\'','Variable_name')->{version}->{Value},0,2); + if ($server_version ge '4.1') { + # $self->db_do('SET SESSION character_set_client = \'utf8\''); + # $self->db_do('SET SESSION character_set_connection = \'utf8\''); + # $self->db_do('SET SESSION character_set_results = \'utf8\''); + $self->db_do('SET CHARACTER SET ' . $session_charset . ''); + dbdebug($self,'session charset ' . $session_charset . ' applied',$logger); + } else { + # $self->db_do('SET SESSION CHARACTER SET = \'utf8\''); + #$self->db_do('SET SESSION CHARACTER SET = \'latin1\''); + + #$self->db_do('SET SESSION CHARACTER SET \'cp1251_koi8\''); # the only valid if convert.cc on server is not modified + } + + + #$self->db_do('SET character_set_client = \'utf8\''); + #$self->db_do('SET character_set_connection = \'utf8\''); + #$self->db_do('SET character_set_results = \'utf8\''); + #$self->db_do('SET SESSION NAMES = \'utf8\''); + #$self->db_do('SET character_set_connection = \'utf8\''); + #$self->db_do('SET character_set_results = \'utf8\''); + + #$self->db_do('SET SESSION date_format = \'%Y-%m-%d\''); + #$self->db_do('SET SESSION time_format = \'%H:%i:%s\''); + #$self->db_do('SET SESSION time_zone = \'Europe/Paris\''); + #$self->db_do('SET SESSION datetime_format = \'%Y-%m-%d %H:%i:%s\''); + + if (length($serialization_level) > 0) { + $self->db_do('SET SESSION TRANSACTION ISOLATION LEVEL ' . $serialization_level); + } + + dbinfo($self,'connected',$logger); + +} + +sub vacuum { + + my $self = shift; + my $tablename = shift; + + $self->db_do('OPTIMIZE TABLE ' . $self->tableidentifier($tablename)); + +} + +sub _db_disconnect { + + my $self = shift; + + $self->SUPER::_db_disconnect(); + +} + +sub getfieldnames { + + my $self = shift; + my $tablename = shift; + return $self->db_get_col('SHOW FIELDS FROM ' . $self->tableidentifier($tablename)); + +} + +sub getprimarykeycols { + + my $self = shift; + my $tablename = shift; + my $fieldinfo = $self->db_get_all_hashref('SHOW FIELDS FROM ' . $self->tableidentifier($tablename),'Field'); + my @keycols = (); + foreach my $fieldname (keys %$fieldinfo) { + if (uc($fieldinfo->{$fieldname}->{'Key'}) eq 'PRI') { + push @keycols,$fieldname; + } + } + return \@keycols; + +} + +sub create_temptable { + + my $self = shift; + my $select_stmt = shift; + my $indexes = shift; + + my $index_tablename = $self->_gettemptablename(); + my $temp_tablename = $self->tableidentifier($index_tablename); + + $self->db_do('CREATE TEMPORARY TABLE ' . $temp_tablename . ' AS ' . $select_stmt); + temptablecreated($self,$index_tablename,$logger); + + if (defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) { + foreach my $indexname (keys %$indexes) { + #my $indexcols = $self->_extract_indexcols($indexes->{$indexname}); + #if (not arrayeq($indexcols,$keycols,1)) { + #$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')'; + my $temptable_indexname = lc($index_tablename) . '_' . $indexname; + $self->db_do('CREATE INDEX ' . $temptable_indexname . ' ON ' . $temp_tablename . ' (' . join(', ', map { local $_ = $_; my @indexcol = _split_indexcol($_); $_ = $self->columnidentifier($indexcol[0]) . $indexcol[1]; $_; } @{$indexes->{$indexname}}) . ')'); + indexcreated($self,$index_tablename,$indexname,$logger); + #} + } + } + + return $temp_tablename; + +} + +sub create_primarykey { + + my $self = shift; + my ($tablename,$keycols,$fieldnames) = @_; + + if (length($tablename) > 0 and defined $fieldnames and ref $fieldnames eq 'ARRAY') { + + if (defined $keycols and ref $keycols eq 'ARRAY' and scalar @$keycols > 0 and setcontains($keycols,$fieldnames,1)) { + my $statement = 'ALTER TABLE ' . $self->tableidentifier($tablename) . ' ADD PRIMARY KEY (' . join(', ',map { local $_ = $_; my @indexcol = _split_indexcol($_); $_ = $self->columnidentifier($indexcol[0]) . $indexcol[1]; $_; } @$keycols) . ')'; + $self->db_do($statement); + primarykeycreated($self,$tablename,$keycols,$logger); + return 1; + } + + } + + return 0; +} + +sub create_indexes { + + my $self = shift; + my ($tablename,$indexes,$keycols) = @_; + + my $index_count = 0; + if (length($tablename) > 0) { + + if (defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) { + foreach my $indexname (keys %$indexes) { + if (not arrayeq($self->_extract_indexcols($indexes->{$indexname}),$keycols,1)) { + my $statement = 'CREATE INDEX ' . $indexname . ' ON ' . $self->tableidentifier($tablename) . ' (' . join(', ',map { local $_ = $_; my @indexcol = _split_indexcol($_); $_ = $self->columnidentifier($indexcol[0]) . $indexcol[1]; $_; } @{$indexes->{$indexname}}) . ')'; + $self->db_do($statement); + indexcreated($self,$tablename,$indexname,$logger); + $index_count++; + } + } + } + + } + + return $index_count; +} + +sub create_texttable { + + my $self = shift; + my ($tablename,$fieldnames,$keycols,$indexes,$truncate,$defer_indexes,$texttable_engine) = @_; + + #my $tablename = $self->getsafetablename($tableidentifier); + #my ($tableidentifier,$fieldnames,$keycols,$indexes,$truncate) = @_; + + #my $tablename = $self->getsafetablename($tableidentifier); + + if (length($tablename) > 0 and defined $fieldnames and ref $fieldnames eq 'ARRAY') { + + my $created = 0; + if ($self->table_exists($tablename) == 0) { + my $statement = 'CREATE TABLE ' . $self->tableidentifier($tablename) . ' ('; + #$statement .= join(' TEXT, ',@$fieldnames) . ' TEXT'; + + my @fieldspecs = (); + foreach my $fieldname (@$fieldnames) { + if (contains($fieldname,$keycols,1)) { + push @fieldspecs,$self->columnidentifier($fieldname) . ' VARCHAR(' . $varcharsize . ')'; + #$statement .= $fieldname . ' VARCHAR(256)'; + } else { + push @fieldspecs,$self->columnidentifier($fieldname) . ' TEXT'; + #$statement .= $fieldname . ' TEXT'; + } + } + $statement .= join(', ',@fieldspecs); + + + #if (defined $keycols and ref $keycols eq 'ARRAY' and scalar @$keycols > 0 and setcontains($keycols,$fieldnames,1)) { + if (not $defer_indexes and defined $keycols and ref $keycols eq 'ARRAY' and scalar @$keycols > 0 and setcontains($keycols,$fieldnames,1)) { + $statement .= ', PRIMARY KEY (' . join(', ',map { local $_ = $_; my @indexcol = _split_indexcol($_); $_ = $self->columnidentifier($indexcol[0]) . $indexcol[1]; $_; } @$keycols) . ')'; + } + if (not $defer_indexes and defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) { + foreach my $indexname (keys %$indexes) { + if (not arrayeq($self->_extract_indexcols($indexes->{$indexname}),$keycols,1)) { + $statement .= ', INDEX ' . $indexname . ' (' . join(', ',map { local $_ = $_; my @indexcol = _split_indexcol($_); $_ = $self->columnidentifier($indexcol[0]) . $indexcol[1]; $_; } @{$indexes->{$indexname}}) . ')'; + } + } + } + if (length($texttable_engine) == 0) { + $texttable_engine = $default_texttable_engine; + } + $statement .= ') CHARACTER SET ' . $texttable_charset . ', COLLATE ' . $texttable_collation . ', ENGINE ' . $texttable_engine; + + $self->db_do($statement); + texttablecreated($self,$tablename . ' (' . $texttable_engine . ')',$logger); + $created = 1; + } else { + my $fieldnamesfound = $self->getfieldnames($tablename); + if (not setcontains($fieldnames,$fieldnamesfound,1)) { + fieldnamesdiffer($self,$tablename,$fieldnames,$fieldnamesfound,$logger); + return 0; + } + } + + if (not $created and $truncate) { + $self->truncate_table($tablename); + } + return 1; + } else { + return 0; + } + +} + +sub multithreading_supported { + + my $self = shift; + return 1; + +} + +sub truncate_table { + + my $self = shift; + my $tablename = shift; + + $self->db_do('TRUNCATE ' . $self->tableidentifier($tablename)); + tabletruncated($self,$tablename,$logger); + +} + +sub table_exists { + + my $self = shift; + my $tablename = shift; + + # ... again, avoid using mysql's information_schema table, + # since its availability is obviously user/version dependent. + return itemcount($tablename,$self->db_get_col('SHOW TABLES')); #,1); + +} + +sub drop_table { + + my $self = shift; + my $tablename = shift; + + if ($self->table_exists($tablename) > 0) { + $self->db_do('DROP TABLE ' . $self->tableidentifier($tablename)); + tabledropped($self,$tablename,$logger); + return 1; + } + return 0; + +} + + +sub lock_tables { + + my $self = shift; + my $tablestolock = shift; + + if (defined $self->{dbh} and defined $tablestolock and ref $tablestolock eq 'HASH') { + + my $locks = join(', ',map { local $_ = $_; $_ = $self->tableidentifier($_) . ' ' . $tablestolock->{$_}; $_; } keys %$tablestolock); + dbdebug($self,"lock_tables:\n" . $locks,$logger); + $self->db_do('LOCK TABLES ' . $locks); + + } + +} + +sub unlock_tables { + + my $self = shift; + if (defined $self->{dbh}) { + + dbdebug($self,'unlock_tables',$logger); + $self->db_do('UNLOCK TABLES'); + + } + +} + +sub db_do_begin { + + my $self = shift; + my $query = shift; + my $tablename = shift; + + $self->SUPER::db_do_begin($query,$tablename,$lock_do_chunk,@_); + +} + +sub db_get_begin { + + my $self = shift; + my $query = shift; + my $tablename = shift; + #my $lock = shift; + + $self->SUPER::db_get_begin($query,$tablename,$lock_get_chunk,@_); + +} + +sub db_finish { + + my $self = shift; + #my $unlock = shift; + + $self->SUPER::db_finish($lock_do_chunk | $lock_get_chunk); + +} + +sub _split_indexcol { + my $indexcol = shift; + if ($indexcol =~ /(.+)(\(\d+\))/g) { + return ($1,$2); + } + return ($indexcol, ''); +} + +1; \ No newline at end of file diff --git a/SqlConnectors/OracleDB.pm b/SqlConnectors/OracleDB.pm new file mode 100644 index 0000000..349d9e8 --- /dev/null +++ b/SqlConnectors/OracleDB.pm @@ -0,0 +1,532 @@ +package SqlConnectors::OracleDB; +use strict; + +## no critic + +use File::Basename; +use Cwd; +use lib Cwd::abs_path(File::Basename::dirname(__FILE__) . '/../'); + +use Globals qw($LongReadLen_limit); +use Logging qw( + getlogger + dbinfo + dbdebug + texttablecreated + temptablecreated + indexcreated + primarykeycreated + tabletruncated + tabledropped); +use LogError qw(dberror dbwarn fieldnamesdiffer); + +use DBI; +use DBD::Oracle 1.21; + +use Array qw(contains arrayeq setcontains); + +use SqlConnector; + +require Exporter; +our @ISA = qw(Exporter SqlConnector); +our @EXPORT_OK = qw(get_tableidentifier); + +my $defaultport = '1521'; + +#$NLS_LANG = 'GERMAN_AUSTRIA.WE8ISO8859P1'; + +my $connNLS_LANGUAGE = 'GERMAN'; +my $connNLS_TERRITORY = 'AUSTRIA'; + +#my $connNLS_CHARACTERSET = 'WE8ISO8859P1'; + +my $varcharsize = 4000; +my $max_identifier_length = 30; + +my $LongReadLen = $LongReadLen_limit; #bytes +my $LongTruncOk = 0; + +my $logger = getlogger(__PACKAGE__); + +my $lock_do_chunk = 0; +my $lock_get_chunk = 0; + +my $isolation_level = ''; #'SERIALIZABLE' + +my $enable_numeric_sorting = 0; + +sub new { + + my $class = shift; + + my $self = SqlConnector->new(@_); + + $self->{host} = undef; + $self->{port} = undef; + $self->{servicename} = undef; + $self->{sid} = undef; + $self->{username} = undef; + $self->{password} = undef; + $self->{schema} = undef; + + $self->{drh} = DBI->install_driver('Oracle'); + + bless($self,$class); + + dbdebug($self,__PACKAGE__ . ' connector created',$logger); + + return $self; + +} + +sub _connectidentifier { + + my $self = shift; + if (defined $self->{schema}) { + if ($self->{servicename}) { + return $self->{username} . '@' . $self->{host} . ':' . $self->{port} . '/' . $self->{servicename} . '.' . $self->{schema}; + } elsif ($self->{sid}) { + return $self->{username} . '@' . $self->{host} . ':' . $self->{port} . '/SID ' . $self->{sid} . '.' . $self->{schema}; + } else { + return undef; + } + } else { + return undef; + } + + +} + +sub tableidentifier { + + my $self = shift; + my $tablename = shift; + return get_tableidentifier($tablename,$self->{schema}); + +} + +sub columnidentifier { + + my $self = shift; + my $columnname = shift; + + return $columnname; + +} + +sub _chopidentifier { + my $identifier = shift; + return substr($identifier,0,$max_identifier_length); +} + +sub get_tableidentifier { + + my ($tablename,$schema,$servicename,$sid) = @_; + my $tableidentifier = $tablename; + if (defined $schema) { + $tableidentifier = $schema . '.' . $tableidentifier; + } + if ($servicename) { + $tableidentifier = $servicename . '.' . $tableidentifier; + } elsif ($sid) { + $tableidentifier = $sid . '.' . $tableidentifier; + } + return $tableidentifier; + +} + +sub getsafetablename { + + my $self = shift; + my $tableidentifier = shift; + return uc($self->SUPER::getsafetablename($tableidentifier)); + #if (defined $self->{schema}) { + # return $self->{schema} . '.' . $tablename; + #} else { + # return $tablename; + #} + +} + +sub paginate_sort_query { + + my $self = shift; + my $statement = shift; + my $offset = shift; + my $limit = shift; + my $sortingconfigurations = shift; + + my $orderby = $self->_orderby_columns($sortingconfigurations); + if (length($orderby) > 0) { + $statement .= ' ORDER BY ' . $orderby; + } + if (defined $offset and defined $limit) { + $statement = 'SELECT * FROM (SELECT p.*, rownum rnum FROM (' . $statement . ') p WHERE rownum < ' . ($offset + $limit + 1) . ') WHERE rnum >= ' . ($offset + 1); + } + return $statement; + +} + +sub _force_numeric_column { + my $self = shift; + my $column = shift; + return 'try_to_number(' . $column . ')'; +} + +sub getdatabases { + + my $self = shift; + return $self->db_get_col('SELECT DISTINCT owner FROM all_objects'); + +} + +#sub _createdatabase { +# +# my $self = shift; +# my ($schema) = @_; +# +# #SQL> create tablespace test datafile 'C:\oraclexe\app\oracle\oradata\XE\test.dbf' size 10M autoextend on; +# #Tablespace created. +# #SQL> create user test identified by test default tablespace test; +# #User created. +# #alter user test quota unlimited on test +# +# $self->db_do('CREATE SCHEMA AUTHORIZATION ' . $schema); +# dbinfo($self,'schema \'' . $schema . '\' created',$logger); +# +#} + +sub db_connect { + + my $self = shift; + + my ($servicename,$sid,$schema,$username,$password,$host,$port) = @_; + + $self->SUPER::db_connect($servicename,$sid,$schema,$username,$password,$host,$port); + + $port = $defaultport if (not $port); + + $self->{host} = $host; + $self->{port} = $port; + $self->{servicename} = $servicename; + $self->{sid} = $sid; + $self->{username} = $username; + $self->{password} = $password; + $self->{schema} = $schema; + + dbdebug($self,'connecting',$logger); + + my $dbh; + if ($servicename) { + $dbh = DBI->connect( + 'dbi:Oracle:host=' . $host . ';service_name=' . $servicename . ';port=' . $port,$username,$password, + { + PrintError => 0, + RaiseError => 0, + AutoCommit => 1, + #AutoCommit => 0, + } + ) or dberror($self,'error connecting - service name: ' . $self->{drh}->errstr(),$logger); + } elsif ($sid) { + $dbh = DBI->connect( + 'dbi:Oracle:host=' . $host . ';sid=' . $sid . ';port=' . $port,$username,$password, + { + PrintError => 0, + RaiseError => 0, + AutoCommit => 1, + } + ) or dberror($self,'error connecting - sid: ' . $self->{drh}->errstr(),$logger); + } else { + dberror($self,'neither service name nor sid specified',$logger); + } + + $self->{dbh} = $dbh; + + if (not contains($schema,$self->getdatabases(),0)) { + $self->_createdatabase($schema); #notimplemented error... + } + + $dbh->{InactiveDestroy} = 1; + + $dbh->{LongReadLen} = $LongReadLen; + $dbh->{LongTruncOk} = $LongTruncOk; + + $self->db_do('ALTER SESSION SET NLS_LANGUAGE = \'' . $connNLS_LANGUAGE . '\''); + $self->db_do('ALTER SESSION SET NLS_TERRITORY = \'' . $connNLS_TERRITORY . '\''); + #$self->db_do('ALTER SESSION SET NLS_CHARACTERSET = \'' . $connNLS_CHARACTERSET . '\''); + $self->db_do('ALTER SESSION SET NLS_NUMERIC_CHARACTERS = \'.,\''); + $self->db_do('ALTER SESSION SET NLS_DATE_FORMAT = \'YYYY-MM-DD HH24:MI:SS\''); + + if (length($isolation_level) > 0) { + $self->db_do('ALTER SESSION SET ISOLATION_LEVEL = ' . $isolation_level); + } + + if ($enable_numeric_sorting) { + #http://stackoverflow.com/questions/6470819/sql-if-cannot-convert-to-number-set-as-null + eval { + $self->db_do("CREATE OR REPLACE FUNCTION try_to_number( p_str IN VARCHAR2 )\n" . + " RETURN NUMBER\n" . + "IS\n" . + " l_num NUMBER;\n" . + "BEGIN\n" . + " BEGIN\n" . + " l_num := to_number( p_str );\n" . + " EXCEPTION\n" . + " WHEN others THEN\n" . + " l_num := null;\n" . + " END;\n" . + " RETURN l_num;\n" . + "END;"); + }; + if ($@) { + dbwarn($self,'numeric sorting not supported',$logger); + } + } else { + dbdebug($self,'numeric sorting not enabled',$logger); + } + + dbinfo($self,'connected',$logger); + +} + +sub vacuum { + + my $self = shift; + my $tablename = shift; + +} + +sub _db_disconnect { + + my $self = shift; + + $self->SUPER::_db_disconnect(); + +} + +sub getfieldnames { + + my $self = shift; + my $tablename = shift; + return $self->db_get_col('SELECT column_name FROM all_tab_columns WHERE CONCAT(CONCAT(owner,\'.\'),table_name) = ?',$self->tableidentifier($tablename)); + +} + +sub getprimarykeycols { + + my $self = shift; + my $tablename = shift; + return $self->db_get_col('SELECT cols.column_name FROM all_constraints cons, all_cons_columns cols WHERE + CONCAT(CONCAT(cols.owner,\'.\'),cols.table_name) = ? AND + cons.constraint_type = \'P\' AND + cons.constraint_name = cols.constraint_name AND + cons.owner = cols.owner + ORDER BY cols.table_name, cols.position',$self->tableidentifier($tablename)); + +} + +sub create_temptable { + + my $self = shift; + my $select_stmt = shift; + my $indexes = shift; + + my $index_tablename = $self->_gettemptablename(); + my $temp_tablename = $self->tableidentifier($index_tablename); + + #$self->db_do('CREATE GLOBAL TEMPORARY TABLE ' . $temp_tablename . ' ON COMMIT PRESERVE ROWS AS ' . $select_stmt); + $self->db_do('CREATE TABLE ' . $temp_tablename . ' AS ' . $select_stmt); + push(@{$self->{temp_tables}},$index_tablename); + + temptablecreated($self,$index_tablename,$logger); + + #$self->{temp_table_count} += 1; + + if (defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) { + foreach my $indexname (keys %$indexes) { + my $indexcols = $self->_extract_indexcols($indexes->{$indexname}); + #if (not arrayeq($indexcols,$keycols,1)) { + #$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')'; + $indexname = _chopidentifier(lc($index_tablename) . '_' . $indexname); + $self->db_do('CREATE INDEX ' . $indexname . ' ON ' . $temp_tablename . ' (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$indexcols) . ')'); + indexcreated($self,$index_tablename,$indexname,$logger); + #} + } + } + + return $temp_tablename; + +} + +sub create_primarykey { + + my $self = shift; + my ($tablename,$keycols,$fieldnames) = @_; + + if (length($tablename) > 0 and defined $fieldnames and ref $fieldnames eq 'ARRAY') { + + if (defined $keycols and ref $keycols eq 'ARRAY' and scalar @$keycols > 0 and setcontains($keycols,$fieldnames,1)) { + my $statement = 'ALTER TABLE ' . $self->tableidentifier($tablename) . ' ADD PRIMARY KEY (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$keycols) . ')'; + $self->db_do($statement); + primarykeycreated($self,$tablename,$keycols,$logger); + return 1; + } + + } + + return 0; +} + +sub create_indexes { + + my $self = shift; + my ($tablename,$indexes,$keycols) = @_; + + my $index_count = 0; + if (length($tablename) > 0) { + + if (defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) { + foreach my $indexname (keys %$indexes) { + my $indexcols = $self->_extract_indexcols($indexes->{$indexname}); + if (not arrayeq($indexcols,$keycols,1)) { + #$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')'; + $indexname = _chopidentifier($indexname); + $self->db_do('CREATE INDEX ' . $indexname . ' ON ' . $self->tableidentifier($tablename) . ' (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$indexcols) . ')'); + indexcreated($self,$tablename,$indexname,$logger); + } + } + } + + } + + return $index_count; +} + +sub create_texttable { + + my $self = shift; + my ($tablename,$fieldnames,$keycols,$indexes,$truncate,$defer_indexes) = @_; + #my ($tableidentifier,$fieldnames,$keycols,$indexes,$truncate) = @_; + + #my $tablename = $self->getsafetablename($tableidentifier); + + if (length($tablename) > 0 and defined $fieldnames and ref $fieldnames eq 'ARRAY') { + + my $created = 0; + if ($self->table_exists($tablename) == 0) { + my $statement = 'CREATE TABLE ' . $self->tableidentifier($tablename) . ' ('; + $statement .= join(' VARCHAR2(' . $varcharsize . '), ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$fieldnames) . ' VARCHAR2(' . $varcharsize . ')'; + if (not $defer_indexes and defined $keycols and ref $keycols eq 'ARRAY' and scalar @$keycols > 0 and setcontains($keycols,$fieldnames,1)) { + #$statement .= ', CONSTRAINT ' . $tablename . '_pk PRIMARY KEY (' . join(', ',@$keycols) . ')'; + $statement .= ', CONSTRAINT PRIMARY KEY (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$keycols) . ')'; + } + #if (defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) { + # foreach my $indexname (keys %$indexes) { + # $statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')'; + # } + #} + $statement .= ')'; + + $self->db_do($statement); + texttablecreated($self,$tablename,$logger); + + if (not $defer_indexes and defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) { + foreach my $indexname (keys %$indexes) { + my $indexcols = $self->_extract_indexcols($indexes->{$indexname}); + if (not arrayeq($indexcols,$keycols,1)) { + #$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')'; + $indexname = _chopidentifier($indexname); + $self->db_do('CREATE INDEX ' . $indexname . ' ON ' . $self->tableidentifier($tablename) . ' (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$indexcols) . ')'); + indexcreated($self,$tablename,$indexname,$logger); + } + } + } + $created = 1; + } else { + my $fieldnamesfound = $self->getfieldnames($tablename); + if (not setcontains($fieldnames,$fieldnamesfound,1)) { + fieldnamesdiffer($self,$tablename,$fieldnames,$fieldnamesfound,$logger); + return 0; + } + } + + if (not $created and $truncate) { + $self->truncate_table($tablename); + } + return 1; + } else { + return 0; + } + +} + +sub multithreading_supported { + + my $self = shift; + return 1; + +} + +sub truncate_table { + + my $self = shift; + my $tablename = shift; + + $self->db_do('TRUNCATE ' . $self->tableidentifier($tablename)); + tabletruncated($self,$tablename,$logger); + +} + +sub table_exists { + + my $self = shift; + my $tablename = shift; + + return $self->db_get_value('SELECT COUNT(*) FROM all_tables WHERE CONCAT(CONCAT(owner,\'.\'),table_name) = ?',$self->tableidentifier($tablename)); + +} + +sub drop_table { + + my $self = shift; + my $tablename = shift; + + if ($self->table_exists($tablename) > 0) { + $self->db_do('DROP TABLE ' . $self->tableidentifier($tablename) . ' PURGE'); #CASCADE CONSTRAINTS PURGE'); + tabledropped($self,$tablename,$logger); + return 1; + } + return 0; + +} + +sub db_do_begin { + + my $self = shift; + my $query = shift; + my $tablename = shift; + + $self->SUPER::db_do_begin($query,$tablename,0,@_); + +} + +sub db_get_begin { + + my $self = shift; + my $query = shift; + my $tablename = shift; + + $self->SUPER::db_get_begin($query,$tablename,0,@_); + +} + +sub db_finish { + + my $self = shift; + #my $unlock = shift; + + $self->SUPER::db_finish($lock_do_chunk | $lock_get_chunk); + +} + +1; \ No newline at end of file diff --git a/SqlConnectors/PostgreSQLDB.pm b/SqlConnectors/PostgreSQLDB.pm new file mode 100644 index 0000000..7f9f07c --- /dev/null +++ b/SqlConnectors/PostgreSQLDB.pm @@ -0,0 +1,536 @@ +package SqlConnectors::PostgreSQLDB; +use strict; + +## no critic + +use File::Basename; +use Cwd; +use lib Cwd::abs_path(File::Basename::dirname(__FILE__) . '/../'); + +use Globals qw($LongReadLen_limit); +use Logging qw( + getlogger + dbinfo + dbdebug + texttablecreated + temptablecreated + indexcreated + primarykeycreated + tabletruncated + tabledropped); +use LogError qw(dberror dbwarn fieldnamesdiffer); + +use DBI; +use DBD::Pg 2.17.2; + +use Array qw(arrayeq itemcount contains setcontains); + +use SqlConnector; + +require Exporter; +our @ISA = qw(Exporter SqlConnector); +our @EXPORT_OK = qw(get_tableidentifier); + +my $defaulthost = '127.0.0.1'; +my $defaultport = '5432'; +my $defaultusername = 'postgres'; +my $defaultpassword = ''; +my $defaultschemaname = 'template1'; + +my $varcharsize = 256; + +my $encoding = 'LATIN1'; +my $lc_collate = 'C'; #OS locales only +my $lc_ctype = 'C'; + +my $client_encoding = 'LATIN1'; + +#my $LongReadLen = $LongReadLen_limit; #bytes +#my $LongTruncOk = 0; + +my $logger = getlogger(__PACKAGE__); + +my $lock_do_chunk = 0; +my $lock_get_chunk = 0; + +#my $to_number_pattern = '9.9999999999999'; #EEEE'; + +my $transaction_isolation_level = ''; #'SERIALIZABLE' + +my $enable_numeric_sorting = 0; + +sub new { + + my $class = shift; + + my $self = SqlConnector->new(@_); + + $self->{host} = undef; + $self->{port} = undef; + $self->{schemaname} = undef; + $self->{username} = undef; + $self->{password} = undef; + + $self->{drh} = DBI->install_driver('Pg'); + + bless($self,$class); + + dbdebug($self,__PACKAGE__ . ' connector created',$logger); + + return $self; + +} + +sub _connectidentifier { + + my $self = shift; + if (defined $self->{schemaname}) { + return $self->{username} . '@' . $self->{host} . ':' . $self->{port} . '.' . $self->{schemaname}; + } else { + return undef; + } + +} + +sub tableidentifier { + + my $self = shift; + my $tablename = shift; + return $tablename; + +} + +sub columnidentifier { + + my $self = shift; + my $columnname = shift; + + return $columnname; + +} + +sub get_tableidentifier { + + my ($tablename,$schemaname) = @_; + + #return SUPER::get_tableidentifier($tablename,$schemaname); + + if (defined $schemaname) { + return $schemaname . '.' . $tablename; + } else { + return $tablename; + } + +} + +sub getsafetablename { + + # make a table name (identifier) string save for use within create table statements + # of this rdbms connector. + my $self = shift; + my $tableidentifier = shift; + + return lc($self->SUPER::getsafetablename($tableidentifier)); + + #$tableidentifier =~ s/[^0-9a-z_]/_/gi; + #return lc($tableidentifier); # ... windows! + +} + +sub paginate_sort_query { + my $self = shift; + my $statement = shift; + my $offset = shift; + my $limit = shift; + my $sortingconfigurations = shift; + + my $orderby = $self->_orderby_columns($sortingconfigurations); + if (length($orderby) > 0) { + $statement .= ' ORDER BY ' . $orderby; + } + if (defined $offset and defined $limit) { + $statement .= ' LIMIT ' . $limit . ' OFFSET ' . $offset; + } + return $statement; + +} + +sub _force_numeric_column { + my $self = shift; + my $column = shift; + return 'try_to_number(' . $column . '::text)'; # ,\'' . $to_number_pattern . '\')'; +} + +sub getdatabases { + + my $self = shift; + + my $DBI_USER = $ENV{DBI_USER}; + my $DBI_PASS = $ENV{DBI_PASS}; + $ENV{DBI_USER} = $self->{username}; + $ENV{DBI_PASS} = $self->{password}; + + my @dbs = $self->{drh}->data_sources('port=' . $self->{port} . ';host=' . $self->{host}); + + $DBI_USER = $ENV{DBI_USER}; + $DBI_PASS = $ENV{DBI_PASS}; + + if (scalar @dbs == 0) { + dberror($self,'error listing databases: ' . $self->{drh}->errstr(),$logger); + } else { + @dbs = map { local $_ = $_; $_ =~ s/^dbi:Pg:dbname=[\"\']?([a-zA-Z0-9_-]+)[\"\']?;.+$/$1/gi; $_; } @dbs; + } + + return \@dbs; + +} + +sub _createdatabase { + + my $self = shift; + my ($schemaname) = @_; + + my $dbh = DBI->connect( + 'dbi:Pg:database=template1;host=' . $self->{host} . ';port=' . $self->{port},$self->{username},$self->{password}, + { + PrintError => 0, + RaiseError => 0, + AutoCommit => 1, + #AutoCommit => 0, + } + ) or dberror($self,'error connecting: ' . $self->{drh}->errstr(),$logger); + $self->{dbh} = $dbh; + $self->db_do('CREATE DATABASE ' . $schemaname . ' TEMPLATE template0 ENCODING = ? LC_COLLATE = ? LC_CTYPE = ?', $encoding, $lc_collate, $lc_ctype); + dbinfo($self,'database \'' . $schemaname . '\' created',$logger); + $self->{dbh}->disconnect() or dberror($self,'error disconnecting: ' . $self->{dbh}->errstr(),$logger); + $self->{dbh} = undef; +} + +sub db_connect { + + my $self = shift; + + my ($schemaname,$username,$password,$host,$port) = @_; + + $self->SUPER::db_connect($schemaname,$username,$password,$host,$port); + + $host = $defaulthost if (not $host); + $port = $defaultport if (not $port); + $schemaname = $defaultschemaname if (not $schemaname); + $username = $defaultusername if (not $username); + $password = $defaultpassword if (not $password); + + $self->{host} = $host; + $self->{port} = $port; + $self->{schemaname} = $schemaname; + $self->{username} = $username; + $self->{password} = $password; + + if (not contains($schemaname,$self->getdatabases(),0)) { + $self->_createdatabase($schemaname); + } + + dbdebug($self,'connecting',$logger); + + my $dbh = DBI->connect( + 'dbi:Pg:database=' . $schemaname . ';host=' . $host . ';port=' . $port,$username,$password, + { + PrintError => 0, + RaiseError => 0, + AutoCommit => 1, + #AutoCommit => 0, + } + ) or dberror($self,'error connecting: ' . $self->{drh}->errstr(),$logger); + + $dbh->{InactiveDestroy} = 1; + + #$dbh->{LongReadLen} = $LongReadLen; + #$dbh->{LongTruncOk} = $LongTruncOk; + + $self->{dbh} = $dbh; + + $self->db_do('SET CLIENT_ENCODING TO ?',$client_encoding); + + if (length($transaction_isolation_level) > 0) { + $self->db_do('SET SESSION CHARACTERISTICS AS TRANSACTION ISOLATION LEVEL ' . $transaction_isolation_level); + } + + #http://stackoverflow.com/questions/2082686/how-do-i-cast-a-string-to-integer-and-have-0-in-case-of-error-in-the-cast-with-p + + if ($enable_numeric_sorting) { + eval { + $self->db_do("CREATE OR REPLACE FUNCTION try_to_number (v_input text) RETURNS NUMERIC AS\n" . + '$$' . "\n" . + "DECLARE v_value NUMERIC DEFAULT NULL;\n" . + "BEGIN\n" . + " BEGIN\n" . + " v_value := v_input::NUMERIC;\n" . + " EXCEPTION WHEN OTHERS THEN\n" . + " RAISE NOTICE 'Invalid integer value: \"%\". Returning NULL.', v_input;\n" . + " RETURN NULL;\n" . + " END;\n" . + " RETURN v_value;\n" . + "END;\n" . + '$$' . "\n" . + "LANGUAGE 'plpgsql';\n"); + }; + if ($@) { + dbwarn($self,'numeric sorting not supported',$logger); + } + } else { + dbdebug($self,'numeric sorting not enabled',$logger); + } + + dbinfo($self,'connected',$logger); + +} + +sub vacuum { + + my $self = shift; + my $tablename = shift; + + $self->db_do('VACUUM FULL ' . $self->tableidentifier($tablename)); + +} + +sub _db_disconnect { + + my $self = shift; + ##$self->db_finish(); + #$self->SUPER::db_finish(); + # + #if (defined $self->{dbh}) { + # cleartableinfo($self); + # mysqldbinfo($self,'mysql db disconnecting',$logger); + # $self->{dbh}->disconnect() or mysqldberror($self,'error disconnecting from mysql db',$logger); + # $self->{dbh} = undef; + # + # mysqldbinfo($self,'mysql db disconnected',$logger); + # + #} + + $self->SUPER::_db_disconnect(); + +} + +sub getfieldnames { + + my $self = shift; + my $tablename = shift; + + return $self->db_get_col('SELECT attname FROM pg_attribute WHERE attrelid = \'' . $tablename . '\'::regclass AND attnum > 0 AND NOT attisdropped ORDER BY attnum'); + +} + +sub getprimarykeycols { + + my $self = shift; + my $tablename = shift; + + return $self->db_get_col('SELECT pg_attribute.attname FROM pg_index, pg_class, pg_attribute WHERE pg_class.oid = \'' . $tablename . '\'::regclass AND indrelid = pg_class.oid AND pg_attribute.attrelid = pg_class.oid AND pg_attribute.attnum = any(pg_index.indkey) AND indisprimary'); + +} + +sub create_temptable { + + my $self = shift; + my $select_stmt = shift; + my $indexes = shift; + + my $index_tablename = $self->_gettemptablename(); + my $temp_tablename = $self->tableidentifier($index_tablename); + + $self->db_do('CREATE TEMPORARY TABLE ' . $temp_tablename . ' AS ' . $select_stmt); + temptablecreated($self,$index_tablename,$logger); + + if (defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) { + foreach my $indexname (keys %$indexes) { + my $indexcols = $self->_extract_indexcols($indexes->{$indexname}); + #if (not arrayeq($indexcols,$keycols,1)) { + #$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')'; + $indexname = lc($index_tablename) . '_' . $indexname; + $self->db_do('CREATE INDEX ' . $indexname . ' ON ' . $temp_tablename . ' (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$indexcols) . ')'); + indexcreated($self,$index_tablename,$indexname,$logger); + #} + } + } + + return $temp_tablename; + +} + +sub create_primarykey { + + my $self = shift; + my ($tablename,$keycols,$fieldnames) = @_; + + if (length($tablename) > 0 and defined $fieldnames and ref $fieldnames eq 'ARRAY') { + + if (defined $keycols and ref $keycols eq 'ARRAY' and scalar @$keycols > 0 and setcontains($keycols,$fieldnames,1)) { + my $statement = 'ALTER TABLE ' . $self->tableidentifier($tablename) . ' ADD PRIMARY KEY (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$keycols) . ')'; + $self->db_do($statement); + primarykeycreated($self,$tablename,$keycols,$logger); + return 1; + } + + } + + return 0; +} + +sub create_indexes { + + my $self = shift; + my ($tablename,$indexes,$keycols) = @_; + + my $index_count = 0; + if (length($tablename) > 0) { + + if (defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) { + foreach my $indexname (keys %$indexes) { + my $indexcols = $self->_extract_indexcols($indexes->{$indexname}); + if (not arrayeq($indexcols,$keycols,1)) { + #$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')'; + $self->db_do('CREATE INDEX ' . $indexname . ' ON ' . $self->tableidentifier($tablename) . ' (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$indexcols) . ')'); + indexcreated($self,$tablename,$indexname,$logger); + } + } + } + + } + + return $index_count; +} + +sub create_texttable { + + my $self = shift; + my ($tablename,$fieldnames,$keycols,$indexes,$truncate,$defer_indexes) = @_; + + #my $tablename = $self->getsafetablename($tableidentifier); + #my ($tableidentifier,$fieldnames,$keycols,$indexes,$truncate) = @_; + + #my $tablename = $self->getsafetablename($tableidentifier); + + if (length($tablename) > 0 and defined $fieldnames and ref $fieldnames eq 'ARRAY') { + + my $created = 0; + if ($self->table_exists($tablename) == 0) { + my $statement = 'CREATE TABLE ' . $self->tableidentifier($tablename) . ' ('; + #$statement .= join(' TEXT, ',@$fieldnames) . ' TEXT'; + + my @fieldspecs = (); + foreach my $fieldname (@$fieldnames) { + my $fieldnamespec = $self->columnidentifier($fieldname) . ' TEXT'; + if (not $defer_indexes and contains($fieldname,$keycols,1)) { + $fieldnamespec .= ' PRIMARY KEY'; + } + push @fieldspecs,$fieldnamespec; + } + $statement .= join(', ',@fieldspecs) . ')'; + $self->db_do($statement); + texttablecreated($self,$tablename,$logger); + + if (not $defer_indexes and defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) { + foreach my $indexname (keys %$indexes) { + my $indexcols = $self->_extract_indexcols($indexes->{$indexname}); + if (not arrayeq($indexcols,$keycols,1)) { + #$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')'; + $self->db_do('CREATE INDEX ' . $indexname . ' ON ' . $self->tableidentifier($tablename) . ' (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$indexcols) . ')'); + indexcreated($self,$tablename,$indexname,$logger); + } + } + } + + $created = 1; + } else { + my $fieldnamesfound = $self->getfieldnames($tablename); + if (not setcontains($fieldnames,$fieldnamesfound,1)) { + fieldnamesdiffer($self,$tablename,$fieldnames,$fieldnamesfound,$logger); + return 0; + } + } + + if (not $created and $truncate) { + $self->truncate_table($tablename); + } + return 1; + } else { + return 0; + } + + #return $tablename; + +} + +sub multithreading_supported { + + my $self = shift; + return 1; + +} + +sub truncate_table { + + my $self = shift; + my $tablename = shift; + + $self->db_do('TRUNCATE ' . $self->tableidentifier($tablename)); + tabletruncated($self,$tablename,$logger); + +} + +sub table_exists { + + my $self = shift; + my $tablename = shift; + + return $self->db_get_value('SELECT COUNT(*) FROM pg_catalog.pg_tables WHERE tablename = ?',$tablename); +} + +sub drop_table { + + my $self = shift; + my $tablename = shift; + + if ($self->table_exists($tablename) > 0) { + $self->db_do('DROP TABLE ' . $self->tableidentifier($tablename)); + tabledropped($self,$tablename,$logger); + return 1; + } + return 0; + +} + +sub db_do_begin { + + my $self = shift; + my $query = shift; + my $tablename = shift; + + $self->SUPER::db_do_begin($query,$tablename,$lock_do_chunk,@_); + +} + +sub db_get_begin { + + my $self = shift; + my $query = shift; + my $tablename = shift; + #my $lock = shift; + + $self->SUPER::db_get_begin($query,$tablename,$lock_get_chunk,@_); + +} + +sub db_finish { + + my $self = shift; + #my $unlock = shift; + + $self->SUPER::db_finish($lock_do_chunk | $lock_get_chunk); + +} + +1; \ No newline at end of file diff --git a/SqlConnectors/SQLServerDB.pm b/SqlConnectors/SQLServerDB.pm new file mode 100644 index 0000000..2d3fe07 --- /dev/null +++ b/SqlConnectors/SQLServerDB.pm @@ -0,0 +1,527 @@ +package SqlConnectors::SQLServerDB; +use strict; + +## no critic + +use File::Basename; +use Cwd; +use lib Cwd::abs_path(File::Basename::dirname(__FILE__) . '/../'); + +use Globals qw($LongReadLen_limit); +use Logging qw( + getlogger + dbinfo + dbdebug + texttablecreated + temptablecreated + indexcreated + primarykeycreated + tabletruncated + tabledropped); +use LogError qw( + dberror + fieldnamesdiffer); + +use DBI; +use DBD::ODBC 1.50; + +#https://blog.afoolishmanifesto.com/posts/install-and-configure-the-ms-odbc-driver-on-debian/ +#http://community.spiceworks.com/how_to/show/78224-install-the-ms-sql-odbc-driver-on-debian-7 + +use Array qw(arrayeq itemcount contains setcontains removeduplicates mergearrays); + +use SqlConnector; + +require Exporter; +our @ISA = qw(Exporter SqlConnector); +our @EXPORT_OK = qw(get_tableidentifier); + +my $defaulthost = '127.0.0.1'; +my $defaultport = '1433'; +my $defaultusername = 'SA'; +my $defaultpassword = ''; +my $defaultdatabasename = 'master'; + +my $varcharsize = 900; #8000; + +my $encoding = 'LATIN1'; +my $collation_name = 'Latin1_General_CI_AS'; #OS locales only +my $lc_ctype = 'C'; + +my $client_encoding = 'LATIN1'; + +my $LongReadLen = $LongReadLen_limit; #bytes +my $LongTruncOk = 0; + +my $logger = getlogger(__PACKAGE__); + +my $lock_do_chunk = 0; +my $lock_get_chunk = 0; + +my $transaction_isolation_level = ''; #'SERIALIZABLE' + +sub new { + + my $class = shift; + + my $self = SqlConnector->new(@_); + + $self->{host} = undef; + $self->{port} = undef; + $self->{databasename} = undef; + $self->{username} = undef; + $self->{password} = undef; + + $self->{drh} = DBI->install_driver('ODBC'); + + bless($self,$class); + + dbdebug($self,__PACKAGE__ . ' connector created',$logger); + + return $self; + +} + +sub _connectidentifier { + + my $self = shift; + if (defined $self->{databasename}) { + return $self->{username} . '@' . $self->{host} . ':' . $self->{port} . '.' . $self->{databasename}; + } else { + return undef; + } + +} + +sub tableidentifier { + + my $self = shift; + my $tablename = shift; + return $tablename; +} + +sub columnidentifier { + + my $self = shift; + my $columnname = shift; + + return $columnname; + +} + +sub get_tableidentifier { + + my ($tablename,$databasename) = @_; + + if (defined $databasename) { + return $databasename . '.' . $tablename; + } else { + return $tablename; + } + +} + +sub getsafetablename { + + # make a table name (identifier) string save for use within create table statements + # of this rdbms connector. + my $self = shift; + my $tableidentifier = shift; + + return lc($self->SUPER::getsafetablename($tableidentifier)); + +} + +sub paginate_sort_query { + my $self = shift; + my $statement = shift; + my $offset = shift; + my $limit = shift; + my $sortingconfigurations = shift; + + my $orderby = $self->_orderby_columns($sortingconfigurations); + if (defined $offset and defined $limit and length($orderby) > 0) { + my ($select_fields_part,$table_whereclause_part) = split /\s+from\s+/i,$statement,2; + $select_fields_part =~ s/^\s*select\s+//i; + + return 'SELECT * FROM (SELECT ' . $select_fields_part . ', ROW_NUMBER() OVER (ORDER BY ' . $orderby . ') as row FROM ' . $table_whereclause_part . ') AS p WHERE p.row > ' . $offset . ' AND p.row <= ' . ($offset + $limit); + } + +} + +sub _force_numeric_column { + my $self = shift; + my $column = shift; + return 'TRY_CONVERT(NUMERIC, ' . $column . ')'; +} + +sub _dbd_connect { + my $self = shift; + my $databasename = shift; + my $connection_string; + if ($^O eq 'MSWin32') { + $connection_string = 'DBI:ODBC:Driver={SQL Server};Server=' . $self->{host} . ',' . $self->{port}; + } else { + $connection_string = 'dbi:ODBC:driver=SQL Server Native Client 11.0;server=tcp:' . $self->{host} . ',' . $self->{port}; # . ';database=DB_TOWNE;MARS_Connection=yes; + } + if (length($databasename) > 0) { + $connection_string .= ';database=' . $databasename; + } + return (DBI->connect($connection_string,$self->{username},$self->{password}, + { + PrintError => 0, + RaiseError => 0, + AutoCommit => 1, + #AutoCommit => 0, + } + ) or dberror($self,'error connecting: ' . $self->{drh}->errstr(),$logger)); +} + +sub getdatabases { + + my $self = shift; + + my $connected_wo_db = 0; + if (not defined $self->{dbh}) { + $self->{dbh} = $self->_dbd_connect(); + $connected_wo_db = 1; + } + my $dbs = $self->db_get_col('SELECT name FROM master..sysdatabases'); + if ($connected_wo_db) { + $self->{dbh}->disconnect() or dberror($self,'error disconnecting: ' . $self->{dbh}->errstr(),$logger); + $self->{dbh} = undef; + } + + return $dbs; + +} + +sub _createdatabase { + + my $self = shift; + my ($databasename) = @_; + + $self->{dbh} = $self->_dbd_connect(); + $self->db_do('CREATE DATABASE ' . $databasename . ' COLLATE ' . $collation_name); + dbinfo($self,'database \'' . $databasename . '\' created',$logger); + $self->{dbh}->disconnect() or dberror($self,'error disconnecting: ' . $self->{dbh}->errstr(),$logger); + $self->{dbh} = undef; +} + +sub db_connect { + + my $self = shift; + + my ($databasename,$username,$password,$host,$port) = @_; + + $self->SUPER::db_connect($databasename,$username,$password,$host,$port); + + #if (defined $self->{dbh}) { + # $self->db_disconnect(); + #} + + $host = $defaulthost if (not $host); + $port = $defaultport if (not $port); + $databasename = $defaultdatabasename if (not $databasename); + $username = $defaultusername if (not $username); + $password = $defaultpassword if (not $password); + + $self->{host} = $host; + $self->{port} = $port; + $self->{databasename} = $databasename; + $self->{username} = $username; + $self->{password} = $password; + + if (not contains($databasename,$self->getdatabases(),0)) { + $self->_createdatabase($databasename); + } + + dbdebug($self,'connecting',$logger); + + my $dbh = $self->_dbd_connect($databasename); + + $dbh->{InactiveDestroy} = 1; + + $dbh->{LongReadLen} = $LongReadLen; + $dbh->{LongTruncOk} = $LongTruncOk; + + $self->{dbh} = $dbh; + + #$self->db_do('SET CLIENT_ENCODING TO ?',$client_encoding); + + if (length($transaction_isolation_level) > 0) { + $self->db_do('SET TRANSACTION ISOLATION LEVEL ' . $transaction_isolation_level); + } + + dbinfo($self,'connected',$logger); + +} + +sub vacuum { + + my $self = shift; + my $tablename = shift; + + $self->db_do('DBCC SHRINKDATABASE (0) WITH NO_INFOMSGS'); + +} + +sub _db_disconnect { + + my $self = shift; + + $self->SUPER::_db_disconnect(); + +} + +sub getfieldnames { + + my $self = shift; + my $tablename = shift; + return $self->db_get_col('SELECT column_name FROM information_schema.columns WHERE table_name = ?',$tablename); + #return $self->db_get_col('SELECT name FROM sys.columns WHERE object_id = OBJECT_ID(?)', 'dbo.' . $tablename); + +} + +sub getprimarykeycols { + + my $self = shift; + my $tablename = shift; + return $self->db_get_col('SELECT c.column_name from ' . + 'information_schema.table_constraints t, ' . + 'information_schema.constraint_column_usage c ' . + 'WHERE ' . + 'c.constraint_name = t.constraint_name ' . + 'AND c.table_name = t.table_name ' . + 'AND t.constraint_type = ? ' . + 'AND c.table_name = ?','PRIMARY KEY',$tablename); + +} + +sub create_temptable { + + my $self = shift; + my $select_stmt = shift; + my $indexes = shift; + + my $index_tablename = $self->_gettemptablename(); + my $temp_tablename = '##' . $index_tablename; + + my ($select_fields_part,$table_whereclause_part) = split /\s+from\s+/i,$select_stmt,2; + + $self->db_do($select_fields_part . ' INTO ' . $temp_tablename . ' FROM ' . $table_whereclause_part); + temptablecreated($self,$index_tablename,$logger); + + if (defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) { + foreach my $indexname (keys %$indexes) { + my $indexcols = $self->_extract_indexcols($indexes->{$indexname}); + #if (not arrayeq($indexcols,$keycols,1)) { + #$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')'; + $indexname = lc($index_tablename) . '_' . $indexname; + $self->db_do('CREATE INDEX ' . $indexname . ' ON ' . $temp_tablename . ' (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$indexcols) . ')'); + indexcreated($self,$index_tablename,$indexname,$logger); + #} + } + } + + return $temp_tablename; + +} + +sub create_primarykey { + + my $self = shift; + my ($tablename,$keycols,$fieldnames) = @_; + + if (length($tablename) > 0 and defined $fieldnames and ref $fieldnames eq 'ARRAY') { + + if (defined $keycols and ref $keycols eq 'ARRAY' and scalar @$keycols > 0 and setcontains($keycols,$fieldnames,1)) { + my $statement = 'ALTER TABLE ' . $self->tableidentifier($tablename) . ' ADD PRIMARY KEY (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$keycols) . ')'; + $self->db_do($statement); + primarykeycreated($self,$tablename,$keycols,$logger); + return 1; + } + + } + + return 0; +} +sub create_indexes { + + my $self = shift; + my ($tablename,$indexes,$keycols) = @_; + + my $index_count = 0; + if (length($tablename) > 0) { + + if (defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) { + foreach my $indexname (keys %$indexes) { + my $indexcols = $self->_extract_indexcols($indexes->{$indexname}); + if (not arrayeq($indexcols,$keycols,1)) { + #$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')'; + $self->db_do('CREATE INDEX ' . $indexname . ' ON ' . $self->tableidentifier($tablename) . ' (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$indexcols) . ')'); + indexcreated($self,$tablename,$indexname,$logger); + } + } + } + + } + + return $index_count; +} + +sub create_texttable { + + my $self = shift; + my ($tablename,$fieldnames,$keycols,$indexes,$truncate,$defer_indexes) = @_; + + #my $tablename = $self->getsafetablename($tableidentifier); + #my ($tableidentifier,$fieldnames,$keycols,$indexes,$truncate) = @_; + + #my $tablename = $self->getsafetablename($tableidentifier); + + if (length($tablename) > 0 and defined $fieldnames and ref $fieldnames eq 'ARRAY') { + + my $created = 0; + if ($self->table_exists($tablename) == 0) { + my $statement = 'CREATE TABLE ' . $self->tableidentifier($tablename) . ' ('; + #$statement .= join(' TEXT, ',@$fieldnames) . ' TEXT'; + + my $allindexcols = []; + if (defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) { + foreach my $indexname (keys %$indexes) { + $allindexcols = mergearrays($allindexcols,$self->_extract_indexcols($indexes->{$indexname})); + #push(@allindexcols, $self->_extract_indexcols($indexes->{$indexname})); + } + } + $allindexcols = removeduplicates($allindexcols,1); + + my @fieldspecs = (); + foreach my $fieldname (@$fieldnames) { + if (contains($fieldname,$keycols,1)) { + push @fieldspecs,$self->columnidentifier($fieldname) . ' VARCHAR(' . $varcharsize . ') NOT NULL'; + #$statement .= $fieldname . ' VARCHAR(256)'; + } elsif (contains($fieldname,$allindexcols,1)) { + push @fieldspecs,$self->columnidentifier($fieldname) . ' VARCHAR(' . $varcharsize . ')'; + #$statement .= $fieldname . ' VARCHAR(256)'; + } else { + push @fieldspecs,$self->columnidentifier($fieldname) . ' VARCHAR(MAX)'; + #$statement .= $fieldname . ' TEXT'; + } + } + $statement .= join(', ',@fieldspecs); + + + #if (defined $keycols and ref $keycols eq 'ARRAY' and scalar @$keycols > 0 and setcontains($keycols,$fieldnames,1)) { + if (not $defer_indexes and defined $keycols and ref $keycols eq 'ARRAY' and scalar @$keycols > 0 and setcontains($keycols,$fieldnames,1)) { + $statement .= ', PRIMARY KEY (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$keycols) . ')'; + } + + $statement .= ')'; # CHARACTER SET ' . $texttable_charset . ', COLLATE ' . $texttable_collation . ', ENGINE ' . $texttable_engine; + + $self->db_do($statement); + texttablecreated($self,$tablename,$logger); + + if (not $defer_indexes and defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) { + foreach my $indexname (keys %$indexes) { + my $indexcols = $self->_extract_indexcols($indexes->{$indexname}); + if (not arrayeq($indexcols,$keycols,1)) { + #$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')'; + $self->db_do('CREATE INDEX ' . $indexname . ' ON ' . $self->tableidentifier($tablename) . ' (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$indexcols) . ')'); + indexcreated($self,$tablename,$indexname,$logger); + } + } + } + + $created = 1; + } else { + my $fieldnamesfound = $self->getfieldnames($tablename); + if (not setcontains($fieldnames,$fieldnamesfound,1)) { + fieldnamesdiffer($self,$tablename,$fieldnames,$fieldnamesfound,$logger); + return 0; + } + } + + if (not $created and $truncate) { + $self->truncate_table($tablename); + } + return 1; + } else { + return 0; + } + + #return $tablename; + +} + +sub multithreading_supported { + + my $self = shift; + return 1; + +} + +sub truncate_table { + + my $self = shift; + my $tablename = shift; + + $self->db_do('TRUNCATE ' . $self->tableidentifier($tablename)); + tabletruncated($self,$tablename,$logger); + +} + +sub table_exists { + + my $self = shift; + my $tablename = shift; + + return $self->db_get_value('SELECT COUNT(*) FROM information_schema.tables WHERE table_name = ?',$tablename); + +} + +sub drop_table { + + my $self = shift; + my $tablename = shift; + + if ($self->table_exists($tablename) > 0) { + $self->db_do('DROP TABLE ' . $self->tableidentifier($tablename)); + tabledropped($self,$tablename,$logger); + return 1; + } + return 0; + +} + +sub db_do_begin { + + my $self = shift; + my $query = shift; + my $tablename = shift; + + $self->SUPER::db_do_begin($query,$tablename,$lock_do_chunk,@_); + +} + +sub db_get_begin { + + my $self = shift; + my $query = shift; + my $tablename = shift; + #my $lock = shift; + + $self->SUPER::db_get_begin($query,$tablename,$lock_get_chunk,@_); + +} + +sub db_finish { + + my $self = shift; + #my $unlock = shift; + + $self->SUPER::db_finish($lock_do_chunk | $lock_get_chunk); + +} + +1; \ No newline at end of file diff --git a/SqlConnectors/SQLiteDB.pm b/SqlConnectors/SQLiteDB.pm new file mode 100644 index 0000000..a072096 --- /dev/null +++ b/SqlConnectors/SQLiteDB.pm @@ -0,0 +1,609 @@ +package SqlConnectors::SQLiteDB; +use strict; + +## no critic + +use File::Basename; +use Cwd; +use lib Cwd::abs_path(File::Basename::dirname(__FILE__) . '/../'); + +use Globals qw( + $local_db_path + $LongReadLen_limit); +use Logging qw( + getlogger + dbinfo + dbdebug + texttablecreated + temptablecreated + indexcreated + tabletruncated + tabledropped); +use LogError qw( + dberror + fieldnamesdiffer + dbwarn + fileerror + filewarn); + +use DBI 1.608 qw(:sql_types); +use DBD::SQLite 1.29; +use Array qw(arrayeq contains setcontains); + +use Utils qw( + tempfilename + timestampdigits + timestamp); + +use SqlConnectors::SQLiteVarianceAggregate; + +use SqlConnector; + +require Exporter; +our @ISA = qw(Exporter SqlConnector); +our @EXPORT_OK = qw($staticdbfilemode + $timestampdbfilemode + $temporarydbfilemode + $memorydbfilemode + $privatedbfilemode + get_tableidentifier + cleanupdbfiles); + +our $staticdbfilemode = 0; #remains on disk after shutdown +our $timestampdbfilemode = 1; #remains on disk after shutdown +our $temporarydbfilemode = 2; #cleaned on shutdown +our $memorydbfilemode = 3; #never on disk +our $privatedbfilemode = 4; #somewhere on disk, cleaned on shutdown + +my $cachesize = 16384; #40000; +my $pagesize = 2048; #8192; +my $busytimeout = 20000; #msecs + +my $dbextension = '.db'; +my $journalpostfix = '-journal'; + +my $texttable_encoding = 'UTF-8'; # sqlite returns whats inserted... + +$DBD::SQLite::COLLATION{no_accents} = sub { + my ( $a, $b ) = map lc, @_; + tr[àâáäåãçðèêéëìîíïñòôóöõøùûúüý] + [aaaaaacdeeeeiiiinoooooouuuuy] for $a, $b; + $a cmp $b; + }; + +my $LongReadLen = $LongReadLen_limit; #bytes +my $LongTruncOk = 0; + +my $logger = getlogger(__PACKAGE__); + +my $lock_do_chunk = 1; +my $lock_get_chunk = 1; + +#SQLite transactions are always serializable. + +sub new { + + my $class = shift; + + my $self = SqlConnector->new(@_); + + $self->{filemode} = undef; + $self->{dbfilename} = undef; + + $self->{drh} = DBI->install_driver('SQLite'); + + bless($self,$class); + + dbdebug($self,__PACKAGE__ . ' connector created',$logger); + + return $self; + +} + +sub _connectidentifier { + + my $self = shift; + return _get_connectidentifier($self->{filemode},$self->{dbfilename}); + +} + +sub tableidentifier { + + my $self = shift; + my $tablename = shift; + return $tablename; + +} + +sub columnidentifier { + + my $self = shift; + my $columnname = shift; + + return $columnname; + +} + +sub get_tableidentifier { + + my ($tablename,$filemode, $filename) = @_; + my $connectionidentifier = _get_connectidentifier($filemode, $filename); + if (defined $connectionidentifier) { + return $connectionidentifier . '.' . $tablename; + } else { + return $tablename; + } + +} + +sub getsafetablename { + + my $self = shift; + my $tableidentifier = shift; + + return $self->SUPER::getsafetablename($tableidentifier); + +} + +sub _force_numeric_column { + my $self = shift; + my $column = shift; + return 'CAST(' . $column . ' AS REAL)'; +} + +sub getdatabases { + + my $self = shift; + + my $rdbextension = quotemeta($dbextension); + my $ucrdbextension = quotemeta(uc($dbextension)); + #my $rjournalpostfix = quotemeta($journalpostfix); + local *DBDIR; + if (not opendir(DBDIR, $local_db_path)) { + fileerror('cannot opendir ' . $local_db_path . ': ' . $!,$logger); + return []; + } + my @files = grep { /($rdbextension|$ucrdbextension)$/ && -f $local_db_path . $_ } readdir(DBDIR); + closedir DBDIR; + my @databases = (); + foreach my $file (@files) { + #print $file; + my $databasename = $file; + $databasename =~ s/($rdbextension|$ucrdbextension)$//g; + push @databases,$databasename; + } + return \@databases; + +} + +sub _createdatabase { + + my $self = shift; + my ($filename) = @_; + my $dbfilename = _getdbfilename($self->{filemode},$filename); + + if ($self->_is_filebased() and not -e $dbfilename) { + my $dbh = DBI->connect( + 'dbi:SQLite:dbname=' . $dbfilename, '', '', + { + PrintError => 0, + RaiseError => 0, + #sqlite_unicode => 1, latin 1 chars + #AutoCommit => 0, + } + ) or dberror($self,'error connecting: ' . $self->{drh}->errstr(),$logger); + $dbh->disconnect() or dbwarn($self,'error disconnecting: ' . $dbh->errstr(),$logger); + dbinfo($self,'database \'' . $dbfilename . '\' created',$logger); + } + + return $dbfilename; + +} + +sub db_connect { + + my $self = shift; + my ($filemode, $filename) = @_; + + $self->SUPER::db_connect($filemode, $filename); + + #if (defined $self->{dbh}) { + # $self->db_disconnect(); + #} + + $self->{filemode} = $filemode; + $self->{dbfilename} = $self->_createdatabase($filename); + + + my $dbh = DBI->connect( + 'dbi:SQLite:dbname=' . $self->{dbfilename}, '', '', + { + PrintError => 0, + RaiseError => 0, + #sqlite_unicode => 1, latin 1 chars + #AutoCommit => 0, + } + ) or dberror($self,'error connecting: ' . $self->{drh}->errstr(),$logger); + #or sqlitedberror($dbfilename,'error connecting to sqlite db',$logger); + + $dbh->{InactiveDestroy} = 1; + + $dbh->{LongReadLen} = $LongReadLen; + $dbh->{LongTruncOk} = $LongTruncOk; + + $dbh->{AutoCommit} = 1; + # we use a mysql style + $dbh->sqlite_create_function('now', 0, \×tamp ); + $dbh->sqlite_create_function('concat', 2, \&_concat ); + #$dbh->sqlite_create_function(float_equal ?? + $dbh->sqlite_create_aggregate( 'variance', 1, 'SQLiteVarianceAggregate' ); + + $dbh->sqlite_busy_timeout($busytimeout); + + $self->{dbh} = $dbh; + + #SQLite transactions are always serializable. + + $self->db_do('PRAGMA foreign_keys = OFF'); + #$self->db_do('PRAGMA default_synchronous = OFF'); + $self->db_do('PRAGMA synchronous = OFF'); + $self->db_do('PRAGMA page_size = ' . $pagesize); + $self->db_do('PRAGMA cache_size = ' . $cachesize); + #$self->db_do('PRAGMA encoding = "UTF-8"'); # only new databases! + $self->db_do('PRAGMA encoding = "' . $texttable_encoding . '"'); # only new databases! + #PRAGMA locking_mode = NORMAL ... by default + #$self->db_do('PRAGMA auto_vacuum = INCREMENTAL'); + + dbinfo($self,'connected',$logger); + +} + +sub _concat { + + return $_[0] . $_[1]; + +} + +sub vacuum { + + my $self = shift; + my $tablename = shift; + + $self->db_finish(); + + if (defined $self->{dbh}) { + if ($self->{filemode} == $staticdbfilemode or $self->{filemode} == $timestampdbfilemode) { + $self->db_do('VACUUM'); # or sqlitedberror($self,"failed to VACUUM\nDBI error:\n" . $self->{dbh}->errstr(),$logger); + dbinfo($self,'VACUUMed',$logger); + } + } + +} + +sub _db_disconnect { + + my $self = shift; + + $self->SUPER::_db_disconnect(); + + if ($self->{filemode} == $temporarydbfilemode and defined $self->{dbfilename} and -e $self->{dbfilename}) { + if ((unlink $self->{dbfilename}) > 0) { + dbinfo($self,'db file removed',$logger); + } else { + dbwarn($self,'cannot remove db file: ' . $!,$logger); + } + my $journalfilename = $self->{dbfilename} . '-journal'; + if (-e $journalfilename) { + if ((unlink $journalfilename) > 0) { + dbinfo($self,'journal file removed',$logger); + } else { + dbwarn($self,'cannot remove journal file: ' . $!,$logger); + } + } + } + +} + + +sub cleanupdbfiles { + + my (@remainingdbfilenames) = @_; + my $rdbextension = quotemeta($dbextension); + my $ucrdbextension = quotemeta(uc($dbextension)); + my $rjournalpostfix = quotemeta($journalpostfix); + local *DBDIR; + if (not opendir(DBDIR, $local_db_path)) { + fileerror('cannot opendir ' . $local_db_path . ': ' . $!,$logger); + return; + } + my @files = grep { /($rdbextension|$ucrdbextension)($rjournalpostfix)?$/ && -f $local_db_path . $_ } readdir(DBDIR); + closedir DBDIR; + my @remainingdbfiles = (); + foreach my $filename (@remainingdbfilenames) { + push @remainingdbfiles,$local_db_path . $filename . $dbextension; + push @remainingdbfiles,$local_db_path . $filename . $dbextension . $journalpostfix; + push @remainingdbfiles,$local_db_path . uc($filename . $dbextension) . $journalpostfix; + } + foreach my $file (@files) { + #print $file; + my $filepath = $local_db_path . $file; + if (not contains($filepath,\@remainingdbfiles)) { + if ((unlink $filepath) == 0) { + filewarn('cannot remove ' . $filepath . ': ' . $!,$logger); + } + } + } + +} + +sub getfieldnames { + + my $self = shift; + my $tablename = shift; + my @fieldnames = keys %{$self->db_get_all_hashref('PRAGMA table_info(' . $tablename . ')','name')}; + return \@fieldnames; + +} + +sub getprimarykeycols { + + my $self = shift; + my $tablename = shift; + #return $self->db_get_col('SHOW FIELDS FROM ' . $tablename); + my $fieldinfo = $self->db_get_all_hashref('PRAGMA table_info(' . $tablename . ')','name'); + my @keycols = (); + foreach my $fieldname (keys %$fieldinfo) { + if ($fieldinfo->{$fieldname}->{'pk'}) { + push @keycols,$fieldname; + } + } + return \@keycols; + +} + +sub create_primarykey { + + my $self = shift; + my ($tablename,$keycols,$fieldnames) = @_; + + #not supported by sqlite + + return 0; +} + +sub create_indexes { + my $self = shift; + my ($tablename,$indexes,$keycols) = @_; + + my $index_count = 0; + if (length($tablename) > 0) { + + if (defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) { + foreach my $indexname (keys %$indexes) { + my $indexcols = $self->_extract_indexcols($indexes->{$indexname}); + if (not arrayeq($indexcols,$keycols,1)) { + #$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')'; + $self->db_do('CREATE INDEX ' . $indexname . ' ON ' . $self->tableidentifier($tablename) . ' (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$indexcols) . ')'); + indexcreated($self,$tablename,$indexname,$logger); + } + } + } + + } + + return $index_count; +} + +sub create_temptable { + + my $self = shift; + my $select_stmt = shift; + my $indexes = shift; + + my $index_tablename = $self->_gettemptablename(); + my $temp_tablename = $self->tableidentifier($index_tablename); + + $self->db_do('CREATE TEMPORARY TABLE ' . $temp_tablename . ' AS ' . $select_stmt); + #push(@{$self->{temp_tables}},$temp_tablename); + temptablecreated($self,$index_tablename,$logger); + + #$self->{temp_table_count} += 1; + + if (defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) { + foreach my $indexname (keys %$indexes) { + my $indexcols = $self->_extract_indexcols($indexes->{$indexname}); + #if (not arrayeq($indexcols,$keycols,1)) { + #$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')'; + $indexname = lc($index_tablename) . '_' . $indexname; + $self->db_do('CREATE INDEX ' . $indexname . ' ON ' . $temp_tablename . ' (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$indexcols) . ')'); + indexcreated($self,$index_tablename,$indexname,$logger); + #} + } + } + + return $temp_tablename; + +} + +sub create_texttable { + + my $self = shift; + my ($tablename,$fieldnames,$keycols,$indexes,$truncate,$defer_indexes) = @_; + #my ($tableidentifier,$fieldnames,$keycols,$indexes,$truncate) = @_; + + #my $tablename = $self->getsafetablename($tableidentifier); + + if (length($tablename) > 0 and defined $fieldnames and ref $fieldnames eq 'ARRAY') { + + my $created = 0; + if ($self->table_exists($tablename) == 0) { + my $statement = 'CREATE TABLE ' . $self->tableidentifier($tablename) . ' ('; + $statement .= join(' TEXT, ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$fieldnames) . ' TEXT'; # sqlite_unicode off... outcoming strings not marked utf8 + #$statement .= join(' BLOB, ',@$fieldnames) . ' BLOB'; #to maintain source char encoding when inserting? + #if (not $defer_indexes and defined $keycols and ref $keycols eq 'ARRAY' and scalar @$keycols > 0 and setcontains($keycols,$fieldnames,1)) { + if (defined $keycols and ref $keycols eq 'ARRAY' and scalar @$keycols > 0 and setcontains($keycols,$fieldnames,1)) { + $statement .= ', PRIMARY KEY (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$keycols) . ')'; + } + $statement .= ')'; + + $self->db_do($statement); + texttablecreated($self,$tablename,$logger); + + if (not $defer_indexes and defined $indexes and ref $indexes eq 'HASH' and scalar keys %$indexes > 0) { + foreach my $indexname (keys %$indexes) { + my $indexcols = $self->_extract_indexcols($indexes->{$indexname}); + if (not arrayeq($indexcols,$keycols,1)) { + #$statement .= ', INDEX ' . $indexname . ' (' . join(', ',@{$indexes->{$indexname}}) . ')'; + $self->db_do('CREATE INDEX ' . $indexname . ' ON ' . $self->tableidentifier($tablename) . ' (' . join(', ',map { local $_ = $_; $_ = $self->columnidentifier($_); $_; } @$indexcols) . ')'); + indexcreated($self,$tablename,$indexname,$logger); + } + } + } + $created = 1; + } else { + my $fieldnamesfound = $self->getfieldnames($tablename); + if (not setcontains($fieldnames,$fieldnamesfound,1)) { + fieldnamesdiffer($self,$tablename,$fieldnames,$fieldnamesfound,$logger); + return 0; + } + } + + if (not $created and $truncate) { + $self->truncate_table($tablename); + } + return 1; + } else { + return 0; + } + + #return $tablename; + +} + +sub multithreading_supported { + + my $self = shift; + return 1; + +} + +sub truncate_table { + + my $self = shift; + my $tablename = shift; + + $self->db_do('DELETE FROM ' . $self->tableidentifier($tablename)); + #$self->db_do('VACUUM'); + tabletruncated($self,$tablename,$logger); + +} + +sub table_exists { + + my $self = shift; + my $tablename = shift; + + return $self->db_get_value('SELECT COUNT(*) FROM sqlite_master WHERE type = \'table\' AND name = ?',$tablename); + +} + +sub drop_table { + + my $self = shift; + my $tablename = shift; + + if ($self->table_exists($tablename) > 0) { + $self->db_do('DROP TABLE ' . $self->tableidentifier($tablename)); + + #my $indexes = $self->db_get_col('SELECT name FROM sqlite_master WHERE type = \'index\' AND tbl_name = ?',$tablename); + #foreach my $indexname (@$indexes) { + # $self->db_do('DROP INDEX IF EXISTS ' . $indexname); + #} + + + #$self->db_do('VACUUM'); + tabledropped($self,$tablename,$logger); + return 1; + } + return 0; + +} + +sub _get_connectidentifier { + + my ($filemode, $filename) = @_; + if ($filemode == $staticdbfilemode and defined $filename) { + return $filename; + } elsif ($filemode == $timestampdbfilemode) { + return $filename; + } elsif ($filemode == $temporarydbfilemode) { + return $filename; + } elsif ($filemode == $memorydbfilemode) { + return ''; + } elsif ($filemode == $privatedbfilemode) { + return ''; + } else { + return undef; + } + +} + +sub _getdbfilename { + + my ($filemode,$filename) = @_; + if ($filemode == $staticdbfilemode and defined $filename) { + return $local_db_path . $filename . $dbextension; + } elsif ($filemode == $timestampdbfilemode) { + return $local_db_path . timestampdigits() . $dbextension; + } elsif ($filemode == $temporarydbfilemode) { + return tempfilename('XXXX',$local_db_path,$dbextension); + } elsif ($filemode == $memorydbfilemode) { + return ':memory:'; + } elsif ($filemode == $privatedbfilemode) { + return ''; + } + +} + +sub _is_filebased { + + my $self = shift; + if ($self->{filemode} == $staticdbfilemode or $self->{filemode} == $timestampdbfilemode or $self->{filemode} == $temporarydbfilemode) { + return 1; + } else { + return 0; + } + +} + +sub db_do_begin { + + my $self = shift; + my $query = shift; + my $tablename = shift; + + $self->SUPER::db_do_begin($query,$tablename,$lock_do_chunk,@_); + +} + +sub db_get_begin { + + my $self = shift; + my $query = shift; + my $tablename = shift; + #my $lock = shift; + + $self->SUPER::db_get_begin($query,$tablename,$lock_get_chunk,@_); + +} + +sub db_finish { + + my $self = shift; + #my $unlock = shift; + + $self->SUPER::db_finish($lock_do_chunk | $lock_get_chunk); + +} + +1; \ No newline at end of file diff --git a/SqlConnectors/SQLiteVarianceAggregate.pm b/SqlConnectors/SQLiteVarianceAggregate.pm new file mode 100644 index 0000000..5a207e8 --- /dev/null +++ b/SqlConnectors/SQLiteVarianceAggregate.pm @@ -0,0 +1,67 @@ +# helper module to implement variance aggregate function with SQLite +# adamk@cpan.org +# 2009 + +# used only for testing custom functions ... + +package SqlConnectors::SQLiteVarianceAggregate; +use strict; + +## no critic + +use File::Basename; +use Cwd; +use lib Cwd::abs_path(File::Basename::dirname(__FILE__) . '/../'); + + #sub new { bless [], shift; } + # + #sub step { + # my ( $self, $value ) = @_; + # + # push @$self, $value; + #} + # + #sub finalize { + # my $self = $_[0]; + # + # my $n = @$self; + # + # # Variance is NULL unless there is more than one row + # return undef unless $n || $n == 1; + # + # my $mu = 0; + # foreach my $v ( @$self ) { + # $mu += $v; + # } + # $mu /= $n; + # + # my $sigma = 0; + # foreach my $v ( @$self ) { + # #$sigma += ($x - $mu)**2; + # $sigma += ($v - $mu)**2; + # } + # $sigma = $sigma / ($n - 1); + # + # return $sigma; + #} + +my $mu = 0; +my $count = 0; +my $S = 0; + +sub new { bless [], shift; } + +sub step { + my ( $self, $value ) = @_; + $count++; + my $delta = $value - $mu; + $mu += $delta / $count; + $S += $delta * ($value - $mu); +} + +sub finalize { + my $self = $_[0]; + return $S / ($count - 1); +} + +1; \ No newline at end of file diff --git a/SqlRecord.pm b/SqlRecord.pm new file mode 100644 index 0000000..7f0c559 --- /dev/null +++ b/SqlRecord.pm @@ -0,0 +1,1504 @@ +# record base object + +package SqlRecord; +use strict; + +## no critic + +#use Thread qw(async yield); +#use Thread::Queue; +use threads qw(yield); +use threads::shared; +use Thread::Queue; +#use Thread::Semaphore; +#use POSIX qw(ceil); + +use Time::HiRes qw(sleep); + +use Logging qw( + getlogger + fieldnamesaquired + primarykeycolsaquired + tableinfoscleared + + tablefixed + + tabletransferstarted + tableprocessingstarted + + rowtransferstarted + rowtransferred + rowskipped + rowinserted + rowupdated + rowsdeleted + totalrowsdeleted + rowinsertskipped + rowupdateskipped + tabletransferdone + tableprocessingdone + rowtransferdone + + fetching_rows + writing_rows + processing_rows + + tablethreadingdebug +); + +use LogError qw( + fieldnamesdiffer + transferzerorowcount + processzerorowcount + deleterowserror + tabletransferfailed + tableprocessingfailed +); +#use LogWarn qw(calendarwarn); + +use Table qw(get_rowhash); +use Array qw(setcontains contains); +use Utils qw(round threadid); +#use SQLiteDB qw(sqlitetablename); +#use ConnectorPool qw(destroy_dbs_thread); + +#use LoadConfig; +use Globals qw( +$enablemultithreading +$cpucount +$cells_transfer_memory_limit +$defer_indexes); + +#use Terminate qw(setsigkill); + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw( + transfer_table + copy_row + process_table + cleartableinfo + checktableinfo + registertableinfo + create_targettable + transfer_record + transfer_records + insert_record + update_record + delete_records +); + +my $table_expected_fieldnames = {}; +my $table_fieldnames_cached = {}; +my $table_primarykeys = {}; +my $table_target_indexes = {}; + +my $logger = getlogger(__PACKAGE__); + +my $tabletransfer_threadqueuelength = 5; #100; #30; #5; # ... >= 1 +my $minblocksize = 100; +my $maxblocksize = 100000; +my $minnumberofchunks = 10; + +my $tableprocessing_threadqueuelength = 10; +my $tableprocessing_threads = $cpucount; #3; + +my $reader_connection_name = 'reader'; +#my $writer_connection_name = 'writer'; + +my $thread_sleep_secs = 0.1; + +sub new { + + my $class = shift; + my $self = bless {}, $class; + my ($get_db,$tablename,$expected_fieldnames,$target_indexes) = @_; + + my $db = (ref $get_db eq 'CODE') ? &$get_db() : $get_db; + + my $connectidentifier = $db->connectidentifier(); + my $tid = threadid(); + + checktableinfo($db,$tablename,$expected_fieldnames,$target_indexes); + + + if (defined $table_expected_fieldnames->{$tid}->{$connectidentifier}->{$tablename}) { # and ref $table_fieldnames_cached->{$connectidentifier}->{$tablename} eq 'ARRAY') { + # if there are fieldnames defined, we make a member variable for each and set it to undef + foreach my $fieldname (@{$table_expected_fieldnames->{$tid}->{$connectidentifier}->{$tablename}}) { + $self->{$fieldname} = undef; + } + } + + return $self; + +} + +sub gethash { + my $self = shift; + my @fieldvalues = (); + foreach my $field (sort keys %$self) { #http://www.perlmonks.org/?node_id=997682 + my $value = $self->{$field}; + if (ref $value eq '') { + push(@fieldvalues,$value); + } + } + return get_rowhash(\@fieldvalues); +} + +sub cleartableinfo { + + my $get_db = shift; + + my $db = (ref $get_db eq 'CODE') ? &$get_db() : $get_db; + my $tid = threadid(); + + my $connectidentifier = $db->connectidentifier(); + + my $found = 0; + + if (exists $table_expected_fieldnames->{$tid}) { + if (exists $table_expected_fieldnames->{$tid}->{$connectidentifier}) { + delete $table_expected_fieldnames->{$tid}->{$connectidentifier}; + $found = 1; + } + } + if (exists $table_fieldnames_cached->{$tid}){ + if (exists $table_fieldnames_cached->{$tid}->{$connectidentifier}) { + delete $table_fieldnames_cached->{$tid}->{$connectidentifier}; + $found = 1; + } + } + if (exists $table_primarykeys->{$tid}) { + if (exists $table_primarykeys->{$tid}->{$connectidentifier}) { + delete $table_primarykeys->{$tid}->{$connectidentifier}; + $found = 1; + } + } + if (exists $table_target_indexes->{$tid}) { + if (exists $table_target_indexes->{$tid}->{$connectidentifier}) { + delete $table_target_indexes->{$tid}->{$connectidentifier}; + $found = 1; + } + } + + if ((scalar keys %{$table_expected_fieldnames->{$tid}}) == 0) { + delete $table_expected_fieldnames->{$tid}; + $found = 1; + } + if ((scalar keys %{$table_fieldnames_cached->{$tid}}) == 0) { + delete $table_fieldnames_cached->{$tid}; + $found = 1; + } + if ((scalar keys %{$table_primarykeys->{$tid}}) == 0) { + delete $table_primarykeys->{$tid}; + $found = 1; + } + if ((scalar keys %{$table_target_indexes->{$tid}}) == 0) { + delete $table_target_indexes->{$tid}; + $found = 1; + } + + if ($found) { + tableinfoscleared($db,$logger); + } + +} + +sub registertableinfo { + + my ($get_db,$tablename,$fieldnames,$indexes,$keycols) = @_; + + my $db = (ref $get_db eq 'CODE') ? &$get_db() : $get_db; + + my $connectidentifier = $db->connectidentifier(); + my $tid = threadid(); + + if (not exists $table_expected_fieldnames->{$tid}) { + $table_expected_fieldnames->{$tid} = {}; + } + if (not exists $table_expected_fieldnames->{$tid}->{$connectidentifier}) { + # create an empty category for the connection if none exists yet: + $table_expected_fieldnames->{$tid}->{$connectidentifier} = {}; + } + # we prefer to always update the expected fieldnames (that come from a derived class) + $table_expected_fieldnames->{$tid}->{$connectidentifier}->{$tablename} = $fieldnames; + + if (not exists $table_fieldnames_cached->{$tid}) { + $table_fieldnames_cached->{$tid} = {}; + } + if (not exists $table_fieldnames_cached->{$tid}->{$connectidentifier}) { + # create an empty fieldname cache for the connection if none exists yet: + $table_fieldnames_cached->{$tid}->{$connectidentifier} = {}; + } + + if (not exists $table_primarykeys->{$tid}) { + $table_primarykeys->{$tid} = {}; + } + if (not exists $table_primarykeys->{$tid}->{$connectidentifier}) { + # create an empty primary key column name cache for the connection if none exists yet: + $table_primarykeys->{$tid}->{$connectidentifier} = {}; + } + $table_primarykeys->{$tid}->{$connectidentifier}->{$tablename} = $keycols; + + if (not exists $table_target_indexes->{$tid}) { + $table_target_indexes->{$tid} = {}; + } + if (not exists $table_target_indexes->{$tid}->{$connectidentifier}) { + # create an empty index set list for target tables for the connection if none exists yet: + $table_target_indexes->{$tid}->{$connectidentifier} = {}; + } + # we prefer to always update the target table indexes (that come from a derived class) + $table_target_indexes->{$tid}->{$connectidentifier}->{$tablename} = $indexes; + +} + +sub checktableinfo { + + my ($get_db,$tablename,$expected_fieldnames,$target_indexes) = @_; + + my $success = 1; + + my $db = (ref $get_db eq 'CODE') ? &$get_db() : $get_db; + + my $connectidentifier = $db->connectidentifier(); + my $tid = threadid(); + + if (not exists $table_expected_fieldnames->{$tid}) { + #$table_expected_fieldnames->{$tid} = shared_clone({}); + $table_expected_fieldnames->{$tid} = {}; + } + if (not exists $table_expected_fieldnames->{$tid}->{$connectidentifier}) { + # create an empty category for the connection if none exists yet: + #$table_expected_fieldnames->{$tid}->{$connectidentifier} = shared_clone({}); + $table_expected_fieldnames->{$tid}->{$connectidentifier} = {}; + } + # we prefer to always update the expected fieldnames (that come from a derived class) + #$table_expected_fieldnames->{$tid}->{$connectidentifier}->{$tablename} = shared_clone($expected_fieldnames); + $table_expected_fieldnames->{$tid}->{$connectidentifier}->{$tablename} = $expected_fieldnames; + + if (not exists $table_fieldnames_cached->{$tid}) { + #$table_fieldnames_cached->{$tid} = shared_clone({}); + $table_fieldnames_cached->{$tid} = {}; + } + if (not exists $table_fieldnames_cached->{$tid}->{$connectidentifier}) { + # create an empty fieldname cache for the connection if none exists yet: + #$table_fieldnames_cached->{$tid}->{$connectidentifier} = shared_clone({}); + $table_fieldnames_cached->{$tid}->{$connectidentifier} = {}; + } + + if (not exists $table_fieldnames_cached->{$tid}->{$connectidentifier}->{$tablename}) { + # query the database for fieldnames of the table if we don't have a cache entry yet: + #$table_fieldnames_cached->{$tid}->{$connectidentifier}->{$tablename} = shared_clone($db->getfieldnames($tablename)); + $table_fieldnames_cached->{$tid}->{$connectidentifier}->{$tablename} = $db->getfieldnames($tablename); + #my $fieldnames = $db->getfieldnames($tablename); + if (not defined $table_expected_fieldnames->{$tid}->{$connectidentifier}->{$tablename} or setcontains($table_expected_fieldnames->{$tid}->{$connectidentifier}->{$tablename},$table_fieldnames_cached->{$tid}->{$connectidentifier}->{$tablename},1)) { #fieldnames are case insensitive in general + # if not expected fieldnames are given or queried fieldnames match, we log this: + #$table_fieldnames_cached->{$connectidentifier}->{$tablename} = $table_expected_fieldnames->{$connectidentifier}->{$tablename}; + fieldnamesaquired($db,$tablename,$logger); + } else { + # otherwise we log a failure (exit? - see Logging Module) + #$table_fieldnames_cached->{$connectidentifier}->{$tablename} = {}; #$fieldnames; + fieldnamesdiffer($db,$tablename,$table_expected_fieldnames->{$tid}->{$connectidentifier}->{$tablename},$table_fieldnames_cached->{$tid}->{$connectidentifier}->{$tablename},$logger); + $success = 0; + } + } + + if (not exists $table_primarykeys->{$tid}) { + #$table_primarykeys->{$tid} = shared_clone({}); + $table_primarykeys->{$tid} = {}; + } + if (not exists $table_primarykeys->{$tid}->{$connectidentifier}) { + # create an empty primary key column name cache for the connection if none exists yet: + #$table_primarykeys->{$tid}->{$connectidentifier} = shared_clone({}); + $table_primarykeys->{$tid}->{$connectidentifier} = {}; + } + if (not exists $table_primarykeys->{$tid}->{$connectidentifier}->{$tablename}) { + # query the database for primary keys of the table if we don't have them cached yet: + #$table_primarykeys->{$tid}->{$connectidentifier}->{$tablename} = shared_clone($db->getprimarykeycols($tablename)); + $table_primarykeys->{$tid}->{$connectidentifier}->{$tablename} = $db->getprimarykeycols($tablename); + primarykeycolsaquired($db,$tablename,$table_primarykeys->{$tid}->{$connectidentifier}->{$tablename},$logger); + } + + if (not exists $table_target_indexes->{$tid}) { + #$table_target_indexes->{$tid} = shared_clone({}); + $table_target_indexes->{$tid} = {}; + } + if (not exists $table_target_indexes->{$tid}->{$connectidentifier}) { + # create an empty index set list for target tables for the connection if none exists yet: + #$table_target_indexes->{$tid}->{$connectidentifier} = shared_clone({}); + $table_target_indexes->{$tid}->{$connectidentifier} = {}; + } + # we prefer to always update the target table indexes (that come from a derived class) + #$table_target_indexes->{$tid}->{$connectidentifier}->{$tablename} = shared_clone($target_indexes); + $table_target_indexes->{$tid}->{$connectidentifier}->{$tablename} = $target_indexes; + + return $success; + +} + +sub create_targettable { + + my ($get_db,$tablename,$get_target_db,$targettablename,$truncate,$defer_indexes,$texttable_engine) = @_; + + my $db = (ref $get_db eq 'CODE') ? &$get_db() : $get_db; + my $target_db = (ref $get_target_db eq 'CODE') ? &$get_target_db() : $get_target_db; + + #my $targettablename = _gettargettablename($db,$tablename,$target_db); + my $connectidentifier = $db->connectidentifier(); + my $tid = threadid(); + + if ($truncate and $defer_indexes) { + $target_db->drop_table($targettablename); + } + + my $result = $target_db->create_texttable($targettablename, + $table_expected_fieldnames->{$tid}->{$connectidentifier}->{$tablename}, + $table_primarykeys->{$tid}->{$connectidentifier}->{$tablename}, + $table_target_indexes->{$tid}->{$connectidentifier}->{$tablename}, + # 'ifnotexists' is always true + $truncate, + $defer_indexes, + $texttable_engine); + + checktableinfo($target_db,$targettablename,$table_expected_fieldnames->{$tid}->{$connectidentifier}->{$tablename},$defer_indexes ? undef : $table_target_indexes->{$tid}->{$connectidentifier}->{$tablename}); + return $result; + +} + +sub delete_records { + + my ($get_db,$tablename,$keyfields,$equal,$vals_table) = @_; + + my $db = (ref $get_db eq 'CODE') ? &$get_db() : $get_db; + + my $connectidentifier = $db->connectidentifier(); + my $tid = threadid(); + + my $expected_fieldnames = $table_expected_fieldnames->{$tid}->{$connectidentifier}->{$tablename}; + my $primarykeys = $table_primarykeys->{$tid}->{$connectidentifier}->{$tablename}; + + if (defined $expected_fieldnames and + (defined $keyfields and + ref $keyfields eq 'ARRAY') and + (defined $vals_table and + ref $vals_table eq 'Table')) { + + my @fields = @$keyfields; + my $field_cnt = scalar @fields; + + my $total_rowcount = 0; + + my $initial_rowcount = $db->db_get_value('SELECT COUNT(*) FROM ' . $db->tableidentifier($tablename)); + + if ($field_cnt > 0) { + my $where_clause; + if ($equal) { + $where_clause = ' WHERE ' . join(' = ? AND ',map { local $_ = $_; $_ = $db->columnidentifier($_); $_; } @fields) . ' = ?'; + + my $count_stmt = 'SELECT COUNT(*) FROM ' . $db->tableidentifier($tablename) . $where_clause; + my $delete_stmt = 'DELETE FROM ' . $db->tableidentifier($tablename) . $where_clause; + + for (my $i = 0; $i < $vals_table->rowcount(); $i++) { + my @vals = $vals_table->getrow($i); + my $new_initial_rowcount = $db->db_get_value('SELECT COUNT(*) FROM ' . $db->tableidentifier($tablename)); + my $rowcount = $db->db_get_value($count_stmt,@vals); + $db->db_do($delete_stmt,@vals); + rowsdeleted($db,$tablename,$rowcount,$new_initial_rowcount,$logger); + $total_rowcount += $rowcount; + } + + } elsif ($field_cnt == 1) { + my @ne_vals = $vals_table->getcol(0); + $where_clause = ' WHERE ' . $db->columnidentifier($fields[0]) . ' NOT IN (' . substr(',?' x scalar @ne_vals,1) . ')'; + my $count_stmt = 'SELECT COUNT(*) FROM ' . $db->tableidentifier($tablename) . $where_clause; + my $delete_stmt = 'DELETE FROM ' . $db->tableidentifier($tablename) . $where_clause; + my $rowcount = $db->db_get_value($count_stmt,@ne_vals); + $db->db_do($delete_stmt,@ne_vals); + rowsdeleted($db,$tablename,$rowcount,$initial_rowcount,$logger); + $total_rowcount += $rowcount; + } else { + + deleterowserror($db,$tablename,'deletings rows by complementary identifier values works with a single identifier column only',$logger); + return; + + } + } else { + my $delete_stmt = 'DELETE FROM ' . $db->tableidentifier($tablename); + my $count_stmt = 'SELECT COUNT(*) FROM ' . $db->tableidentifier($tablename); + my $rowcount = $db->db_get_value($count_stmt); + $db->db_do($delete_stmt); + rowsdeleted($db,$tablename,$rowcount,$initial_rowcount,$logger); + $total_rowcount += $rowcount; + } + + $db->vacuum($tablename); + + #if ($total_rowcount > 0) { + totalrowsdeleted($db,$tablename,$total_rowcount,$initial_rowcount,$logger); + #} + + return $total_rowcount; + + } + +} + +sub insert_record { + + my ($get_db,$tablename,$allowdupes,$row) = @_; + + my $db = (ref $get_db eq 'CODE') ? &$get_db() : $get_db; + + #my $targettablename = _gettargettablename($db,$tablename,$target_db); #$target_db->getsafetablename($db->tableidentifier($tablename)); + my $connectidentifier = $db->connectidentifier(); + my $tid = threadid(); + + my $expected_fieldnames = $table_expected_fieldnames->{$tid}->{$connectidentifier}->{$tablename}; + my $primarykeys = $table_primarykeys->{$tid}->{$connectidentifier}->{$tablename}; + + if (defined $expected_fieldnames and defined $row) { + + my @fieldnames = @$expected_fieldnames; + my @fields = (); + my @vals = (); + + foreach my $fieldname (@fieldnames) { + if (exists $row->{$fieldname}) { + push @fields,$fieldname; + push @vals,$row->{$fieldname}; + } + } + + my @pk_fieldnames; + my @pk_fields = (); + my @pk_vals = (); + + if (not $allowdupes) { + if (defined $primarykeys) { + @pk_fieldnames = @$primarykeys; + if (scalar @pk_fieldnames > 0) { + foreach my $fieldname (@pk_fieldnames) { + if (exists $row->{$fieldname}) { + push @pk_fields,$fieldname; + push @pk_vals,$row->{$fieldname}; + #} else { + # 'insert error: pk field not foun din row'; + # push @pk_vals,undef; + } + } + } else { + @pk_fields = @fields; + @pk_vals = @vals; + } + } else { + @pk_fields = @fields; + @pk_vals = @vals; + } + } + + if ($allowdupes or $db->db_get_value('SELECT COUNT(*) FROM ' . $db->tableidentifier($tablename) . ' WHERE ' . join(' = ? AND ',map { local $_ = $_; $_ = $db->columnidentifier($_); $_; } @pk_fields) . ' = ?',@pk_vals) == 0) { + $db->db_do('INSERT INTO ' . $db->tableidentifier($tablename) . ' (' . join(', ',map { local $_ = $_; $_ = $db->columnidentifier($_); $_; } @fields) . ') VALUES (' . substr(',?' x scalar @fields,1) . ')',@vals); + rowinserted($db,$tablename,$logger); + return 1; + } else { + rowinsertskipped($db,$tablename,$logger); + return 0; + } + + } + +} + +sub update_record { + + my ($get_db,$tablename,$row) = @_; + + my $db = (ref $get_db eq 'CODE') ? &$get_db() : $get_db; + + #my $targettablename = _gettargettablename($db,$tablename,$target_db); #$target_db->getsafetablename($db->tableidentifier($tablename)); + my $connectidentifier = $db->connectidentifier(); + my $tid = threadid(); + + my $expected_fieldnames = $table_expected_fieldnames->{$tid}->{$connectidentifier}->{$tablename}; + my $primarykeys = $table_primarykeys->{$tid}->{$connectidentifier}->{$tablename}; + + if (defined $expected_fieldnames and defined $row) { + + my @fieldnames = @$expected_fieldnames; + my @fields = (); + my @vals = (); + + foreach my $fieldname (@fieldnames) { + if (exists $row->{$fieldname}) { + push @fields,$fieldname; + push @vals,$row->{$fieldname}; + } + } + + my @pk_fieldnames; + my @pk_fields = (); + my @pk_vals = (); + + if (defined $primarykeys) { + @pk_fieldnames = @$primarykeys; + if (scalar @pk_fieldnames > 0) { + foreach my $fieldname (@pk_fieldnames) { + if (exists $row->{$fieldname}) { + push @pk_fields,$fieldname; + push @pk_vals,$row->{$fieldname}; + #} else { + # 'insert error: pk field not foun din row'; + # push @pk_vals,undef; + } + } + } else { + @pk_fields = @fields; + @pk_vals = @vals; + } + } else { + @pk_fields = @fields; + @pk_vals = @vals; + } + + my $selectpk_fieldnames = join(' = ? AND ',map { local $_ = $_; $_ = $db->columnidentifier($_); $_; } @pk_fields); + + if ($db->db_get_value('SELECT COUNT(*) FROM ' . $db->tableidentifier($tablename) . ' WHERE ' . $selectpk_fieldnames . ' = ?',@pk_vals) == 1) { + $db->db_do('UPDATE ' . $db->tableidentifier($tablename) . ' SET ' . join(' = ?, ',map { local $_ = $_; $_ = $db->columnidentifier($_); $_; } @fields) . ' = ? WHERE ' . $selectpk_fieldnames . ' = ?',@vals,@pk_vals); + rowupdated($db,$tablename,$logger); + return 1; + } else { + rowupdateskipped($db,$tablename,$logger); + return 0; + } + + } + +} + +sub transfer_record { + + #my $self = shift + my ($get_db,$tablename,$get_target_db,$targettablename,$allowdupes,$row) = @_; + + my $db = (ref $get_db eq 'CODE') ? &$get_db() : $get_db; + my $target_db = (ref $get_target_db eq 'CODE') ? &$get_target_db() : $get_target_db; + + #my $targettablename = _gettargettablename($db,$tablename,$target_db); #$target_db->getsafetablename($db->tableidentifier($tablename)); + my $connectidentifier = $db->connectidentifier(); + my $tid = threadid(); + + my $expected_fieldnames = $table_expected_fieldnames->{$tid}->{$connectidentifier}->{$tablename}; + my $primarykeys = $table_primarykeys->{$tid}->{$connectidentifier}->{$tablename}; + + if (defined $expected_fieldnames and defined $row) { + + my @fieldnames = @$expected_fieldnames; + my @vals = (); + + foreach my $fieldname (@fieldnames) { + push @vals,$row->{$fieldname}; + } + + my @pk_fieldnames; + my @pk_vals = (); + + if (not $allowdupes) { + if (defined $primarykeys) { + @pk_fieldnames = @$primarykeys; + if (scalar @pk_fieldnames > 0) { + foreach my $fieldname (@pk_fieldnames) { + push @pk_vals,$row->{$fieldname}; + } + } else { + @pk_fieldnames = @fieldnames; + @pk_vals = @vals; + } + } else { + @pk_fieldnames = @fieldnames; + @pk_vals = @vals; + } + } + + if ($allowdupes or $target_db->db_get_value('SELECT COUNT(*) FROM ' . $target_db->tableidentifier($targettablename) . ' WHERE ' . join(' = ? AND ',map { local $_ = $_; $_ = $target_db->columnidentifier($_); $_; } @pk_fieldnames) . ' = ?',@pk_vals) == 0) { + $target_db->db_do('INSERT INTO ' . $target_db->tableidentifier($targettablename) . ' (' . join(', ',map { local $_ = $_; $_ = $target_db->columnidentifier($_); $_; } @fieldnames) . ') VALUES (' . substr(',?' x scalar @fieldnames,1) . ')',@vals); + rowtransferred($db,$tablename,$target_db,$targettablename,1,1,$logger); + return 1; + } else { + rowskipped($db,$tablename,$target_db,$targettablename,1,1,$logger); + return 0; + } + + } + +} + +sub transfer_records { + + my ($get_db,$tablename,$get_target_db,$targettablename,$allowdupes,$rows) = @_; + + my $db = (ref $get_db eq 'CODE') ? &$get_db() : $get_db; + my $target_db = (ref $get_target_db eq 'CODE') ? &$get_target_db() : $get_target_db; + + #my $targettablename = _gettargettablename($db,$tablename,$target_db); #$target_db->getsafetablename($db->tableidentifier($tablename)); + my $connectidentifier = $db->connectidentifier(); + my $tid = threadid(); + + my $expected_fieldnames = $table_expected_fieldnames->{$tid}->{$connectidentifier}->{$tablename}; + my $primarykeys = $table_primarykeys->{$tid}->{$connectidentifier}->{$tablename}; + + if (defined $expected_fieldnames and defined $rows and ref $rows eq 'ARRAY') { # and defined $getrecords_code and ref $getrecords_code eq 'CODE') { + #get_local_db(); + + my $numofrows = scalar @$rows; + rowtransferstarted($db,$tablename,$target_db,$targettablename,$numofrows,$logger); + + my @fieldnames = @$expected_fieldnames; + + my $setfieldnames = join(', ',map { local $_ = $_; $_ = $target_db->columnidentifier($_); $_; } @fieldnames); + my $valueplaceholders = substr(',?' x scalar @fieldnames,1); + + my $rowstransferred = 0; + + if ($allowdupes) { + + my @rows_array = (); + $target_db->db_do_begin('INSERT INTO ' . $target_db->tableidentifier($targettablename) . ' (' . $setfieldnames . ') VALUES (' . $valueplaceholders . ')'); + foreach my $row (@$rows) { + my @vals = (); + foreach my $fieldname (@fieldnames) { + push @vals,$row->{$fieldname}; + } + push @rows_array,\@vals; + } + $target_db->db_do_rowblock(\@rows_array); + $target_db->db_finish(); + $rowstransferred = scalar @rows_array; + + } else { + + my $i = 1; + + my @pk_fieldnames; + + if (defined $primarykeys) { + @pk_fieldnames = @$primarykeys; + if (scalar @pk_fieldnames == 0) { + @pk_fieldnames = @fieldnames; + } + } else { + @pk_fieldnames = @fieldnames; + } + + my $selectpk_fieldnames = join(' = ? AND ',map { local $_ = $_; $_ = $target_db->columnidentifier($_); $_; } @pk_fieldnames) . ' = ?'; + + foreach my $row (@$rows) { + + my @vals = (); + + foreach my $fieldname (@fieldnames) { + push @vals,$row->{$fieldname}; + } + + my @pk_vals; + + foreach my $fieldname (@pk_fieldnames) { + push @pk_vals,$row->{$fieldname}; + } + + if ($target_db->db_get_value('SELECT COUNT(*) FROM ' . $target_db->tableidentifier($targettablename) . ' WHERE ' . $selectpk_fieldnames,@pk_vals) == 0) { + $target_db->db_do('INSERT INTO ' . $db->target_tableidentifier($targettablename) . ' (' . $setfieldnames . ') VALUES (' . $valueplaceholders . ')',@vals); + rowtransferred($db,$tablename,$target_db,$targettablename,$i,$numofrows,$logger); + $rowstransferred += 1; + } else { + rowskipped($db,$tablename,$target_db,$targettablename,$i,$numofrows,$logger); + } + $i++; + } + } + rowtransferdone($db,$tablename,$target_db,$targettablename,$numofrows,$logger); + return $rowstransferred; + } + +} + +sub transfer_table { + + my ($get_db,$tablename,$get_target_db,$targettablename,$truncate_targettable,$create_indexes,$texttable_engine,$fixtable_statements,$selectcount,$select,@values) = @_; + + if (ref $get_db eq 'CODE' and ref $get_target_db eq 'CODE') { + + my $db = &$get_db($reader_connection_name,1); + my $target_db = &$get_target_db(); #$writer_connection_name); + + my $countstatement; + if (defined $selectcount) { + $countstatement = $selectcount; + } else { + $countstatement = 'SELECT COUNT(*) FROM ' . $db->tableidentifier($tablename); + } + + my $rowcount = $db->db_get_value($countstatement,@values); + + #my $targettablename = _gettargettablename($db,$tablename,$target_db); #$target_db->getsafetablename($db->tableidentifier($tablename)); + + if ($rowcount > 0) { + tabletransferstarted($db,$tablename,$target_db,$targettablename,$rowcount,$logger); + } else { + transferzerorowcount($db,$tablename,$target_db,$targettablename,$rowcount,$logger); + return; + } + + my $errorstate = 1; + + $create_indexes = ((defined $create_indexes) ? $create_indexes : $defer_indexes); + + if (create_targettable($db,$tablename,$target_db,$targettablename,$truncate_targettable,$create_indexes,$texttable_engine)) { + + my $connectidentifier = $db->connectidentifier(); + my $tid = threadid(); + my $expected_fieldnames = $table_expected_fieldnames->{$tid}->{$connectidentifier}->{$tablename}; + + my @fieldnames = @$expected_fieldnames; + + #my $setfieldnames = join(', ',map { local $_ = $_; $_ = $db->columnidentifier($_); $_; } @fieldnames); + my $valueplaceholders = substr(',?' x scalar @fieldnames,1); + + my $selectstatement; + if (length($select) > 0) { + $selectstatement = $select; + } else { + $selectstatement = 'SELECT ' . join(', ',map { local $_ = $_; $_ = $db->columnidentifier($_); $_; } @fieldnames) . ' FROM ' . $db->tableidentifier($tablename) + } + + my $insertstatement = 'INSERT INTO ' . $target_db->tableidentifier($targettablename) . ' (' . join(', ',map { local $_ = $_; $_ = $target_db->columnidentifier($_); $_; } @fieldnames) . ') VALUES (' . $valueplaceholders . ')'; + + my $blocksize; + + if ($enablemultithreading and $db->multithreading_supported() and $target_db->multithreading_supported() and $cpucount > 1) { # and $multithreaded) { # definitely no multithreading when CSVDB is involved + + $blocksize = _calc_blocksize($rowcount,scalar @fieldnames,1,$tabletransfer_threadqueuelength); + + my $reader; + my $writer; + + my %errorstates :shared = (); + #$errorstates{$tid} = $errorstate; + + #my $readererrorstate :shared = 1; + #my $writererrorstate :shared = 1; + + my $queue = Thread::Queue->new(); + + tablethreadingdebug('shutting down db connections ...',$logger); + + $db->db_disconnect(); + #undef $db; + $target_db->db_disconnect(); + #undef $target_db; + my $default_connection = &$get_db(undef,0); + my $default_connection_reconnect = $default_connection->is_connected(); + $default_connection->db_disconnect(); + + tablethreadingdebug('starting reader thread',$logger); + + $reader = threads->create(\&_reader, + { queue => $queue, + errorstates => \%errorstates, + #readererrorstate_ref => \$readererrorstate, + #writererrorstate_ref => \$writererrorstate, + threadqueuelength => $tabletransfer_threadqueuelength, + get_db => $get_db, + tablename => $tablename, + selectstatement => $selectstatement, + blocksize => $blocksize, + rowcount => $rowcount, + #logger => $logger, + values_ref => \@values, + }); + + tablethreadingdebug('starting writer thread',$logger); + + $writer = threads->create(\&_writer, + { queue => $queue, + errorstates => \%errorstates, + readertid => $reader->tid(), + #readererrorstate_ref => \$readererrorstate, + #writererrorstate_ref => \$writererrorstate, + get_target_db => $get_target_db, + targettablename => $targettablename, + insertstatement => $insertstatement, + blocksize => $blocksize, + rowcount => $rowcount, + #logger => $logger, + }); + + $reader->join(); + tablethreadingdebug('reader thread joined',$logger); + $writer->join(); + tablethreadingdebug('writer thread joined',$logger); + + #$errorstate = $readererrorstate | $writererrorstate; + $errorstate = _get_other_threads_state(\%errorstates,$tid); + + tablethreadingdebug('restoring db connections ...',$logger); + + #$db = &$get_db($reader_connection_name,1); + $target_db = &$get_target_db(undef,1); + if ($default_connection_reconnect) { + $default_connection = &$get_db(undef,1); + } + + } else { + + $blocksize = _calc_blocksize($rowcount,scalar @fieldnames,0,undef); + + #$db->db_disconnect(); + #undef $db; + #$db = &$get_db($reader_connection_name); + #$target_db->db_disconnect(); + #undef $target_db; + #$target_db = &$get_target_db($writer_connection_name); + + eval { + $db->db_get_begin($selectstatement,$tablename,@values); + + my $i = 0; + while (1) { + fetching_rows($db,$tablename,$i,$blocksize,$rowcount,$logger); + my $rowblock = $db->db_get_rowblock($blocksize); + my $realblocksize = scalar @$rowblock; + if ($realblocksize > 0) { + writing_rows($target_db,$targettablename,$i,$realblocksize,$rowcount,$logger); + $target_db->db_do_begin($insertstatement,$targettablename); + $target_db->db_do_rowblock($rowblock); + $target_db->db_finish(); + $i += $realblocksize; + + #foreach my $row (@$rowblock) { + # undef $row; + #} + #undef $rowblock; + + if ($realblocksize < $blocksize) { + last; + } + } else { + last; + } + } + $db->db_finish(); + + }; + + if ($@) { + $errorstate = 4; + } else { + $errorstate = 2; + } + + $db->db_disconnect(); + #undef $db; + #$target_db->db_disconnect(); + #undef $target_db; + + } + + #$db = &$get_db($controller_name,1); + #$target_db = &$get_target_db($controller_name,1); + + if ($errorstate == 2 and ref $fixtable_statements eq 'ARRAY' and (scalar @$fixtable_statements) > 0) { + eval { + foreach my $fixtable_statement (@$fixtable_statements) { + if (ref $fixtable_statement eq '') { + $target_db->db_do($fixtable_statement); + tablefixed($target_db,$targettablename,$fixtable_statement,$logger); + } else { + $fixtable_statement = &$fixtable_statement($target_db->tableidentifier($targettablename)); + $target_db->db_do($fixtable_statement); + tablefixed($target_db,$targettablename,$fixtable_statement,$logger); + } + + } + }; + if ($@) { + $errorstate = 4; + #} else { + # $errorstate = 2; + } + } + + if ($errorstate == 2 and $create_indexes) { + + eval { + $target_db->create_primarykey($targettablename, + $table_primarykeys->{$tid}->{$connectidentifier}->{$tablename}, + $table_expected_fieldnames->{$tid}->{$connectidentifier}->{$tablename}); + + $target_db->create_indexes($targettablename, + $table_target_indexes->{$tid}->{$connectidentifier}->{$tablename}, + $table_primarykeys->{$tid}->{$connectidentifier}->{$tablename}); + + + delete $table_primarykeys->{$tid}->{$target_db->connectidentifier()}->{$targettablename}; + checktableinfo($target_db,$targettablename,$table_expected_fieldnames->{$tid}->{$connectidentifier}->{$tablename},$table_target_indexes->{$tid}->{$connectidentifier}->{$tablename}); + + $target_db->vacuum($targettablename); + + }; + + if ($@) { + $errorstate = 4; + #} else { + # $errorstate = 2; + } + } + + } + + if ($errorstate == 2) { + tabletransferdone($db,$tablename,$target_db,$targettablename,$rowcount,$logger); + #$db->db_disconnect(); + #$target_db->db_disconnect(); + return 1; + } else { + tabletransferfailed($db,$tablename,$target_db,$targettablename,$rowcount,$logger); + #$db->db_disconnect(); + #$target_db->db_disconnect(); + } + + } + + return 0; + +} + +sub process_table { + + my ($get_db,$tablename,$process_code,$multithreading,$selectcount,$select,@values) = @_; + + if (ref $get_db eq 'CODE') { + + my $db = &$get_db($reader_connection_name,1); + + my $countstatement; + if (defined $selectcount) { + $countstatement = $selectcount; + } else { + $countstatement = 'SELECT COUNT(*) FROM ' . $db->tableidentifier($tablename); + } + + my $rowcount = $db->db_get_value($countstatement,@values); + + if ($rowcount > 0) { + tableprocessingstarted($db,$tablename,$rowcount,$logger); + } else { + processzerorowcount($db,$tablename,$rowcount,$logger); + return; + } + + my $errorstate = 1; + + my $connectidentifier = $db->connectidentifier(); + my $tid = threadid(); + my $expected_fieldnames = $table_expected_fieldnames->{$tid}->{$connectidentifier}->{$tablename}; + + my @fieldnames = @$expected_fieldnames; + + #my $setfieldnames = join(', ',@fieldnames); + #my $valueplaceholders = substr(',?' x scalar @fieldnames,1); + + my $selectstatement; + if (length($select) > 0) { + $selectstatement = $select; + } else { + $selectstatement = 'SELECT ' . join(', ',map { local $_ = $_; $_ = $db->columnidentifier($_); $_; } @fieldnames) . ' FROM ' . $db->tableidentifier($tablename); + } + + my $blocksize; + + if ($enablemultithreading and $multithreading and $db->multithreading_supported() and $cpucount > 1) { # and $multithreaded) { # definitely no multithreading when CSVDB is involved + + $blocksize = _calc_blocksize($rowcount,scalar @fieldnames,1,$tableprocessing_threadqueuelength); + + my $reader; + #my $processor; + my %processors = (); + + my %errorstates :shared = (); + #$errorstates{$tid} = $errorstate; + + #my $readererrorstate :shared = 1; + #my $processorerrorstate :shared = 1; + + my $queue = Thread::Queue->new(); + + tablethreadingdebug('shutting down db connections ...',$logger); + + $db->db_disconnect(); + #undef $db; + my $default_connection = &$get_db(undef,0); + my $default_connection_reconnect = $default_connection->is_connected(); + $default_connection->db_disconnect(); + + tablethreadingdebug('starting reader thread',$logger); + + $reader = threads->create(\&_reader, + { queue => $queue, + errorstates => \%errorstates, + #readererrorstate_ref => \$readererrorstate, + #writererrorstate_ref => \$processorerrorstate, + threadqueuelength => $tableprocessing_threadqueuelength, + get_db => $get_db, + tablename => $tablename, + selectstatement => $selectstatement, + blocksize => $blocksize, + rowcount => $rowcount, + #logger => $logger, + values_ref => \@values, + }); + + for (my $i = 0; $i < $tableprocessing_threads; $i++) { + tablethreadingdebug('starting processor thread ' . ($i + 1) . ' of ' . $tableprocessing_threads,$logger); + my $processor = threads->create(\&_process, + { queue => $queue, + errorstates => \%errorstates, + readertid => $reader->tid(), + #readererrorstate_ref => \$readererrorstate, + #processorerrorstate_ref => \$processorerrorstate, + process_code => $process_code, + blocksize => $blocksize, + rowcount => $rowcount, + #logger => $logger, + }); + if (not defined $processor) { + tablethreadingdebug('processor thread ' . ($i + 1) . ' of ' . $tableprocessing_threads . ' NOT started',$logger); + } + $processors{$processor->tid()} = $processor; + #push (@processors,$processor); + } + + #$reader->join(); + #tablethreadingdebug('reader thread joined',$logger); + #for (my $i = 0; $i < $tableprocessing_threads; $i++) { + # my $processor = $processors[$i]; + # if (defined $processor) { + # $processor->join(); + # tablethreadingdebug('processor thread ' . ($i + 1) . ' of ' . $tableprocessing_threads . ' joinded',$logger); + # } else { + # tablethreadingdebug('processor thread ' . ($i + 1) . ' of ' . $tableprocessing_threads . ' NOT joinded',$logger); + # } + #} + + $reader->join(); + tablethreadingdebug('reader thread joined',$logger); + #print 'threads running: ' . (scalar threads->list(threads::running)); + #while ((scalar threads->list(threads::running)) > 1 or (scalar threads->list(threads::joinable)) > 0) { + while ((scalar keys %processors) > 0) { + #for (my $i = 0; $i < $tableprocessing_threads; $i++) { + foreach my $processor (values %processors) { + #my $processor = $processors[$i]; + if (defined $processor and $processor->is_joinable()) { + $processor->join(); + delete $processors{$processor->tid()}; + #tablethreadingdebug('processor thread ' . ($i + 1) . ' of ' . $tableprocessing_threads . ' joinded',$logger); + tablethreadingdebug('processor thread tid ' . $processor->tid() . ' joined',$logger); + } + #} else { + # tablethreadingdebug('processor thread ' . ($i + 1) . ' of ' . $tableprocessing_threads . ' NOT joinded',$logger); + #} + } + sleep($thread_sleep_secs); + } + + #$errorstate = $readererrorstate | $processorerrorstate; + $errorstate = (_get_other_threads_state(\%errorstates,$tid) & ~1); + + tablethreadingdebug('restoring db connections ...',$logger); + + #$db = &$get_db($reader_connection_name,1); + if ($default_connection_reconnect) { + $default_connection = &$get_db(undef,1); + } + + } else { + + $blocksize = _calc_blocksize($rowcount,scalar @fieldnames,0,undef); + #$db->db_disconnect(); + #undef $db; + #$db = &$get_db($reader_connection_name); + + my $rowblock_result = 1; + eval { + $db->db_get_begin($selectstatement,$tablename,@values); + + my $i = 0; + while (1) { + fetching_rows($db,$tablename,$i,$blocksize,$rowcount,$logger); + my $rowblock = $db->db_get_rowblock($blocksize); + my $realblocksize = scalar @$rowblock; + if ($realblocksize > 0) { + processing_rows($tid,$i,$realblocksize,$rowcount,$logger); + + $rowblock_result = &$process_code($rowblock,$i); + + #$target_db->db_do_begin($insertstatement,$targettablename); + #$target_db->db_do_rowblock($rowblock); + #$target_db->db_finish(); + $i += $realblocksize; + + if ($realblocksize < $blocksize || not $rowblock_result) { + last; + } + } else { + last; + } + } + $db->db_finish(); + + }; + + if ($@) { + $errorstate = 4; + } else { + $errorstate = (not $rowblock_result) ? 4 : 2; + } + + $db->db_disconnect(); + #undef $db; + + } + + #$db = &$get_db($controller_name,1); + + if ($errorstate == 2) { + tableprocessingdone($db,$tablename,$rowcount,$logger); + #$db->db_disconnect(); + return 1; + } else { + tableprocessingfailed($db,$tablename,$rowcount,$logger); + #$db->db_disconnect(); + } + + } + + return 0; + +} + +sub _calc_blocksize { + + my ($rowcount,$columncount,$multithreaded,$threadqueuelength) = @_; + + if ($rowcount > $minblocksize) { + + my $exp = int ( log ($rowcount) / log(10.0) ); + my $blocksize = int ( 10 ** $exp ); + my $cellcount_in_memory = $columncount * $blocksize; + if ($multithreaded) { + $cellcount_in_memory *= $threadqueuelength; + } + + while ( $cellcount_in_memory > $cells_transfer_memory_limit or + $rowcount / $blocksize < $minnumberofchunks) { + $exp -= 1.0; + $blocksize = int ( 10 ** $exp ); + $cellcount_in_memory = $columncount * $blocksize; + if ($multithreaded) { + $cellcount_in_memory *= $threadqueuelength; + } + } + + if ($blocksize < $minblocksize) { + return $minblocksize; + } elsif ($blocksize > $maxblocksize) { + return $maxblocksize; + } else { + return $blocksize; + } + + } else { + + return $minblocksize; + + } + +} + +sub _get_other_threads_state { + my ($errorstates,$tid) = @_; + my $result = 0; + if (not defined $tid) { + $tid = threadid(); + } + if (defined $errorstates and ref $errorstates eq 'HASH') { + lock $errorstates; + foreach my $threadid (keys %$errorstates) { + if ($threadid != $tid) { + $result |= $errorstates->{$threadid}; + } + } + } + return $result; +} + +sub _get_stop_consumer_thread { + my ($context,$tid) = @_; + my $result = 1; + my $other_threads_state; + my $reader_state; + my $queuesize; + { + my $errorstates = $context->{errorstates}; + lock $errorstates; + $other_threads_state = _get_other_threads_state($errorstates,$tid); + $reader_state = $errorstates->{$context->{readertid}}; + } + $queuesize = $context->{queue}->pending(); + if (($other_threads_state & 4) == 0 and ($queuesize > 0 or $reader_state == 1)) { + $result = 0; + #keep the consumer thread running if there is no defunct thread and queue is not empty or reader is still running + } + + if ($result) { + tablethreadingdebug('[' . $tid . '] consumer thread is shutting down (' . + (($other_threads_state & 4) == 0 ? 'no defunct thread(s)' : 'defunct thread(s)') . ', ' . + ($queuesize > 0 ? 'blocks pending' : 'no blocks pending') . ', ' . + ($reader_state == 1 ? 'reader thread running' : 'reader thread not running') . ') ...' + ,$logger); + } + + return $result; + +} + +sub _reader { + + #my ($queue,$readererrorstate_ref,$writererrorstate_ref,$get_db,$tablename,$selectstatement,$blocksize,$rowcount,$logger,@values) = @_; + my $context = shift; + + my $reader_db; + my $tid = threadid(); + { + lock $context->{errorstates}; + $context->{errorstates}->{$tid} = 1; + } + + tablethreadingdebug('[' . $tid . '] reader thread tid ' . $tid . ' started',$logger); + + my $blockcount = 0; + eval { + $reader_db = &{$context->{get_db}}(); #$reader_connection_name); + $reader_db->db_get_begin($context->{selectstatement},$context->{tablename},@{$context->{values_ref}}); + my $i = 0; + tablethreadingdebug('[' . $tid . '] reader thread waiting for consumer threads',$logger); + while ((_get_other_threads_state($context->{errorstates},$tid) & 1) == 0) { #wait on cosumers to come up + #yield(); + sleep($thread_sleep_secs); + } + my $state = 1; #start at first + while (($state & 1) == 1 and ($state & 4) == 0) { #as long there is one running consumer and no defunct consumer + fetching_rows($reader_db,$context->{tablename},$i,$context->{blocksize},$context->{rowcount},$logger); + my $rowblock = $reader_db->db_get_rowblock($context->{blocksize}); + my $realblocksize = scalar @$rowblock; + my $packet = {rows => $rowblock, + size => $realblocksize, + #block => $i, + row_offset => $i}; + my %packet :shared = (); + $packet{rows} = $rowblock; + $packet{size} = $realblocksize; + $packet{row_offset} = $i; + if ($realblocksize > 0) { + $context->{queue}->enqueue(\%packet); #$packet); + $blockcount++; + #wait if thequeue is full and there there is one running consumer + while (((($state = _get_other_threads_state($context->{errorstates},$tid)) & 1) == 1) and $context->{queue}->pending() >= $context->{threadqueuelength}) { + #yield(); + sleep($thread_sleep_secs); + } + $i += $realblocksize; + if ($realblocksize < $context->{blocksize}) { + tablethreadingdebug('[' . $tid . '] reader thread is shutting down (end of data) ...',$logger); + last; + } + } else { + $context->{queue}->enqueue(\%packet); #$packet); + tablethreadingdebug('[' . $tid . '] reader thread is shutting down (end of data - empty block) ...',$logger); + last; + } + } + if (not (($state & 1) == 1 and ($state & 4) == 0)) { + tablethreadingdebug('[' . $tid . '] reader thread is shutting down (' . + (($state & 1) == 1 ? 'still running consumer threads' : 'no running consumer threads') . ', ' . + (($state & 4) == 0 ? 'no defunct thread(s)' : 'defunct thread(s)') . ') ...' + ,$logger); + } + $reader_db->db_finish(); + }; + # stop the consumer: + # $context->{queue}->enqueue(undef); + if (defined $reader_db) { + # if thread cleanup has a problem... + $reader_db->db_disconnect(); + } + tablethreadingdebug($@ ? '[' . $tid . '] reader thread error: ' . $@ : '[' . $tid . '] reader thread finished (' . $blockcount . ' blocks)',$logger); + lock $context->{errorstates}; + if ($@) { + $context->{errorstates}->{$tid} = 4; + } else { + $context->{errorstates}->{$tid} = 2; + } + return $context->{errorstates}->{$tid}; +} + +sub _writer { + + my $context = shift; + + #get_target_db + my $writer_db; + my $tid = threadid(); + { + lock $context->{errorstates}; + $context->{errorstates}->{$tid} = 1; + } + tablethreadingdebug('[' . $tid . '] writer thread tid ' . $tid . ' started',$logger); + + my $blockcount = 0; + eval { + $writer_db = &{$context->{get_target_db}}(); #$writer_connection_name); + while (not _get_stop_consumer_thread($context,$tid)) { + my $packet = $context->{queue}->dequeue_nb(); + if (defined $packet) { + if ($packet->{size} > 0) { + writing_rows($writer_db,$context->{targettablename},$packet->{row_offset},$packet->{size},$context->{rowcount},$logger); + + $writer_db->db_do_begin($context->{insertstatement},$context->{targettablename}); + $writer_db->db_do_rowblock($packet->{rows}); + $writer_db->db_finish(); + $blockcount++; + + } else { #empty packet received + tablethreadingdebug('[' . $tid . '] shutting down writer thread (end of data - empty block) ...',$logger); + last; + } + } else { + #yield(); + sleep($thread_sleep_secs); #2015-01 + } + } + }; + if (defined $writer_db) { + # if thread cleanup has a problem... + $writer_db->db_disconnect(); + } + tablethreadingdebug($@ ? '[' . $tid . '] writer thread error: ' . $@ : '[' . $tid . '] writer thread finished (' . $blockcount . ' blocks)',$logger); + lock $context->{errorstates}; + if ($@) { + $context->{errorstates}->{$tid} = 4; + } else { + $context->{errorstates}->{$tid} = 2; + } + return $context->{errorstates}->{$tid}; +} + +sub _process { + + my $context = shift; + + #my $writer_db; + my $rowblock_result = 1; + my $tid = threadid(); + { + lock $context->{errorstates}; + $context->{errorstates}->{$tid} = 1; + } + + tablethreadingdebug('[' . $tid . '] processor thread tid ' . $tid . ' started',$logger); + + my $blockcount = 0; + eval { + #$writer_db = &{$context->{get_target_db}}($writer_connection_name); + while (not _get_stop_consumer_thread($context,$tid)) { + my $packet = $context->{queue}->dequeue_nb(); + if (defined $packet) { + if ($packet->{size} > 0) { + + #writing_rows($writer_db,$context->{targettablename},$i,$realblocksize,$context->{rowcount},$logger); + + #$writer_db->db_do_begin($context->{insertstatement},$context->{targettablename}); + #$writer_db->db_do_rowblock($rowblock); + #$writer_db->db_finish(); + + #$i += $realblocksize; + + processing_rows($tid,$packet->{row_offset},$packet->{size},$context->{rowcount},$logger); + + $rowblock_result = &{$context->{process_code}}($packet->{rows},$packet->{row_offset}); + + $blockcount++; + + #$i += $realblocksize; + + if (not $rowblock_result) { + tablethreadingdebug('[' . $tid . '] shutting down processor thread (processing block NOK) ...',$logger); + last; + } + + } else { + tablethreadingdebug('[' . $tid . '] shutting down processor thread (end of data - empty block) ...',$logger); + last; + } + } else { + #yield(); + sleep($thread_sleep_secs); #2015-01 + } + } + }; + #if (defined $writer_db) { + # $writer_db->db_disconnect(); + #} + tablethreadingdebug($@ ? '[' . $tid . '] processor thread error: ' . $@ : '[' . $tid . '] processor thread finished (' . $blockcount . ' blocks)',$logger); + lock $context->{errorstates}; + if ($@) { + $context->{errorstates}->{$tid} = 4; + } else { + $context->{errorstates}->{$tid} = (not $rowblock_result) ? 4 : 2; + } + return $context->{errorstates}->{$tid}; +} + +sub copy_row { + my ($record,$row,$expected_fieldnames) = @_; + if (defined $record and defined $row) { + my $i; + if (ref $row eq 'ARRAY') { + $i = 0; + } elsif (ref $row eq 'HASH') { + $i = -1; + } elsif (ref $row eq ref $record) { + $i = -2; + } else { + $i = -3; + } + foreach my $fieldname (@$expected_fieldnames) { + if ($i >= 0) { + $record->{$fieldname} = $row->[$i]; + $i++; + } elsif ($i == -1 or $i == -2) { + if (exists $row->{$fieldname}) { + $record->{$fieldname} = $row->{$fieldname}; + } elsif (exists $row->{uc($fieldname)}) { + $record->{$fieldname} = $row->{uc($fieldname)}; + } else { + $record->{$fieldname} = undef; + } + } else { + last; + } + } + } + return $record; +} + +1; \ No newline at end of file diff --git a/Table.pm b/Table.pm new file mode 100644 index 0000000..b96d70e --- /dev/null +++ b/Table.pm @@ -0,0 +1,236 @@ +# table module: a 2D array object = array of arrays = fetchall_arrayref result + +package Table; +use strict; + +## no critic + +use Digest::MD5; + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(get_rowhash); + +sub new { + + my $class = shift; + my $self = bless {}, $class; + $self->_set_data($_[0],$_[1]); + return $self; + +} + +sub _set_data { + + my $self = shift; + my ($data,$dupecheck) = shift; + $self->clear(); + if (defined $data and ref $data eq 'ARRAY') { + if ($dupecheck) { + foreach my $row (@$data) { + $self->addrow_ref_nodupe($row); + } + } else { + foreach my $row (@$data) { + $self->addrow_ref($row); + } + } + } + +} + +sub clear { + + my $self = shift; + $self->{data} = []; + $self->{rowhashes} = {}; + +} + +sub data_ref { + + my $self = shift; + if ($_[0]) { + #if argument, set the value + $self->_set_data($_[0],$_[1]); + } else { + return $self->{data}; + } + +} + +sub addrow { + + my $self = shift; + #my @row = @_; + return $self->addrow_ref(\@_); + +} + +sub addrow_nodupe { + + my $self = shift; + #my @row = @_; + return $self->addrow_ref_nodupe(\@_); + +} + +sub addrow_ref { + + my $self = shift; + my $row_ref = shift; + my $rowhash = get_rowhash($row_ref); + my $itemcount = 0; + if (defined $rowhash) { + if (not exists $self->{rowhashes}->{$rowhash}) { + $self->{rowhashes}->{$rowhash} = 0; + } + $itemcount = $self->{rowhashes}->{$rowhash} + 1; + $self->{rowhashes}->{$rowhash} = $itemcount; + push @{$self->{data}},$row_ref; + } + return $itemcount; + +} + +sub addrow_ref_nodupe { + + my $self = shift; + my $row_ref = shift; + my $rowhash = get_rowhash($row_ref); + my $itemcount = 0; + if (defined $rowhash) { + if (not exists $self->{rowhashes}->{$rowhash}) { + $self->{rowhashes}->{$rowhash} = 1; + $itemcount = 1; + push @{$self->{data}},$row_ref; + } else { + $itemcount = $self->{rowhashes}->{$rowhash}; + } + } + return $itemcount; + +} + +sub rowexists { + + my $self = shift; + #my @row = @_; + return $self->rowexists_ref(\@_); + +} + +sub rowexists_ref { + + my $self = shift; + my $row_ref = shift; + my $rowhash = get_rowhash($row_ref); + my $itemcount = 0; + if (defined $rowhash) { + if (exists $self->{rowhashes}->{$rowhash}) { + return 1; + } + } + return 0; + +} + +sub get_rowhash { + + my $row_ref = shift; + if (defined $row_ref and ref $row_ref eq 'ARRAY') { + my $md5 = Digest::MD5->new; + foreach my $element (@$row_ref) { + $md5->add($element); + } + return $md5->hexdigest; + } else { + return undef; + } + +} + +sub rowcount { + + my $self = shift; + #my @rows = @{$self->{data}}; + return scalar @{$self->{data}}; # + 1; + +} + +sub element { + + my $self = shift; + return $self->{data}->[$_[0]]->[$_[1]]; + +} + +sub getrow { + + my $self = shift; + my $row_ref = $self->{data}->[$_[0]]; + if ($row_ref) { + return @$row_ref; + } else { + return (); + } + +} + +sub getrow_ref { + + my $self = shift; + my $row_ref = $self->{data}->[$_[0]]; + if ($row_ref) { + return $row_ref; + } else { + return []; + } + +} + +sub getcol { + + my $self = shift; + my @col = (); + for (my $i = 0; $i < $self->rowcount(); $i++) { + push(@col,$self->{data}->[$i]->[$_[0]]); + } + return @col; + +} + +sub getcol_ref { + + my $self = shift; + my @col = $self->getcol($_[0]); + return \@col; + +} + +sub sortrows { + + my $self = shift; + my $sortfunction = shift; + my @new_rows = sort $sortfunction @{$self->{data}}; + #$self->_set_data(\@new_rows); + # since sorting can not affect uniqueness of rows and rowhashes, we just set: + $self->{data} = \@new_rows; + +} + +sub tostring { + + my $self = shift; + my @rows = @{$self->{data}}; + my $result = ''; + my $row_ref; + for (my $i = 0; $i < scalar @rows; $i++) { + $row_ref = $rows[$i]; + $result .= join($_[0],@$row_ref) . $_[1]; + } + return substr($result,0,length($result) - length($_[1])); + +} + +1; \ No newline at end of file diff --git a/Utils.pm b/Utils.pm new file mode 100644 index 0000000..cd24564 --- /dev/null +++ b/Utils.pm @@ -0,0 +1,787 @@ +package Utils; +use strict; + +## no critic + +use threads; + +#use POSIX qw(strtod); +use POSIX qw(strtod locale_h); +setlocale(LC_NUMERIC, 'C'); +#use Logging qw(fileerror); + +use Data::UUID; + +use Net::Address::IP::Local; +#use FindBin qw($Bin); +#use File::Spec::Functions qw(splitdir catdir); +use Net::Domain qw(hostname hostfqdn hostdomain); + +use Cwd 'abs_path'; +#use File::Basename qw(fileparse); + +use Date::Manip qw(Date_Init ParseDate UnixDate); +#Date_Init('Language=English','DateFormat=non-US'); +Date_Init('DateFormat=US'); +#use Net::Address::IP::Local; + +use Date::Calc qw(Normalize_DHMS Add_Delta_DHMS); + +use Text::Wrap; +#use FindBin qw($Bin); +use Digest::MD5; #qw(md5 md5_hex md5_base64); +use File::Temp qw(tempfile tempdir); +use File::Path qw(remove_tree); + +#use Sys::Info; +#use Sys::Info::Constants qw( :device_cpu ); + +# after all, the only reliable way to get the true vCPU count: +use Sys::CpuAffinity; # qw(getNumCpus); not exported? + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw( + float_equal + round + stringtobool + booltostring + check_bool + tempfilename + timestampdigits + datestampdigits + parse_datetime + parse_date + timestampfromdigits + datestampfromdigits + timestamptodigits + datestamptodigits + timestamptostring + timestampaddsecs + file_md5 + cat_file + wrap_text + create_guid + urlencode + urldecode + timestamp + datestamp + timestamp_fromepochsecs + get_year + get_year_month + get_year_month_day + secs_to_years + zerofill + trim + chopstring + get_ipaddress + get_hostfqdn + getscriptpath + + kbytes2gigs + cleanupdir + threadid + format_number + + dec2bin + bin2dec + + check_number + min_timestamp + max_timestamp + add_months + makedir + changemod + + get_cpucount + + $chmod_umask + +); + +our $chmod_umask = '0777'; + +my $default_epsilon = 1e-3; #float comparison tolerance + +sub float_equal { + + my ($a, $b, $epsilon) = @_; + if ((!defined $epsilon) || ($epsilon <= 0.0)) { + $epsilon = $default_epsilon; + } + return (abs($a - $b) < $epsilon); + +} + +sub round { + + my ($number) = shift; + return int($number + .5 * ($number <=> 0)); + +} + +sub stringtobool { + + my $inputstring = shift; + if (lc($inputstring) eq 'y' or lc($inputstring) eq 'true' or $inputstring >= 1) { + return 1; + } else { + return 0; + } + +} + +sub booltostring { + + if (shift) { + return 'true'; + } else { + return 'false'; + } + +} + +sub check_bool { + + my $inputstring = shift; + if (lc($inputstring) eq 'y' or lc($inputstring) eq 'true' or $inputstring >= 1) { + return 1; + } elsif (lc($inputstring) eq 'n' or lc($inputstring) eq 'false' or $inputstring == 0) { + return 1; + } else { + return 0; + } + +} + +sub timestampdigits { + + my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); + return sprintf "%4d%02d%02d%02d%02d%02d",$year+1900,$mon+1,$mday,$hour,$min,$sec; + +} + +sub datestampdigits { + + my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); + return sprintf "%4d%02d%02d",$year+1900,$mon+1,$mday; + +} + +sub parse_datetime { + + my ($datetimestring,$non_us) = @_; + if ($non_us) { + Date_Init('DateFormat=non-US'); + } else { + Date_Init('DateFormat=US'); + } + my $datetime = ParseDate($datetimestring); + if (!$datetime) { + return undef; + } else { + my ($year,$mon,$mday,$hour,$min,$sec) = UnixDate($datetime,"%Y","%m","%d","%H","%M","%S"); + return sprintf "%4d-%02d-%02d %02d:%02d:%02d",$year,$mon,$mday,$hour,$min,$sec; + } + +} + +sub parse_date { + + my ($datetimestring,$non_us) = @_; + if ($non_us) { + Date_Init('DateFormat=non-US'); + } else { + Date_Init('DateFormat=US'); + } + my $datetime = ParseDate($datetimestring); + if (!$datetime) { + return undef; + } else { + my ($year,$mon,$mday) = UnixDate($datetime,"%Y","%m","%d"); + return sprintf "%4d-%02d-%02d",$year,$mon,$mday; + } + +} + +sub timestampfromdigits { + + my ($timestampdigits) = @_; + if ($timestampdigits =~ /^[0-9]{14}$/g) { + return substr($timestampdigits,0,4) . '-' . + substr($timestampdigits,4,2) . '-' . + substr($timestampdigits,6,2) . ' ' . + substr($timestampdigits,8,2) . ':' . + substr($timestampdigits,10,2) . ':' . + substr($timestampdigits,12,2); + } else { + return $timestampdigits; + } + +} + +sub datestampfromdigits { + + my ($datestampdigits) = @_; + if ($datestampdigits =~ /^[0-9]{8}$/g) { + return substr($datestampdigits,0,4) . '-' . + substr($datestampdigits,4,2) . '-' . + substr($datestampdigits,6,2); + } else { + return $datestampdigits; + } + +} + +sub timestamptodigits { + + my ($datetimestring,$non_us) = @_; + if ($non_us) { + Date_Init('DateFormat=non-US'); + } else { + Date_Init('DateFormat=US'); + } + my $datetime = ParseDate($datetimestring); + if (!$datetime) { + return '0'; + } else { + my ($year,$mon,$mday,$hour,$min,$sec) = UnixDate($datetime,"%Y","%m","%d","%H","%M","%S"); + return sprintf "%4d%02d%02d%02d%02d%02d",$year,$mon,$mday,$hour,$min,$sec; + } + +} + +sub datestamptodigits { + + my ($datestring,$non_us) = @_; + if ($non_us) { + Date_Init('DateFormat=non-US'); + } else { + Date_Init('DateFormat=US'); + } + my $datetime = ParseDate($datestring); + if (!$datetime) { + return '0'; + } else { + my ($year,$mon,$mday) = UnixDate($datetime,"%Y","%m","%d"); + return sprintf "%4d%02d%02d",$year,$mon,$mday; + } + +} + +sub timestamptostring { + + Date_Init('DateFormat=US'); + return UnixDate(@_); + +} + +sub timestampaddsecs { + + my ($datetimestring,$timespan,$non_us) = @_; + + if ($non_us) { + Date_Init('DateFormat=non-US'); + } else { + Date_Init('DateFormat=US'); + } + + my $datetime = ParseDate($datetimestring); + + if (!$datetime) { + + return $datetimestring; + + } else { + + my ($fromyear,$frommonth,$fromday,$fromhour,$fromminute,$fromsecond) = UnixDate($datetime,"%Y","%m","%d","%H","%M","%S"); + + my ($Dd,$Dh,$Dm,$Ds) = Date::Calc::Normalize_DHMS(0,0,0,$timespan); + my ($toyear,$tomonth,$to_day,$tohour,$tominute,$tosecond) = Date::Calc::Add_Delta_DHMS($fromyear,$frommonth,$fromday,$fromhour,$fromminute,$fromsecond, + $Dd,$Dh,$Dm,$Ds); + + return sprintf "%4d-%02d-%02d %02d:%02d:%02d",$toyear,$tomonth,$to_day,$tohour,$tominute,$tosecond; + + } + +} + +sub tempfilename { + + my ($template,$path,$suffix) = @_; + my ($tmpfh,$tmpfilename) = tempfile($template,DIR => $path,SUFFIX => $suffix); + close $tmpfh; + return $tmpfilename; + +} + +sub file_md5 { + + my ($filepath,$fileerrorcode,$logger) = @_; + #use Logging qw(fileerror); + local *MD5FILE; + + if (not open (MD5FILE, '<' . $filepath)) { + if (defined $fileerrorcode and ref $fileerrorcode eq 'CODE') { + &$fileerrorcode('md5sum - cannot open file ' . $filepath . ': ' . $!,$logger); + } + return ''; + } + binmode MD5FILE; + my $md5digest = Digest::MD5->new->addfile(*MD5FILE)->hexdigest; + close MD5FILE; + return $md5digest; + +} + +sub cat_file { + + my ($filepath,$fileerrorcode,$logger) = @_; + + if (not open (CATFILE, '<' . $filepath)) { + if (defined $fileerrorcode and ref $fileerrorcode eq 'CODE') { + &$fileerrorcode('cat - cannot open file ' . $filepath . ': ' . $!,$logger); + } + return ''; + } + my @linebuffer = ; + close CATFILE; + return join("\n",@linebuffer); + +} + +sub wrap_text { + + my ($inputstring, $columns) = @_; + $Text::Wrap::columns = $columns; + return Text::Wrap::wrap("","",$inputstring); + +} + +sub create_guid { + + my $ug = new Data::UUID; + my $uuid = $ug->create(); + return $ug->to_string( $uuid ); + +} + +sub urlencode { + my ($urltoencode) = @_; + $urltoencode =~ s/([^a-zA-Z0-9\/_\-.])/uc sprintf("%%%02x",ord($1))/eg; + return $urltoencode; +} + +sub urldecode { + my ($urltodecode) = @_; + $urltodecode =~ s/%([\dA-Fa-f][\dA-Fa-f])/pack ("C", hex ($1))/eg; + return $urltodecode; +} + +sub timestamp { + + my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); + return sprintf "%4d-%02d-%02d %02d:%02d:%02d",$year+1900,$mon+1,$mday,$hour,$min,$sec; + +} + +sub timestamp_fromepochsecs { + + my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(shift); + return sprintf "%4d-%02d-%02d %02d:%02d:%02d",$year+1900,$mon+1,$mday,$hour,$min,$sec; + +} + +sub datestamp { + + my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); + return sprintf "%4d-%02d-%02d",$year+1900,$mon+1,$mday; + +} + +sub get_year { + + my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); + return (sprintf "%4d",$year+1900); + +} + +sub get_year_month { + + my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); + return ((sprintf "%4d",$year+1900),(sprintf "%02d",$mon+1)); + +} + +sub get_year_month_day { + + my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); + return ((sprintf "%4d",$year+1900),(sprintf "%02d",$mon+1),(sprintf "%02d",$mday)); + +} + +sub zerofill { + my ($integer,$digits) = @_; + my $numberofzeroes = $digits - length($integer); + my $resultstring = $integer; + if ($digits > 0) { + for (my $i = 0; $i < $numberofzeroes; $i += 1) { + $resultstring = "0" . $resultstring; + } + } + return $resultstring; +} + +sub trim { + my ($inputstring) = @_; + + $inputstring =~ s/[\n\r\t]/ /g; + $inputstring =~ s/^ +//; + $inputstring =~ s/ +$//; + + return $inputstring; +} + +sub chopstring { + + my ($inputstring,$trimlength,$ending) = @_; + + my $result = $inputstring; + + if (defined $inputstring) { + + $result =~ s/[\n\r\t]/ /g; + + if (not defined $trimlength) { + $trimlength = 30; + } + if (not defined $ending) { + $ending = '...' + } + + if (length($result) > $trimlength) { + return substr($result,0,$trimlength-length($ending)) . $ending; + } + } + + return $result; + +} + +sub get_ipaddress { + + # Get the local system's IP address that is "en route" to "the internet": + return Net::Address::IP::Local->public; + +} + +sub get_hostfqdn { + + return hostfqdn(); + +} + +sub getscriptpath { + + return abs_path($0); + +} + +sub kbytes2gigs { + my ($TotalkBytes,$kbytebase,$round) = @_; + + if ($kbytebase <= 0) { + $kbytebase = 1024; + } + + my $TotalkByteskBytes = $TotalkBytes; + my $TotalkBytesMBytes = $TotalkBytes; + my $TotalkBytesGBytes = $TotalkBytes; + + my $rounded = 0; + $TotalkByteskBytes = $TotalkBytes; + $TotalkBytesMBytes = 0; + $TotalkBytesGBytes = 0; + + if ($TotalkByteskBytes >= $kbytebase) { + $TotalkBytesMBytes = int($TotalkByteskBytes / $kbytebase); + $rounded = int(($TotalkByteskBytes * 100) / $kbytebase) / 100; + if ($round) { # == 1) { + $rounded = int($rounded); + } + $rounded .= " MBytes"; + $TotalkByteskBytes = $TotalkBytes - $TotalkBytesGBytes * $kbytebase * $kbytebase - $TotalkBytesMBytes * $kbytebase; + if ($TotalkBytesMBytes >= $kbytebase) { + $TotalkBytesGBytes = int($TotalkBytesMBytes / $kbytebase); + $rounded = int(($TotalkBytesMBytes * 100) / $kbytebase) / 100; + if ($round) { # == 1) { + $rounded = int($rounded); + } + $rounded .= " GBytes"; + $TotalkBytesMBytes = int(($TotalkBytes - $TotalkBytesGBytes * $kbytebase * $kbytebase) / $kbytebase); + $TotalkByteskBytes = $TotalkBytes - $TotalkBytesGBytes * $kbytebase * $kbytebase - $TotalkBytesMBytes * $kbytebase; + } + } + + if ($TotalkBytesGBytes == 0 && $TotalkBytesMBytes == 0) { + $TotalkBytes .= " kBytes"; + } elsif ($TotalkBytesGBytes == 0) { + $TotalkBytes = $rounded; # . " (" . $TotalkBytesMBytes . " MBytes " . $TotalkByteskBytes . " kBytes)"; + if ($round) { # == 1) { + $TotalkBytes = $rounded; + } + } else { + $TotalkBytes = $rounded; # . " (" . $TotalkBytesGBytes . " GBytes " . $TotalkBytesMBytes . " MBytes " . $TotalkByteskBytes . " kBytes)"; + if ($round) { # == 1) { + $TotalkBytes = $rounded; + } + } + return $TotalkBytes; +} + +sub cleanupdir { + + my ($dirpath,$restoredir,$cleanupinfocode,$filewarncode,$logger) = @_; + if (-e $dirpath) { + if (remove_tree($dirpath) == 0) { + if (defined $filewarncode and ref $filewarncode eq 'CODE') { + &$filewarncode('cannot remove ' . $dirpath . ': ' . $!,$logger); + } + } else { + if (defined $cleanupinfocode and ref $cleanupinfocode eq 'CODE') { + &$cleanupinfocode($dirpath . ' removed',$logger); + } + } + if ($restoredir) { + makedir($dirpath); + } + } + +} + +sub makedir { + my ($dirpath) = @_; + mkdir $dirpath; + chmod oct($chmod_umask),$dirpath; +} + +sub changemod { + my ($filepath) = @_; + chmod oct($chmod_umask),$filepath; +} + +sub threadid { + + return threads->tid(); + #return threads->_handle(); + +} + +sub format_number { + my ($value,$decimals) = @_; + my $output = $value; + #if (index($output,',') > -1) { + # $output =~ s/,/\./g; + #} + if (defined $decimals and $decimals >= 0) { + $output = round(($output * (10 ** ($decimals + 1))) / 10) / (10 ** $decimals); + $output = sprintf("%." . $decimals . "f",$output); + if (index($output,',') > -1) { + $output =~ s/,/\./g; + } + } else { + $output = sprintf("%f",$output); + #if (index($output,',') > -1) { + # $output =~ s/,/\./g; + #} + if (index($output,'.') > -1) { + $output =~ s/0+$//g; + $output =~ s/\.$//g; + } + } + return $output; +} + +sub dec2bin { + my $str = unpack("B32", pack("N", shift)); + $str =~ s/^0+(?=\d)//; # leading zeros otherwise + return $str; +} + +sub bin2dec { + return unpack("N", pack("B32", substr("0" x 32 . shift, -32))); +} + +sub getnum { + + my $str = shift; + $str =~ s/^\s+//; + $str =~ s/\s+$//; + $! = 0; + my($num, $unparsed) = strtod($str); + if (($str eq '') || ($unparsed != 0) || $!) { + return; + } else { + return $num; + } +} + +sub check_number { + + my $potential_number = shift; + if (defined getnum($potential_number)) { + return 1; + } else { + return 0; + } + +} + +sub min_timestamp { + + my (@timestamps) = @_; + + my $min_ts = $timestamps[0]; + foreach my $ts (@timestamps) { + if (($ts cmp $min_ts) < 0) { + $min_ts = $ts; + } + } + + return $min_ts; + +} + +sub max_timestamp { + + my (@timestamps) = @_; + + my $min_ts = $timestamps[0]; + foreach my $ts (@timestamps) { + if (($ts cmp $min_ts) > 0) { + $min_ts = $ts; + } + } + + return $min_ts; + +} + +sub add_months { + + my ($month, $year, $ads) = @_; + + if ($month > 0 and $month <= 12) { + + my $sign = ($ads > 0) ? 1 : -1; + my $rmonths = $month + $sign * (abs($ads) % 12); + my $ryears = $year + int( $ads / 12 ); + + if ($rmonths < 1) { + $rmonths += 12; + $ryears -= 1; + } elsif ($rmonths > 12) { + $rmonths -= 12; + $ryears += 1; + } + + return ($rmonths,$ryears); + + } else { + + return (undef,undef); + + } + +} + +sub secs_to_years { + + my $time_in_secs = shift; + + my $negative = 0; + if ($time_in_secs < 0) { + $time_in_secs *= -1; + $negative = 1; + } + + my $years = 0; + my $months = 0; + my $days = 0; + my $hours = 0; + my $mins = 0; + my $secs = $time_in_secs; + + if ($secs >= 60) { + $mins = int($secs / 60); + $secs = ($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30-$days*60*60*24-$hours*60*60-$mins*60); + if ($mins >= 60) { + $hours = int($mins / 60); + $mins = int(($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30-$days*60*60*24-$hours*60*60) / (60)); + $secs = ($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30-$days*60*60*24-$hours*60*60-$mins*60); + if ($hours >= 24) { + $days = int($hours / 24); + $hours = int(($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30-$days*60*60*24) / (60*60)); + $mins = int(($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30-$days*60*60*24-$hours*60*60) / (60)); + $secs = ($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30-$days*60*60*24-$hours*60*60-$mins*60); + if ($days >= 30) { + $months = int($days / 30); + $days = int(($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30) / (60*60*24)); + $hours = int(($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30-$days*60*60*24) / (60*60)); + $mins = int(($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30-$days*60*60*24-$hours*60*60) / (60)); + $secs = ($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30-$days*60*60*24-$hours*60*60-$mins*60); + if ($months >= 12) { + $years = int($months / 12); + $months = int(($time_in_secs-$years*60*60*24*30*12) / (60*60*24*30)); + $days = int(($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30) / (60*60*24)); + $hours = int(($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30-$days*60*60*24) / (60*60)); + $mins = int(($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30-$days*60*60*24-$hours*60*60) / (60)); + $secs = ($time_in_secs-$years*60*60*24*30*12-$months*60*60*24*30-$days*60*60*24-$hours*60*60-$mins*60); + } + } + } + } + } + + $secs = zerofill(int($secs),2); + $mins = zerofill($mins,2); + $hours = zerofill($hours,2); + + if ($years == 0 && $months == 0 && $days == 0) { + $time_in_secs = $hours . ':' . $mins . ':' . $secs; + } elsif($years == 0 && $months == 0) { + $time_in_secs = $days . ' day(s) - ' . $hours . ':' . $mins . ':' . $secs; + } elsif($years == 0) { + $time_in_secs = $months . ' month(s)/' . $days . ' day(s) - ' . $hours . ':' . $mins . ':' . $secs; + } else { + $time_in_secs = $years . ' year(s)/' . $months . ' month(s)/' . $days . ' day(s) - ' . $hours . ':' . $mins . ':' . $secs; + } + + if ($negative == 1) { + return '- ' . $time_in_secs; + } else { + return $time_in_secs; + } +} + +sub get_cpucount { + my $cpucount = Sys::CpuAffinity::getNumCpus() + 0; + return ($cpucount > 0) ? $cpucount : 1; + #my $info = Sys::Info->new(); + #my $cpu = $info->device('CPU'); # => %options ); + #print "cpuidentify:" . scalar($cpu->identify()) . "\n"; + #print "cpuidentify:" . scalar($cpu->identify()) . "\n"; + #my $cpucount = $cpu->count() + 0; + #print "ht:" . $cpu->ht() . "\n"; + #if ($cpu->ht()) { + # $cpucount *= 2; + #} + + return ($cpucount > 0) ? $cpucount : 1; + #printf "CPU: %s\n", scalar($cpu->identify) || 'N/A'; + #printf "CPU speed is %s MHz\n", $cpu->speed || 'N/A'; + #printf "There are %d CPUs\n" , $cpu->count || 1; + #printf "CPU load: %s\n" , $cpu->load || 0; +} + +1; \ No newline at end of file