vptk_w
view release on metacpan or search on metacpan
$os = 'win' if $^O =~ /win/i;
$os = 'unix' if $^O =~ /linux|unix|aix|sun|solaris|cygwin/i;
# we treat cygwin-X environment as "Unix-like"
}
use strict;
use Tk 800;
use Tk::DialogBox;
use Tk::Photo;
use Tk::Checkbutton;
use Tk::Balloon;
use Tk::Adjuster;
use Tk::LabFrame;
use Tk::LabEntry;
use Tk::BrowseEntry;
use Tk::NoteBook;
use Tk::HList;
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{$_};
}
],
[Button => 'Perl/Tk ~status', -command => [\&ShowStatusMessage]],
[Button => '~About', -command => [\&ShowAboutMessage,$VERSION]],
])->pack(-side=>'right');
# pop-up menu on right button
my $popup=$mw->Menu(-tearoff=>0);
my $popup_insert=$popup->Menu(-tearoff=>0);
$popup_insert->add('command',-label=>'Before',-underline=>0,-command=>[\&insert,'before']);
$popup_insert->add('command',-label=>'After',-underline=>0,-command=>[\&insert,'after']);
$popup_insert->add('command',-label=>'Subwidget',-underline=>0,-command=>[\&insert,'subwidget']);
$popup->add('cascade',-label=>'Insert',-underline=>0,-menu=>$popup_insert);
$popup->add('command',-label=>'Properties',-underline=>0,-command=>\&edit_properties);
$popup->add('command',-label=>'Balloons',-underline=>0,-command=>\&edit_balloon);
$popup->add('command',-label=>'Context help',-underline=>8,-command=>\&tkpod);
$popup->add('command',-label=>'Cut',-underline=>0,-command=>\&edit_cut,-accelerator => 'Control+x');
$popup->add('command',-label=>'Copy',-underline=>1,-command=>\&edit_copy,-accelerator => 'Control+c');
$popup->add('command',-label=>'Paste before sel',-underline=>1,-command=>\&edit_paste,-accelerator => 'Control+v');
$popup->add('command',-label=>'Paste after sel',-underline=>3,-command=>[\&edit_paste,'after']);
$popup->add('command',-label=>'Paste under sel',-underline=>6,-command=>[\&edit_paste,'under']);
$popup->add('command',-label=>'Rename',-underline=>0,-command=>\&rename);
$popup->add('command',-label=>'Delete',-underline=>0,-command=>\&edit_delete,-accelerator => 'Delete');
my $bf=$mw->Frame()->
form(-top=>$menubar,-left=>'%0',-right=>'%100',-bottom=>'%100');
# ===============
# 'buttons' frame
# ===============
my $ctrl_frame=$bf->Frame()->pack(-side=>'top',-anchor=>'nw');
my $main_frame=$bf->Frame()
->pack(-side=>'top',-anchor=>'ne',-fill=>'both',-expand=>1);
my $status_frame=$bf->Frame(-relief=>'groove')
->pack(-side=>'top',-anchor=>'nw',-fill=>'x');
my $status=$status_frame->Label(-text=>'No selection',-relief=>'sunken',-borderwidth=>2)
->pack(-side=>'left');
my $changes_l=$status_frame->Label(-text=>' ',-relief=>'sunken',-borderwidth=>2)
->pack(-side=>'right');
$status_frame->Label(-textvariable=>\$xy,-relief=>'sunken',-borderwidth=>2,-width=>11)
->pack(-side=>'right',-padx=>10);
&changes(0);
# ==========
# ctrl_frame
# ==========
$b=$mw->Balloon();
my @buttons =
(
['new', \&file_new, 'New project'],
['open', \&file_open, 'Open file'],
['save', \&file_save, 'Save current file'],
[],
['before', [\&insert,'before'], 'Insert new widget before'],
['after', [\&insert,'after'], 'Insert new widget after'],
['subwidget',[\&insert,'subwidget'],'Insert new subwidget'],
[],
['undo', \&undo, 'Undo last change'],
['redo', \&redo, 'Redo last change'],
[],
['delete', \&edit_delete, 'Erase selected'],
['cut', \&edit_cut, 'Cut selected tree to clipboard'],
['copy', \&edit_copy, 'Copy selected tree to clipboard'],
['paste', \&edit_paste, 'Paste from clipboard before selected'],
['properties',\&edit_properties, 'View & edit properties'],
[],
['balloon', \&edit_balloon, 'Edit widget\'s balloon'],
['bind', \&edit_bindings, 'Edit widget\'s binding(s)'],
['callback', [\&file_properties,'callbacks'], 'Edit callbacks'],
[],
['viewcode', sub{&CodePreview(&code_print)}, 'Preview generated code'],
['run', \&debug_run, 'Run generated program'],
[],
['exit', \&abandon, 'Exit program'],
);
foreach my $button(@buttons)
{
if(@$button)
{
$b->attach(
$ctrl_frame->Button(-image=>$pic{$button->[0]}, -command=>$button->[1])->pack(-side=>'left',-expand=>1),
-balloonmsg=>$button->[2]);
}
else
{
$ctrl_frame->Label(-text=>' ')->pack(-side=>'left',-expand=>1);
}
}
my $tf=$main_frame->Scrolled('HList', -scrollbars=>'se',-itemtype=>'imagetext')
->pack(-side=>'left',-fill=>'y');
$tf->bind('<Button-1>',
sub{ my $s=$tf->infoSelection; &set_selected($tf->info('data',$s))if $s; } );
$tf->configure(
-command => sub{&set_selected($tf->info('data',$tf->infoSelection));&edit_properties},
-browsecmd=> sub{&set_selected($tf->info('data',$tf->infoSelection));} );
$tf->add('mw',-text=>'mw',-data=>'mw',-image=>WidgetIcon('Frame'));
my $w;
$tf->packAdjust(-side=>'left');
$tf->bind('<Button-3>',
sub{ &set_selected($tf->nearest($tf->pointery-$tf->rooty)); $popup->Post($mw->pointerxy)});
my %EditorBindings =
(
'<Control-o>' => \&file_open,
'<Control-s>' => \&file_save,
'<Control-n>' => \&file_new,
'<Control-z>' => \&undo,
'<Control-r>' => \&redo,
'<Delete>' => \&edit_delete,
'<Control-x>' => \&edit_cut,
'<Control-c>' => \&edit_copy,
'<Control-v>' => \&edit_paste,
'<F1>' => [\&ShowHelp,@html_help],
'<Escape>' => \&abandon,
);
map( $mw->bind($_ => $EditorBindings{$_}), keys %EditorBindings );
$mw->geometry('=600x500+120+1'); # initial window position
$mw->protocol('WM_DELETE_WINDOW',\&abandon);
$mw->SelectionOwn(-selection=>'CLIPBOARD');
&ReadIDE_Settings();
{
&PopulateProject($Project);
print DATA map ("$_\n",$Project->print);
close DATA;
}
# reset changes flag
&changes(0);
return 0;
}
# Open file dialog box and load file if success
sub file_open
{
return unless &check_changes;
$mw->Busy;
# open file save dialog box
my $file = $lastfile;
$file=~s%.*[/\\]([^/\\]+)$%$1%;
if($os eq 'win')
{
my @types = ( ["Perl files",'.pl'], ["All files", '*'] );
$file = $mw->getOpenFile(-filetypes => \@types,
-initialfile => $file, -defaultextension => '.pl',
-title=>'file to read');
}
else
{
$file = $mw->FileSelect(-directory => '.',
-initialfile => $file, -title=>'file to read')->Show;
}
$mw->Unbusy;
# return 'Cancel' if file not selected
return 'Cancel' unless($file);
&file_clean;
&file_read($file);
}
# read file and convert to internal data
sub file_read
{
my ($file)=(@_);
$lastfile=$file;
my (@file);
unless(open (DATA,$file))
{
# report error
&ShowDialog(-title=>'Error:',-text=>"File $file read - $!\n",-buttons=>['Continue']);
return 'Cancel';
}
&struct_read(<DATA>);
close DATA;
&view_repaint;
}
## Clipboard operations implementation
#
# 1. Clibpoard data consistency (check for signature line)
# 2. All clipboard operations can be performed on single
# widget selection (and all it's sub-widgets)
# 3. When placing to clipboard the data must be 'transferred'
# to root hierarhy level by substitution of 'parent' for
# selected widget
# 4. While pasting data from clipboard 1st of all must be
# checked selected (to be inserted) widget type. If it
# contradict to paste context - operation cancelled with
# error box.
# 5. Next check is for possible geometry management conflicts
# between widget to be inserted and context. User can
# choose one of following: 'propagate' | 'adopt' | 'cancel'
# 6. Last check must be done per widget to be inserted:
# does it's ID conflicting with existing widgets?
# In case of conflict operation must be cancelled
# (no ugly automatic names!)
## Copy then delete selected widgets (and its subs). @see edit_copy, edit_delete
sub edit_cut
{
return if $selected eq 'mw';
# store selected:
&edit_copy;
# delete selected:
&edit_delete;
}
## Copy selected widget and its subs.
sub edit_copy
{
return if $selected eq 'mw';
my $id=&path_to_id($selected);
#$mw->clipboardClear();
#$mw->SelectionClear(-selection => 'CLIPBOARD');
@main_clipboard=();
push (@main_clipboard,join('|','#VPTK_W',$descriptor{$id}->{'parent'},$id,
$descriptor{$id}->{'type'},$descriptor{$id}->{'geom'}));
# get all IDs of copied widgets:
my @copy_id=grep(/(^|\.)$id(\.|$)/,@tree);
map (s#^.*\.##,@copy_id);
push (@main_clipboard,'#'.join('|',@copy_id));
grep (push(@main_clipboard,&code_line_print($_)),@copy_id);
#$mw->clipboardAppend(join("\n",@clipboard));
}
## Paste before/after selected widget.
sub edit_paste
{
return if $selected eq 'mw';
my $where = shift || 'before';
my $id=&path_to_id($selected);
my @clipboard=@main_clipboard;
#@clipboard = split(/\n/,$mw->SelectionGet(-selection => 'CLIPBOARD'));
# check for signature:
unless ($clipboard[0]=~/^#VPTK_W\|/)
{
&ShowDialog(-bitmap=>'error',-text=> "Clipboard is empty or corrupt!");
return;
}
# check type conflict:
my $parent=$descriptor{$id}->{'parent'};
$parent = $id if $where eq 'under';
my $parent_type=$descriptor{$parent}->{'type'};
$clipboard[0]=~s/^#VPTK_W\|//;
my ($clp_parent,$clp_id,$clp_type,$clp_geom)=split(/\|/,shift(@clipboard));
if(
($clp_type eq 'NoteBookFrame' && $parent_type ne 'NoteBook') ||
($clp_type eq 'Menu' && $parent_type !~ /^(Menubutton|cascade)$/) ||
($parent_type ne 'Menu' && $clp_type =~
/^(cascade|command|checkbutton|radiobutton|separator)$/))
{
&ShowDialog(-bitmap=>'error',-text=>
"Clipboard <-> destination type conflict ($clp_type,$parent_type)!");
return;
}
# check name conflict:
$clipboard[0]=~s/^#//;
foreach (split(/\|/,$clipboard[0]))
{
if(defined $descriptor{$_})
{
&ShowDialog(-bitmap=>'error',
-text=> "Can't paste $_ from clipboard - this ID already used!");
return;
}
}
my $reply='';
# check geometry conflict:
if($clp_geom)
{
my $clp_geom_patt=$clp_geom;
$clp_geom_patt=~s/\(.*$//;
# Get brothers, but only those with geometry
my (@brothers)=grep($descriptor{$_}->{'type'} !~ /packAdjust|Menu/,&tree_get_sons($parent));
# get their geometry
map ( $_=$descriptor{$_}->{'geom'} , @brothers );
if (grep(!/^$clp_geom_patt/,@brothers))
{
# if any of brothers does not match:
# Ask user about possible conflict solution
# 'Propagate' | 'Adopt' | 'Cancel'
# return on 'Cancel'
my $eb = $mw->DialogBox(-title=>'Geometry conflict!',
-buttons=>[qw/Propagate Adopt Cancel/]);
$eb->Label(-justify=>'left',-text=>"Geometry <$clp_geom> of clipboard widget conflicts with\n".
"other sub-widgets of $parent :\n".
join(' ',grep(!/^$clp_geom_patt/,@brothers)).
"\n\n Now you can:\n".
" Propagate this geometry to neighbor widgets\n".
" Adopt current widget geometry to it's neighbors\n".
" or Cancel paste operation")->pack();
$eb->resizable(1,0);
&Coloring($eb);
$reply = $eb->Show();
return if $reply eq 'Cancel';
}
}
shift(@clipboard);
$clipboard[0] =~ s/\$($clp_parent)(\W)/\$$parent$2/g; # rename parent for inserted root
# Save undo information:
&undo_save();
# insert here:
# 1st, calculate insert position
my $insert_pos = &calc_insert_position($where);
# then, divide tree into two parts
my (@save_tree)=splice(@tree,$insert_pos);
# and put the new contents after 1st part
&struct_read(@clipboard);
# and finally - put 2nd part
push (@tree,@save_tree);
if ($reply eq 'Propagate')
{
foreach (&tree_get_brothers($clp_id)) { $descriptor{$_}->{'geom'}=$descriptor{$clp_id}->{'geom'} }
}
if ($reply eq 'Adopt')
{
$descriptor{$clp_id}->{'geom'} = $descriptor{(&tree_get_brothers($clp_id))[0]}->{'geom'}
}
# repaint tree:
$tf->delete('all');
$descriptor{'mw'}->{'type'}='Frame';
map ( $tf->add($_,-text=>&path_to_id($_),-data=>$_,
-image=>WidgetIcon($descriptor{&path_to_id($_)}->{'type'})), @tree );
delete $descriptor{'mw'};
&changes(1);
&set_selected($selected);
}
## check are any of erased widgets listed in 'bind array'
# if any - warn and update array
sub check_bind_before_delete
{
my @widgets_todelete = grep(/$selected/,@tree);
map(s/.*\.//,@widgets_todelete);
my @bind_todelete;
foreach my $w (@widgets_todelete)
{
push(@bind_todelete,grep(/^$w.>bind\(/,@project_bindings));
}
if(@bind_todelete)
{
my $reply = ShowDialog(-title=>'Error',
-text=>"There are some bindings connected to selected widget(s)",
-buttons=>['Ok','Dismiss']);
if($reply eq 'Ok')
{
foreach my $b(@bind_todelete)
{
@project_bindings = grep($_ ne $b,@project_bindings);
}
}
else
{
return 0;
}
}
return 1;
}
## Delete selected widget and its subs.
sub edit_delete
{
return unless &check_bind_before_delete();
if ($selected eq 'mw') # say something to user here:
{
# &ShowDialog(-title=>'Error',-text=>'Use File->New in order to clear all');
&file_new;
return;
( run in 0.800 second using v1.01-cache-2.11-cpan-4ab04211f4c )