vptk_w
view release on metacpan or search on metacpan
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;
['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'],
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!)
&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
# 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'}
}
( run in 2.610 seconds using v1.01-cache-2.11-cpan-84e82930d8c )