summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/TextEdit.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/TextEdit.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/TextEdit.pm509
1 files changed, 0 insertions, 509 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/TextEdit.pm b/Master/tlpkg/tlperl/lib/Tk/TextEdit.pm
deleted file mode 100644
index e1ff20b6149..00000000000
--- a/Master/tlpkg/tlperl/lib/Tk/TextEdit.pm
+++ /dev/null
@@ -1,509 +0,0 @@
-# Copyright (c) 1999 Greg Bartels. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-# Special thanks to Nick Ing-Simmons for pushing a lot of
-# my text edit functionality into Text.pm and TextUndo.pm
-# otherwise, this module would have been monstrous.
-
-# Andy Worhal had it wrong, its "fifteen megabytes of fame"
-# -Greg Bartels
-
-package Tk::TextEdit;
-
-
-use vars qw($VERSION);
-$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/TextEdit.pm#4 $
-
-use Tk qw (Ev);
-use AutoLoader;
-
-use Text::Tabs;
-
-use base qw(Tk::TextUndo);
-
-Construct Tk::Widget 'TextEdit';
-
-#######################################################################
-#######################################################################
-sub ClassInit
-{
- my ($class,$mw) = @_;
- $class->SUPER::ClassInit($mw);
-
- $mw->bind($class,'<F5>', 'IndentSelectedLines');
- $mw->bind($class,'<F6>', 'UnindentSelectedLines');
-
- $mw->bind($class,'<F7>', 'CommentSelectedLines');
- $mw->bind($class,'<F8>', 'UncommentSelectedLines');
-
- return $class;
-}
-
-# 8 horizontal pixels in the "space" character in default font.
-my $tab_multiplier = 8;
-
-sub debug_code_f1
-{
- my $w=shift;
-}
-
-sub debug_code_f2
-{
- my $w=shift;
-}
-
-#######################################################################
-#######################################################################
-sub InitObject
-{
- my ($w) = @_;
- $w->SUPER::InitObject;
-
- $w->{'INDENT_STRING'} = "\t"; # Greg mode=>"\t", Nick mode=>" "
- $w->{'LINE_COMMENT_STRING'} = "#"; # assuming perl comments
-
- my %pair_descriptor_hash =
- (
- 'PARENS' => [ 'multiline', '(', ')', "[()]" ],
- 'CURLIES' => [ 'multiline', '{', '}', "[{}]" ],
- 'BRACES' => [ 'multiline', '[', ']', "[][]" ],
- 'DOUBLEQUOTE' => [ 'singleline', "\"","\"" ],
- 'SINGLEQUOTE' => [ 'singleline', "'","'" ],
- );
-
- $w->{'HIGHLIGHT_PAIR_DESCRIPTOR_HASH_REF'}=\%pair_descriptor_hash;
-
- $w->tagConfigure
- ('CURSOR_HIGHLIGHT_PARENS', -foreground=>'white', -background=>'violet');
- $w->tagConfigure
- ('CURSOR_HIGHLIGHT_CURLIES', -foreground=>'white', -background=>'blue');
- $w->tagConfigure
- ('CURSOR_HIGHLIGHT_BRACES', -foreground=>'white', -background=>'purple');
- $w->tagConfigure
- ('CURSOR_HIGHLIGHT_DOUBLEQUOTE', -foreground=>'black', -background=>'green');
- $w->tagConfigure
- ('CURSOR_HIGHLIGHT_SINGLEQUOTE', -foreground=>'black', -background=>'grey');
-
- $w->tagConfigure('BLOCK_HIGHLIGHT_PARENS', -background=>'red');
- $w->tagConfigure('BLOCK_HIGHLIGHT_CURLIES', -background=>'orange');
- $w->tagConfigure('BLOCK_HIGHLIGHT_BRACES', -background=>'red');
- $w->tagConfigure('BLOCK_HIGHLIGHT_DOUBLEQUOTE', -background=>'red');
- $w->tagConfigure('BLOCK_HIGHLIGHT_SINGLEQUOTE', -background=>'red');
-
- $w->tagRaise('BLOCK_HIGHLIGHT_PARENS','CURSOR_HIGHLIGHT_PARENS');
- $w->tagRaise('BLOCK_HIGHLIGHT_CURLIES','CURSOR_HIGHLIGHT_CURLIES');
- $w->tagRaise('BLOCK_HIGHLIGHT_BRACES','CURSOR_HIGHLIGHT_BRACES');
- $w->tagRaise('BLOCK_HIGHLIGHT_DOUBLEQUOTE','CURSOR_HIGHLIGHT_DOUBLEQUOTE');
- $w->tagRaise('BLOCK_HIGHLIGHT_SINGLEQUOTE','CURSOR_HIGHLIGHT_SINGLEQUOTE');
-
- $w->{'UPDATE_WIDGET_PERIOD'}=300; # how much time between each call.
- $w->{'WINDOW_PLUS_AND_MINUS_VALUE'}=80;
- $w->SetGUICallbackIndex(0);
- $w->schedule_next_callback;
-
-}
-
-#######################################################################
-
-sub cancel_current_gui_callback_and_restart_from_beginning
-{
- my ($w)=@_;
- if(defined($w->{'UPDATE_WIDGET_AFTER_REFERENCE'}))
- {$w->{'UPDATE_WIDGET_AFTER_REFERENCE'}->cancel();}
- $w->SetGUICallbackIndex(0);
-
- $w->schedule_next_callback;
-}
-
-sub schedule_next_callback
-{
- my ($w)=@_;
- return if $w->NoMoreGUICallbacksToCall; #stops infinite recursive call.
- $w->{'UPDATE_WIDGET_AFTER_REFERENCE'} = $w->after
- ($w->{'UPDATE_WIDGET_PERIOD'},
- sub
- {
- $w->CallNextGUICallback;
- $w->schedule_next_callback;
- }
- );
-
-}
-
-
-#######################################################################
-# use these methods to pass the TextEdit widget an anonymous array
-# of code references.
-# any time the widget changes that requires the display to be updated,
-# then these code references will be scheduled in sequence for calling.
-# splitting them up allows them to be prioritized by order,
-# and prevents the widget from "freezing" too long if they were
-# one large callback. scheduling them apart allows the widget time
-# to respond to user inputs.
-#######################################################################
-sub SetGUICallbacks
-{
- my ($w,$callback_array_ref) = @_;
- $w->{GUI_CALLBACK_ARRAY_REF}=$callback_array_ref;
- $w->SetGUICallbackIndex(0);
-}
-
-sub GetGUICallbacks
-{
- return shift->{GUI_CALLBACK_ARRAY_REF};
-}
-
-sub SetGUICallbackIndex
-{
- my ($w, $val)=@_;
- $w->{GUI_CALLBACK_ARRAY_INDEX}=$val;
-}
-
-sub GetGUICallbackIndex
-{
- return shift->{GUI_CALLBACK_ARRAY_INDEX};
-}
-
-sub IncrementGUICallbackIndex
-{
- shift->{GUI_CALLBACK_ARRAY_INDEX} += 1;
-}
-
-sub NoMoreGUICallbacksToCall
-{
- my ($w) = @_;
- return 0 unless defined ($w->{GUI_CALLBACK_ARRAY_REF});
- return 0 unless defined ($w->{GUI_CALLBACK_ARRAY_INDEX});
- my $arr_ref = $w->{GUI_CALLBACK_ARRAY_REF};
- my $arr_ind = $w->{GUI_CALLBACK_ARRAY_INDEX};
- return $arr_ind >= @$arr_ref;
-}
-
-sub CallNextGUICallback
-{
- my ($w) = @_;
- return if $w->NoMoreGUICallbacksToCall;
- my $arr_ref = $w->{GUI_CALLBACK_ARRAY_REF};
- my $arr_ind = $w->{GUI_CALLBACK_ARRAY_INDEX};
- &{$arr_ref->[$arr_ind]};
- $w->IncrementGUICallbackIndex;
-}
-
-
-#######################################################################
-#######################################################################
-
-sub insert
-{
- my $w = shift;
- $w->SUPER::insert(@_);
- $w->cancel_current_gui_callback_and_restart_from_beginning;
-}
-
-sub delete
-{
- my $w = shift;
- $w->SUPER::delete(@_);
- $w->cancel_current_gui_callback_and_restart_from_beginning;
-}
-
-sub SetCursor
-{
- my $w = shift;
- $w->SUPER::SetCursor(@_);
- $w->cancel_current_gui_callback_and_restart_from_beginning;
-}
-
-sub OverstrikeMode
-{
- my ($w,$mode) = @_;
- if (defined($mode))
- {
- $w->SUPER::OverstrikeMode($mode);
- $w->cancel_current_gui_callback_and_restart_from_beginning;
- }
- return $w->SUPER::OverstrikeMode;
-}
-
-
-#######################################################################
-# use yview on scrollbar to get fractional coordinates.
-# scale this by the total length of the text to find the
-# approximate start line of widget and end line of widget.
-#######################################################################
-sub GetScreenWindowCoordinates
-{
- my $w = shift;
- my ($top_frac, $bot_frac) = $w->yview;
- my $end_index = $w->index('end');
- my ($lines,$columns) = split (/\./,$end_index);
- my $window = $w->{'WINDOW_PLUS_AND_MINUS_VALUE'};
- my $top_line = int(($top_frac * $lines) - $window);
- $top_line = 0 if ($top_line < 0);
- my $bot_line = int(($bot_frac * $lines) + $window);
- $bot_line = $lines if ($bot_line > $lines);
- my $top_index = $top_line . '.0';
- my $bot_index = $bot_line . '.0';
-
- $_[0] = $top_index;
- $_[1] = $bot_index;
-}
-
-########################################################################
-# take two indices as inputs.
-# if they are on the same line or same column (accounting for tabs)
-# then return 1
-# else return 0
-# (assume indices passed in are in line.column format)
-########################################################################
-sub IndicesLookGood
-{
- my ($w, $start, $end, $singleline) = @_;
-
- return 0 unless ( (defined($start)) and (defined($end)));
-
- my ($start_line, $start_column) = split (/\./,$start);
- my ($end_line, $end_column) = split (/\./,$end);
-
- ##########################
- # good if on the same line
- ##########################
- return 1 if ($start_line == $end_line);
-
- ##########################
- # if not on same line and its a singleline, its bad
- ##########################
- return 0 if $singleline;
-
-
- # get both lines, convert the tabs to spaces, and get the new column.
- # see if they line up or not.
- my $string;
- $string = $w->get($start_line.'.0', $start_line.'.0 lineend');
- $string = substr($string, 0, $start_column+1);
- $string = expand($string);
- $start_column = length($string);
-
- $string = $w->get($end_line.'.0', $end_line.'.0 lineend');
- $string = substr($string, 0, $end_column +1);
- $string = expand($string);
- $end_column = length($string);
-
- ##########################
- # good if on the same column (adjusting for tabs)
- ##########################
- return 1 if ($start_column == $end_column);
-
- # otherwise its bad
- return 0;
-}
-
-########################################################################
-# if searching backward, count paranthesis until find a start parenthesis
-# which does not have a forward match.
-#
-# (<= search backward will return this index
-# ()
-# START X HERE
-# ( ( ) () )
-# )<== search forward will return this index
-#
-# if searching forward, count paranthesis until find a end parenthesis
-# which does not have a rearward match.
-########################################################################
-sub searchForBaseCharacterInPair
-{
- my
- (
- $w, $top_index, $searchfromindex, $bot_index,
- $direction, $startchar, $endchar, $charpair
- )=@_;
- my ($plus_one_char, $search_end_index, $index_offset, $done_index);
- if ($direction eq '-forward')
- {
- $plus_one_char = $endchar;
- $search_end_index = $bot_index;
- $index_offset = ' +1c';
- $done_index = $w->index('end');
- }
- else
- {
- $plus_one_char = $startchar;
- $search_end_index = $top_index;
- $index_offset = '';
- $done_index = '1.0';
- }
-
- my $at_done_index = 0;
- my $count = 0;
- my $char;
- while(1)
- {
- $searchfromindex = $w->search
- ($direction, '-regexp', $charpair, $searchfromindex, $search_end_index );
-
- last unless(defined($searchfromindex));
- $char = $w->get($searchfromindex, $w->index($searchfromindex.' +1c'));
- if ($char eq $plus_one_char)
- {$count += 1;}
- else
- {$count -= 1;}
- last if ($count==1);
- # boundary condition exists when first char in widget is the match char
- # need to be able to determine if search tried to go past index '1.0'
- # if so, set index to undef and return.
- if ( $at_done_index )
- {
- $searchfromindex = undef;
- last;
- }
- $at_done_index = 1 if ($searchfromindex eq $done_index);
- $searchfromindex=$w->index($searchfromindex . $index_offset);
- }
- return $searchfromindex;
-}
-
-########################################################################
-# highlight a character pair that most closely brackets the cursor.
-# allows you to pick and choose which ones you want to do.
-########################################################################
-
-sub HighlightParenthesisAroundCursor
-{
- my ($w)=@_;
- $w->HighlightSinglePairBracketingCursor
- ( '(', ')', '[()]', 'CURSOR_HIGHLIGHT_PARENS','BLOCK_HIGHLIGHT_PARENS',0);
-}
-
-sub HighlightCurlyBracesAroundCursor
-{
- my ($w)=@_;
- $w->HighlightSinglePairBracketingCursor
- ( '{', '}', '[{}]', 'CURSOR_HIGHLIGHT_CURLIES','BLOCK_HIGHLIGHT_CURLIES',0);
-}
-
-sub HighlightBracesAroundCursor
-{
- my ($w)=@_;
- $w->HighlightSinglePairBracketingCursor
- ( '[', ']','[][]', 'CURSOR_HIGHLIGHT_BRACES','BLOCK_HIGHLIGHT_BRACES',0);
-}
-
-sub HighlightDoubleQuotesAroundCursor
-{
- my ($w)=@_;
- $w->HighlightSinglePairBracketingCursor
- ( "\"", "\"", "\"", 'CURSOR_HIGHLIGHT_DOUBLEQUOTE','BLOCK_HIGHLIGHT_DOUBLEQUOTE',1);
-}
-
-sub HighlightSingleQuotesAroundCursor
-{
- my ($w)=@_;
- $w->HighlightSinglePairBracketingCursor
- ( "'", "'", "'", 'CURSOR_HIGHLIGHT_SINGLEQUOTE','BLOCK_HIGHLIGHT_SINGLEQUOTE',1);
-}
-
-########################################################################
-# highlight all the character pairs that most closely bracket the cursor.
-########################################################################
-sub HighlightAllPairsBracketingCursor
-{
- my ($w)=@_;
- $w->HighlightParenthesisAroundCursor;
- $w->HighlightCurlyBracesAroundCursor;
- $w->HighlightBracesAroundCursor;
- $w->HighlightDoubleQuotesAroundCursor;
- $w->HighlightSingleQuotesAroundCursor;
-}
-
-########################################################################
-# search for a pair of matching characters that bracket the
-# cursor and tag them with the given tagname.
-# startchar might be '['
-# endchar would then be ']'
-# tagname is a name of a tag, which has already been
-# configured to highlight however the user wants them to behave.
-# error tagname is the tag to highlight the chars with if there
-# is a problem of some kind.
-# singleline indicates whether the character pairs must occur
-# on a single line. quotation marks are single line characters usually.
-########################################################################
-sub HighlightSinglePairBracketingCursor
-{
- my
- (
- $w, $startchar, $endchar, $charpair,
- $good_tagname, $bad_tagname, $single_line
- ) = @_;
- $single_line=0 unless defined($single_line);
- $w->tagRemove($good_tagname, '1.0','end');
- $w->tagRemove($bad_tagname, '1.0','end');
- my $top_index; my $bot_index;
- my $cursor = $w->index('insert');
- if ($single_line)
- {
- $top_index = $w->index($cursor.' linestart');
- $bot_index = $w->index($cursor.' lineend');
- }
- else
- {
- $w->GetScreenWindowCoordinates($top_index, $bot_index);
- }
-
- # search backward for the startchar
- # $top_index, $searchfromindex, $bot_index,
- # $direction, $startchar, $endchar, $charpair
-
- my $startindex = $w->searchForBaseCharacterInPair
- (
- $top_index, $cursor, $bot_index,
- '-backward', $startchar, $endchar, $charpair
- );
-
- # search forward for the endchar
- my $endindex = $w->searchForBaseCharacterInPair
- (
- $top_index, $cursor, $bot_index,
- '-forward', $startchar, $endchar, $charpair
- );
- return unless ((defined $startindex) and (defined $endindex));
-
- my $final_tag = $bad_tagname;
- if ($w->IndicesLookGood( $startindex, $endindex, $single_line))
- {
- $final_tag = $good_tagname;
- }
-
- $w->tagAdd($final_tag, $startindex, $w->index($startindex.'+1c') );
- $w->tagAdd($final_tag, $endindex, $w->index( $endindex.'+1c') );
-}
-
-####################################################################
-sub IndentSelectedLines
-{
- my($w)=@_;
- $w->insertStringAtStartOfSelectedLines($w->{'INDENT_STRING'});
-}
-
-sub UnindentSelectedLines
-{
- my($w)=@_;
- $w->deleteStringAtStartOfSelectedLines($w->{'INDENT_STRING'});
-}
-
-sub CommentSelectedLines
-{
- my($w)=@_;
- $w->insertStringAtStartOfSelectedLines($w->{'LINE_COMMENT_STRING'});
-}
-
-sub UncommentSelectedLines
-{
- my($w)=@_;
- $w->deleteStringAtStartOfSelectedLines($w->{'LINE_COMMENT_STRING'});
-}
-
-
-1;
-__END__