DBIx-JCL
view release on metacpan or search on metacpan
lib/DBIx/JCL.pm view on Meta::CPAN
$jobname = $jn;
foreach my $opt ( @cl ) {
push @ARGV, $opt; # add additional command line option
}
unless ( $jobname ) {
sys_die( 'Please specify jobname when initializing', 0 );
}
_sys_init_vars();
$log_file = $jobname . $log_ext;
$log_filefull = $path_log_dir.$log_file;
push @ARGV, '-r' if $jobname eq "JCL"; # for convenience
$sys_jobconf_file = _sys_check_de_override( $jobname );
$sys_jobconf_file .= ".conf";
_sys_read_conf( $sys_jobconf_file ); # tie %conf_job to job's conf file
_sys_read_job(); # read job specific settings from %conf_job
GetOptions( "r" => \$opt_run,
"rb" => \$opt_run_background,
"rs=s" => \$opt_run_scheduled,
"rr=s" => \$opt_run_restart,
"rde=s" => \$opt_run_de,
"x=s" => \$opt_commandline_ext,
"c=s" => \$opt_connection,
"v" => \$opt_verbose,
"vv" => \$opt_very_verbose,
"ng" => \$opt_no_greeting,
"tc=s" => \$opt_test_dbcon,
"lf=s" => \$opt_log_file,
"lg=i" => \$opt_log_gdg,
"lp=s" => \$opt_log_prefix,
"lr=i" => \$opt_log_radix,
"ll=s" => \$opt_logging_levels,
"cl=s" => \$opt_console_levels,
"ne" => \$opt_notify_email_oncomp,
"np" => \$opt_notify_pager_oncomp,
"et=s" => \$opt_notify_email_tolist,
"el=s" => \$opt_notify_email_levels,
"pt=s" => \$opt_notify_pager_tolist,
"pl=s" => \$opt_notify_pager_levels,
"dp" => \$opt_disp_params,
"dq" => \$opt_disp_sql,
"dd" => \$opt_disp_doc,
"dl" => \$opt_disp_logprev,
"da" => \$opt_disp_logarch,
"dj" => \$opt_disp_jobs,
"dja" => \$opt_disp_active_jobs,
"se=s" => \$opt_send_email,
"sp=s" => \$opt_send_pager,
"um" => \$opt_util_move,
"h" => \$opt_help,
"ha" => \$opt_help_args,
) || _sys_help(0);
if ( $opt_connection ) {
foreach my $connectdef ( split m/,/, $opt_connection ) {
my ($db, $inst) = split m/:/, $connectdef;
_check_array_val( $db, \@databases )
|| sys_die( "Invalid database: [$db]", 0 );
_check_array_val( $inst, [split m/,/, $dbinst{$db}] )
|| sys_die( "Invalid database instance: [$db.$inst]", 0 );
## update default connection data
$dbdefenvr{$db} = $inst;
}
}
# create dbitrace file if not found
if ( ! -e $dbitrace_filefull ) {
open my $fh, ">", $dbitrace_filefull
|| sys_die( 'Unable to open dbitrace file', 0 );
close $fh;
}
if ( $opt_help ) {
_sys_help( 1 ); }
if ( $opt_help_args ) {
_sys_help( 2 ); }
if ( $opt_run_background ) {
_sys_run_background(); }
if ( $opt_run_scheduled ) {
_sys_run_scheduled(); }
if ( $opt_run_de ) {
_sys_run_de( $opt_run_de ); }
if ( $opt_run_restart ) {
_sys_run_restart(); }
if ( $opt_test_dbcon ) {
_sys_test_dbcon( $opt_test_dbcon); }
if ( $opt_commandline_ext ) {
$commandline_ext = $opt_commandline_ext; }
if ( $opt_logging_levels ) {
$log_logging_levels = _sys_check_severity_levels( $opt_logging_levels ); }
if ( $opt_console_levels ) {
$log_console_levels = _sys_check_severity_levels( $opt_console_levels ); }
if ( $opt_log_gdg ) {
$log_gdg = _sys_check_log_gdg( $opt_log_gdg ); }
if ( $opt_log_prefix ) {
$log_prefix = $opt_log_prefix; }
if ( $opt_log_radix ) {
$log_radix = _sys_check_log_radix( $opt_log_radix ); }
if ( $opt_notify_email_tolist ) {
$mail_emailto = $opt_notify_email_tolist; }
if ( $opt_notify_pager_tolist ) {
$mail_pagerto = $opt_notify_pager_tolist; }
if ( $opt_notify_email_levels ) {
$mail_email_levels = _sys_check_severity_levels( $opt_notify_email_levels ); }
if ( $opt_notify_pager_levels ) {
$mail_pager_levels = _sys_check_severity_levels( $opt_notify_pager_levels ); }
if ( $opt_disp_logprev ) {
_sys_disp_logprev(); }
if ( $opt_disp_logarch ) {
_sys_disp_logarch(); }
if ( $opt_disp_exec ) {
_sys_disp_exec(); }
if ( $opt_disp_sql ) {
_sys_disp_sql(); }
if ( $opt_disp_params ) {
_sys_disp_params(); }
if ( $opt_disp_doc ) {
_sys_disp_doc(); }
if ( $opt_disp_jobs ) {
lib/DBIx/JCL.pm view on Meta::CPAN
if ( ! $conf_job{$section}{$sqlname} ) {
sys_die( "The job conf file does not contain a query named [$sqlname]", 0 );
}
}
return $conf_job{$section}{$sqlname};
}
sub sys_get_item {
=begin wiki
!3 sys_get_item
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
my ($item, $altsection) = @_;
my $section = $altsection || 'job';
my $value = $conf_job{$section}{$item};
if ( ! defined $value ) {
sys_die( "Job conf missing entry [$item] in section [$section]", 0 );
}
if ( $value eq '0' ) {
return $conf_job{$section}{$item};
}
return $value;
}
sub sys_get_hash {
=begin wiki
!3 sys_get_hash
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
my ($section, $entry, $delim) = @_;
$delim = ':' unless $delim;
my ($pseudo, %hash);
if ( $conf_job{$section}{$entry} ) {
$pseudo = $conf_job{$section}{$entry};
} else {
sys_die( "No job conf entry found for $entry in section $section" );
}
## construct a real hash from the pseudo hash
foreach my $item ( split "\n", $pseudo ) {
my ($key, $value) = split m/$delim/, $item;
$hash{$key} = $value;
}
return \%hash; ## ref to hash
}
sub sys_get_array {
=begin wiki
!3 sys_get_array
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
my ($section, $entry, $delim) = @_;
$delim = ':' unless $delim;
my ($pseudo, @array);
if ( $conf_job{$section}{$entry} ) {
$pseudo = $conf_job{$section}{$entry};
} else {
sys_die( "No job conf entry found for $entry in section $section" );
}
## construct a real array from the pseudo array
foreach my $item ( split "\n", $pseudo ) {
push @array, $item;
}
return \@array; ## ref to an array
}
sub sys_get_common_sql {
=begin wiki
!3 sys_get_common_sql
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
my ($sqlname, $altsection) = @_;
my $section = $altsection || 'sql';
if ( ! $conf_query{$section}{$sqlname} ) {
$sqlname = 'sql:'.$sqlname;
if ( ! $conf_query{$section}{$sqlname} ) {
sys_die( 'Common sql conf missing query by that name', 0 );
}
}
return $conf_query{$section}{$sqlname};
}
lib/DBIx/JCL.pm view on Meta::CPAN
sub sys_get_logging_levels {
=begin wiki
!3 sys_get_logging_levels
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
return $log_logging_levels;
}
sub sys_get_console_levels {
=begin wiki
!3 sys_get_console_levels
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
return $log_console_levels;
}
sub sys_get_commandline {
=begin wiki
!3 sys_get_commandline
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
return join ' ', @ARGV;
}
sub sys_get_commandline_opt {
=begin wiki
!3 sys_get_commandline_opt
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
my $target_opt = shift;
foreach my $option ( @ARGV ) {
my ($opt,$val) = split m/=/, $option;
$opt =~ s/^-\s*//x;
$opt =~ s/\s+$//x;
if ( $opt =~ m/^$target_opt$/ix ) {
return 1;
}
}
return 0;
}
sub sys_get_commandline_val {
=begin wiki
!3 sys_get_commandline_val
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
my ($target_opt,$default_value) = @_;
## handle:
## >script.pl -r -- -batchsize=10
foreach my $option ( @ARGV ) {
$option =~ s/\s+=/=/x;
$option =~ s/=\s+/=/x;
my ($opt,$val) = split m/=/, $option;
$opt =~ s/^-\s*//x;
$opt =~ s/\s+$//x;
if ( $opt =~ m/^$target_opt$/ix ) {
#$val =~ s/^\s*//;
#$val =~ s/\s*$//;
return $val;
}
}
return $default_value;
}
sub sys_get_script_file {
=begin wiki
!3 sys_get_script_file
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
return $script_file;
}
sub sys_get_util_move {
=begin wiki
!3 sys_get_util_move
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
return $util_move;
}
sub sys_get_user {
=begin wiki
!3 sys_get_user
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
return getlogin || 'unknown';
}
sub sys_get_maxval {
=begin wiki
!3 sys_get_maxval
lib/DBIx/JCL.pm view on Meta::CPAN
!3 db_init
Parameters: ( )
User interface to settings used by the various db functions. Requested \
settings are validated against those held in the db_func_parmas hash.
Returns:
=cut
my ($id, %params) = @_;
if ( ! defined $db_func_params{$id} ) {
sys_die( "Param $id to db_init is invalid")
}
foreach my $key ( keys %params ) {
if ( ! defined $db_func_params{$id}{$key} ) {
sys_die( "Param $key to db_init is invalid" );
}
$db_func_params{$id}{$key} = $params{$key};
}
return 0;
}
sub db_connect {
=begin wiki
!3 db_connect
Parameters: ( vdn )
This function accepts a virtual database name and makes a connection to the \
database resource identified by that name. The desired database instance has \
already been determined and stored before this function is called.
This function sets the DBI tracing mode so that we have a dbitrace.log file \
with pertinent history in it. This file will get large, so it should be \
rotated frequently. Contrary to what I've read, this does not supress \
output to STDERR. It appears that this just forces DBI to write errors to \
both STDERR and the dbitrace file. To fix that, this function redirects \
STDERR to /dev/null. This is an ugly hack. So until I can figure out if I \
read the docs wrong, or if DBI is just broken in this regard, I need to \
leave this to prevent garbage output. It's garbage because I always check \
and log DBI errors anyway.
Returns:
=cut
my ($vdn, %connect_params) = @_;
my ($starttime, $dbh, $instance);
## time increment is secs, action is either 'run' or 'fail'
my $dependent_jobname = $connect_params{dependent_jobname} || '';
my $wait_duration = $connect_params{wait_duration} || 60;
my $wait_max_secs = $connect_params{wait_max_secs} || 60*60;
my $wait_action = $connect_params{wait_action} || 'fail';
my $retry_duration = $connect_params{retry_duration} || 0;
my $retry_max_secs = $connect_params{retry_max_secs} || 0;
if ( $vdn =~ m/:/x ) { ## vdn contains instance definiton
my ($db, $inst) = split m/:/, $vdn;
_check_array_val( $db, \@databases )
|| sys_die( "Invalid database: [$db]", 0 );
_check_array_val( $inst, [split m/,/, $dbinst{$db}] )
|| sys_die( "Invalid database instance: [$db.$inst]", 0 );
$dbdefenvr{$db} = $inst; ## update default connection data
$vdn = $db; ## vdn gets true vdn
}
## check for dependent job
_db_connect_check_dependent(
$dependent_jobname, $wait_duration, $wait_max_secs, $wait_action
);
## get database parameters
my ($db, $un, $pw) = _db_vdn('connect', $vdn);
DBI->trace( 1, $dbitrace_filefull );
open STDERR, '>', '/dev/null' unless $opt_very_verbose;
## connect with retry
$dbh = _db_connect_retry(
$db, $un, $pw, $retry_duration, $retry_max_secs
);
## connection established
$dbhandles{$vdn}{'dbh'} = $dbh; ## store handle for cleanup on exit
db_nil( $vdn );
return 0;
}
sub db_nil {
=begin wiki
!3 db_nil
Parameters: ( )
This is just a convenience function. When running in test mode, this will \
call the internal C<_db_vdn> to function for force closure of all database \
connections immediately.
Returns:
=cut
my $vdn = shift;
my ($dbh, $sth) = _db_vdn( 'nil', $vdn);
return 0;
}
sub db_disconnect {
=begin wiki
!3 db_disconnect
Parameters: ( vdn )
Accept a virtual database name and disconnect from the datatabase specified \
by the virtual database name.
Returns:
=cut
my $vdn = shift;
my ($dbh, $sth) = _db_vdn( 'disconnect', $vdn);
if ( $dbh ) {
$dbh->disconnect;
if ( DBI->errstr ) {
log_warn( DBI->errstr );
return 1;
}
}
$dbhandles{$vdn}{'dbh'} = 0;
return 0;
}
sub db_finish {
=begin wiki
!3 db_finish
Parameters: ( vdn )
Accept a virtual database name and close the current statement handle for \
the database specified by the virtual database name.
Returns:
=cut
my $vdn = shift;
my ($dbh, $sth) = _db_vdn( 'finish', $vdn);
if ( $sth ) {
$sth->finish;
if ( DBI->errstr ) {
log_warn( DBI->errstr );
return 1;
}
}
$dbhandles{$vdn}{'sth'} = 0;
return 0;
}
sub db_prepare {
=begin wiki
!3 db_prepare
Parameters: ( vdn, sql_query )
Accept a virtual database name and an sql query and prepares the query for \
database processing. This function stores the resulting statement handle for \
subsequent access under the via the virtual database name.
Returns:
=cut
my ($vdn, $sql, $longrlen) = @_;
$longrlen = 0 unless $longrlen;
my $sth_name = 'sth_default'; ## default statement handle name
if ( $vdn =~ m/\./x ) {
($vdn, $sth_name) = split m/\./x, $vdn;
if ( $sth_name eq 'sth_default' ) {
sys_die( 'Invalid statement handle name', 0 );
}
}
my ($dbh, $sth) = _db_vdn('prepare', $vdn);
if ( $longrlen > 0 ) { $dbh->{LongReadLen} = $longrlen; }
$sth = $dbh->prepare( $sql )
or sys_die( $dbh->errstr );
## store statement handle for this vdn
$dbhandles{$vdn}{$sth_name} = $sth;
return 0;
}
sub db_truncate {
=begin wiki
!3 db_truncate
Parameters: ( vdn, table_name )
Accept a virtual database name and a table name. Truncate the specified \
table. This function returns number of rows truncated.
Returns:
=cut
my ($vdn, $table_name) = @_;
my ($dbh, $sth) = _db_vdn('truncate', $vdn);
my $sql = "truncate table $table_name";
$dbh->do( $sql )
or sys_die( DBI->errstr );
return 0;
}
sub db_execute {
=begin wiki
!3 db_execute
Parameters: ( vdn, sql_substitution_paramaters )
Accept a virtual database name and sql substitution parameters. Execute \
the query against the stored statement handle associated with the supplied \
virtual database name. The statement handle needs to be prepard before this \
function is called.
Returns:
=cut
my ($vdn, @params) = @_;
my ($dbh, $sth) = _db_vdn('execute', $vdn);
$sth->execute( @params )
or sys_die( $sth->errstr );
return 0;
}
sub db_get_sth {
=begin wiki
!3 db_get_sth
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
my $vdn = shift;
my $sth_name = 'sth_default'; ## default statement handle name
if ( $vdn =~ m/\./x ) {
($vdn, $sth_name) = split m/\./x, $vdn;
}
return $dbhandles{$vdn}{$sth_name};
}
sub db_get_defenvr {
=begin wiki
!3 db_get_defenvr
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
my $vdn = shift;
if ( $dbdefenvr{$vdn} ) {
return $dbdefenvr{$vdn};
}
return '';
}
sub db_bindcols {
=begin wiki
!3 db_bindcols
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
#
# interface:
# interface to sth->bind_columns()
#
# accepts:
# 1st position
# a raw statement handle
# a vdn which is used to obtain a default statment handle (one per vdn)
# a vdn, named statement handle pair in the form vdn||nsth
# remaining
# any number of references to scalars
#
# returns:
# 0 = success
# errors handled internally
#
my ($vdn,@colrefs) = @_;
my $sth;
if ( ref $vdn ) {
$sth = $vdn; ## received a raw sth
} else {
my $sth_name = 'sth_default'; ## default statement handle name
if ( $vdn =~ m/\./x ) { ## dot notation vdn.sthn
($vdn, $sth_name) = split m/\./x, $vdn;
}
$sth = $dbhandles{$vdn}{$sth_name};
}
foreach my $colref ( @colrefs ) {
if ( ! ref $colref ) { sys_die( "Received bad ref in db_bindcols" ); }
}
$sth->bind_columns( @colrefs );
return 0;
}
sub db_pef {
=begin wiki
!3 db_pef
Parameters: ( )
Prepare, Execute, Fetch a scalar value
This function always returns the first element of the first row of the
result set.
Returns:
=cut
my ($vdn, $sqlname, @params) = @_;
my $sql = sys_get_sql( $sqlname );
db_prepare( $vdn, $sql );
db_execute( $vdn, @params );
my $row = db_fetchrow( $vdn );
return @{$row}[0];
}
sub db_pef_list {
=begin wiki
!3 db_pef_list
Parameters: ( )
Prepare, Execute, Fetch a result set as a list of scalars
This function returns a list of the first element from each row of the \
result set.
Returns:
=cut
my ($vdn, $sqlname, @params) = @_;
my @rsalist;
my $sql = sys_get_sql( $sqlname );
db_prepare( $vdn, $sql );
db_execute( $vdn, @params );
while ( my $row = db_fetchrow( $vdn ) ) {
push @rsalist, @{$row}[0];
}
return \@rsalist; ## return result set asa list
}
sub db_fetchrow {
=begin wiki
!3 db_fetchrow
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
#
# interface:
# interface to sth->fetchrow_arrayref()
#
# accepts:
# a raw statement handle
# a vdn which is used to obtain a default statment handle (one per vdn)
# a vdn, named statement handle pair in the form vdn||nsth
#
# note:
# If you are going to make lots of calls to db_fetchrow for the
# same execute cycle, you will get better performance using a raw
# statement handle over a statement handle name
#
# returns:
# reference to an array
#
my $vdn = shift;
my $sth;
if ( ref $vdn ) {
$sth = $vdn; ## received a raw sth
} else {
my $sth_name = 'sth_default'; ## default statement handle name
if ( $vdn =~ m/\./x ) {
($vdn, $sth_name) = split m/\./x, $vdn;
}
$sth = $dbhandles{$vdn}{$sth_name};
}
return $sth->fetchrow_arrayref();
}
sub db_commit {
=begin wiki
!3 db_commit
Parameters: ( virtual_database_name )
Accept a virtual database name and perform a commit against the specified \
database connection.
Returns:
=cut
my ($vdn) = shift;
my ($dbh, $sth) = _db_vdn('commit', $vdn);
$dbh->commit;
if ( DBI->errstr ) {
sys_die( DBI->errstr );
return 1; ## test harness returns from sys_die
}
return 0;
}
sub db_rollback {
=begin wiki
!3 db_rollback
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
my ($vdn) = shift;
my ($dbh, $sth) = _db_vdn('rollback', $vdn);
$dbh->rollback;
if ( DBI->errstr ) {
sys_die( DBI->errstr );
return 1; ## test harness returns from sys_die
}
return 0;
}
sub db_rowcount_table {
=begin wiki
!3 db_rowcount_table
Parameters: ( vdn, table_name )
lib/DBIx/JCL.pm view on Meta::CPAN
"checkpoints". If you have four database environments, you should have \
four checkpoint entries in your job conf file. The name of the current \
database environment is determined using the function sys_get_dataenvr().
Once the range limit query and all of the checkpoint values have been \
obtained, the parameter vdn is used to execute the range limit query.
Each checkpoint entry takes the form:
COLUMN_VALUE = count:percent_deviation
The range limit query will be executed for each COLUMN_VALUE entry. The \
actual count returned will be compared to the checkpoint count, if the \
count returned is within the percent range specified by the checkpoint \
percent_deviation, the test will pass, otherwise the test will fail and a \
log warning will be generated.
A percent_deviation of 0 (zero) represents a special case. If a \
percent_deviation of 0 is used, this instructs db_sanity_check to accept \
any positive value for count as a valid value. Typically, this behavior \
would be invoked by using a column value entry of "1:0".
An expected value of 0 (zero) represents a special case as well. When the \
expected value is 0, checking for that column value will be bypassed. In \
this way you can "turn off" sanity checking for an entire database \
environment by making all of the column value entries equal to "0:0".
If the /notify/ parameter is set, a notification will be sent in addition \
to a log warning.
Returns:
=cut
my ($vdn, $query_name, $notify) = @_;
$notify = 0 unless $notify;
my $warnings = 0;
my $lead = "Sanity check:";
my $okay = " Ok ";
my $outofbounds = " Out Of Bounds ";
my $disabled = " Disabled ";
## get checkpoints
my $checkpoints;
my $conf_entry = sys_get_dataenvr . '_checkpoints';
if ( $conf_job{threshold}{$conf_entry} ) {
$checkpoints = $conf_job{threshold}{$conf_entry};
} else {
log_warn( "No threshold checkpoints found in job conf for: $conf_entry" );
return 1;
}
## prepare range limit query
my $query = sys_get_sql( $query_name );
db_prepare( $vdn, $query );
log_info( "$lead Status [Test] Expected/Actual/Threshold(%)/Threshold(#)" );
## perform checkpoint tests
foreach my $chkpt ( split "\n", $checkpoints ) {
my ($param,$rest) = split m/=/, $chkpt;
my ($exp,$range) = split m/:/, $rest;
$param = _trim($param); ## col to check
$exp = _trim($exp); ## expected value
$range = _trim($range); ## range/tolerance
db_execute( $vdn, $param );
my $row = db_fetchrow( $vdn );
my $act = @{$row}[0]; ## actual value
my $dev = int $exp * ( $range / 100 ); ## deviation as a percent
my $status = "[$param] $exp/$act/$range/$dev ";
if ( $exp == 0 ) { ## checking has been disabled
log_info( $lead . $disabled . $status );
next;
}
if ( $range == 0 ) { ## any positive value for actual is acceptable
if ( $act > 0 ) {
log_info( $lead . $okay . $status );
next;
}
$warnings++;
log_info( $lead . $outofbounds . $status );
next;
}
if ( $act < $exp ) { ## actual is below threshold
if ( $act < $exp - $dev ) {
log_info( $lead . $outofbounds . $status );
$warnings++;
next;
}
}
if ( $act > $exp ) { ## actual is above threshold
if ( $act > $exp + $dev ) {
log_info( $lead . $outofbounds . $status );
$warnings++;
next;
}
}
log_info( $lead . $okay . $status );
}
## send out notifications if there are warnings
if ( $warnings && $notify ) {
_log_send_notifications( "WARN", 1, "Sanity check threshold exceeded" );
}
return 0;
}
sub db_drop_index {
=begin wiki
!3 db_drop_index
Parameters: ( vdn, index_name )
lib/DBIx/JCL.pm view on Meta::CPAN
=cut
$pid = $PROCESS_ID;
$errorlevel = 0;
@plugins = ();
$sys_dbms_output = 1;
$sys_log_open = 0;
$sys_jobconf_override = 0;
$sys_jobconf_file = '';
%log_level_opts = (
FATAL => 'FATAL',
ERROR => 'FATAL,ERROR',
WARN => 'FATAL,ERROR,WARN',
INFO => 'FATAL,ERROR,WARN,INFO',
DEBUG => 'FATAL,ERROR,WARN,INFO,DEBUG',
NONE => 'NONE',
);
_sys_read_conf( 'sys_data.conf' );
_sys_read_conf( 'sys_log.conf' );
_sys_read_conf( 'sys_mail.conf' );
_sys_read_conf( 'sys_common.conf' );
_sys_read_conf( 'sys_util.conf' );
_sys_read_conf( 'sys_environment.conf' );
_sys_read_conf( 'sys_de.conf');
_sys_read_conf( 'sys_run_controls.conf');
my $envvar = uc $conf_system{'system'}{'envvar'};
$dataenvr = lc $ENV{$envvar};
if ( ! defined $dataenvr ) {
sys_die( "Environment variable $dataenvr not set", 0 );
}
$path_bin_dir = $conf_system{"$OSNAME directory bin"}{$dataenvr};
$path_lib_dir = $conf_system{"$OSNAME directory lib"}{$dataenvr};
$path_log_dir = $conf_system{"$OSNAME directory log"}{$dataenvr};
$path_load_dir = $conf_system{"$OSNAME directory load"}{$dataenvr};
$path_extr_dir = $conf_system{"$OSNAME directory extr"}{$dataenvr};
$path_prev_dir = $conf_system{"$OSNAME directory prev"}{$dataenvr};
$path_scripts_dir = $conf_system{"$OSNAME directory scripts"}{$dataenvr};
$mail_server = $conf_mail{'mail'}{'server'};
$mail_from = $conf_mail{'mail'}{'from'};
$mail_emailto = $conf_mail{'mail'}{'emailto'};
$mail_pagerto = $conf_mail{'mail'}{'pagerto'};
$mail_email_levels = $conf_mail{'mail'}{'email_levels'} || "FATAL";
$mail_pager_levels = $conf_mail{'mail'}{'pager_levels'} || "FATAL";
$log_file = $conf_log{'log'}{'default_logfile'};
$log_filefull = $path_log_dir . $log_file;
$log_logging_levels = $conf_log{'log'}{'logging_levels'} || "FATAL,ERROR,WARN,INFO";
$log_console_levels = $conf_log{'log'}{'console_levels'} || "FATAL,ERROR,WARN,INFO";
$log_gdg = $conf_log{'log'}{'gdg'} || 5;
$path_plugin_dir = $conf_system{"$OSNAME directory plugin"}{$dataenvr};
if ( $osuser ) {
$dbitrace_file = $dbitrace_base . '_' . $osuser . $log_ext;
}
$dbitrace_filefull = $path_log_dir.$dbitrace_file;
## load data structures
@databases = split m/,/, $conf_data{'databases'}{'databases'};
@dat_envrs = split m/,/, $conf_system{'system'}{'dat_envrs'};
@job_acros = split m/,/, $conf_system{'system'}{'job_acros'};
foreach my $db ( @databases ) {
$dbname{$db} = $conf_data{'names'}{$db};
}
foreach my $db ( @databases ) {
$dbdefenvr{$db} = $conf_data{'default '.$dataenvr}{$db};
}
foreach my $db ( @databases ) {
$dbhandles{$db}{'dbh'} = 0;
$dbhandles{$db}{'sth'} = 0;
}
foreach my $db ( @databases ) {
$dbinst{$db} = $conf_data{'instances'}{$db};
}
foreach my $db ( @databases ) {
foreach my $inst ( split m/,/, $conf_data{'instances'}{$db} ) {
$dbconn{$db}{$inst}{'netservice'} = $conf_data{"$db $inst"}{'netservice'};
$dbconn{$db}{$inst}{'database' } = $conf_data{"$db $inst"}{'database'};
$dbconn{$db}{$inst}{'username' } = $conf_data{"$db $inst"}{'username'};
$dbconn{$db}{$inst}{'password' } = $conf_data{"$db $inst"}{'password'};
}
}
return 0;
}
sub _sys_job_init {
=begin wiki
!3 _sys_job_init
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
my $rtconf = $path_conf_dir.'/'.$jobname.'.'.$pid.'.running';
## create runtime conf file
open my $cfile, '>', $rtconf or sys_die( "Error creating runtime jobconf file" );
close $cfile;
my $conf = new Config::IniFiles( -file => $rtconf );
unless ( defined $conf ) { sys_die( "Error opening runtime jobconf file" ); }
my $starttime = time;
$conf->newval( 'pid', 'pid', $pid );
$conf->newval( 'starttime', 'starttime', $starttime );
$conf->newval( 'restart', 'restart', 0 );
$conf->RewriteConfig;
return 0;
}
sub _sys_job_end {
=begin wiki
!3 _sys_job_end
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
my $rtconf = $path_conf_dir.'/'.$jobname.'.'.$pid.'.running';
if ( -e $rtconf ) {
unlink $rtconf;
}
return 0;
}
sub _sys_job_dependent {
=begin wiki
lib/DBIx/JCL.pm view on Meta::CPAN
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
my ($jobname, @params) = @_;
my $pid;
if ( $pid = fork ) {
return $pid;
## this is the parent, so return the pid, everything below here is
## either the child or a major system failure
}
elsif ( defined $pid ) {
exec $jobname, @params;
## shouldn't reach this unless exec fails, we exit here (not return)
## becuase we are in the child
exit 0;
} else {
log_warn( "Could not fork $!" );
return 0;
}
}
sub _sys_reap_child {
=begin wiki
!3 _sys_reap_child
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
my $pid = 0;
if ( ($pid = waitpid(-1, 0)) > 0 ) {
$pidlib{$pid}{retcd} = $? >> 8;
}
return $pid;
}
sub _sys_test_dbcon {
=begin wiki
!3 _sys_test_dbcon
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
my $connections = shift;
## open dbi trace file
DBI->trace(1, $dbitrace_filefull );
foreach my $connectdef ( split m/,/, $connections ) {
my ($db, $inst) = split m/:/, $connectdef;
_check_array_val( $db, \@databases )
|| sys_die( "Invalid database: [$db]", 0 );
_check_array_val( $inst, [split m/,/, $dbinst{$db}] )
|| sys_die( "Invalid database instance: [$db.$inst]", 0 );
my $database = $dbconn{$db}{$inst}{'database'};
my $username = $dbconn{$db}{$inst}{'username'};
my $password = $dbconn{$db}{$inst}{'password'};
print "Connecting to: $db/$inst\n";
my $dbh = DBI->connect( $database, $username, $password, { RaiseError => 0, AutoCommit => 0 } )
or sys_die( DBI->errstr, 0 );
## push resulting handle onto handle stack for cleanup on exit
$dbhandles{$db}{'dbh'} = $dbh;
print "Success\n\n";
}
exit 0;
}
sub _sys_check_severity_levels {
=begin wiki
!3 _sys_check_severity_levels
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
my $lvls_str = shift;
## levls_str can be either a single value or a comma delimited list
if ( $lvls_str =~ /,/ ) {
## received a list of severity levels
my @loglvls = split m/,/, $lvls_str;
foreach my $level ( @loglvls ) {
if ( $level !~ /FATAL|ERROR|WARN|INFO|DEBUG|NONE/ ) {
sys_die( 'Invalid logging/notification severity list', 0 );
}
}
return $lvls_str;
} else {
## received a single severity level to be translated to a list
if ( $lvls_str =~ /^FATAL$/i ) {
$lvls_str = 'FATAL';
return $lvls_str;
}
if ( $lvls_str =~ /^ERROR$/i ) {
$lvls_str = 'FATAL,ERROR';
return $lvls_str;
}
if ( $lvls_str =~ /^WARN$/i ) {
$lvls_str = 'FATAL,ERROR,WARN';
return $lvls_str;
}
if ( $lvls_str =~ /^INFO$/i ) {
$lvls_str = 'FATAL,ERROR,WARN,INFO';
return $lvls_str;
}
if ( $lvls_str =~ /^DEBUG$/i ) {
$lvls_str = 'FATAL,ERROR,WARN,INFO,DEBUG';
return $lvls_str;
}
if ( $lvls_str =~ /^NONE$/i ) {
$lvls_str = '';
return $lvls_str;
}
sys_die( 'Invalid logging/notification severity level', 0 );
}
return 0;
}
sub _sys_check_log_gdg {
=begin wiki
!3 _sys_check_log_gdg
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
if ( $opt_log_gdg =~ /[0-9]{1,3}/ ) {
sys_die( 'Invalid log gdg specified', 0 );
}
return $opt_log_gdg;
}
sub _sys_check_log_radix {
=begin wiki
!3 _sys_check_log_radix
lib/DBIx/JCL.pm view on Meta::CPAN
=begin wiki
!3 _sys_disp_params
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
my $dblen = 0;
foreach my $db ( @databases ) {
if ( length $dbname{$db} > $dblen ) { $dblen = length $dbname{$db}; }
}
print "\n" . uc($dataenvr) . " Database Connections:\n";
foreach my $db ( @databases ) {
my $dbstr = sprintf "%-${dblen}s", $dbname{$db};
$dbstr .= ' = ' . $db . '/' . $dbdefenvr{$db};
print " $dbstr\n",;
}
print "\n" . uc($dataenvr) . " Job Settings:\n";
print " Job Name = ", $jobname, "\n";
print " Log File = ", $log_file, "\n";
print " Log Logging Levels = ", $log_logging_levels, "\n";
print " Log Console Levels = ", $log_console_levels, "\n";
print " Log Gdg = ", $log_gdg, "\n";
print " Path Bin Dir = ", $path_bin_dir, "\n";
print " Path Log Dir = ", $path_log_dir, "\n";
print " Path Lib Dir = ", $path_lib_dir, "\n";
print " Path Conf Dir = ", $path_conf_dir, "\n";
print " Path Plugin Dir = ", $path_plugin_dir, "\n";
print " Path Load Dir = ", $path_load_dir, "\n";
print " path Extract Dir = ", $path_extr_dir, "\n";
print " path Prev Dir = ", $path_prev_dir, "\n";
print " path Scripts Dir = ", $path_scripts_dir, "\n";
print " Mail Server = ", $mail_server, "\n";
print " Mail Email From = ", $mail_from, "\n";
print " Mail Email To = ", $mail_emailto, "\n";
print " Mail Pager To = ", $mail_pagerto, "\n";
print " Mail Email Levels = ", $mail_email_levels, "\n";
print " Mail Pager Levels = ", $mail_pager_levels, "\n";
print "\n";
exit 0;
}
sub _sys_send_email_message {
=begin wiki
!3 _sys_send_email_message
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
my $params = shift;
my ($addrlist, $message) = split m/~/, $params;
$mail_emailto = $addrlist;
_log_send_mail($message, 'MESSAGE');
exit 0;
}
sub _sys_send_pager_message {
=begin wiki
!3 _sys_send_pager_message
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
my $params = shift;
my ($addrlist, $message) = split m/~/, $params;
$mail_pagerto = $addrlist;
_log_send_page($message, 'MESSAGE');
exit 0;
}
sub _sys_help {
=begin wiki
!3 _sys_help
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
my $verbose = shift;
$verbose = 0 unless $verbose;
my $section;
if ( $verbose == 0 ) {
print "\nUSAGE\n $script_file [options]\n\n";
print "Use option -h for help with options\n";
print "Use option -hp for help with option parameters\n";
print "Use option -man for system documentation\n";
exit 1;
}
if ( $verbose == 1 ) { $section = 'OPTIONS'; };
if ( $verbose == 2 ) { $section = 'ARGUMENTS'; };
print "\n";
my %podparams = (
infile => $path_lib_dir."DBIx/JCL.pm",
outfile => "STDOUT",
section => $section,
);
wikipod2text( %podparams );
exit 1;
}
sub _log_init_log_file {
=begin wiki
!3 _log_init_log_file
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
## log file rotation if generations > 0
if ( -e $log_filefull && $log_gdg > 0 ) {
_log_rotate();
}
## create new locked log file
lib/DBIx/JCL.pm view on Meta::CPAN
} else {
if ( $log_console_levels =~ /$level/ || $force ) {
print "$message\n";
}
}
return 0;
}
sub _log_print_log {
=begin wiki
!3 _log_print_log
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
my ($level, $message) = @_;
my $preamble = time2str( '%Y/%m/%d %T', time );
if ( $level eq 'FATAL' ) { $preamble .= ' FATAL'; }
if ( $level eq 'ERROR' ) { $preamble .= ' ERROR'; }
if ( $level eq 'WARN' ) { $preamble .= ' WARNING'; }
## open locked log file for appending
## if the file is already locked, will wait until the file is unlocked
my $fh = new IO::LockedFile(">>$log_filefull")
or sys_die( 'Failed opening log file', 0 );
print {$fh} "$preamble $message\n";
## close and unlock the file
$fh->close();
return 0;
}
sub _log_trim_msg {
=begin wiki
!3 _log_trim_msg
Parameters: ( message )
Format log file text so that it looks good when printed to STDOUT. This \
function is only called from the logging functions. This takes message \
text that was previously retrieved by dbms_output_get and stringified by \
a logging function and removes the leading whitespace from each line of \
text, if there is any. This is made necessary due to the fact that this \
text started life as an array of lines retrieved from dbms_output_get(), \
and each of these lines had leading whitespace to make them more readable \
in the log file.
Returns:
=cut
my $msg = shift;
my $trimmed = '';
if ( $msg =~ /\n/ms ) { ## trim leading spaces from multi-line messages
foreach my $m ( split m/\n/, $msg ) {
$m =~ s/^\s+//;
$trimmed .= $m."\n";
}
$trimmed =~ s/\n$//ms;
} else {
$trimmed = $msg;
}
return $trimmed;
}
sub _log_send_notifications {
=begin wiki
!3 _log_send_notifications
Parameters: ( message, severity_level )
Send email and pager notifications based on supplied severity. If the \
severity levels for email and or pager notifications are at or below the \
severity level supplied to this function, a notification will be sent.
Note: if running under test harness (different than test mode), all \
messages are logged, but no notifications of any severity will be generated. \
Generation of actual email and pager notices is not testable using the test \
harness.
Returns:
=cut
my ($level, $force, $message) = @_;
# if ( $tst_harness ) {
# return 0;
# }
if ( $mail_email_levels =~ /$level/ || $force ) {
_log_send_mail( $message, $level );
}
if ( $mail_pager_levels =~ /$level/ || $force ) {
_log_send_page( $message, $level );
}
return 0;
}
sub _log_send_mail {
=begin wiki
!3 _log_send_mail
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
my ($message, $severity) = @_;
return 0 unless $mail_emailto;
return 0 if $mail_emailto =~ /NONE/i;
lib/DBIx/JCL.pm view on Meta::CPAN
=cut
my ($db,$un,$pw,$retry_duration,$retry_max_secs) = @_;
my $dbh = 0;
my $starttime = time;
while ( 1 ) {
$dbh = DBI->connect( $db, $un, $pw, { RaiseError => 0, AutoCommit => 0 } );
if ( DBI->errstr ) {
if ( $retry_max_secs < 1 ) {
sys_die( DBI->errstr );
return 1; ## reachable if $sys_test_harness
}
if ( DBI->err == 1017 ) { ## ora invalid account or password
sys_die( DBI->errstr );
return 1; ## reachable if $sys_test_harness
}
log_info( DBI->errstr );
log_info( "Connection retry requested, waiting" );
sleep $retry_duration;
my $curtime = time;
if ( $curtime - $starttime > $retry_max_secs ) {
sys_die( "Maximum connection retry time exceeded, aborting" );
return 1; ## reachable if $sys_test_harness
}
} else {
last;
}
}
return $dbh;
}
sub _db_vdn {
=begin wiki
!3 _db_vdn
Parameters: ( caller_id_string, vdn )
This function accepts a caller id string and a virtual database name. A \
virtual database name is a text string which identifies a database \
connection. If we are running in test mode and the caller is not the \
db_connect function, this function will gracefully shut-down. Otherwise \
it returns either raw database connection information or it returns the \
appropriate database handle and statement handle for the named database.
Returns:
=cut
my ($caller, $vdn) = @_;
my $sth_name = 'sth_default'; ## default statement handle name
## does vdn contains explicit statement handle?
if ( $vdn =~ /\./ ) {
($vdn, $sth_name) = split /\./, $vdn;
}
my ($this_db, $this_inst);
if ( $vdn =~ m/:/x ) { ## does vdn contain explicit instance?
($this_db, $this_inst) = split m/:/, $vdn;
} else {
$this_db = $vdn;
$this_inst = $dbdefenvr{$vdn};
}
if ( ! $dbname{$this_db} ) {
sys_die( "Virtual database name [$vdn] is invalid" );
}
## special return values if caller is 'connect'
if ( $caller eq 'connect' ) {
my $database = $dbconn{$this_db}{$this_inst}{'database'};
my $username = $dbconn{$this_db}{$this_inst}{'username'};
my $password = $dbconn{$this_db}{$this_inst}{'password'};
return ($database, $username, $password);
}
# ## shutdown gracefully if running under the 'test connections' flag
# if ( $opt_test ) {
# log_close( "End connection test: $jobname" );
# sys_end();
# exit 0;
# }
## return database and statement handles for this vdn
my $dbh = $dbhandles{$this_db}{'dbh'};
my $sth = $dbhandles{$vdn}{$sth_name};
return ($dbh, $sth);
}
sub _db_netservice {
=begin wiki
!3 _db_netservice
Parameters: ( vdn )
This function accepts a virtual database name that contains an explicit \
instance. A virtual database name is a text string which identifies a \
database connection. The "network service", i.e., remote database \
connection string is returned from sys_data.conf for the provided instance.
Returns:
=cut
my ($vdni) = shift;
my $netservice = '';
if ( $vdni =~ m/:/x ) { ## vdn contains instance definiton
my ($db, $inst) = split m/:/, $vdni;
_check_array_val( $db, \@databases )
|| sys_die( "Invalid database: [$db]", 0 );
_check_array_val( $inst, [split m/,/, $dbinst{$db}] )
|| sys_die( "Invalid database instance: [$db.$inst]", 0 );
$netservice = $dbconn{$db}{$inst}{netservice};
}
return $netservice;
}
sub _db_proc_build_sql {
=begin wiki
!3 _db_proc_build_sql
Parameters: ( package_name, procedure_name, parameters)
* /parameters/ - parameters is a reference to an array
This function builds a sql statement to execute an Oracle Stored Procedure. \
The sql statement uses generated variable names, e.g., :p1, :p2, :p3, etc. \
This works because functions that use this sql statement all pass parameters \
to the requested stored procedure positionally. The function accepts a \
reference to an array of param in parameters. This is used only to get a \
count of the number of parameters in the procedure's signature.
Returns:
=cut
my ($package, $proc_name, $params) = @_;
my $numparams = scalar @{$params};
if ( $package ) { $proc_name = $package . '.' . $proc_name; }
my $sql = 'BEGIN ' . $proc_name . '(';
for my $i ( 0 .. $numparams - 1 ) {
$sql .= ':p'.$i;
if ( $i < $numparams - 1 ) { $sql .= ','; }
}
$sql .= '); END;';
return $sql;
}
sub _db_sqlloaderx_parse_logfile {
=begin wiki
!3 _db_sqlloaderx_parse_logfile
Parameters: ( p1, p2, p3 )
Please write this documentation.
Returns:
=cut
my $logfile = shift;
%sqlloader_results = (); ## hash of SQL*Loader results
## default values
$sqlloader_results{'skipped'} = "Problem obtaining value";
$sqlloader_results{'read'} = $sqlloader_results{'skipped'};
$sqlloader_results{'rejected'} = $sqlloader_results{'skipped'};
$sqlloader_results{'discarded'} = $sqlloader_results{'skipped'};
$sqlloader_results{'elapsed_time'} = $sqlloader_results{'skipped'};
lib/DBIx/JCL.pm view on Meta::CPAN
% $truth = _is_yes( $truth );
% # later
% if ( $truth ) {
% # do something
% }
%%
=cut
my $str = shift;
if ( $str =~ /^y$|^yes$/i ) { return 1; }
return 0;
}
sub _is_no {
=begin wiki
!3 _is_no
Parameters: ( str )
Examing a string and determine if the string indicates 'NO'. The string is \
examined as case insensitive and must be either a 'n' or 'no' exactly. If so, \
the function returns true (1), otherwise it returns false (0).
Returns:
=cut
my $str = shift;
if ( $str =~ /^n$|^no$/i ) { return 1; }
return 0;
}
sub END {
=begin wiki
!3 END
Parameters: None
Close all open statement handles and database handles. Statement handles and \
Database handles are stored for us by the database connection function. The \
end function in each loaded plugin is also called here. They are called in \
reverse load order. Send exit notifications if any have been requested.
Returns:
=cut
## remove job information from sys_environment.conf
_sys_job_end();
## disconnect any open database handles
foreach my $vdn ( keys %dbhandles ) {
my $dbh = $dbhandles{$vdn}{'dbh'};
my $sth = $dbhandles{$vdn}{'sth'};
if ( defined $sth && $sth ) { $sth->finish; }
if ( defined $dbh && $dbh ) { $dbh->disconnect; }
}
## call plugin end functions
while ( my $pluginf = pop @plugins ) {
my ($pp, $pf, $pff) = split m/~/, $pluginf;
$pp->end();
}
## send completion notifications
unless ( defined $jobname ) { $jobname = '?'; }
my $msg = "Job $jobname ($script_file) has completed ($errorlevel).";
if ( $opt_notify_email_oncomp ) {
_log_send_mail($msg, 'MESSAGE' );
}
if ( $opt_notify_pager_oncomp ) {
_log_send_page($msg, 'MESSAGE' );
}
}
1;
=begin wiki
----
!1 Dependencies
The following modules are all used by DBIx-JCL.
* English
* Getopt::Long
* Config::IniFiles
* IO::File
* IO::Handle
* IO::LockedFile
* Fcntl
* File::Copy
* File::Bidirectional
* File::Basename
* MIME::Lite
* Date::Format
* Pod::WikiText
* DBI
----
!1 Incompatibilities
None currently documented. Please feel free to notify the author if you have \
concern that you would like to see addressed.
----
!1 Test Support
There are a number of test functions built-in to DBIx-JCL. Please see the \
function reference section for descriptions of all the testing functions.
----
!1 Tips
Here are some tips for using job scripts. (A job script is any perl script \
that uses the DBIx-JCL Module.
( run in 0.439 second using v1.01-cache-2.11-cpan-71847e10f99 )