Orac-alpha
view release on metacpan or search on metacpan
orac_dba.pl view on Meta::CPAN
if (($menu_line[0] eq 'command') ||
($menu_line[0] eq 'casc_command')){
if ($menu_line[1] ne '0'){
# The use of this has now been deprecated with the
# constant use of Toplevel windows. However,
# we may use it again in the future,
# therefore we'll leave it here.
#$menu_command = $menu_command . ' $main::this_button' .
# ' = ';
}
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::but_' .
$menu_line[3] .
' = $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";
}
if ($menu_line[0] eq 'add_cascade_button') {
$menu_command .= $main::current_db->add_cascade_button($menu_line[1]);
}
}
close(MENU_F);
# And if you think it was fun writing that stuff above,
# then you ain't coming to no parties of mine :)
# 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::tm_but[$main::tm_but_ct]->command(
-label=>$main::lg{dbish},
-command=>sub{
main::call_shell();
}
);
return;
}
=head2 Jareds_tools
Builds up the 'My Tools' options, where Orac users can specify their own
local SQL files to generate Orac-like reports.
=cut
sub Jareds_tools {
# Build up the 'My Tools' menu option.
if(!defined($main::jareds_tool)){
# Monster coming up. You'll cope.
my $comm_str =
' $main::jareds_tool = $main::mb->Menubutton( ' . "\n" .
' -text=>$main::lg{my_tools},' . "\n" .
' -menuitems=> ' . "\n" .
' [[Button=>$main::lg{help_with_tools},' .
' -command=>sub{main::bz();' . "\n" .
' $main::current_db->see_sql' .
'($main::mw,$main::current_db->gf_str(' .
'"$FindBin::RealBin/help/HelpTools.txt"),' .
'$main::lg{help_with_tools});' . "\n" .
' main::ubz()}], ' . "\n" .
' [Cascade=>$main::lg{config_tools},-menuitems => ' . "\n" .
' [[Button=>$main::lg{config_add_casc},' . "\n" .
' -command=>sub{' . "\n" .
' main::bz();' . "\n" .
' main::config_Jared_tools(1);' . "\n" .
orac_dba.pl view on Meta::CPAN
# 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 $@;
}
}
=head2 save_sql
Picks up the SQL the user has entered, and saves it into the appropriate file.
=cut
sub save_sql {
# Pick up the SQL the user has entered, and
# save it into the appropriate file
my($txt_ref, $filename) = @_;
my $dirname = File::Basename::dirname($filename);
my $basename = File::Basename::basename($filename);
$filename = File::Spec->catfile($dirname, $basename);
copy($filename,"${filename}.old");
open(SAV_SQL,">$filename");
print SAV_SQL $$txt_ref->get("1.0", "end");
close(SAV_SQL);
return $filename;
}
=head2 ed_butt
Allows configuration of 'My Tools' menus, buttons, cascades, etc. Tries
to make the setting up of new buttons, cascades etc, as painless as
possible.
=cut
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 = $main::orac_home.'/sql/tools/' . $casc . '.' . $butt . '.sql';
my $dirname = File::Basename::dirname($sql_file);
my $basename = File::Basename::basename($sql_file);
$sql_file = File::Spec->catfile($dirname, $basename);
my $window = $main::mw->Toplevel();
$window->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;
$window->Label( -textvariable => \$ed_sql_txt,
-anchor=>'n',
-relief=>'groove'
)->pack(-expand=>'no');
$window->{text} =
$window->Scrolled( 'Text',
-wrap=>'none',
-font=>$main::font{name},
-foreground=>$main::fc,
-background=>$main::bc
)->pack(-expand=>'yes',
-fill=>'both'
);
my(@lay) = qw/-side bottom -padx 5 -fill both -expand no/;
my $f = $window->Frame->pack(@lay);
$f->Button(
-text=>$main::lg{exit},
-command=>sub{ $window->destroy() }
)->pack(-side=>'right',
-anchor=>'e');
$f->Button(
-text => $main::lg{save},
-command =>
sub {
my $file_name = main::save_sql( \$window->{text},
$sql_file,
);
$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( $window );
if(open(SQL_SAV,$sql_file)){
while(<SQL_SAV>){
$window->{text}->insert("end", $_);
}
close(SQL_SAV);
}
}
=head2 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 apologies to those who may want to re-write this, and provide something
much neater.
=cut
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;
my $jt_config_file =
File::Spec->catfile($main::orac_home, 'config.tools');
if(open(JT_CONFIG, $jt_config_file )){
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);
}
orac_dba.pl view on Meta::CPAN
"\n";
} elsif($param == 99) {
print JT_CONFIG_APPEND $main_check .
'^' .
$loc_casc .
'^' .
$main_inp_value .
'^' .
$inp_text .
'^' .
"\n";
}
close(JT_CONFIG_APPEND);
my $sort1 =
File::Spec->catfile($main::orac_home, 'config.tools');
my $sort2 =
File::Spec->catfile($main::orac_home, 'config.tools.sort');
main::sort_this_file( $sort1,
$sort2,
);
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;
my $jt_config_file = File::Spec->catfile($main::orac_home,'config.tools');
if(open(JT_CONFIG, $jt_config_file )){
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++;
}
}
}
}
# Ok, Ok, this stuff is all horrible, but I ain't rewriting
# it. If you want to code improvements, please, please, please
# get in touch!!! :)
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'
);
orac_dba.pl view on Meta::CPAN
my ($balloon_ref, $font_button_ref) = @_;
my $font = $main::font{family} .
'-' .
$main::font{size} .
'-' .
$main::font{weight} .
'-' .
$main::font{slant};
my $message = $main::lg{font_sel} .
' (' .
$font .
')';
$$balloon_ref->attach($$font_button_ref, -msg => $message );
return $font;
}
sub splash_screen {
my($please_destroy_flag) = @_;
$main::splash_screen = MainWindow->new();
$main::splash_screen->overrideredirect(1);
my $splash_image =
$main::splash_screen->Photo(-file=>"$FindBin::RealBin/img/splash.gif");
Tk::wm($main::splash_screen, "geometry",
"+" .
int(($main::splash_screen->screenwidth)/2 -
($splash_image->width)/2) .
"+" .
int(($main::splash_screen->screenheight)/2 -
($splash_image->height)/2));
my $splash_label =
$main::splash_screen->Button( -image => $splash_image,
)->pack(-fill=>'both', -expand => 1);
Tk::update($main::splash_screen);
if($please_destroy_flag){
sleep 5;
main::destroy_splash();
}
}
sub destroy_splash {
if ($main::splash_screen) {
$main::splash_screen->destroy()
}
}
sub colour_menu {
my($file_mb_ref, $text, $col_ref) = @_;
$$file_mb_ref->cascade(-label=>$text);
my $col_men = $$file_mb_ref->cget(-menu);
my $colour_cols = $col_men->Menu;
# Now pick up all the lovely colours and build a radiobutton
$$file_mb_ref->entryconfigure($text,-menu=>$colour_cols);
open(COLOUR_FILE, "$FindBin::RealBin/txt/colours.txt");
while(<COLOUR_FILE>){
chomp;
eval {
$colour_cols->radiobutton(
-label=>$_,-background=>$_,
-command=>[ sub {main::bc_upd()}],
-variable=>$col_ref,
-value=>$_);
};
}
close(COLOUR_FILE);
}
# EOF
( run in 0.900 second using v1.01-cache-2.11-cpan-99c4e6809bf )