← Back to branch summary

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

« back to all changes in this revision

Viewing changes to demos/demos/widget_lib/floor.pl

  • Committer: Bazaar Package Importer
  • Author(s): Stephen Zander
  • Date: 2004-03-14 13:54:44 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20040314135444-prc09u2or4dbr3to
Tags: 1:800.025-2
http://bugs.debian.org/237942
Add xlibs-dev to Build-Depends:,
Closes: #237942

Show diffs side-by-side

added added

removed removed

Lines of Context:
demos/demos/widget_lib/floor.pl
1
1
# floor.pl
2
2
 
 
3
use Tk::Trace;
3
4
use subs qw/floor_bg1 floor_bg2 floor_bg3 floor_display floor_fg1 floor_fg2
4
5
            floor_fg3 floor_room_changed/;
5
6
use vars qw/$TOP/;
6
7
 
7
8
sub floor {
8
9
 
9
 
    # Create a top-level window containing a canvas that displays the
 
10
    # Create a top-level window containing a Canvas that displays the
10
11
    # floorplan for DEC's Western Research Laboratory.
11
12
 
12
13
    my($demo) = @_;
21
22
                           -borderwidth 2 -scrollbars se/);
22
23
    $c->pack(qw/-expand yes -fill both/);
23
24
 
24
 
    # Create an entry for displaying and typing in current room.
25
 
    untie $floor::current_room;
 
25
    # Create an Entry for displaying and typing in current room.
 
26
 
26
27
    $floor::current_room = '';
27
28
    my $c_entry = $c->Entry(qw/-width 10 -relief sunken -borderwidth 2
28
29
                            -textvariable/ => \$floor::current_room);
56
57
    floor_display $c->Subwidget('canvas'), 3, \%floor_labels, \%floor_items,
57
58
        \%cinfo, \$active_floor, $c_entry;
58
59
 
59
 
    # Set up event bindings for canvas.
 
60
    # Set up event bindings for the Canvas.
60
61
 
61
62
    my $floor_number;
62
63
    for $floor_number (1..3) {
68
69
    $c->bind('room', '<Enter>' => sub {
69
70
        my($c) = @_;
70
71
        my $id = $c->find('withtag' => 'current');
71
 
        $floor::current_room  = $floor_labels{$c->find('withtag','current')}
72
 
            if defined $id;
 
72
        $id = $id->[0] if ref($id) eq 'ARRAY';
 
73
        $floor::current_room  = $floor_labels{$id} if defined $id;
73
74
        $c->idletasks;
74
75
    });
75
76
    $c->bind('room', '<Leave>' => sub {$floor::current_room = ''});
76
 
    $c->Tk::bind('<2>' => sub {
77
 
        my($c) = @_;
78
 
        my $e = $c->XEvent;
79
 
        $c->scan('mark', $e->x, $e->y);
80
 
    });
81
 
    $c->Tk::bind('<B2-Motion>' => sub {
82
 
        my($c) = @_;
83
 
        my $e = $c->XEvent;
84
 
        $c->scan('dragto', $e->x, $e->y);
85
 
    });
86
 
    $c->Tk::bind('<Enter>', => [sub {shift; shift->focus}, $c_entry]);
87
 
    tie $floor::current_room, 'floor', $c->Subwidget('canvas'), \%floor_items,
88
 
        \%cinfo;
 
77
    $c->CanvasBind('<2>' => sub {
 
78
        my($c) = @_;
 
79
        my $e = $c->XEvent;
 
80
        $c->scanMark($e->x, $e->y);
 
81
    });
 
82
    $c->CanvasBind('<B2-Motion>' => sub {
 
83
        my($c) = @_;
 
84
        my $e = $c->XEvent;
 
85
        $c->scanDragto($e->x, $e->y);
 
86
    });
 
87
    $c->CanvasBind('<Enter>', => [sub {shift; shift->focus}, $c_entry]);
 
88
 
 
89
    $c->traceVariable(\$floor::current_room, 'w' =>
 
90
        [sub {
 
91
            my($index, $value, $op, $floor_items, $cinfo) = @_;
 
92
            return if $op eq 'u';
 
93
            $floor_current_room = $value;
 
94
            &floor_room_changed($c->Subwidget('canvas'), $floor_items, $cinfo);
 
95
            $value;             # always return variable's new value
 
96
        }, \%floor_items, \%cinfo],
 
97
    ); 
89
98
 
90
99
} # floor
91
100
 
92
101
sub floor_display {
93
102
 
94
103
    # The following procedure recreates the floorplan display in the
95
 
    # canvas given by "w".  The floor given by "active" (1, 2, or 3) is
 
104
    # Canvas given by "w".  The floor given by "active" (1, 2, or 3) is
96
105
    # displayed on top, with office structure visible.  (Used as a callback
97
106
    # and a normal function.)
98
107
 
1312
1321
 
1313
1322
} # end floor_fg3;
1314
1323
 
1315
 
package floor;
1316
 
 
1317
 
# $current_room is tied to package "floor" for tracing purposes, thus, when
1318
 
# characters are typed in the Entry widget we can call floor_room_changed()
1319
 
# at every keystroke, and when a valid room number is found light the room up.
1320
 
#
1321
 
# All other global variables are also "floor" qualified.
1322
 
 
1323
 
my($class, $current_room, $canvas, $floor_items, $cinfo);
1324
 
 
1325
 
sub TIESCALAR {
1326
 
 
1327
 
    # "new" method for scalars.  Save reference to the floorplan canvas,
1328
 
    # item descriptions and canvas info hash in this package's namespace.
1329
 
    #
1330
 
    # Return a blessed reference, which is what FETCH and STORE will get.
1331
 
 
1332
 
    ($class, $canvas, $floor_items, $cinfo) = @_;
1333
 
    my $self;
1334
 
    bless \$self, $class;
1335
 
 
1336
 
}
1337
 
 
1338
 
sub FETCH {
1339
 
 
1340
 
    # Method to handle reads of the tied variable:  simply return it's value.
1341
 
   
1342
 
    my($current_room) = @_;
1343
 
    return $$current_room;
1344
 
 
1345
 
}
1346
 
 
1347
 
sub STORE {
1348
 
 
1349
 
    # Method to handle writes to the tied variable:  simply store it's value.
1350
 
    # Call floor_room_changed() to highlight a room, if possible.
1351
 
 
1352
 
    my($current_room, $value) = @_;
1353
 
    $$current_room = $value;
1354
 
    &::floor_room_changed($canvas, $floor_items, $cinfo);
1355
 
 
1356
 
}
1357
 
 
1358
 
sub DESTROY {                   # class destructor (unused)
1359
 
}
1360
 
 
1361
1324
1;