Orac
view release on metacpan or search on metacpan
orac_dba.pl view on Meta::CPAN
# for kevinb :)
# and now for thomasl too :)
$main::debug = exists($ENV{ORAC_DEBUG}) ? int($ENV{ORAC_DEBUG}) : 0;
$main::do_shell = exists( $ENV{DBI_SHELL} ) ? 1:0;
# Bring up the main "Worksheet" window
$main::mw = MainWindow->new();
# Start work on the menu, with the Orac badge,
# and then build up the menu buttons
my(@layout_mb) = qw/-side top -padx 5 -expand no -fill both/;
$main::mb = $main::mw->Frame->pack(@layout_mb);
my $orac_li = $main::mw->Photo(-file=>'img/orac.gif');
$main::conn_ball{green} = $main::mw->Photo( -file => "img/grn_ball.gif" );
$main::conn_ball{red} = $main::mw->Photo( -file => "img/red_ball.gif" );
$main::mb->Label(-image=>$orac_li,
-borderwidth=>2,
-relief=>'flat'
)->pack(-side=>'left',
-anchor=>'w');
# First of all, provide the only hard-coded menu that we
# do, for functions across all databases
my $file_mb = $main::mb->Menubutton(-text=>$main::lg{file},
)->pack(-side=>'left',
-padx=>2);
$file_mb->command(-label=>$main::lg{reconn},
-command=>sub{main::get_db()});
$file_mb->command(-label=>$main::lg{about_orac},
-command=>
sub{ main::bz();
$main::current_db->f_clr($main::v_clr);
$main::current_db->about_orac('README');
main::ubz()
}
);
$file_mb->command(-label=>$main::lg{menu_config},
-command=>
sub{ main::bz();
$main::current_db->f_clr($main::v_clr);
$main::current_db->about_orac('txt/menu_config.txt');
main::ubz()
}
);
$file_mb->separator();
# Build up the colour options, so
# a nice lemonchiffon is possible as a backdrop
$main::bc_txt = $main::lg{back_col_menu};
$file_mb->cascade(-label=>$main::bc_txt);
$main::bc_men = $file_mb->cget(-menu);
$main::bc_cols = $main::bc_men->Menu;
# Now pick up all the lovely colours and build a radiobutton
$file_mb->entryconfigure($main::bc_txt,-menu=>$main::bc_cols);
open(COLOUR_FILE, "txt/colours.txt");
while(<COLOUR_FILE>){
chomp;
eval {
$main::bc_cols->radiobutton(
-label=>$_,-background=>$_,
-command=>[ sub {main::bc_upd()}],
-variable=>\$main::bc,
-value=>$_);
};
}
close(COLOUR_FILE);
# Now give them the 'Exit Orac' option
$file_mb->separator();
$file_mb->command(-label=>$main::lg{exit},-command=>sub{main::back_orac()});
# Let them know the state of play, on connections
$main::l_top_t = $main::lg{not_conn};
$main::mb->Label(-textvariable => \$main::l_top_t,
-padx=>2,
-pady=>2,
)->pack(-side=>'right',
-anchor=>'e');
my $main_label = $main::mb->Label( -image => $main::conn_ball{red},
-padx=>2,
-pady=>2,
)->pack(-side=>'right',
-anchor=>'e');
(@layout_mb) = qw/-side top -expand yes -fill both/;
my $middle_box = $main::mw->Frame->pack(@layout_mb);
$main::v_text = $middle_box->Scrolled( 'Text',
-wrap=>'none',
-cursor=>undef,
-foreground=>$main::fc,
-background=>$main::bc
);
$main::v_text->pack(-expand=>1,-fil=>'both');
tie (*TEXT,'Tk::Text',$main::v_text);
# Sort out the options to clear the screen on
# each report
my $bb = $main::mw->Frame->pack(-side=>'bottom',
-padx=>5,
-expand=>'no',
-fill=>'both',
-anchor=>'s',
-before=>$middle_box);
orac_dba.pl view on Meta::CPAN
# A successful connection means we store the variable for later
# Pick up the standard DBA user for the particular database
($main::sys_user,$main::v_db) = get_dba_user($loc_db);
main::fill_defaults($loc_db, $main::sys_user, $main::bc, $main::v_db);
return $loc_db;
}
sub get_dba_user {
my($db) = @_;
my $dba_user;
my $new_db;
# Picks up the typical DBA user for the particular database
open(DB_FIL,'config/all_dbs.txt');
while(<DB_FIL>){
my @hold = split(/\^/, $_);
if ($db eq $hold[0]){
$dba_user = $hold[1];
$new_db = $hold[2];
}
}
close(DB_FIL);
return ($dba_user,$new_db);
}
sub get_db {
# Picks up database, and then configures menus accordingly
main::get_connected();
unless (defined($main::current_db)){
main::back_orac();
}
# Run the second initialisation routine
$main::current_db->init2( $main::dbh );
# Now sort out Jared's tools and configurable menus
if ($main::orac_orig_db ne $main::orac_curr_db_typ){
# We do this, if either we're into the program for the first time,
# or the user has changed the database type
main::del_Jareds_tools();
main::config_menu();
main::Jareds_tools();
$main::orac_orig_db = $main::orac_curr_db_typ;
}
}
sub bz {
# Make the main GUI pointer go busy
$main::mw->Busy;
}
sub ubz {
# Make the main GUI pointer normalise to unbusy
$main::mw->Unbusy;
}
sub get_Jared_sql {
# Takes pointers to which cascade and button the user
# wishes to run, and sucks SQL info out of the appropriate
# file, before returning as a Perl string variable
my($casc,$butt) = @_;
my $filename = 'tools/sql/' . $casc . '.' . $butt . '.sql';
my $cm = '';
open(JARED_FILE, "$filename");
while(<JARED_FILE>){
$cm = $cm . $_;
}
close(JARED_FILE);
return $cm;
}
sub mes {
# Produce the box that contains viewable Error
my $d = $_[0]->DialogBox();
my $t = $d->Scrolled( 'Text',
-cursor=>undef,
-foreground=>$main::fc,
-background=>$main::bc);
$t->pack(-expand=>1,-fil=>'both');
$t->insert('end', $_[1]);
$d->Show;
}
sub bc_upd {
# Change the background colour on all open windows.
# This is where all those text and window handles
# come in useful.
eval {
$main::v_text->configure(-background=>$main::bc);
};
my $comp_str = "";
my $i;
my $f;
foreach $f (keys(%main::swc))
{
if (defined($main::swc{$f})){
print STDERR "main swc f state >" . $main::swc{$f}->state . "< \n" if ($main::debug > 0);
my $comp_str = $main::swc{$f}->state;
if("$comp_str" ne 'withdrawn'){
eval {
$main::swc{$f}->{text}->configure(-background=>$main::bc);
}
}
}
}
}
sub read_language {
# Open up the main configurable
# language file, and pick up all
orac_dba.pl view on Meta::CPAN
' $main::tm_but_ct++; ' . "\n" .
' $main::tm_but[$main::tm_but_ct] = ' . "\n" .
' $main::mb->Menubutton(-text=>$main::lg{' .
$menu_line[1] . '},' . "\n" .
' )->pack(-side=>\'left\',-padx=>2); ' . "\n";
}
if (($menu_line[0] eq 'command') ||
($menu_line[0] eq 'casc_command')){
if ($menu_line[1] ne '0'){
$menu_command = $menu_command . ' $main::sub_win_but_hand{' .
$menu_line[1] . '} = ';
}
if ($menu_line[0] eq 'command'){
$menu_command =
$menu_command .
' $main::tm_but[$main::tm_but_ct]->command(-label=>$main::lg{' .
$menu_line[3] . '},' .
' -command=>sub{main::bz();';
} elsif ($menu_line[0] eq 'casc_command'){
$menu_command = $menu_command .
' $main::casc_item->command(-label=>$main::lg{' .
$menu_line[3] . '},' .
' -command=>sub{main::bz();';
}
if ($menu_line[2] == 1){
$menu_command = $menu_command .
' $main::current_db->f_clr($main::v_clr); ';
}
$menu_command = $menu_command . $menu_line[4] . '(';
if(defined($menu_line[5])){
# Now build the function's parameters we're going to run.
# (if any parameters exist)
my @func_line = split(/\+/, $menu_line[5]);
$func_line_ct = @func_line;
for ($i = 0;$i < $func_line_ct;$i++){
$menu_command = $menu_command . $func_line[$i];
if (($i + 1) < $func_line_ct){
$menu_command = $menu_command . ', ';
}
}
}
$menu_command = $menu_command . ');main::ubz()}); ' . "\n";
}
if ($menu_line[0] eq 'separator'){
$menu_command = $menu_command .
' $main::tm_but[$main::tm_but_ct]->separator(); ' .
"\n";
}
if ($menu_line[0] eq 'cascade'){
# Ok, it ain't pretty, but then are you first thing
# of a morning? :)
$menu_command =
$menu_command .
' $main::tm_but[$main::tm_but_ct]->cascade(-label=>$main::lg{' .
$menu_line[1] . '}); ' .
"\n" .
' $main::casc = $main::tm_but[$main::tm_but_ct]->cget(-menu); ' .
"\n" .
' $main::casc_item = $main::casc->Menu; ' .
"\n" .
' $main::tm_but[$main::tm_but_ct]->entryconfigure($main::lg{' .
$menu_line[1] .
'}, -menu => $main::casc_item); ' .
"\n";
}
}
close(MENU_F);
# Here we go! Slap up those menus.
print STDERR "config_menu: menu_command >\n$menu_command\n<\n"
if ($main::debug > 0);
eval $menu_command ; warn $@ if $@;
$main::tm_but_ct++;
$main::tm_but[$main::tm_but_ct] =
$main::mb->Menubutton(-text=>$main::lg{sql_menu},
)->pack(-side=>'left',
-padx=>2);
$main::sub_win_but_hand{quick_sql} =
$main::tm_but[$main::tm_but_ct]->command(
-label=>$main::lg{quick_sql},
-command=>sub{ main::bz();
orac_QuickSQL::quick_sql();
main::ubz()
}
);
$main::sub_win_but_hand{dbish} =
$main::tm_but[$main::tm_but_ct]->command(
-label=>$main::lg{dbish},
-command=>sub{ main::bz();
print STDERR "mw >$main::mw<, dbh >$main::dbh< \n" if ($main::debug > 0);
$main::shell = orac_Shell->new( $main::mw, $main::dbh );
$main::shell->dbish_open();
main::ubz()
}
);
return;
}
sub Jareds_tools {
# Build up the 'My Tools' menu option.
if(!defined($main::jt)){
# Monster coming up. You'll cope.
my $comm_str =
' $main::jt = $main::mb->Menubutton( ' . "\n" .
orac_dba.pl view on Meta::CPAN
my @jt_casc = split(/\^/, $_);
if ($jt_casc[0] eq 'C'){
$comm_str = $comm_str .
' [Cascade =>\'' .
$jt_casc[2] .
'\',-menuitems => [ ' . "\n";
open(JT_CASC_BUTTS,'tools/config.tools');
while(<JT_CASC_BUTTS>){
my @jt_casc_butts = split(/\^/, $_);
if (($jt_casc_butts[0] eq 'B') &&
($jt_casc_butts[1] eq $jt_casc[1])){
# Bit of a pig below, but you'll get through it
# if you have a quick lager
$comm_str =
$comm_str .
' [Button=>\'' .
$jt_casc_butts[3] .
'\',' .
'-command=>sub{main::bz(); ' .
'$main::current_db->f_clr($main::v_clr); ' .
"\n" .
' main::run_Jareds_tool(\'' .
$jt_casc[1] .
'\',\'' .
$jt_casc_butts[2] .
'\');main::ubz()}], ' . "\n";
}
}
close(JT_CASC_BUTTS);
$comm_str = $comm_str . ' ],], ' . "\n";
}
}
close(JT_CASC);
}
$comm_str = $comm_str .
' ])->pack(-side=>\'left\',-padx=>2) ; ';
eval $comm_str ; warn $@ if $@;
}
}
sub save_sql {
# Pick up the SQL the user has entered, and
# save it into the appropriate file
my($filename) = @_;
main::orac_copy($filename,"${filename}.old");
open(SAV_SQL,">$filename");
print SAV_SQL $main::swc{ed_butt_win}->{text}->get("1.0", "end");
close(SAV_SQL);
return $filename;
}
sub ed_butt {
# Allow configuration of 'My Tools' menus, buttons, cascades, etc
my($casc,$butt) = @_;
my $ed_fl_txt = main::get_butt_text($casc,$butt);
my $sql_file = 'tools/sql/' . $casc . '.' . $butt . '.sql';
$main::swc{ed_butt_win} = MainWindow->new();
$main::swc{ed_butt_win}->title( "$main::lg{cascade} $casc,
$main::lg{button} $butt");
my $ed_sql_txt = "$ed_fl_txt: $main::lg{ed_sql_txt}";
my $ed_sql_txt_cnt = 0;
$main::swc{ed_butt_win}->Label(
-textvariable => \$ed_sql_txt,
-anchor=>'n',
-relief=>'groove'
)->pack(-expand=>'no');
$main::swc{ed_butt_win}->{text} =
$main::swc{ed_butt_win}->Scrolled('Text',
-wrap=>'none',
-cursor=>undef,
-foreground=>$main::fc,
-background=>$main::bc
)->pack(-expand=>'yes',
-fill=>'both');
my(@lay) = qw/-side bottom -padx 5 -fill both -expand no/;
my $f = $main::swc{ed_butt_win}->Frame->pack(@lay);
$f->Button(
-text=>$main::lg{exit},
-command=>sub{ $main::swc{ed_butt_win}->withdraw() }
)->pack(-side=>'right',
-anchor=>'e');
$f->Button(
-text=>$main::lg{save},
-command=>
sub{ my $file_name = main::save_sql($sql_file, $ed_fl_txt);
$ed_sql_txt_cnt++;
$ed_sql_txt = "$ed_fl_txt: $file_name $main::lg{saved}" .
' #' .
$ed_sql_txt_cnt;
}
)->pack(-side=>'right',
-anchor=>'e');
$f->Label(-text=>$main::lg{no_semi_colon},
-relief=>'sunken'
)->pack(-side=>'left',
-anchor=>'w');
main::iconize($main::swc{ed_butt_win});
if(open(SQL_SAV,$sql_file)){
while(<SQL_SAV>){
$main::swc{ed_butt_win}->{text}->insert("end", $_);
}
close(SQL_SAV);
}
}
sub config_Jared_tools {
# More functionality required to allow on-the-fly configuration
# of the 'My Tools' options.
# This function is fairly overloaded, and may require some
# detailed analysis, before it becomes clearer what it's doing.
my($param,$loc_casc,$loc_butt) = @_;
my $main_check;
my $title;
my $action;
my $inp_text;
my $sec_check;
if(($param == 1)||($param == 99)||($param == 69)||($param == 49)){
$main_check = 'C';
$title = $main::lg{add_cascade};
my $main_field = 1;
my $main_inp_value;
my $add_text = $main::lg{casc_text};
$action = $main::lg{add};
if($param == 69){
$title = $main::lg{upd_cascade};
$action = $main::lg{upd};
} elsif($param == 49) {
$main_check = 'B';
$title = "$main::lg{cascade} $loc_casc, $main::lg{button}";
$add_text = $main::lg{upd_button};
$action = $main::lg{upd};
} elsif($param == 99) {
$main_field = 2;
$main_check = 'B';
$title = "$main::lg{cascade} $loc_casc: $main::lg{add_button}";
$add_text = $main::lg{butt_text};
}
if(($param == 69)||($param == 49)){
$main_inp_value = $loc_casc;
} else {
my @inp_value;
my $inp_count = 0;
if(open(JT_CONFIG,'tools/config.tools')){
while(<JT_CONFIG>){
my @hold = split(/\^/, $_);
# Jesus, I can't believe I wrote the 'if' statement
# below. If you can figure it out, can you let me know
# what it's doing? ;-)
if ((($param == 1) &&
($hold[0] eq $main_check)) ||
(($param == 99) &&
($hold[0] eq $main_check) &&
($hold[1] eq $loc_casc))) {
$inp_value[ $inp_count ] = $hold[ $main_field ];
$inp_count++;
}
}
close(JT_CONFIG);
}
if($inp_count > 0){
$inp_count--;
my $flag = 0;
my $flag2 = 0;
$main_inp_value = 1;
while($flag == 0){
my $i;
$flag2 = 0;
for ($i = 0;$i <= $inp_count;$i++){
if($main_inp_value == $inp_value[$i]){
$main_inp_value++;
$flag2 = 1;
last;
}
}
if ($flag2 == 0){
$flag = 1;
}
}
} else {
$main_inp_value = 1;
}
$main_inp_value = sprintf("%03d", $main_inp_value);
}
# Now get to main dialogue and pick up the reqd. info
my $d = $main::mw->DialogBox(-title=>"$title $main_inp_value",
-buttons=>[ $action,
orac_dba.pl view on Meta::CPAN
if($param == 1){
print JT_CONFIG_APPEND $main_check .
'^' .
$main_inp_value .
'^' .
$inp_text .
'^' .
"\n";
} elsif($param == 99) {
print JT_CONFIG_APPEND $main_check .
'^' .
$loc_casc .
'^' .
$main_inp_value .
'^' .
$inp_text .
'^' .
"\n";
}
close(JT_CONFIG_APPEND);
main::sort_Jareds_file();
if($param == 99){
main::ed_butt($loc_casc,$main_inp_value);
}
}
} else {
main::mes($d,$main::lg{no_val_def});
if($param == 69){
return (0,$inp_text);
}
}
}
} elsif(($param == 2)||
($param == 3)||
($param == 4)||
($param == 5)||
($param == 6)||
($param == 7)||
($param == 59)||
($param == 79)||
($param == 89)){
my $d_inp;
my $b_d;
my $tl;
my $l;
my @casc1;
my @casc2;
my $d;
my $message;
$main_check = 'C';
my $del_text = $main::lg{casc_text};
if($param == 2){
$title = $main::lg{del_cascade};
$action = $main::lg{del};
$message = $main::lg{del_message};
} elsif($param == 3) {
$title = $main::lg{add_button};
$action = $main::lg{next};
$message = $main::lg{add_butt_mess};
} elsif($param == 4) {
$title = $main::lg{del_button};
$action = $main::lg{next};
$message = $main::lg{del_butt_mess};
} elsif($param == 5) {
$title = $main::lg{config_edit_sql};
$action = $main::lg{next};
$message = $main::lg{ed_sql_mess};
} elsif($param == 6){
$title = $main::lg{config_edit_casc};
$action = $main::lg{next};
$message = $main::lg{choose_casc};
} elsif($param == 7){
$sec_check = 'B';
$title = $main::lg{config_edit_butt};
$action = $main::lg{next};
$message = $main::lg{choose_casc};
} elsif($param == 59) {
$main_check = 'B';
$title = $main::lg{config_edit_butt};
$action = $main::lg{next};
$message = "$main::lg{cascade} $loc_casc: $main::lg{choose_butt}";
$del_text = $main::lg{choose_butt};
} elsif($param == 79) {
$main_check = 'B';
$title = $main::lg{config_edit_sql};
$action = $main::lg{next};
$message = $main::lg{ed_sql_mess2};
} elsif($param == 89) {
$main_check = 'B';
$title = $main::lg{del_button};
$action = $main::lg{del};
$message = "$main::lg{cascade} $loc_casc: $main::lg{del_butt_mess2}";
$del_text = $main::lg{del_butt_text};
}
my $i_count = 0;
if(open(JT_CONFIG,'tools/config.tools')){
while(<JT_CONFIG>){
my @hold = split(/\^/, $_);
if(($param != 89) &&
($param != 79) &&
($param != 59)){
if ($hold[0] eq $main_check){
$casc1[$i_count] = sprintf("%03d",$hold[1]) . ":$hold[2]";
$i_count++;
}
} else {
if (($hold[0] eq $main_check) &&
($hold[1] eq $loc_casc)){
$casc1[$i_count] = sprintf("%03d",$hold[2]) . ":$hold[3]";
$i_count++;
}
}
}
}
if ($i_count > 0){
@casc2 = sort @casc1;
$i_count = 0;
my $t_l;
foreach(@casc2){
if($i_count == 0){
$d = $main::mw->DialogBox(-title=>$title,
-buttons=>[ $action,
$main::lg{cancel} ]
);
$t_l = $d->Label(-text=>$message,
-anchor=>'n'
)->pack(-side=>'top');
$l = $d->Label(-text=>$del_text . ':',
-anchor=>'e',
-justify=>'right'
);
$d_inp = $casc2[$i_count];
$b_d = $d->BrowseEntry( -cursor=>undef,
-variable=>\$d_inp,
-foreground=>$main::fc,
-background=>$main::ec,
( run in 0.666 second using v1.01-cache-2.11-cpan-788537b7465 )