~ubuntu-branches/ubuntu/natty/perl-tk/natty

« back to all changes in this revision

Viewing changes to Tk/Widget.pm

• browse files at revision 3
• compare with another revision
• download diff
• download tarball
• view history from revision 3

Show diffs side-by-side

added

removed

Tk/Widget.pm

1

 

# Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved.

 

1

# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.

2

2

# This program is free software; you can redistribute it and/or

3

3

# modify it under the same terms as Perl itself.

4

4

package Tk::Widget;

5

5

use vars qw($VERSION @DefaultMenuLabels);

6

 

$VERSION = '3.080'; # $Id: //depot/Tk8/Tk/Widget.pm#80 $

 

6

$VERSION = '3.085'; # $Id: //depot/Tk8/Tk/Widget.pm#85 $

7

7

 

8

8

require Tk;

9

9

use AutoLoader;

475

475

# but does auto-cancel when widget is deleted.

476

476

require Tk::After;

477

477

 

478

 

sub afterIdle

479

 

{

480

 

 my $w = shift;

481

 

 return Tk::After->new($w,'idle','once',@_);

482

 

}

483

 

 

484

478

sub afterCancel

485

479

{

486

480

 my ($w,$what) = @_;

492

486

  }

493

487

}

494

488

 

 

489

sub afterIdle

 

490

{

 

491

 my $w = shift;

 

492

 return Tk::After->new($w,'idle','once',@_);

 

493

}

 

494

 

 

495

sub afterInfo {

 

496

    my ($w, $id) = @_;

 

497

    if (defined $id) {

 

498

        return ($id->[4], $id->[2], $id->[3]);

 

499

    } else {

 

500

        return sort( keys %{$w->{_After_}} );

 

501

    }

 

502

}

 

503

 

495

504

sub after

496

505

{

497

506

 my $w = shift;

818

827

 

819

828

sub Busy

820

829

{

821

 

 my ($w,%args) = @_;

 

830

 my ($w,@args) = @_;

822

831

 return unless $w->viewable;

 

832

 my($sub, %args);

 

833

 for(my $i=0; $i<=$#args; $i++)

 

834

  {

 

835

   if (ref $args[$i] eq 'CODE')

 

836

    {

 

837

     if (defined $sub)

 

838

      {

 

839

       croak "Multiple code definitions not allowed in Tk::Widget::Busy";

 

840

      }

 

841

     $sub = $args[$i];

 

842

    }

 

843

   else

 

844

    {

 

845

     $args{$args[$i]} = $args[$i+1]; $i++;

 

846

    }

 

847

  }

823

848

 my $cursor  = delete $args{'-cursor'};

824

849

 my $recurse = delete $args{'-recurse'};

825

850

 $cursor  = 'watch' unless defined $cursor;

856

881

 $w->update;

857

882

 eval {local $SIG{'__DIE__'};  $w->grab };

858

883

 $w->update;

 

884

 if ($sub)

 

885

  {

 

886

   eval { $sub->() };

 

887

   my $err = $@;

 

888

   $w->Unbusy(-recurse => $recurse);

 

889

   die $err if $err;

 

890

  }

859

891

}

860

892

 

861

893

sub _busy

936

968

 

937

969

 $mw->bind($class,'<Home>',         ['xview','moveto',0]);

938

970

 $mw->bind($class,'<End>',          ['xview','moveto',1]);

 

971

 $mw->XMouseWheelBind($class);

939

972

}

940

973

 

941

974

sub PriorNextBind

945

978

 $mw->bind($class,'<Prior>',    ['yview','scroll',-1,'pages']);

946

979

}

947

980

 

 

981

sub XMouseWheelBind

 

982

{

 

983

 my ($mw,$class) = @_;

 

984

 # <4> and <5> are how mousewheel looks on X

 

985

 # <4> and <5> are how mousewheel looks on X

 

986

 $mw->bind($class,'<Shift-4>',      ['xview','scroll',-1,'units']);

 

987

 $mw->bind($class,'<Shift-5>',      ['xview','scroll',1,'units']);

 

988

}

 

989

 

 

990

sub YMouseWheelBind

 

991

{

 

992

 my ($mw,$class) = @_;

 

993

 # <4> and <5> are how mousewheel looks on X

 

994

 $mw->bind($class,'<4>',         ['yview','scroll',-1,'units']);

 

995

 $mw->bind($class,'<5>',         ['yview','scroll',1,'units']);

 

996

}

 

997

 

948

998

sub YscrollBind

949

999

{

950

1000

 my ($mw,$class) = @_;

951

1001

 $mw->PriorNextBind($class);

952

1002

 $mw->bind($class,'<Up>',       ['yview','scroll',-1,'units']);

953

1003

 $mw->bind($class,'<Down>',     ['yview','scroll',1,'units']);

 

1004

 $mw->YMouseWheelBind($class);

954

1005

}

955

1006

 

956

1007

sub XYscrollBind

958

1009

 my ($mw,$class) = @_;

959

1010

 $mw->YscrollBind($class);

960

1011

 $mw->XscrollBind($class);

 

1012

 # <4> and <5> are how mousewheel looks on X

 

1013

}

 

1014

 

 

1015

sub MouseWheelBind

 

1016

{

 

1017

 my($mw,$class) = @_;

 

1018

 

 

1019

 # The MouseWheel will typically only fire on Windows. However, one

 

1020

 # could use the "event generate" command to produce MouseWheel

 

1021

 # events on other platforms.

 

1022

 

 

1023

 $mw->Tk::bind($class, '<MouseWheel>',

 

1024

               [ sub { $_[0]->yview('scroll',-($_[1]/120)*3,'units') }, Tk::Ev("D")]);

 

1025

 

 

1026

 if ($Tk::platform eq 'unix')

 

1027

  {

 

1028

   # Support for mousewheels on Linux/Unix commonly comes through mapping

 

1029

   # the wheel to the extended buttons.  If you have a mousewheel, find

 

1030

   # Linux configuration info at:

 

1031

   #   http://www.inria.fr/koala/colas/mouse-wheel-scroll/

 

1032

   $mw->Tk::bind($class, '<4>',

 

1033

                 sub { $_[0]->yview('scroll', -3, 'units')

 

1034

                           unless $Tk::strictMotif;

 

1035

                   });

 

1036

   $mw->Tk::bind($class, '<5>',

 

1037

                 sub { $_[0]->yview('scroll', 3, 'units')

 

1038

                           unless $Tk::strictMotif;

 

1039

                   });

 

1040

  }

961

1041

}

962

1042

 

963

1043

sub ScrlListbox

1096

1176

sub Scrolled

1097

1177

{

1098

1178

 my ($parent,$kind,%args) = @_;

 

1179

 $kind = 'Pane' if $kind eq 'Frame';

1099

1180

 # Find args that are Frame create time args

1100

1181

 my @args = Tk::Frame->CreateArgs($parent,\%args);

1101

1182

 my $name = delete $args{'Name'};

1296

1377

}

1297

1378

 

1298

1379

 

 

1380

 

• Older »

Loggerhead is a web-based interface for Breezy
Version: 2.0.1