home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2004 July / APC0407D2.iso / workshop / apache / files / ActivePerl-5.6.1.638-MSWin32-x86.msi / _b3567548d47b19ce6f73c9bba480fb91 < prev    next >
Encoding:
Text File  |  2004-04-13  |  24.9 KB  |  992 lines
  1. # Copyright (c) 1995-1999 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 = '3.050'; # $Id: //depot/Tk8/Tk/TextUndo.pm#50 $
  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. }
  575.  
  576.  
  577. sub InsertKeypress
  578. {
  579.  my ($w,$char)=@_;
  580.  return if $char eq '';
  581.  if ($char =~ /^\S$/ and !$w->OverstrikeMode and !$w->tagRanges('sel'))
  582.   {
  583.    my $index = $w->index('insert');
  584.    my $undo_item = $w->getUndoAtIndex(-1);
  585.    if (defined($undo_item) &&
  586.        ($undo_item->[0] eq 'delete') &&
  587.        ($undo_item->[2] == $index)
  588.       )
  589.     {
  590.      $w->SUPER::insert($index,$char);
  591.      $undo_item->[2] = $w->index('insert');
  592.      return;
  593.     }
  594.   }
  595.  $w->addGlobStart;
  596.  $w->SUPER::InsertKeypress($char);
  597.  $w->addGlobEnd;
  598. }
  599.  
  600. ############################################################
  601. sub TextUndoFileProgress
  602. {
  603.  my ($w,$action,$filename,$count,$val,$total) = @_;
  604.  return unless(defined($filename) and defined($count));
  605.  
  606.  my $popup = $w->{'FILE_PROGRESS_POP_UP'};
  607.  unless (defined($popup))
  608.   {
  609.    $w->update;
  610.    $popup = $w->Toplevel(-title => "File Progress",-popover => $w);
  611.    $popup->transient($w->toplevel);
  612.    $popup->withdraw;
  613.    $popup->resizable('no','no');
  614.    $popup->Label(-textvariable => \$popup->{ACTION})->pack;
  615.    $popup->Label(-textvariable => \$popup->{FILENAME})->pack;
  616.    $popup->Label(-textvariable => \$popup->{COUNT})->pack;
  617.    my $f = $popup->Frame(-height => 10, -border => 2, -relief => 'sunken')->pack(-fill => 'x');
  618.    my $i = $f->Frame(-background => 'blue', -relief => 'raised', -border => 2);
  619.    $w->{'FILE_PROGRESS_POP_UP'} = $popup;
  620.    $popup->{PROGBAR} = $i;
  621.   }
  622.  $popup->{ACTION}   = $action;
  623.  $popup->{COUNT}    = "lines: $count";
  624.  $popup->{FILENAME} = "Filename: $filename";
  625.  if (defined($val) && defined($total) && $total != 0)
  626.   {
  627.    $popup->{PROGBAR}->place('-x' => 0, '-y' => 0, -relheight => 1, -relwidth => $val/$total);
  628.   }
  629.  else
  630.   {
  631.    $popup->{PROGBAR}->placeForget;
  632.   }
  633.  
  634.  $popup->idletasks;
  635.  unless ($popup->viewable)
  636.   {
  637.    $w->idletasks;
  638.    $w->toplevel->deiconify unless $w->viewable;
  639.    $popup->Popup;
  640.   }
  641.  $popup->update;
  642.  return $popup;
  643. }
  644.  
  645. sub FileName
  646. {
  647.  my ($w,$filename) = @_;
  648.  if (@_ > 1)
  649.   {
  650.    $w->{'FILENAME'}=$filename;
  651.   }
  652.  return $w->{'FILENAME'};
  653. }
  654.  
  655. sub ConfirmDiscard
  656. {
  657.  my ($w)=@_;
  658.  if ($w->numberChanges)
  659.   {
  660.    my $ans = $w->messageBox(-icon    => 'warning',
  661.                             -type => 'YesNoCancel', -default => 'Yes',
  662.                             -message =>
  663. "The text has been modified without being saved.
  664. Save edits?");
  665.    return 0 if $ans eq 'Cancel';
  666.    return 0 if ($ans eq 'Yes' && !$w->Save);
  667.   }
  668.  return 1;
  669. }
  670.  
  671. ################################################################################
  672. # if the file has been modified since being saved, a pop up window will be
  673. # created, asking the user to confirm whether or not to exit.
  674. # this allows the user to return to the application and save the file.
  675. # the code would look something like this:
  676. #
  677. # if ($w->user_wants_to_exit)
  678. #  {$w->ConfirmExit;}
  679. #
  680. # it is also possible to trap attempts to delete the main window.
  681. # this allows the ->ConfirmExit method to be called when the main window
  682. # is attempted to be deleted.
  683. #
  684. # $mw->protocol('WM_DELETE_WINDOW'=>
  685. #  sub{$w->ConfirmExit;});
  686. #
  687. # finally, it might be desirable to trap Control-C signals at the
  688. # application level so that ->ConfirmExit is also called.
  689. #
  690. # $SIG{INT}= sub{$w->ConfirmExit;};
  691. #
  692. ################################################################################
  693.  
  694. sub ConfirmExit
  695. {
  696.  my ($w) = @_;
  697.  $w->toplevel->destroy if $w->ConfirmDiscard;
  698. }
  699.  
  700. sub Save
  701. {
  702.  my ($w,$filename) = @_;
  703.  $filename = $w->FileName unless defined $filename;
  704.  return $w->FileSaveAsPopup unless defined $filename;
  705.  local *FILE;
  706.  if (open(FILE,">$filename"))
  707.   {
  708.    my $status;
  709.    my $count=0;
  710.    my $index = '1.0';
  711.    my $progress;
  712.    my ($lines) = $w->index('end') =~ /^(\d+)\./;
  713.    while ($w->compare($index,'<','end'))
  714.     {
  715. #    my $end = $w->index("$index + 1024 chars");
  716.      my $end = $w->index("$index  lineend +1c");
  717.      print FILE $w->get($index,$end);
  718.      $index = $end;
  719.      if (($count++%1000) == 0)
  720.       {
  721.        $progress = $w->TextUndoFileProgress (Saving => $filename,$count,$count,$lines);
  722.       }
  723.     }
  724.    $progress->withdraw if defined $progress;
  725.    if (close(FILE))
  726.     {
  727.      $w->ResetUndo;
  728.      $w->FileName($filename);
  729.      return 1;
  730.     }
  731.   }
  732.  else
  733.   {
  734.    $w->BackTrace("Cannot open $filename:$!");
  735.   }
  736.  return 0;
  737. }
  738.  
  739. sub Load
  740. {
  741.  my ($w,$filename) = @_;
  742.  $filename = $w->FileName unless (defined($filename));
  743.  return 0 unless defined $filename;
  744.  local *FILE;
  745.  if (open(FILE,"<$filename"))
  746.   {
  747.    $w->MainWindow->Busy;
  748.    $w->EmptyDocument;
  749.    my $count=1;
  750.    my $progress;
  751.    while (<FILE>)
  752.     {
  753.      $w->SUPER::insert('end',$_);
  754.      if (($count++%1000) == 0)
  755.       {
  756.        $progress = $w->TextUndoFileProgress (Loading => $filename,$count,tell(FILE),-s $filename);
  757.       }
  758.     }
  759.    close(FILE);
  760.    $progress->withdraw if defined $progress;
  761.    $w->markSet('insert' => '1.0');
  762.    $w->FileName($filename);
  763.    $w->MainWindow->Unbusy;
  764.   }
  765.  else
  766.   {
  767.    $w->BackTrace("Cannot open $filename:$!");
  768.   }
  769. }
  770.  
  771. sub IncludeFile
  772. {
  773.  my ($w,$filename) = @_;
  774.  unless (defined($filename))
  775.   {$w->BackTrace("filename not specified"); return;}
  776.  if (open(FILE,"<$filename"))
  777.   {
  778.    $w->Busy;
  779.    my $count=1;
  780.    $w->addGlobStart;
  781.    my $progress;
  782.    while (<FILE>)
  783.     {
  784.      $w->insert('insert',$_);
  785.      if (($count++%1000) == 0)
  786.       {
  787.        $progress = $w->TextUndoFileProgress(Including => $filename,$count,tell(FILE),-s $filename);
  788.       }
  789.     }
  790.    $progress->withdraw if defined $progress;
  791.    $w->addGlobEnd;
  792.    close(FILE);
  793.    $w->Unbusy;
  794.   }
  795.  else
  796.   {
  797.    $w->BackTrace("Cannot open $filename:$!");
  798.   }
  799. }
  800.  
  801. # clear document without pushing it into UNDO array, (use SUPER::delete)
  802. # (using plain delete(1.0,end) on a really big document fills up the undo array)
  803. # and then clear the Undo and Redo stacks.
  804. sub EmptyDocument
  805. {
  806.  my ($w) = @_;
  807.  $w->SUPER::delete('1.0','end');
  808.  $w->ResetUndo;
  809.  $w->FileName(undef);
  810. }
  811.  
  812. sub ConfirmEmptyDocument
  813. {
  814.  my ($w)=@_;
  815.  $w->EmptyDocument if $w->ConfirmDiscard;
  816. }
  817.  
  818. sub FileMenuItems
  819. {
  820.  my ($w) = @_;
  821.  return [
  822.    ["command"=>'~Open',    -command => [$w => 'FileLoadPopup']],
  823.    ["command"=>'~Save',    -command => [$w => 'Save' ]],
  824.    ["command"=>'Save ~As', -command => [$w => 'FileSaveAsPopup']],
  825.    ["command"=>'~Include', -command => [$w => 'IncludeFilePopup']],
  826.    ["command"=>'~Clear',   -command => [$w => 'ConfirmEmptyDocument']],
  827.    "-",@{$w->SUPER::FileMenuItems}
  828.   ]
  829. }
  830.  
  831. sub EditMenuItems
  832. {
  833.  my ($w) = @_;
  834.  
  835.  return [
  836.     ["command"=>'Undo', -command => [$w => 'undo']],
  837.     ["command"=>'Redo', -command => [$w => 'redo']],
  838.      "-",@{$w->SUPER::EditMenuItems}
  839.   ];
  840. }
  841.  
  842. sub CreateFileSelect
  843. {
  844.  my $w = shift;
  845.  my $k = shift;
  846.  my $name = $w->FileName;
  847.  my @types = (['All Files', '*']);
  848.  my $dir   = undef;
  849.  if (defined $name)
  850.   {
  851.    require File::Basename;
  852.    my $sfx;
  853.    ($name,$dir,$sfx) = File::Basename::fileparse($name,'\..*');
  854.    #
  855.    # it should never happen where we have a file suffix and
  856.    # no file name... but fileparse() screws this up with dotfiles.
  857.    #
  858.    if (length($sfx) && !length($name)) { ($name, $sfx) = ($sfx, $name) }
  859.  
  860.    if (defined($sfx) && length($sfx))
  861.     {
  862.      unshift(@types,['Similar Files',[$sfx]]);
  863.      $name .= $sfx;
  864.     }
  865.   }
  866.  return $w->$k(-initialdir  => $dir, -initialfile => $name,
  867.                -filetypes => \@types, @_);
  868. }
  869.  
  870. sub FileLoadPopup
  871. {
  872.  my ($w)=@_;
  873.  my $name = $w->CreateFileSelect('getOpenFile',-title => 'File Load');
  874.  return $w->Load($name) if defined($name) and length($name);
  875.  return 0;
  876. }
  877.  
  878. sub IncludeFilePopup
  879. {
  880.  my ($w)=@_;
  881.  my $name = $w->CreateFileSelect('getOpenFile',-title => 'File Include');
  882.  return $w->IncludeFile($name) if defined($name) and length($name);
  883.  return 0;
  884. }
  885.  
  886. sub FileSaveAsPopup
  887. {
  888.  my ($w)=@_;
  889.  my $name = $w->CreateFileSelect('getSaveFile',-title => 'File Save As');
  890.  return $w->Save($name) if defined($name) and length($name);
  891.  return 0;
  892. }
  893.  
  894.  
  895. sub MarkSelectionsSavePositions
  896. {
  897.  my ($w)=@_;
  898.  $w->markSet('MarkInsertSavePosition','insert');
  899.  my @ranges = $w->tagRanges('sel');
  900.  my $i = 0;
  901.  while (@ranges)
  902.   {
  903.    my ($start,$end) = splice(@ranges,0,2);
  904.    $w->markSet( 'MarkSelectionsSavePositions_'.++$i, $start);
  905.    $w->markSet( 'MarkSelectionsSavePositions_'.++$i, $end);
  906.    $w->tagRemove('sel',$start,$end);
  907.   }
  908. }
  909.  
  910. sub RestoreSelectionsMarkedSaved
  911. {
  912.  my ($w)=@_;
  913.  my $i = 0;
  914.  my %mark_hash;
  915.  foreach my $mark ($w->markNames)
  916.   {
  917.    $mark_hash{$mark}=1;
  918.   }
  919.  while(1)
  920.   {
  921.    my $markstart = 'MarkSelectionsSavePositions_'.$i++;
  922.    last unless(exists($mark_hash{$markstart}));
  923.    my $indexstart = $w->index($markstart);
  924.    my $markend = 'MarkSelectionsSavePositions_'.$i++;
  925.    last unless(exists($mark_hash{$markend}));
  926.    my $indexend = $w->index($markend);
  927.    $w->tagAdd('sel',$indexstart, $indexend);
  928.    $w->markUnset($markstart, $markend);
  929.   }
  930.  $w->markSet('insert','MarkInsertSavePosition');
  931. }
  932.  
  933. ####################################################################
  934. # selected lines may be discontinous sequence.
  935. sub SelectedLineNumbers
  936. {
  937.  my ($w) = @_;
  938.  my @ranges = $w->tagRanges('sel');
  939.  my @selection_list;
  940.  while (@ranges)
  941.   {
  942.    my ($first) = split(/\./,shift(@ranges));
  943.    my ($last) = split(/\./,shift(@ranges));
  944.    # if previous selection ended on the same line that this selection starts,
  945.    # then fiddle the numbers so that this line number isnt included twice.
  946.    if (defined($selection_list[-1]) and ($first == $selection_list[-1]))
  947.     {
  948.      # if this selection ends on the same line its starts, then skip this sel
  949.      next if ($first == $last);
  950.      $first++; # count this selection starting from the next line.
  951.     }
  952.    push(@selection_list, $first .. $last);
  953.   }
  954.  return @selection_list;
  955. }
  956.  
  957. sub insertStringAtStartOfSelectedLines
  958. {
  959.  my ($w,$insert_string)=@_;
  960.  $w->addGlobStart;
  961.  $w->MarkSelectionsSavePositions;
  962.  foreach my $line ($w->SelectedLineNumbers)
  963.   {
  964.    $w->insert($line.'.0', $insert_string);
  965.   }
  966.  $w->RestoreSelectionsMarkedSaved;
  967.  $w->addGlobEnd;
  968. }
  969.  
  970. sub deleteStringAtStartOfSelectedLines
  971. {
  972.  my ($w,$insert_string)=@_;
  973.  $w->addGlobStart;
  974.  $w->MarkSelectionsSavePositions;
  975.  my $length = length($insert_string);
  976.  foreach my $line ($w->SelectedLineNumbers)
  977.   {
  978.    my $start = $line.'.0';
  979.    my $end   = $line.'.'.$length;
  980.    my $current_text = $w->get($start, $end);
  981.    next unless ($current_text eq $insert_string);
  982.    $w->delete($start, $end);
  983.   }
  984.  $w->RestoreSelectionsMarkedSaved;
  985.  $w->addGlobEnd;
  986. }
  987.  
  988.  
  989. 1;
  990. __END__
  991.  
  992.