home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _b3567548d47b19ce6f73c9bba480fb91 < prev    next >
Text File  |  2004-06-01  |  26KB  |  1,023 lines
  1. # Copyright (c) 1995-2004 Nick Ing-Simmons.
  2. # Copyright (c) 1999 Greg London.
  3. # All rights reserved.
  4. # This program is free software; you can redistribute it and/or
  5. # modify it under the same terms as Perl itself.
  6. package Tk::TextUndo;
  7.  
  8. use vars qw($VERSION $DoDebug);
  9. $VERSION = '4.013'; # $Id: //depot/Tkutf8/Tk/TextUndo.pm#15 $
  10. $DoDebug = 0;
  11.  
  12. use Tk qw (Ev);
  13. use AutoLoader;
  14.  
  15. use Tk::Text ();
  16. use base qw(Tk::Text);
  17.  
  18. Construct Tk::Widget 'TextUndo';
  19.  
  20. sub ClassInit
  21. {
  22.  my ($class,$mw) = @_;
  23.  $mw->bind($class,'<<Undo>>','undo');
  24.  $mw->bind($class,'<<Redo>>','redo');
  25.  
  26.  return $class->SUPER::ClassInit($mw);
  27. }
  28.  
  29.  
  30. ####################################################################
  31. # methods for manipulating the undo and redo stacks.
  32. # no one should directly access the stacks except for these methods.
  33. # everyone else must access the stacks through these methods.
  34. ####################################################################
  35. sub ResetUndo
  36. {
  37.  my ($w) = @_;
  38.  delete $w->{UNDO};
  39.  delete $w->{REDO};
  40. }
  41.  
  42. sub PushUndo
  43. {
  44.  my $w = shift;
  45.  $w->{UNDO} = [] unless (exists $w->{UNDO});
  46.  push(@{$w->{UNDO}},@_);
  47. }
  48.  
  49. sub PushRedo
  50. {
  51.  my $w = shift;
  52.  $w->{REDO} = [] unless (exists $w->{REDO});
  53.  push(@{$w->{REDO}},@_);
  54. }
  55.  
  56. sub PopUndo
  57. {
  58.  my ($w) = @_;
  59.  return pop(@{$w->{UNDO}}) if defined $w->{UNDO};
  60.  return undef;
  61. }
  62.  
  63. sub PopRedo
  64. {
  65.  my ($w) = @_;
  66.  return pop(@{$w->{REDO}}) if defined $w->{REDO};
  67.  return undef;
  68. }
  69.  
  70. sub ShiftRedo
  71. {
  72.  my ($w) = @_;
  73.  return shift(@{$w->{REDO}}) if defined $w->{REDO};
  74.  return undef;
  75. }
  76.  
  77. sub numberChanges
  78. {
  79.  my ($w) = @_;
  80.  return 0 unless (exists $w->{'UNDO'}) and (defined($w->{'UNDO'}));
  81.  return scalar(@{$w->{'UNDO'}});
  82. }
  83.  
  84. sub SizeRedo
  85. {
  86.  my ($w) = @_;
  87.  return 0 unless exists $w->{'REDO'};
  88.  return scalar(@{$w->{'REDO'}});
  89. }
  90.  
  91. sub getUndoAtIndex
  92. {
  93.  my ($w,$index) = @_;
  94.  return undef unless (exists $w->{UNDO});
  95.  return $w->{UNDO}[$index];
  96. }
  97.  
  98. sub getRedoAtIndex
  99. {
  100.  my ($w,$index) = @_;
  101.  return undef unless (exists $w->{REDO});
  102.  return $w->{REDO}[$index];
  103. }
  104.  
  105. ####################################################################
  106. # type "hello there"
  107. # hello there_
  108. # hit UNDO
  109. # hello_
  110. # type "out"
  111. # hello out_
  112. # pressing REDO should not do anything
  113. # pressing UNDO should make "out" disappear.
  114. # pressing UNDO should make "there" reappear.
  115. # pressing UNDO should make "there" disappear.
  116. # pressing UNDO should make "hello" disappear.
  117. #
  118. # if there is anything in REDO stack and
  119. # the OperationMode is normal, (i.e. not in the middle of an ->undo or ->redo)
  120. # then before performing the current operation
  121. # take the REDO stack, and put it on UNDO stack
  122. # such that UNDO/REDO keystrokes will still make logical sense.
  123. #
  124. # call this method at the beginning of any overloaded method
  125. # which adds operations to the undo or redo stacks.
  126. # it will perform all the magic needed to handle the redo stack.
  127. ####################################################################
  128. sub CheckForRedoShuffle
  129. {
  130.  my ($w) = @_;
  131.  my $size_redo = $w->SizeRedo;
  132.  return unless $size_redo && ($w->OperationMode eq 'normal');
  133.  # local $DoDebug = 1;
  134.  
  135.  # we are about to 'do' something new, but have something in REDO stack.
  136.  # The REDOs may conflict with new ops, but we want to preserve them.
  137.  # So convert them to UNDOs - effectively do them and their inverses
  138.  # so net effect on the widget is no-change.
  139.  
  140.  $w->dump_array('StartShuffle');
  141.  
  142.  $w->OperationMode('REDO_MAGIC');
  143.  $w->MarkSelectionsSavePositions;
  144.  
  145.  my @pvtundo;
  146.  
  147.  # go through REDO array from end downto 0, i.e. pseudo pop
  148.  # then pretend we did 'redo' get inverse, and push into UNDO array
  149.  # and 'do' the op.
  150.  for (my $i=$size_redo-1; $i>=0 ; $i--)
  151.   {
  152.    my ($op,@args) = @{$w->getRedoAtIndex($i)};
  153.    my $op_undo = $op .'_UNDO';
  154.    # save the inverse of the op on the UNDO array
  155.    # do this before the re-doing the op - after a 'delete' we cannot see
  156.    # text we deleted!
  157.    my $undo = $w->$op_undo(@args);
  158.    $w->PushUndo($undo);
  159.    # We must 'do' the operation now so if this is an insert
  160.    # the text and tags are available for inspection in delete_UNDO, and
  161.    # indices reflect changes.
  162.    $w->$op(@args);
  163.    # Save the undo that will reverse what we just did - it is
  164.    # on the undo stack but will be tricky to find
  165.    push(@pvtundo,$undo);
  166.   }
  167.  
  168.  # Now shift each item off REDO array until empty
  169.  # push each item onto UNDO array - this reverses the order
  170.  # and we are not altering buffer so we cannot look in the
  171.  # buffer to compute inverses - which is why we saved them above
  172.  
  173.  while ($w->SizeRedo)
  174.   {
  175.    my $ref = $w->ShiftRedo;
  176.    $w->PushUndo($ref);
  177.   }
  178.  
  179.  # Finally undo whatever we did to compensate for doing it
  180.  # and get buffer back to state it was before we started.
  181.  while (@pvtundo)
  182.   {
  183.    my ($op,@args) = @{pop(@pvtundo)};
  184.    $w->$op(@args);
  185.   }
  186.  
  187.  $w->RestoreSelectionsMarkedSaved;
  188.  $w->OperationMode('normal');
  189.  $w->dump_array('EndShuffle');
  190. }
  191.  
  192. # sets/returns undo/redo/normal operation mode
  193. sub OperationMode
  194. {
  195.  my ($w,$mode) = @_;
  196.  $w->{'OPERATION_MODE'} = $mode  if (@_ > 1);
  197.  $w->{'OPERATION_MODE'} = 'normal' unless exists($w->{'OPERATION_MODE'});
  198.  return $w->{'OPERATION_MODE'};
  199. }
  200.  
  201. ####################################################################
  202. # dump the undo and redo stacks to the screen.
  203. # used for debug purposes.
  204. sub dump_array
  205. {
  206.  return unless $DoDebug;
  207.  my ($w,$why) = @_;
  208.  print "At $why:\n";
  209.  foreach my $key ('UNDO','REDO')
  210.   {
  211.    if (defined($w->{$key}))
  212.     {
  213.      print " $key array is:\n";
  214.      my $array = $w->{$key};
  215.      foreach my $ref (@$array)
  216.       {
  217.        my @items;
  218.        foreach my $item (@$ref)
  219.         {
  220.          my $loc = $item;
  221.          $loc =~ tr/\n/\^/;
  222.          push(@items,$loc);
  223.         }
  224.        print "  [",join(',',@items),"]\n";
  225.       }
  226.     }
  227.   }
  228.  print "\n";
  229. }
  230.  
  231.  
  232. ############################################################
  233. ############################################################
  234. # these are a group of methods used to indicate the start and end of
  235. # several operations that are to be undo/redo 'ed in a single step.
  236. #
  237. # in other words, "glob" a bunch of operations together.
  238. #
  239. # for example, a search and replace should be undone with a single
  240. # keystroke, rather than one keypress undoes the insert and another
  241. # undoes the delete.
  242. # all other methods should access the count via these methods.
  243. # no other method should directly access the {GLOB_COUNT} value directly
  244. #############################################################
  245. #############################################################
  246.  
  247. sub AddOperation
  248. {
  249.  my ($w,@operation) = @_;
  250.  my $mode = $w->OperationMode;
  251.  
  252.  if ($mode eq 'normal')
  253.   {$w->PushUndo([@operation]);}
  254.  elsif ($mode eq 'undo')
  255.   {$w->PushRedo([@operation]);}
  256.  elsif ($mode eq 'redo')
  257.   {$w->PushUndo([@operation]);}
  258.  else
  259.   {die "invalid destination '$mode', must be one of 'normal', 'undo' or 'redo'";}
  260. }
  261.  
  262. sub addGlobStart    # add it to end of undo list
  263. {
  264.  my ($w, $who) = @_;
  265.  unless (defined($who)) {$who = (caller(1))[3];}
  266.  $w->CheckForRedoShuffle;
  267.  $w->dump_array('Start'.$who);
  268.  $w->AddOperation('GlobStart', $who) ;
  269. }
  270.  
  271. sub addGlobEnd        # add it to end of undo list
  272. {
  273.  my ($w, $who) = @_;
  274.  unless (defined($who)) {$who = (caller(1))[3];}
  275.  my $topundo = $w->getUndoAtIndex(-1);
  276.  if ($topundo->[0] eq 'GlobStart')
  277.   {
  278.    $w->PopUndo;
  279.   }
  280.  else
  281.   {
  282.    my $nxtundo = $w->getUndoAtIndex(-2);
  283.    if ($nxtundo->[0] eq 'GlobStart')
  284.     {
  285.      $w->PopUndo;
  286.      $w->PopUndo;
  287.      $w->PushUndo($topundo);
  288.     }
  289.    else
  290.     {
  291.      $w->AddOperation('GlobEnd',  $who);
  292.     }
  293.   }
  294.  $w->dump_array('End'.$who);
  295. }
  296.  
  297. sub GlobStart
  298. {
  299.  my ($w, $who) = @_;
  300.  unless (defined($w->{GLOB_COUNT})) {$w->{GLOB_COUNT}=0;}
  301.  if ($w->OperationMode eq 'normal')
  302.   {
  303.    $w->PushUndo($w->GlobStart_UNDO($who));
  304.   }
  305.  $w->{GLOB_COUNT} = $w->{GLOB_COUNT} + 1;
  306. }
  307.  
  308. sub GlobStart_UNDO
  309. {
  310.  my ($w, $who) = @_;
  311.  $who = 'GlobEnd_UNDO' unless defined($who);
  312.  return ['GlobEnd',$who];
  313. }
  314.  
  315. sub GlobEnd
  316. {
  317.  my ($w, $who) = @_;
  318.  unless (defined($w->{GLOB_COUNT})) {$w->{GLOB_COUNT}=0;}
  319.  if ($w->OperationMode eq 'normal')
  320.   {
  321.    $w->PushUndo($w->GlobStart_UNDO($who));
  322.   }
  323.  $w->{GLOB_COUNT} = $w->{GLOB_COUNT} - 1;
  324. }
  325.  
  326. sub GlobEnd_UNDO
  327. {
  328.  my ($w, $who) = @_;
  329.  $who = 'GlobStart_UNDO' unless defined($who);
  330.  return ['GlobStart',$who];
  331. }
  332.  
  333. sub GlobCount
  334. {
  335.  my ($w,$count) = @_;
  336.  unless ( exists($w->{'GLOB_COUNT'}) and defined($w->{'GLOB_COUNT'}) )
  337.   {
  338.    $w->{'GLOB_COUNT'}=0;
  339.   }
  340.  if (defined($count))
  341.   {
  342.    $w->{'GLOB_COUNT'}=$count;
  343.   }
  344.  return $w->{'GLOB_COUNT'};
  345. }
  346.  
  347. ####################################################################
  348. # two methods should be used by applications to access undo and redo
  349. # capability, namely, $w->undo; and $w->redo; methods.
  350. # these methods undo and redo the last operation, respectively.
  351. ####################################################################
  352. sub undo
  353. {
  354.  my ($w) = @_;
  355.  $w->dump_array('Start'.'undo');
  356.  unless ($w->numberChanges) {$w->bell; return;} # beep and return if empty
  357.  $w->GlobCount(0); #initialize to zero
  358.  $w->OperationMode('undo');
  359.  do
  360.   {
  361.    my ($op,@args) = @{$w->PopUndo};  # get undo operation, convert ref to array
  362.    my $undo_op = $op .'_UNDO';
  363.    $w->PushRedo($w->$undo_op(@args)); # find out how to undo it
  364.    $w->$op(@args);   # do the operation
  365.   } while($w->GlobCount and $w->numberChanges);
  366.  $w->OperationMode('normal');
  367.  $w->dump_array('End'.'undo');
  368. }
  369.  
  370. sub redo
  371. {
  372.  my ($w) = @_;
  373.  unless ($w->SizeRedo) {$w->bell; return;} # beep and return if empty
  374.  $w->OperationMode('redo');
  375.  $w->GlobCount(0); #initialize to zero
  376.  do
  377.   {
  378.    my ($op,@args) = @{$w->PopRedo}; # get op from redo stack, convert to list
  379.    my $undo_op = $op .'_UNDO';
  380.    $w->PushUndo($w->$undo_op(@args)); # figure out how to undo operation
  381.    $w->$op(@args); # do the operation
  382.   } while($w->GlobCount and $w->SizeRedo);
  383.  $w->OperationMode('normal');
  384. }
  385.  
  386.  
  387. ############################################################
  388. # override low level subroutines so that they work with UNDO/REDO capability.
  389. # every overridden subroutine must also have a corresponding *_UNDO subroutine.
  390. # the *_UNDO method takes the same parameters in and returns an array reference
  391. # which is how to undo itself.
  392. # note that the *_UNDO must receive absolute indexes.
  393. # ->insert receives 'markname' as the starting index.
  394. # ->insert must convert 'markname' using $absindex=$w->index('markname')
  395. # and pass $absindex to ->insert_UNDO.
  396. ############################################################
  397.  
  398. sub insert
  399. {
  400.  my $w = shift;
  401.  $w->markSet('insert', $w->index(shift) );
  402.  while(@_)
  403.   {
  404.    my $index1 = $w->index('insert');
  405.    my $string = shift;
  406.    my $taglist_ref = shift if @_;
  407.  
  408.    if ($w->OperationMode eq 'normal')
  409.     {
  410.      $w->CheckForRedoShuffle;
  411.      $w->PushUndo($w->insert_UNDO($index1,$string,$taglist_ref));
  412.     }
  413.    $w->markSet('notepos' => $index1);
  414.    $w->SUPER::insert($index1,$string,$taglist_ref);
  415.    $w->markSet('insert', $w->index('notepos'));
  416.   }
  417. }
  418.  
  419. sub insert_UNDO
  420. {
  421.  my $w = shift;
  422.  my $index = shift;
  423.  my $string = '';
  424.  # This possible call: ->insert (index, string, tag, string, tag...);
  425.  # if more than one string, keep reading strings in (discarding tags)
  426.  # until all strings are read in and $string contains entire text inserted.
  427.  while (@_)
  428.   {
  429.    $string .= shift;
  430.    my $tags    = shift if (@_);
  431.   }
  432.  # calculate index
  433.  # possible things to insert:
  434.  # carriage return
  435.  # single character (not CR)
  436.  # single line of characters (not ending in CR)
  437.  # single line of characters ending with a CR
  438.  # multi-line characters. last line does not end with CR
  439.  # multi-line characters, last line does end with CR.
  440.  my ($line,$col) = split(/\./,$index);
  441.  if ($string =~ /\n(.*)$/)
  442.   {
  443.    $line += $string =~ tr/\n/\n/;
  444.    $col  = length($1);
  445.   }
  446.  else
  447.   {
  448.    $col += length($string);
  449.   }
  450.  return ['delete', $index, $line.'.'.$col];
  451. }
  452.  
  453. sub delete
  454. {
  455.  my ($w, $start, $stop) = @_;
  456.  unless(defined($stop))
  457.   { $stop = $start .'+1c'; }
  458.  my $index1 = $w->index($start);
  459.  my $index2 = $w->index($stop);
  460.  if ($w->OperationMode eq 'normal')
  461.   {
  462.    $w->CheckForRedoShuffle;
  463.    $w->PushUndo($w->delete_UNDO($index1,$index2));
  464.   }
  465.  $w->SUPER::delete($index1,$index2);
  466.  # why call SetCursor - it has side effects
  467.  # which cause a whole slew if save/restore hassles ?
  468.  $w->SetCursor($index1);
  469. }
  470.  
  471. sub delete_UNDO
  472. {
  473.  my ($w, $index1, $index2) = @_;
  474.  my %tags;
  475.  my @result = ( 'insert' => $index1 );
  476.  my $str   = '';
  477.  
  478.  ###############################################################
  479.  # get tags in range and return them in a format that
  480.  # can be inserted.
  481.  # $text->insert('1.0', $string1, [tag1,tag2], $string2, [tag2, tag3]);
  482.  # note, have to break tags up into sequential order
  483.  # in reference to _all_ tags.
  484.  ###############################################################
  485.  
  486.  $w->dump('-text','-tag', -command => sub {
  487.   my ($kind,$value,$posn) = @_;
  488.   if ($kind eq 'text')
  489.    {
  490.     $str .= $value;
  491.    }
  492.   else
  493.    {
  494.     push(@result,$str,[keys %tags]) if (length $str);
  495.     $str = '';
  496.     if ($kind eq 'tagon')
  497.      {
  498.       $tags{$value} = 1;
  499.      }
  500.     elsif ($kind eq 'tagoff')
  501.      {
  502.       delete $tags{$value};
  503.      }
  504.    }
  505.  }, $index1, $index2);
  506.  push(@result,$str,[keys %tags]) if (length $str);
  507.  return \@result;
  508. }
  509.  
  510. ############################################################
  511. # override subroutines which are collections of low level
  512. # routines executed in sequence.
  513. # wrap a globstart and globend around the SUPER:: version of routine.
  514. ############################################################
  515.  
  516. sub ReplaceSelectionsWith
  517. {
  518.  my $w = shift;
  519.  $w->addGlobStart;
  520.  $w->SUPER::ReplaceSelectionsWith(@_);
  521.  $w->addGlobEnd;
  522. }
  523.  
  524. sub FindAndReplaceAll
  525. {
  526.  my $w = shift;
  527.  $w->addGlobStart;
  528.  $w->SUPER::FindAndReplaceAll(@_);
  529.  $w->addGlobEnd;
  530. }
  531.  
  532. sub clipboardCut
  533. {
  534.  my $w = shift;
  535.  $w->addGlobStart;
  536.  $w->SUPER::clipboardCut(@_);
  537.  $w->addGlobEnd;
  538. }
  539.  
  540. sub clipboardPaste
  541. {
  542.  my $w = shift;
  543.  $w->addGlobStart;
  544.  $w->SUPER::clipboardPaste(@_);
  545.  $w->addGlobEnd;
  546. }
  547.  
  548. sub clipboardColumnCut
  549. {
  550.  my $w = shift;
  551.  $w->addGlobStart;
  552.  $w->SUPER::clipboardColumnCut(@_);
  553.  $w->addGlobEnd;
  554. }
  555.  
  556. sub clipboardColumnPaste
  557. {
  558.  my $w = shift;
  559.  $w->addGlobStart;
  560.  $w->SUPER::clipboardColumnPaste(@_);
  561.  $w->addGlobEnd;
  562. }
  563.  
  564. # Greg: this method is more tightly coupled to the base class
  565. # than I would prefer, but I know of no other way to do it.
  566.  
  567. sub Insert
  568. {
  569.  my ($w,$char)=@_;
  570.  return if $char eq '';
  571.  $w->addGlobStart;
  572.  $w->SUPER::Insert($char);
  573.  $w->addGlobEnd;
  574.  $w->see('insert');
  575. }
  576.  
  577.  
  578. sub InsertKeypress
  579. {
  580.  my ($w,$char)=@_;
  581.  return if $char eq '';
  582.  if ($char =~ /^\S$/ and !$w->OverstrikeMode and !$w->tagRanges('sel'))
  583.   {
  584.    my $index = $w->index('insert');
  585.    my $undo_item = $w->getUndoAtIndex(-1);
  586.    if (defined($undo_item) &&
  587.        ($undo_item->[0] eq 'delete') &&
  588.        ($undo_item->[2] == $index)
  589.       )
  590.     {
  591.      $w->SUPER::insert($index,$char);
  592.      $undo_item->[2] = $w->index('insert');
  593.      return;
  594.     }
  595.   }
  596.  $w->addGlobStart;
  597.  $w->SUPER::InsertKeypress($char);
  598.  $w->addGlobEnd;
  599. }
  600.  
  601. ############################################################
  602. sub TextUndoFileProgress
  603. {
  604.  my ($w,$action,$filename,$count,$val,$total) = @_;
  605.  return unless(defined($filename) and defined($count));
  606.  
  607.  my $popup = $w->{'FILE_PROGRESS_POP_UP'};
  608.  unless (defined($popup))
  609.   {
  610.    $w->update;
  611.    $popup = $w->Toplevel(-title => "File Progress",-popover => $w);
  612.    $popup->transient($w->toplevel);
  613.    $popup->withdraw;
  614.    $popup->resizable('no','no');
  615.    $popup->Label(-textvariable => \$popup->{ACTION})->pack;
  616.    $popup->Label(-textvariable => \$popup->{FILENAME})->pack;
  617.    $popup->Label(-textvariable => \$popup->{COUNT})->pack;
  618.    my $f = $popup->Frame(-height => 10, -border => 2, -relief => 'sunken')->pack(-fill => 'x');
  619.    my $i = $f->Frame(-background => 'blue', -relief => 'raised', -border => 2);
  620.    $w->{'FILE_PROGRESS_POP_UP'} = $popup;
  621.    $popup->{PROGBAR} = $i;
  622.   }
  623.  $popup->{ACTION}   = $action;
  624.  $popup->{COUNT}    = "lines: $count";
  625.  $popup->{FILENAME} = "Filename: $filename";
  626.  if (defined($val) && defined($total) && $total != 0)
  627.   {
  628.    $popup->{PROGBAR}->place('-x' => 0, '-y' => 0, -relheight => 1, -relwidth => $val/$total);
  629.   }
  630.  else
  631.   {
  632.    $popup->{PROGBAR}->placeForget;
  633.   }
  634.  
  635.  $popup->idletasks;
  636.  unless ($popup->viewable)
  637.   {
  638.    $w->idletasks;
  639.    $w->toplevel->deiconify unless $w->viewable;
  640.    $popup->Popup;
  641.   }
  642.  $popup->update;
  643.  return $popup;
  644. }
  645.  
  646. sub FileName
  647. {
  648.  my ($w,$filename) = @_;
  649.  if (@_ > 1)
  650.   {
  651.    $w->{'FILENAME'}=$filename;
  652.   }
  653.  return $w->{'FILENAME'};
  654. }
  655.  
  656. sub PerlIO_layers
  657. {
  658.  my ($w,$layers) = @_;
  659.  $w->{PERLIO_LAYERS} = $layers if @_ > 1;
  660.  return $w->{PERLIO_LAYERS} || '' ;
  661. }
  662.  
  663. sub ConfirmDiscard
  664. {
  665.  my ($w)=@_;
  666.  if ($w->numberChanges)
  667.   {
  668.    my $ans = $w->messageBox(-icon    => 'warning',
  669.                             -type => 'YesNoCancel', -default => 'Yes',
  670.                             -message =>
  671. "The text has been modified without being saved.
  672. Save edits?");
  673.    return 0 if $ans eq 'Cancel';
  674.    return 0 if ($ans eq 'Yes' && !$w->Save);
  675.   }
  676.  return 1;
  677. }
  678.  
  679. ################################################################################
  680. # if the file has been modified since being saved, a pop up window will be
  681. # created, asking the user to confirm whether or not to exit.
  682. # this allows the user to return to the application and save the file.
  683. # the code would look something like this:
  684. #
  685. # if ($w->user_wants_to_exit)
  686. #  {$w->ConfirmExit;}
  687. #
  688. # it is also possible to trap attempts to delete the main window.
  689. # this allows the ->ConfirmExit method to be called when the main window
  690. # is attempted to be deleted.
  691. #
  692. # $mw->protocol('WM_DELETE_WINDOW'=>
  693. #  sub{$w->ConfirmExit;});
  694. #
  695. # finally, it might be desirable to trap Control-C signals at the
  696. # application level so that ->ConfirmExit is also called.
  697. #
  698. # $SIG{INT}= sub{$w->ConfirmExit;};
  699. #
  700. ################################################################################
  701.  
  702. sub ConfirmExit
  703. {
  704.  my ($w) = @_;
  705.  $w->toplevel->destroy if $w->ConfirmDiscard;
  706. }
  707.  
  708. sub Save
  709. {
  710.  my ($w,$filename) = @_;
  711.  $filename = $w->FileName unless defined $filename;
  712.  return $w->FileSaveAsPopup unless defined $filename;
  713.  my $layers = $w->PerlIO_layers;
  714.  if (open(my $file,">$layers",$filename))
  715.   {
  716.    my $status;
  717.    my $count=0;
  718.    my $index = '1.0';
  719.    my $progress;
  720.    my ($lines) = $w->index('end - 1 chars') =~ /^(\d+)\./;
  721.    while ($w->compare($index,'<','end'))
  722.     {
  723. #    my $end = $w->index("$index + 1024 chars");
  724.      my $end = $w->index("$index  lineend +1c");
  725.      print $file $w->get($index,$end);
  726.      $index = $end;
  727.      if (($count++%1000) == 0)
  728.       {
  729.        $progress = $w->TextUndoFileProgress (Saving => $filename,$count,$count,$lines);
  730.       }
  731.     }
  732.    $progress->withdraw if defined $progress;
  733.    if (close($file))
  734.     {
  735.      $w->ResetUndo;
  736.      $w->FileName($filename);
  737.      return 1;
  738.     }
  739.   }
  740.  else
  741.   {
  742.    $w->BackTrace("Cannot open $filename:$!");
  743.   }
  744.  return 0;
  745. }
  746.  
  747. sub Load
  748. {
  749.  my ($w,$filename) = @_;
  750.  $filename = $w->FileName unless (defined($filename));
  751.  return 0 unless defined $filename;
  752.  my $layers = $w->PerlIO_layers;
  753.  if (open(my $file,"<$layers",$filename))
  754.   {
  755.    $w->MainWindow->Busy;
  756.    $w->EmptyDocument;
  757.    my $count=1;
  758.    my $progress;
  759.    while (<$file>)
  760.     {
  761.      $w->SUPER::insert('end',$_);
  762.      if (($count++%1000) == 0)
  763.       {
  764.        $progress = $w->TextUndoFileProgress (Loading => $filename,
  765.                          $count,tell($file),-s $filename);
  766.       }
  767.     }
  768.    close($file);
  769.    $progress->withdraw if defined $progress;
  770.    $w->markSet('insert' => '1.0');
  771.    $w->FileName($filename);
  772.    $w->MainWindow->Unbusy;
  773.   }
  774.  else
  775.   {
  776.    $w->BackTrace("Cannot open $filename:$!");
  777.   }
  778. }
  779.  
  780. sub IncludeFile
  781. {
  782.  my ($w,$filename) = @_;
  783.  unless (defined($filename))
  784.   {$w->BackTrace("filename not specified"); return;}
  785.  my $layers = $w->PerlIO_layers;
  786.  if (open(my $file,"<$layers",$filename))
  787.   {
  788.    $w->Busy;
  789.    my $count=1;
  790.    $w->addGlobStart;
  791.    my $progress;
  792.    while (<$file>)
  793.     {
  794.      $w->insert('insert',$_);
  795.      if (($count++%1000) == 0)
  796.       {
  797.        $progress = $w->TextUndoFileProgress(Including => $filename,
  798.                         $count,tell($file),-s $filename);
  799.       }
  800.     }
  801.    $progress->withdraw if defined $progress;
  802.    $w->addGlobEnd;
  803.    close($file);
  804.    $w->Unbusy;
  805.   }
  806.  else
  807.   {
  808.    $w->BackTrace("Cannot open $filename:$!");
  809.   }
  810. }
  811.  
  812. # clear document without pushing it into UNDO array, (use SUPER::delete)
  813. # (using plain delete(1.0,end) on a really big document fills up the undo array)
  814. # and then clear the Undo and Redo stacks.
  815. sub EmptyDocument
  816. {
  817.  my ($w) = @_;
  818.  $w->SUPER::delete('1.0','end');
  819.  $w->ResetUndo;
  820.  $w->FileName(undef);
  821. }
  822.  
  823. sub ConfirmEmptyDocument
  824. {
  825.  my ($w)=@_;
  826.  $w->EmptyDocument if $w->ConfirmDiscard;
  827. }
  828.  
  829. sub FileMenuItems
  830. {
  831.  my ($w) = @_;
  832.  return [
  833.    ["command"=>'~Open',    -command => [$w => 'FileLoadPopup']],
  834.    ["command"=>'~Save',    -command => [$w => 'Save' ]],
  835.    ["command"=>'Save ~As', -command => [$w => 'FileSaveAsPopup']],
  836.    ["command"=>'~Include', -command => [$w => 'IncludeFilePopup']],
  837.    ["command"=>'~Clear',   -command => [$w => 'ConfirmEmptyDocument']],
  838.    "-",@{$w->SUPER::FileMenuItems}
  839.   ]
  840. }
  841.  
  842. sub EditMenuItems
  843. {
  844.  my ($w) = @_;
  845.  
  846.  return [
  847.     ["command"=>'Undo', -command => [$w => 'undo']],
  848.     ["command"=>'Redo', -command => [$w => 'redo']],
  849.      "-",@{$w->SUPER::EditMenuItems}
  850.   ];
  851. }
  852.  
  853. sub CreateFileSelect
  854. {
  855.  my $w = shift;
  856.  my $k = shift;
  857.  my $name = $w->FileName;
  858.  my @types = (['All Files', '*']);
  859.  my $dir   = undef;
  860.  if (defined $name)
  861.   {
  862.    require File::Basename;
  863.    my $sfx;
  864.    ($name,$dir,$sfx) = File::Basename::fileparse($name,'\..*');
  865.    #
  866.    # it should never happen where we have a file suffix and
  867.    # no file name... but fileparse() screws this up with dotfiles.
  868.    #
  869.    if (length($sfx) && !length($name)) { ($name, $sfx) = ($sfx, $name) }
  870.  
  871.    if (defined($sfx) && length($sfx))
  872.     {
  873.      unshift(@types,['Similar Files',[$sfx]]);
  874.      $name .= $sfx;
  875.     }
  876.   }
  877.  return $w->$k(-initialdir  => $dir, -initialfile => $name,
  878.                -filetypes => \@types, @_);
  879. }
  880.  
  881. sub FileLoadPopup
  882. {
  883.  my ($w)=@_;
  884.  my $name = $w->CreateFileSelect('getOpenFile',-title => 'File Load');
  885.  return $w->Load($name) if defined($name) and length($name);
  886.  return 0;
  887. }
  888.  
  889. sub IncludeFilePopup
  890. {
  891.  my ($w)=@_;
  892.  my $name = $w->CreateFileSelect('getOpenFile',-title => 'File Include');
  893.  return $w->IncludeFile($name) if defined($name) and length($name);
  894.  return 0;
  895. }
  896.  
  897. sub FileSaveAsPopup
  898. {
  899.  my ($w)=@_;
  900.  my $name = $w->CreateFileSelect('getSaveFile',-title => 'File Save As');
  901.  return $w->Save($name) if defined($name) and length($name);
  902.  return 0;
  903. }
  904.  
  905.  
  906. sub MarkSelectionsSavePositions
  907. {
  908.  my ($w)=@_;
  909.  $w->markSet('MarkInsertSavePosition','insert');
  910.  my @ranges = $w->tagRanges('sel');
  911.  my $i = 0;
  912.  while (@ranges)
  913.   {
  914.    my ($start,$end) = splice(@ranges,0,2);
  915.    $w->markSet( 'MarkSelectionsSavePositions_'.++$i, $start);
  916.    $w->markSet( 'MarkSelectionsSavePositions_'.++$i, $end);
  917.    $w->tagRemove('sel',$start,$end);
  918.   }
  919. }
  920.  
  921. sub RestoreSelectionsMarkedSaved
  922. {
  923.  my ($w)=@_;
  924.  my $i = 1;
  925.  my %mark_hash;
  926.  foreach my $mark ($w->markNames)
  927.   {
  928.    $mark_hash{$mark}=1;
  929.   }
  930.  while(1)
  931.   {
  932.    my $markstart = 'MarkSelectionsSavePositions_'.$i++;
  933.    last unless(exists($mark_hash{$markstart}));
  934.    my $indexstart = $w->index($markstart);
  935.    my $markend = 'MarkSelectionsSavePositions_'.$i++;
  936.    last unless(exists($mark_hash{$markend}));
  937.    my $indexend = $w->index($markend);
  938.    $w->tagAdd('sel',$indexstart, $indexend);
  939.    $w->markUnset($markstart, $markend);
  940.   }
  941.  $w->markSet('insert','MarkInsertSavePosition');
  942. }
  943.  
  944. ####################################################################
  945. # selected lines may be discontinous sequence.
  946. sub GetMarkedSelectedLineNumbers
  947. {
  948.  my ($w) = @_;
  949.  
  950.  my $i = 1;
  951.  my %mark_hash;
  952.  my @ranges;
  953.  foreach my $mark ($w->markNames)
  954.   {
  955.    $mark_hash{$mark}=1;
  956.   }
  957.  
  958.  while(1)
  959.   {
  960.    my $markstart = 'MarkSelectionsSavePositions_'.$i++;
  961.    last unless(exists($mark_hash{$markstart}));
  962.    my $indexstart = $w->index($markstart);
  963.    my $markend = 'MarkSelectionsSavePositions_'.$i++;
  964.    last unless(exists($mark_hash{$markend}));
  965.    my $indexend = $w->index($markend);
  966.  
  967.    push(@ranges, $indexstart, $indexend);
  968.   }
  969.  
  970.  my @selection_list;
  971.  while (@ranges)
  972.   {
  973.    my ($first) = split(/\./,shift(@ranges));
  974.    my ($last) = split(/\./,shift(@ranges));
  975.    # if previous selection ended on the same line that this selection starts,
  976.    # then fiddle the numbers so that this line number isnt included twice.
  977.    if (defined($selection_list[-1]) and ($first == $selection_list[-1]))
  978.     {
  979.      # if this selection ends on the same line its starts, then skip this sel
  980.      next if ($first == $last);
  981.      $first++; # count this selection starting from the next line.
  982.     }
  983.    push(@selection_list, $first .. $last);
  984.   }
  985.  return @selection_list;
  986. }
  987.  
  988. sub insertStringAtStartOfSelectedLines
  989. {
  990.  my ($w,$insert_string)=@_;
  991.  $w->addGlobStart;
  992.  $w->MarkSelectionsSavePositions;
  993.  foreach my $line ($w->GetMarkedSelectedLineNumbers)
  994.   {
  995.    $w->insert($line.'.0', $insert_string);
  996.   }
  997.  $w->RestoreSelectionsMarkedSaved;
  998.  $w->addGlobEnd;
  999. }
  1000.  
  1001. sub deleteStringAtStartOfSelectedLines
  1002. {
  1003.  my ($w,$insert_string)=@_;
  1004.  $w->addGlobStart;
  1005.  $w->MarkSelectionsSavePositions;
  1006.  my $length = length($insert_string);
  1007.  foreach my $line ($w->GetMarkedSelectedLineNumbers)
  1008.   {
  1009.    my $start = $line.'.0';
  1010.    my $end   = $line.'.'.$length;
  1011.    my $current_text = $w->get($start, $end);
  1012.    next unless ($current_text eq $insert_string);
  1013.    $w->delete($start, $end);
  1014.   }
  1015.  $w->RestoreSelectionsMarkedSaved;
  1016.  $w->addGlobEnd;
  1017. }
  1018.  
  1019.  
  1020. 1;
  1021. __END__
  1022.  
  1023.