App-Asciio-1.02.71/0000755000076400001440000000000011122301056012611 5ustar nadimusersApp-Asciio-1.02.71/t/0000755000076400001440000000000011122301056013054 5ustar nadimusersApp-Asciio-1.02.71/t/002_multi_wirl_connection.t0000444000076400001440000001151511122301056020231 0ustar nadimusers use strict; use warnings; use lib qw(lib lib/stripes) ; use Test::More 'no_plan'; #----------------------------------------------------------------------------- use Readonly ; Readonly my $QUOTE_GLYPH => "'" ; Readonly my $DOT_GLYPH => '.' ; Readonly my $MINUS_GLYPH => '-' ; Readonly my $PIPE_GLYPH => '|' ; for my $multi_wirl ( # expected # 2 points [$MINUS_GLYPH, [-2, -2, 'upleft'], [-4, -2, 'left']], [$DOT_GLYPH, [0, -2, 'up'], [-4, -2, 'left']], [$QUOTE_GLYPH, [2, -2, 'upright'], [0, -4, 'upleft']], [$QUOTE_GLYPH, [5, 0, 'right'], [0, -2, 'upleft']], [$DOT_GLYPH, [5, -2, 'rightup'], [0, -2, 'left']], [$QUOTE_GLYPH, [5, 2, 'rightdown'], [0, 2, 'left']], [$MINUS_GLYPH, [-2, 5, 'downleft'], [-5, 5, 'left']], [$QUOTE_GLYPH, [0, 5, 'down'], [-5, 5, 'left']], [$DOT_GLYPH, [5, 2, 'downright'], [0, 4, 'downleft']], [$MINUS_GLYPH, [-2, 0, 'left'], [-5, 0, 'left']], [$DOT_GLYPH, [-2, -2, 'leftup'], [-5, -2, 'left']], [$QUOTE_GLYPH, [-2, 2, 'leftdown'], [-5, 2, 'left']], #-------------------------------------------------------------------------------------- [$QUOTE_GLYPH, [-2, -2, 'upleft'], [-2, -4, 'up']], [$PIPE_GLYPH, [0, -2, 'up'], [0, -4, 'up']], [$QUOTE_GLYPH, [2, -2, 'upright'], [2, -4, 'up']], [$QUOTE_GLYPH, [5, 0, 'right'], [5, -2, 'up']], [$PIPE_GLYPH, [5, -2, 'rightup'], [5, -4, 'up']], [$QUOTE_GLYPH, [5, 2, 'rightdown'], [10, 0, 'rightup']], [$QUOTE_GLYPH, [-2, 5, 'downleft'], [-2, 0, 'up']], [$QUOTE_GLYPH, [0, 5, 'down'], [2, 0, 'rightup']], [$QUOTE_GLYPH, [5, 2, 'downright'], [5, 0, 'up']], [$QUOTE_GLYPH, [-2, 0, 'left'], [-2, -2, 'up']], [$PIPE_GLYPH, [-2, -2, 'leftup'], [-2, -4, 'up']], [$QUOTE_GLYPH, [-2, 2, 'leftdown'], [-4, 0, 'leftup']], #-------------------------------------------------------------------------------------- [$QUOTE_GLYPH, [-2, -2, 'upleft'], [0, -4, 'upright']], [$DOT_GLYPH, [0, -2, 'up'], [4, 0, 'right']], [$MINUS_GLYPH, [2, -2, 'upright'], [4, -2, 'right']], [$MINUS_GLYPH, [5, 0, 'right'], [8, 0, 'right']], [$DOT_GLYPH, [5, -2, 'rightup'], [8, -2, 'right']], [$QUOTE_GLYPH, [5, 2, 'rightdown'], [10, 2, 'right']], [$DOT_GLYPH, [-2, 5, 'downleft'], [0, 7, 'downright']], [$QUOTE_GLYPH, [0, 5, 'down'], [5, 5, 'right']], [$MINUS_GLYPH, [5, 2, 'downright'], [8, 2, 'right']], [$QUOTE_GLYPH, [-2, 0, 'left'], [0, -2, 'upright']], [$DOT_GLYPH, [-2, -2, 'leftup'], [0, -2, 'right']], [$QUOTE_GLYPH, [-2, 2, 'leftdown'], [0, 2, 'right']], #-------------------------------------------------------------------------------------- [$DOT_GLYPH, [-2, -2, 'upleft'], [-2, 4, 'down']], [$DOT_GLYPH, [0, -2, 'up'], [4, 0, 'rightdown']], [$DOT_GLYPH, [2, -2, 'upright'], [2, 2, 'down']], [$DOT_GLYPH, [5, 0, 'right'], [5, 5, 'down']], [$DOT_GLYPH, [5, -2, 'rightup'], [8, 2, 'rightdown']], [$PIPE_GLYPH, [5, 2, 'rightdown'], [5, 5, 'down']], [$DOT_GLYPH, [-2, 5, 'downleft'], [-2, 7, 'down']], [$PIPE_GLYPH, [0, 5, 'down'], [0, 8, 'down']], [$DOT_GLYPH, [5, 2, 'downright'], [5, 5, 'down']], [$DOT_GLYPH, [-2, 0, 'left'], [-2, 5, 'down']], [$DOT_GLYPH, [-2, -2, 'leftup'], [-4, -4, 'leftdown']], [$PIPE_GLYPH, [-2, 2, 'leftdown'], [-2, 4, 'down']], #-------------------------------------------------------------------------------------- ) { my ($expected_connection_character, $point_1, $point_2) = @{$multi_wirl} ; my $origin = [10, 10] ; # offset the arrow as character with negative indexes don't ger rendered my $text = get_multi_wirl_connection_text($origin, $point_1, $point_2) ; #~ print $text ; my @buffer ; my $line_index = 0 ; for my $line (split "\n", $text) { $buffer[$line_index++] = [split '', $line] ; } my ($origin_x, $origin_y) = @{$origin} ; my ($point_1_x, $point_1_y) = @{$point_1} ; is($buffer[$point_1_y + $origin_y][$point_1_x + $origin_x], $expected_connection_character) or print "$point_1->[2], $point_2->[2]\n$text" ; } #----------------------------------------------------------------------------- sub get_multi_wirl_connection_text { my ($origin, @points) = @_ ; use App::Asciio ; use App::Asciio::stripes::section_wirl_arrow; my $asciio = new App::Asciio() ; $asciio->set_character_size(8, 16) ; my $new_element = new App::Asciio::stripes::section_wirl_arrow ({ POINTS => [@points], DIRECTION => '', ALLOW_DIAGONAL_LINES => 0, EDITABLE => 1, RESIZABLE => 1, }) ; my ($character_width, $character_height) = $asciio->get_character_size() ; my ($origin_x, $origin_y) = @{$origin} ; @$new_element{'X', 'Y'} = ($origin_x, $origin_y) ; $asciio->add_elements($new_element) ; return $asciio->transform_elements_to_ascii_buffer() ; } #----------------------------------------------------------------------------- App-Asciio-1.02.71/t/001_load.t0000555000076400001440000000067611122301056014552 0ustar nadimusers # test module loading use strict ; use warnings ; use Test::NoWarnings qw(warnings clear_warnings); use Test::Warn ; use Test::More qw(no_plan); use_ok( 'App::Asciio' ) or BAIL_OUT("Can't load module"); for my $warning (warnings()) { my $message = $warning->getMessage() ; chomp $message ; fail("No warnings. Found '$message'!") unless $message =~ /asked to lazy-load .* but that package is not registered/ ; } clear_warnings() ;App-Asciio-1.02.71/lib/0000755000076400001440000000000011122301056013357 5ustar nadimusersApp-Asciio-1.02.71/lib/App/0000755000076400001440000000000011122301056014077 5ustar nadimusersApp-Asciio-1.02.71/lib/App/Asciio/0000755000076400001440000000000011122301056015306 5ustar nadimusersApp-Asciio-1.02.71/lib/App/Asciio/Io.pm0000555000076400001440000001301011122301056016207 0ustar nadimusers package App::Asciio ; $|++ ; use strict; use warnings; use Data::Dumper ; use Data::TreeDumper ; use File::Slurp ; use Readonly ; #~ use Compress::LZF ':compress'; use Compress::Bzip2 qw(:all :utilities :gzip); #----------------------------------------------------------------------------- sub load_file { my ($self, $file_name) = @_; return unless defined $file_name ; my ($base_name, $path, $extension) = File::Basename::fileparse($file_name, ('\..*')) ; $extension =~ s/^\.// ; my $type = $extension ne q{} ? $extension : 'internal_asciio_format'; my $title ; if ( exists $self->{IMPORT_EXPORT_HANDLERS}{$type}{IMPORT} && defined $self->{IMPORT_EXPORT_HANDLERS}{$type}{IMPORT} ) { my ($saved_self, $handler_data) ; ($saved_self, $title, $handler_data) = $self->{IMPORT_EXPORT_HANDLERS}{$type}{IMPORT}-> ( $self, $file_name, ) ; $self->load_self($saved_self) ; # resurect from momified $self->{IMPORT_EXPORT_HANDLERS}{HANDLER_DATA} = $handler_data ; } else { my $serialized_self = decompress(read_file($file_name)) ; my $VAR1 ; my $saved_self = eval $serialized_self or die "load_file: can't load file '$file_name': $! $@\n" ; $self->load_self($saved_self) ; # resurect delete $self->{IMPORT_EXPORT_HANDLERS}{HANDLER_DATA} ; $title = $file_name ; } return $title ; } #----------------------------------------------------------------------------- # gtk elements memory is handled by Gtk2 module Readonly my @GTK_ELEMENTS => qw ( widget PIXMAP ALLOCATED_COLORS ACTIONS CURRENT_ACTIONS ACTIONS_BY_NAME HOOKS IMPORT_EXPORT_HANDLERS TITLE ) ; sub load_self { my ($self, $new_self) = @_; return unless defined $new_self ; delete @{$new_self}{@GTK_ELEMENTS} ; my @keys = keys %{$new_self} ; @{$self}{@keys} = @{$new_self}{@keys} ; } #----------------------------------------------------------------------------- sub load_elements { my ($self, $file_name, $path) = @_; return unless defined $file_name ; my $elements = do $file_name or die "can't load file '$file_name': $! $@\n" ; $path = '' unless defined $path ; for my $new_element (@{$elements}) { my $new_element_type = ref $new_element or die "element without type in file '$file_name'!" ; unless(exists $self->{LOADED_TYPES}{$new_element_type}) { eval "use $new_element_type" ; die "Error loading type '$new_element_type' :$@" if $@ ; $self->{LOADED_TYPES}{$new_element_type}++ ; } my $next_element_type_index = @{$self->{ELEMENT_TYPES}} ; $new_element->{NAME} = "$path/$new_element->{NAME}" ; $new_element->{NAME} =~ s~/+~/~g ; $new_element->{NAME} =~ s~^/~~g ; #~ print $new_element->{NAME} . "\n" ; if(exists $new_element->{NAME}) { if(exists $self->{ELEMENT_TYPES_BY_NAME}{$new_element->{NAME}}) { print "Overriding element type '$new_element->{NAME}'!\n" ; $self->{ELEMENT_TYPES}[$self->{ELEMENT_TYPES_BY_NAME}{$new_element->{NAME}}] = $new_element ; } else { $self->{ELEMENT_TYPES_BY_NAME}{$new_element->{NAME}} = $next_element_type_index ; push @{$self->{ELEMENT_TYPES}}, $new_element ; $next_element_type_index++ ; } } if(exists $new_element->{X}) { push @{$self->{ELEMENTS}}, $new_element ; } } } #----------------------------------------------------------------------------- sub save_stencil { my ($self) = @_ ; my $name = $self->display_edit_dialog('stencil name') ; if(defined $name && $name ne q[]) { my $file_name = $self->get_file_name('save') ; if(defined $file_name && $file_name ne q[]) { if(-e $file_name) { my $override = $self->display_yes_no_cancel_dialog ( "Override file!", "File '$file_name' exists!\nOverride file?" ) ; $file_name = undef unless $override eq 'yes' ; } } if(defined $file_name && $file_name ne q[]) { use Data::Dumper ; my ($element) = $self->get_selected_elements(1) ; my $stencil = Clone::clone($element) ; delete $stencil->{X} ; delete $stencil->{Y} ; $stencil->{NAME} = $name; write_file($file_name, Dumper [$stencil]) ; } } } #----------------------------------------------------------------------------- sub serialize_self { my ($self, $indent) = @_ ; local $self->{widget} = undef ; local $self->{PIXMAP} = undef ; local $self->{ALLOCATED_COLORS} = undef ; local $self->{ACTIONS} = [] ; local $self->{HOOKS} = [] ; local $self->{CURRENT_ACTIONS} = [] ; local $self->{ACTIONS_BY_NAME} = [] ; local $self->{DO_STACK} = undef ; local $self->{IMPORT_EXPORT_HANDLERS} = undef ; local $self->{MODIFIED} => 0 ; local $self->{TITLE} = '' ; local $self->{CREATE_BACKUP} = undef ; local $Data::Dumper::Purity = 1 ; local $Data::Dumper::Indent = $indent || 0 ; local $Data::Dumper::Sortkeys = 1 ; Dumper($self) ; } #----------------------------------------------------------------------------- sub save_with_type { my ($self, $elements_to_save, $type, $file_name) = @_ ; my $title ; if ( exists $self->{IMPORT_EXPORT_HANDLERS}{$type}{EXPORT} && defined $self->{IMPORT_EXPORT_HANDLERS}{$type}{EXPORT} ) { $title = $self->{IMPORT_EXPORT_HANDLERS}{$type}{EXPORT}-> ( $self, $elements_to_save, $file_name, $self->{IMPORT_EXPORT_HANDLERS}{HANDLER_DATA}, ) ; } else { if($self->{CREATE_BACKUP} && -e $file_name) { use File::Copy; copy($file_name,"$file_name.bak") or die "save_with_type: Copy failed while making backup copy: $!"; } write_file($file_name,compress($self->serialize_self() .'$VAR1 ;')) ; $title = $file_name ; } return $title ; } #----------------------------------------------------------------------------- 1 ;App-Asciio-1.02.71/lib/App/Asciio/Options.pm0000555000076400001440000000421211122301056017277 0ustar nadimusers package App::Asciio ; $|++ ; use strict; use warnings; use Data::TreeDumper ; use Getopt::Long ; #----------------------------------------------------------------------------- sub ParseSwitches { my ($self, $switches_to_parse, $ignore_error) = @_ ; my $asciio_config = {} ; Getopt::Long::Configure('no_auto_abbrev', 'no_ignore_case', 'require_order') ; my @flags = Get_GetoptLong_Data($asciio_config) ; @ARGV = @{$switches_to_parse} ; # tweek option parsing so we can mix switches with targets my $contains_switch ; my @targets ; do { while(@ARGV && $ARGV[0] !~ /^-/) { #~ print "target => $ARGV[0] \n" ; push @targets, shift @ARGV ; } $contains_switch = @ARGV ; local $SIG{__WARN__} = sub {print STDERR $_[0] unless $ignore_error ;} ; unless(GetOptions(@flags)) { return(0, "Try perl asciio -h.", $asciio_config, @ARGV) unless $ignore_error; } } while($contains_switch) ; $asciio_config->{TARGETS} = \@targets ; #~ use Data::TreeDumper ; #~ print DumpTree $asciio_config ; return(1, '', $asciio_config) ; } #------------------------------------------------------------------------------- sub Get_GetoptLong_Data { my $asciio_config = shift || die 'Missing argument.' ; my @flags_and_help = GetSwitches($asciio_config) ; my $flag_element_counter = 0 ; my @getoptlong_data ; for (my $i = 0 ; $i < @flags_and_help; $i += 4) { my ($flag, $variable) = ($flags_and_help[$i], $flags_and_help[$i + 1]) ; push @getoptlong_data, ($flag, $variable) ; } return(@getoptlong_data) ; } #------------------------------------------------------------------------------- sub GetSwitches { my $asciio_config = shift || {} ; $asciio_config->{SETUP_PATH} = undef ; my @flags_and_help = ( 'setup_path=s' => \$asciio_config->{SETUP_PATH}, 'Sets the root of the setup directory.', '', 's|script=s' => \$asciio_config->{SCRIPT}, 'script to be run at AsciiO start.', '', 'h|help' => \$asciio_config->{HELP}, 'Displays some help.', '', ) ; return(@flags_and_help) ; } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.02.71/lib/App/Asciio/Actions.pm0000555000076400001440000000701711122301056017252 0ustar nadimusers package App::Asciio ; $|++ ; use strict; use warnings; #------------------------------------------------------------------------------------------------------ sub get_key_modifiers { my ($event) = @_ ; my $key_modifiers = $event->state() ; my $modifiers = $key_modifiers =~ /control-mask/ ? 'C' :0 ; $modifiers .= $key_modifiers =~ /mod1-mask/ ? 'A' :0 ; $modifiers .= $key_modifiers =~ /shift-mask/ ? 'S' :0 ; return($modifiers) ; } #------------------------------------------------------------------------------------------------------ my Readonly $SHORTCUTS = 0 ; my Readonly $CODE = 1 ; my Readonly $ARGUMENTS = 2 ; my Readonly $CONTEXT_MENUE_SUB = 3 ; my Readonly $CONTEXT_MENUE_ARGUMENTS = 4 ; my Readonly $NAME= 5 ; my Readonly $ORIGIN= 6 ; sub run_actions { my ($self, @actions) = @_ ; my @results ; for my $action (@actions) { my @arguments ; if('ARRAY' eq ref $action) { ($action, @arguments) = @{ $action } ; } my ($modifiers, $action_key) = $action =~ /(...)-(.*)/ ; if(exists $self->{CURRENT_ACTIONS}{$action}) { if('HASH' eq ref $self->{CURRENT_ACTIONS}{$action}) { my $action_group_name = $self->{CURRENT_ACTIONS}{$action}{GROUP_NAME} || 'unnamed action group' ; print "using action handlers group '$action_group_name'" . "[$self->{CURRENT_ACTIONS}{$action}{ORIGIN}].\n" ; $self->{CURRENT_ACTIONS} = $self->{CURRENT_ACTIONS}{$action} ; } else { print "Handling input '$modifiers + $action_key' with action '$self->{CURRENT_ACTIONS}{$action}[$NAME]'" . "[$self->{CURRENT_ACTIONS}{$action}[$ORIGIN]].\n" ; if(defined $self->{CURRENT_ACTIONS}{$action}[$ARGUMENTS]) { push @results, [ $self->{CURRENT_ACTIONS}{$action}[$CODE]-> ( $self, $self->{CURRENT_ACTIONS}{$action}[$ARGUMENTS], @arguments ) ] ; } else { push @results, [ $self->{CURRENT_ACTIONS}{$action}[$CODE]->($self, @arguments) ] ; } } } else { print "no handler for input '$modifiers + $action_key'.\n" ; $self->{CURRENT_ACTIONS} = $self->{ACTIONS} ; } } return @results ; } #------------------------------------------------------------------------------------------------------ sub run_actions_by_name { my ($self, @actions) = @_ ; my @results ; my $current_actions_by_name = $self->{ACTIONS_BY_NAME} ; for my $action (@actions) { my @arguments ; if('ARRAY' eq ref $action) { ($action, @arguments) = @{ $action } ; } if(exists $current_actions_by_name->{$action}) { if('HASH' eq ref $self->{CURRENT_ACTIONS}{$action}) { print "using action handlers group '$action'\n" ; $current_actions_by_name = $self->{CURRENT_ACTIONS}{$action} ; } else { print "running action '$action'.\n" ; if(defined $current_actions_by_name->{$action}[$ARGUMENTS]) { push @results, [ $current_actions_by_name->{$action}[$CODE]-> ( $self, $self->{CURRENT_ACTIONS}{$action}[$ARGUMENTS], @arguments ) ] ; } else { push @results, [ $current_actions_by_name->{$action}[$CODE]->($self, @arguments) ] ; } } } else { print "no handler for '$action'.\n" ; last ; } } return @results ; } #------------------------------------------------------------------------------------------------------ sub exists_action { my ($self, $action) = @_ ; return exists $self->{CURRENT_ACTIONS}{$action} ; } #------------------------------------------------------------------------------------------------------ 1 ; App-Asciio-1.02.71/lib/App/Asciio/Dialogs.pm0000555000076400001440000002644511122301056017242 0ustar nadimusers package App::Asciio ; $|++ ; use strict; use warnings; use Data::TreeDumper ; use Data::TreeDumper::Renderer::GTK ; #----------------------------------------------------------------------------- sub get_color_from_user { my ($self, $previous_color) = @_ ; my $color = Gtk2::Gdk::Color->new (@{$previous_color}); my $dialog = Gtk2::ColorSelectionDialog->new ("Changing color"); my $colorsel = $dialog->colorsel; $colorsel->set_previous_color ($color); $colorsel->set_current_color ($color); $colorsel->set_has_palette (TRUE); my $response = $dialog->run; if ($response eq 'ok') { $color = $colorsel->get_current_color; } $dialog->destroy; return [$color->red, $color->green , $color->blue] ; } #----------------------------------------------------------------------------- sub show_dump_window { my ($self, $data, $title, @dumper_setup) = @_ ; my $treedumper = Data::TreeDumper::Renderer::GTK->new ( data => $data, title => $title, dumper_setup => {@dumper_setup} ); $treedumper->modify_font(Gtk2::Pango::FontDescription->from_string ('monospace')); $treedumper->collapse_all; # some boilerplate to get the widget onto the screen... my $window = Gtk2::Window->new; my $scroller = Gtk2::ScrolledWindow->new; $scroller->add ($treedumper); $window->add ($scroller); $window->set_default_size(640, 1000) ; $window->show_all; } #----------------------------------------------------------------------------- sub display_message_modal { my ($self, $message) = @_ ; my $window = new Gtk2::Window() ; my $dialog = Gtk2::MessageDialog->new ( $window, 'destroy-with-parent' , 'info' , 'close' , $message , ) ; $dialog->signal_connect(response => sub { $dialog->destroy ; 1 }) ; $dialog->run() ; } #----------------------------------------------------------------------------- sub display_yes_no_cancel_dialog { my ($self, $title, $text) = @_ ; my $window = new Gtk2::Window() ; my $dialog = Gtk2::Dialog->new($title, $window, 'destroy-with-parent') ; $dialog->set_default_size (300, 150); $dialog->add_button ('gtk-yes' => 'yes'); $dialog->add_button ('gtk-no' => 'no'); $dialog->add_button ('gtk-cancel' => 'cancel'); my $lable = Gtk2::Label->new($text); $dialog->vbox->add ($lable); $lable->show; my $result = $dialog->run() ; $dialog->destroy ; return $result ; } #----------------------------------------------------------------------------- sub display_quit_dialog { my ($self, $title, $text) = @_ ; my $window = new Gtk2::Window() ; my $dialog = Gtk2::Dialog->new($title, $window, 'destroy-with-parent') ; $dialog->set_default_size (300, 150); add_button_with_icon ($dialog, 'Continue editing', 'gtk-cancel' => 'cancel'); add_button_with_icon ($dialog, 'Save and Quit', 'gtk-save' => 999); add_button_with_icon ($dialog, 'Quit and loose changes', 'gtk-ok' => 'ok'); my $lable = Gtk2::Label->new($text); $dialog->vbox->add ($lable); $lable->show; my $result = $dialog->run() ; $result = 'save_and_quit' if "$result" eq "999" ; $dialog->destroy ; return $result ; } sub add_button_with_icon { # code by Muppet my ($dialog, $text, $stock_id, $response_id) = @_; my $button = create_button ($text, $stock_id); $button->show; $dialog->add_action_widget ($button, $response_id); } # # Create a button with a stock icon but with non-stock text. # sub create_button { # code by Muppet my ($text, $stock_id) = @_; my $button = Gtk2::Button->new (); # # This setup is cribbed from gtk_button_construct_child() # in gtkbutton.c. It does not handle all the details like # left-to-right ordering and alignment and such, as in the # real button code. # my $image = Gtk2::Image->new_from_stock ($stock_id, 'button'); my $label = Gtk2::Label->new ($text); # accepts mnemonics $label->set_mnemonic_widget ($button); my $hbox = Gtk2::HBox->new (); $hbox->pack_start ($image, FALSE, FALSE, 0); $hbox->pack_start ($label, FALSE, FALSE, 0); $hbox->show_all (); $button->add ($hbox); return $button; } #----------------------------------------------------------------------------- sub display_edit_dialog { my ($self, $title, $text) = @_ ; $text ='' unless defined $text ; my $window = new Gtk2::Window() ; my $dialog = Gtk2::Dialog->new($title, $window, 'destroy-with-parent') ; $dialog->set_default_size (300, 150); $dialog->add_button ('gtk-ok' => 'ok'); my $textview = Gtk2::TextView->new; $textview->modify_font (Gtk2::Pango::FontDescription->from_string ('monospace 10')); my $buffer = $textview->get_buffer; $buffer->insert ($buffer->get_end_iter, $text); $dialog->vbox->add ($textview); $textview->show; # # Set up the dialog such that Ctrl+Return will activate the "ok" response. Muppet # #~ my $accel = Gtk2::AccelGroup->new; #~ $accel->connect #~ ( #~ Gtk2::Gdk->keyval_from_name ('Return'), ['control-mask'], [], #~ sub { $dialog->response ('ok'); } #~ ); #~ $dialog->add_accel_group ($accel); $dialog->run() ; my $new_text = $textview->get_buffer->get_text($buffer->get_start_iter, $buffer->get_end_iter, TRUE) ; $dialog->destroy ; return $new_text } #----------------------------------------------------------------------------- sub get_file_name { my ($self, $type) = @_ ; my $file_name = '' ; my $file_chooser = Gtk2::FileChooserDialog->new ( $type, undef, $type, 'gtk-cancel' => 'cancel', 'gtk-ok' => 'ok' ); $file_name = $file_chooser->get_filename if ('ok' eq $file_chooser->run) ; $file_chooser->destroy; return $file_name ; } #----------------------------------------------------------------------------- sub display_box_edit_dialog { my ($rows, $title, $text) = @_ ; my $window = new Gtk2::Window() ; my $dialog = Gtk2::Dialog->new('Box attributes', $window, 'destroy-with-parent') ; $dialog->set_default_size (450, 305); $dialog->add_button ('gtk-ok' => 'ok'); #~ my $vbox = $dialog->vbox ; my $dialog_vbox = $dialog->vbox ; my $vbox = Gtk2::VBox->new (FALSE, 5); $dialog_vbox->pack_start ($vbox, TRUE, TRUE, 0); $vbox->pack_start (Gtk2::Label->new (""), FALSE, FALSE, 0); my $sw = Gtk2::ScrolledWindow->new; $sw->set_shadow_type ('etched-in'); $sw->set_policy ('automatic', 'automatic'); $vbox->pack_start ($sw, TRUE, TRUE, 0); # create model my $model = create_model ($rows); # create tree view my $treeview = Gtk2::TreeView->new_with_model ($model); $treeview->set_rules_hint (TRUE); $treeview->get_selection->set_mode ('single'); add_columns($treeview, $rows); $sw->add($treeview); # title my $titleview = Gtk2::TextView->new; $titleview->modify_font (Gtk2::Pango::FontDescription->from_string ('monospace 10')); my $title_buffer = $titleview->get_buffer ; $title_buffer->insert ($title_buffer->get_end_iter, $title); $vbox->add ($titleview); $titleview->show; # text my $textview = Gtk2::TextView->new; $textview->modify_font (Gtk2::Pango::FontDescription->from_string ('monospace 10')); my $text_buffer = $textview->get_buffer; $text_buffer->insert ($text_buffer->get_end_iter, $text); $vbox->add ($textview) ; $textview->show() ; # Focus and select, code by Tian $text_buffer->select_range($text_buffer->get_start_iter, $text_buffer->get_end_iter); $textview->grab_focus() ; # some buttons #~ my $hbox = Gtk2::HBox->new (TRUE, 4); #~ $vbox->pack_start ($hbox, FALSE, FALSE, 0); #~ my $button = Gtk2::Button->new ("Add item"); #~ $button->show() ; #~ $button->signal_connect (clicked => \&add_item, $model); #~ $hbox->pack_start ($button, TRUE, TRUE, 0); #~ $button = Gtk2::Button->new ("Remove item"); #~ $button->signal_connect (clicked => \&remove_item, $treeview); #~ $hbox->pack_start ($button, TRUE, TRUE, 0); #~ $hbox->show() ; $treeview->show() ; $vbox->show() ; $sw->show() ; $dialog->run() ; my $new_text = $textview->get_buffer->get_text($text_buffer->get_start_iter, $text_buffer->get_end_iter, TRUE) ; my $new_title = $titleview->get_buffer->get_text($title_buffer->get_start_iter, $title_buffer->get_end_iter, TRUE) ; $dialog->destroy ; return($new_text, $new_title) ; } #----------------------------------------------------------------------------- sub create_model { my ($rows) = @_ ; my $model = Gtk2::ListStore->new(qw/Glib::Boolean Glib::String Glib::String Glib::String Glib::String Glib::Boolean/); foreach my $row (@{$rows}) { my $iter = $model->append; my $column = 0 ; $model->set ($iter, map {$column++, $_} @{$row}) ; } return $model; } #----------------------------------------------------------------------------- sub add_columns { my ($treeview, $rows) = @_ ; my $model = $treeview->get_model; # column for fixed toggles my $renderer = Gtk2::CellRendererToggle->new; $renderer->signal_connect (toggled => \&display_toggled, [$model, $rows]) ; my $column = Gtk2::TreeViewColumn->new_with_attributes ( 'show', $renderer, active => 0 ) ; $column->set_sizing('fixed') ; $column->set_fixed_width(70) ; $treeview->append_column($column) ; # column for row titles my $row_renderer = Gtk2::CellRendererText->new; $row_renderer->set_data (column => 1); $treeview->insert_column_with_attributes(-1, '', $row_renderer, text => 1) ; #~ $column->set_sort_column_id (COLUMN_NUMBER); my $current_column = 2 ; for my $column_title('left', 'body', 'right') { my $renderer = Gtk2::CellRendererText->new; $renderer->signal_connect (edited => \&cell_edited, [$model, $rows]); $renderer->set_data (column => $current_column ); $treeview->insert_column_with_attributes ( -1, $column_title, $renderer, text => $current_column, editable => 5, ); $current_column++ ; } } #----------------------------------------------------------------------------- sub cell_edited { my ($cell, $path_string, $new_text, $model_and_rows) = @_; my ($model, $rows) = @{$model_and_rows} ; my $path = Gtk2::TreePath->new_from_string ($path_string); my $column = $cell->get_data ("column"); my $iter = $model->get_iter($path); my $row = ($path->get_indices)[0]; $rows->[$row][$column] = $new_text ; $model->set($iter, $column, $new_text); } #----------------------------------------------------------------------------- sub display_toggled { my ($cell, $path_string, $model_and_rows) = @_; my ($model, $rows) = @{$model_and_rows} ; my $column = $cell->get_data ('column'); my $path = Gtk2::TreePath->new ($path_string) ; my $iter = $model->get_iter ($path); my $display = $model->get($iter, 0); $rows->[$path_string][$column] = $display ^ 1 ; $model->set ($iter, 0, $display ^ 1); } #----------------------------------------------------------------------------- #~ sub add_item { #~ my ($button, $model) = @_; #~ push @articles, { #~ number => 0, #~ product => "Description here", #~ editable => TRUE, #~ }; #~ my $iter = $model->append; #~ $model->set ($iter, #~ COLUMN_NUMBER, $articles[-1]{number}, #~ COLUMN_PRODUCT, $articles[-1]{product}, #~ COLUMN_EDITABLE, $articles[-1]{editable}); #~ } #~ sub remove_item { #~ my ($widget, $treeview) = @_; #~ my $model = $treeview->get_model; #~ my $selection = $treeview->get_selection; #~ my $iter = $selection->get_selected; #~ if ($iter) { #~ my $path = $model->get_path ($iter); #~ my $i = ($path->get_indices)[0]; #~ $model->remove ($iter); #~ splice @articles, $i; #~ } #~ } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.02.71/lib/App/Asciio/Ascii.pm0000555000076400001440000000237611122301056016705 0ustar nadimusers package App::Asciio; $|++ ; use strict; use warnings; #----------------------------------------------------------------------------- sub transform_elements_to_ascii_buffer { my ($self, @elements) = @_ ; return(join("\n", $self->transform_elements_to_ascii_array(@elements)) . "\n") ; } #----------------------------------------------------------------------------- sub transform_elements_to_ascii_array { my ($self, @elements) = @_ ; @elements = @{$self->{ELEMENTS}} unless @elements ; my @lines ; for my $element (@elements) { for my $strip ($element->get_mask_and_element_stripes()) { my $line_index = 0 ; for my $sub_strip (split("\n", $strip->{TEXT})) { my $character_index = 0 ; for my $character (split '', $sub_strip) { my $x = $element->{X} + $strip->{X_OFFSET} + $character_index ; my $y = $element->{Y} + $strip->{Y_OFFSET} + $line_index ; $lines[$y][$x] = $character if ($x >= 0 && $y >= 0) ; $character_index ++ ; } $line_index++ ; } } } my @ascii; for my $line (@lines) { my $ascii_line = join('', map {defined $_ ? $_ : ' '} @{$line}) ; push @ascii, $ascii_line; } return(@ascii) ; } #----------------------------------------------------------------------------- 1 ;App-Asciio-1.02.71/lib/App/Asciio/stripes/0000755000076400001440000000000011122301056016777 5ustar nadimusersApp-Asciio-1.02.71/lib/App/Asciio/stripes/process_box.pm0000555000076400001440000001762111122301056021673 0ustar nadimusers package App::Asciio::stripes::process_box ; use base App::Asciio::stripes::stripes ; use strict; use warnings; use List::Util qw(min max) ; use Readonly ; #----------------------------------------------------------------------------- sub new { my ($class, $element_definition) = @_ ; my $self = bless {}, __PACKAGE__ ; $self->setup ( $element_definition->{TEXT_ONLY}, $element_definition->{WIDTH} || 1, $element_definition->{HEIGHT} || 1, $element_definition->{EDITABLE}, $element_definition->{RESIZABLE}, ) ; return $self ; } #----------------------------------------------------------------------------- sub setup { my ($self, $text_only, $end_x, $end_y, $editable, $resizable) = @_ ; Readonly my $side_glyphs_size => 4 ; $text_only = '' unless defined $text_only ; my @lines = split("\n", $text_only) ; @lines = ('') unless @lines; my $number_of_lines = scalar(@lines) ; if($end_y - 3 > $number_of_lines) { my $lines_to_add = ($end_y - 3) - $number_of_lines ; $lines_to_add += $lines_to_add % 2 ; # number of lines is always even unshift @lines, map {''} (1 .. $lines_to_add / 2) ; push @lines, map {''} (1 .. $lines_to_add / 2) ; $number_of_lines += $lines_to_add ; } my $half_the_lines = int($number_of_lines / 2) ; my $element_width = 0 ; my $current_half_the_lines = $half_the_lines ; my (@lines_width_plus_offset) ; for my $line (@lines) { push @lines_width_plus_offset, length($line) + abs($current_half_the_lines) ; $current_half_the_lines-- ; } my $text_width_plus_offset = max(@lines_width_plus_offset, $end_x) ; my @top_lines = (splice @lines, 0, $number_of_lines / 2) ; my $center_line = shift @lines || '' ; my @bottom_lines = @lines ; push @bottom_lines, '' for (1 .. scalar(@top_lines) - scalar(@bottom_lines)) ; my (@stripes, $strip_text, $x_offset, $y_offset) ; $strip_text = '_' x (($text_width_plus_offset - 1) + $side_glyphs_size) . "\n\\" . ' ' x (($text_width_plus_offset - 2) + $side_glyphs_size) . "\\" ; push @stripes, { 'HEIGHT' => 2, 'TEXT' => $strip_text, 'WIDTH' => $text_width_plus_offset + $side_glyphs_size, 'X_OFFSET' => 0, 'Y_OFFSET' =>0, } ; $x_offset = 1 ; $y_offset = 2 ; $current_half_the_lines = $half_the_lines ; for my $line (@top_lines) { my $front_padding = ' ' x $current_half_the_lines ; my $padding = ' ' x ($text_width_plus_offset - (length($line) + $current_half_the_lines)) ; my $strip_text = "\\ $front_padding$line$padding \\" ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $strip_text, 'WIDTH' => length($strip_text), 'X_OFFSET' => $x_offset, 'Y_OFFSET' => $y_offset , } ; $x_offset++ ; $y_offset++ ; $current_half_the_lines-- ; } my $padding = ' ' x ($text_width_plus_offset - length($center_line)) ; $strip_text = ') ' . $center_line . $padding . ' )' ; $element_width = length($strip_text) + $y_offset - 1 ; # first stripe is two lines high, compensate offset by substracting one my $left_center_x = $y_offset - 2 ; # compensate as above and shft left push @stripes, { 'HEIGHT' => 1, 'TEXT' => $strip_text, 'WIDTH' => length($strip_text), 'X_OFFSET' => $x_offset, 'Y_OFFSET' => $y_offset, }; $y_offset++ ; $x_offset-- ; $current_half_the_lines = 1; for my $line (@bottom_lines) { my $front_padding = ' ' x $current_half_the_lines ; my $padding = ' ' x ($text_width_plus_offset - (length($line) + $current_half_the_lines)) ; my $strip_text = "/ $front_padding$line$padding /" ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $strip_text, 'WIDTH' => length($strip_text), 'X_OFFSET' => $x_offset, 'Y_OFFSET' => $y_offset , } ; $x_offset-- ; $y_offset++ ; $current_half_the_lines++; } $strip_text = '/' . '_' x (($text_width_plus_offset - 2) + $side_glyphs_size ) . '/' ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $strip_text, 'WIDTH' => $text_width_plus_offset + $side_glyphs_size, 'X_OFFSET' => 0, 'Y_OFFSET' => $y_offset, }; $self->set ( STRIPES => \@stripes, WIDTH => $element_width, HEIGHT => $y_offset + 1, LEFT_CENTER_X => $left_center_x, RESIZE_POINT_X => $text_width_plus_offset + $side_glyphs_size - 1, TEXT_ONLY => $text_only, EDITABLE => $editable, RESIZABLE => $resizable, ) ; } #----------------------------------------------------------------------------- sub get_selection_action { my ($self, $x, $y) = @_ ; if ( ($x == $self->{RESIZE_POINT_X} && $y == $self->{HEIGHT} - 1) ) { 'resize' ; } else { 'move' ; } } #----------------------------------------------------------------------------- sub match_connector { my ($self, $x, $y) = @_ ; my $middle_width = int($self->{WIDTH} / 2) ; my $middle_height = int($self->{HEIGHT} / 2) ; if($x == $middle_width && $y == -1) { return {X => $x, Y => $y, NAME => 'top_center'} ; } elsif($x == $middle_width && $y == $self->{HEIGHT}) { return {X => $x, Y => $y, NAME => 'bottom_center'} ; } if($x == $self->{LEFT_CENTER_X} && $y == $middle_height) { return {X => $x, Y => $y, NAME => 'left_center'} ; } elsif($x == $self->{WIDTH} && $y == $middle_height) { return {X => $x, Y => $y, NAME => 'right_center'} ; } elsif($x >= 0 && $x < $self->{WIDTH} && $y >= 0 && $y < $self->{HEIGHT}) { return {X => $middle_width, Y => -1, NAME => 'to_be_optimized'} ; } else { return ; } } #----------------------------------------------------------------------------- sub get_connection_points { my ($self) = @_ ; my $middle_width = int($self->{WIDTH} / 2) ; my $middle_height = int($self->{HEIGHT} / 2) ; return ( {X => $middle_width, Y => -1, NAME => 'top_center'}, {X => $middle_width, Y => $self->{HEIGHT}, NAME => 'bottom_center'}, {X => $self->{LEFT_CENTER_X}, Y => $middle_height, NAME => 'left_center'}, {X => $self->{WIDTH}, Y => $middle_height, NAME => 'right_center'}, ) ; } #----------------------------------------------------------------------------- sub get_extra_points { my ($self) = @_ ; return ( {X => $self->{RESIZE_POINT_X}, Y => $self->{HEIGHT} - 1 , NAME => 'resize'}, ) ; } #----------------------------------------------------------------------------- sub get_named_connection { my ($self, $name) = @_ ; my $middle_width = int($self->{WIDTH} / 2) ; my $middle_height = int($self->{HEIGHT} / 2) ; if($name eq 'top_center') { return {X => $middle_width, Y => -1, NAME => 'top_center'} ; } elsif($name eq 'bottom_center') { return {X => $middle_width, Y => $self->{HEIGHT}, NAME => 'bottom_center'} ; } elsif($name eq 'left_center') { return {X => $self->{LEFT_CENTER_X}, Y => $middle_height, NAME => 'left_center'}, } elsif($name eq 'right_center') { return {X => $self->{WIDTH}, Y => $middle_height, NAME => 'right_center'}, } else { return ; } } #----------------------------------------------------------------------------- sub resize { my ($self, $reference_x, $reference_y, $new_x, $new_y) = @_ ; my $new_end_x = $new_x ; my $new_end_y = $new_y ; if($new_end_x >= 0 && $new_end_y >= 0) { $self->setup ( $self->{TEXT_ONLY}, $new_end_x + 1 - ($self->{WIDTH} - $self->{RESIZE_POINT_X}), # compensate for resize point X not equal to width $new_end_y + 1, $self->{EDITABLE}, $self->{RESIZABLE} ) ; } return(0, 0, $self->{WIDTH}, $self->{HEIGHT}) ; } #----------------------------------------------------------------------------- sub get_text { my ($self) = @_ ; return($self->{TEXT_ONLY}) ; } #----------------------------------------------------------------------------- sub set_text { my ($self, $text) = @_ ; $self->setup ( $text, $self->{RESIZE_POINT_X} - 3, # magic number are ugly $self->{HEIGHT} - 1, $self->{EDITABLE}, $self->{RESIZABLE} ) ; } #----------------------------------------------------------------------------- sub edit { my ($self) = @_ ; return unless $self->{EDITABLE} ; my ($text_only) = App::Asciio::display_edit_dialog($self, 'asciio', $self->{TEXT_ONLY}) ; my $tab_as_space = $self->{TAB_AS_SPACES} || (' ' x 3) ; $text_only =~ s/\t/$tab_as_space/g ; $self->set_text($text_only) ; } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.02.71/lib/App/Asciio/stripes/if_box.pm0000555000076400001440000001452011122301056020606 0ustar nadimusers package App::Asciio::stripes::if_box ; use base App::Asciio::stripes::single_stripe ; use strict; use warnings; use List::Util qw(min max) ; use Readonly ; use Clone ; #----------------------------------------------------------------------------- sub new { my ($class, $element_definition) = @_ ; my $self = bless {}, __PACKAGE__ ; $self->setup ( $element_definition->{TEXT_ONLY}, 1, 1, $element_definition->{RESIZABLE}, $element_definition->{EDITABLE}, ) ; return $self ; } #----------------------------------------------------------------------------- sub setup { my ($self, $text_only, $end_x, $end_y, $resizable, $editable) = @_ ; # $end_x, $end_y are used if we want to keep a box size constant if the included text gets smaller # if_boxes automatically fit to their content (so far) so those variables are not used $text_only = '' unless defined $text_only ; my ($text_width, @lines) = (0) ; for my $line (split("\n", $text_only)) { $text_width = max($text_width, length($line)) ; push @lines, $line ; } my $number_of_lines = scalar(@lines) ; my $lines_to_add = ($number_of_lines + 1) % 2 ; # always odd unshift @lines, map {''} (1 .. $lines_to_add / 2) ; push @lines, map {''} (1 .. $lines_to_add / 2) ; $number_of_lines += $lines_to_add ; my $half_the_lines = int($number_of_lines / 2) ; my $extra_width = 2 + $half_the_lines ; my $extra_height = 2 ; my $text = ' ' x ($half_the_lines + 1). '.' . '-' x $text_width . '.' . "\n" ; my @top_lines = (splice @lines, 0, $number_of_lines / 2) ; my $left_indentation = $half_the_lines ; my $inside_indentation = 0 ; for my $line (@top_lines) { my $padding = ' ' x ($text_width - length($line)) ; $text .= ' ' x $left_indentation . '/ ' . ' ' x $inside_indentation . $line . $padding . ' ' x $inside_indentation. ' \\' . "\n" ; $left_indentation-- ; $inside_indentation++ ; } my $center_line = shift @lines || '' ; my $padding = ' ' x ($text_width - length($center_line)) ; $center_line = '( ' . ' ' x $inside_indentation . $center_line . $padding . ' ' x $inside_indentation . ' )' ; my $width = length($center_line) ; $text .= $center_line . "\n" ; $left_indentation = 1 ; $inside_indentation-- ; my @bottom_lines = @lines ; push @bottom_lines, '' for (1 .. scalar(@top_lines) - scalar(@bottom_lines)) ; for my $line (@bottom_lines) { my $padding = ' ' x ($text_width - length($line)) ; $text .= ' ' x $left_indentation . '\\ ' . ' ' x $inside_indentation . $line . $padding . ' ' x $inside_indentation . ' /' . "\n" ; $left_indentation++ ; $inside_indentation-- ; } $text .= ' ' x ($half_the_lines + 1) . q{'} . '-' x $text_width . q{'} . "\n" ; $self->set ( TEXT => $text, WIDTH => $width, HEIGHT => $number_of_lines + 2, TEXT_ONLY => $text_only, RESIZABLE => $resizable, EDITABLE => $editable, ) ; } #----------------------------------------------------------------------------- sub get_selection_action { my ($self, $x, $y) = @_ ; if ( ($x == $self->{WIDTH} - 1 && $y == $self->{HEIGHT} - 1) ) { 'resize' ; } else { 'move' ; } } #----------------------------------------------------------------------------- sub match_connector { my ($self, $x, $y) = @_ ; my $middle_width = int($self->{WIDTH} / 2) ; my $middle_height = int($self->{HEIGHT} / 2) ; if($x == $middle_width && $y == -1) { return {X => $x, Y => $y, NAME => 'top_center'} ; } elsif($x == $middle_width && $y == $self->{HEIGHT}) { return {X => $x, Y => $y, NAME => 'bottom_center'} ; } if($x == -1 && $y == $middle_height) { return {X => $x, Y => $y, NAME => 'left_center'} ; } elsif($x == $self->{WIDTH} && $y == $middle_height) { return {X => $x, Y => $y, NAME => 'right_center'} ; } elsif($x >= 0 && $x < $self->{WIDTH} && $y >= 0 && $y < $self->{HEIGHT}) { return {X => $middle_width, Y => -1, NAME => 'to_be_optimized'} ; } else { return ; } } #----------------------------------------------------------------------------- sub get_connection_points { my ($self) = @_ ; my $middle_width = int($self->{WIDTH} / 2) ; my $middle_height = int($self->{HEIGHT} / 2) ; return ( {X => $middle_width, Y => -1, NAME => 'top_center'}, {X => $middle_width, Y => $self->{HEIGHT}, NAME => 'bottom_center'}, {X => -1, Y => $middle_height, NAME => 'left_center'}, {X => $self->{WIDTH}, Y => $middle_height, NAME => 'right_center'}, ) ; } #----------------------------------------------------------------------------- sub get_named_connection { my ($self, $name) = @_ ; my $middle_width = int($self->{WIDTH} / 2) ; my $middle_height = int($self->{HEIGHT} / 2) ; if($name eq 'top_center') { return( {X => $middle_width, Y => -1, NAME => 'top_center'} ) ; } elsif($name eq 'bottom_center') { return( {X => $middle_width, Y => $self->{HEIGHT}, NAME => 'bottom_center'} ) ; } elsif($name eq 'left_center') { return {X => -1, Y => $middle_height, NAME => 'left_center'}, } elsif($name eq 'right_center') { return {X => $self->{WIDTH}, Y => $middle_height, NAME => 'right_center'}, } else { return ; } } #----------------------------------------------------------------------------- sub resize { my ($self, $reference_x, $reference_y, $new_x, $new_y) = @_ ; # if box is npt resizable return(0, 0, $self->{WIDTH}, $self->{HEIGHT}) ; #~ return(0, 0, $self->{WIDTH}, $self->{HEIGHT}) unless $self->{RESIZABLE} ; #~ my $new_end_x = $new_x ; #~ my $new_end_y = $new_y ; #~ if($new_end_x >= 0 && $new_end_y >= 0) #~ { #~ $self->setup($self->{TEXT_ONLY}, $new_end_x + 1, $new_end_y + 1, $self->{RESIZABLE}, $self->{EDITABLE}) ; #~ } #~ return(0, 0, $self->{WIDTH}, $self->{HEIGHT}) ; } #----------------------------------------------------------------------------- sub get_text { my ($self) = @_ ; return($self->{TEXT_ONLY}) ; } #----------------------------------------------------------------------------- sub set_text { my ($self, $text) = @_ ; $text = 'edit_me' if($text eq '') ; $self->setup($text, $self->{WIDTH}, $self->{HEIGHT}, $self->{RESIZABLE}, $self->{EDITABLE}) ; } #----------------------------------------------------------------------------- sub edit { my ($self) = @_ ; return unless $self->{EDITABLE} ; my ($text) = App::Asciio::display_edit_dialog($self, 'asciio', $self->{TEXT_ONLY}) ; my $tab_as_space = $self->{TAB_AS_SPACES} || (' ' x 3) ; $text =~ s/\t/$tab_as_space/g ; $self->set_text($text) ; } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.02.71/lib/App/Asciio/stripes/wirl_arrow.pm0000555000076400001440000004654111122301056021537 0ustar nadimusers package App::Asciio::stripes::wirl_arrow ; use base App::Asciio::stripes::stripes ; use strict; use warnings; use List::Util qw(min max) ; use Readonly ; use Clone ; #----------------------------------------------------------------------------- Readonly my $DEFAULT_ARROW_TYPE => [ #name: $start, $body, $connection, $body_2, $end ['origin', '', '*', '', '', '', 1], ['up', '|', '|', '', '', '^', 1], ['down', '|', '|', '', '', 'v', 1], ['left', '-', '-', '', '', '<', 1], ['upleft', '|', '|', '.', '-', '<', 1], ['leftup', '-', '-', '\'', '|', '^', 1], ['downleft', '|', '|', '\'', '-', '<', 1], ['leftdown', '-', '-', '.', '|', 'v', 1], ['right', '-', '-','', '', '>', 1], ['upright', '|', '|', '.', '-', '>', 1], ['rightup', '-', '-', '\'', '|', '^', 1], ['downright', '|', '|', '\'', '-', '>', 1], ['rightdown', '-', '-', '.', '|', 'v', 1], ['45', '/', '/', '', '', '^', 1, ], ['135', '\\', '\\', '', '', 'v', 1, ], ['225', '/', '/', '', '', 'v', 1, ], ['315', '\\', '\\', '', '', '^', 1, ], ] ; sub new { my ($class, $element_definition) = @_ ; my $self = bless {}, __PACKAGE__ ; $self->setup ( $element_definition->{ARROW_TYPE} || Clone::clone($DEFAULT_ARROW_TYPE), $element_definition->{END_X}, $element_definition->{END_Y}, $element_definition->{DIRECTION}, $element_definition->{ALLOW_DIAGONAL_LINES}, $element_definition->{EDITABLE}, ) ; return $self ; } #----------------------------------------------------------------------------- sub setup { my ($self, $arrow_type, $end_x, $end_y, $direction, $allow_diagonal_lines, $editable) = @_ ; my ($stripes, $width, $height) ; ($stripes, $width, $height, $direction) = get_arrow($arrow_type, $end_x, $end_y, $direction, $allow_diagonal_lines) ; $self->set ( STRIPES => $stripes, WIDTH => $width, HEIGHT => $height, DIRECTION => $direction, ARROW_TYPE => $arrow_type, END_X => $end_x, END_Y => $end_y, ALLOW_DIAGONAL_LINES => $allow_diagonal_lines, ) ; } #----------------------------------------------------------------------------- my %direction_to_arrow = ( 'origin' => \&draw_origin, 'up' => \&draw_up, 'down' => \&draw_down, 'left' => \&draw_left, 'up-left' => \&draw_upleft, 'left-up' => \&draw_leftup, 'down-left' => \&draw_downleft, 'left-down' => \&draw_leftdown, 'right' => \&draw_right, 'up-right' => \&draw_upright, 'right-up' => \&draw_rightup, 'down-right' => \&draw_downright, 'right-down' => \&draw_rightdown, ) ; sub get_arrow { my ($arrow_type, $end_x, $end_y, $direction, $allow_diagonal_lines) = @_ ; use constant CENTER => 1 ; use constant LEFT => 0 ; use constant RIGHT => 2 ; use constant UP => 0 ; use constant DOWN => 2 ; my @position_to_direction = ( [$direction =~ /^up/ ? 'up-left' : 'left-up', 'left', $direction =~ /^down/ ? 'down-left' : 'left-down'] , ['up', 'origin', 'down'], [$direction =~ /^up/ ? 'up-right' : 'right-up', 'right', $direction =~ /^down/ ? 'down-right' : 'right-down'], ) ; $direction = $position_to_direction [$end_x == 0 ? CENTER : $end_x < 0 ? LEFT : RIGHT] [$end_y == 0 ? CENTER : $end_y < 0 ? UP : DOWN] ; return($direction_to_arrow{$direction}->($arrow_type, $end_x, $end_y, $allow_diagonal_lines), $direction) ; } sub draw_down { my ($arrow_type, $end_x, $end_y) = @_ ; my ($stripes, $width, $height) = ([], 1, $end_y + 1) ; my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[2]}[1 .. 5] ; push @{$stripes}, { 'HEIGHT' => $height, 'TEXT' => $height == 2 ? "$start\n$end" : $start . "\n" . ("$body\n" x ($height -2)) . $end, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; return($stripes, $width, $height) ; } sub draw_origin { my ($arrow_type, $end_x, $end_y) = @_ ; my ($stripes, $width, $height) = ([], 1, 1) ; my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[0]}[1 .. 5] ; push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; return($stripes, $width, $height) ; } sub draw_up { my ($arrow_type, $end_x, $end_y) = @_ ; my ($stripes, $width, $height) = ([], 1, -$end_y + 1) ; my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[1]}[1 .. 5] ; push @{$stripes}, { 'HEIGHT' => $height, 'TEXT' => $height == 2 ? "$end\n$start" : $end . "\n" . ("$body\n" x ($height -2)) . $start, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => $end_y, }; return($stripes, $width, $height) ; } sub draw_left { my ($arrow_type, $end_x, $end_y) = @_ ; my ($stripes, $width, $height) = ([], -$end_x + 1, 1) ; my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[3]}[1 .. 5] ; push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $width == 2 ? "$end$start" : $end . $body x ($width -2) . $start, 'WIDTH' => $width, 'X_OFFSET' => $end_x, 'Y_OFFSET' => 0, }; return($stripes, $width, $height) ; } sub draw_upleft # or 315 { my ($arrow_type, $end_x, $end_y, $allow_diagonal_lines) = @_ ; my ($stripes, $width, $height) = ([], -$end_x + 1, -$end_y + 1) ; if($allow_diagonal_lines && $end_x == $end_y) { my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[16]}[1 .. 5] ; push @{$stripes}, get_315_stripes($end_x, $start, $body, $end) ; } else { my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[4]}[1 .. 5] ; push @{$stripes}, { 'HEIGHT' => $height , 'TEXT' => "$connection\n" . "$body\n" x ($height - 2) . $start, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => $end_y, }, { 'HEIGHT' => 1, 'TEXT' => $end . $body_2 x ($width - 2), 'WIDTH' => $width - 1, 'X_OFFSET' => $end_x, 'Y_OFFSET' => $end_y , }; } return($stripes, $width, $height) ; } sub draw_leftup # or 315 { my ($arrow_type, $end_x, $end_y, $allow_diagonal_lines) = @_ ; my ($stripes, $width, $height) = ([], -$end_x + 1, -$end_y + 1) ; my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[5]}[1 .. 5] ; if($allow_diagonal_lines && $end_x == $end_y) { my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[16]}[1 .. 5] ; push @{$stripes}, get_315_stripes($end_x, $start, $body, $end) ; } else { push @{$stripes}, { 'HEIGHT' => 1 , 'TEXT' => $connection . $body x ($width - 2) . $start, 'WIDTH' => $width, 'X_OFFSET' => $end_x, 'Y_OFFSET' => 0, }, { 'HEIGHT' => $height - 1, 'TEXT' => "$end\n" . "$body_2\n" x ($height - 2), 'WIDTH' => 1, 'X_OFFSET' => $end_x, 'Y_OFFSET' => $end_y , }; } return($stripes, $width, $height) ; } sub get_315_stripes { my ($position, $start, $body, $end) = @_ ; my @stripes ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; for(my $xy = -$position - 1 ; $xy> 0 ; $xy--) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => -$xy, 'Y_OFFSET' => -$xy, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => $position , 'Y_OFFSET' => $position , }; return(@stripes) ; } sub draw_downleft # or 225 { my ($arrow_type, $end_x, $end_y, $allow_diagonal_lines) = @_ ; my ($stripes, $width, $height) = ([], -$end_x + 1, $end_y + 1) ; my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[6]}[1 .. 5] ; if($allow_diagonal_lines && -$end_x == $end_y) { my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[15]}[1 .. 5] ; push @{$stripes}, get_225_stripes($end_x, $start, $body, $end) ; } else { push @{$stripes}, { 'HEIGHT' => $height , 'TEXT' => "$start\n" . "$body\n" x ($height - 2) . $connection, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }, { 'HEIGHT' => 1, 'TEXT' => $end . $body_2 x ($width - 2), 'WIDTH' => $width - 1, 'X_OFFSET' => $end_x, 'Y_OFFSET' => $end_y , }; } return($stripes, $width, $height) ; } sub draw_leftdown # or 225 { my ($arrow_type, $end_x, $end_y, $allow_diagonal_lines) = @_ ; my ($stripes, $width, $height) = ([], -$end_x + 1, $end_y + 1) ; my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[7]}[1 .. 5] ; if($allow_diagonal_lines && -$end_x == $end_y) { my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[15]}[1 .. 5] ; push @{$stripes}, get_225_stripes($end_x, $start, $body, $end) ; } else { push @{$stripes}, { 'HEIGHT' => 1 , 'TEXT' => $connection . $body x ($width - 2) . $start, 'WIDTH' => $width, 'X_OFFSET' => $end_x, 'Y_OFFSET' => 0, }, { 'HEIGHT' => $height - 1, 'TEXT' => "$body_2\n" x ($height - 2) . $end, 'WIDTH' => 1, 'X_OFFSET' => $end_x, 'Y_OFFSET' => 1 , }; } return($stripes, $width, $height) ; } sub get_225_stripes { my ($position, $start, $body, $end) = @_ ; my @stripes ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; for(my $xy = -$position - 1 ; $xy> 0 ; $xy--) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => -$xy, 'Y_OFFSET' => $xy, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => $position , 'Y_OFFSET' => -$position , }; return(@stripes) ; } sub draw_right { my ($arrow_type, $end_x, $end_y) = @_ ; my ($stripes, $width, $height) = ([], $end_x + 1, 1) ; my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[8]}[1 .. 5] ; push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $width == 2 ? "$start$end" : $start . $body x ($width -2) . $end, 'WIDTH' => $width, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; return($stripes, $width, $height) ; } sub draw_upright # or 45 { my ($arrow_type, $end_x, $end_y, $allow_diagonal_lines) = @_ ; my ($stripes, $width, $height) = ([], $end_x + 1, -$end_y + 1) ; my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[9]}[1 .. 5] ; if($allow_diagonal_lines && -$end_x == $end_y) { my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[13]}[1 .. 5] ; push @{$stripes}, get_45_stripes($end_x, $start, $body, $end) ; } else { push @{$stripes}, { 'HEIGHT' => $height , 'TEXT' => "$connection\n". "$body\n" x ($height -2) . $start, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => $end_y, }, { 'HEIGHT' => 1, 'TEXT' => $body_2 x ($width -2) . $end, 'WIDTH' => $end_x, 'X_OFFSET' => 1, 'Y_OFFSET' => $end_y, }; } return($stripes, $width, $height) ; } sub draw_rightup # or 45 { my ($arrow_type, $end_x, $end_y, $allow_diagonal_lines) = @_ ; my ($stripes, $width, $height) = ([], $end_x + 1, -$end_y + 1) ; my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[10]}[1 .. 5] ; if($allow_diagonal_lines && -$end_x == $end_y) { my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[13]}[1 .. 5] ; push @{$stripes}, get_45_stripes($end_x, $start, $body, $end) ; } else { push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $start . $body x ($width -2) . $connection, 'WIDTH' => $width, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }, { 'HEIGHT' => $height - 1, 'TEXT' => "$end\n" . "$body_2\n" x ($height -2), 'WIDTH' => 1, 'X_OFFSET' => $end_x, 'Y_OFFSET' => $end_y, }; } return($stripes, $width, $height) ; } sub get_45_stripes { my ($position, $start, $body, $end) = @_ ; my @stripes ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; for(my $xy = $position - 1 ; $xy > 0 ; $xy--) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => $xy, 'Y_OFFSET' => -$xy, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => $position , 'Y_OFFSET' => -$position , }; return(@stripes) ; } sub draw_downright # or 135 { my ($arrow_type, $end_x, $end_y, $allow_diagonal_lines) = @_ ; my ($stripes, $width, $height) = ([], $end_x + 1, $end_y + 1) ; my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[11]}[1 .. 5] ; if($allow_diagonal_lines && $end_x == $end_y) { my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[14]}[1 .. 5] ; push @{$stripes}, get_135_stripes($end_x, $start, $body, $end) ; } else { push @{$stripes}, { 'HEIGHT' => $height , 'TEXT' => "$start\n" ."$body\n" x ($height -2) . $connection, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }, { 'HEIGHT' => 1, 'TEXT' => $body_2 x ($width -2) . $end, 'WIDTH' => $width - 1, 'X_OFFSET' => 1, 'Y_OFFSET' => $end_y, }; } return($stripes, $width, $height) ; } sub draw_rightdown # or 135 { my ($arrow_type, $end_x, $end_y, $allow_diagonal_lines) = @_ ; my ($stripes, $width, $height) = ([], $end_x + 1, $end_y + 1) ; my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[12]}[1 .. 5] ; if($allow_diagonal_lines && $end_x == $end_y) { my ($start, $body, $connection, $body_2, $end) = @{$arrow_type->[14]}[1 .. 5] ; push @{$stripes}, get_135_stripes($end_x, $start, $body, $end) ; } else { push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $start . $body x ($width -2) . $connection, 'WIDTH' => $width, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }, { 'HEIGHT' => $height - 1 , 'TEXT' => "$body_2\n" x ($height -2) . $end, 'WIDTH' => 1, 'X_OFFSET' => $end_x, 'Y_OFFSET' => 1, }; } return($stripes, $width, $height) ; } sub get_135_stripes { my ($position, $start, $body, $end) = @_ ; my @stripes ; push @stripes, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => 0 , 'Y_OFFSET' => 0 , }; for(my $xy = 1 ; $xy < $position ; $xy++) { push @stripes, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => $xy, 'Y_OFFSET' => $xy, }; } push @stripes, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => $position, 'Y_OFFSET' => $position, }; return(@stripes) ; } #----------------------------------------------------------------------------- sub get_selection_action { my ($self, $x, $y) = @_ ; if ( ($x == 0 && $y == 0) || ($x == $self->{END_X} && $y == $self->{END_Y}) ) { 'resize' ; } else { 'move' ; } } #----------------------------------------------------------------------------- sub get_connector_points { my ($self) = @_ ; return ( {X => 0, Y => 0, NAME => 'start'}, {X => $self->{END_X}, Y => $self->{END_Y}, NAME => 'end'}, ) ; } #----------------------------------------------------------------------------- sub get_named_connection { my ($self, $name) = @_ ; if($name eq 'start') { return( {X => 0, Y => 0, NAME => 'start'} ) ; } elsif($name eq 'end') { return( {X => $self->{END_X}, Y => $self->{END_Y}, NAME => 'end'} ) ; } else { return ; } } #----------------------------------------------------------------------------- sub get_section_direction { my ($self, $section_index) = @_ ; return $self->{DIRECTION} ; } #----------------------------------------------------------------------------- sub move_connector { my ($self, $connector_name, $x_offset, $y_offset, $hint) = @_ ; if($connector_name eq 'start') { my ($x_offset, $y_offset, $width, $height, undef) = $self->resize(0, 0, $x_offset, $y_offset, $hint) ; return $x_offset, $y_offset, $width, $height, {X => $self->{END_X}, Y => $self->{END_Y}, NAME => 'start'} ; } elsif($connector_name eq 'end') { my ($x_offset, $y_offset, $width, $height, undef) = $self->resize(-1, -1, $self->{END_X} + $x_offset, $self->{END_Y} + $y_offset, $hint) ; return $x_offset, $y_offset, $width, $height, {X => $self->{END_X}, Y => $self->{END_Y}, NAME => 'end'} ; } else { die "unknown connector '$connector_name'!\n" ; } } #----------------------------------------------------------------------------- sub resize { my ($self, $reference_x, $reference_y, $new_x, $new_y, $hint, $connector_name) = @_ ; my $is_start ; if(defined $connector_name) { if($connector_name eq 'start') { $is_start++ ; } } else { if($reference_x == 0 && $reference_y == 0) { $is_start++ ; } } if($is_start) { my $x_offset = $new_x ; my $y_offset = $new_y ; my $new_end_x = $self->{END_X} - $x_offset ; my $new_end_y = $self->{END_Y} - $y_offset ; $self->setup($self->{ARROW_TYPE}, $new_end_x, $new_end_y, $hint || $self->{DIRECTION},$self ->{ALLOW_DIAGONAL_LINES}, $self->{EDITABLE}) ; return($x_offset, $y_offset, $self->{WIDTH}, $self->{HEIGHT}, 'start') ; } else { my $new_end_x = $new_x ; my $new_end_y = $new_y ; $self->setup($self->{ARROW_TYPE}, $new_end_x, $new_end_y, $hint || $self->{DIRECTION}, $self ->{ALLOW_DIAGONAL_LINES}, $self->{EDITABLE}) ; return(0, 0, $self->{WIDTH}, $self->{HEIGHT}, 'end') ; } } #----------------------------------------------------------------------------- sub edit { my ($self) = @_ ; return unless $self->{EDITABLE} ; display_arrow_edit_dialog($self->{ARROW_TYPE}) ; # inline modification my ($stripes, $width, $height, $x_offset, $y_offset) = $direction_to_arrow{$self->{DIRECTION}}->($self->{ARROW_TYPE}, $self->{END_X}, $self->{END_Y}) ; $self->set(STRIPES => $stripes,) ; } use Glib ':constants'; use Gtk2 -init; use Glib qw(TRUE FALSE); sub display_arrow_edit_dialog { my ($rows) = @_ ; my $window = new Gtk2::Window() ; my $dialog = Gtk2::Dialog->new('Arrow attributes', $window, 'destroy-with-parent') ; $dialog->set_default_size (450, 505); $dialog->add_button ('gtk-ok' => 'ok'); #~ my $vbox = $dialog->vbox ; my $dialog_vbox = $dialog->vbox ; my $vbox = Gtk2::VBox->new (FALSE, 5); $dialog_vbox->pack_start ($vbox, TRUE, TRUE, 0); $vbox->pack_start (Gtk2::Label->new (""), FALSE, FALSE, 0); my $sw = Gtk2::ScrolledWindow->new; $sw->set_shadow_type ('etched-in'); $sw->set_policy ('automatic', 'automatic'); $vbox->pack_start ($sw, TRUE, TRUE, 0); # create model my $model = create_model ($rows); # create tree view my $treeview = Gtk2::TreeView->new_with_model ($model); $treeview->set_rules_hint (TRUE); $treeview->get_selection->set_mode ('single'); add_columns($treeview, $rows); $sw->add($treeview); $treeview->show() ; $vbox->show() ; $sw->show() ; $dialog->run() ; $dialog->destroy ; } #----------------------------------------------------------------------------- sub create_model { my ($rows) = @_ ; my $model = Gtk2::ListStore->new(qw/Glib::String Glib::String Glib::String Glib::String Glib::String Glib::String Glib::Boolean/); foreach my $row (@{$rows}) { my $iter = $model->append; my $column = 0 ; $model->set ($iter, map {$column++, $_} @{$row}) ; } return $model; } #----------------------------------------------------------------------------- sub add_columns { my ($treeview, $rows) = @_ ; my $model = $treeview->get_model; # column for row titles my $row_renderer = Gtk2::CellRendererText->new; $row_renderer->set_data (column => 0); $treeview->insert_column_with_attributes ( -1, '', $row_renderer, text => 0, ) ; my $column = $treeview->get_column(0) ; $column->set_sizing('fixed') ; $column->set_fixed_width(120) ; my $current_column = 1 ; for my $column_title('start', 'body', 'connection', 'body_2', 'end') { my $renderer = Gtk2::CellRendererText->new; $renderer->signal_connect (edited => \&cell_edited, [$model, $rows]); $renderer->set_data (column => $current_column ); $treeview->insert_column_with_attributes ( -1, $column_title, $renderer, text => $current_column, editable => 6, ); $current_column++ ; } } #----------------------------------------------------------------------------- sub cell_edited { my ($cell, $path_string, $new_text, $model_and_rows) = @_; my ($model, $rows) = @{$model_and_rows} ; my $path = Gtk2::TreePath->new_from_string ($path_string); my $column = $cell->get_data ("column"); my $iter = $model->get_iter($path); my $row = ($path->get_indices)[0]; $rows->[$row][$column] = $new_text ; $model->set($iter, $column, $new_text); } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.02.71/lib/App/Asciio/stripes/editable_box2.pm0000555000076400001440000002753011122301056022050 0ustar nadimusers package App::Asciio::stripes::editable_box2 ; use base App::Asciio::stripes::single_stripe ; use strict; use warnings; use List::Util qw(min max) ; use Readonly ; use Clone ; #----------------------------------------------------------------------------- Readonly my $DEFAULT_BOX_TYPE => [ [1, 'top', '.', '-', '.', 1, ], [0, 'title separator', '|', '-', '|', 1, ], [1, 'body separator', '| ', '|', ' |', 1, ], [1, 'bottom', '\'', '-', '\'', 1, ], ] ; sub new { my ($class, $element_definition) = @_ ; my $self = bless {}, __PACKAGE__ ; $self->setup ( $element_definition->{TEXT_ONLY}, $element_definition->{TITLE}, $element_definition->{BOX_TYPE} || Clone::clone($DEFAULT_BOX_TYPE), 1, 1, $element_definition->{RESIZABLE}, $element_definition->{EDITABLE}, $element_definition->{AUTO_SHRINK}, ) ; return $self ; } #----------------------------------------------------------------------------- sub setup { my ($self, $text_only, $title_text, $box_type, $end_x, $end_y, $resizable, $editable, $auto_shrink) = @_ ; my ($text_width, @lines) = (0) ; for my $line (split("\n", $text_only)) { $text_width = max($text_width, length($line)) ; push @lines, $line ; } my ($title_width, @title_lines) = (0) ; $title_text = '' unless defined $title_text ; for my $title_line (split("\n", $title_text)) { $title_width = max($title_width, length($title_line)) ; push @title_lines, $title_line ; } my ($extra_width, $extra_height) = get_box_frame_size_overhead($box_type) ; my $display_title = (defined $title_text and $title_text ne '') ? 1 : 0 ; $text_width = max($text_width, $title_width) if $display_title; if($auto_shrink) { ($end_x, $end_y) = (-5, -5) ; } $end_x = max($end_x, $text_width + $extra_width, $title_width + $extra_width) ; $end_y = max($end_y, scalar(@lines) + $extra_height + scalar(@title_lines)) ; my ($box_top, $box_left, $box_right, $box_bottom, $title_separator, $title_left, $title_right) = get_box_frame_elements($box_type, $end_x) ; my $text = $box_top ; for my $title_line (@title_lines) { my $pading = ($end_x - (length($title_left . $title_line . $title_right))) ; my $left_pading = int($pading / 2) ; my $right_pading = $pading - $left_pading ; $text .= $title_left . (' ' x $left_pading) . $title_line . (' ' x $right_pading) . $title_right ."\n" ; } $text .= $title_separator ; for my $line (@lines) { $text .= $box_left . $line . (' ' x ($end_x - (length($line) + $extra_width))) . $box_right . "\n" ; } for (1 .. ($end_y - (@lines + $extra_height + @title_lines))) { $text .= $box_left . (' ' x ($end_x - $extra_width)) . $box_right . "\n" ; } $text .= $box_bottom ; $self->set ( TEXT => $text, TITLE => $title_text, WIDTH => $end_x, HEIGHT => $end_y, TEXT_ONLY => $text_only, BOX_TYPE => $box_type, RESIZABLE => $resizable, EDITABLE => $editable, ) ; } #----------------------------------------------------------------------------- use Readonly ; Readonly my $TOP => 0 ; Readonly my $TITLE_SEPARATOR => 1 ; Readonly my $BODY_SEPARATOR => 2 ; Readonly my $BOTTOM => 3; Readonly my $DISPLAY => 0 ; Readonly my $NAME => 1 ; Readonly my $LEFT => 2 ; Readonly my $BODY => 3 ; Readonly my $RIGHT => 4 ; sub get_box_frame_size_overhead { my ($box_type) = @_ ; my @displayed_elements = grep { $_->[$DISPLAY] } @{$box_type} ; my $extra_width = max(0, map {length} map {$_->[$LEFT]}@displayed_elements) + max(0, map {length} map {$_->[$RIGHT]}@displayed_elements) ; my $extra_height = 0 ; for ($TOP, $TITLE_SEPARATOR, $BOTTOM) { $extra_height++ if defined $box_type->[$_][$DISPLAY] && $box_type->[$_][$DISPLAY] ; } return($extra_width, $extra_height) ; } sub get_box_frame_elements { my ($box_type, $width) = @_ ; my ($box_top, $box_left, $box_right, $box_bottom, $title_separator, $title_left, $title_right) = map {''} (1 .. 7) ; if($box_type->[$TOP][$DISPLAY]) { my $box_left_and_right_length = length($box_type->[$TOP][$LEFT]) + length($box_type->[$TOP][$RIGHT]) ; $box_top = $box_type->[$TOP][$LEFT] . ($box_type->[$TOP][$BODY] x ($width - $box_left_and_right_length)) . $box_type->[$TOP][$RIGHT] . "\n" ; } $title_left = $box_type->[$TITLE_SEPARATOR][$LEFT] if($box_type->[$BODY_SEPARATOR][$DISPLAY]) ; $title_right = $box_type->[$TITLE_SEPARATOR][$RIGHT] if($box_type->[$BODY_SEPARATOR][$DISPLAY]) ; if($box_type->[$TITLE_SEPARATOR][$DISPLAY]) { my $title_left_and_right_length = length($title_left) + length($title_right) ; my $title_separator_body = $box_type->[$TITLE_SEPARATOR][$BODY] ; $title_separator_body = ' ' unless defined $title_separator_body ; $title_separator_body = ' ' if $title_separator_body eq '' ; $title_separator = $title_left . ($title_separator_body x ($width - $title_left_and_right_length)) . $title_right . "\n" ; } $box_left = $box_type->[$BODY_SEPARATOR][$LEFT] if($box_type->[$BODY_SEPARATOR][$DISPLAY]) ; $box_right = $box_type->[$BODY_SEPARATOR][$RIGHT] if($box_type->[$BODY_SEPARATOR][$DISPLAY]) ; if($box_type->[$BOTTOM][$DISPLAY]) { my $box_left_and_right_length = length($box_type->[$BOTTOM][$LEFT]) + length($box_type->[$BOTTOM][$RIGHT]) ; $box_bottom = $box_type->[$BOTTOM][$LEFT] . ($box_type->[$BOTTOM][$BODY] x ($width - $box_left_and_right_length)) . $box_type->[$BOTTOM][$RIGHT] ; } return ($box_top, $box_left, $box_right, $box_bottom, $title_separator, $title_left, $title_right) ; } #----------------------------------------------------------------------------- sub get_selection_action { my ($self, $x, $y) = @_ ; if ( ($x == $self->{WIDTH} - 1 && $y == $self->{HEIGHT} - 1) ) { 'resize' ; } else { 'move' ; } } #----------------------------------------------------------------------------- sub match_connector { my ($self, $x, $y) = @_ ; my $middle_width = int($self->{WIDTH} / 2) ; my $middle_height = int($self->{HEIGHT} / 2) ; if($x == $middle_width && $y == -1) { return {X => $x, Y => $y, NAME => 'top_center'} ; } elsif($x == $middle_width && $y == $self->{HEIGHT}) { return {X => $x, Y => $y, NAME => 'bottom_center'} ; } if($x == -1 && $y == $middle_height) { return {X => $x, Y => $y, NAME => 'left_center'} ; } elsif($x == $self->{WIDTH} && $y == $middle_height) { return {X => $x, Y => $y, NAME => 'right_center'} ; } elsif($x >= 0 && $x < $self->{WIDTH} && $y >= 0 && $y < $self->{HEIGHT}) { return {X => $middle_width, Y => -1, NAME => 'to_be_optimized'} ; } elsif($self->{ALLOW_BORDER_CONNECTION} && $x >= -1 && $x <= $self->{WIDTH} && $y >= -1 && $y <= $self->{HEIGHT}) { return {X => $x, Y => $y, NAME => 'border'} ; } else { return ; } } #----------------------------------------------------------------------------- sub get_connection_points { my ($self) = @_ ; my $middle_width = int($self->{WIDTH} / 2) ; my $middle_height = int($self->{HEIGHT} / 2) ; return ( {X => $middle_width, Y => -1, NAME => 'top_center'}, {X => $middle_width, Y => $self->{HEIGHT}, NAME => 'bottom_center'}, {X => -1, Y => $middle_height, NAME => 'left_center'}, {X => $self->{WIDTH}, Y => $middle_height, NAME => 'right_center'}, ) ; } #----------------------------------------------------------------------------- sub get_extra_points { my ($self) = @_ ; if($self->{RESIZABLE} && ! $self->is_auto_shrink()) { return {X => $self->{WIDTH} - 1, Y => $self->{HEIGHT} - 1, NAME => 'resize'} ; } else { return ; } } #----------------------------------------------------------------------------- sub get_named_connection { my ($self, $name) = @_ ; my $middle_width = int($self->{WIDTH} / 2) ; my $middle_height = int($self->{HEIGHT} / 2) ; if($name eq 'top_center') { return( {X => $middle_width, Y => -1, NAME => 'top_center'} ) ; } elsif($name eq 'bottom_center') { return( {X => $middle_width, Y => $self->{HEIGHT}, NAME => 'bottom_center'} ) ; } elsif($name eq 'left_center') { return {X => -1, Y => $middle_height, NAME => 'left_center'}, } elsif($name eq 'right_center') { return {X => $self->{WIDTH}, Y => $middle_height, NAME => 'right_center'}, } else { return ; } } #----------------------------------------------------------------------------- sub allow_border_connection { my($self, $allow) = @_ ; $self->{ALLOW_BORDER_CONNECTION} = $allow ; } #----------------------------------------------------------------------------- sub is_border_connection_allowed { my($self) = @_ ; return $self->{ALLOW_BORDER_CONNECTION} ; } #----------------------------------------------------------------------------- sub flip_auto_shrink { my($self) = @_ ; $self->{AUTO_SHRINK} ^= 1 ; } #----------------------------------------------------------------------------- sub is_auto_shrink { my($self) = @_ ; return $self->{AUTO_SHRINK} ; } #----------------------------------------------------------------------------- sub resize { my ($self, $reference_x, $reference_y, $new_x, $new_y) = @_ ; return(0, 0, $self->{WIDTH}, $self->{HEIGHT}) unless $self->{RESIZABLE} ; my $new_end_x = $new_x ; my $new_end_y = $new_y ; if($new_end_x >= 0 && $new_end_y >= 0) { $self->setup ( $self->{TEXT_ONLY}, $self->{TITLE}, $self->{BOX_TYPE}, $new_end_x + 1, $new_end_y + 1, $self->{RESIZABLE}, $self->{EDITABLE}, $self->{AUTO_SHRINK}, ) ; } return(0, 0, $self->{WIDTH}, $self->{HEIGHT}) ; } #----------------------------------------------------------------------------- sub get_text { my ($self) = @_ ; return($self->{TITLE}, $self->{TEXT_ONLY}) ; } #----------------------------------------------------------------------------- sub set_text { my ($self, $title, $text) = @_ ; my @displayed_elements = grep { $_->[$DISPLAY] } @{$self->{BOX_TYPE}} ; $text = 'edit_me' if($text eq '' && @displayed_elements == 0) ; $self->setup ( $text, $title, $self->{BOX_TYPE}, $self->{WIDTH}, $self->{HEIGHT}, $self->{RESIZABLE}, $self->{EDITABLE}, $self->{AUTO_SHRINK}, ) ; } #----------------------------------------------------------------------------- sub get_box_type { my ($self) = @_ ; return($self->{BOX_TYPE}) ; } #----------------------------------------------------------------------------- sub set_box_type { my ($self, $box_type) = @_ ; $self->setup ( $self->{TEXT_ONLY}, $self->{TITLE}, $box_type, $self->{WIDTH}, $self->{HEIGHT}, $self->{RESIZABLE}, $self->{EDITABLE}, $self->{AUTO_SHRINK}, ) ; } #----------------------------------------------------------------------------- sub edit { my ($self) = @_ ; return unless $self->{EDITABLE} ; my $text = $self->{TEXT_ONLY} ; $text = make_vertical_text($text) if $self->{VERTICAL_TEXT} ; ($text, my $title) = App::Asciio::display_box_edit_dialog($self->{BOX_TYPE}, $self->{TITLE}, $text) ; my $tab_as_space = $self->{TAB_AS_SPACES} || (' ' x 3) ; $text =~ s/\t/$tab_as_space/g ; $title=~ s/\t/$tab_as_space/g ; $text = make_vertical_text($text) if $self->{VERTICAL_TEXT} ; $self->set_text($title, $text) ; } #----------------------------------------------------------------------------- sub rotate_text { my ($self) = @_ ; my $text = make_vertical_text($self->{TEXT_ONLY}) ; $self->set_text($self->{TITLE}, $text) ; $self->shrink() ; $self->{VERTICAL_TEXT} ^= 1 ; } #----------------------------------------------------------------------------- sub shrink { my ($self) = @_ ; $self->setup ( $self->{TEXT_ONLY}, $self->{TITLE}, $self->{BOX_TYPE}, -5, -5, $self->{RESIZABLE}, $self->{EDITABLE}, $self->{AUTO_SHRINK}, ) ; } #----------------------------------------------------------------------------- sub make_vertical_text { my ($text) = @_ ; my @lines = map{[split '', $_]} split "\n", $text ; my $vertical = '' ; my $found_character = 1 ; my $index = 0 ; while($found_character) { my $line ; $found_character = 0 ; for(@lines) { if(defined $_->[$index]) { $line.= $_->[$index] ; $found_character++ ; } else { $line .= ' ' ; } } $line =~ s/\s+$//; $vertical .= "$line\n" if $found_character ; $index++ ; } return $vertical ; } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.02.71/lib/App/Asciio/stripes/stripes.pm0000555000076400001440000000742311122301056021035 0ustar nadimusers package App::Asciio::stripes::stripes ; use strict; use warnings; use List::MoreUtils qw(minmax) ; sub new { my ($class, $element_definition) = @_ ; my @stripes ; my ($total_width, $total_height) = (0, 0) ; for my $stripe (@{$element_definition->{STRIPES}}) { my $text = $stripe->{TEXT} ; my $width = 0 ; map {$width = $width < length($_) ? length($_) : $width} split("\n", $text) ; my $height = ($text =~ tr[\n][\n]) + 1 ; push @stripes, { TEXT => $text, X_OFFSET => $stripe->{X_OFFSET}, Y_OFFSET => $stripe->{Y_OFFSET}, WIDTH => $width, HEIGHT => $height , } ; (undef, $total_width) = minmax($total_width, $stripe->{X_OFFSET} + $width) ; (undef, $total_height) = minmax($total_height, $stripe->{Y_OFFSET} + $height) ; } return bless { STRIPES => \@stripes, WIDTH => $total_width, HEIGHT => $total_height, }, __PACKAGE__ ; } #--------------------------------------------------------------------------- sub get_mask_and_element_stripes { my ($self) = @_ ; my @elements_stripes ; for my $stripe (@{$self->{STRIPES}}) { push @elements_stripes, {X_OFFSET => $stripe->{X_OFFSET}, Y_OFFSET => $stripe->{Y_OFFSET}, WIDTH => $stripe->{WIDTH}, HEIGHT => $stripe->{HEIGHT}, TEXT => $stripe->{TEXT}} ; } return(@elements_stripes) ; } #----------------------------------------------------------------------------- sub get_size { my ($self) = @_ ; return($self->{WIDTH}, $self->{HEIGHT}) ; } #----------------------------------------------------------------------------- sub resize { my ($self, $reference_x, $reference_y, $new_x, $new_y) = @_ ; return(0, 0, $self->{WIDTH}, $self->{HEIGHT}) ; } #----------------------------------------------------------------------------- sub get_action_menu_entries { } #----------------------------------------------------------------------------- sub get_selection_action { 'move' ; } #----------------------------------------------------------------------------- sub get_colors { my ($self) = @_ ; return $self->{COLORS}{BACKGROUND}, $self->{COLORS}{FOREGROUND} ; } #----------------------------------------------------------------------------- sub set_background_color { my ($self, $background_color) = @_ ; $self->{COLORS}{BACKGROUND} = $background_color ; } #----------------------------------------------------------------------------- sub set_foreground_color { my ($self, $foreground_color) = @_ ; $self->{COLORS}{FOREGROUND} = $foreground_color ; } #----------------------------------------------------------------------------- sub set_colors { my ($self, $background_color, $foreground_color) = @_ ; $self->{COLORS}{BACKGROUND} = $background_color ; $self->{COLORS}{FOREGROUND} = $foreground_color ; } #----------------------------------------------------------------------------- sub get_text { } #----------------------------------------------------------------------------- sub set_text { } #----------------------------------------------------------------------------- sub edit { } #----------------------------------------------------------------------------- sub match_connector { } #----------------------------------------------------------------------------- sub get_connector_points { } sub get_connection_points { } sub get_extra_points { } #----------------------------------------------------------------------------- sub get_named_connection { } #----------------------------------------------------------------------------- sub move_connector { } #----------------------------------------------------------------------------- sub set { # set fields in the hash my ($self, %key_values) = @_ ; while (my ($key, $value) = each %key_values) { #~ print "setting $key, $value\n" ; $self->{$key} = ${value} ; } } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.02.71/lib/App/Asciio/stripes/single_stripe.pm0000555000076400001440000000306711122301056022213 0ustar nadimusers package App::Asciio::stripes::single_stripe ; use base App::Asciio::stripes::stripes ; use strict; use warnings; sub new { my ($class, $element_definition) = @_ ; my $self = bless {}, __PACKAGE__ ; $self->setup($element_definition->{TEXT}) ; return($self) ; } #----------------------------------------------------------------------------- sub setup { my ($self, $text) = @_ ; my $width = 0 ; map {$width = $width < length($_) ? length($_) : $width} split("\n", $text) ; my $height = ($text =~ tr[\n][\n]) + 1 ; $self->set ( TEXT => $text, WIDTH => $width, HEIGHT => $height, ) ; } #----------------------------------------------------------------------------- sub get_mask_and_element_stripes { my ($self) = @_ ; return {X_OFFSET => 0, Y_OFFSET => 0, WIDTH => $self->{WIDTH}, HEIGHT => $self->{HEIGHT}, TEXT => $self->{TEXT}} ; } #----------------------------------------------------------------------------- sub get_size { my ($self) = @_ ; return($self->{WIDTH}, $self->{HEIGHT}) ; } #----------------------------------------------------------------------------- sub resize { my ($self, $reference_x, $reference_y, $new_x, $new_y) = @_ ; return(0, 0, $self->{WIDTH}, $self->{HEIGHT}) ; } #----------------------------------------------------------------------------- sub get_text { my ($self) = @_ ; return($self->{TEXT}) ; } #----------------------------------------------------------------------------- sub set_text { my ($self, $text) = @_ ; $self->setup($text) ; } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.02.71/lib/App/Asciio/stripes/section_wirl_arrow.pm0000555000076400001440000005564011122301056023263 0ustar nadimusers package App::Asciio::stripes::section_wirl_arrow ; use base App::Asciio::stripes::stripes ; use strict; use warnings; use List::Util qw(min max) ; use Readonly ; use Clone ; use App::Asciio::stripes::wirl_arrow ; #----------------------------------------------------------------------------- # the idea is to reuse wirl arrow implementation as much as possible #----------------------------------------------------------------------------- Readonly my $DEFAULT_ARROW_TYPE => [ ['origin', '', '*', '', '', '', 1], ['up', '|', '|', '', '', '^', 1], ['down', '|', '|', '', '', 'v', 1], ['left', '-', '-', '', '', '<', 1], ['upleft', '|', '|', '.', '-', '<', 1], ['leftup', '-', '-', '\'', '|', '^', 1], ['downleft', '|', '|', '\'', '-', '<', 1], ['leftdown', '-', '-', '.', '|', 'v', 1], ['right', '-', '-','', '', '>', 1], ['upright', '|', '|', '.', '-', '>', 1], ['rightup', '-', '-', '\'', '|', '^', 1], ['downright', '|', '|', '\'', '-', '>', 1], ['rightdown', '-', '-', '.', '|', 'v', 1], ['45', '/', '/', '', '', '^', 1, ], ['135', '\\', '\\', '', '', 'v', 1, ], ['225', '/', '/', '', '', 'v', 1, ], ['315', '\\', '\\', '', '', '^', 1, ], ] ; # constants for connector overlays Readonly my $body_index => 2 ; Readonly my $connection_index => 3 ; Readonly my $up_index=> 1 ; Readonly my $left_index=> 3 ; Readonly my $leftup_index => 5 ; Readonly my $leftdown_index => 7 ; sub new { my ($class, $element_definition) = @_ ; my $self = bless {}, __PACKAGE__ ; $self->setup ( $element_definition->{ARROW_TYPE} || Clone::clone($DEFAULT_ARROW_TYPE), $element_definition->{POINTS}, $element_definition->{DIRECTION}, $element_definition->{ALLOW_DIAGONAL_LINES}, $element_definition->{EDITABLE}, $element_definition->{NOT_CONNECTABLE_START}, $element_definition->{NOT_CONNECTABLE_END}, ) ; return $self ; } #----------------------------------------------------------------------------- sub setup { my ($self, $arrow_type, $points, $direction, $allow_diagonal_lines, $editable, $not_connectable_start, $not_connectable_end) = @_ ; if('ARRAY' eq ref $points && @{$points} > 0) { my ($start_x, $start_y, $arrows) = (0, 0, []) ; my $points_offsets ; my $arrow_index = 0 ; # must have a numeric index or 'undo' won't work for my $point (@{$points}) { my ($x, $y, $point_direction) = @{$point} ; my $arrow = new App::Asciio::stripes::wirl_arrow ({ ARROW_TYPE => $arrow_type, END_X => $x - $start_x, END_Y => $y - $start_y, DIRECTION => $point_direction || $direction, ALLOW_DIAGONAL_LINES => $allow_diagonal_lines, EDITABLE => $editable, }) ; $points_offsets->[$arrow_index++] = [$start_x, $start_y] ; push @{$arrows}, $arrow ; ($start_x, $start_y) = ($x, $y) ; } $self->set ( POINTS_OFFSETS => $points_offsets, ARROWS => $arrows, # keep data to allow section insertion later ARROW_TYPE => $arrow_type, DIRECTION => $direction, ALLOW_DIAGONAL_LINES => $allow_diagonal_lines, EDITABLE => $editable, NOT_CONNECTABLE_START => $not_connectable_start, NOT_CONNECTABLE_END => $not_connectable_end, ) ; my ($width, $height) = $self->get_width_and_height() ; $self->set ( WIDTH => $width, HEIGHT => $height, ) ; } else { die "Bad 'section wirl arrow' defintion! Expecting points array." ; } } #----------------------------------------------------------------------------- my %diagonal_direction_to_overlay_character = ( (map {$_ => q{\\}} qw( down-right right-down up-left left-up)), (map {$_ => q{/}} qw( down-left left-down up-right right-up)), ) ; my %diagonal_non_diagonal_to_overlay_character = ( (map {$_ => q{.}} qw( down-right right-down up-left left-up)), (map {$_ => q{'}} qw( down-left left-down up-right right-up)), ) ; sub get_mask_and_element_stripes { my ($self) = @_ ; my @mask_and_element_stripes ; my $arrow_index = 0 ; for my $arrow(@{$self->{ARROWS}}) { push @mask_and_element_stripes, map { $_->{X_OFFSET} += $self->{POINTS_OFFSETS}[$arrow_index][0] ; $_->{Y_OFFSET} += $self->{POINTS_OFFSETS}[$arrow_index][1]; $_ ; } $arrow->get_mask_and_element_stripes() ; $arrow_index++ ; } # handle connections my ($previous_direction) = ($self->{ARROWS}[0]{DIRECTION} =~ /^([^-]+)-/) ; $previous_direction ||= $self->{ARROWS}[0]{DIRECTION} ; my $previous_was_diagonal ; $arrow_index = 0 ; for my $arrow(@{$self->{ARROWS}}) { # the whole computation can be skipped if a single section is present my ($connection, $d1, $d2) ; unless(($d1, $d2) = ($arrow->{DIRECTION} =~ /^([^-]+)-(.*)$/)) { $d1 = $arrow->{DIRECTION}; } if($self->{ALLOW_DIAGONAL_LINES} && $arrow->{WIDTH} == $arrow->{HEIGHT}) { # this arrow is diagonal if ( $previous_was_diagonal && ($previous_was_diagonal eq $arrow->{DIRECTION} || $previous_was_diagonal eq "$d2-$d1") ) { # two diagonals going in the same direction $connection = $diagonal_direction_to_overlay_character{$arrow->{DIRECTION}} ; } else { # previous non diagonal or two diagonals not going in the same direction $connection = ($d1 eq 'up' || $d2 eq 'up') ? q{'} : q{.} ; } $previous_was_diagonal = $arrow->{DIRECTION} ; } else { # straight or angled arrow if(defined $previous_was_diagonal) { $connection = $previous_was_diagonal =~ /down/ ? q{'} : q{.} ; } else { if($previous_direction ne $d1) { $connection = $self->{ARROW_TYPE}[$left_index][$body_index] ; # for left and right, up down cases handled below if($d1 eq 'down') { $connection = $self->{ARROW_TYPE}[$leftdown_index][$connection_index] ; } elsif($d1 eq 'up') { $connection = $self->{ARROW_TYPE}[$leftup_index][$connection_index] ; } elsif($previous_direction eq 'down') { $connection = $self->{ARROW_TYPE}[$leftup_index][$connection_index] ; } elsif($previous_direction eq 'up') { $connection = $self->{ARROW_TYPE}[$leftdown_index][$connection_index] ; } } } $previous_direction = defined $d2 ? $d2 : $d1 ; $previous_was_diagonal = undef ; } if($arrow_index != 0 && defined $connection) # first character of the first section is always right { # overlay the first character of this arrow push @mask_and_element_stripes, { X_OFFSET => $self->{POINTS_OFFSETS}[$arrow_index][0], Y_OFFSET => $self->{POINTS_OFFSETS}[$arrow_index][1], WIDTH => 1, HEIGHT => 1, TEXT => $connection, } ; } $arrow_index++ ; } return(@mask_and_element_stripes) ; } #----------------------------------------------------------------------------- sub get_selection_action { my ($self, $x, $y) = @_ ; my $action = 'move' ; my $arrow_index = 0 ; for my $arrow(@{$self->{ARROWS}}) { my ($start_connector, $end_connector) = $arrow->get_connector_points() ; $start_connector->{X} += $self->{POINTS_OFFSETS}[$arrow_index][0] ; $start_connector->{Y} += $self->{POINTS_OFFSETS}[$arrow_index][1] ; if($x == $start_connector->{X} && $y == $start_connector->{Y}) { $action = 'resize' ; last ; } $end_connector->{X} += $self->{POINTS_OFFSETS}[$arrow_index][0] ; $end_connector->{Y} += $self->{POINTS_OFFSETS}[$arrow_index][1] ; if($x == $end_connector->{X} && $y == $end_connector->{Y}) { $action = 'resize' ; last ; } $arrow_index++ ; } return $action ; } #----------------------------------------------------------------------------- sub is_autoconnect_enabled { my ($self) = @_ ; return ! $self->{AUTOCONNECT_DISABLED} ; } #----------------------------------------------------------------------------- sub enable_autoconnect { my ($self, $enable) = @_ ; $self->{AUTOCONNECT_DISABLED} = !$enable ; } #----------------------------------------------------------------------------- sub allow_connection { my ($self, $which, $connect) = @_ ; if($which eq 'start') { $self->{NOT_CONNECTABLE_START} = !$connect ; } else { $self->{NOT_CONNECTABLE_END} = !$connect ; } } #----------------------------------------------------------------------------- sub is_connection_allowed { my ($self, $which) = @_ ; if($which eq 'start') { return(! $self->{NOT_CONNECTABLE_START}) ; } else { return(! $self->{NOT_CONNECTABLE_END}) ; } } #----------------------------------------------------------------------------- sub are_diagonals_allowed { my ($self, $allow) = @_ ; return $self->{ALLOW_DIAGONAL_LINES} ; } #----------------------------------------------------------------------------- sub allow_diagonals { my ($self, $allow) = @_ ; $self->{ALLOW_DIAGONAL_LINES} = $allow ; for my $arrow(@{$self->{ARROWS}}) { $arrow->{ALLOW_DIAGONAL_LINES} = $allow ; } } #----------------------------------------------------------------------------- sub get_connector_points { my ($self) = @_ ; my(@all_connector_points) = $self->get_all_points() ; my(@connector_points) ; push @connector_points, $all_connector_points[0] unless $self->{NOT_CONNECTABLE_START} ; push @connector_points, $all_connector_points[-1] unless $self->{NOT_CONNECTABLE_END} ; return(@connector_points) ; } sub get_extra_points { my ($self) = @_ ; my(@all_connector_points) = $self->get_all_points() ; shift @all_connector_points unless $self->{NOT_CONNECTABLE_START} ; pop @all_connector_points unless $self->{NOT_CONNECTABLE_END} ; return(@all_connector_points) ; } sub get_all_points { my ($self) = @_ ; my(@connector_points) ; my $arrow_index = 0 ; for my $arrow(@{$self->{ARROWS}}) { my ($start_connector, $end_connector) = $arrow->get_connector_points() ; if($arrow == $self->{ARROWS}[0]) { $start_connector->{X} += $self->{POINTS_OFFSETS}[$arrow_index][0] ; $start_connector->{Y} += $self->{POINTS_OFFSETS}[$arrow_index][1] ; $start_connector->{NAME} .= "section_$arrow_index" ; push @connector_points, $start_connector ; } $end_connector->{X} += $self->{POINTS_OFFSETS}[$arrow_index][0] ; $end_connector->{Y} += $self->{POINTS_OFFSETS}[$arrow_index][1] ; $end_connector->{NAME} .= "section_$arrow_index" ; push @connector_points, $end_connector ; $arrow_index++ ; } return(@connector_points) ; } #----------------------------------------------------------------------------- sub get_named_connection { my ($self, $name) = @_ ; my $connection ; my $arrow_index = 0 ; for my $arrow(@{$self->{ARROWS}}) { my ($start_connector, $end_connector) = $arrow->get_connector_points() ; if($arrow == $self->{ARROWS}[0]) { $start_connector->{NAME} .= "section_$arrow_index" ; if($name eq $start_connector->{NAME}) { $start_connector->{X} += $self->{POINTS_OFFSETS}[$arrow_index][0] ; $start_connector->{Y} += $self->{POINTS_OFFSETS}[$arrow_index][1] ; $connection = $start_connector ; last ; } } $end_connector->{NAME} .= "section_$arrow_index" ; if($name eq $end_connector->{NAME}) { $end_connector->{X} += $self->{POINTS_OFFSETS}[$arrow_index][0] ; $end_connector->{Y} += $self->{POINTS_OFFSETS}[$arrow_index][1] ; $connection = $end_connector ; last ; } $arrow_index++ ; } return $connection ; } #----------------------------------------------------------------------------- sub move_connector { my ($self, $connector_name, $x_offset, $y_offset, $hint) = @_ ; my $connection = $self->get_named_connection($connector_name) ; (my $no_section_connetor_name = $connector_name) =~ s/section_.*// ; if($connection) { my ($x_offset, $y_offset, $width, $height, undef) = $self->resize ( $connection->{X}, $connection->{Y}, $connection->{X} + $x_offset, $connection->{Y} + $y_offset, $hint, #~ [$no_section_connetor_name, $connector_name], [$connector_name, $no_section_connetor_name], ) ; return ( $x_offset, $y_offset, $width, $height, $self->get_named_connection($connector_name) ) ; } else { die "unknown connector '$connector_name'!\n" ; } } #----------------------------------------------------------------------------- sub resize { my ($self, $reference_x, $reference_y, $new_x, $new_y, $hint, $connector_name_array) = @_ ; Readonly my $MULTI_WIRL_CONNECTOR_NAME_INDEX => 0 ; Readonly my $WIRL_CONNECTOR_NAME_INDEX => 1 ; my ($start_element, $start_element_index, $end_element, $end_element_index) ; # find elements connected by the connector if(defined $connector_name_array) { ($start_element, $start_element_index, $end_element, $end_element_index, $connector_name_array) = $self->find_elements_for_connector_named($connector_name_array) ; } else { ($start_element, $start_element_index, $end_element, $end_element_index, $connector_name_array) = $self->find_elements_for_connector_at($reference_x, $reference_y) ; } my ($start_x_offset, $start_y_offset) = (0, 0) ; if(defined $start_element) { my $is_start ; if(defined $connector_name_array) { if ( $connector_name_array->[$WIRL_CONNECTOR_NAME_INDEX] eq 'start' || $connector_name_array->[$MULTI_WIRL_CONNECTOR_NAME_INDEX] eq 'startsection_0' ) { $is_start++ ; } } else { if($reference_x == 0 && $reference_y == 0) { $is_start++ ; } } if($is_start) { #~ print "Moving start connector\n" ; ($start_x_offset, $start_y_offset) = $start_element->resize ( 0, 0, $new_x, $new_y, $hint, $connector_name_array->[$WIRL_CONNECTOR_NAME_INDEX] ) ; my $arrow_index = 0 ; for my $arrow(@{$self->{ARROWS}}) { # offsets all other wirl_arrow start offsets if($arrow == $start_element) { } else { $self->{POINTS_OFFSETS}[$arrow_index][0] -= $start_x_offset ; $self->{POINTS_OFFSETS}[$arrow_index][1] -= $start_y_offset ; } $arrow_index++ ; } } else { my $start_element_x_offset = $self->{POINTS_OFFSETS}[$start_element_index][0] ; my $start_element_y_offset = $self->{POINTS_OFFSETS}[$start_element_index][1] ; my ($x_offset, $y_offset) = $start_element ->resize ( $reference_x - $start_element_x_offset, $reference_y - $start_element_y_offset, $new_x - $start_element_x_offset, $new_y - $start_element_y_offset, $hint, $connector_name_array->[$WIRL_CONNECTOR_NAME_INDEX] ) ; $self->{POINTS_OFFSETS}[$start_element_index][0] += $x_offset ; $self->{POINTS_OFFSETS}[$start_element_index][1] += $y_offset ; if(defined $end_element) { my ($x_offset, $y_offset) = $end_element->resize(0, 0, $new_x - $reference_x, $new_y - $reference_y) ; $self->{POINTS_OFFSETS}[$end_element_index][0] += $x_offset ; $self->{POINTS_OFFSETS}[$end_element_index][1] += $y_offset ; } } } my ($width, $height) = $self->get_width_and_height() ; $self->set(WIDTH => $width, HEIGHT => $height) ; return($start_x_offset, $start_y_offset, $width, $height, $connector_name_array) ; } sub find_elements_for_connector_at { my ($self, $reference_x, $reference_y) = @_ ; my ($start_element, $start_element_index, $end_element, $end_element_index, $connector_name, $wirl_connector_name) ; my $arrow_index = 0 ; for my $arrow(@{$self->{ARROWS}}) { my ($start_connector, $end_connector) = $arrow->get_connector_points() ; if($reference_x == 0 && $reference_y == 0) { ($start_element, $start_element_index) = ($arrow, $arrow_index) ; $wirl_connector_name = $start_connector->{NAME} ; $connector_name = $wirl_connector_name . "section_$arrow_index" ; last ; } if(defined $start_element) { ($end_element, $end_element_index) = ($arrow, $arrow_index) ; last ; } if ( $reference_x == $end_connector->{X} + $self->{POINTS_OFFSETS}[$arrow_index][0] && $reference_y == $end_connector->{Y} + $self->{POINTS_OFFSETS}[$arrow_index][1] ) { ($start_element, $start_element_index) = ($arrow, $arrow_index) ; $wirl_connector_name = $end_connector->{NAME} ; $connector_name = $wirl_connector_name . "section_$arrow_index" ; } $arrow_index++ ; } return($start_element, $start_element_index, $end_element, $end_element_index, [$connector_name, $wirl_connector_name]) } sub find_elements_for_connector_named { my ($self, $connector_name_array) = @_ ; my ($connector_name, $wirl_connector_name) = @{$connector_name_array} ; my ($start_element, $start_element_index, $end_element, $end_element_index) ; my $arrow_index = 0 ; for my $arrow(@{$self->{ARROWS}}) { my ($start_connector, $end_connector) = $arrow->get_connector_points() ; if($connector_name eq $start_connector->{NAME} . "section_$arrow_index" ) { ($start_element, $start_element_index) = ($arrow, $arrow_index) ; last ; } if(defined $start_element) { ($end_element, $end_element_index) = ($arrow, $arrow_index) ; last ; } if($connector_name eq $end_connector->{NAME} . "section_$arrow_index") { ($start_element, $start_element_index) = ($arrow, $arrow_index) ; } $arrow_index++ ; } return($start_element, $start_element_index, $end_element, $end_element_index, $connector_name_array) ; } #----------------------------------------------------------------------------- sub get_number_of_sections { my ($self) = @_ ; return scalar(@{$self->{ARROWS}}) ; } #----------------------------------------------------------------------------- sub get_section_direction { my ($self, $section_index) = @_ ; if(exists($self->{ARROWS}[$section_index])) { return $self->{ARROWS}[$section_index]{DIRECTION} ; } else { return ; } } #----------------------------------------------------------------------------- sub prepend_section { my ($self, $extend_x, $extend_y) = @_ ; my $arrow = new App::Asciio::stripes::wirl_arrow ({ END_X => -$extend_x, END_Y => -$extend_y, ARROW_TYPE => $self->{ARROW_TYPE}, DIRECTION => $self->{DIRECTION}, ALLOW_DIAGONAL_LINES => $self->{ALLOW_DIAGONAL_LINES}, EDITABLE => $self->{EDITABLE}, }) ; my $arrow_index = 0 ; for my $arrow(@{$self->{ARROWS}}) { $self->{POINTS_OFFSETS}[$arrow_index][0] += -$extend_x ; $self->{POINTS_OFFSETS}[$arrow_index][1] += -$extend_y ; $arrow_index++ ; } unshift @{$self->{POINTS_OFFSETS}}, [0, 0] ; unshift @{$self->{ARROWS}}, $arrow ; my ($width, $height) = $self->get_width_and_height() ; $self->set(WIDTH => $width, HEIGHT => $height,) ; } sub append_section { my ($self, $extend_x, $extend_y) = @_ ; my $last_point = $self->get_points()->[-1] ; my $arrow = new App::Asciio::stripes::wirl_arrow ({ END_X => $extend_x - $last_point->[0], END_Y => $extend_y - $last_point->[1], ARROW_TYPE => $self->{ARROW_TYPE}, DIRECTION => $self->{DIRECTION}, ALLOW_DIAGONAL_LINES => $self->{ALLOW_DIAGONAL_LINES}, EDITABLE => $self->{EDITABLE}, }) ; my ($start_x, $start_y) = @{$self->{POINTS_OFFSETS}[-1]} ; my ($start_connector, $end_connector) = $self->{ARROWS}[-1]->get_connector_points() ; $start_x += $end_connector->{X} ; $start_y += $end_connector->{Y} ; push @{$self->{POINTS_OFFSETS}}, [$start_x, $start_y] ; push @{$self->{ARROWS}}, $arrow ; my ($width, $height) = $self->get_width_and_height() ; $self->set(WIDTH => $width, HEIGHT => $height,) ; } #----------------------------------------------------------------------------- sub remove_last_section { my ($self) = @_ ; return if @{$self->{ARROWS}} == 1 ; pop @{$self->{POINTS_OFFSETS}} ; pop @{$self->{ARROWS}} ; my ($width, $height) = $self->get_width_and_height() ; $self->set(WIDTH => $width, HEIGHT => $height,) ; } #----------------------------------------------------------------------------- sub remove_first_section { my ($self) = @_ ; return(0, 0) if @{$self->{ARROWS}} == 1 ; my $second_arrow_x_offset = $self->{POINTS_OFFSETS}[1][0] ; my $second_arrow_y_offset = $self->{POINTS_OFFSETS}[1][1] ; shift @{$self->{POINTS_OFFSETS}} ; shift @{$self->{ARROWS}} ; my $arrow_index = 0 ; for my $arrow(@{$self->{ARROWS}}) { $self->{POINTS_OFFSETS}[$arrow_index][0] -= $second_arrow_x_offset ; $self->{POINTS_OFFSETS}[$arrow_index][1] -= $second_arrow_y_offset ; $arrow_index++ ; } my ($width, $height) = $self->get_width_and_height() ; $self->set(WIDTH => $width, HEIGHT => $height,) ; return($second_arrow_x_offset, $second_arrow_y_offset) ; } #----------------------------------------------------------------------------- sub change_section_direction { my ($self, $x, $y) = @_ ; if(1 == @{$self->{ARROWS}}) { my $direction = $self->{ARROWS}[0]->get_section_direction(0) ; if($direction =~ /(.*)-(.*)/) { $self->{ARROWS}[0]->resize(0, 0, 0, 0, "$2-$1") ; } } else { my $index = 0 ; for my $arrow(@{$self->{ARROWS}}) { if ( $self->is_over_element ( $arrow, $x, $y, 0, @{$self->{POINTS_OFFSETS}[$index]} ) ) { my $direction = $arrow->get_section_direction($index) ; if($direction =~ /(.*)-(.*)/) { $arrow->resize(0, 0, 0, 0, "$2-$1") ; } } $index++ ; } } } sub is_over_element { my ($self, $element, $x, $y, $field, $element_offset_x, $element_offset_y, ) = @_ ; die "Error: 'is_over_element' needs position!" unless defined $x && defined $y ; $field ||= 0 ; my $is_under = 0 ; for my $mask_strip ($element->get_mask_and_element_stripes()) { my $stripe_x = $element_offset_x + $mask_strip->{X_OFFSET} ; my $stripe_y = $element_offset_y + $mask_strip->{Y_OFFSET} ; if ( $stripe_x - $field <= $x && $x < $stripe_x + $mask_strip->{WIDTH} + $field && $stripe_y - $field <= $y && $y < $stripe_y + $mask_strip->{HEIGHT} + $field ) { $is_under++ ; last ; } } return($is_under) ; } #----------------------------------------------------------------------------- sub get_width_and_height { my ($self) = @_ ; my ($smallest_x, $biggest_x, $smallest_y, $biggest_y) = (0, 0, 0, 0) ; my $arrow_index = 0 ; for my $start_point (@{$self->{POINTS_OFFSETS}}) { my ($x, $y) = @{$start_point} ; my ($start_connector, $end_connector) = $self->{ARROWS}[$arrow_index]->get_connector_points() ; $x += $end_connector->{X} ; $y += $end_connector->{Y} ; $smallest_x = min($smallest_x, $x) ; $smallest_y = min($smallest_y, $y) ; $biggest_x = max($biggest_x, $x) ; $biggest_y = max($biggest_y, $y) ; $arrow_index++ ; } return(($biggest_x - $smallest_x) + 1, ($biggest_y - $smallest_y) + 1) ; } #----------------------------------------------------------------------------- sub get_arrow_type { my ($self) = @_ ; return($self->{ARROW_TYPE}) ; } #----------------------------------------------------------------------------- sub set_arrow_type { my ($self, $arrow_type) = @_ ; $self->setup($arrow_type, $self->get_points(), $self->{DIRECTION}, $self->{ALLOW_DIAGONAL_LINES}, $self->{EDITABLE}) ; } #----------------------------------------------------------------------------- sub get_points { my ($self) = @_ ; my @points ; my $arrow_index = 0 ; for my $point_offset (@{$self->{POINTS_OFFSETS}}) { my ($x_offset, $y_offset) = @{$point_offset} ; my ($start_connector, $end_connector) = $self->{ARROWS}[$arrow_index]->get_connector_points() ; push @points, [$x_offset + $end_connector->{X}, $y_offset + $end_connector->{Y}] ; $arrow_index++ ; } return \@points ; } #----------------------------------------------------------------------------- sub edit { my ($self) = @_ ; return unless $self->{EDITABLE} ; # add section # remove section # handle offset array } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.02.71/lib/App/Asciio/stripes/editable_arrow2.pm0000555000076400001440000002516311122301056022412 0ustar nadimusers package App::Asciio::stripes::editable_arrow2 ; use base App::Asciio::stripes::stripes ; use strict; use warnings; use List::Util qw(min max) ; use Readonly ; use Clone ; #----------------------------------------------------------------------------- Readonly my $DEFAULT_ARROW_TYPE => [ ['Up', '|', '|', '^', 1, ], ['45', '/', '/', '^', 1, ], ['Right', '-', '-', '>', 1, ], ['135', '\\', '\\', 'v', 1, ], ['Down', '|', '|', 'v', 1, ], ['225', '/', '/', 'v', 1, ], ['Left', '-', '-', '<', 1, ], ['315', '\\', '\\', '^', 1, ], ] ; sub new { my ($class, $element_definition) = @_ ; my $self = bless {}, __PACKAGE__ ; $self->setup ( $element_definition->{ARROW_TYPE} || Clone::clone($DEFAULT_ARROW_TYPE), $element_definition->{END_X}, $element_definition->{END_Y}, $element_definition->{EDITABLE}, ) ; return $self ; } #----------------------------------------------------------------------------- sub setup { my ($self, $arrow_type, $end_x, $end_y, $editable) = @_ ; my ($stripes, $real_end_x, $real_end_y) = get_arrow($arrow_type, $end_x, $end_y) ; $self->set ( STRIPES => $stripes, END_X => $real_end_x, END_Y => $real_end_y, ARROW_TYPE => $arrow_type, ) ; } #----------------------------------------------------------------------------- sub get_arrow { my ($arrow_type, $end_x, $end_y) = @_ ; my ($stripes, $real_end_x, $real_end_y, $height, $width) = ([]) ; $end_y *= 2 ; # compensate for aspect ratio my $direction = $end_x >= 0 ? $end_y <= 0 ? -$end_y > $end_x ? -$end_y / 4 > $end_x ? 'up' :'45' : -$end_y > $end_x / 2 ? '45' : 'right' : $end_y < $end_x ? $end_y < $end_x / 2 ? 'right' :'135' : $end_y / 4 < $end_x ? '135' : 'down' : $end_y < 0 ? $end_y < $end_x ? $end_y / 4 < $end_x ? 'up' : '315' : $end_y < $end_x / 2 ? '315' : 'left' : $end_y > -$end_x ? $end_y / 4 > -$end_x ? 'down' : '225' : $end_y > -$end_x / 2 ? '225' : 'left' ; $end_y /= 2 ; # done compensating for aspect ratio my $arrow ; for ($direction) { $_ eq 'up' and do { my ($start, $body, $end) = @{$arrow_type->[0]}[1 .. 3] ; $height = -$end_y + 1 ; $real_end_y = $end_y ; $real_end_x = 0 ; $arrow = $height == 2 ? $end . "\n" . $start : $end . "\n" . ("$body\n" x ($height -2)) . $start ; push @{$stripes}, { 'HEIGHT' => $height, 'TEXT' => $arrow, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => $end_y, }; last ; } ; $_ eq '45' and do { my ($start, $body, $end) = @{$arrow_type->[1]}[1 .. 3] ; $height = -$end_y + 1 ; $real_end_y = $end_y ; $width = $height ; $real_end_x = - $real_end_y; push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; for(my $position = -$end_y - 1 ; $position > 0 ; $position--) { push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => $position, 'Y_OFFSET' => -$position, }; } push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => -$end_y , 'Y_OFFSET' => $end_y , }; last ; } ; $_ eq 'right' and do { my ($start, $body, $end) = @{$arrow_type->[2]}[1 .. 3] ; $width = $end_x + 1 ; $real_end_x = $end_x ; $real_end_y = 0 ; $arrow = $width == 1 ? $end : $width == 2 ? $start . $end : $start . ($body x ($width -2)) . $end ; push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $arrow, 'WIDTH' => $width, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; last ; } ; $_ eq '135' and do { my ($start, $body, $end) = @{$arrow_type->[3]}[1 .. 3] ; $height = $end_y + 1 ; $real_end_y = $end_y ; $width = $height ; $real_end_x = $real_end_y ; push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => 0 , 'Y_OFFSET' => 0 , }; for(my $position = 1 ; $position < $end_y ; $position++) { push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => $position, 'Y_OFFSET' => $position, }; } push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => $end_y , 'Y_OFFSET' => $end_y , }; last ; } ; $_ eq 'down' and do { my ($start, $body, $end) = @{$arrow_type->[4]}[1 .. 3] ; $height = $end_y + 1 ; $real_end_y = $end_y ; $real_end_x = 0 ; $arrow = $height == 2 ? $start . "\n" . $end : $start . "\n" . ("$body\n" x ($height -2)) . $end ; push @{$stripes}, { 'HEIGHT' => $height, 'TEXT' => $arrow, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; last ; } ; $_ eq '225' and do { my ($start, $body, $end) = @{$arrow_type->[5]}[1 .. 3] ; $height = $end_y + 1 ; $real_end_y = $end_y ; $width = $height ; $real_end_x = -$real_end_y ; push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; for(my $position = $end_y - 1 ; $position > 0 ; $position--) { push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $body, 'WIDTH' => 1, 'X_OFFSET' => -$position, 'Y_OFFSET' => $position, }; } push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => -$end_y , 'Y_OFFSET' => $end_y , }; last ; } ; $_ eq 'left' and do { my ($start, $body, $end) = @{$arrow_type->[6]}[1 .. 3] ; $width = -$end_x + 1 ; $real_end_y = 0 ; $real_end_x = $end_x ; $arrow = $width == 2 ? $end . $start : $end . ($body x ($width -2)) . $start ; push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $arrow, 'WIDTH' => $width, 'X_OFFSET' => $end_x, 'Y_OFFSET' => 0, }; last ; } ; $_ eq '315' and do { my ($start, $body, $end) = @{$arrow_type->[7]}[1 .. 3] ; $height = -$end_y + 1 ; $real_end_y = $end_y ; $width = $height ; $real_end_x = $real_end_y ; push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $start, 'WIDTH' => 1, 'X_OFFSET' => 0, 'Y_OFFSET' => 0, }; for(my $position = 1 ; $position < -$end_y ; $position++) { push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => '\\', 'WIDTH' => 1, 'X_OFFSET' => -$position, 'Y_OFFSET' => -$position, }; } push @{$stripes}, { 'HEIGHT' => 1, 'TEXT' => $end, 'WIDTH' => 1, 'X_OFFSET' => $end_y, 'Y_OFFSET' => $end_y, }; last ; } ; } return($stripes, $real_end_x, $real_end_y) ; } #----------------------------------------------------------------------------- sub get_extra_points { my ($self) = @_ ; return ( {X => $self->{END_X}, Y => $self->{END_Y}, NAME => 'resize'}, ) ; } #----------------------------------------------------------------------------- sub get_selection_action { my ($self, $x, $y) = @_ ; if ($x == $self->{END_X} && $y == $self->{END_Y}) { 'resize' ; } else { 'move' ; } } #----------------------------------------------------------------------------- sub resize { my ($self, $reference_x, $reference_y, $new_x, $new_y) = @_ ; my $new_end_x = $new_x ; my $new_end_y = $new_y ; $self->setup($self->{ARROW_TYPE}, $new_end_x, $new_end_y, $self->{EDITABLE}) ; return(0, 0, $self->{END_X} + 1, $self->{END_X} + 1) ; } #----------------------------------------------------------------------------- sub get_text { my ($self) = @_ ; } #----------------------------------------------------------------------------- sub set_text { my ($self) = @_ ; } #----------------------------------------------------------------------------- sub edit { my ($self) = @_ ; return unless $self->{EDITABLE} ; display_box_edit_dialog($self->{ARROW_TYPE}) ; $self->setup($self->{ARROW_TYPE}, $self->{END_X}, $self->{END_Y}, $self->{EDITABLE}) ; } use Glib ':constants'; use Gtk2 -init; use Glib qw(TRUE FALSE); sub display_box_edit_dialog { my ($rows) = @_ ; my $window = new Gtk2::Window() ; my $dialog = Gtk2::Dialog->new('Arrow attributes', $window, 'destroy-with-parent') ; $dialog->set_default_size (220, 270); $dialog->add_button ('gtk-ok' => 'ok'); #~ my $vbox = $dialog->vbox ; my $dialog_vbox = $dialog->vbox ; my $vbox = Gtk2::VBox->new (FALSE, 5); $dialog_vbox->pack_start ($vbox, TRUE, TRUE, 0); $vbox->pack_start (Gtk2::Label->new (""), FALSE, FALSE, 0); my $sw = Gtk2::ScrolledWindow->new; $sw->set_shadow_type ('etched-in'); $sw->set_policy ('automatic', 'automatic'); $vbox->pack_start ($sw, TRUE, TRUE, 0); # create model my $model = create_model ($rows); # create tree view my $treeview = Gtk2::TreeView->new_with_model ($model); $treeview->set_rules_hint (TRUE); $treeview->get_selection->set_mode ('single'); add_columns($treeview, $rows); $sw->add($treeview); $treeview->show() ; $vbox->show() ; $sw->show() ; $dialog->run() ; $dialog->destroy ; } #----------------------------------------------------------------------------- sub create_model { my ($rows) = @_ ; my $model = Gtk2::ListStore->new(qw/Glib::String Glib::String Glib::String Glib::String Glib::Boolean/); foreach my $row (@{$rows}) { my $iter = $model->append; my $column = 0 ; $model->set ($iter, map {$column++, $_} @{$row}) ; } return $model; } #----------------------------------------------------------------------------- sub add_columns { my ($treeview, $rows) = @_ ; my $model = $treeview->get_model; # column for row titles my $row_renderer = Gtk2::CellRendererText->new; $row_renderer->set_data (column => 0); $treeview->insert_column_with_attributes ( -1, '', $row_renderer, text => 0, ) ; my $column = $treeview->get_column(0) ; $column->set_sizing('fixed') ; $column->set_fixed_width(80) ; my $current_column = 1 ; for my $column_title('start', 'body', 'end') { my $renderer = Gtk2::CellRendererText->new; $renderer->signal_connect (edited => \&cell_edited, [$model, $rows]); $renderer->set_data (column => $current_column ); $treeview->insert_column_with_attributes ( -1, $column_title, $renderer, text => $current_column, editable => 4, ); $current_column++ ; } } #----------------------------------------------------------------------------- sub cell_edited { my ($cell, $path_string, $new_text, $model_and_rows) = @_; my ($model, $rows) = @{$model_and_rows} ; my $path = Gtk2::TreePath->new_from_string ($path_string); my $column = $cell->get_data ("column"); my $iter = $model->get_iter($path); my $row = ($path->get_indices)[0]; $rows->[$row][$column] = $new_text ; $model->set($iter, $column, $new_text); } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.02.71/lib/App/Asciio/Setup.pm0000555000076400001440000002200611122301056016745 0ustar nadimusers package App::Asciio ; $|++ ; use strict; use warnings; use Data::TreeDumper ; use Eval::Context ; use Carp ; use Module::Util qw(find_installed) ; use File::Basename ; use Gtk2::Gdk::Keysyms ; my %K = %Gtk2::Gdk::Keysyms ; #------------------------------------------------------------------------------------------------------ sub setup { my($self, $setup_ini_file, $setup_path) = @_ ; $setup_ini_file = 'setup.ini' unless(defined $setup_ini_file) ; unless(defined $setup_path) { my ($basename, $path, $ext) = File::Basename::fileparse(find_installed('App::Asciio'), ('\..*')) ; $setup_path = $path . $basename . '/setup/' ; } if(-e $setup_path) { eval "use lib qw($setup_path) ;" ; die "Can't use '$setup_path'\n" if $@ ; print "Using setup directory:'$setup_path'\n" ; } else { croak "Can't find setup directory '$setup_path'\n" ; } my $ini_files ; if('HASH' ne ref $setup_ini_file) { my $context = new Eval::Context() ; $ini_files = $context->eval ( PRE_CODE => "use strict;\nuse warnings;\n", CODE_FROM_FILE => "$setup_path/$setup_ini_file", ) ; die "can't load '$setup_ini_file': $! $@\n" if $@ ; } $self->setup_stencils($setup_path, $ini_files->{STENCILS} || []) ; $self->setup_hooks($setup_path, $ini_files->{HOOK_FILES} || []) ; $self->setup_action_handlers($setup_path, $ini_files->{ACTION_FILES} || []) ; $self->setup_import_export_handlers($setup_path, $ini_files->{IMPORT_EXPORT} || []) ; $self->setup_object_options($setup_path, $ini_files->{ASCIIO_OBJECT_SETUP} || []) ; } #------------------------------------------------------------------------------------------------------ sub setup_stencils { my($self, $setup_path, $stencils) = @_ ; for my $stencil (@{$stencils}) { if(-e "$setup_path/$stencil") { if(-f "$setup_path/$stencil") { $self->load_elements("$setup_path/$stencil", $stencil) ; } elsif(-d "$setup_path/$stencil") { print "batch loading stencil from $setup_path/$stencil\n" ; for(glob("$setup_path/$stencil/*")) { $self->load_elements($_, $stencil) ; } } else { print "Unknown type '$setup_path/$stencil'!\n" ; } } else { print "Can't find '$setup_path/$stencil'!\n" ; } } } #------------------------------------------------------------------------------------------------------ my Readonly $CATEGORY = 0 ; my Readonly $SHORTCUTS = 0 ; my Readonly $CODE = 1 ; my Readonly $ARGUMENTS = 2 ; my Readonly $CONTEXT_MENUE_SUB = 3; my Readonly $CONTEXT_MENUE_ARGUMENTS = 4 ; my Readonly $NAME= 5 ; my Readonly $ORIGIN= 6 ; sub setup_hooks { my($self, $setup_path, $hook_files) = @_ ; for my $hook_file (@{ $hook_files }) { my $context = new Eval::Context() ; my @hooks ; $context->eval ( REMOVE_PACKAGE_AFTER_EVAL => 0, # VERY IMPORTANT as we return code references that will cease to exist otherwise INSTALL_SUBS => {register_hooks => sub{@hooks = @_}}, PRE_CODE => "use strict;\nuse warnings;\n", CODE_FROM_FILE => "$setup_path/$hook_file" , ) ; die "can't load hook file '$hook_file ': $! $@\n" if $@ ; for my $hook (@hooks) { $self->{HOOKS}{$hook->[$CATEGORY]} = $hook->[$CODE] ; } } } #------------------------------------------------------------------------------------------------------ sub setup_action_handlers { my($self, $setup_path, $action_files) = @_ ; for my $action_file (@{ $action_files }) { #~ print "setup_action_handlers: loading '$action_file'\n" ; my $context = new Eval::Context() ; my %action_handlers; $context->eval ( REMOVE_PACKAGE_AFTER_EVAL => 0, # VERY IMPORTANT as we return code references that will cease to exist otherwise INSTALL_SUBS => {register_action_handlers => sub{%action_handlers = @_}}, PRE_CODE => "use strict;\nuse warnings;\n", CODE_FROM_FILE => "$setup_path/$action_file", ) ; die "can't load setup file '$action_file': $! $@\n" if $@ ; for my $name (keys %action_handlers) { my $action_handler ; my $group_name ; my $shortcuts_definition ; if('HASH' eq ref $action_handlers{$name}) { $shortcuts_definition = $action_handlers{$name}{SHORTCUTS} ; $action_handlers{$name}{GROUP_NAME} = $group_name = $name ; $action_handlers{$name}{ORIGIN} = $action_file; $action_handler = $self->get_group_action_handler($action_handlers{$name}, $action_file) ; } elsif('ARRAY' eq ref $action_handlers{$name}) { $shortcuts_definition= $action_handlers{$name}[$SHORTCUTS] ; $action_handlers{$name}[$NAME] = $name ; $action_handlers{$name}[$ORIGIN] = $action_file ; $action_handler = $action_handlers{$name} ; } else { #~ print "ignoring '$name'\n" ; next ; } $self->{ACTIONS_BY_NAME}{$name} = $action_handlers{$name} ; my $shortcuts ; if('ARRAY' eq ref $shortcuts_definition) { $shortcuts = $shortcuts_definition ; } else { $shortcuts = [$shortcuts_definition] ; } for my $shortcut (@$shortcuts) { if(exists $self->{ACTIONS}{$shortcut}) { print "Overriding action '$shortcut' with definition from file'$action_file'!\n" ; } $self->{ACTIONS}{$shortcut} = $action_handler ; if(defined $group_name) { $self->{ACTIONS}{$shortcut}{GROUP_NAME} = $group_name ; $self->{ACTIONS}{$shortcut}{ORIGIN} = $action_file; } } } } } sub get_group_action_handler { my ($self, $action_handler_definition, $action_file) = @_ ; my %handler ; for my $name (keys %{$action_handler_definition}) { my $action_handler ; my $group_name ; my $shortcuts_definition ; if('SHORTCUTS' eq $name) { #~ print "Found shortcuts definition.\n" ; next ; } elsif('HASH' eq ref $action_handler_definition->{$name}) { $shortcuts_definition= $action_handler_definition->{$name}{SHORTCUTS} ; $action_handler_definition->{$name}{GROUP_NAME} = $group_name = $name ; $action_handler_definition->{$name}{ORIGIN} = $action_file ; $action_handler = $self->get_group_action_handler($action_handler_definition->{$name}, $action_file) ; } elsif('ARRAY' eq ref $action_handler_definition->{$name}) { $shortcuts_definition= $action_handler_definition->{$name}[$SHORTCUTS] ; $action_handler_definition->{$name}[$NAME] = $name ; $action_handler_definition->{$name}[$ORIGIN] = $action_file ; $action_handler = $action_handler_definition->{$name} ; } else { #~ print "ignoring '$name'\n" ; next ; } my $shortcuts ; if('ARRAY' eq ref $shortcuts_definition) { $shortcuts = $shortcuts_definition ; } else { $shortcuts = [$shortcuts_definition] ; } for my $shortcut (@$shortcuts) { if(exists $handler{$shortcut}) { print "Overriding action group '$shortcut' with definition from file'$action_file'!\n" ; } $handler{$shortcut} = $action_handler ; if(defined $group_name) { $handler{$shortcut}{GROUP_NAME} = $group_name ; } } } return \%handler ; } #------------------------------------------------------------------------------------------------------ sub setup_import_export_handlers { my($self, $setup_path, $import_export_files) = @_ ; for my $import_export_file (@{ $import_export_files }) { my $context = new Eval::Context() ; my %import_export_handlers ; $context->eval ( REMOVE_PACKAGE_AFTER_EVAL => 0, # VERY IMPORTANT as we return code references that will cease to exist otherwise INSTALL_SUBS => {register_import_export_handlers => sub{%import_export_handlers = @_}}, PRE_CODE => < "$setup_path/$import_export_file", ) ; die "can't load import/export handler defintion file '$import_export_file': $! $@\n" if $@ ; for my $extension (keys %import_export_handlers) { if(exists $self->{IMPORT_EXPORT_HANDLERS}{$extension}) { print "Overriding import/export handler for extension '$extension'!\n" ; } $self->{IMPORT_EXPORT_HANDLERS}{$extension} = $import_export_handlers{$extension} ; } } } #------------------------------------------------------------------------------------------------------ sub setup_object_options { my($self, $setup_path, $options_files) = @_ ; for my $options_file (@{ $options_files }) { my $context = new Eval::Context() ; my %options = $context->eval ( PRE_CODE => "use strict;\nuse warnings;\n", CODE_FROM_FILE => "$setup_path/$options_file", ) ; for my $option_name (keys %options) { $self->{$option_name} = $options{$option_name} ; } die "can't load setup file '$options_file': $! $@\n" if $@ ; } $self->event_options_changed() ; } #------------------------------------------------------------------------------------------------------ sub run_script { my($self, $script) = @_ ; if(defined $script) { my $context = new Eval::Context() ; $context->eval ( PRE_CODE => "use strict;\nuse warnings;\n", CODE_FROM_FILE => $script, INSTALL_VARIABLES => [ [ '$self' => $self => $Eval::Context::SHARED ], ] , ) ; die "can't load setup file '$script': $! $@\n" if $@ ; } } #------------------------------------------------------------------------------------------------------ 1 ; App-Asciio-1.02.71/lib/App/Asciio/Elements.pm0000555000076400001440000004401511122301056017425 0ustar nadimusers package App::Asciio ; $|++ ; use strict; use warnings; use Carp ; use Data::Dumper ; use Data::TreeDumper ; use File::Slurp ; use Clone; use List::Util qw(min max) ; use List::MoreUtils qw(any minmax first_value) ; use Readonly ; use Glib ':constants'; use Gtk2 -init; use Gtk2::Gdk::Keysyms ; my %K = %Gtk2::Gdk::Keysyms ; use App::Asciio::Connections ; #----------------------------------------------------------------------------- sub set_modified_state { my ($self, $state) = @_ ; $self->{MODIFIED} = $state ; } #----------------------------------------------------------------------------- sub get_modified_state { my ($self) = @_ ; $self->{MODIFIED} ; } #----------------------------------------------------------------------------- sub get_color { my ($self, $name) = @_; unless (exists $self->{ALLOCATED_COLORS}{$name}) { my $color ; if('ARRAY' eq ref $name) { $color = Gtk2::Gdk::Color->new( map {$_ * 257} @{$name}) ; } elsif(exists $self->{COLORS}{$name}) { if('ARRAY' eq ref $self->{COLORS}{$name}) { $color = Gtk2::Gdk::Color->new( map {$_ * 257} @{ $self->{COLORS}{$name}}) ; } else { $color = Gtk2::Gdk::Color->parse($self->{COLORS}{$name}); } } else { $color = Gtk2::Gdk::Color->parse($name); } $color = Gtk2::Gdk::Color->new( map {$_ * 257} (255, 0, 0)) unless defined $color ; $self->{widget}->get_colormap->alloc_color($color,TRUE,TRUE) ; $self->{ALLOCATED_COLORS}{$name} = $color ; } return($self->{ALLOCATED_COLORS}{$name}) ; } #----------------------------------------------------------------------------- sub flush_color_cache { my ($self) = @_ ; delete $self->{ALLOCATED_COLORS} ; } #----------------------------------------------------------------------------- sub get_group_color { # cycle through color to give visual clue to user my ($self) = @_ ; my $name = $self->{GROUP_COLORS}[$self->{NEXT_GROUP_COLOR}] ; $self->{NEXT_GROUP_COLOR}++ ; $self->{NEXT_GROUP_COLOR} = 0 if $self->{NEXT_GROUP_COLOR} >= scalar(@{$self->{GROUP_COLORS}}) ; return ($name) ; } #----------------------------------------------------------------------------- sub add_ruler_lines { my ($self, @lines) = @_ ; push @{$self->{RULER_LINES}}, @lines ; $self->{MODIFIED }++ ; } sub remove_ruler_lines { my ($self, @ruler_lines_to_remove) = @_ ; my %removed ; for my $ruler_line_to_remove (@ruler_lines_to_remove) { for my $ruler_line (@{$self->{RULER_LINES}}) { if ( $ruler_line->{TYPE} eq $ruler_line_to_remove->{TYPE} && $ruler_line->{POSITION} == $ruler_line_to_remove->{POSITION} ) { $removed{$ruler_line} ++ ; } } } $self->{RULER_LINES} = [grep {! exists $removed{$_}} @{$self->{RULER_LINES}} ] ; } sub exists_ruler_line { my ($self, @ruler_lines_to_check) = @_ ; my $exists = 0 ; for my $ruler_line_to_check (@ruler_lines_to_check) { for my $ruler_line (@{$self->{RULER_LINES}}) { if ( $ruler_line->{TYPE} eq $ruler_line_to_check->{TYPE} && $ruler_line->{POSITION} == $ruler_line_to_check->{POSITION} ) { $exists++ ; last ; } } } return $exists ; } #----------------------------------------------------------------------------- sub add_new_element_named { my ($self, $element_name, $x, $y) = @_ ; my $element_index = $self->{ELEMENT_TYPES_BY_NAME}{$element_name} ; if(defined $element_index) { return add_new_element_of_type($self, $self->{ELEMENT_TYPES}[$element_index], $x, $y) ; } else { croak "add_new_element_named: can't create element named '$element_name'!\n" ; } } #----------------------------------------------------------------------------- sub add_new_element_of_type { my ($self, $element, $x, $y) = @_ ; my $new_element = Clone::clone($element) ; @$new_element{'X', 'Y', 'SELECTED'} = ($x, $y, 0) ; $self->add_elements($new_element) ; return($new_element) ; } #----------------------------------------------------------------------------- sub set_element_position { my ($self, $element, $x, $y) = @_ ; @$element{'X', 'Y'} = ($x, $y) ; } #----------------------------------------------------------------------------- sub add_element_at { my ($self, $element, $x, $y) = @_ ; $self->add_element_at_no_connection($element,$x, $y) ; $self->connect_elements($element) ; } sub add_element_at_no_connection { my ($self, $element, $x, $y) = @_ ; $self->set_element_position($element,$x, $y) ; $self->add_elements_no_connection($element) ; } #----------------------------------------------------------------------------- sub add_elements { my ($self, @elements) = @_ ; $self->add_elements_no_connection(@elements) ; $self->connect_elements(@elements) ; } sub add_elements_no_connection { my ($self, @elements) = @_ ; push @{$self->{ELEMENTS}}, @elements ; $self->{MODIFIED }++ ; } #----------------------------------------------------------------------------- sub unshift_elements { my ($self, @elements) = @_ ; unshift @{$self->{ELEMENTS}}, @elements ; $self->{MODIFIED }++ ; } #----------------------------------------------------------------------------- sub move_elements { my ($self, $x_offset, $y_offset, @elements) = @_ ; my %selected_elements = map { $_ => 1} @elements ; for my $element (@elements) { @$element{'X', 'Y'} = ($element->{X} + $x_offset, $element->{Y} + $y_offset) ; # handle arrow element my (@current_element_connections, %used_connectors) ; if($self->is_connected($element)) { # disconnect current connections if it is not connected to another elements we are moving # connectees move their connected along @current_element_connections =$self->get_connections_containing($element) , my (@connections_to_delete, @connections_to_keep) ; for my $current_element_connection (@current_element_connections) { if(exists $selected_elements{$current_element_connection->{CONNECTEE}}) { $used_connectors{$current_element_connection->{CONNECTOR}{NAME}}++ ; push @connections_to_keep, $current_element_connection ; } else { push @connections_to_delete, $current_element_connection ; } } $self->delete_connections(@connections_to_delete) ; @current_element_connections = @connections_to_keep ; } # connect to new elements if the connection doesn't already exist # and connection not already done with one of the elements being moved my @new_connections = grep { # connector already used to connect to a moved element ! exists $used_connectors{$_->{CONNECTOR}{NAME}} } grep { # connection to that element already exists, don't reconnect to moved element ! exists $selected_elements{$_->{CONNECTEE}} } $self->get_possible_connections($element) ; $self->add_connections(@new_connections) ; # handle box element for my $connection ($self->get_connected($element)) { # move connected with connectees if (exists $selected_elements{$connection->{CONNECTED}}) { # arrow is part of the selection being moved } else { my ($x_offset, $y_offset, $width, $height, $new_connector) = $connection->{CONNECTED}->move_connector ( $connection->{CONNECTOR}{NAME}, $x_offset, $y_offset ) ; $connection->{CONNECTED}{X} += $x_offset ; $connection->{CONNECTED}{Y} += $y_offset; # the connection point has also changed $connection->{CONNECTOR} = $new_connector ; $connection->{FIXED}++ ; #find the other connectors belonging to this connected for my $other_connection (grep{ ! $_->{FIXED}} @{$self->{CONNECTIONS}}) { # move them relatively to their previous position if($connection->{CONNECTED} == $other_connection->{CONNECTED}) { my ($new_connector) = # in characters relative to element origin $other_connection->{CONNECTED}->get_named_connection($other_connection->{CONNECTOR}{NAME}) ; $other_connection->{CONNECTOR} = $new_connector ; $other_connection->{FIXED}++ ; } } } } for my $connection (@{$self->{CONNECTIONS}}) { delete $connection->{FIXED} ; } $self->{MODIFIED }++ ; } } #----------------------------------------------------------------------------- sub resize_element { my ($self, $reference_x, $reference_y, $new_x, $new_y, $selected_element, $connector_name) = @ _; my ($x_offset, $y_offset, undef, undef, $resized_connector_name) = $selected_element->resize($reference_x, $reference_y, $new_x, $new_y, undef, $connector_name) ; $selected_element->{X} += $x_offset ; $selected_element->{Y} += $y_offset; # handle connections if($self->is_connected($selected_element)) { # disconnect current connections $self->delete_connections_containing($selected_element) ; } $self->connect_elements($selected_element) ; # connect to new elements if any for my $connection ($self->get_connected($selected_element)) { # all connection where the selected element is the connectee my ($new_connection) = # in characters relative to element origin $selected_element->get_named_connection($connection->{CONNECTION}{NAME}) ; if(defined $new_connection) { my ($x_offset, $y_offset, $width, $height, $new_connector) = $connection->{CONNECTED}->move_connector ( $connection->{CONNECTOR}{NAME}, $new_connection->{X} - $connection->{CONNECTION}{X}, $new_connection->{Y}- $connection->{CONNECTION}{Y} ) ; $connection->{CONNECTED}{X} += $x_offset ; $connection->{CONNECTED}{Y} += $y_offset ; # the connection point has also changed $connection->{CONNECTOR} = $new_connector ; $connection->{CONNECTION} = $new_connection ; $connection->{FIXED}++ ; #find the other connectors belonging to this connected for my $other_connection (grep{ ! $_->{FIXED}} @{$self->{CONNECTIONS}}) { # move them relatively to their previous position if($connection->{CONNECTED} == $other_connection->{CONNECTED}) { my ($new_connector) = # in characters relative to element origin $other_connection->{CONNECTED}->get_named_connection($other_connection->{CONNECTOR}{NAME}) ; $other_connection->{CONNECTOR} = $new_connector ; $other_connection->{FIXED}++ ; } } for my $connection (@{$self->{CONNECTIONS}}) { delete $connection->{FIXED} ; } } else { $self->delete_connections($connection) ; } } return($x_offset, $y_offset, $resized_connector_name) ; } #----------------------------------------------------------------------------- sub move_elements_to_front { my ($self, @elements) = @_ ; my %elements_to_move = map {$_ => 1} @elements ; my @new_element_list ; for(@{$self->{ELEMENTS}}) { push @new_element_list, $_ unless (exists $elements_to_move{$_}) ; } $self->{ELEMENTS} = [@new_element_list, @elements] ; } ; #---------------------------------------------------------------------------------------------- sub move_elements_to_back { my ($self, @elements) = @_ ; my %elements_to_move = map {$_ => 1} @elements ; my @new_element_list ; for(@{$self->{ELEMENTS}}) { push @new_element_list, $_ unless (exists $elements_to_move{$_}) ; } $self->{ELEMENTS} = [@elements, @new_element_list] ; } ; #----------------------------------------------------------------------------- sub delete_elements { my($self, @elements) = @_ ; my %elements_to_delete = map {$_, 1} @elements ; for my $element (@{$self->{ELEMENTS}}) { if(exists $elements_to_delete{$element}) { $self->delete_connections_containing($element) ; $element = undef ; } } @{$self->{ELEMENTS}} = grep { defined $_} @{$self->{ELEMENTS}} ; $self->{MODIFIED }++ ; } #----------------------------------------------------------------------------- sub edit_element { my ($self, $selected_element) = @_ ; $selected_element->edit() ; # handle connections if($self->is_connected($selected_element)) { # disconnect current connections $self->delete_connections_containing($selected_element) ; } #~ !!! TODO if not already connected to them (same connection) $self->connect_elements($selected_element) ; # connect to new elements if any for my $connection ($self->get_connected($selected_element)) { # all connection where the selected element is the connectee my ($new_connection) = # in characters relative to element origin $selected_element->get_named_connection($connection->{CONNECTION}{NAME}) ; if(defined $new_connection) { my ($x_offset, $y_offset, $width, $height, $new_connector) = $connection->{CONNECTED}->move_connector ( $connection->{CONNECTOR}{NAME}, $new_connection->{X} - $connection->{CONNECTION}{X}, $new_connection->{Y}- $connection->{CONNECTION}{Y} ) ; $connection->{CONNECTED}{X} += $x_offset ; $connection->{CONNECTED}{Y} += $y_offset; # the connection point has also changed $connection->{CONNECTOR} = $new_connector ; $connection->{CONNECTION} = $new_connection ; $connection->{FIXED}++ ; #find the other connectors belonging to this connected for my $other_connection (grep{ ! $_->{FIXED}} @{$self->{CONNECTIONS}}) { # move them relatively to their previous position if($connection->{CONNECTED} == $other_connection->{CONNECTED}) { my ($new_connector) = # in characters relative to element origin $other_connection->{CONNECTED}->get_named_connection($other_connection->{CONNECTOR}{NAME}) ; $other_connection->{CONNECTOR} = $new_connector ; $other_connection->{FIXED}++ ; } } for my $connection (@{$self->{CONNECTIONS}}) { delete $connection->{FIXED} ; } } else { $self->delete_connections($connection) ; } #~ TODO fix the other connection as move does above } $self->{MODIFIED }++ ; } #----------------------------------------------------------------------------- sub get_selected_elements { my ($self, $state) = @_ ; return ( grep { if($state) { exists $_->{SELECTED} && $_->{SELECTED} != 0 } else { ! exists $_->{SELECTED} || $_->{SELECTED} == 0 } } @{$self->{ELEMENTS}} ) ; } #----------------------------------------------------------------------------- sub any_select_elements { my ($self) = @_ ; return(any {$_->{SELECTED}} @{$self->{ELEMENTS}}) ; } #----------------------------------------------------------------------------- sub select_elements { my ($self, $state, @elements) = @_ ; my %groups_to_select ; for my $element (@elements) { if($state) { $element->{SELECTED} = ++$self->{SELECTION_INDEX} ; } else { $element->{SELECTED} = 0 ; } if(exists $element->{GROUP} && defined $element->{GROUP}[-1]) { $groups_to_select{$element->{GROUP}[-1]}++ ; } } # select groups for my $element (@{$self->{ELEMENTS}}) { if ( exists $element->{GROUP} && defined $element->{GROUP}[-1] && exists $groups_to_select{$element->{GROUP}[-1]} ) { if($state) { $element->{SELECTED} = ++$self->{SELECTION_INDEX} ; } else { $element->{SELECTED} = 0 ; } } } delete $self->{SELECTION_INDEX} unless $self->get_selected_elements(1) ; } #----------------------------------------------------------------------------- sub select_elements_flip { my ($self, @elements) = @_ ; for my $element (@elements) { $self->select_elements($element->{SELECTED} ^ 1, $element) ; } delete $self->{SELECTION_INDEX} unless $self->get_selected_elements(1) ; } #----------------------------------------------------------------------------- sub is_element_selected { my ($self, $element) = @_ ; $element->{SELECTED} ; } #----------------------------------------------------------------------------- sub is_over_element { my ($self, $element, $x, $y, $field) = @_ ; die "Error: 'is_over_element' needs position!" unless defined $x && defined $y ; $field ||= 0 ; my $is_under = 0 ; for my $mask_strip ($element->get_mask_and_element_stripes()) { my $stripe_x = $element->{X} + $mask_strip->{X_OFFSET} ; my $stripe_y = $element->{Y} + $mask_strip->{Y_OFFSET} ; if ( $stripe_x - $field <= $x && $x < $stripe_x + $mask_strip->{WIDTH} + $field && $stripe_y - $field <= $y && $y < $stripe_y + $mask_strip->{HEIGHT} + $field ) { $is_under++ ; last ; } } return($is_under) ; } #----------------------------------------------------------------------------- sub element_completely_within_rectangle { my ($self, $element, $rectangle) = @_ ; my ($start_x, $start_y) = ($rectangle->{START_X}, $rectangle->{START_Y}) ; my $width = $rectangle->{END_X} - $rectangle->{START_X} ; my $height = $rectangle->{END_Y} - $rectangle->{START_Y}; if($width < 0) { $width *= -1 ; $start_x -= $width ; } if($height < 0) { $height *= -1 ; $start_y -= $height ; } my $is_under = 1 ; for my $mask_strip ($element->get_mask_and_element_stripes()) { my $stripe_x = $element->{X} + $mask_strip->{X_OFFSET} ; my $stripe_y = $element->{Y} + $mask_strip->{Y_OFFSET} ; if ( $start_x <= $stripe_x && ($stripe_x + $mask_strip->{WIDTH}) <= $start_x +$width && $start_y <= $stripe_y && ($stripe_y + $mask_strip->{HEIGHT}) <= $start_y + $height ) { } else { $is_under = 0 ; last } } return($is_under) ; } #----------------------------------------------------------------------------- sub pixel_to_character_x { my ($self, @pixels) = @_ ; my ($character_width, $character_height) = $self->get_character_size() ; map {int($_ / $character_width)} @pixels ; } sub pixel_to_character_y { my ($self, @pixels) = @_ ; my ($character_width, $character_height) = $self->get_character_size() ; map {int($_ / $character_height)} @pixels ; } #----------------------------------------------------------------------------- sub closest_character { my ($self, $x, $y) = @_ ; my ($character_width, $character_height) = $self->get_character_size() ; my $character_x = int($x / $character_width) ; my $character_y = int($y / $character_height) ; return($character_x, $character_y) ; } #----------------------------------------------------------------------------- sub get_character_size { my ($self) = @_ ; if(exists $self->{USER_CHARACTER_WIDTH}) { return ($self->{USER_CHARACTER_WIDTH}, $self->{USER_CHARACTER_HEIGHT}) ; } else { my $layout = $self->{widget}->create_pango_layout('M') ; return $layout->get_pixel_size() ; } } sub set_character_size { my ($self, $width, $height) = @_ ; ($self->{USER_CHARACTER_WIDTH}, $self->{USER_CHARACTER_HEIGHT}) = ($width, $height) ; } #----------------------------------------------------------------------------- 1 ;App-Asciio-1.02.71/lib/App/Asciio/Connections.pm0000555000076400001440000001053211122301056020130 0ustar nadimusers package App::Asciio; $|++ ; use strict; use warnings; use Data::TreeDumper ; use Clone; use List::Util qw(min max) ; use List::MoreUtils qw(any minmax first_value) ; #----------------------------------------------------------------------------- sub connect_elements { my ($self, @elements) = @_ ; my @possible_connections = $self->get_possible_connections(@elements) ; #~ $self->show_dump_window(\@possible_connections, "\@possible_connections for @elements") ; $self->add_connections(@possible_connections) ; } #----------------------------------------------------------------------------- sub add_connections { my ($self, @connections) = @_ ; $self->flash_new_connections(@connections) ; push @{$self->{CONNECTIONS}}, @connections ; $self->{MODIFIED }++ ; } #----------------------------------------------------------------------------- sub get_possible_connections { my ($self, @elements) = @_ ; my @possible_connections ; my %connected_connectors ; for my $element (@elements) { my @connectors = $element->get_connector_points() ; last unless @connectors ; #optimize search by eliminating those elements that are too far for my $connectee (reverse @{$self->{ELEMENTS}}) { next if $connectee == $element ; # dont connect to self for my $connector (@connectors) { my @connections = $connectee->match_connector ( # translate coordinates to connectee reference ($element->{X} - $connectee->{X}) + $connector->{X}, ($element->{Y} - $connectee->{Y}) + $connector->{Y}, ) ; # make connection if possible. connect to a single point if(defined $connections[0] && ! exists $connected_connectors{$element.$connector->{NAME}}) { push @possible_connections, { CONNECTED => $element, CONNECTOR =>$connector, CONNECTEE => $connectee, CONNECTION => $connections[0], } ; $connected_connectors{$element.$connector->{NAME}}++ ; next ; } } } } return(@possible_connections) ; } #----------------------------------------------------------------------------- sub get_connections_containing { my($self, @elements) = @_ ; my %elements_to_find = map {$_ => 1} @elements ; my @connections ; for my $connection (@{$self->{CONNECTIONS}}) { if(exists $elements_to_find{$connection->{CONNECTED}} || exists $elements_to_find{$connection->{CONNECTEE}}) { push @connections, $connection; } } return(@connections) ; } #----------------------------------------------------------------------------- sub delete_connections { my($self, @connections) = @_ ; my %connections_to_delete = map {$_ => 1} @connections ; for my $connection (@{$self->{CONNECTIONS}}) { if(exists $connections_to_delete{$connection}) { $connection = undef ; } } @{$self->{CONNECTIONS}} = grep { defined $_} @{$self->{CONNECTIONS}} ; $self->{MODIFIED }++ ; } #----------------------------------------------------------------------------- sub delete_connections_containing { my($self, @elements) = @_ ; for my $element(@elements) { for my $connection (@{$self->{CONNECTIONS}}) { if($connection->{CONNECTED} == $element || $connection->{CONNECTEE} == $element) { $connection = undef ; } } } @{$self->{CONNECTIONS}} = grep { defined $_} @{$self->{CONNECTIONS}} ; $self->{MODIFIED }++ ; } #----------------------------------------------------------------------------- sub is_connectee { my($self, $element) = @_ ; my $connectee = 0 ; for my $connection (@{$self->{CONNECTIONS}}) { if($connection->{CONNECTEE} == $element) { $connectee++ ; last } } return($connectee) ; } sub get_connected { my($self, $element) = @_ ; my(@connected) ; for my $connection (@{$self->{CONNECTIONS}}) { if($connection->{CONNECTEE} == $element) { push @connected, $connection ; } } return(@connected) ; } #----------------------------------------------------------------------------- sub is_connected { my($self, $element) = @_ ; my $connected = 0 ; for my $connection (@{$self->{CONNECTIONS}}) { if($connection->{CONNECTED} == $element) { $connected++ ; last } } return($connected) ; } #----------------------------------------------------------------------------- sub flash_new_connections { my($self, @connections) = @_ ; push @{$self->{NEW_CONNECTIONS}}, @connections ; } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.02.71/lib/App/Asciio/Menues.pm0000555000076400001440000000657511122301056017116 0ustar nadimusers package App::Asciio ; $|++ ; use strict; use warnings; use Data::TreeDumper ; use Clone; use List::Util qw(min max) ; use List::MoreUtils qw(any minmax first_value) ; use Eval::Context ; use Glib ':constants'; use Gtk2 -init; use Gtk2::Gdk::Keysyms ; my %K = %Gtk2::Gdk::Keysyms ; my %C = map{$K{$_} => $_} keys %K ; #------------------------------------------------------------------------------------------------------ sub display_popup_menu { my ($self, $event) = @_; my ($popup_x, $popup_y) = $event->coords() ; my @menu_items ; for my $element (@{$self->{ELEMENT_TYPES}}) { (my $name_with_underscore = $element->{NAME}) =~ s/_/__/g ; push @menu_items, [ "/$name_with_underscore", undef , insert_generator($self, $element, $popup_x, $popup_y), 0 , '', undef], } for my $menu_entry (@{$self->get_context_menu_entries($popup_x, $popup_y)}) { my($name, $sub, $data) = @{$menu_entry} ; (my $name_with_underscore = $name) =~ s/_/__/g ; push @menu_items, [ $name_with_underscore, undef , $self->menue_entry_wrapper($sub, $data), 0, '', undef], } push @menu_items, ( ['/File/open', undef , sub {$self->run_actions_by_name('Open') ;}, 0 , '', undef], ['/File/save', undef , sub {$self->run_actions_by_name('Save') ;}, 0 , '', undef], [ '/File/save as', undef , sub {$self->run_actions_by_name(['Save', 1]) ;}, 0 , '', undef], ) ; if($self->get_selected_elements(1) == 1) { push @menu_items, [ '/File/save stencil', undef , $self->menue_entry_wrapper(\&save_stencil), 0 , '', undef ] ; } my $item_factory = Gtk2::ItemFactory->new("Gtk2::Menu" ,"") ; $item_factory ->create_items($self->{widget}, @menu_items) ; my $menu = $item_factory->get_widget("") ; $menu->popup(undef, undef, undef, undef, $event->button, $event->time) ; } sub insert_generator { my ($self, $element, $x, $y) = @_ ; my ($character_width, $character_height) = $self->get_character_size() ; return sub { $self->add_new_element_of_type($element, $self->closest_character($x, $y)) ; $self->update_display(); } ; } sub menue_entry_wrapper { my ($self, $sub, $data) = @_ ; return sub { $sub->($self, $data) ; } ; } #------------------------------------------------------------------------------------------------------ my Readonly $SHORTCUTS = 0 ; my Readonly $CODE = 1 ; my Readonly $ARGUMENTS = 2 ; my Readonly $CONTEXT_MENUE_SUB = 3 ; my Readonly $CONTEXT_MENUE_ARGUMENTS = 4 ; my Readonly $NAME= 5 ; sub get_context_menu_entries { my ($self, $popup_x, $popup_y) = @_ ; my @context_menu_entries ; for my $context_menu_handler ( map {$self->{CURRENT_ACTIONS}{$_}} grep { 'ARRAY' eq ref $self->{CURRENT_ACTIONS}{$_} # not a sub actions definition && defined $self->{CURRENT_ACTIONS}{$_}[$CONTEXT_MENUE_SUB] } sort keys %{$self->{CURRENT_ACTIONS}} ) { #~ print "Adding context menue from action '$context_menu_handler->[$NAME]'.\n" ; if(defined $context_menu_handler->[$CONTEXT_MENUE_ARGUMENTS]) { push @context_menu_entries, $context_menu_handler->[$CONTEXT_MENUE_SUB]-> ( $self, $context_menu_handler->[$CONTEXT_MENUE_ARGUMENTS], $popup_x, $popup_y, ) ; } else { push @context_menu_entries, $context_menu_handler->[$CONTEXT_MENUE_SUB]->($self, $popup_x, $popup_y) ; } } return(\@context_menu_entries) ; } #------------------------------------------------------------------------------------------------------ 1 ; App-Asciio-1.02.71/lib/App/Asciio/Undo.pm0000555000076400001440000001557211122301056016564 0ustar nadimusers package App::Asciio ; $|++ ; use strict; use warnings; use Data::TreeDumper ; #~ use Compress::LZF ':compress'; use Compress::Bzip2 qw(:all :utilities :gzip); #----------------------------------------------------------------------------- sub pop_undo_buffer { my ($self, $number_of_steps) = @_; pop @{$self->{DO_STACK}} for(1 .. $number_of_steps) ; } #----------------------------------------------------------------------------- sub redo { my ($self, $number_of_steps) = @_; $self->{DO_STACK_POINTER} += $number_of_steps ; if($self->{DO_STACK_POINTER} >= @{$self->{DO_STACK}}) { $self->{DO_STACK_POINTER} = @{$self->{DO_STACK}} - 1 ; } $self->do($self->{DO_STACK_POINTER}) ; } sub undo { my ($self, $number_of_steps) = @_; (my $new_stack_pointer = $self->{DO_STACK_POINTER}) -= $number_of_steps ; $new_stack_pointer = 0 if($new_stack_pointer < 0) ; $self->{DO_STACK} ||= [] ; if($self->{DO_STACK_POINTER} == @{$self->{DO_STACK}}) { $self->create_undo_snapshot() ; } $self->{DO_STACK_POINTER} = $new_stack_pointer ; $self->do($new_stack_pointer) ; } sub do { my ($self, $stack_pointer) = @_; my $new_self = $self->{DO_STACK}[$stack_pointer] ; if(defined $new_self) { my ($do_stack_pointer, $do_stack) = ($self->{DO_STACK_POINTER}, $self->{DO_STACK}) ; my $decompressed_new_self = decompress $new_self ; $decompressed_new_self .= "\n\n" ; # important line or eval would complain about syntax errors !!! my $VAR1 ; eval $decompressed_new_self ; if($@) { use File::Slurp ; write_file('undo_error.pl', $decompressed_new_self ) ; die "Can't undo! $@\n" ; } else { $self->load_self($VAR1) ; ($self->{DO_STACK_POINTER}, $self->{DO_STACK}) = ($do_stack_pointer, $do_stack) ; $self->update_display() ; } } } #----------------------------------------------------------------------------- sub create_undo_snapshot { my ($self) = @_; #TODO: delta, serialize and compress, use the same huffman table for extra compression my $serialized_self ; { local $self->{DO_STACK} = undef ; $serialized_self = $self->serialize_self() ; } #~ my $previous_serialized_self = '' ; #~ { #~ local $self->{DO_STACK} = undef ; #~ my $xxx= $self->serialize_self(1) ; #~ use File::Slurp ; #~ write_file("test/undo_$self->{DO_STACK_POINTER}.txt", $xxx) ; # diff serialize 1 + bzip 2 => 500-1000 bytes vs 4000-5000 bytes with no diff and compress #~ } my $compressed_self = compress $serialized_self ; splice(@{$self->{DO_STACK}}, min($self->{DO_STACK_POINTER}, scalar(@{$self->{DO_STACK}}))) ; # new do branch push @{$self->{DO_STACK}}, $compressed_self ; $self->{DO_STACK_POINTER} = @{$self->{DO_STACK}} ; #~ print 'stack: ' . scalar(@{$self->{DO_STACK}}) . ' size: ' . length($serialized_self) . ' compressed: ' . length($compressed_self) . "\n" ; } #----------------------------------------------------------------------------- use Algorithm::Diff qw(diff LCS traverse_sequences) ; sub test_diff { # This example produces traditional 'diff' output: my @seq1 = ("line 1", "line 2", "line3", "line 4", "line 5", 'line 6') ; my @seq2 = ("line mod1", "line 2", "line 2B", "line3", "line 5") ; my @diff_lines = get_diff_lines(\@seq1, \@seq2) ; for my $diff_line (@diff_lines) { print DumpTree $diff_line ; my ( $number_of_errors , $number_of_match , $synchronized_a , $synchronized_b , $error_string ) = CompareStrings($diff_line->{REFERENCE}, $diff_line->{NEW}) ; my $undefined_line = '' ; $undefined_line = '** reference line did not exist! **' unless defined $diff_line->{REFERENCE} ; $undefined_line = '** new line did not exist! **' unless defined $diff_line->{NEW} ; print <{LINE} number_of_match = $number_of_match number_of_errors = $number_of_errors $undefined_line $synchronized_a $synchronized_b $error_string ERRORS } } sub get_diff_lines { my ($seq1, $seq2) = @_ ; my $diff = Algorithm::Diff->new($seq1, $seq2 ); my @diff_lines ; $diff->Base(1); my $line = 1 ; while($diff->Next()) { unless($diff->Same()) { my ($reference_line) = $diff->Items(1) ; my ($new_line) = $diff->Items(2) ; push @diff_lines, {LINE => $line, REFERENCE => $reference_line , NEW => $new_line} ; } $line++ ; } return @diff_lines ; } sub CompareStrings($$) { =head2 CompareStrings Returns the following list: =over 2 =item 1 number_of_errors =item 2 number_of_match =item 3 synchronized_a =item 4 synchronized_b =item 5 error_string =back =cut my ($a_string, $b_string) = @_ ; my ($a, $b) ; # handle cases were one or both strings are not defined if(!defined $a_string && ! defined $b_string) { return (0, 0, '', '', '') ; } elsif(!defined $a_string) { return (length($b_string), 0, '', $b_string, '^' x length($b_string)) ; } elsif(!defined $b_string) { return (length($a_string), 0, $a_string, '', '^' x length($a_string)) ; } my @a = split //, $a_string ; my @b = split //, $b_string ; my @match_indexes = Algorithm::Diff::_longestCommonSubsequence( \@a, \@b) ; #print Dumper(\@match_indexes), "\n" ; #my @LCS = LCS( \@a, \@b ) ; #print Dumper(\@LCS), "\n" ; my $previous = -1 ; my $last_match_in_B = -1 ; # build $a a character at a time. Synchronize strings before adding current character for(0 .. $#match_indexes) { if(defined $previous) { if(defined $match_indexes[$_]) { if($match_indexes[$_] == $previous + 1) { # match $b .= $b[$match_indexes[$_]] ; $last_match_in_B = $match_indexes[$_] ; } else { # match but extra letters in B, synchronize A $a .= ' ' x ($match_indexes[$_] - ($previous + 1)) ; $b .= join '', @b[$previous + 1 .. $match_indexes[$_]] ; $last_match_in_B = $match_indexes[$_] ; } } #else # letter in A doesn't match in B } else { if(defined $match_indexes[$_]) { # match # synchronize B my $number_of_skipped_characters_in_B = ($match_indexes[$_] - 1) - ($last_match_in_B) ; $b .= ' ' x (length($a) - (length($b) + $number_of_skipped_characters_in_B)) ; $b .= join '', @b[$last_match_in_B + 1 .. $match_indexes[$_]] ; $last_match_in_B = $match_indexes[$_] ; # synchronize A if needed $a .= ' ' x (length($b) - (length($a) + 1)) ; # +1 as current character will be appended to $a } #else # letter in A doesn't match in B } $a .= $a[$_] ; $previous = $match_indexes[$_] ; } my $trailers_in_A = scalar(@a) - scalar(@match_indexes) ; $a .= join '', @a[-$trailers_in_A .. -1] ; my $trailers_in_B = scalar(@b) - ($last_match_in_B + 1) ; $b .= join '', @b[-$trailers_in_B .. -1] ; my $error_string = $a ^ $b ; my $number_of_matches = $error_string =~ tr[\0][\0] ; my $number_of_errors = length($error_string) - $number_of_matches ; # show were the strings are different $error_string =~ tr[\0][^]c ; $error_string =~ tr[\0][ ] ; return ($number_of_errors, $number_of_matches, $a, $b, $error_string) ; } #----------------------------------------------------------------------------- 1 ; App-Asciio-1.02.71/lib/App/Asciio.pm0000444000076400001440000007425311122301056015655 0ustar nadimusers package App::Asciio ; $|++ ; use strict; use warnings; use Data::TreeDumper ; use Clone; use List::Util qw(min max first) ; use List::MoreUtils qw(any minmax first_value) ; use Glib ':constants'; use Gtk2 -init; use Gtk2::Gdk::Keysyms ; my %K = %Gtk2::Gdk::Keysyms ; my %C = map{$K{$_} => $_} keys %K ; use App::Asciio::Setup ; use App::Asciio::Dialogs ; use App::Asciio::Elements ; use App::Asciio::Menues ; use App::Asciio::Actions ; use App::Asciio::Undo ; use App::Asciio::Io ; use App::Asciio::Ascii ; use App::Asciio::Options ; #----------------------------------------------------------------------------- our $VERSION = '1.02' ; #----------------------------------------------------------------------------- =head1 NAME App::Asciio - Plain ASCII diagram | | | | | | | | | | | | | | | | v | v | v | v v v _____ _____ /\ _ \ /\ __ \ \ \ \_\ \ ___ ___ _ _\ \ \ \ \ -----> \ \ __ \ / __\ / ___\/\ \/\ \ \ \ \ \ -----> \ \ \ \ \/\__, \/\ \___' \ \ \ \ \ \_\ \ \ \_\ \_\/\____/\ \____/\ \_\ \_\ \_____\ \/_/\/_/\/___/ \/___/ \/_/\/_/\/_____/ | | | | | | | | | | | v | | | v | | | v | | | v | | v v v (\_/) (O.o) ASCII world domination is near! (> <) =head1 SYNOPSIS $> perl asciio.pl =head1 DESCRIPTION This gtk2-perl application allows you to draw ASCII diagrams in a modern (but simple) graphical application. The ASCII graphs can be saved as ASCII or in a format that allows you to modify them later. Thanks to all the Perl-QA hackathon 2008 in Oslo for pushing me to do an early release. Special thanks go to the Muppet and the gtk-perl group, Gábor Szabó for his help and advices. Adam Kennedy coined the cool name. Sometimes a diagram is worth a lot of text in a source code file. It has always been painfull to do ASCII diagrams by hand. =head1 DOCUMENTATION =head2 Asciio user interface .-----------------------------------------------------------------. | Asciio | |-----------------------------------------------------------------| | ............................................................... | | ..............-------------..------------..--------------...... | | .............| stencils > || asciio > || box |..... | | .............| Rulers > || computer > || text |..... | | .............| File > || people > || wirl_arrow |..... | grid---------->.......'-------------'| divers > || axis |..... | | ............................'------------'| boxes > |..... | | ......................^...................| rulers > |..... | | ......................|...................'--------------'..... | | ......................|........................................ | | ......................|........................................ | | ......................|........................................ | | ......................|........................................ | '-----------------------|-----------------------------------------' | | context menu =head2 context menu The context menu allows to access to B commands. B is used to insert ASCII elements. =head2 keyboard shortcuts All the keyboad commands definitions can be found under I. Among the commands implemented are: =over 2 =item * select all =item * delete =item * undo =item * group/ungroup =item * open / save =item * local clipboard operations =back A window displaying the currently available commands is displayed if you press B. =head2 elements There but a few elements implemented at the moment. =head3 wirl arrow An arrow that tries to do what you want. Try rotating the end clockwise then counter clockwise to see how it acts ^ | | --------. | | '------- | | O-------------X / | / | / | / v / / v =head3 box and text Both are implemented within the same code. Try double clicking on a box to see what you can do with it. .----------. | title | .----------. |----------| ************ | | | body 1 | * * '----------' | body 2 | ************ '----------' anything in a box (\_/) | edit_me (O.o) <------------' (> <) =head3 your own stencils Take a look at I for a stencil example. Stencils lites in I will be loaded when B starts. =head3 your own element type For simple elemnts, put your design in a box. that should cover 90% of anyone's needs. You can look in I for element implementation examples. =head2 exporting to ASCII You can export to a file in ASCII format but using the B<.txt> extension. Exporting to the clipboard is done with B. =head1 EXAMPLES User code ^ ^ OS code \ / \ / \ / User code <----Mode----->OS code / \ / \ / \ User code v v OS code .---. .---. .---. .---. .---. .---. OS API '---' '---' '---' '---' '---' '---' | | | | | | v v | v | v .------------. | .-----------. | .-----. | Filesystem | | | Scheduler | | | MMU | '------------' | '-----------' | '-----' | | | | v | | v .----. | | .---------. | IO |<----' | | Network | '----' | '---------' | | | v v v .---------------------------------------. | HAL | '---------------------------------------' .---------. .---------. | State 1 | | State 2 | '---------' '---------' ^ \ ^ \ / \ / \ / \ / \ / \ / \ / \ / \ / v v ****** ****** ****** * T1 * * T2 * * T3 * ****** ****** ****** ^ ^ / \ \ / \ \ / \ \ / stimuli \ \ / \ \ v \ .---------. '--------| State 3 | '---------' =cut sub new { my ($class, $width, $height) = @_ ; my $drawing_area = Gtk2::DrawingArea->new; my $self = bless { widget => $drawing_area, ELEMENT_TYPES => [], ELEMENTS => [], CONNECTIONS => [], CLIPBOARD => {}, FONT_FAMILY => 'Monospace', FONT_SIZE => '10', TAB_AS_SPACES => ' ', OPAQUE_ELEMENTS => 1, DISPLAY_GRID => 1, PREVIOUS_X => -1, PREVIOUS_Y => -1, MOUSE_X => 0, MOUSE_Y => 0, DRAGGING => '', SELECTION_RECTANGLE =>{START_X => 0, START_Y => 0}, ACTIONS => {}, VALID_SELECT_ACTION => { map {$_, 1} qw(resize move)}, COPY_OFFSET_X => 3, COPY_OFFSET_Y => 3, COLORS => { background => [255, 255, 255], grid => [229, 235, 255], ruler_line => [85, 155, 225], selected_element_background => [180, 244, 255], element_background => [251, 251, 254], element_foreground => [0, 0, 0] , selection_rectangle => [255, 0, 255], test => [0, 255, 255], group_colors => [ [[250, 221, 190], [250, 245, 239]], [[182, 250, 182], [241, 250, 241]], [[185, 219, 250], [244, 247, 250]], [[137, 250, 250], [235, 250, 250]], [[198, 229, 198], [239, 243, 239]], ], connection => 'Chocolate', connection_point => [230, 198, 133], connector_point => 'DodgerBlue', extra_point => [230, 198, 133], }, NEXT_GROUP_COLOR => 0, WORK_DIRECTORY => '.asciio_work_dir', CREATE_BACKUP => 1, MODIFIED => 0, DO_STACK_POINTER => 0, DO_STACK => [] , }, __PACKAGE__ ; $drawing_area->can_focus(TRUE) ; $drawing_area->signal_connect(configure_event => \&configure_event, $self); $drawing_area->signal_connect(expose_event => \&expose_event, $self); $drawing_area->signal_connect(motion_notify_event => \&motion_notify_event, $self); $drawing_area->signal_connect(button_press_event => \&button_press_event, $self); $drawing_area->signal_connect(button_release_event => \&button_release_event, $self); $drawing_area->signal_connect(key_press_event => \&key_press_event, $self); $drawing_area->set_events ([qw/ exposure-mask leave-notify-mask button-press-mask button-release-mask pointer-motion-mask key-press-mask key-release-mask /]); $self->event_options_changed() ; return($self) ; } #----------------------------------------------------------------------------- sub event_options_changed { my ($self) = @_; my $number_of_group_colors = scalar(@{$self->{COLORS}{group_colors}}) ; $self->{GROUP_COLORS} = [0 .. $number_of_group_colors - 1] , $self->{CURRENT_ACTIONS} = $self->{ACTIONS} ; $self->set_font($self->{FONT_FAMILY}, $self->{FONT_SIZE}); } #----------------------------------------------------------------------------- sub destroy { my ($self) = @_; $self->{widget}->get_toplevel()->destroy() ; } #----------------------------------------------------------------------------- sub set_title { my ($self, $title) = @_; if(defined $title) { $self->{widget}->get_toplevel()->set_title($title . ' - asciio') ; $self->{TITLE} = $title ; } } sub get_title { my ($self) = @_; $self->{TITLE} ; } #----------------------------------------------------------------------------- sub set_font { my ($self, $font_family, $font_size) = @_; $self->{FONT_FAMILY} = $font_family || 'Monospace'; $self->{FONT_SIZE} = $font_size || 10 ; $self->{widget}->modify_font ( Gtk2::Pango::FontDescription->from_string ( $self->{FONT_FAMILY} . ' ' . $self->{FONT_SIZE} ) ); } sub get_font { my ($self) = @_; return($self->{FONT_FAMILY}, $self->{FONT_SIZE}) ; } #----------------------------------------------------------------------------- sub update_display { my ($self) = @_; my $widget = $self->{widget} ; $self->call_hook('CANONIZE_CONNECTIONS', $self->{CONNECTIONS}, $self->get_character_size()) ; $widget->queue_draw_area(0, 0, $widget->allocation->width,$widget->allocation->height); } #----------------------------------------------------------------------------- sub call_hook { my ($self, $hook_name, @arguments) = @_; $self->{HOOKS}{$hook_name}->(@arguments) if (exists $self->{HOOKS}{$hook_name}) ; } #----------------------------------------------------------------------------- sub configure_event { my ($widget, $event, $self) = @_; $self->{PIXMAP} = Gtk2::Gdk::Pixmap->new ( $widget->window, $widget->allocation->width, $widget->allocation->height, -1 ); $self->{PIXMAP}->draw_rectangle ( $widget->get_style->base_gc ($widget->state), TRUE, 0, 0, $widget->allocation->width, $widget->allocation->height ); return TRUE; } #----------------------------------------------------------------------------- sub expose_event { my ($widget, $event, $self) = @_; my $gc = Gtk2::Gdk::GC->new($self->{PIXMAP}); # draw background $gc->set_foreground($self->get_color('background')); $self->{PIXMAP}->draw_rectangle ( $gc, TRUE, 0, 0, $widget->allocation->width, $widget->allocation->height ); my ($character_width, $character_height) = $self->get_character_size() ; my ($widget_width, $widget_height) = $self->{PIXMAP}->get_size(); if($self->{DISPLAY_GRID}) { $gc->set_foreground($self->get_color('grid')); for my $horizontal (0 .. ($widget_height/$character_height) + 1) { $self->{PIXMAP}->draw_line ( $gc, 0, $horizontal * $character_height, $widget_width, $horizontal * $character_height ); } for my $vertical(0 .. ($widget_width/$character_width) + 1) { $self->{PIXMAP}->draw_line ( $gc, $vertical * $character_width, 0, $vertical * $character_width, $widget_height ); } } # draw elements for my $element (@{$self->{ELEMENTS}}) { my ($background_color, $foreground_color) = $element->get_colors() ; if($self->is_element_selected($element)) { if(exists $element->{GROUP} and defined $element->{GROUP}[-1]) { $background_color = $self->get_color ( $self->{COLORS}{group_colors}[$element->{GROUP}[-1]{GROUP_COLOR}][0] ) ; } else { $background_color = $self->get_color('selected_element_background'); } } else { if(defined $background_color) { $background_color = $self->get_color($background_color) ; } else { if(exists $element->{GROUP} and defined $element->{GROUP}[-1]) { $background_color = $self->get_color ( $self->{COLORS}{group_colors}[$element->{GROUP}[-1]{GROUP_COLOR}][1] ) ; } else { $background_color = $self->get_color('element_background') ; } } } $foreground_color = defined $foreground_color ? $self->get_color($foreground_color) : $self->get_color('element_foreground') ; $gc->set_foreground($foreground_color); for my $mask_and_element_strip ($element->get_mask_and_element_stripes()) { $gc->set_foreground($background_color); $self->{PIXMAP}->draw_rectangle ( $gc, $self->{OPAQUE_ELEMENTS}, ($element->{X} + $mask_and_element_strip->{X_OFFSET}) * $character_width, ($element->{Y} + $mask_and_element_strip->{Y_OFFSET}) * $character_height, $mask_and_element_strip->{WIDTH} * $character_width, $mask_and_element_strip->{HEIGHT} * $character_height, ); $gc->set_foreground($foreground_color); my $layout = $widget->create_pango_layout($mask_and_element_strip->{TEXT}) ; my ($text_width, $text_height) = $layout->get_pixel_size; $self->{PIXMAP}->draw_layout ( $gc, ($element->{X} + $mask_and_element_strip->{X_OFFSET}) * $character_width, ($element->{Y} + $mask_and_element_strip->{Y_OFFSET}) * $character_height, $layout ); } } # draw ruler lines for my $line (@{$self->{RULER_LINES}}) { my $color = Gtk2::Gdk::Color->new( map {$_ * 257} @{$line->{COLOR} }) ; $self->{widget}->get_colormap->alloc_color($color,TRUE,TRUE) ; $gc->set_foreground($color); if($line->{TYPE} eq 'VERTICAL') { $self->{PIXMAP}->draw_line ( $gc, $line->{POSITION} * $character_width, 0, $line->{POSITION} * $character_width, $widget_height ); } else { $self->{PIXMAP}->draw_line ( $gc, 0, $line->{POSITION} * $character_height, $widget_width, $line->{POSITION} * $character_height ); } } # draw connections my (%connected_connections, %connected_connectors) ; for my $connection (@{$self->{CONNECTIONS}}) { my $draw_connection ; my $connector ; if($self->is_over_element($connection->{CONNECTED}, $self->{MOUSE_X}, $self->{MOUSE_Y}, 1)) { $draw_connection++ ; $connector = $connection->{CONNECTED}->get_named_connection($connection->{CONNECTOR}{NAME}) ; $connected_connectors{$connection->{CONNECTED}}{$connector->{X}}{$connector->{Y}}++ ; } if($self->is_over_element($connection->{CONNECTEE}, $self->{MOUSE_X}, $self->{MOUSE_Y}, 1)) { $draw_connection++ ; my $connectee_connection = $connection->{CONNECTEE}->get_named_connection($connection->{CONNECTION}{NAME}) ; if($connectee_connection) { $connected_connectors{$connection->{CONNECTEE}}{$connectee_connection->{X}}{$connectee_connection->{Y}}++ ; } } if($draw_connection) { $gc->set_foreground($self->get_color('connection')); $connector ||= $connection->{CONNECTED}->get_named_connection($connection->{CONNECTOR}{NAME}) ; $self->{PIXMAP}->draw_rectangle ( $gc, FALSE, ($connector->{X} + $connection->{CONNECTED}{X}) * $character_width, ($connector->{Y} + $connection->{CONNECTED}{Y}) * $character_height, $character_width, $character_height ); } } # draw connectors and connection points for my $element (grep {$self->is_over_element($_, $self->{MOUSE_X}, $self->{MOUSE_Y}, 1)} @{$self->{ELEMENTS}}) { $gc->set_foreground($self->get_color('connector_point')); for my $connector ($element->get_connector_points()) { next if exists $connected_connectors{$element}{$connector->{X}}{$connector->{Y}} ; $self->{PIXMAP}->draw_rectangle ( $gc, FALSE, ($element->{X} + $connector->{X}) * $character_width, ($connector->{Y} + $element->{Y}) * $character_height, $character_width, $character_height ); } $gc->set_foreground($self->get_color('connection_point')); for my $connection_point ($element->get_connection_points()) { next if exists $connected_connections{$element}{$connection_point->{X}}{$connection_point->{Y}} ; $self->{PIXMAP}->draw_rectangle # little box ( $gc, TRUE, (($connection_point->{X} + $element->{X}) * $character_width) + ($character_width / 3), (($connection_point->{Y} + $element->{Y}) * $character_height) + ($character_height / 3), $character_width / 3 , $character_height / 3 ); } for my $extra_point ($element->get_extra_points()) { if(exists $extra_point ->{COLOR}) { $gc->set_foreground($self->get_color($extra_point ->{COLOR})); } else { $gc->set_foreground($self->get_color('extra_point')); } $self->{PIXMAP}->draw_rectangle ( $gc, FALSE, (($extra_point ->{X} + $element->{X}) * $character_width), (($extra_point ->{Y} + $element->{Y}) * $character_height), $character_width, $character_height ); } } # draw new connections for my $new_connection (@{$self->{NEW_CONNECTIONS}}) { $gc->set_foreground($self->get_color('red')); my $end_connection = $new_connection->{CONNECTED}->get_named_connection($new_connection->{CONNECTOR}{NAME}) ; $self->{PIXMAP}->draw_rectangle ( $gc, FALSE, ($end_connection->{X} + $new_connection->{CONNECTED}{X}) * $character_width , ($end_connection->{Y} + $new_connection->{CONNECTED}{Y}) * $character_height , $character_width, $character_height ); } delete $self->{NEW_CONNECTIONS} ; # draw selection rectangle if(defined $self->{SELECTION_RECTANGLE}{END_X}) { my $start_x = $self->{SELECTION_RECTANGLE}{START_X} * $character_width ; my $start_y = $self->{SELECTION_RECTANGLE}{START_Y} * $character_height ; my $width = ($self->{SELECTION_RECTANGLE}{END_X} - $self->{SELECTION_RECTANGLE}{START_X}) * $character_width ; my $height = ($self->{SELECTION_RECTANGLE}{END_Y} - $self->{SELECTION_RECTANGLE}{START_Y}) * $character_height; if($width < 0) { $width *= -1 ; $start_x -= $width ; } if($height < 0) { $height *= -1 ; $start_y -= $height ; } $gc->set_foreground($self->get_color('selection_rectangle')) ; $self->{PIXMAP}->draw_rectangle($gc, FALSE,$start_x, $start_y, $width, $height); delete $self->{SELECTION_RECTANGLE}{END_X} ; } $widget->window->draw_drawable ( $widget->style->fg_gc($widget->state), $self->{PIXMAP}, $event->area->x, $event->area->y, $event->area->x, $event->area->y, $event->area->width, $event->area->height ); return TRUE; } #----------------------------------------------------------------------------- sub button_release_event { my ($widget, $event, $self) = @_ ; my $modifiers = get_key_modifiers($event) ; if($self->exists_action("${modifiers}-button_release")) { $self->run_actions(["${modifiers}-button_release", $event]) ; return TRUE ; } if(defined $self->{MODIFIED_INDEX} && defined $self->{MODIFIED} && $self->{MODIFIED_INDEX} == $self->{MODIFIED}) { $self->pop_undo_buffer(1) ; # no changes } $self->update_display(); } #----------------------------------------------------------------------------- sub button_press_event { #~ print "button_press_event\n" ; my ($widget, $event, $self) = @_ ; $self->{DRAGGING} = '' ; delete $self->{RESIZE_CONNECTOR_NAME} ; $self->create_undo_snapshot() ; $self->{MODIFIED_INDEX} = $self->{MODIFIED} ; my $modifiers = get_key_modifiers($event) ; my $button = ${event}->button() ; if($self->exists_action("${modifiers}-button_press-$button")) { $self->run_actions(["${modifiers}-button_press-$button", $event]) ; return TRUE ; } if($event->type eq '2button-press') { my($x, $y) = $self->closest_character($event->coords()) ; my @element_over = grep { $self->is_over_element($_, $x, $y) } reverse @{$self->{ELEMENTS}} ; if(@element_over) { my $selected_element = $element_over[0] ; $self->edit_element($selected_element) ; $self->update_display(); } return TRUE ; } if($event->button == 1) { my $modifiers = get_key_modifiers($event) ; my ($x, $y) = $self->closest_character($event->coords()) ; my ($first_element) = first_value {$self->is_over_element($_, $x, $y)} reverse @{$self->{ELEMENTS}} ; if ($modifiers eq 'C00') { if(defined $first_element) { $self->run_actions_by_name('Copy to clipboard', ['Insert from clipboard', 0, 0]) ; } } else { if(defined $first_element) { if ($modifiers eq '00S') { $self->select_elements_flip($first_element) ; } else { unless($self->is_element_selected($first_element)) { $self->select_elements(0, @{$self->{ELEMENTS}}) ; $self->select_elements(1, $first_element) ; } } } else { $self->select_elements(0, @{$self->{ELEMENTS}}) if ($modifiers eq '000') ; } } $self->{SELECTION_RECTANGLE} = {START_X => $x , START_Y => $y} ; $self->update_display(); } if($event->button == 2) { my ($x, $y) = $self->closest_character($event->coords()) ; $self->{SELECTION_RECTANGLE} = {START_X => $x , START_Y => $y} ; $self->update_display(); } if($event->button == 3) { $self->display_popup_menu($event) ; } return TRUE; } #----------------------------------------------------------------------------- sub motion_notify_event { my ($widget, $event, $self) = @_ ; my ($x, $y) = $self->closest_character($event->coords()) ; my $modifiers = get_key_modifiers($event) ; if($self->exists_action("${modifiers}motion_notify")) { $self->run_actions(["${modifiers}-motion_notify", $event]) ; return TRUE ; } if($self->{PREVIOUS_X} != $x || $self->{PREVIOUS_Y} != $y) { ($self->{MOUSE_X}, $self->{MOUSE_Y}) = ($x, $y) ; $self->update_display() ; } if ($event->state >= "button1-mask") { if($self->{DRAGGING} ne '') { if ($self->{DRAGGING} eq 'move') { $self->move_elements_event($x, $y) ; } elsif ($self->{DRAGGING}eq 'resize') { $self->resize_element_event($x, $y) ; } elsif ($self->{DRAGGING}eq 'select') { $self->select_element_event($x, $y) ; } } else { my @selected_elements = $self->get_selected_elements(1) ; my ($first_element) = first_value {$self->is_over_element($_, $x, $y)} reverse @selected_elements ; if(@selected_elements > 1) { if(defined $first_element) { $self->{DRAGGING} = 'move' ; } else { $self->{DRAGGING} = 'select' ; } } else { if(defined $first_element) { $self->{DRAGGING} = $first_element->get_selection_action ( $x - $first_element->{X}, $y - $first_element->{Y}, ); $self->{DRAGGING} ='' unless exists $self->{VALID_SELECT_ACTION}{$self->{DRAGGING}} ; } else { $self->{DRAGGING} = 'select' ; } } ($self->{PREVIOUS_X}, $self->{PREVIOUS_Y}) = ($x, $y) ; } } if ($event->state >= "button2-mask") { $self->select_element_event($x, $y, sub{ref $_[0] ne 'App::Asciio::stripes::section_wirl_arrow'}) ; } return TRUE; } #----------------------------------------------------------------------------- sub select_element_event { my ($self, $x, $y, $filter) = @_ ; my ($x_offset, $y_offset) = ($x - $self->{PREVIOUS_X}, $y - $self->{PREVIOUS_Y}) ; if($x_offset != 0 || $y_offset != 0) { $self->{SELECTION_RECTANGLE}{END_X} = $x ; $self->{SELECTION_RECTANGLE}{END_Y} = $y ; $filter = sub {1} unless defined $filter ; $self->select_elements ( 1, grep { $filter->($_) } grep # elements within selection rectangle { $self->element_completely_within_rectangle ( $_, $self->{SELECTION_RECTANGLE}, ) } @{$self->{ELEMENTS}} ) ; $self->update_display(); ($self->{PREVIOUS_X}, $self->{PREVIOUS_Y}) = ($x, $y) ; } } #----------------------------------------------------------------------------- sub move_elements_event { my ($self, $x, $y) = @_; my ($x_offset, $y_offset) = ($x - $self->{PREVIOUS_X}, $y - $self->{PREVIOUS_Y}) ; if($x_offset != 0 || $y_offset != 0) { my @selected_elements = $self->get_selected_elements(1) ; $self->move_elements($x_offset, $y_offset, @selected_elements) ; $self->update_display(); ($self->{PREVIOUS_X}, $self->{PREVIOUS_Y}) = ($x, $y) ; } } #----------------------------------------------------------------------------- sub resize_element_event { my ($self, $x, $y) = @_ ; my ($x_offset, $y_offset) = ($x - $self->{PREVIOUS_X}, $y - $self->{PREVIOUS_Y}) ; if($x_offset != 0 || $y_offset != 0) { my ($selected_element) = $self->get_selected_elements(1) ; $self->{RESIZE_CONNECTOR_NAME} = $self->resize_element ( $self->{PREVIOUS_X} - $selected_element->{X}, $self->{PREVIOUS_Y} - $selected_element->{Y} , $x - $selected_element->{X}, $y - $selected_element->{Y} , $selected_element, $self->{RESIZE_CONNECTOR_NAME}, ) ; $self->update_display(); ($self->{PREVIOUS_X}, $self->{PREVIOUS_Y}) = ($x, $y) ; } } #----------------------------------------------------------------------------- sub key_press_event { my ($widget, $event, $self)= @_; #~ print DumpTree \@_, '', DISPLAY_PERL_ADDRESS => 1 ; #~ print "key_press_event: keyval is <" . $event->keyval() . ">\n" ; my $key = $C{$event->keyval()} ; my $modifiers = get_key_modifiers($event) ; $self->run_actions("$modifiers-$key") ; return FALSE; } =head1 DEPENDENCIES gnome libraries, gtk, gtk-perl, perl =head1 BUGS AND LIMITATIONS Undoubtedly many as I wrote this as a fun little project where I used no design nor 'methodic' whatsoever. =head1 AUTHOR Khemir Nadim ibn Hamouda CPAN ID: NKH mailto:nadim@khemir.net =head1 LICENSE AND COPYRIGHT This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SUPPORTED OSes =head2 Gentoo I run gentoo, packages to install gtk-perl exist. Install Ascii with cpan. =head2 FreeBSD FreeBSD users can now install asciio either by package: $ pkg_add -r asciio or from source (out of the ports system) by: $ cd /usr/ports/graphics/asciio $ make install clean Thanks to Emanuel Haupt. =head2 Ubuntu and Debian Ports are on the way. =head2 Windows AsciiO is part of B and can be found here: L. Install, run AsciiO from the 'bin' directory. .-------------------------------. / /| / camelbox for win32 / | / / | / / | .-------------------------------. | | ______\\_, | | | (_. _ o_ _/ | | | '-' \_. / | | | / / | | | / / .--. .--. | | | ( ( / '' \/ '' \ " | | | \ \_.' \ ) | | | || _ './ | | | |\ \ ___.'\ / | | | '-./ .' \ |/ | | | \| / )|\ | | | |/ // \\ | . | |\ __// \\__ | / | //\\ /__/ mrf\__| | / | .--_/ \_--. | / | /__/ \__\ |/ '-------------------------------' B is a great distribution for windows. I hope it will merge with X-berry series of Perl distributions. =head1 Mac OsX This works too (and I have screenshots to prove it :). I don't own a mac and the mac user hasn't send me how to do it yet. =head1 other unices YMMV, install gtk-perl and AsciiO from cpan. =head1 SEE ALSO http://www.jave.de http://search.cpan.org/~osfameron/Text-JavE-0.0.2/JavE.pm http://ditaa.sourceforge.net/ http://www.codeproject.com/KB/macros/codeplotter.aspx http://search.cpan.org/~jpierce/Text-FIGlet-1.06/FIGlet.pm http://www.fossildraw.com/?gclid=CLanxZXxoJECFRYYEAodnBS8Dg (doesn't always respond) http://www.ascii-art.de (used some entries as base for the network stencil) http://c2.com/cgi/wiki?UmlAsciiArt http://www.textfiles.com/art/ http://www2.b3ta.com/_bunny/texbunny.gif *\o_ _o/* / * * \ <\ *\o/* /> ) o/* / > *\o <\ /> __o */\ /\* o__ * /> <\ * /\* __o_ _o__ */\ * / * * \ * <\ /> *\o/* ejm97 __)__ =cut #------------------------------------------------------------------------------------------------------ "ASCII world domination!" ; App-Asciio-1.02.71/setup/0000755000076400001440000000000011122301056013751 5ustar nadimusersApp-Asciio-1.02.71/setup/import_export/0000755000076400001440000000000011122301056016664 5ustar nadimusersApp-Asciio-1.02.71/setup/import_export/asciioe.pl0000444000076400001440000000215711122301056020640 0ustar nadimusers #---------------------------------------------------------------------------------------------------------------------------- use File::Slurp ; #---------------------------------------------------------------------------------------------------------------------------- register_import_export_handlers ( asciioe => { IMPORT => \&import_asciioe, EXPORT => \&export_asciioe, }, ) ; #---------------------------------------------------------------------------------------------------------------------------- sub import_asciioe { my ($self, $file) = @_ ; my $self_to_resurect= do $file or die "import_asciioe: can't load file '$file': $! $@\n" ; return($self_to_resurect, $file) ; } #---------------------------------------------------------------------------------------------------------------------------- sub export_asciioe { my ($self, $elements_to_save, $file, $data) = @_ ; if($self->{CREATE_BACKUP} && -e $file) { use File::Copy; copy($file,"$file.bak") or die "export_pod: Copy failed while making backup copy: $!"; } write_file($file, $self->serialize_self(1) .'$VAR1 ;') ; return $file ; } App-Asciio-1.02.71/setup/import_export/png.pl0000444000076400001440000000111111122301056017775 0ustar nadimusers register_import_export_handlers ( png => { IMPORT => undef , EXPORT => \&export_png, }, ) ; sub export_png { my ($self, $elements_to_save, $file) = @_ ; if($self->{CREATE_BACKUP} && -e $file) { use File::Copy; copy($file,"$file.bak") or die "export_pod: Copy failed while making backup copy: $!"; } my $alloc = $self->{widget}->allocation; my $pixbuf = Gtk2::Gdk::Pixbuf->get_from_drawable ( $self->{PIXMAP}, $self->{widget}->window->get_colormap, 0, 0, 0, 0, $alloc->width, $alloc->height ); $pixbuf->save($file, "png" ); return ; } App-Asciio-1.02.71/setup/import_export/ascii.pl0000444000076400001440000000103611122301056020307 0ustar nadimusers register_import_export_handlers ( txt => { IMPORT => undef , EXPORT => \&export_ascii, }, ) ; use File::Slurp ; sub export_ascii { my ($self, $elements_to_save, $file) = @_ ; if($self->{CREATE_BACKUP} && -e $file) { use File::Copy; copy($file,"$file.bak") or die "export_pod: Copy failed while making backup copy: $!"; } write_file($file, $self->transform_elements_to_ascii_buffer()) ; #~ open FH, ">:encoding(utf8)", $file_name; #~ print FH $self->transform_elements_to_ascii_buffer() ; #~ close FH ; return ; } App-Asciio-1.02.71/setup/import_export/perl.pl0000444000076400001440000001035111122301056020161 0ustar nadimusers #---------------------------------------------------------------------------------------------------------------------------- use File::Slurp ; use Data::Dumper ; use List::Util qw(max); use File::Basename ; #~ use Compress::LZF ':compress'; use Compress::Bzip2 qw(:all :utilities :gzip); use MIME::Base64 (); my $BASE64_HEADER = (' ' x 120) . '#asciio' ; my $BASE64_HEADER_SIZE = length($BASE64_HEADER) ; #---------------------------------------------------------------------------------------------------------------------------- register_import_export_handlers ( pod => { IMPORT => \&import_pod, EXPORT => \&export_pod, }, pl => { IMPORT => \&import_pod, EXPORT => \&export_pod, }, pm => { IMPORT => \&import_pod, EXPORT => \&export_pod, }, ) ; #---------------------------------------------------------------------------------------------------------------------------- sub import_pod { my ($self, $file) = @_ ; my ($base_name, $path, $extension) = File::Basename::fileparse($file, ('\..*')) ; my $file_name = $base_name . $extension ; my ($base64_data, $header, $footer) = get_base64_data($file_name) ; my $decoded_base64 = MIME::Base64::decode($base64_data); my $self_to_resurect = decompress($decoded_base64) ; my $VAR1 ; my $resurected_self = eval $self_to_resurect ; die $@ if $@ ; return($resurected_self, $file, {HEADER => $header, FOOTER => $footer}) ; } sub get_base64_data { =pod find all asciio sections select one section extract section remove diagram and padding regenerate base 64 string =cut my ($file_name) = @_ ; my ($header, $footer) = ('', '') ; eval "use Pod::Select ; use Pod::Text;" ; die $@ if $@ ; open INPUT, '<', $file_name or die "get_base64_data: Can't open '$file_name'!\n" ; open my $out, '>', \my $all_pod or die "Can't redirect to scalar output: $!\n"; my $parser = new Pod::Select(); $parser->parse_from_filehandle(\*INPUT, $out); $all_pod .= '=cut' ; #add the =cut taken away by above parsing my @asciio_pods ; while($all_pod =~ /(^=.*?(?=\n=))/smg) { my $section = $1 ; if($section =~ s/^=for asciio\s*//i) { push @asciio_pods, "=for asciio $section" ; last ; } } #todo: handle files without asciio section #todo: handle files with multiple asciio sections my $asciio_section = $asciio_pods[0] ; my @asciio_lines = split "\n", $asciio_section ; my $asciio_header = shift @asciio_lines ; #~ use Data::TreeDumper ; #~ print DumpTree \@asciio_lines, 'asciio_lines' ; my $whole_file = read_file($file_name) ; if($whole_file =~ /(.*)$asciio_header.*?(\n=.*)/sm) { ($header, $footer) = ($1, $2) ; } else { die "get_base64_data: Can't find the text we just extracted!" ; } my ($for, $asciio, $width, $name) = split ' ', $asciio_header ; my $base64 = '' ; for my $asciio_line (@asciio_lines) { substr($asciio_line, 0, $width + $BASE64_HEADER_SIZE + 1, '') ; # strip to base64 $base64 .= $asciio_line . "\n" ; } return ($base64, $header, $footer) ; } #---------------------------------------------------------------------------------------------------------------------------- sub export_pod { my ($self, $elements_to_save, $file, $data) = @_ ; my ($base_name, $path, $extension) = File::Basename::fileparse($file, ('\..*')) ; my $file_name = $base_name . $extension ; my @ascii_representation = $self->transform_elements_to_ascii_array() ; my $longest_line = max( map{length} @ascii_representation) ; my $compressed_self = compress($self->serialize_self() . '$VAR1 ;') ; my $base64 =MIME::Base64::encode($compressed_self, '') ; my $base64_chunk_size = int((length($base64) / @ascii_representation) + 1) ; if($self->{CREATE_BACKUP} && -e $file) { use File::Copy; copy($file,"$file.bak") or die "export_pod: Copy failed while making backup copy: $!"; } open POD, ">:encoding(utf8)", $file_name or die "export_pod: can't open file '$file_name'!\n"; print POD $data->{HEADER} || '' ; print POD "=for asciio $longest_line $base_name\n\n" ; for my $diagram_line (@ascii_representation) { my $padding = ' ' x ($longest_line - length($diagram_line)) ; my $base64_chunk = substr($base64, 0, $base64_chunk_size, '') || '' ; print POD ' ' , $diagram_line, $padding, $BASE64_HEADER, $base64_chunk, "\n" } print POD $data->{FOOTER} || "\n=cut\n\n"; close POD ; return $file ; } App-Asciio-1.02.71/setup/asciio_object/0000755000076400001440000000000011122301056016546 5ustar nadimusersApp-Asciio-1.02.71/setup/asciio_object/basic.pl0000444000076400001440000000206111122301056020161 0ustar nadimusersFONT_FAMILY => 'Monospace', FONT_SIZE => '10', TAB_AS_SPACES => ' ', DISPLAY_GRID => 1, COPY_OFFSET_X => 3, COPY_OFFSET_Y => 3, COLORS => { background => [255, 255, 255], grid => [229, 235, 255], ruler_line => [85, 155, 225], selected_element_background => [180, 244, 255], element_background => [251, 251, 254], element_foreground => [0, 0, 0] , selection_rectangle => [255, 0, 255], test => [0, 255, 255], group_colors => [ [[250, 221, 190], [250, 245, 239]], [[182, 250, 182], [241, 250, 241]], [[185, 219, 250], [244, 247, 250]], [[137, 250, 250], [235, 250, 250]], [[198, 229, 198], [239, 243, 239]], ], connection => 'Chocolate', connection_point => [230, 198, 133], connector_point => 'DodgerBlue', extra_point => [230, 198, 133], }, RULER_LINES => [ { TYPE => 'VERTICAL', COLOR => [220, 200, 200], POSITION => 80, NAME => 'RIGHT_LIMIT', }, { TYPE => 'HORIZONTAL', COLOR => [220, 200, 200], POSITION => 50, NAME => 'BOTTOM_LIMIT', }, ], WORK_DIRECTORY => '.asciio_work_dir', CREATE_BACKUP => 1, App-Asciio-1.02.71/setup/hooks/0000755000076400001440000000000011122301056015074 5ustar nadimusersApp-Asciio-1.02.71/setup/hooks/canonize_connections.pl0000555000076400001440000001437011122301056021647 0ustar nadimusers #~ use Data::TreeDumper ; #---------------------------------------------------------------------------------------------- register_hooks ( ['CANONIZE_CONNECTIONS' => \&canonize_connections], ) ; #---------------------------------------------------------------------------------------------- =pod .-------. | | | .---. | | C | start connector (first character) | C | o | / | O | n | / | N | n | .---. end connector (last character) | N | e | | --------------------------------. / | E | c | '---' | / | C | t | CONNECTED .-|-./ | T | i | | v | | E | o | '---' | E | n | | '---' .------------. | | | Connection | '-------' .----'------------'-----. | | | CONNECTEE | | | '-----------------------' =cut sub canonize_connections { my ($connections) = @_ ; for my $connection (@{$connections}) { if ( ref $connection->{CONNECTED} eq 'App::Asciio::stripes::section_wirl_arrow' && $connection->{CONNECTED}->is_autoconnect_enabled() ) { reconnect_section_wirl_arrow($connection) ; } } } sub reconnect_section_wirl_arrow { my ($connection) = @_ ; my ($connected, $connectee) = ($connection->{CONNECTED}, $connection->{CONNECTEE}) ; my @connectors = $connected->get_all_points() ; my ($start_name, $end_name) = ($connectors[0]{NAME}, $connectors[-1]{NAME}) ; if($connection->{CONNECTOR}{NAME} eq $end_name) { # end connector my ($connectee_x, $connectee_y, $connectee_width, $connectee_hight) = ($connectee->{X}, $connectee->{Y}, $connectee->get_size()) ; my $connected_x = $connected->{X} + $connectors[-2]{X}; my $connected_y = $connected->{Y} + $connectors[-2]{Y}; if($connected_x < $connectee_x) { # arrow starts on left of the box if($connected->get_section_direction(-1) =~ /^right/) { if($connected_y < $connectee_y) { reconnect($connection, 'top_center', $end_name) ; } else { if($connected_y < $connectee_y + $connectee_hight) { reconnect($connection, 'left_center', $end_name) ; } else { # arrow below, right-up to bottom_center reconnect($connection, 'bottom_center', $end_name) ; } } } else { # arrow going up or down reconnect($connection, 'left_center', $end_name) ; } } elsif($connected_x < $connectee_x + $connectee_width) { # arrow starts within width of the box if($connected_y < $connectee_y) { #arrow above, right-down to top_center reconnect($connection, 'top_center', $end_name, 'right') ; } else { reconnect($connection, 'bottom_center', $end_name) ; } } else { # arrow starts on right of the box if($connected->get_section_direction(-1) =~ /^left/) { if($connected_y < $connectee_y) { reconnect($connection, 'top_center', $end_name) ; } else { if($connected_y < $connectee_y + $connectee_hight) { reconnect($connection, 'right_center', $end_name) ; } else { reconnect($connection, 'bottom_center', $end_name) ; } } } else { # arrow going up or down reconnect($connection, 'right_center', $end_name) ; } } } else { # start connector my ($connectee_x, $connectee_y, $connectee_width, $connectee_hight) = ($connectee->{X}, $connectee->{Y}, $connectee->get_size()) ; my $end_connector_x = $connected->{X} + $connectors[1]{X}; my $end_connector_y = $connected->{Y} + $connectors[1]{Y} ; if($end_connector_x < $connectee_x) { # arrow ends on left of the box if($connected->get_section_direction(0) !~ /^left/) { if($end_connector_y < $connectee_y) { reconnect($connection, 'top_center', $start_name) ; } else { if($end_connector_y < $connectee_y + $connectee_hight) { reconnect($connection, 'left_center', $start_name) ; } else { reconnect($connection, 'bottom_center', $start_name) ; } } } else { reconnect($connection, 'left_center', $start_name) ; } } elsif($end_connector_x < $connectee_x + $connectee_width) { # arrow starts within width of the box if($end_connector_y < $connectee_y) { reconnect($connection, 'top_center', $start_name) ; } else { reconnect($connection, 'bottom_center', $start_name) ; } } else { # arrow ends on right of the box if($connected->get_section_direction(0) !~ /^right/) { if($end_connector_y < $connectee_y) { reconnect($connection, 'top_center', $start_name) ; } else { if($end_connector_y < $connectee_y + $connectee_hight) { reconnect($connection, 'right_center', $start_name) ; } else { reconnect($connection, 'bottom_center', $start_name) ; } } } else { reconnect($connection, 'right_center', $start_name) ; } } } } sub reconnect { my($asciio_connection, $connection_name, $connector_name, $hint) = @_ ; if($asciio_connection->{CONNECTION}{NAME} ne $connection_name) { my ($connected, $connectee) = ($asciio_connection->{CONNECTED}, $asciio_connection->{CONNECTEE}) ; my ($connection) = $connectee->get_named_connection($connection_name) ; my ($connector) = $connected->get_named_connection($connector_name) ; my $x_offset_to_connection = ($connectee->{X} + $connection->{X}) - ($connected->{X} + $connector->{X}) ; my $y_offset_to_connection = ($connectee->{Y} + $connection->{Y}) - ($connected->{Y} + $connector->{Y}) ; # move connector #~ print "reconnect: $connection_name $connector_name\n" ; my ($x_offset, $y_offset, $width, $height, $new_connector) = $connected->move_connector($connector_name, $x_offset_to_connection, $y_offset_to_connection, $hint) ; $connected->{X} += $x_offset ; $connected->{Y} += $y_offset ; $asciio_connection->{CONNECTOR} = $new_connector ; $asciio_connection->{CONNECTION} = $connection ; } } App-Asciio-1.02.71/setup/setup.ini0000444000076400001440000000133611122301056015613 0ustar nadimusers{ STENCILS => [ 'stencils/asciio', 'stencils/computer', 'stencils/people', 'stencils/divers', ], ACTION_FILES => [ 'actions/align.pl', 'actions/clipboard.pl', 'actions/debug.pl', 'actions/new_elements.pl', 'actions/elements_manipulation.pl', 'actions/file.pl', 'actions/mouse.pl', 'actions/colors.pl', 'actions/unsorted.pl', 'actions/presentation.pl', 'actions/context_menu_multi_wirl.pl', 'actions/context_menu_box.pl', 'actions/context_menu_rulers.pl', ], HOOK_FILES => [ 'hooks/canonize_connections.pl', ], ASCIIO_OBJECT_SETUP => [ 'asciio_object/basic.pl', ], IMPORT_EXPORT => [ 'import_export/ascii.pl', 'import_export/perl.pl', 'import_export/asciioe.pl', 'import_export/png.pl', ], } App-Asciio-1.02.71/setup/actions/0000755000076400001440000000000011122301056015411 5ustar nadimusersApp-Asciio-1.02.71/setup/actions/presentation.pl0000555000076400001440000000324711122301056020470 0ustar nadimusers #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Load slides'=> ['C00-l', \&load_slides] , 'previous slide' => ['C00-Left', \&previous_slide], 'next slide' => ['C00-Right', \&next_slide], 'first slide' => ['C00-Up', \&first_slide], ) ; #---------------------------------------------------------------------------------------------- my ($slides, $current_slide) ; #---------------------------------------------------------------------------------------------- sub load_slides { my ($self) = @_ ; # get file name for slides definitions my $file_name = $self->get_file_name('open') ; # load slides $slides = do $file_name or die $@ ; $current_slide = 0 ; # run first slide $slides->[$current_slide]->($self) ; $self->update_display() ; } #---------------------------------------------------------------------------------------------- sub first_slide { my ($self) = @_ ; if($slides) { $current_slide = 0 ; $slides->[$current_slide]->($self) ; $self->update_display() ; } } #---------------------------------------------------------------------------------------------- sub next_slide { my ($self) = @_ ; if($slides && $current_slide != $#$slides) { $current_slide++ ; $slides->[$current_slide]->($self) ; $self->update_display() ; } } #---------------------------------------------------------------------------------------------- sub previous_slide { my ($self) = @_ ; if($slides && $current_slide != 0) { $current_slide-- ; $slides->[$current_slide]->($self) ; $self->update_display() ; } } #---------------------------------------------------------------------------------------------- App-Asciio-1.02.71/setup/actions/colors.pl0000555000076400001440000000313511122301056017252 0ustar nadimusers #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Change elements background color' => ['000-c', \&change_elements_colors, 0], 'Change elements foreground color' => ['00S-C', \&change_elements_colors, 1], 'Change AsciiO background color' => ['0A0-c', \&change_asciio_background_color], 'Change grid color' => ['0AS-C', \&change_grid_color], ) ; #---------------------------------------------------------------------------------------------- sub change_elements_colors { my ($self, $is_background) = @_ ; my ($color) = $self->get_color_from_user([0, 0, 0]) ; $self->create_undo_snapshot() ; for my $element($self->get_selected_elements(1)) { $is_background ? $element->set_background_color($color) : $element->set_foreground_color($color) ; } $self->update_display() ; } #---------------------------------------------------------------------------------------------- sub change_asciio_background_color { my ($self) = @_ ; my ($color) = $self->get_color_from_user([0, 0, 0]) ; $self->create_undo_snapshot() ; $self->flush_color_cache() ; $self->{COLORS}{background} = $color ; $self->update_display() ; } #---------------------------------------------------------------------------------------------- sub change_grid_color { my ($self) = @_ ; my ($color) = $self->get_color_from_user([0, 0, 0]) ; $self->create_undo_snapshot() ; $self->flush_color_cache() ; $self->{COLORS}{grid} = $color ; $self->update_display() ; } #---------------------------------------------------------------------------------------------- App-Asciio-1.02.71/setup/actions/context_menu_rulers.pl0000555000076400001440000000370211122301056022055 0ustar nadimusers #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Add ruler' => ['000-r', \&add_ruler, undef, \&rulers_context_menu], 'Remove rulers' => ['00S-R', \&remove_ruler], ) ; #---------------------------------------------------------------------------------------------- sub add_ruler { my ($self, $data) = @_ ; $self->create_undo_snapshot() ; my ($type, $column, $line) ; $data = {TYPE => 'VERTICAL', POSITION => $self->{MOUSE_X}} unless defined $data ; $self->add_ruler_lines ({ COLOR => $self->{COLORS}{ruler_line}, NAME => 'from context menu', %{$data}, }) ; $self->update_display(); } #---------------------------------------------------------------------------------------------- sub remove_ruler { my ($self, $data) = @_ ; $data = {TYPE => 'VERTICAL', POSITION => $self->{MOUSE_X}} unless defined $data ; $self->create_undo_snapshot() ; $self->remove_ruler_lines($data) ; $self->update_display(); } #---------------------------------------------------------------------------------------------- sub rulers_context_menu { my ($self, $popup_x, $popup_y) = @_ ; my @context_menu_entries ; my ($x, $y) = $self->closest_character($popup_x, $popup_y) ; my $vertical = {TYPE => 'VERTICAL', POSITION => $x} ; my $horizontal = {TYPE => 'HORIZONTAL', POSITION => $y} ; if($self->exists_ruler_line($vertical)) { push @context_menu_entries, ["/Ruler/remove vertical ruler", \&remove_ruler, $vertical] ; } else { push @context_menu_entries, ["/Ruler/add vertical ruler", \&add_ruler, $vertical] ; } if($self->exists_ruler_line($horizontal)) { push @context_menu_entries, ["/Ruler/remove horizontal ruler", \&remove_ruler, $horizontal] ; } else { push @context_menu_entries, ["/Ruler/add horizontal ruler", \&add_ruler, $horizontal] ; } return(@context_menu_entries) ; } #---------------------------------------------------------------------------------------------- App-Asciio-1.02.71/setup/actions/unsorted.pl0000555000076400001440000002747211122301056017626 0ustar nadimusers #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Create multiple box elements from a text description' => ['C00-m', \&insert_multiple_boxes_from_text_description], 'Create multiple text elements from a text description' => ['C0S-M', \&insert_multiple_texts_from_text_description], 'Flip transparent element background' => ['C00-t', \&transparent_elements], 'Flip grid display' => ['000-g', \&flip_grid_display], 'Undo' => ['C00-z', \&undo], 'Display undo stack statistics' => ['C0S-Z', \&display_undo_stack_statistics], 'Redo' => ['C00-y', \&redo], 'Display keyboard mapping' => ['000-k', \&display_keyboard_mapping], 'Display commands' => ['C00-k', \&display_commands], 'Display action files' => ['C0S-K', \&display_action_files], 'Zoom in' => ['000-KP_Add', \&zoom, 2], 'Zoom out' => ['000-KP_Subtract', \&zoom, -2], 'Help' => ['000-F1', \&display_help], 'External command output in a box' => ['000-x', \&external_command_output, 1], 'External command output in a box no frame' => ['C00-x', \&external_command_output, 0], ) ; #---------------------------------------------------------------------------------------------- sub display_help { my ($self) = @_ ; $self->display_message_modal(<get_font() ; $self->set_font($family, $size + $direction) ; } #---------------------------------------------------------------------------------------------- sub display_keyboard_mapping { my ($self) = @_ ; #~ print Data::TreeDumper::DumpTree $self->{ACTIONS_BY_NAME}, 'ACTIONS_BY_NAME:'; my $keyboard_mapping = get_keyboard_mapping($self->{ACTIONS_BY_NAME}) ; #~ print Data::TreeDumper::DumpTree $keyboard_mapping , 'Keyboard mapping:'; $self->show_dump_window ( $keyboard_mapping , 'Keyboard mapping:', DISPLAY_ADDRESS => 0, ) } sub get_keyboard_mapping { my ($actions, $list) = @_ ; $list ||= [] ; my $keyboard_mapping ; for my $action (keys %{$actions}) { if('ARRAY' eq ref $actions->{$action}) { my $shortcut = ref $actions->{$action}[0] eq '' ? $actions->{$action}[0] : '[' . join('/', @{$actions->{$action}[0]}) . ']'; $keyboard_mapping->{$shortcut . ' => ' . $action} = {FILE=> $actions->{$action}[6]} ; } elsif('HASH' eq ref $actions->{$action}) { my $sub_keyboard_mapping = get_keyboard_mapping($actions->{$action}) ; for my $shortcut (keys %{$sub_keyboard_mapping}) { my $start_shortcut = '[' . join('/', $actions->{$action}{SHORTCUTS}) . '] + '; $keyboard_mapping->{$start_shortcut . $shortcut} = $sub_keyboard_mapping->{$shortcut} ; } } else { #~ die "unknown type while running 'dump_keyboard_mapping'\n" ; } } return($keyboard_mapping) ; } #---------------------------------------------------------------------------------------------- sub display_commands { my ($self) = @_ ; #~ print Data::TreeDumper::DumpTree $self->{ACTIONS_BY_NAME}, 'ACTIONS_BY_NAME:'; my $commands = get_commands($self->{ACTIONS_BY_NAME}) ; $self->show_dump_window ( $commands, 'commands:', DISPLAY_ADDRESS => 0, ) } sub get_commands { my ($actions, $list) = @_ ; $list ||= [] ; my $commands ; for my $action (keys %{$actions}) { if('ARRAY' eq ref $actions->{$action}) { my $shortcut = ref $actions->{$action}[0] eq '' ? $actions->{$action}[0] : '[' . join('/', @{$actions->{$action}[0]}) . ']'; $commands->{$action . " [$shortcut]"} = {FILE=> $actions->{$action}[6]} ; } elsif('HASH' eq ref $actions->{$action}) { my $sub_commands = get_commands($actions->{$action}) ; for my $shortcut (keys %{$sub_commands}) { my ($name, $shortcut_text) = $shortcut =~ /([^\[]*)(.*)/ ; my $start_shortcut = '[' . join('/', $actions->{$action}{SHORTCUTS}) . '] + '; $commands->{$name . $start_shortcut . $shortcut_text} = $sub_commands->{$shortcut} ; } } else { #~ die "unknown type while running 'dump_keyboard_mapping'\n" ; } } return($commands) ; } #---------------------------------------------------------------------------------------------- sub display_action_files { my ($self) = @_ ; my $actions_per_file = {} ; generate_keyboard_mapping_text_dump($self->{ACTIONS_BY_NAME}, $actions_per_file) ; #~ print Data::TreeDumper::DumpTree #~ $actions_per_file, #~ 'Action files:', #~ DISPLAY_ADDRESS => 0, #~ GLYPHS => [' ', ' ', ' ', ' '], #~ NO_NO_ELEMENTS => 1, #~ FILTER => \&filter_keyboard_mapping ; $self->show_dump_window ( $actions_per_file, 'Action files:', DISPLAY_ADDRESS => 0, GLYPHS => [' ', ' ', ' ', ' '], NO_NO_ELEMENTS => 1, FILTER => \&filter_keyboard_mapping ) ; } sub filter_keyboard_mapping { my $s = shift ; if('HASH' eq ref $s) { my (%hash, @keys) ; for my $entry (sort keys %{$s}) { if('ARRAY' eq ref $s->{$entry}) { my $shortcuts = $s->{$entry}[0] ; $shortcuts = join(' ', @{$shortcuts}) if('ARRAY' eq ref $shortcuts) ; my $key_name = "$entry [$shortcuts]" ; $hash{$key_name} = [] ; push @keys, $key_name ; } else { $hash{$entry} = $s->{$entry} ; push @keys, $entry ; } } return('HASH', \%hash, @keys) ; } return(Data::TreeDumper::DefaultNodesToDisplay($s)) ; } sub generate_keyboard_mapping_text_dump { my ($key_mapping, $actions_per_file) = @_ ; die "Need argument!" unless defined $actions_per_file ; for my $action (keys %{$key_mapping}) { if('ARRAY' eq ref $key_mapping->{$action}) { $actions_per_file->{$key_mapping->{$action}[6]}{$action} = $key_mapping->{$action} ; } elsif('HASH' eq ref $key_mapping->{$action}) { my $sub_actions = {} ; { local $key_mapping->{$action}{GROUP_NAME} = undef ; local $key_mapping->{$action}{ORIGIN} = undef ; local $key_mapping->{$action}{SHORTCUTS} = undef ; generate_keyboard_mapping_text_dump($key_mapping->{$action}, $sub_actions) ; } #~ print Data::TreeDumper::DumpTree $key_mapping->{$action} ; #~ print Data::TreeDumper::DumpTree $sub_actions ; my $shortcuts = $key_mapping->{$action}{SHORTCUTS} ; $shortcuts = join(' ', @{$key_mapping->{$action}{SHORTCUTS}}) if('ARRAY' eq ref $key_mapping->{$action}{SHORTCUTS}) ; $actions_per_file->{$key_mapping->{$action}{ORIGIN}}{"group: $action [$shortcuts]"} = $sub_actions->{$key_mapping->{$action}{ORIGIN}} ; } else { #~ print Data::TreeDumper::DumpTree $key_mapping->{$action}, $action ; #~ die "unknown type while running 'dump_keyboard_mapping'\n" ; } } } #---------------------------------------------------------------------------------------------- sub code_to_key { my ($modifier_and_code) = @_ ; use Gtk2::Gdk::Keysyms ; my %K = %Gtk2::Gdk::Keysyms ; my %C = map{$K{$_} => $_} keys %K ; my($modifier, $code) = $modifier_and_code=~ /^(...)(.*)/ ; my $key = $C{$code} || $code ; "$modifier-$key" ; } #---------------------------------------------------------------------------------------------- sub undo { my ($self) = @_ ; $self->undo(1) ; } #---------------------------------------------------------------------------------------------- sub redo { my ($self) = @_ ; $self->redo(1) ; } #---------------------------------------------------------------------------------------------- sub display_undo_stack_statistics { my ($self) = @_ ; my $statistics = { DO_STACK_POINTER => $self->{DO_STACK_POINTER} } ; my $total_size = 0 ; for my $stack_element (@{$self->{DO_STACK}}) { push @{$statistics->{ELEMENT_SIZE}}, length($stack_element) ; $total_size += length($stack_element) ; } $statistics->{TOTAL_SIZE} = $total_size ; $self->show_dump_window($statistics, 'Undo stack statistics:') ; } #---------------------------------------------------------------------------------------------- sub insert_multiple_boxes_from_text_description { my ($self) = @_ ; $self->create_undo_snapshot() ; my $text = $self->display_edit_dialog('multiple boxes from input', "--\nA\n--\nB\n--\nC\n--\nD\n--\nE\n" ) ; if(defined $text && $text ne '') { my ($current_x, $current_y) = ($self->{MOUSE_X}, $self->{MOUSE_Y}) ; my ($separator) = split("\n", $text) ; $text =~ s/$separator\n// ; for my $element_text (split("$separator\n", $text)) { chomp $element_text ; my $new_element = new App::Asciio::stripes::editable_box2 ({ TITLE => '', TEXT_ONLY => $element_text, EDITABLE => 1, RESIZABLE => 1, }) ; @$new_element{'X', 'Y'} = ($current_x, $current_y) ; $current_x += $self->{COPY_OFFSET_X} ; $current_y += $self->{COPY_OFFSET_Y} ; $self->add_elements($new_element) ; } $self->update_display() ; } } sub insert_multiple_texts_from_text_description { my ($self) = @_ ; $self->create_undo_snapshot() ; my $text = $self->display_edit_dialog('multiple texts from input', "--\ntext\n--\ntext\n--\ntext\n--\ntext" ) ; if(defined $text && $text ne '') { my ($current_x, $current_y) = ($self->{MOUSE_X}, $self->{MOUSE_Y}) ; my ($separator) = split("\n", $text) ; $text =~ s/$separator\n// ; for my $element_text (split("$separator\n", $text)) { chomp $element_text ; my $new_element = new App::Asciio::stripes::editable_box2 ({ TITLE => '', TEXT_ONLY => $element_text, BOX_TYPE => [ [0, 'top', '.', '-', '.', 1, ], [0, 'title separator', '.', '-', '.', 1, ], [0, 'body separator', '. ', '|', ' .', 1, ], [0, 'bottom', '\'', '-', '\'', 1, ], ], EDITABLE => 1, RESIZABLE => 1, }) ; @$new_element{'X', 'Y'} = ($current_x, $current_y) ; $current_x += $self->{COPY_OFFSET_X} ; $current_y += $self->{COPY_OFFSET_Y} ; $self->add_elements($new_element) ; } $self->update_display() ; } } #---------------------------------------------------------------------------------------------- sub flip_grid_display { my ($self) = @_ ; $self->{DISPLAY_GRID} ^=1 ; $self->update_display(); } #---------------------------------------------------------------------------------------------- sub transparent_elements { my ($self) = @_ ; $self->{OPAQUE_ELEMENTS} ^=1 ; $self->update_display(); } #---------------------------------------------------------------------------------------------- sub external_command_output { my ($self, $in_box) = @_ ; $self->create_undo_snapshot() ; my $command = $self->display_edit_dialog('Enter command', '') ; if(defined $command && $command ne '') { (my $command_stderr_redirected = $command) =~ s/$/ 2>&1/gsm ; my $output = `$command_stderr_redirected` ; if($?) { $output = '' unless defined $output ; $output = "Can't execute '$command':\noutput:\n$output\nerror:\n$! [$?]" ; $in_box++ ; } my @box ; unless($in_box) { push @box, BOX_TYPE => [ [0, 'top', '.', '-', '.', 1, ], [0, 'title separator', '|', '-', '|', 1, ], [0, 'body separator', '| ', '|', ' |', 1, ], [0, 'bottom', '\'', '-', '\'', 1, ], ] ; } use App::Asciio::stripes::editable_box2 ; my $new_element = new App::Asciio::stripes::editable_box2 ({ TEXT_ONLY => $output, TITLE => '', EDITABLE => 1, RESIZABLE => 1, @box }) ; $self->add_element_at($new_element, $self->{MOUSE_X}, $self->{MOUSE_Y}) ; $self->update_display() ; } } App-Asciio-1.02.71/setup/actions/clipboard.pl0000555000076400001440000000764111122301056017716 0ustar nadimusers use List::Util qw(min max) ; #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Copy to clipboard' => [ ['C00-c', 'C00-Insert'] , \©_to_clipboard ], 'Insert from clipboard' => [ ['C00-v', '00S-Insert'] , \&insert_from_clipboard ], 'Export to clipboard & primary as ascii'=> ['C00-e', \&export_to_clipboard_as_ascii] , 'Import from clipboard to box'=> ['C0S-E', \&import_from_clipboard_to_box] , 'Import from primary to box'=> ['0A0-e', \&import_from_primary_to_box] , ) ; #---------------------------------------------------------------------------------------------- sub export_to_clipboard_as_ascii { my ($self) = @_ ; my $ascii = $self->transform_elements_to_ascii_buffer($self->get_selected_elements(1)) ; Gtk2::Clipboard->get (Gtk2::Gdk->SELECTION_CLIPBOARD)->set_text($ascii); # also put in selection -- DH Gtk2::Clipboard->get (Gtk2::Gdk->SELECTION_PRIMARY)->set_text($ascii); } #---------------------------------------------------------------------------------------------- sub import_from_clipboard_to_box { my ($self) = @_ ; my $ascii = Gtk2::Clipboard->get (Gtk2::Gdk->SELECTION_CLIPBOARD)->wait_for_text(); my $element = $self->add_new_element_named('stencils/asciio/box', $self->{MOUSE_X}, $self->{MOUSE_Y}) ; $element->set_text('', $ascii) ; $self->select_elements(1, $element) ; $self->update_display() ; } #---------------------------------------------------------------------------------------------- sub import_from_primary_to_box { my ($self) = @_ ; my $ascii = Gtk2::Clipboard->get (Gtk2::Gdk->SELECTION_PRIMARY)->wait_for_text(); my $element = $self->add_new_element_named('stencils/asciio/box', $self->{MOUSE_X}, $self->{MOUSE_Y}) ; $element->set_text('', $ascii) ; $self->select_elements(1, $element) ; $self->update_display() ; } #---------------------------------------------------------------------------------------------- sub copy_to_clipboard { my ($self) = @_ ; my @selected_elements = $self->get_selected_elements(1) ; return unless @selected_elements ; my %selected_elements = map { $_ => 1} @selected_elements ; my @connections = grep { exists $selected_elements{$_->{CONNECTED}} && exists $selected_elements{$_->{CONNECTEE}} } $self->get_connections_containing(@selected_elements) ; my $elements_and_connections = { ELEMENTS => \@selected_elements, CONNECTIONS => \@connections , }; # print Data::TreeDumper::DumpTree $elements_and_connections, '$elements_and_connections:', MAX_DEPTH => 2 ; #~ print Data::Dumper::Dumper $elements_and_connections ;#, '$elements_and_connections:', MAX_DEPTH => 2 ; $self->{CLIPBOARD} = Clone::clone($elements_and_connections) ; } ; #---------------------------------------------------------------------------------------------- sub insert_from_clipboard { my ($self, $x_offset, $y_offset) = @_ ; $self->create_undo_snapshot() ; $self->select_elements(0, @{$self->{ELEMENTS}}) ; unless(defined $x_offset) { my $min_x = min(map {$_->{X}} @{$self->{CLIPBOARD}{ELEMENTS}}) ; $x_offset = $min_x - $self->{MOUSE_X} ; } unless(defined $y_offset) { my $min_y = min(map {$_->{Y}} @{$self->{CLIPBOARD}{ELEMENTS}}) ; $y_offset = $min_y - $self->{MOUSE_Y} ; } my %new_group ; for my $element (@{$self->{CLIPBOARD}{ELEMENTS}}) { @$element{'X', 'Y'}= ($element->{X} - $x_offset, $element->{Y} - $y_offset) ; if(exists $element->{GROUP} && scalar(@{$element->{GROUP}}) > 0) { my $group = $element->{GROUP}[-1] ; unless(exists $new_group{$group}) { $new_group{$group} = {'GROUP_COLOR' => $self->get_group_color()} ; } pop @{$element->{GROUP}} ; push @{$element->{GROUP}}, $new_group{$group} ; } else { delete $element->{GROUP} ; } } my $clipboard = Clone::clone($self->{CLIPBOARD}) ; $self->add_elements(@{$clipboard->{ELEMENTS}}) ; $self->add_connections(@{$clipboard->{CONNECTIONS}}) ; $self->update_display() ; } ; App-Asciio-1.02.71/setup/actions/file.pl0000555000076400001440000000543711122301056016677 0ustar nadimusers use File::Basename ; #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Open' => ['C00-o', \&open], 'Save' => ['C00-s', \&save, undef], 'SaveAs' => ['C0S-S', \&save, 'as'], ) ; #---------------------------------------------------------------------------------------------- sub save { my ($self, $as, $type, $file_name) = @_ ; unless(defined $file_name) { if((! defined $as) && $self->get_title()) { $file_name = $self->get_title() ; } else { $file_name = $self->get_file_name('save') ; if(defined $file_name && $file_name ne q[]) { if(-e $file_name) { my $override = $self->display_yes_no_cancel_dialog ( "Override file!", "File '$file_name' exists!\nOverride file?" ) ; $file_name = undef unless $override eq 'yes' ; } } } } if(defined $file_name && $file_name ne q[]) { my ($base_name, $path, $extension) = File::Basename::fileparse($file_name, ('\..*')) ; $extension =~ s/^\.// ; $type = defined $type ? $type : $extension ne q{} ? $extension : 'asciio_internal_format' ; my $elements_to_save = Clone::clone($self->{ELEMENTS}) ; for my $element (@{$elements_to_save}) { delete $element->{NAME} ; } my $new_title ; eval { $new_title = $self->save_with_type($elements_to_save, $type, $file_name) ; } ; if($@) { $self->display_message_modal("Can't save file '$file_name':\n$@\n") ; $file_name = undef ; } else { if(defined $new_title) { $self->set_title($new_title) ; $self->set_modified_state(0) ; } } } return $file_name ; } ; #---------------------------------------------------------------------------------------------- sub open { my ($self, $file_name) = @_ ; my $user_answer = '' ; if($self->get_modified_state()) { $user_answer = $self->display_yes_no_cancel_dialog('asciio', 'Diagram modified. Save it?') ; if($user_answer eq 'yes') { my $file_name = $self->get_file_name('save') ; my ($base_name, $path, $extension) = File::Basename::fileparse($file_name, ('\..*')) ; $extension =~ s/^\.// ; my $type = $extension ne q{} ? $extension : 'asciio_internal_format' ; $self->save_with_type(undef, $type, $file_name) if(defined $file_name && $file_name ne q[]) ; } } if($user_answer ne 'cancel') { $file_name ||= $self->get_file_name('open') ; if(defined $file_name && $file_name ne q[]) { my $title = $self->load_file($file_name) ; my ($base_name, $path, $extension) = File::Basename::fileparse($file_name, ('\..*')) ; $extension =~ s/^\.// ; my $type = $extension ne q{} ? $extension : 'asciio_internal_format' ; $self->set_title($title) if defined $title; $self->set_modified_state(0) ; } } } ; App-Asciio-1.02.71/setup/actions/context_menu_multi_wirl.pl0000555000076400001440000002304711122301056022734 0ustar nadimusers #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Append multi_wirl section' => ['000-s', \&append_section, undef, \&multi_wirl_context_menu], 'Prepend multi_wirl section' => ['0A0-s', \&prepend_section], 'Remove last section from multi_wirl' => ['000-q', \&remove_last_section_from_section_wirl_arrow], 'Remove first section from multi_wirl' => ['0A0-q', \&remove_first_section_from_section_wirl_arrow], ) ; #---------------------------------------------------------------------------------------------- sub prepend_section { my ($self) = @_ ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements == 1 && 'App::Asciio::stripes::section_wirl_arrow' eq ref $selected_elements[0]) { my $element = $selected_elements[0] ; $self->create_undo_snapshot() ; $self->delete_connections_containing($element) ; my $x_offset = $self->{MOUSE_X} - $element->{X} ; my $y_offset = $self->{MOUSE_Y} - $element->{Y} ; $element->prepend_section($x_offset, $y_offset) ; $self->move_elements($x_offset, $y_offset, $element) ; $self->update_display() ; } } #---------------------------------------------------------------------------------------------- sub append_section { my ($self) = @_ ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements == 1 && 'App::Asciio::stripes::section_wirl_arrow' eq ref $selected_elements[0]) { my $element = $selected_elements[0] ; add_section_to_section_wirl_arrow ( $self, { ELEMENT => $element, X => $self->{MOUSE_X} - $element->{X}, Y => $self->{MOUSE_Y} - $element->{Y}, } ) ; } } #---------------------------------------------------------------------------------------------- sub add_section_to_section_wirl_arrow { my ($self, $data) = @_ ; $self->create_undo_snapshot() ; $self->delete_connections_containing($data->{ELEMENT}) ; $data->{ELEMENT}->append_section($data->{X}, $data->{Y}) ; $self->connect_elements($data->{ELEMENT}) ; $self->call_hook('CANONIZE_CONNECTIONS', $self->{CONNECTIONS}, $self->get_character_size()) ; $self->update_display() ; } #---------------------------------------------------------------------------------------------- sub remove_last_section_from_section_wirl_arrow { my ($self, $data) = @_ ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements == 1 && 'App::Asciio::stripes::section_wirl_arrow' eq ref $selected_elements[0]) { my $element = $selected_elements[0] ; $self->create_undo_snapshot() ; $self->delete_connections_containing($element) ; $element->remove_last_section() ; $self->connect_elements($element) ; $self->call_hook('CANONIZE_CONNECTIONS', $self->{CONNECTIONS}, $self->get_character_size()) ; $self->update_display() ; } } #---------------------------------------------------------------------------------------------- sub remove_first_section_from_section_wirl_arrow { my ($self, $data) = @_ ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements == 1 && 'App::Asciio::stripes::section_wirl_arrow' eq ref $selected_elements[0]) { my $element = $selected_elements[0] ; $self->create_undo_snapshot() ; $self->delete_connections_containing($element) ; my ($second_arrow_x_offset, $second_arrow_y_offset) = $element->remove_first_section() ; $self->move_elements($second_arrow_x_offset, $second_arrow_y_offset, $element) ; $self->update_display() ; } } #---------------------------------------------------------------------------------------------- sub multi_wirl_context_menu { my ($self, $popup_x, $popup_y) = @_ ; my @context_menu_entries ; my ($character_width, $character_height) = $self->get_character_size() ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements == 1 && 'App::Asciio::stripes::section_wirl_arrow' eq ref $selected_elements[0]) { my $element = $selected_elements[0] ; my ($x, $y) = $self->closest_character($popup_x - ($element->{X} * $character_width) , $popup_y - ($element->{Y} * $character_height)) ; push @context_menu_entries, [ '/append section', \&add_section_to_section_wirl_arrow, {ELEMENT => $selected_elements[0], X => $x, Y => $y,} ] ; if($element->is_connection_allowed('start')) { push @context_menu_entries, ["/Arrow connection/start doesn't connect", sub {$selected_elements[0]->allow_connection('start',0) ;}] ; } else { push @context_menu_entries, ["/Arrow connection/start connects", sub {$selected_elements[0]->allow_connection('start',1) ;}] ; } if($element->is_connection_allowed('end')) { push @context_menu_entries, ["/Arrow connection/end doesn't connect", sub {$selected_elements[0]->allow_connection('end',0) ;}] ; } else { push @context_menu_entries, ["/Arrow connection/end connects", sub {$selected_elements[0]->allow_connection('end',1) ;}] ; } push @context_menu_entries, [ $selected_elements[0]->is_autoconnect_enabled() ? '/disable autoconnection' : '/enable autoconnection', sub { $self->create_undo_snapshot() ; $selected_elements[0]->enable_autoconnect(! $selected_elements[0]->is_autoconnect_enabled()) ; $self->update_display() ; } ] ; push @context_menu_entries, [ $selected_elements[0]->are_diagonals_allowed() ? '/no diagonals' : '/allow diagonals', sub {$selected_elements[0]->allow_diagonals(! $selected_elements[0]->are_diagonals_allowed()) ;} ] ; push @context_menu_entries, [ '/Arrow type/dash', \&change_arrow_type, {ELEMENT => $selected_elements[0], TYPE => 'dash', X => $x, Y => $y,} ] , [ '/Arrow type/dot', \&change_arrow_type, {ELEMENT => $selected_elements[0], TYPE => 'dot', X => $x, Y => $y,} ], [ '/Arrow type/octo', \&change_arrow_type, {ELEMENT => $selected_elements[0], TYPE => 'octo',X => $x, Y => $y,} ], [ '/Arrow type/star', \&change_arrow_type, {ELEMENT => $selected_elements[0], TYPE => 'star', X => $x, Y => $y, } ] ; } return(@context_menu_entries) ; } #---------------------------------------------------------------------------------------------- sub arrow_connection { my ($self, $arguments) = @_ ; $arguments->{ELEMENT}->allow_connection($arguments->{WHICH}, $arguments->{CONNECT}) ; } #---------------------------------------------------------------------------------------------- my %arrow_types = ( dash => [ ['origin', '', '*', '', '', '', 1], ['up', '|', '|', '', '', '^', 1], ['down', '|', '|', '', '', 'v', 1], ['left', '-', '-', '', '', '<', 1], ['upleft', '|', '|', '.', '-', '<', 1], ['leftup', '-', '-', '\'', '|', '^', 1], ['downleft', '|', '|', '\'', '-', '<', 1], ['leftdown', '-', '-', '.', '|', 'v', 1], ['right', '-', '-','', '', '>', 1], ['upright', '|', '|', '.', '-', '>', 1], ['rightup', '-', '-', '\'', '|', '^', 1], ['downright', '|', '|', '\'', '-', '>', 1], ['rightdown', '-', '-', '.', '|', 'v', 1], ['45', '/', '/', '', '', '^', 1, ], ['135', '\\', '\\', '', '', 'v', 1, ], ['225', '/', '/', '', '', 'v', 1, ], ['315', '\\', '\\', '', '', '^', 1, ], ], dot => [ ['origin', '', '*', '', '', '', 1], ['up', '.', '.', '', '', '^', 1], ['down', '.', '.', '', '', 'v', 1], ['left', '.', '.', '', '', '<', 1], ['upleft', '.', '.', '.', '.', '<', 1], ['leftup', '.', '.', '\'', '.', '^', 1], ['downleft', '.', '.', '\'', '.', '<', 1], ['leftdown', '.', '.', '.', '.', 'v', 1], ['right', '.', '.','', '', '>', 1], ['upright', '.', '.', '.', '.', '>', 1], ['rightup', '.', '.', '\'', '.', '^', 1], ['downright', '.', '.', '\'', '.', '>', 1], ['rightdown', '.', '.', '.', '.', 'v', 1], ['45', '.', '.', '', '', '^', 1, ], ['135', '.', '.', '', '', 'v', 1, ], ['225', '.', '.', '', '', 'v', 1, ], ['315', '.', '.', '', '', '^', 1, ], ], star => [ ['origin', '', '*', '', '', '', 1], ['up', '*', '*', '', '', '^', 1], ['down', '*', '*', '', '', 'v', 1], ['left', '*', '*', '', '', '<', 1], ['upleft', '*', '*', '*', '*', '<', 1], ['leftup', '*', '*', '*', '*', '^', 1], ['downleft', '*', '*', '*', '*', '<', 1], ['leftdown', '*', '*', '*', '*', 'v', 1], ['right', '*', '*','', '', '>', 1], ['upright', '*', '*', '*', '*', '>', 1], ['rightup', '*', '*', '*', '*', '^', 1], ['downright', '*', '*', '*', '*', '>', 1], ['rightdown', '*', '*', '*', '*', 'v', 1], ['45', '*', '*', '', '', '^', 1, ], ['135', '*', '*', '', '', 'v', 1, ], ['225', '*', '*', '', '', 'v', 1, ], ['315', '*', '*', '', '', '^', 1, ], ], octo => [ ['origin', '', '#', '', '', '', 1], ['up', '#', '#', '', '', '^', 1], ['down', '#', '#', '', '', 'v', 1], ['left', '#', '#', '', '', '<', 1], ['upleft', '#', '#', '#', '#', '<', 1], ['leftup', '#', '#', '#', '#', '^', 1], ['downleft', '#', '#', '#', '#', '<', 1], ['leftdown', '#', '#', '#', '#', 'v', 1], ['right', '#', '#','', '', '>', 1], ['upright', '#', '#', '#', '#', '>', 1], ['rightup', '#', '#', '#', '#', '^', 1], ['downright', '#', '#', '#', '#', '>', 1], ['rightdown', '#', '#', '#', '#', 'v', 1], ['45', '#', '#', '', '', '^', 1, ], ['135', '#', '#', '', '', 'v', 1, ], ['225', '#', '#', '', '', 'v', 1, ], ['315', '#', '#', '', '', '^', 1, ], ], ) ; sub change_arrow_type { my ($self, $data) = @_ ; use Clone ; if(exists $arrow_types{$data->{TYPE}}) { $self->create_undo_snapshot() ; my $new_type = Clone::clone($arrow_types{$data->{TYPE}}) ; $data->{ELEMENT}->set_arrow_type($new_type) ; $self->update_display() ; } } #---------------------------------------------------------------------------------------------- App-Asciio-1.02.71/setup/actions/debug.pl0000555000076400001440000000446011122301056017041 0ustar nadimusers use List::Util qw(min max sum) ; #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Dump self' => ['CA0-d', \&dump_self], 'Dump all elements' => ['C00-d', \&dump_all_elements], 'Dump selected elements'=> ['C0S-D' , \&dump_selected_elements], 'Test' => ['0A0-t', \&test], ) ; #---------------------------------------------------------------------------------------------- sub dump_self { my ($self) = @_ ; my $size = sum(map { length } @{$self->{DO_STACK}}) || 0 ; local $self->{DO_STACK} = scalar(@{$self->{DO_STACK}}) . " [$size]"; #~ print Data::TreeDumper::DumpTree $self ; $self->show_dump_window($self, 'asciio') ; } #---------------------------------------------------------------------------------------------- sub dump_selected_elements { my ($self) = @_ ; #~ print Data::TreeDumper::DumpTree [$self->get_selected_elements(1)] ; $self->show_dump_window([$self->get_selected_elements(1)], 'asciio selected elements') ; } #---------------------------------------------------------------------------------------------- sub dump_all_elements { my ($self) = @_ ; #~ print Data::TreeDumper::DumpTree $self->{ELEMENTS} ; $self->show_dump_window($self->{ELEMENTS}, 'asciio elements') ; } #---------------------------------------------------------------------------------------------- sub test { my ($self) = @_ ; $self->create_undo_snapshot() ; #~ use Text::FIGlet ; #~ my $font = Text::FIGlet->new(-f=>'doh'); #~ my $font = Text::FIGlet->new(-d=>'/usr/share/figlet/'); #~ my $output = $font->figify(-A=>"Test"); #~ use App::Asciio::stripes::editable_box2 ; #~ my $new_element = new App::Asciio::stripes::editable_box2 #~ ({ #~ TEXT_ONLY => $output, #~ TITLE => '', #~ EDITABLE => 1, #~ RESIZABLE => 1, #~ }) ; #~ $self->add_element_at($new_element, $self->{MOUSE_X}, $self->{MOUSE_Y}) ; use App::Asciio::stripes::section_wirl_arrow ; my $new_element = new App::Asciio::stripes::section_wirl_arrow ({ POINTS => [[5, 5, 'downright']], DIRECTION => '', ALLOW_DIAGONAL_LINES => 0, EDITABLE => 1, RESIZABLE => 1, NOT_CONNECTABLE_START => 1, NOT_CONNECTABLE_END => 1, }) ; $self->add_element_at($new_element, $self->{MOUSE_X}, $self->{MOUSE_Y}) ; $self->update_display() ; } App-Asciio-1.02.71/setup/actions/mouse.pl0000555000076400001440000001242411122301056017102 0ustar nadimusers use List::MoreUtils qw(any minmax first_value) ; use Readonly ; use App::Asciio::stripes::section_wirl_arrow ; #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Quick link' => ['C0S-button_press-1', \&quick_link] , #~ 'C00-button_release' => ['', ] , #~ 'C00-motion_notify' =>['', ] , ) ; #---------------------------------------------------------------------------------------------- Readonly my $PREFERED_DIRECTION => 'right-down' ; # or 'down-right' ; #---------------------------------------------------------------------------------------------- sub quick_link { my ($self, $event) = @_ ; $self->create_undo_snapshot() ; if($event->button == 1) { my ($x, $y) = $self->closest_character($event->coords()) ; my ($destination_element) = first_value {$self->is_over_element($_, $x, $y)} reverse @{$self->{ELEMENTS}} ; if($destination_element) { connect_to_destination_element($self, $destination_element, $x, $y) ; } else { # user clicked in void or un-linkable object no_destination_element($self, $x, $y) ; } } #~ if($event->type eq '2button-press') #~ { #~ } #~ if($event->button == 3) #~ { #~ } } #---------------------------------------------------------------------------------------------- sub no_destination_element { my ($self, $x, $y) = @_ ; my $new_box = $self->add_new_element_named('stencils/asciio/box', $x, $y) ; connect_to_destination_element($self, $new_box, $x, $y) ; } #---------------------------------------------------------------------------------------------- sub connect_to_destination_element { my ($self, $destination_element, $x, $y) = @_ ; my @destination_connections = grep {$_->{NAME} ne 'resize'} $destination_element->get_connection_points() ; if(@destination_connections) { my @selected_elements = grep {$_ != $destination_element} $self->get_selected_elements(1) ; my $destination_connection = $destination_connections[0] ; if(@selected_elements) { $self->select_elements(0, @{$self->{ELEMENTS}}) ; for my $element (@selected_elements) { # link $element to $destination_element my @source_connections = grep {$_->{NAME} ne 'resize'} $element->get_connection_points() ; if(@source_connections) { connect_from_box($self, $element, $source_connections[0], $destination_element, $destination_connection) ; } else { connect_from_arrow($self, $element, $destination_element, $destination_connection) ; } } $self->select_elements(1, @selected_elements) ; } else { $self->select_elements(1, $destination_element) ; } $self->update_display() ; # will also canonize the connections } } #---------------------------------------------------------------------------------------------- sub connect_from_box { my ($self, $element, $source_connection, $destination_element, $destination_connection) = @_ ; my $wirl_arrow = new App::Asciio::stripes::section_wirl_arrow ({ POINTS => [ [ ($destination_element->{X} + $destination_connection->{X}) - ($element->{X} + $source_connection->{X}), ($destination_element->{Y} + $destination_connection->{Y}) - ($element->{Y} + $source_connection->{Y}), $PREFERED_DIRECTION, ], ], DIRECTION => $PREFERED_DIRECTION, ALLOW_DIAGONAL_LINES => 0, EDITABLE => 1, RESIZABLE => 1, }) ; $self->add_element_at_no_connection ( $wirl_arrow, $element->{X} + $source_connection->{X}, $element->{Y} + $source_connection->{Y}, ) ; $self->add_connections ({ CONNECTED => $wirl_arrow, CONNECTOR => $wirl_arrow->get_named_connection('startsection_0'), CONNECTEE => $element, CONNECTION => $source_connection, }) ; $self->add_connections ({ CONNECTED => $wirl_arrow, CONNECTOR => $wirl_arrow->get_named_connection('endsection_0'), CONNECTEE => $destination_element, CONNECTION => $destination_connection, }) ; } #---------------------------------------------------------------------------------------------- sub connect_from_arrow { my ($self, $element, $destination_element, $destination_connection) = @_ ; my %source_connectors = map {$_->{NAME} => $_} grep {$_->{NAME} ne 'resize'} $element->get_connector_points() ; for(grep {$_->{CONNECTED} == $element } @{$self->{CONNECTIONS}}) { delete $source_connectors{$_->{CONNECTOR}{NAME}} ; } my ($unconnected_connector_name) = reverse sort keys %source_connectors ; print "$unconnected_connector_name\n" ; if($unconnected_connector_name) { my $unconnected_connector = $source_connectors{$unconnected_connector_name} ; my ($x_offset, $y_offset) = $element->move_connector ( $unconnected_connector_name, ($destination_element->{X} + $destination_connection->{X}) - ($element->{X} + $unconnected_connector->{X}), ($destination_element->{Y} + $destination_connection->{Y}) - ($element->{Y} + $unconnected_connector->{Y}), ) ; $element->{X} += $x_offset ; $element->{Y} += $y_offset ; my $new_connection = { CONNECTED => $element, CONNECTOR =>$unconnected_connector, CONNECTEE => $destination_element, CONNECTION => $destination_connection, } ; $self->add_connections($new_connection) ; } } #---------------------------------------------------------------------------------------------- App-Asciio-1.02.71/setup/actions/context_menu_box.pl0000555000076400001440000001011311122301056021323 0ustar nadimusers #---------------------------------------------------------------------------------------------- register_action_handlers ( 'box_context_menu' => ['box_context_menu', undef, undef, \&box_context_menu], ) ; #---------------------------------------------------------------------------------------------- use Readonly ; Readonly my $TOP => 0 ; Readonly my $TITLE_SEPARATOR => 1 ; Readonly my $BODY_SEPARATOR => 2 ; Readonly my $BOTTOM => 3; Readonly my $DISPLAY => 0 ; Readonly my $NAME => 1 ; Readonly my $LEFT => 2 ; Readonly my $BODY => 3 ; Readonly my $RIGHT => 4 ; my %box_types = ( dash => [ [1, 'top', '.', '-', '.', 1, ], [0, 'title separator', '|', '-', '|', 1, ], [1, 'body separator', '| ', '|', ' |', 1, ], [1, 'bottom', '\'', '-', '\'', 1, ], ], dot => [ [1, 'top', '.', '.', '.', 1, ], [0, 'title separator', '.', '.', '.', 1, ], [1, 'body separator', '. ', '.', ' .', 1, ], [1, 'bottom', '.', '.', '.', 1, ], ], star => [ [1, 'top', '*', '*', '*', 1, ], [0, 'title separator', '*', '*', '*', 1, ], [1, 'body separator', '* ', '*', ' *', 1, ], [1, 'bottom', '*', '*', '*', 1, ], ], ) ; #---------------------------------------------------------------------------------------------- sub box_context_menu { my ($self, $popup_x, $popup_y) = @_ ; my @context_menu_entries ; my ($character_width, $character_height) = $self->get_character_size() ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements == 1 && 'App::Asciio::stripes::editable_box2' eq ref $selected_elements[0]) { my $element = $selected_elements[0] ; my ($x, $y) = $self->closest_character($popup_x - ($element->{X} * $character_width) , $popup_y - ($element->{Y} * $character_height)) ; push @context_menu_entries, [ '/Rotate text', sub {$element->rotate_text() ;}, ] ; push @context_menu_entries, [ '/box selected element', \&box_selected_element, { ELEMENT => $element}, ] ; push @context_menu_entries, [ '/Box type/dash', \&change_box_type, { ELEMENT => $element, TYPE => 'dash', } ], [ '/Box type/dot', \&change_box_type, { ELEMENT => $element, TYPE => 'dot', } ], [ '/Box type/star', \&change_box_type, { ELEMENT => $element, TYPE => 'star', } ] ; if($element->is_border_connection_allowed()) { push @context_menu_entries, ["/Disable border connection", sub {$element->allow_border_connection(0) ;}] ; } else { push @context_menu_entries, ["/Enable border connection", sub {$element->allow_border_connection(1) ;}] ; } if($element->is_auto_shrink()) { push @context_menu_entries, ["/Disable auto shrink", sub {$element->flip_auto_shrink() ;}] ; } else { push @context_menu_entries, ["/Enable auto shrink", sub {$element->shrink() ; $element->flip_auto_shrink() ; }] ; } } return(@context_menu_entries) ; } #---------------------------------------------------------------------------------------------- sub change_box_type { my ($self, $data) = @_ ; use Clone ; if(exists $box_types{$data->{TYPE}}) { $self->create_undo_snapshot() ; my $element_type = $data->{ELEMENT}->get_box_type() ; my $new_type = Clone::clone($box_types{$data->{TYPE}}) ; for (my $frame_element_index = 0 ; $frame_element_index < @{$new_type} ; $frame_element_index++) { $new_type->[$frame_element_index][$DISPLAY] = $element_type->[$frame_element_index][$DISPLAY] } $data->{ELEMENT}->set_box_type($new_type) ; $self->update_display() ; } } #---------------------------------------------------------------------------------------------- sub box_selected_element { my ($self, $data) = @_ ; $self->create_undo_snapshot() ; my $element_type = $data->{ELEMENT}->get_box_type() ; my ($title, $text) = $data->{ELEMENT}->get_text() ; for (0 .. $#$element_type) { next if $_ == $TITLE_SEPARATOR && $title eq '' ; $element_type->[$_][$DISPLAY] = 1 ; } $data->{ELEMENT}->set_box_type($element_type) ; $self->update_display() ; } #---------------------------------------------------------------------------------------------- App-Asciio-1.02.71/setup/actions/new_elements.pl0000555000076400001440000000201711122301056020434 0ustar nadimusers #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Add box no edit' => ['000-b', \&add_element, ['stencils/asciio/box', 0]], 'Add box' => ['00S-B', \&add_element, ['stencils/asciio/box', 1]], 'Add text' => ['000-t', \&add_element, ['stencils/asciio/text', 1]], 'Add if' => ['000-i', \&add_element, ['stencils/asciio/boxes/if', 1]], 'Add process' => ['000-p', \&add_element, ['stencils/asciio/boxes/process', 1]], 'Add arrow' => ['000-a', \&add_element, ['stencils/asciio/wirl_arrow', 0]], ) ; #---------------------------------------------------------------------------------------------- sub add_element { my ($self, $name_and_edit) = @_ ; $self->create_undo_snapshot() ; $self->select_elements(0, @{$self->{ELEMENTS}}) ; my ($name, $edit) = @{$name_and_edit} ; my $element = $self->add_new_element_named($name, $self->{MOUSE_X}, $self->{MOUSE_Y}) ; $element->edit() if $edit; $self->select_elements(1, $element) ; $self->update_display() ; } ; App-Asciio-1.02.71/setup/actions/align.pl0000555000076400001440000001041511122301056017042 0ustar nadimusers use List::Util qw(min max) ; #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Align objects'=> { SHORTCUTS => '0A0-a', 'Align left' => ['000-l', \&align, 'left'], 'Align center' => ['000-c', \&align, 'center'], 'Align right' => ['000-r', \&align, 'right'], 'Align top' => ['000-t', \&align, 'top'], 'Align middle' => ['000-m', \&align, 'middle'], 'Align bottom' => ['000-b', \&align, 'bottom'], # spread vertically # spread horizontally # adjacent vert # adjacent hor # stack }, ) ; #---------------------------------------------------------------------------------------------- sub align { my ($self, $alignment) = @_ ; $self->create_undo_snapshot() ; my @elements_to_move = grep {my @connectors = $_->get_connector_points() ; @connectors == 0 } $self->get_selected_elements(1) ; for ($alignment) { $_ eq 'left' and do { my $left = min( map{$_->{X}} @elements_to_move) ; for my $element (@elements_to_move) { $self->move_elements($left - $element->{X},0, $element) ; } last ; } ; $_ eq 'center' and do { my $left = min( map{$_->{X}} @elements_to_move) ; my $right = max ( map { my ($w, $h) = $_->get_size() ; $_->{X} + $w ; } @elements_to_move ) ; my $center = int(($left + $right) / 2) ; # find element which center is closes to geometric center my $closest_element = undef ; my $closest_element_distance = 1_000_000 ; my $closest_center ; for my $element (@elements_to_move) { my ($w, $h) = $element->get_size() ; my $element_center = $element->{X} + int($w / 2) ; my $center_to_center_distance = abs($center - $element_center) ; if($center_to_center_distance <$closest_element_distance) { $closest_element = $element ; $closest_element_distance = $center_to_center_distance; $closest_center = $element_center ; } } for my $element (@elements_to_move) { next if $element == $closest_element ; my ($w, $h) = $element->get_size() ; my $element_center = $element->{X} + int($w / 2) ; $self->move_elements($closest_center - $element_center, 0, $element) ; } last ; } ; $_ eq 'right' and do { my $right = max ( map { my ($w, $h) = $_->get_size() ; $_->{X} + $w ; } @elements_to_move ) ; for my $element (@elements_to_move) { my ($w, $h) = $element->get_size() ; $self->move_elements($right - ($element->{X} + $w), 0, $element) ; } last ; } ; $_ eq 'top' and do { my $top = min( map{$_->{Y}} @elements_to_move) ; for my$element (@elements_to_move) { $self->move_elements(0, $top - $element->{Y}, $element) ; } last ; } ; $_ eq 'middle' and do { my $top = min( map{$_->{Y}} @elements_to_move) ; my $bottom = max ( map { my ($w, $h) = $_->get_size() ; $_->{Y} + $h ; } @elements_to_move ) ; my $center = int(($top + $bottom) / 2) ; # find element which center is closes to geometric center my $closest_element = undef ; my $closest_element_distance = 1_000_000 ; my $closest_center ; for my $element (@elements_to_move) { my ($w, $h) = $element->get_size() ; my $element_center = $element->{Y} + int($h / 2) ; my $center_to_center_distance = abs($center - $element_center) ; if($center_to_center_distance <$closest_element_distance) { $closest_element = $element ; $closest_element_distance = $center_to_center_distance; $closest_center = $element_center ; } } for my $element (@elements_to_move) { next if $element == $closest_element ; my ($w, $h) = $element->get_size() ; my $element_center = $element->{Y} + int($h / 2) ; $self->move_elements(0, $closest_center - $element_center, $element) ; } last ; } ; $_ eq 'bottom' and do { my $bottom = max ( map { my ($w, $h) = $_->get_size() ; $_->{Y} + $h ; } @elements_to_move ) ; for my $element (@elements_to_move) { my ($w, $h) = $element->get_size() ; $self->move_elements(0, $bottom - ($element->{Y} + $h), $element) ; } last ; } ; } $self->update_display() ; } App-Asciio-1.02.71/setup/actions/elements_manipulation.pl0000555000076400001440000002144211122301056022346 0ustar nadimusers #---------------------------------------------------------------------------------------------- register_action_handlers ( 'Select next element' => ['000-Tab', \&select_next_element], 'Select previous element' => ['00S-ISO_Left_Tab', \&select_previous_element], 'Select all elements' => ['C00-a', \&select_all_elements], 'Delete selected elements' => ['000-Delete', \&delete_selected_elements], 'Group selected elements' => ['C00-g', \&group_selected_elements], 'Ungroup selected elements' => ['C00-u', \&ungroup_selected_elements], 'Move selected elements to the front' => ['C00-f', \&move_selected_elements_to_front], 'Move selected elements to the back' => ['C00-b', \&move_selected_elements_to_back], 'Edit selected element' => ['000-Return', \&edit_selected_element], 'Move selected elements left' => ['000-Left', \&move_selection_left], 'Move selected elements right' => ['000-Right', \&move_selection_right], 'Move selected elements up' => ['000-Up', \&move_selection_up], 'Move selected elements down' => ['000-Down', \&move_selection_down], 'Change arrow direction' => ['000-d', \&change_arrow_direction], 'Flip arrow start and end' => ['000-f', \&flip_arrow_ends], ) ; #---------------------------------------------------------------------------------------------- sub edit_selected_element { my ($self) = @_ ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements == 1) { $self->create_undo_snapshot() ; $self->edit_element($selected_elements[0]) ; $self->update_display(); } } #---------------------------------------------------------------------------------------------- sub change_arrow_direction { my ($self) = @_ ; my @elements_to_redirect = grep {ref $_ eq 'App::Asciio::stripes::section_wirl_arrow'} $self->get_selected_elements(1) ; if(@elements_to_redirect) { $self->create_undo_snapshot() ; for (@elements_to_redirect) { $_->change_section_direction($self->{MOUSE_X} - $_->{X}, $self->{MOUSE_Y} - $_->{Y}) ; } $self->update_display() ; } } #---------------------------------------------------------------------------------------------- sub flip_arrow_ends { my ($self) = @_ ; my @elements_to_flip = grep { my @connectors = $_->get_connector_points() ; ref $_ eq 'App::Asciio::stripes::section_wirl_arrow' && $_->get_number_of_sections() == 1 && @connectors > 0 ; } $self->get_selected_elements(1) ; if(@elements_to_flip) { $self->create_undo_snapshot() ; my %reverse_direction = ( 'up', => 'down', 'right' => 'left', 'down' => 'up', 'left' => 'right' ) ; for (@elements_to_flip) { # create one with ends swapped my $new_direction = $_->get_section_direction(0) ; if($new_direction =~ /(.*)-(.*)/) { my ($start_direction, $end_direction) = ($1, $2) ; $new_direction = $reverse_direction{$end_direction} . '-' . $reverse_direction{$start_direction} ; } else { $new_direction = $reverse_direction{$new_direction} ; } my ($start_connector, $end_connector) = $_->get_connector_points() ; my $arrow = new App::Asciio::stripes::section_wirl_arrow ({ %{$_}, POINTS => [ [ - $end_connector->{X}, - $end_connector->{Y}, $new_direction, ] ], DIRECTION => $new_direction, }) ; #add new element, connects automatically $self->add_element_at($arrow, $_->{X} + $end_connector->{X}, $_->{Y} + $end_connector->{Y}) ; # remove element $self->delete_elements($_) ; # keep the element selected $self->select_elements(1, $arrow) ; } $self->update_display() ; } } #---------------------------------------------------------------------------------------------- sub select_next_element { my ($self) = @_ ; return unless exists $self->{ELEMENTS}[0] ; $self->create_undo_snapshot() ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements) { my $last_selected_element = $selected_elements[-1] ; my ($seen_selected, $next_element) ; for my $element (@{$self->{ELEMENTS}}) { if(! $self->is_element_selected($element) && $seen_selected) { $next_element = $element ; last ; } $seen_selected =$element == $last_selected_element ; } $self->select_elements(0, @{$self->{ELEMENTS}}) ; if($next_element) { $self->select_elements(1, $next_element) ; } else { $self->select_elements(1, $self->{ELEMENTS}[0]); } } else { $self->select_elements(1, $self->{ELEMENTS}[0]); } $self->update_display() ; } #---------------------------------------------------------------------------------------------- sub select_previous_element { my ($self) = @_ ; return unless exists $self->{ELEMENTS}[0] ; $self->create_undo_snapshot() ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements) { my $last_selected_element = $selected_elements[0] ; my ($seen_selected, $next_element) ; for my $element (reverse @{$self->{ELEMENTS}}) { if(! $self->is_element_selected($element) && $seen_selected) { $next_element = $element ; last ; } $seen_selected =$element == $last_selected_element ; } $self->select_elements(0, @{$self->{ELEMENTS}}) ; if(defined $next_element) { $self->select_elements(1, $next_element) ; } else { $self->select_elements(1, $self->{ELEMENTS}[-1]); } } else { $self->select_elements(1, $self->{ELEMENTS}[-1]); } $self->update_display() ; } #---------------------------------------------------------------------------------------------- sub select_all_elements { my ($self) = @_ ; $self->select_elements(1, @{$self->{ELEMENTS}}) ; $self->update_display() ; } ; #---------------------------------------------------------------------------------------------- sub delete_selected_elements { my ($self) = @_ ; $self->create_undo_snapshot() ; $self->delete_elements($self->get_selected_elements(1)) ; $self->update_display() ; } ; #---------------------------------------------------------------------------------------------- sub move_selection_left { my ($self, $offset) = @_ ; $offset = 1 unless defined $offset ; $self->create_undo_snapshot() ; $self->move_elements(-$offset, 0, $self->get_selected_elements(1)) ; $self->update_display() ; } ; #---------------------------------------------------------------------------------------------- sub move_selection_right { my ($self, $offset) = @_ ; $offset = 1 unless defined $offset ; $self->create_undo_snapshot() ; $self->move_elements($offset, 0, $self->get_selected_elements(1)) ; $self->update_display() ; } ; #---------------------------------------------------------------------------------------------- sub move_selection_up { my ($self, $offset) = @_ ; $offset = 1 unless defined $offset ; $self->create_undo_snapshot() ; $self->move_elements(0, -$offset, $self->get_selected_elements(1)) ; $self->update_display() ; } ; #---------------------------------------------------------------------------------------------- sub move_selection_down { my ($self, $offset) = @_ ; $offset = 1 unless defined $offset ; $self->create_undo_snapshot() ; $self->move_elements(0, $offset, $self->get_selected_elements(1)) ; $self->update_display() ; } ; #---------------------------------------------------------------------------------------------- sub group_selected_elements { my ($self) = @_ ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements >= 2) { $self->create_undo_snapshot() ; my $group = {'GROUP_COLOR' => $self->get_group_color()} ; for my $element (@selected_elements) { push @{$element->{'GROUP'}}, $group ; } } $self->update_display() ; } ; #---------------------------------------------------------------------------------------------- sub ungroup_selected_elements { my ($self) = @_ ; my @selected_elements = $self->get_selected_elements(1) ; for my $grouped (grep {exists $_->{GROUP} } @selected_elements) { pop @{$grouped->{GROUP}} ; } $self->update_display() ; } ; #---------------------------------------------------------------------------------------------- sub move_selected_elements_to_front { my ($self) = @_ ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements) { $self->create_undo_snapshot() ; $self->move_elements_to_front(@selected_elements) ; } $self->update_display() ; } ; #---------------------------------------------------------------------------------------------- sub move_selected_elements_to_back { my ($self) = @_ ; my @selected_elements = $self->get_selected_elements(1) ; if(@selected_elements) { $self->create_undo_snapshot() ; $self->move_elements_to_back(@selected_elements) ; } $self->update_display() ; } ; App-Asciio-1.02.71/setup/stencils/0000755000076400001440000000000011122301056015575 5ustar nadimusersApp-Asciio-1.02.71/setup/stencils/asciio0000444000076400001440000001451711122301056016775 0ustar nadimusers$VAR1 = [ bless( { 'HEIGHT' => 3, 'TEXT' => '.---. | | \'---\'', 'NAME' => 'box', 'WIDTH' => 5, 'TEXT_ONLY' => '', 'TITLE' => '', 'BOX_TYPE' => [ [TRUE, 'top', '.', '-', '.', TRUE, ], [FALSE, 'title separator', '|', '-', '|', TRUE, ], [TRUE, 'body separator', '| ', '|', ' |', TRUE, ], [TRUE, 'bottom', '\'', '-', '\'', TRUE, ], ] , 'EDITABLE' => 1, RESIZABLE => 1, X_OFFSET => 0, Y_OFFSET => 0, }, 'App::Asciio::stripes::editable_box2' ), bless( { 'HEIGHT' => 1, 'TEXT' => 'A', 'NAME' => 'text', 'WIDTH' => 1, 'TEXT_ONLY' => 'A', 'TITLE' => '', 'BOX_TYPE' => [ [FALSE, 'top', '.', '-', '.', TRUE, ], [FALSE, 'title separator', '.', '-', '.', TRUE, ], [FALSE, 'body separator', '. ', '|', ' .', TRUE, ], [FALSE, 'bottom', '\'', '-', '\'', TRUE, ], ], 'EDITABLE' => 1, RESIZABLE => 1, X_OFFSET => 0, Y_OFFSET => 0, }, 'App::Asciio::stripes::editable_box2' ), bless({ 'NAME' => 'wirl_arrow', 'HEIGHT' => 6, 'WIDTH' => 17, 'POINTS' => [[16,5]], 'SELECTED' => 0, 'EDITABLE' => 1, 'ALLOW_DIAGONAL_LINES' => 0, 'POINTS_OFFSETS' => [[0,0]], 'DIRECTION' => 'down-right' , 'ARROW_TYPE' => [ ['origin', '', '*', '', '', '', TRUE], ['up', '|', '|', '', '', '^', TRUE], ['down', '|', '|', '', '', 'v', TRUE], ['left', '-', '-', '', '', '<', TRUE], ['upleft', '|', '|', '.', '-', '<', TRUE], ['leftup', '-', '-', '\'', '|', '^', TRUE], ['downleft', '|', '|', '\'', '-', '<', TRUE], ['leftdown', '-', '-', '.', '|', 'v', TRUE], ['right', '-', '-','', '', '>', TRUE], ['upright', '|', '|', '.', '-', '>', TRUE], ['rightup', '-', '-', '\'', '|', '^', TRUE], ['downright', '|', '|', '\'', '-', '>', TRUE], ['rightdown', '-', '-', '.', '|', 'v', TRUE], ['45', '/', '/', '', '', '^', TRUE, ], ['135', '\\', '\\', '', '', 'v', TRUE, ], ['225', '/', '/', '', '', 'v', TRUE, ], ['315', '\\', '\\', '', '', '^', TRUE, ], ], 'ARROWS' => [ bless( { 'HEIGHT' => 6, 'STRIPES' => [ {'TEXT' => '| | | | | \'', 'HEIGHT' => 6, 'Y_OFFSET' => 0, 'WIDTH' => 1, 'X_OFFSET' => 0} , { 'TEXT' => '--------------->', 'HEIGHT' => 1, 'Y_OFFSET' => 5, 'WIDTH' => 16, 'X_OFFSET' => 1 } ], 'WIDTH' => 17, 'END_X' => 16, 'ARROW_TYPE' => [ #name: $start, $body, $connection, $body_2, $end ['origin', '', '*', '', '', '', TRUE], ['up', '|', '|', '', '', '^', TRUE], ['down', '|', '|', '', '', 'v', TRUE], ['left', '-', '-', '', '', '<', TRUE], ['upleft', '|', '|', '.', '-', '<', TRUE], ['leftup', '-', '-', '\'', '|', '^', TRUE], ['downleft', '|', '|', '\'', '-', '<', TRUE], ['leftdown', '-', '-', '.', '|', 'v', TRUE], ['right', '-', '-','', '', '>', TRUE], ['upright', '|', '|', '.', '-', '>', TRUE], ['rightup', '-', '-', '\'', '|', '^', TRUE], ['downright', '|', '|', '\'', '-', '>', TRUE], ['rightdown', '-', '-', '.', '|', 'v', TRUE], ['45', '/', '/', '', '', '^', TRUE, ], ['135', '\\', '\\', '', '', 'v', TRUE, ], ['225', '/', '/', '', '', 'v', TRUE, ], ['315', '\\', '\\', '', '', '^', TRUE, ], ], 'END_Y' => 5, 'DIRECTION' => 'down-right' }, 'App::Asciio::stripes::wirl_arrow' ), ], }, 'App::Asciio::stripes::section_wirl_arrow' ) , bless( { 'STRIPES' => [ { 'HEIGHT' => 1, 'TEXT' => '--->', 'WIDTH' => 4, 'X_OFFSET' => 0, 'Y_OFFSET' => 0 }, ], 'NAME' => 'axis', 'ARROW_TYPE' => [ ['Up', '|', '|', '^', TRUE, ], ['45', '/', '/', '^', TRUE, ], ['Right', '-', '-', '>', TRUE, ], ['135', '\\', '\\', 'v', TRUE, ], ['Down', '|', '|', 'v', TRUE, ], ['225', '/', '/', 'v', TRUE, ], ['Left', '-', '-', '<', TRUE, ], ['315', '\\', '\\', '^', TRUE, ], ], EDITABLE => 1, X_OFFSET => 0, Y_OFFSET => 0, END_X => 3, END_Y => 0, }, 'App::Asciio::stripes::editable_arrow2' ), bless( { 'HEIGHT' => 4, 'STRIPES' => [ { 'HEIGHT' => 2, 'TEXT' => "______________\n\\ \\", 'WIDTH' => 15, 'X_OFFSET' => 0, 'Y_OFFSET' =>0, }, { 'HEIGHT' => 1, 'TEXT' => ") )", 'WIDTH' => 15, 'X_OFFSET' => 1, 'Y_OFFSET' => 2 , }, { 'HEIGHT' => 1, 'TEXT' => "/_____________/", 'WIDTH' => 15, 'X_OFFSET' =>0, 'Y_OFFSET' => 3 , } ], TEXT_ONLY => '', LEFT_CENTER_X => 0, RESIZE_POINT_X => 14, 'NAME' => 'boxes/process', 'WIDTH' => 16, EDITABLE => 1, X_OFFSET => 0, Y_OFFSET => 0, }, 'App::Asciio::stripes::process_box' ), bless( { 'NAME' => 'boxes/if', 'HEIGHT' => 5, 'WIDTH' => 16, 'SELECTED' => 0, 'TEXT_ONLY' => '', 'TEXT' => ' .----------. / \\ ( ) \\ / \'----------\' ', 'EDITABLE' => 1, 'RESIZABLE' => 1 }, 'App::Asciio::stripes::if_box' ), bless( { 'HEIGHT' => 1, 'TEXT' => '01___5____0____5____0____5____0____5____0____5____0', 'NAME' => 'rulers/01_to_50_horizontal', 'WIDTH' => 51, X_OFFSET => 0, Y_OFFSET => 0, }, 'App::Asciio::stripes::single_stripe' ), bless( { 'HEIGHT' => 1, 'TEXT' => '0123456789', 'NAME' => 'rulers/0_to_9_horizontal', 'WIDTH' => 10, X_OFFSET => 0, Y_OFFSET => 0, }, 'App::Asciio::stripes::single_stripe' ), bless( { 'HEIGHT' => 10, 'TEXT' => '0 1 2 3 4 5 6 7 8 9', 'NAME' => 'rulers/0_to_9_vertical', 'WIDTH' => 1, X_OFFSET => 0, Y_OFFSET => 0, }, 'App::Asciio::stripes::single_stripe' ), ]; App-Asciio-1.02.71/setup/stencils/divers0000444000076400001440000000207611122301056017017 0ustar nadimusersmy @ascii = ( 'house' => <<'EOA', ___________ //////|\\\\\\ '.-----------.' | ___ | | [] | | [] | |____|_|____| EOA 'corporate building' => <<'EOA', .-'-. _.-'-._.-'-._ '-. _.-._ .' ' | '-._.-' | |'-_| | |_.'| | |'-|-'| | |'-_| | |_.'| | |'-|-'| | |'-_| | |_.'| | |'-|-'| | ___ .'['-_| | |_.-] .` .' '-'_'-.|.-|_'-' .` ' --..._ '._| _|-'_.' EOA 'building' => <<'EOA', .--------. ,' .'| :-------.'# | | # # # | # | | # # # | # | | # # # | # | | # # # | # | | # # # | # | # # # | EOA ) ; my @boxes ; use App::Asciio::stripes::editable_box2 ; for(my $ascii_index = 0 ; $ascii_index < $#ascii ; $ascii_index+= 2) { my $box = new App::Asciio::stripes::editable_box2 ({ TEXT_ONLY => $ascii[$ascii_index + 1], EDITABLE => 1, RESIZABLE => 1, }) ; $box->set_box_type([map{$_->[0] = 0; $_} @{$box->get_box_type()}]) ; $box->shrink() ; $box->{'NAME'} = $ascii[$ascii_index] ; push @boxes, $box ; } [@boxes] ; App-Asciio-1.02.71/setup/stencils/computer0000444000076400001440000000502511122301056017356 0ustar nadimusersmy @ascii = ( '3D_box' => <<'EOA', .---. / /| .---. | | | ' | |/ '---' EOA 'console' => <<'EOA', ____ | | |____| /::::/ EOA 'computer_small' => <<'EOA', __ _ [__]|=| /::/|_| EOA 'mainframe' => <<'EOA', ________ |==|=====| | | | | | | | | | | | | | |====°| |__|_____| EOA 'Mini' => <<'EOA', ____ |====| | | | | |____| EOA '19_rack' => <<'EOA', __________ [_..._....°] [_..._....°] [_..._....°] [_..._....°] [_|||||||_°] [_|||||||_°] [_|||||||_°] [_________°] [_________°] [_________°] [___....__°] EOA 'rack modem' => <<'EOA', __________ |____oooo_°| EOA 'SAN' => <<'EOA', __________ [_|||||||_°] [_|||||||_°] [_|||||||_°] EOA 'router' => <<'EOA', __________ [_...__...°] EOA 'wireless' => <<'EOA', |_|_| [____°] EOA 'workstation' => <<'EOA', ____ __ | | |==| |____| | | /::::/ |__| EOA 'print server' => <<'EOA', _____ _/____/| /__/__/|| |= |-°||' |___|__|/ EOA 'small_rack' => <<'EOA', ______ [.....°] [.....°] [|||||°] [|||||°] [_____°] [_____°] [_____°] EOA 'modem' => <<'EOA', ______ |_ooo_°| EOA 'firewall' => <<'EOA', _____________________ |___|___|___|___|___|_| |_|___|___|___|___|___| |___|___|___|___|___|_| EOA 'INTERNET' => <<'EOA', .--. _ -( )- _ .--,( ),--. _.-( )-._ ( INTERNET ) '-._( )_.-' '__,( ),__' - ._(__)_. - EOA 'internet' => <<'EOA', .-,( ),-. .-( )-. ( internet ) '-( ).-' '-.( ).-' EOA 'backbone' => <<'EOA', =================================== EOA 'BACKBONE' => <<'EOA', =================================== =================================== =================================== EOA 'document' => <<'EOA', ___ | |\ | '-| | | |_____| EOA 'DB' => <<'EOA', _.-----._ .- -. |-_ _-| | ~-----~ | | | `._ _.' "-----" EOA 'wireless_mast' => <<'EOA', ((.)) | /_\ /___\ / \ EOA ) ; my @boxes ; use App::Asciio::stripes::editable_box2 ; for(my $ascii_index = 0 ; $ascii_index < $#ascii ; $ascii_index+= 2) { my $box = new App::Asciio::stripes::editable_box2 ({ TEXT_ONLY => $ascii[$ascii_index + 1], EDITABLE => 1, RESIZABLE => 1, }) ; $box->set_box_type([map{$_->[0] = 0; $_} @{$box->get_box_type()}]) ; $box->shrink() ; $box->{'NAME'} = $ascii[$ascii_index] ; push @boxes, $box ; } [@boxes] ; App-Asciio-1.02.71/setup/stencils/people0000444000076400001440000000214611122301056017005 0ustar nadimusersmy @ascii = ( 'arms_down' => <<'EOA', o /|\ / \ EOA 'arms_up' => <<'EOA', \o/ | / \ EOA 'Bunny' => <<'EOA', (\_/) (O.o) (> <) EOA 'Dilbert' => <<'EOA', -.-.-,~ . ) ( |_ | /(_)---`\ (_ -' ] | | _,') [_,-'_-'( (_).-' \ / / \ EOA 'BSD_devil' => <<'EOA', , , \\_ /| /- _`-/ ' (/\/ \ /\ O O ) / | `-^--'`< ' (_) _ )/ `.___/` / `--' / <---. __ / __ \ <---|==(fl)=) \ /=== <---' `-' `._,'\ \ / ( ( / \__ ,---_' | \ `-(____) V EOA ) ; my @boxes ; use App::Asciio::stripes::editable_box2 ; for(my $ascii_index = 0 ; $ascii_index < $#ascii ; $ascii_index+= 2) { my $box = new App::Asciio::stripes::editable_box2 ({ TEXT_ONLY => $ascii[$ascii_index + 1], EDITABLE => 1, RESIZABLE => 1, }) ; $box->set_box_type([map{$_->[0] = 0; $_} @{$box->get_box_type()}]) ; $box->shrink() ; $box->{'NAME'} = $ascii[$ascii_index] ; push @boxes, $box ; } [@boxes] ; App-Asciio-1.02.71/README0000444000076400001440000000022611122301056013467 0ustar nadimusersAsciio ==== INSTALLATION ------------ To install this module type the following: perl Build.PL ./Build ./Build test ./Build install App-Asciio-1.02.71/Changes0000444000076400001440000003347711122301056014120 0ustar nadimuserscommit 67a872d9a3d01d46b04bf10c37974b9b7e696619 Author: nadim khemir Date: Wed Dec 17 23:49:21 2008 +0100 CHANGED: use git to generate Changes commit 1b59aba199b99f6ea99fc2b108ae1cf0ef392928 Author: nadim khemir Date: Wed Dec 17 23:31:27 2008 +0100 CHANGED: default box made smaller CHANGED: remove unnecessary test dependencies CHANGED: simplify Build.PL commit 9726996439418451761ff28e4f9625af08c32dc3 Author: nadim khemir Date: Sun Oct 26 13:50:26 2008 +0100 ADDED: cut and paste use the primary selection (used by emacs) patch by Eddward DeVilla commit 0489cbf50c4f28f4c7c367fbed78370a8cbb02e9 Author: nadim khemir Date: Sun Oct 26 13:42:50 2008 +0100 ADDED: .gitignore commit 830946d92fe1e4601751316cef1569c466d26e55 Author: nadim khemir Date: Tue Aug 26 20:18:46 2008 +0200 FIXED: gtk warning test commit 91c2e8d85488dd504d33e0a93187611bc1b12889 Author: nadim khemir Date: Sat Aug 23 18:55:09 2008 +0200 CHANGED: actions moving objects take offset argument commit 7fda4a05605c5c8ef1839e67beede591b0954573 Author: nadim khemir Date: Sat Aug 23 13:18:18 2008 +0200 ADDED: simple slide API commit b1b19e62716d9ca2bfcf72bdc798b95eb7fda366 Author: nadim khemir Date: Thu Aug 21 21:35:17 2008 +0200 CHANGED: split stencils in different files CHANGED: thin_box is now box ADDED: import from clipboard to box CHANGED: documentation update commit d8fa2393b90aea894735e195c2ac36b76f302458 Author: nadim khemir Date: Thu Aug 21 18:50:15 2008 +0200 ADDED: box auto shrink and context menue entry commit 5545955ef31af33ffc11f27bd03b06dad302e930 Author: nadim khemir Date: Wed Aug 20 22:46:20 2008 +0200 CHANGED: keyboard mapping information format commit 54e36b66715ae2ff75ae7b070f149bcf512ed439 Author: nadim khemir Date: Thu Jun 5 22:51:06 2008 +0200 ADDED: selection that doesn't take arrows (middle button) ADDED: saving of single stencil commit c06cda291372f7fcb5f91a9e0a6d982438b6f3c2 Author: nadim khemir Date: Thu Jun 5 21:34:53 2008 +0200 CHANGED: stencils name have their directory prepended CHANGED: ASCII menu entry removed ADDED: stencils directly created from ascii ADDED: network stencils commit 80b4b037640daf6f2d4e203d21715b65ef699e72 Author: nadim khemir Date: Tue Jun 3 21:05:16 2008 +0200 ADDED: batch stencil loading commit 490a1c3835237da5fe56a2f9cefb0bfad733fffc Author: nadim khemir Date: Tue Jun 3 19:41:57 2008 +0200 ADDED: remove first section from multi wirl arrow commit 76094db961c271ea419b7835ad15f432bbb66fc1 Author: nadim khemir Date: Tue Jun 3 19:20:18 2008 +0200 ADDED: prepend section to multi wirl commit 34ae4c898f3937625baccf12690276670194da71 Author: nadim khemir Date: Sat May 31 18:10:11 2008 +0200 ADDED: vertical text commit d1e0d1bfc044d1d5ef9fdf6e1944a696d7726027 Author: nadim khemir Date: Fri May 30 23:55:02 2008 +0200 CHANGED: text element contains a single letter, this fixes the resize problem on creation ADDED: box object, invisible, border connectors commit a20878b3e338cf263fa01caa2487066fac57b231 Author: nadim khemir Date: Fri May 30 20:33:02 2008 +0200 CHANGED: newly added element, via shortcut, is selected commit 89875206288eebadda5f88745e81625d5c8460ba Author: nadim khemir Date: Wed May 28 14:34:35 2008 +0200 ADDED: keep selected elements selected after a quick link commit e021055fcbc708a39f26e2d9a1c524664add87b9 Author: nadim khemir Date: Thu May 15 08:30:42 2008 +0200 ADDED: changing background and grid color ADDED: show/hide grid commit 9df9c91a11a865ea95b8abedc245a29c825e8e6d Author: nadim khemir Date: Fri May 9 01:45:37 2008 +0200 CHANGED: shortcuts to zoomin zoom out CHANGED: text edit box automatically focused and selected (thanks to Tian) commit 08ae9b7e8d9fe1d4e3cb7b8d72623cc3e116cf3a Author: nadim khemir Date: Wed May 7 23:51:42 2008 +0200 FIXED: title has frame when text doesn't commit ae1b8461e6698ae7df9f8ba49e0189794803e742 Author: nadim khemir Date: Wed May 7 21:57:50 2008 +0200 ADDED: background and grid color changing commit 611b3a181257daf60cb3ea771ee1631c7350b314 Merge: 637524b... 8a7f7d3... Author: nadim khemir Date: Wed May 7 01:48:24 2008 +0200 Merge hp:/home/nadim/Desktop/asciio Conflicts: Todo.txt commit 637524b6813500d1f9f1eafb56a273a6dcf41df3 Author: nadim khemir Date: Wed May 7 01:45:30 2008 +0200 ADDED: resuirements and errors in todo file commit 8a7f7d3275151edd9a2746f9b25b4a7f0203cece Author: nadim khemir Date: Wed May 7 01:40:55 2008 +0200 ADDED: requirements from visio and other diagram applications commit 262bc9aa7e1dfba51564e6d1bf03cf771782f219 Author: nadim khemir Date: Sat May 3 16:44:54 2008 +0200 ADDED: icon to 'save and quit' button commit c0f22394a1cea72eb2d18ff1b53aa1981d32bd00 Author: nadim khemir Date: Sat May 3 16:36:52 2008 +0200 ADDED: "save and exit" when closing asciio ADDED: actions can return results to their caller commit b41cdf8aa720823977cf024543a71ce5eb1babeb Author: nadim khemir Date: Sat May 3 15:35:12 2008 +0200 CHANGED: filtered out unecessary information from keyboard shortcuts listing commit 14e04110795cfc9679a1a4a0c90aa79a68599794 Author: nadim khemir Date: Sat May 3 15:15:37 2008 +0200 FIXED: diagonal to non-diagonal section connection CHANGED: refactored non-diagonal connection code commit ac24a1ea8ba1eb907e562cc93b741bf9c21ca724 Author: nadim khemir Date: Fri May 2 21:41:18 2008 +0200 CHANGED: refactored intersection overlay code commit e0cbcdb5c36e8988dfe1bbdcd35a8692f3f09567 Author: nadim khemir Date: Fri May 2 21:21:27 2008 +0200 FIXED: diagonal arrows connector overlay commit 5496f3823605735bc5e72b1744dbb991418d76ab Author: nadim khemir Date: Fri May 2 10:25:28 2008 +0200 ADDED: ruler context menu entry commit 19f188b707c16e8c08a4861fcdb57f5e37211ae8 Author: nadim khemir Date: Fri May 2 02:04:07 2008 +0200 FIXED: handle error when running an external command commit 3885ae0ac37ac0575518f78b6865aae0da87aba9 Author: nadim khemir Date: Thu May 1 18:35:38 2008 +0200 CHANGED: paste at the mouse position commit b15d56c6b93463db710e683172ea23e561d995db Author: nadim khemir Date: Thu May 1 17:08:48 2008 +0200 ADDED: context menue to allow diagonal lines commit 3ff5e3d048d96abccf66fc772f5de7ecdb007743 Author: nadim khemir Date: Thu May 1 16:45:04 2008 +0200 ADDED: arrow can be connected anywhere but modifying box removes connection commit ec1b202992af51e491fe66a13c32efaa7c390f90 Author: nadim khemir Date: Thu May 1 16:24:12 2008 +0200 ADDED: copy selected element to clipboard commit 2a1c7cd90299a6474cad3bedfb06cc82c31c09c5 Author: nadim khemir Date: Thu May 1 16:15:02 2008 +0200 FIXED: ALLOW_DIAGONALS field missing commit db6e60c8b44aa6ab7046809f897004f3f779a1d0 Author: nadim khemir Date: Sun Apr 27 16:48:38 2008 +0200 CHANGED: context menu structure and naming commit 2274872f897aa7e46acc89096b58c936498c2dd6 Author: nadim khemir Date: Sun Apr 27 16:28:02 2008 +0200 ADDED: context menu entries for ruler lines CHANGED: moved default ruler lines definitions to user setup commit 1652aad118f0faa0ef16da7dd707260487c9c4a8 Author: nadim khemir Date: Sun Apr 27 14:57:29 2008 +0200 CHANGED: moved ruler definition to setup commit 4b6f905babca8c9ed60c8116b86d5fb0019397cf Author: nadim khemir Date: Sun Apr 27 14:27:38 2008 +0200 FIXED: number of group colors is automatically updated from cnumber of group color definitions commit 50bd22c8587dad4c929e0e4ce8e2943919bea257 Author: nadim khemir Date: Fri Apr 25 19:48:07 2008 +0200 ADDED: context menu to activate/deactivate wirl arrow connectors commit fa36c0c325a3c0a3663eb5065cb189929c058d73 Author: nadim khemir Date: Fri Apr 25 16:18:41 2008 +0200 ADDED: non connecting arrows. no UI done yet. commit 929a4766c4de5ec4a4f8e19d8fd63d4e7e896e12 Author: nadim khemir Date: Fri Apr 25 15:17:14 2008 +0200 ADDED: external command output insertion commit f0494cfc4aded8366b17c3f48c265e9510756084 Author: nadim khemir Date: Wed Apr 23 00:19:48 2008 +0200 CHANGED: group color has less priority than element color commit 1be6f8e0f4f3f62d2962e0b75e1c7cc97ca25a9c Author: nadim khemir Date: Sun Apr 20 09:15:14 2008 +0200 FIXED: error message and typos commit 49a0e831d105a318fbda1c8a03b84a22d2242341 Author: nadim khemir Date: Sat Apr 19 15:59:57 2008 +0200 ADDED: remove last multi-wirl section commit 44ccf80bf9f8967f96317578ea37b7265b9087d7 Author: nadim khemir Date: Sat Apr 19 09:56:18 2008 +0200 ADDED: export to png format commit a2203d03a022f3c9083fa5f549f3429ab0564a78 Author: nadim khemir Date: Sat Apr 19 09:10:03 2008 +0200 ADDED: destroy sub and commented the startup script commit e3ef7f54ba6da3d1236b3e220bd5878f93e9aa4e Author: nadim khemir Date: Wed Apr 16 21:49:47 2008 +0200 ADDED: 'return' edits the currently selected box commit 660303247b64b9e1a820309c77ddad95ea30bb6c Author: nadim khemir Date: Wed Apr 16 21:28:24 2008 +0200 CHANGE: close button to ok button commit 856b724bb39754b64b0457bfffd1a22043716ba7 Author: nadim khemir Date: Wed Apr 16 20:25:32 2008 +0200 FIXED: targets are not opened commit d48bf64b1335799dff72b8df2c6a6e2297e9eeec Author: nadim khemir Date: Wed Apr 16 08:46:12 2008 +0200 CHANGED: register_action_handlers use own data instead for the evaled package returned values CHANGED: closing window use icons (code by Muppet) commit d7441253720c02741722f1f9ed4b185ce5e1f34d Author: nadim khemir Date: Tue Apr 15 09:56:45 2008 +0200 ADDED: dump of actions per file (for user help and document generation) commit e6e758fd15a725138de0f6195e81fe8e04186a01 Author: nadim khemir Date: Tue Apr 15 07:59:24 2008 +0200 FIXED: multi wirl inter-sections overlays error when the arrow backtracked on itself commit 1e25b671042386f1070d5b454b714a064c3d0c94 Author: nadim khemir Date: Tue Apr 15 07:53:23 2008 +0200 FIXED: moving connectors on each other bugs the connector size commit 0e9e6402ed2684bc572fab38c74fbcef9d9f2448 Author: nadim khemir Date: Mon Apr 14 11:39:43 2008 +0200 FIXED: multi wirl inter-sections overlays should be taken from the arrow definition commit 3eca833a47fa621560c637f2a75c305f2f8608ae Author: nadim khemir Date: Mon Apr 14 10:29:26 2008 +0200 FIXED: added section connects automatically commit b0a8e3cd026aff7680a9da666e29c50b8429e02c Author: nadim khemir Date: Mon Apr 14 10:05:20 2008 +0200 FIXED: Add section keeps connection commit d16ccabee59e0f9e7ac5eb76b1162fba42404906 Author: nadim khemir Date: Mon Apr 14 09:51:54 2008 +0200 ADDED: add section to current mouse position commit 8d79bf5561cd7e5c5dbe8e5113fc6c1a35ff710e Author: nadim khemir Date: Mon Apr 14 09:15:47 2008 +0200 ADDED: keep element selection order ADDED: change arrow type from context menue ADDED: development asciio run command (./A) commit dd91c74a4a770616ae3dbf6c2256465ce634870f Author: nadim khemir Date: Sun Apr 13 21:46:30 2008 +0200 CHANGED: change direction and flip arrow work with multi wirl arrow ADDED: action origin file is kept and displayed when action is run ADDED: scripts handle setup path commit 0f02ed81a5470dfffa95bb10151e31deccfe0783 Author: nadim khemir Date: Sun Apr 13 17:24:44 2008 +0200 CHANGED: single wirl arrow by multi-wirl arrow with single section commit 6a575918d14bbf92e5d1b916a8820c4f1e204c51 Author: nadim khemir Date: Sat Apr 12 02:20:58 2008 +0200 CHANGED: use multi wirl arrow instead for wirl arrow commit ee282672d7a8b1377ce2882a788a15c3ee95cd42 Author: nadim khemir Date: Fri Apr 11 22:29:24 2008 +0200 ADDED: --script commit 5a6c93d3029d199fa81efe4d41adc30cfbbe6627 Author: nadim khemir Date: Fri Apr 11 20:20:31 2008 +0200 FIXED: multi key actions commit 6ced133739a12d2852529d16a5092d34c637413b Author: nadim khemir Date: Fri Apr 11 19:58:57 2008 +0200 FIXED: uninitialized variable in context menu box action commit fe37cb45242cbcf6b259ee702631398a3a7d567d Author: nadim khemir Date: Fri Apr 11 19:38:12 2008 +0200 ADDED: Option parsing from PBS ADDED: Context menu actions commit d17636a35a37ada8e66b80d8cae057385d9f2611 Author: nadim khemir Date: Wed Apr 9 23:38:23 2008 +0200 Initial commit after changing to AsciiO name App-Asciio-1.02.71/Todo.txt0000444000076400001440000004256711122301056014273 0ustar nadimusers#----------------------# # This is the todo.txt # #----------------------# angled-up arrow .---- N::B::T::T::UDP / .-------- N::B::T::Tracker / \ / .-- N::B::T::File `--- N::B::T::T::HTTP / / .---- Net::BitTorrent::Torrent / / .--- Net::BitTorrent::DHT / / \ Net::BitTorrent `---- N::B::D::Node \ `---- Net::BitTorrent::Peer multiple box insert command should not insert boxes without text this allows us to have many more separators in the default list Display version somewhere convert asciio stencil to new format ? shortcut to display popup menu shift + click should deselect the object under the cursor Error: previously saved files (network) do not load new stencils connected, non auto-connect, arrows loose their connection if the connectee is resized => this is because resize doesn't keep the connection. The canonizer reconnects elements but non auto-connect objects are not handled by the canonizer => make canonizer re connect to the same place instead for changing the connector magnet object for ESD reload color options after loading file display_grid + element_backgound_color search for stripe class in the setup directory or list the directories in the setup or add the directory as setup data and 'use lib' let actions load stencils forward KB + mouse events to stripes objects autoconnect can change the direction of the arrow .---------. .---------. ------.| | | | | || | | | | v| | '----->| | | | | | | | | | '---------' '---------' table object bulleted lists and otherwise formatted text record box object save as pdf and printing more than one resize handle resize the selected element if any not the top most zoom on pointer #not ctl to zoom panning autosave merge arrows connector grouping multi-ended connectors add remove end from multi ended connectors vocabulary list save window size in file cancel button in editing windows transparancy mask vs stripes can we automatically generate stripes let user query which keyboard shortcut is still free generate a list instead (with links to existing actions and their files) handle unicode (remove write_file) update documentation error: changing arrow type changed the directions of sections auto routing now arrow can match inside a box, moving an arrow around has become more tricky => do not connect if both ends are unconnected and arrow is being moved move gtk dialog from stripe classes move action constants to module optimize do_stack serialization # use bzip2 => diff + compress # tests done must have a reverse diff that can patch both ways or it's not worth it Management mode => make ascii look like not ascii => use ANSI X3.64 connections connected to a start and an end connector are displayed with warning color move to display plugins => how do we handle double pointed arrows? #------------------- done ---------------------------- #auto resize after text changes? auto resize as an attribute to the box # selection that doesn't take arrows ! move to row column named ruler #save stencil one by one => give name to objects => save selected to stencils #stencil directory #if a directory is listed in the stencil section of the setup file, all the stencils in that directory are loaded #directory name should be added to the element name #ASCII in the context menue should be replaced by stencils or whatever directory is the root #network stencils missing small wireless #auto stencil stencils are 'run' this means that they can be created from other data #remove section at the begining of the arrow #add section at the begining of the arrow => auto connection works but moving the connected object -> error #dialogs #button missing icons !assign ctl + enter as OK in edit boxes => alt + C #vertical text !signing objects and diagrams? #toggle grid #text object should be resized to the text size when created #allow non auto-connect to be one character around the object instead for _on_ the object => this could be handled by the box object - the box object is asked to match a connector - the box object can dynamically create a connector - if the box object is resized, the connectors can be moved the connectors can remember their position if the box object is resized again - new connection should connect new connectors => we need to know who we are connecting to => or this could be done by the asciio object - asciio asks the box to add a connection this let ascioo decide where they should be placed instead for deciding it's around the box - the user can add connectors with the same mechanism - the connector must be handled when resizing the box object by the box object or by the connector itself #Box added via 'B' shortcut should be selected #reselect elements after quick link #select text an focus in text editing window #error: title has frame when text doesn't #link to camel box #background color, grid color #save file in exit dialog #continuation _from_ diagonal is not correct !allow diagonals in setup #diagonal lines #error: connector character is wrong #dynamically choose if the arrow allows diagonal or not (keyboard) #handle error when running external command Can't exec "dsq": No such file or directory at '/devel/perl_modules/App/Asciio/blib/lib/App/Asciio/setup//actions/unsorted.pl' line 365. Use of uninitialized value in split at /devel/perl_modules/App/Asciio/blib/lib/App/Asciio/stripes/editable_box2.pm line 50. #paste at the mouse position #per arrow autoconnect #dynamically add connectors #copy selected elements to clipboard #move ruler line definition to the setup allow removal of rulers allow specific location of rulers #dynamically generate GROUP_COLORS #figlet support Done via external command Emanuel Haupt Useless use of a constant in void context at /usr/lib64/perl5/site_perl/5.8.8/Text/FIGlet.pm line 177. hundreds of : Use of uninitialized value in substitution (s///) at /usr/lib64/perl5/site_perl/5.8.8/Text/FIGlet.pm line 93. Use of uninitialized value in concatenation (.) or string at /usr/lib64/perl5/site_perl/5.8.8/Text/FIGlet.pm line 95. Use of uninitialized value in string ne at /usr/lib64/perl5/site_perl/5.8.8/Text/FIGlet.pm line 154. Use of uninitialized value in string eq at /usr/lib64/perl5/site_perl/5.8.8/Text/FIGlet.pm line 163. Use of uninitialized value in string ne at /usr/lib64/perl5/site_perl/5.8.8/Text/FIGlet.pm line 200. #non connecting section wirl arrows #external command output Emanuel Haupt #screencast demo #remove section #export png #possibility to close the application from a script #return edits the currently selected box #error: targets are not opened #register_action_handlers return own data not the evaled package #script to generate a list of the actions available #error: |------------> #error: moving connectors on each other bugs the connector size only when end connector is backed over start connector #error: multi wirl inter-sections overlays should be taken from the arrow definition # .#### | # #####-## #direction change should work on any arrow section #error: Add section keeps connection #error: Add section doesn't connect # multi wirl extension as if we were drawing the arrow when the mouse takes a turn, a wirl point is added => or add section when clicked #Add section to cursor position #add easy way, through a shortcut, to: #change arrow type dots, equal, star, ... !make an arrow a muti wirl arow => use only multi wirl arrow #box a text #change box type # keep selection mode selected == index not boolean #display action definition file #Remove single wirl arrow object #=> a connection error occures when using a multiple wirl object with a single wirl write a test where two boxes are connected with one type of arrow and two other boxes with the other type of arrow, move the boxes around and compare the display # flip broken #change direction broken #test scripting lib #scripting lib difficult to locate => -Mblib broken too ADDED: option parsing #multi level action do not work anymore #contex menu box has errors Use of uninitialized value in numeric lt (<) at '/devel/perl_modules/App/Asciio/blib/lib/App/Asciio/setup//actions/context_menu_box.pl' line 118. Use of uninitialized value in array element at '/devel/perl_modules/App/Asciio/blib/lib/App/Asciio/setup//actions/context_menu_box.pl' line 120. #parse switches #setup path #file name is not remembered on, first Save As ! not kept in the undo buffer be carefull to not override SaveAs file name => don't go to previous file name if it was saved As #flip start and end of arrows #action can register themselves so they can add entries in context menues #CREATE_BACKUP is saved and restored with the files! #arrow pointing in both direction #wirl #multi wirl #quick insert short cut for both #do pod saving and loading without external commands and files #remove the cp command call and other backticks #connected box.pl with 3 boxes doesn't canonize the links properly note that we are giving a missleading hint to start with => connections are right !record gpad with do_stack and add a play_gpad script => better to save screenshots that are taken when using a keyboard shortcut => we can also record snippets, by recording at each create_undo_snapshot => use screencast #exporting an imported pod generates a slightly different base64 check a gpade dump => Dumper had different order #error when copying element that has connections appeared after quick link implementation connection seems to be wrong as it moves with the copied element but is not connected difficult to reproduce #shortcut to change the direction of an arrow instead for using wirl !auto connect with quick link uses the closest to the pointer give hint to wirl creation => better to be consistent. preference can be given in actions/mouse.pl #action shortcut should not be gtk dependent # remove redo_stack_maximum_size #action should register a name we can call them with instead for calling them by keyboard mapping #move %loaded_types in gpad_io to object #save file sets title, or not #gpad format is unreadable anyway, compress #gpade import/export remove gpade from gpad # importer can set the title #open save POD #use work directory #remove all unecessary use from the action files #open save export as plugins #saving as xx.txt will not save anything in gpad anymore ! add --setup to locate the setup directory => use file::Repository => use getopt #override/move gpad internally set variables with variables set in the setup files #=> wait till tab to space is defined #command to generate a stencil ready definition from the current state of an object => load multiple stencils and keep the filesystem structure in the popup menues => allow shortcut to be associated with the stencil elements (by name and in setup files) #drawing arrow into box connects the arrow #transfor tabs to space #only allow start-end connectors to link for multiwirl but allow moving of the intermediate connectors #shortcut that adds elements but opens the edit dialog directly before inserting the object should this be the default for object creation from stencils? => shall we add a EDIT_ON_CREATE fields= #ctl + shift + arrows => connect arrows as connect boxes does #color groups when using solid background => through a get_element_background_color #error shift plus select area doesn't work #do notshow resize rectangle if attribut is not set #error after aligning box centers, the connectors are real weird in if_elsif.gpad #verify all the '* $character_' and '\ $character_' #editing box breaks the connections #?use DTD::GTK for dumps !? table element => user defined plugin in the future !one character element should move not resize #keyboard mapping #automatic moving of start connector is weird => $moved_connector_name #-init #export is broken since 'save as' #handle file save properly #save unnamed to new name OK #save unnamed to old name ASK FOR OVERRIDE PERMISSION #save named DO NOT ASK NAME #save as WORKS as save UNAMED #save mark document as NOT MODIFIED (check undo still works) #redo #quick insert for text (same as quick insert for boxes) #save element's X Y in character sizes #access stencil elements by name !add module with shared constants (ie setup) => later #update_diagram should be configurable make a module so we can optimize a connection at the time canonize uses $self for character size only ? ask for the optimal connection before creating it #subs to connect specific connectors wherever the elements are and they are sized #script using cononize_connection doesn't work, path was changed #make a script library !update_diagram should be called when running in script mode let the script writer decide if they want "optimized" connections or not # proper setup structure #editable arrow has connections!! use resize/info/highlight points instead # export ASCII to clipboard #quick connect if selected elements connect element under to selected elements deselect all else select element #forward mouse to ACTIONS #$dragging moved to class setting it should be possible through an API #auto connect that moves an arrow start should update the end connector #multi wirl in default gpad.pl #alignment tool #single group element copied still thinks it part of a group #changing text in if reconnect wrong #set/get_text #default glyph types for box #setting X, Y in scipts doesn't generate expected ASCII output #connector error in multi wirl #transfor to ASCII output has extra spaces #multiline arrow take direction for every point (for scripting) !--script my_script.pl #save on exit if modified #multiline arrow !reapeat box given a text, it will repeat it depednding on the size !full multiples or not #process box #segfault #can't use Data::TreeDumper in copy to clipboard # 'new connection' is flashed for a connector that is already connected #tab to select first element generate 'uninitialzed value at 134' #undo #do not save undo buffer #copy doesn't keep connections #front back break connections #keyboard move doesn't move connections !cycle color for selection points like for groups? #move $previous_x, $previous_y to the class #error: drawing connections on move #error: drawing connections on resize box #error: drawing connections on edit #refactor other end offsetting (used in move and resize) #missing: save connections #error moving groups looses connection #thrown a few boxes and arrows in an empty document #keyboard short cut transparent mode show connectors connections #resize connectee doesn't move the connector #move group looses connections #resizing downright arrow flips it to rightdown handle multiple character start and end in angled arrow handle \t in text #after changing line glyphs, it becomes right down from right up !! #ungrouping moves object up selecting a single group element, through selection rectangle, selects the whole group right? #saving named objects uses the objects contents for the next copy #save doesn't save grouping !! save elements without NAME to avoid overriding object at load time ?? seems that selection rectangle sometimes doesn't work #selection is done botom up instead for the opposite! #when bg selection is on, can't select fg selecting an element that is between two grouped elements is not possible !selection cycles through objects when clicking + tab #BOX2 with title and text only displays wrong size #box and arrow streching are not ont the same box doesn't accept row 0 #can't loade face file #edit text to empty string #if only one element is editable in a group, edit it present selection box if multiple editable objects #handle \ in text for pango #_ is removed from name in menues spell cheker #grouping Window size in character multiples Drag drop objects from views or other aflow instance Select font Colored font Background color #Stencils are normal files #Grouping, alignment, send back/front #Grid display #Horizontal and vertical alignement lines !Objects are hilighted when overed (incuding groups) #Select and move object with a single click #Multiple object selection Save in multiple format, try to keep extra attributes like color         text, raw text, html !Object is an instance of a class         node can change class (eg from square to round)         class can be modified (eg color change for all nodes) Node class defines the node's apparence, class is a script User defined key mapping, mouse mapping and menu mapping #Static object mode         select object(s) and click to insert it without drag drop Layers?         each layer has its tab and one can see through tabs         how does this play with split window Scripts can add their mappings Scripts can generate new graphs Re-order script so objects without link are aligned under each other Routing and reordering script Script can be save in stencil Drag drop script object executes it App-Asciio-1.02.71/Build.PL0000444000076400001440000001232411122301056014105 0ustar nadimusers use strict ; use warnings ; use Module::Build; my %all_modules ; my @split_modules ; my @pm_files = qw( lib/App/Asciio.pm lib/App/Asciio/Actions.pm lib/App/Asciio/Ascii.pm lib/App/Asciio/Connections.pm lib/App/Asciio/Dialogs.pm lib/App/Asciio/Elements.pm lib/App/Asciio/Io.pm lib/App/Asciio/Menues.pm lib/App/Asciio/Setup.pm lib/App/Asciio/Undo.pm lib/App/Asciio/Options.pm lib/App/Asciio/stripes/editable_arrow2.pm lib/App/Asciio/stripes/editable_box2.pm lib/App/Asciio/stripes/if_box.pm lib/App/Asciio/stripes/process_box.pm lib/App/Asciio/stripes/section_wirl_arrow.pm lib/App/Asciio/stripes/single_stripe.pm lib/App/Asciio/stripes/stripes.pm lib/App/Asciio/stripes/wirl_arrow.pm ); for(@pm_files) { $all_modules{$_} = $_ ; push @split_modules, $_ ; } my @setup_lib= qw( setup/setup.ini setup/actions/align.pl setup/actions/clipboard.pl setup/actions/debug.pl setup/actions/elements_manipulation.pl setup/actions/file.pl setup/actions/mouse.pl setup/actions/new_elements.pl setup/actions/colors.pl setup/actions/unsorted.pl setup/actions/presentation.pl setup/actions/context_menu_multi_wirl.pl setup/actions/context_menu_box.pl setup/actions/context_menu_rulers.pl setup/asciio_object/basic.pl setup/hooks/canonize_connections.pl setup/import_export/ascii.pl setup/import_export/asciioe.pl setup/import_export/perl.pl setup/import_export/png.pl setup/stencils/asciio setup/stencils/computer setup/stencils/people setup/stencils/divers ) ; for(@setup_lib) { $all_modules{$_} = "lib/App/Asciio/$_" ; } sub GetVersionAndRevisionFrom { my ($file) = @_ ; my $version_from = File::Spec->catfile( split '/', $file ); my $version = Module::Build->version_from_file($version_from); if($ENV{'App_Asciio_USE_GIT_VERSION_FOR_DIST'}) { my $number_of_commits = `git log | grep -E 'commit [0-9a-f]{40}' | wc -l` ; chomp $number_of_commits ; if($number_of_commits) { #print "number of git revision: $number_of_commits.\n" ; return("${version}.${number_of_commits}") ; } else { print "Couldn't get git revision, using version from '$file'!\n" ; return($version) ; } } else { return($version) ; } } my $code = <<'EOC'; use strict ; use warnings ; sub GetVersionAndRevisionFrom { my ($file) = @_ ; my $version_from = File::Spec->catfile( split '/', $file ); my $version = Module::Build->version_from_file($version_from); if($ENV{'App_Asciio_USE_GIT_VERSION_FOR_DIST'}) { my $number_of_commits = `git log | grep -E 'commit [0-9a-f]{40}' | wc -l` ; chomp $number_of_commits ; if($number_of_commits) { #print "number of git revision: $number_of_commits.\n" ; return("${version}.${number_of_commits}") ; } else { print "Couldn't get git revision, using version from '$file'!\n" ; return($version) ; } } else { return($version) ; } } sub ACTION_author_test { my $self = shift; local $self->{properties}{test_files} = 'xt/author/*.t' ; $self->SUPER::ACTION_test(); } sub ACTION_build { my $self = shift; if($ENV{'App_Asciio_USE_GIT_VERSION_FOR_DIST'}) { my ($version) = GetVersionAndRevisionFrom('lib/App/Asciio.pm') ; #~ print "Generating version module ($version)\n" ; open VERSION, '>', 'Version.pm' or die "can't generate Version module: $!\n" ; print VERSION <SUPER::ACTION_build(@_); } sub ACTION_dist { my $self = shift; if($ENV{'App_Asciio_USE_GIT_VERSION_FOR_DIST'}) { my $have_git = $self->do_system('git --version'); if($have_git) { print `git status -a`; if($self->do_system('git log > git_Changes')) { use File::Copy; move('git_Changes', 'Changes') ; } else { print "Couldn't get git log, 'Changes' will not be generated from git log!\n" ; } } else { print "git not found, 'Changes' will not be generated from git log!\n" ; } } $self->SUPER::ACTION_test() ; #~ $self->ACTION_author_test() ; $self->SUPER::ACTION_dist(); }; EOC my $class = Module::Build->subclass(class => 'App::Asciio', code => $code) ; my $build = $class->new ( module_name => 'App::Asciio', dist_version => GetVersionAndRevisionFrom('lib/App/Asciio.pm'), license => 'perl', requires => { 'Readonly' => 0, 'Data::Compare' => 0, 'Sub::Exporter' => 0, 'Data::TreeDumper' => 0, 'version' => 0.50, 'Compress::Bzip2' => 0, 'Cwd' => 0, 'Data::TreeDumper::Renderer::GTK' => 0, 'Directory::Scratch' => 0, 'Directory::Scratch::Structured' => 0, 'Eval::Context' => 0, 'File::Basename' => 0, 'File::Spec' => 0, 'Glib' => 0, 'Gtk2' => 0, 'Gtk2::Gdk::Keysyms' => 0, 'List::MoreUtils' => 0, 'List::Util' => 0, 'MIME::Base64' => 0, 'File::Copy' => 0, 'File::Slurp' => 0, 'Algorithm::Diff' => 0, 'Clone' => 0, 'Module::Util' =>0, 'Test::Block' => 0, 'Test::Exception' => 0, 'Test::NoWarnings' => 0, 'Test::Warn' => 0, 'Test::Strict' => 0, }, pm_files => \%all_modules, #~ autosplit => \@split_modules, script_files => 'script/asciio', dist_author => 'Khemir Nadim ibn Hamouda. ', dist_abstract => 'App::Asciio - ASCII diagramming', ); $build->create_build_script; App-Asciio-1.02.71/documentation/0000755000076400001440000000000011122301056015462 5ustar nadimusersApp-Asciio-1.02.71/documentation/text/0000755000076400001440000000000011122301056016446 5ustar nadimusersApp-Asciio-1.02.71/documentation/text/boxes.txt0000444000076400001440000000066711122301056020336 0ustar nadimusers .----------. | title | .----------. |----------| ************ | | | body 1 | * * '----------' | body 2 | ************ '----------' anything in a box (\_/) | edit_me (O.o) <------------' (> <) App-Asciio-1.02.71/documentation/text/asciio_window.txt0000444000076400001440000000461311122301056022047 0ustar nadimusers default elements in an empty diagram .------------------------. | | | | | | .-------|---------------|--------|------------------------------------------. | | | | asciio | |-------|---------------|--------|------------------------------------------| | ......v---------......v........v......................................... | | .....| |..edit_me....--->....................................... | | .....'----------'........................................................ | | ......................................................................... | | ...................----------------..---------------..................... | | ..................| ASCII > || thin_box |.................... | | ..................| Rules line > || text |.................... | | ..................| Load || wirl_arrow |.................... | grid------------->..........| Save || arrow |.----------......... | | ..................| Export > || box > || star_box |........ | | ..................'----------------'| Rulers > |'----------'........ | | ...........................^........| Misc > |.................... | | ...........................|........| T_star |.................... | | ...........................|........'---------------'.................... | | ...........................|............................................. | | ...........................|............................................. | | ...........................|............................................. | | ...........................|............................................. | | ...........................|............................................. | | ...........................|............................................. | '----------------------------|----------------------------------------------' | context menu App-Asciio-1.02.71/documentation/text/permissions.txt0000444000076400001440000000050511122301056021560 0ustar nadimusers 421 421 421 \ | / \ | / v v v drwxrwxrwx ^| || || | / '-''-''-' / ^ ^ ^ file type \ \ \ indicator \ \ \ user \ \ group \ other App-Asciio-1.02.71/documentation/text/depend_and_build.txt0000444000076400001440000000366311122301056022455 0ustar nadimusers .---------------------------. | PBS::CreateDependencyTree | '---------------------------' | | <-----------------------------------------------depend only------------------------------------------------> | | .-----------. .-------------------. .-------------------------. .---------------------. .---------------------------. '-->| Depender |--->| C_SourceDepender |--->| GenerateDependencyFile |--->| $PreprocessorDepend |-->| Devel::Depend::Cl::Depend | '-----------'| '-------------------' '-------------------------'| '---------------------' '---------------------------' | | | | | | <-----------------------------------depend and build simulteanously----------------------------------------> | | | .--------------------------. | '->| C_DependAndBuildDepender | | '--------------------------' | ^ | | | | | | v | .-------------------------------. | .----------------------. .---------------------------------. | Generate $PreprocessorDepend2 | '---| $PreprocessorDepend2 |--->| Devel::Depend::Cl::RunAndParse | '-------------------------------' '----------------------' '---------------------------------' App-Asciio-1.02.71/documentation/text/wirl.txt0000444000076400001440000000051011122301056020156 0ustar nadimusers ^ | | --------. | | '------- | | O-------------X / | / | / | / v / / v App-Asciio-1.02.71/documentation/text/links.txt0000555000076400001440000000017511122301056020333 0ustar nadimusersinterresting link: http://www.fossildraw.com/?gclid=CLanxZXxoJECFRYYEAodnBS8Dg http://ditaa.sourceforge.net/ www.jave.de App-Asciio-1.02.71/documentation/text/example_3.txt0000444000076400001440000000052311122301056021062 0ustar nadimusers User code ^ ^ OS code \ / \ / \ / User code <----Mode----->OS code / \ / \ / \ User code v v OS code App-Asciio-1.02.71/documentation/text/example_4.txt0000444000076400001440000000157111122301056021067 0ustar nadimusers .---. .---. .---. .---. .---. .---. OS API '---' '---' '---' '---' '---' '---' | | | | | | v v | v | v .------------. | .-----------. | .-----. | Filesystem | | | Scheduler | | | MMU | '------------' | '-----------' | '-----' | | | | v | | v .----. | | .---------. | IO |<----' | | Network | '----' | '---------' | | | v v v .---------------------------------------. | HAL | '---------------------------------------' App-Asciio-1.02.71/documentation/text/example_5.txt0000444000076400001440000000161711122301056021071 0ustar nadimusers .---------. .---------. | State 1 | | State 2 | '---------' '---------' ^ \ ^ \ / \ / \ / \ / \ / \ / \ / \ / \ / v v ****** ****** ****** * T1 * * T2 * * T3 * ****** ****** ****** ^ ^ / \ \ / \ \ / \ \ / stimuli \ \ / \ \ v \ .---------. '--------| State 3 | '---------' App-Asciio-1.02.71/documentation/scripting/0000755000076400001440000000000011122301056017464 5ustar nadimusersApp-Asciio-1.02.71/documentation/scripting/lib/0000755000076400001440000000000011122301056020232 5ustar nadimusersApp-Asciio-1.02.71/documentation/scripting/lib/scripting_lib.pm0000444000076400001440000001030011122301056023410 0ustar nadimusers use strict; use warnings; use lib qw(lib lib/stripes) ; #-------------------------------------------------------------------------------------------- sub new_box { my (@arguments_to_constructor) = @_ ; use App::Asciio::stripes::editable_box2 ; my $box = new App::Asciio::stripes::editable_box2 ({ TEXT_ONLY => 'box', TITLE => '', EDITABLE => 1, RESIZABLE => 1, @arguments_to_constructor, }) ; return($box) ; } #----------------------------------------------------------------------------------------------------------- sub new_wirl_arrow { my (@arguments) = @_ ; use App::Asciio::stripes::section_wirl_arrow ; my $arrow = new App::Asciio::stripes::section_wirl_arrow ({ POINTS => [[5, 5, 'downright']], DIRECTION => '', ALLOW_DIAGONAL_LINES => 0, EDITABLE => 1, RESIZABLE => 1, @arguments, }) ; } #-------------------------------------------------------------------------------------------- sub add_connection { my ($self, $source_element, $destination_element, $hint, @arguments_to_constructor) = @_ ; $hint ||= 'right-down' ; my @destination_connections = grep {$_->{NAME} ne 'resize'} $destination_element->get_connection_points() ; my $destination_connection = $destination_connections[0] ; my @source_connections = grep {$_->{NAME} ne 'resize'} $source_element->get_connection_points() ; my $source_connection = $source_connections[0] ; my $new_element = new App::Asciio::stripes::section_wirl_arrow ({ POINTS => [ [ ($destination_element->{X} + $destination_connection->{X}) - ($source_element->{X} + $source_connection->{X}) , ($destination_element->{Y} + $destination_connection->{Y}) - ($source_element->{Y} + $source_connection->{Y}) , $hint, ] ], DIRECTION => $hint, ALLOW_DIAGONAL_LINES => 0, EDITABLE => 1, RESIZABLE => 1, @arguments_to_constructor, }) ; # let check_connection do the job of optimizing @$new_element{'X', 'Y'} = ($source_element->{X} + $source_connection->{X}, $source_element->{Y} + $source_connection->{Y}) ; $self->add_elements($new_element) ; } #-------------------------------------------------------------------------------------------- sub move_named_connector { my ($connected, $connector_name, $connectee, $connection_name) = @_ ; do { die "Invalid argument to 'move_named_connector'!\n" unless defined $_} for (@_) ; die "Invalid number of arguments to 'move_named_connector'!\n" unless @_ == 4 ; my $connector = $connected->get_named_connection($connector_name) ; my $connection = $connectee->get_named_connection($connection_name) ; if(defined $connector && defined $connection) { my $connector_x = $connected->{X} + $connector->{X} ; my $connector_y = $connected->{Y} + $connector->{Y} ; my $connection_x = $connectee->{X} + $connection->{X} ; my $connection_y = $connectee->{Y} + $connection->{Y} ; my $connector_x_offset = $connection_x - $connector_x ; my $connector_y_offset = $connection_y - $connector_y ; my ($x_offset, $y_offset, $width, $height, $new_connector) = $connected->move_connector ( $connector_name, $connector_x_offset, $connector_y_offset ) ; $connected->{X} += $x_offset ; $connected->{Y} += $y_offset ; return { CONNECTED => $connected, CONNECTOR =>$new_connector, CONNECTEE => $connectee, CONNECTION => $connection, } ; } else { return ; } } #----------------------------------------------------------------------------------------------------------- sub optimize_connections { my ($self) = @_; $self->call_hook('CANONIZE_CONNECTIONS', $self->{CONNECTIONS}) ; } #-------------------------------------------------------------------------------------------- sub get_canonizer { my $context = new Eval::Context() ; $context->eval ( REMOVE_PACKAGE_AFTER_EVAL => 0, # VERY IMPORTANT as we return code references that will cease to exist otherwise PRE_CODE => <<'EOC' , use strict; use warnings; sub register_hooks { return \&canonize_connections ; } EOC CODE_FROM_FILE => 'setup/hooks/canonize_connections.pl' , ) ; } #-------------------------------------------------------------------------------------------- 1 ; App-Asciio-1.02.71/documentation/scripting/connected_boxes.pl0000444000076400001440000000206311122301056023162 0ustar nadimusers use strict; use warnings; use lib qw(lib/stripes documentation/scripting/lib) ; use App::Asciio ; use scripting_lib ; #----------------------------------------------------------------------------- my $asciio = new App::Asciio() ; my ($command_line_switch_parse_ok, $command_line_parse_message, $asciio_config) = $asciio->ParseSwitches([@ARGV], 0) ; die "Error: '$command_line_parse_message'!" unless $command_line_switch_parse_ok ; $asciio->setup($asciio_config->{SETUP_INI_FILE}, $asciio_config->{SETUP_PATH}) ; #----------------------------------------------------------------------------- my $box1 = new_box(TEXT_ONLY =>'box1') ; $asciio->add_element_at($box1, 0, 2) ; my $box2 = new_box(TEXT_ONLY =>'box2') ; $asciio->add_element_at($box2, 20, 10) ; my $box3 = new_box(TEXT_ONLY =>'box3') ; $asciio->add_element_at($box3, 40, 5) ; add_connection($asciio, $box1, $box2, 'down') ; add_connection($asciio, $box2, $box3, ) ; add_connection($asciio, $box3, $box1, 'up') ; optimize_connections($asciio) ; print $asciio->transform_elements_to_ascii_buffer() ; App-Asciio-1.02.71/documentation/scripting/objects.pl0000444000076400001440000000304211122301056021447 0ustar nadimusers use strict; use warnings; use lib qw(lib lib/stripes) ; use Data::TreeDumper ; use App::Asciio ; use App::Asciio::stripes::editable_box2 ; use App::Asciio::stripes::process_box ; use App::Asciio::stripes::single_stripe ; #----------------------------------------------------------------------------- my $asciio = new App::Asciio() ; #----------------------------------------------------------------------------- my ($current_x, $current_y) = (0, 0) ; my $new_box = new App::Asciio::stripes::editable_box2 ({ TEXT_ONLY => 'box', TITLE => '', EDITABLE => 1, RESIZABLE => 1, }) ; $asciio->add_element_at($new_box, 0, 0) ; my $new_process = new App::Asciio::stripes::process_box ({ TEXT_ONLY => 'process', EDITABLE => 1, RESIZABLE => 1, }) ; $asciio->add_element_at($new_process, 25, 0) ; my $new_stripe = new App::Asciio::stripes::single_stripe ({ TEXT => 'stripe', }) ; $asciio->add_element_at($new_stripe, 50, 0) ; print $asciio->transform_elements_to_ascii_buffer() ; $new_box->set_text('title', "line 1\nline 2") ; $new_process->set_text("line 1\nline2\nline3") ; $new_stripe->set_text( "line 1\nline2") ; print $asciio->transform_elements_to_ascii_buffer() ; for ($new_box, $new_process, $new_stripe) { print "\n-------------------------------------------------------\n\n" ; print 'type: ', ref($_), "\n" ; print 'size:', join(",", $_->get_size()) , "\n" ; print DumpTree([$_->get_connection_points()], 'connection points:') , "\n" ; print 'text : ', join("\n", $_->get_text()) , "\n" ; } App-Asciio-1.02.71/documentation/scripting/multi_wirl.pl0000444000076400001440000000125011122301056022204 0ustar nadimusers use strict; use warnings; use lib qw(lib lib/stripes) ; use App::Asciio ; use App::Asciio::stripes::section_wirl_arrow; #----------------------------------------------------------------------------- my $asciio = new App::Asciio() ; #----------------------------------------------------------------------------- my $new_element = new App::Asciio::stripes::section_wirl_arrow ({ POINTS => [[5, 5, 'downright'], [10, 7, 'downright'], [7, 14, 'downleft'], ], DIRECTION => '', ALLOW_DIAGONAL_LINES => 0, EDITABLE => 1, RESIZABLE => 1, }) ; $asciio->add_element_at($new_element, 5, 5) ; print $asciio->transform_elements_to_ascii_buffer() ; App-Asciio-1.02.71/documentation/scripting/if_objects.pl0000444000076400001440000000164511122301056022134 0ustar nadimusers use strict; use warnings; use lib qw(lib lib/stripes) ; use Data::TreeDumper ; use App::Asciio ; use App::Asciio::stripes::if_box ; #----------------------------------------------------------------------------- my $asciio = new App::Asciio() ; #----------------------------------------------------------------------------- my @text = ( 'a == 1235', 'b < 0', 'b > 125', 'very long', '&& $x >= $y_123', 'c eq 35', ' $a ~= /^$/', ) ; my $box_index = 0 ; my $next_line = 0 ; for (1 .. 7) { my $text = '' ; $text .= $text[rand(@text)] . "\n" for (1 .. $box_index) ; my $if_box = new App::Asciio::stripes::if_box ({ TEXT_ONLY => $text, EDITABLE => 1, RESIZABLE => 1, }) ; @$if_box{'X', 'Y'} = (0, $next_line) ; $asciio->add_elements($if_box) ; my ($w, $h) = $if_box->get_size() ; $next_line += $h + 1 ; $box_index++ ; } print $asciio->transform_elements_to_ascii_buffer() ; App-Asciio-1.02.71/documentation/scripting/three_boxes.pl0000444000076400001440000000143211122301056022326 0ustar nadimusers use strict; use warnings; use lib qw(lib lib/stripes) ; use App::Asciio; use App::Asciio::stripes::editable_box2 ; #----------------------------------------------------------------------------- my $asciio = new App::Asciio() ; #----------------------------------------------------------------------------- my ($current_x, $current_y) = (0, 0) ; for my $element_text (qw(box_1 box_2 box_3)) { my $new_element = new App::Asciio::stripes::editable_box2 ({ TEXT_ONLY => $element_text, TITLE => '', EDITABLE => 1, RESIZABLE => 1, }) ; $asciio->add_element_at($new_element, $current_x, $current_y) ; $current_x += $asciio->{COPY_OFFSET_X} ; $current_y += $asciio->{COPY_OFFSET_Y} ; } print $asciio->transform_elements_to_ascii_buffer() ; App-Asciio-1.02.71/documentation/scripting/manual_connect.pl0000444000076400001440000000270011122301056023004 0ustar nadimusers use strict; use warnings; use lib qw(documentation/scripting/lib) ; use App::Asciio ; use scripting_lib ; #----------------------------------------------------------------------------- my $asciio = new App::Asciio() ; my ($command_line_switch_parse_ok, $command_line_parse_message, $asciio_config) = $asciio->ParseSwitches([@ARGV], 0) ; die "Error: '$command_line_parse_message'!" unless $command_line_switch_parse_ok ; $asciio->setup($asciio_config->{SETUP_INI_FILE}, $asciio_config->{SETUP_PATH}) ; #----------------------------------------------------------------------------- my $box1 = new_box(TEXT_ONLY =>'box1') ; $asciio->add_element_at($box1, 0, 2) ; my $box2 = new_box(TEXT_ONLY =>'box2') ; $asciio->add_element_at($box2, 20, 10) ; my $box3 = new_box(TEXT_ONLY =>'box3') ; $asciio->add_element_at($box3, 40, 5) ; my $arrow = new_wirl_arrow () ; $asciio->add_element_at($arrow, 0,0) ; my $start_connection = move_named_connector($arrow, 'startsection_0', $box1, 'bottom_center'); my $end_connection = move_named_connector($arrow, 'endsection_0', $box2, 'bottom_center') ; die "missing connection!" unless defined $start_connection && defined $end_connection ; $asciio->add_connections($start_connection, $end_connection) ; get_canonizer()->([$start_connection, $end_connection]) ; print $asciio->transform_elements_to_ascii_buffer() ; #----------------------------------------------------------------------------------------------------------- App-Asciio-1.02.71/Makefile.PL0000444000076400001440000000023211122301056014556 0ustar nadimusers use strict ; use warnings ; use Module::Build::Compat; Module::Build::Compat->run_build_pl(args => \@ARGV); Module::Build::Compat->write_makefile(); App-Asciio-1.02.71/META.yml0000444000076400001440000000317111122301056014062 0ustar nadimusers--- name: App-Asciio version: 1.02.71 author: - 'Khemir Nadim ibn Hamouda. ' abstract: 'App::Asciio - ASCII diagramming' license: perl resources: license: http://dev.perl.org/licenses/ requires: Algorithm::Diff: 0 Clone: 0 Compress::Bzip2: 0 Cwd: 0 Data::Compare: 0 Data::TreeDumper: 0 Data::TreeDumper::Renderer::GTK: 0 Directory::Scratch: 0 Directory::Scratch::Structured: 0 Eval::Context: 0 File::Basename: 0 File::Copy: 0 File::Slurp: 0 File::Spec: 0 Glib: 0 Gtk2: 0 Gtk2::Gdk::Keysyms: 0 List::MoreUtils: 0 List::Util: 0 MIME::Base64: 0 Module::Util: 0 Readonly: 0 Sub::Exporter: 0 Test::Block: 0 Test::Exception: 0 Test::NoWarnings: 0 Test::Strict: 0 Test::Warn: 0 version: 0.5 provides: App::Asciio: file: lib/App/Asciio.pm version: 1.02 App::Asciio::stripes::editable_arrow2: file: lib/App/Asciio/stripes/editable_arrow2.pm App::Asciio::stripes::editable_box2: file: lib/App/Asciio/stripes/editable_box2.pm App::Asciio::stripes::if_box: file: lib/App/Asciio/stripes/if_box.pm App::Asciio::stripes::process_box: file: lib/App/Asciio/stripes/process_box.pm App::Asciio::stripes::section_wirl_arrow: file: lib/App/Asciio/stripes/section_wirl_arrow.pm App::Asciio::stripes::single_stripe: file: lib/App/Asciio/stripes/single_stripe.pm App::Asciio::stripes::stripes: file: lib/App/Asciio/stripes/stripes.pm App::Asciio::stripes::wirl_arrow: file: lib/App/Asciio/stripes/wirl_arrow.pm generated_by: Module::Build version 0.2808 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.2.html version: 1.2 App-Asciio-1.02.71/script/0000755000076400001440000000000011122301056014115 5ustar nadimusersApp-Asciio-1.02.71/script/asciio0000555000076400001440000000412411122301056015311 0ustar nadimusers#!/usr/bin/perl -w package main ; use strict; use warnings; use Glib ':constants'; use Gtk2 -init; Gtk2->init; use App::Asciio ; #----------------------------------------------------------------------------- my $window = Gtk2::Window->new('toplevel'); $window->set_title("asciio"); $window->set_default_size(640, 480) ; $window->signal_connect("destroy", sub { exit(0); }); my $vbox = Gtk2::VBox->new (FALSE, 0); $window->add($vbox); my $hpaned = Gtk2::HPaned->new; $vbox->pack_start($hpaned, TRUE, TRUE, 0); $hpaned->set_border_width (3); my @asciios ; my $asciio = new App::Asciio(50, 25) ; push @asciios, $asciio ; $hpaned->add1($asciio->{widget}); $vbox->show_all(); $window->show(); my ($command_line_switch_parse_ok, $command_line_parse_message, $asciio_config) = $asciio->ParseSwitches([@ARGV], 0) ; die "Error: '$command_line_parse_message'!" unless $command_line_switch_parse_ok ; $asciio->setup($asciio_config->{SETUP_INI_FILE}, $asciio_config->{SETUP_PATH}) ; my ($character_width, $character_height) = $asciio->get_character_size() ; if(defined $asciio_config->{TARGETS}[0]) { $asciio->run_actions_by_name(['Open', $asciio_config->{TARGETS}[0]]) ; } $asciio->set_modified_state(0) ; $asciio->run_script($asciio_config->{SCRIPT}) ; #-------------------------------------------------------------------------- $window->signal_connect (delete_event => \&delete_event, \@asciios) ; sub delete_event { my ($window, $event, $asciios) = @_; my $answer = 'yes'; my $should_save ; for my $asciio (@{$asciios}) { $should_save++ if $asciio->get_modified_state() ; } if($should_save) { $answer = App::Asciio::display_quit_dialog($window, 'asciio', ' ' x 25 . "Document is modified!\n\nAre you sure you want to quit and loose your changes?\n") ; } if($answer eq 'save_and_quit') { for my $asciio (@{$asciios}) { my @saved_result = $asciio->run_actions_by_name('Save') ; $answer = 'cancel' if(! defined $saved_result[0][0] || $saved_result[0][0] eq '') ; } } return $answer eq 'cancel'; } #-------------------------------------------------------------------------- Gtk2->main(); App-Asciio-1.02.71/MANIFEST0000444000076400001440000000365211122301056013746 0ustar nadimusersChanges Build.PL Makefile.PL MANIFEST README META.yml README Todo.txt script/asciio setup/setup.ini setup/actions/align.pl setup/actions/clipboard.pl setup/actions/debug.pl setup/actions/elements_manipulation.pl setup/actions/file.pl setup/actions/mouse.pl setup/actions/new_elements.pl setup/actions/unsorted.pl setup/actions/context_menu_multi_wirl.pl setup/actions/context_menu_box.pl setup/actions/context_menu_rulers.pl setup/actions/colors.pl setup/actions/presentation.pl setup/asciio_object/basic.pl setup/hooks/canonize_connections.pl setup/import_export/ascii.pl setup/import_export/asciioe.pl setup/import_export/perl.pl setup/import_export/png.pl setup/stencils/asciio setup/stencils/computer setup/stencils/people setup/stencils/divers lib/App/Asciio.pm lib/App/Asciio/Actions.pm lib/App/Asciio/Ascii.pm lib/App/Asciio/Connections.pm lib/App/Asciio/Dialogs.pm lib/App/Asciio/Elements.pm lib/App/Asciio/Io.pm lib/App/Asciio/Menues.pm lib/App/Asciio/Setup.pm lib/App/Asciio/Undo.pm lib/App/Asciio/Options.pm lib/App/Asciio/stripes/editable_arrow2.pm lib/App/Asciio/stripes/editable_box2.pm lib/App/Asciio/stripes/if_box.pm lib/App/Asciio/stripes/process_box.pm lib/App/Asciio/stripes/section_wirl_arrow.pm lib/App/Asciio/stripes/single_stripe.pm lib/App/Asciio/stripes/stripes.pm lib/App/Asciio/stripes/wirl_arrow.pm t/001_load.t t/002_multi_wirl_connection.t documentation/scripting/connected_boxes.pl documentation/scripting/if_objects.pl documentation/scripting/manual_connect.pl documentation/scripting/multi_wirl.pl documentation/scripting/objects.pl documentation/scripting/three_boxes.pl documentation/scripting/lib/scripting_lib.pm documentation/text/boxes.txt documentation/text/depend_and_build.txt documentation/text/example_3.txt documentation/text/example_4.txt documentation/text/example_5.txt documentation/text/asciio_window.txt documentation/text/links.txt documentation/text/permissions.txt documentation/text/wirl.txt