vptk_w
view release on metacpan or search on metacpan
use Tk::FileSelect;
use Tk::Tiler;
use Tk::ROText;
use Tk::Dialog;
use Tk::Pane;
use IPC::Open3;
use Data::Dumper;
# editor-related modules:
use vptk_w::ConfigRead;
use vptk_w::EditorServices;
use vptk_w::VPTK_Widget;
use vptk_w::Project;
use vptk_w::Project::Options;
use vptk_w::Project::Widgets;
use vptk_w::Project::Code;
if (grep /^--?h/,@ARGV)
{
# this works for real perl script only!
# does not work on M$ Win EXE-file
system "perldoc $0";
exit 1;
}
my $VERSION;
$VERSION = q$Revision: 2.42 $;
my $selected; # Currently selected widget path
my %widgets=(); # Displayed Tk visual objects (widgets)
my $changes; # Modifications flag
my $view_repaint = 0; # 'Just repainted' flag
my $lastfile=''; # last file used in Open/Save
my %descriptor=(); # Mapping id->descriptor
my @tree=('mw'); # design tree list ('.' separated entry)
my $obj_count=0; # counter for unique object id
my @undo=(); # Undo buffer
my @redo=(); # Redo buffer
my %cnf_dlg_balloon; # Help messages for all widget configuration options
my $Project = vptk_w::Project->new();
my $pOpt = vptk_w::Project::Options->new();
my @main_clipboard=();
my @user_auto_vars;
my @callbacks;
my @user_subs;
my @project_bindings;
# Structure of project_bindings:
# ['widget_id'=>'event name'=>'callback'], ...
my $wProjOptionsHintMsg;
my %IDE_settings;
my %Project_defaults;
my $balloon_bg_color;
my $balloon_delay;
my @AllWidgetsNames = AllWidgetsNames();
# Legal parameters per geometry:
my (%w_geom) = (
'pack' => [qw/-side -fill -expand -anchor -ipadx -ipady -padx -pady/],
'grid' => [qw/-row -column -rowspan -columnspan -sticky -ipadx -ipady -padx -pady/],
'place' => [qw/-anchor -height -width -x -y -relheight -relwidth -relx -rely/]
);
my @OrdinaryWidgets = (grep(HaveGeometry($_),sort @AllWidgetsNames),'packAdjust');
# (excluded widgets without geometry)
my @wrapped_icons = map(WidgetIconName($_),@AllWidgetsNames);
#
# ======================== Geometry management for Main window ================
#
my $mw = MainWindow->new(-title=>"Visual Perl Tk $VERSION (widget edition)");
&ResetIDE_SettingsToDefaults();
# Prepare help from HTML file:
# 1. read HTML file
my (@html_help)=(&ReadHTML("$toolbar/widget_help.html"));
@html_help = 'Sorry, help file is not available!' unless $html_help[0];
my (@html_tutorial)=(&ReadHTML("$toolbar/tutorial.html"));
@html_tutorial = 'Sorry, tutorial file is not available!' unless $html_tutorial[0];
# 2. get gif-files list
my @html_gifs=grep(/^gif/,@html_help,@html_tutorial);
map s/^\S+\s+//,@html_gifs;
# 3. create bold font:
$mw->fontCreate('C_bold',qw/-family courier -weight bold/);
# read in all pictures:
foreach (sort(qw/open save new before after subwidget balloon run
undo redo viewcode properties delete exit cut copy paste bind callback
justify_right justify_left justify_center
undef fill_both fill_x fill_y
rel_flat rel_groove rel_raised rel_ridge rel_solid rel_sunken
anchor_center anchor_e anchor_n anchor_ne anchor_nw anchor_s anchor_se anchor_sw anchor_w
side_bottom side_left side_right side_top/,
@html_gifs,@wrapped_icons))
{
my $pic_file="$toolbar/$_.gif";
$pic_file = "$toolbar/$_.xpm" unless -e $pic_file;
unless (-e $pic_file) {
warn "no file $pic_file"; next;
}
$pic{$_} = $mw->Photo(-file=>$pic_file)
unless defined $pic{$_};
}
# Read balloon messages:
%cnf_dlg_balloon = &ReadCnfDlgBalloon("$toolbar/balloon_cnf_dlg.txt");
my $xy; # X=nnn Y=nnn indicator
# +-------------------------------+
# | menu ... |
# +-------------------------------+
# | tool bar |
# +------+------------------------+
# | | |
# | tree | |
# | area | drawing |
# | | area |
# | | |
# | | |
# |______|________________________|
# -----------------
# conflict No 1 - remove Label from Frame with grid sub-widgets
# (since geometry manager gets mad in such situation)
# for each frame widget
# get all children id's
# get those geometry
# remove -label if at least one match 'grid'
foreach my $elm(@tree)
{
my ($id) = ($elm=~/\.([^\.]+)$/);
next unless $descriptor{$id}->{'type'} eq 'Frame';
my (@children)=grep(/\.$id\.([^\.]+)$/,@tree);
next unless @children;
map {s/.*\.//} @children;
map {$_=$descriptor{$_}->{'geom'}} @children;
if ( grep (/grid/,@children) )
{
my (%opt)=&split_opt($descriptor{$id}->{'opt'});
if ($opt{'-label'})
{
delete $opt{'-label'};
$descriptor{$id}->{'opt'} = join(', ',%opt);
}
}
}
# @par conflict No 2 - for grid-based widgets calculate position
# and move interlaced element downward
# for each widget:
# - get list of children
# - if 1st child have 'grid' geometry
# - prepare matrix of placement
# - foreach child:
# - re-calculate (xmax,ymax)
# - try to store in matrix
# - if this cell already "in use" - push it into "conflicts" list
# - foreach element in "conflicts" list:
# - place it into free space under ymax row
foreach my $elm(@tree)
{
my ($id) = ($elm=~/\.([^\.]+)$/);
my (@children)=grep(/\.$id\.([^\.]+)$/,@tree);
if($elm eq 'mw') {
@children = grep(/^mw.([^\.]+)$/,@tree);
}
next if scalar(@children) < 2; # need at least 2 for conflict!
map {s/.*\.//} @children;
next unless grep ($descriptor{$_}->{'geom'}=~/grid/,@children);
# here we've list of widgets with 'grid' geometry
# 1. For each element:
# 1.1. calculate (xmax,ymax) using current element (x,y)
# 1.2. check, does this cell free or not
# 1.3. if conflict - store it's id in '@conflicts' list
# 2. For each element in '@conflicts' list
# 2.1. correct element's (x,y) using 'safe' space after (xmax/ymax)
my ($x,$y,$xmax,$ymax);
my @conflicts;
my @matrix;
$xmax = $ymax = -1;
foreach (@children) {
($x) = $descriptor{$_}->{'geom'} =~ /-column\W+(\d+)/; # prevented matching -columnspan
$x = '0' unless $x;
$xmax = $x if $x > $xmax;
($y) = $descriptor{$_}->{'geom'} =~ /-row\W+(\d+)/; # prevented matching -rowspan
$y = '0' unless $y;
$ymax = $y if $y > $ymax;
if($matrix[$y][$x]) { push(@conflicts,$_); }
else { $matrix[$y][$x]=$_; }
}
$x = 0; $ymax++;
foreach (@conflicts) {
$descriptor{$_}->{'geom'} =~ s/(-column)\D+\d+/$1=>$x/; $x++;
$descriptor{$_}->{'geom'} =~ s/(-row)\D+\d+/$1=>$ymax/;
if($x > $xmax) {
$x = 0; $ymax++;
}
}
if(@conflicts) {
# inform user about fix:
&ShowDialog(-title=>"Geometry conflicts!",-bitmap=>'info',-buttons=>['Continue'],
-text=>join("\n",'Grid cell conflicts resolved for following widgets:',@conflicts));
}
}
&view_repaint;
}
}
# "Application close" callback
sub abandon
{
return unless &check_changes;
exit;
}
# Make sure that changes of current project are saved
# Return result indicating success of save procedure
sub check_changes
{
if($changes)
{
# ask for save
my $reply=&ShowDialog(-bitmap=>'question',
-text=>"File not saved!\nDo you want to save the changes?",
-title => "You have some changes",
-buttons => ['Save','Don\'t save', 'Cancel']);
if($reply eq 'Save')
{
$reply=&file_save('Save As');
}
return 0 if($reply eq 'Cancel');
}
return 1; # Ok
}
# Open "file save" dialog box (when needed) and perform save operation.
# return 0 on success and error code otherwise.
# bug: 'Save' does not always save. But 'Save As' works.
sub file_save
{
# pack options:
{
&cnf_dlg_balloon($bl,$g_pack->Label(-text=>'-side',-justify=>'left')->
grid(-row=>0,-column=>0,-sticky=>'w',-padx=>8),'-side');
&SideMenu($g_pack,\$g_val{'-side'},$bl)->grid(-row=>0,-column=>1,-pady=>4);
}
{
&cnf_dlg_balloon($bl,$g_pack->Label(-text=>'-anchor',-justify=>'left')->
grid(-row=>1,-column=>0,-sticky=>'w',-padx=>8),'-anchor');
&AnchorMenu($g_pack,\$g_val{'-anchor'},$bl)->grid(-row=>1,-column=>1,-pady=>4);
}
{
&cnf_dlg_balloon($bl,$g_pack->Label(-text=>'-fill',-justify=>'left')->
grid(-row=>2,-column=>0,-sticky=>'w',-padx=>8),'-fill');
my $mnb = $g_pack->Menubutton(-direction=>'below')->grid(-row=>2,-column=>1,-pady=>4);
&cnf_dlg_balloon($bl,$mnb,'-fill');
my $mnu = $mnb->menu(qw/-tearoff 0/); $mnb->configure(-menu => $mnu);
foreach my $r('','x','y','both')
{
$mnu->command(-label=>$r,-image=>map_pic('fill',$r),-columnbreak=>($r eq 'x'),
-command=>sub{$g_val{'-fill'}=$r;$mnb->configure(-image=>map_pic('fill',$r))});
$mnb->configure(-image=>map_pic('fill',$r)) if($r eq $g_val{'-fill'});
}
}
{
&cnf_dlg_balloon($bl,$g_pack->Label(-text=>'-expand',-justify=>'left')->
grid(-row=>3,-column=>0,-sticky=>'w',-padx=>8),'-expand');
&cnf_dlg_balloon($bl,$g_pack->
Button(-textvariable=>\$g_val{'-expand'},-relief=>'flat',-command=>
sub{$g_val{'-expand'}=1-$g_val{'-expand'}})->grid(-row=>3,-column=>1,-pady=>4),'-expand');
}
my $i=0;
foreach my $k(qw/-ipadx -ipady -padx -pady/)
{
$i++;
&cnf_dlg_balloon($bl,$g_pack->Label(-text=>$k,-justify=>'left')->
grid(-row=>3+$i,-column=>0,-sticky=>'w',-padx=>8),$k);
my $f=$g_pack->Frame()->grid(-row=>3+$i,-column=>1,-pady=>4);
&cnf_dlg_balloon($bl,$f,$k);
&NumEntry($f,-textvariable=>\$g_val{$k},-width=>4,
-minvalue=>0)->pack(-side=>'right');
}
# geometry: grid
{
&cnf_dlg_balloon($bl,$g_grid->Label(-text=>'-sticky',-justify=>'left')->
grid(-row=>0,-column=>0,-sticky=>'w',-padx=>8),'-sticky');
my $f=$g_grid->Frame()->grid(-row=>0,-column=>1,-pady=>4);
&cnf_dlg_balloon($bl,$f,'-sticky');
my %st;
foreach my $s (qw/n s e w/)
{
$st{$s}=grep(/$s/,$g_val{'-sticky'});
$f->Checkbutton(-text=>$s,-variable=>\$st{$s},
-command => sub{$g_val{'-sticky'}=~s/$s//g;$g_val{'-sticky'}.=$s if $st{$s}})
->pack(-side=>'left');
}
}
my $i=1;
foreach my $k(qw/-column -row -columnspan -rowspan -ipadx -ipady -padx -pady/)
{
&cnf_dlg_balloon($bl,$g_grid->Label(-text=>$k,-justify=>'left')->
grid(-row=>$i,-column=>0,-sticky=>'w',-padx=>8),$k);
my $f=$g_grid->Frame()->grid(-row=>$i,-column=>1,-pady=>4);
&cnf_dlg_balloon($bl,$f,$k);
&NumEntry($f,-textvariable=>\$g_val{$k},-width=>4,
-minvalue=>($k=~/(-column|-row)$/)?0:1)->pack(-side=>'right');
$i++;
}
# geometry: place
my $i=0;
foreach my $k(qw/-height -width -x -y -relheight -relwidth -relx -rely/)
{
&cnf_dlg_balloon($bl,$g_place->Label(-text=>$k,-justify=>'left')->
grid(-row=>$i,-column=>0,-sticky=>'w',-padx=>8),$k);
my $f=$g_place->Frame()->grid(-row=>$i,-column=>1,-pady=>4);
&cnf_dlg_balloon($bl,$f,$k);
&NumEntry($f,-textvariable=>\$g_val{$k},-width=>4,
-minvalue=>0)->pack(-side=>'right');
$i++;
}
$n->raise($geom_type);
}
# bind balloon message + help on click
$bl->bind('<Enter>',
sub{$bl->configure(-text=>"Click here to get help about current widget\n".
"by perldoc utility.\n\n".
($n?"Right-click here for current geometry manager help":''))});
$bl->bind('<Leave>',
sub{$bl->configure(-text=>'')});
$bl->bind('<1>',[\&tkpod,$id]);
$bl->bind('<3>',sub{&tkpod($n->raised())}) if $n;
$db->resizable(0,0);
&Coloring($db);
my $reply=$db->Show();
return if($reply eq 'Cancel');
if (keys %$pr)
{
$val{'-labelPack'}="[-side=>'$lpack{'-side'}',-anchor=>'$lpack{'-anchor'}']"
if %lpack;
}
if ($d->{'geom'})
{
$geom_type=$n->raised();
# check for geometry conflicts here:
# find all 'brothers' for current widget
(@brothers)=grep($descriptor{$_}->{'type'} !~ /packAdjust|Menu/,&tree_get_brothers($id));
# get their geometry
map ( $_=$descriptor{$_}->{'geom'} ,@brothers);
# if any of brothers does not match:
# Ask user about possible conflict solution
# 'Propagate' | 'Adopt' | 'Back' | 'Cancel'
# go to start on 'Back'
# return on 'Cancel'
# otherwise - fix geometry respectively after 'undo_save'
if (grep(!/^$geom_type/,@brothers))
{
( run in 0.642 second using v1.01-cache-2.11-cpan-d7f47b0818f )