view release on metacpan or  search on metacpan

lib/Tk/TM/wgMenu.pm  view on Meta::CPAN

#!perl -w
#
# Tk Transaction Manager.
# Menu & Toolbar - Set of data objects.
#
# makarow, demed
#

package Tk::TM::wgMenu;
require 5.000;
use strict;
use Tk;
use Tk::TM::Common;
use Tk::TM::Lang;
use Tk::TM::DataObjSet;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
$VERSION = '0.53';
@ISA = ('Tk::Frame','Tk::TM::DataObjSet');

Tk::Widget->Construct('tmMenu'); 


sub Populate {
 my ($self, $args) = @_;
 my $mw =$self->parent;

 print "Populate0(",join(', ',map {defined($_) ? $_ : 'null'} @_),")\n" if $Tk::TM::Common::Debug;
 $self->Tk::TM::DataObjSet::initialize();
 foreach my $opt ($self->set()) {
   if (exists($args->{$opt})) {
      $self->set($opt=>$args->{$opt});
      delete($args->{$opt})
   }
 }
 $self->ConfigSpecs(-font=>['DESCENDANTS']);
 $self->ConfigSpecs(-relief=>['CHILDREN']);

 print "Populate1(",keys(%$args),")\n" if $Tk::TM::Common::Debug;

 my $mt  =Tk::TM::Lang::txtMenu();
 my @mnu =( [$$mt[0], 'f' .substr($$mt[0],0,1)
            ,[$$mt[1],'',-accelerator=>'Shift+F2',-command=>sub{$self->Save()}]
            ,[$$mt[2],'',-accelerator=>'F5',-command=>sub{$self->Reread()}]
            ,['separator']
            ,[$$mt[3],'',-accelerator=>'Ctrl+P',-command=>sub{$self->Print()}]
            ,[$$mt[4],'',-command=>sub{$self->Export()}]
            ,[$$mt[5],'',-command=>sub{$self->Import()}]
            ,['separator']
            ,[$$mt[6],'',-accelerator=>'Alt+F4',-command=>sub{$self->toplevel->destroy}]
            ,[$$mt[7],'',-accelerator=>'Shift+F3',-command=>sub{Tk::exit}]
            ]
           ,[$$mt[8], 'e' .substr($$mt[8],0,1)
            ,[$$mt[ 9],'',-accelerator=>'Ctrl+N',-command=>sub{$self->RowNew()}]
            ,[$$mt[10],'',-accelerator=>'Ctrl+Y',-command=>sub{$self->RowDel()}]
            ,[$$mt[11],'',-command=>sub{$self->RowUndo()}]
            ,['separator']
            ,[$$mt[12],'',-accelerator=>'F4',-command=>sub{$self->FldHelp()}]
            ,['separator']
         #  ,[$$mt[13],'',-command=>sub{$mw->focusCurrent->undo}]
            ,[$$mt[14],'',-accelerator=>'Shift+Del',-command=>sub{$mw->focusCurrent->clipboardCut}]
            ,[$$mt[15],'',-accelerator=>'Ctrl+Ins',-command=>sub{$mw->focusCurrent->clipboardCopy}]
            ,[$$mt[16],'',-accelerator=>'Shift+Ins',-command=>sub{$mw->focusCurrent->clipboardPaste}]
            ,[$$mt[17],'',-accelerator=>'Ctrl+Del',-command=>sub{$mw->focusCurrent->clipboardClear}]
         #  ,[$$mt[18],'',-command=>sub{$mw->focusCurrent->selectAll}]
            ]
           ,[$$mt[19], 'a' .substr($$mt[19],0,1)]
           ,[$$mt[20], 's' .substr($$mt[20],0,1)
            ,[$$mt[21],'',-command=>sub{$self->Retrieve()}]
            ,[$$mt[22],'',-accelerator=>'F5',-command=>sub{$self->Reread()}]
            ,[$$mt[23],'',-command=>sub{$self->Clear()}]
            ,[$$mt[24],'',-command=>sub{$self->DBICnd()}]
            ,['separator']
            ,[$$mt[25],'',-accelerator=>'Ctrl+F',-command=>sub{$self->Find()}]
            ,[$$mt[26],'',-accelerator=>'Ctrl+G',-command=>sub{$self->FindNxt()}]
            ,['separator']
            ,[$$mt[27],'',-accelerator=>'Ctrl+Home',-command=>sub{$self->RowGo('top')}]
            ,[$$mt[28],'',-accelerator=>'PageUp',-command=>sub{$self->RowGo('pgup')}]
            ,[$$mt[29],'',-accelerator=>'PageDown',-command=>sub{$self->RowGo('pgdn')}]
            ,[$$mt[30],'',-accelerator=>'Ctrl+End',-command=>sub{$self->RowGo('bot')}]
            ]
           ,[$$mt[31], 'h' .substr($$mt[31],0,1)
            ,[$$mt[32],'',-accelerator=>'F1',-command=>sub{$self->Help()}]
            ,[$$mt[33],'',-command=>sub{$self->Help('about')}]
            ]);

 my %bo=(-takefocus=>0,-relief=>'groove');
 my %bf=();
 my $bc;

 if    ($self->{-mdnav}) {
       $self->{-mdmnu}='';
       $bo{-takefocus}=1;
 }
 elsif ($self->{-mdmnu}=~/bar/i) { 
       $self->{'wmBar'} =$self->MenuBarCreate(@mnu);
 }
 elsif ($self->{-mdmnu}=~/button/i) {
       $self->{'wmBar'} =$self->MenuButCreate(@mnu);
       $mt =$self->{'wmBar'}->[0];
       %bf=(-t=>$mt);
 }
 else {
       $bo{-takefocus}=1;
 }

 if ($self->{-mdtbr}) {
 if (!$self->{-mdnav}) {
    $bc =$self->{'wbSave'}      =$self->Button(-text=>'S' ,%bo,-command=>sub{$self->Save()})->form(%bf);
    $bc =$self->{'wbReread'}    =$self->Button(-text=>'<>',%bo,-command=>sub{$self->Reread()})->form(-l=>$bc,%bf);
    $bc =$self->{'wbRowNew'}    =$self->Button(-text=>'+' ,%bo,-command=>sub{$self->RowNew()})->form(-l=>$bc,-lp=>3,%bf);
    $bc =$self->{'wbRowDel'}    =$self->Button(-text=>'-' ,%bo,-command=>sub{$self->RowDel()})->form(-l=>$bc,%bf);
    if (!$self->{-mdmnu}) {
        $bc =$self->{'wbActions'}=$self->Button(-text=>'..',%bo)->form(-l=>$bc,-lp=>3,%bf);
        my $m =$bc->Menu(-type=>'normal',-tearoff=>0); my $b =$bc;
        $bc->configure(-command=>sub{$m->post($b->rootx,$b->rooty +$b->height)});
    }
    $bc =$self->{'wbQuery'}     =$self->Button(-text=>'Q' ,%bo,-command=>sub{$self->Retrieve()})->form(-l=>$bc,-lp=>3,%bf);
    $bc =$self->{'wbClear'}     =$self->Button(-text=>'C' ,%bo,-command=>sub{$self->Clear()})->form(-l=>$bc,%bf);
 }
    $bc =$self->{'wbFind'}      =$self->Button(-text=>'F' ,%bo,-command=>sub{$self->Find()})->form(%bf, $self->{-mdnav} ?() :(-l=>$bc,-lp=>2));
    $bc =$self->{'wbRowGoTop'}  =$self->Button(-text=>'<<',%bo,-command=>sub{$self->RowGo('top')})->form(-l=>$bc,%bf);
    $bc =$self->{'wbRowGoPrev'} =$self->Button(-text=>'<' ,%bo,-command=>sub{$self->RowGo('pgup')})->form(-l=>$bc,%bf);
    $bc =$self->{'wbRowGoNext'} =$self->Button(-text=>'>' ,%bo,-command=>sub{$self->RowGo('pgdn')})->form(-l=>$bc,%bf);