home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _1ed8dcb762d93b5b180403134297bb41 < prev    next >
Encoding:
Text File  |  2004-06-01  |  3.8 KB  |  189 lines
  1. # trace2.pl
  2.  
  3. $Tk::TraceText::VERSION = '1.0';
  4.  
  5. package Tk::TraceText;
  6.  
  7. use Tk::widgets qw/ Trace /;
  8. use base qw/ Tk::Derived Tk::Text /;
  9. use strict;
  10.  
  11. Construct Tk::Widget 'TraceText';
  12.  
  13. sub Populate {
  14.  
  15.     my( $self, $args ) = @_;
  16.  
  17.     $self->SUPER::Populate( $args );
  18.  
  19.     $self->ConfigSpecs(
  20.         -textvariable => [ 'METHOD', 'textVariable', 'TextVariable', undef ],
  21.     );
  22.  
  23.     $self->OnDestroy( sub {
  24.     my $vref = $self->{_vref};
  25.     $self->traceVdelete ( $vref ) if defined $vref;
  26.     } );
  27.  
  28. } # end Populate
  29.  
  30. # Private methods.
  31.  
  32. sub insdel {
  33.  
  34.     my( $self, $sub, @args ) = @_;
  35.     
  36.     $self->{_busy} = 1;
  37.     $self->$sub( @args );
  38.     my $vref = $self->{_vref};
  39.     $$vref = $self->get( qw/1.0 end/ );
  40.     $self->{_busy} = 0;
  41.  
  42. } # end insedel
  43.  
  44. sub textvariable {
  45.  
  46.     my ( $self, $vref ) = @_;
  47.  
  48.     $self->traceVariable( $vref, 'w', [ \&tracew => $self, $vref ] );
  49.     $self->{_vref} = $vref;
  50.     
  51. } # end textvariable
  52.  
  53. sub tracew {
  54.  
  55.     my ( $index, $value, $op, $self, $vref ) = @_;
  56.  
  57.     return unless defined $self;    # if app is being destroyed
  58.     return if $self->{_busy};
  59.  
  60.     if ( $op eq 'w' ) {
  61.     $self->delete( qw/1.0 end/ );
  62.     $self->insert( '1.0', $value );
  63.     } elsif ( $op eq 'r' ) {
  64.     } elsif ( $op eq 'u' ) {
  65.     $self->traceVdelete ( $vref );
  66.     }
  67.  
  68. } # end tracew
  69.  
  70. # Overridden methods.
  71.  
  72. sub delete {
  73.  
  74.     my ( $self, @args ) = @_;
  75.  
  76.     $self->insdel( 'SUPER::delete', @args )
  77.  
  78. } # end delete
  79.  
  80. sub insert {
  81.  
  82.     my ( $self, @args ) = @_;
  83.  
  84.     $self->insdel( 'SUPER::insert', @args );
  85.  
  86. } # end insert
  87.  
  88. 1;
  89.  
  90. package main;
  91.  
  92. use Tk::widgets qw/ Trace /;
  93. use vars qw / $TOP /;
  94. use strict;
  95.  
  96. sub trace2 {
  97.  
  98.     my( $demo ) = @_;
  99.  
  100.     $TOP = $MW->WidgetDemo(
  101.         -name             => $demo,
  102.         -text             => "This demonstration derives a new Text widget whose contents are modified using a normal Perl variable.",
  103.         -title            => 'Contents of a Text widget tied to a variable',
  104.         -iconname         => 'trace2',
  105.     );
  106.  
  107.     my $mw = $TOP;
  108.     my $tt = $mw->Scrolled( 'TraceText', -textvariable => \my $frog )->grid;
  109.     $tt->focus;
  110.  
  111.     $mw->traceVariable( \$frog, 'wu', [ \&trace2_tracefrog, $mw, \$frog ] );
  112.  
  113.     $frog = "Frogs lacking lipophores are blue.";
  114.  
  115. } # end trace2
  116.  
  117. sub trace2_tracefrog {
  118.  
  119.     my( $index, $value, $op ) = @_;
  120.  
  121.     print "Final " if $op eq 'u';
  122.     print "User trace: $value";
  123.     return $value;
  124.  
  125. }
  126.  
  127. __END__
  128.  
  129. =head1 NAME
  130.  
  131. Tk::TraceText - Text contents defined by a traced variable.
  132.  
  133. =for pm Tk/TraceText.pm
  134.  
  135. =for category Text
  136.  
  137. =head1 SYNOPSIS
  138.  
  139.  $tt = $parent->TraceText(-option => value, ... );
  140.  
  141. =head1 DESCRIPTION
  142.  
  143. Create a new B<TraceText> widget that is derived from the standard B<Text>
  144. widget. Because it inherits all the base options and methods it behaves
  145. just like a B<Text> widget.  Additionally, B<TraceText> adds a -textvariable
  146. option, which is a reference to a Perl scalar that defines the contents of
  147. the widget.
  148.  
  149. Based on the Tcl/Tk TracedText "overridden widget" by Kevin Kenny.
  150.  
  151. =over 4
  152.  
  153. =item B<-textvariable>
  154.  
  155. A scalar reference.  The value of the variable defines the contents of the
  156. TraceText widget.  Using the keyboard to insert or delete text changes the 
  157. value of the variable, and changing the variable alters the contents of the
  158. TraceText widget.
  159.  
  160. =back
  161.  
  162. =head1 METHODS
  163.  
  164. Standard Text widget methods.
  165.  
  166. =head1 ADVERTISED SUBWIDGETS
  167.  
  168. None.
  169.  
  170. =head1 EXAMPLE
  171.  
  172.  my $tt = $mw->TraceText( -textvariable => \$scalar );
  173.  
  174. =head1 AUTHOR
  175.  
  176. Stephen.O.Lidie@Lehigh.EDU
  177.  
  178. Copyright (C) 2003 - 2004, Steve Lidie. All rights reserved.
  179.  
  180. This program is free software; you can redistribute it
  181. and/or modify it under the same terms as Perl itself.
  182.  
  183. =head1 KEYWORDS
  184.  
  185. text, trace
  186.  
  187. =cut
  188.  
  189.