1#!/usr/local/bin/perl -w
2
3use Tk;
4
5# one way of doing menu bars that a collegue has come up with
6# not official in any manner yet.
7
8{
9package MenuBar;
10
11sub new
12{
13 my $class = shift;
14 my($parent,@args) = @_;
15 my $me;
16
17 my $f = $parent->Frame('-relief' => "raised",  '-bd' => 1 );
18
19 $me = bless \$f;
20
21 for($i = 0 ; $i < scalar(@args) ; $i += 2)
22  {
23   $me->add($args[$i],$args[$i+1],'-side' => "left");
24  }
25
26 $f->pack('-side' => "top");
27
28 return $me;
29}
30
31sub add
32{
33 my($me,$name,$defn,@args) = @_;
34
35 my $b = ${$me}->Menubutton( '-text' => $name, '-underline' => 0 );
36 my $m = create_menu($b,$defn);
37
38 $b->configure('-menu' => $m);
39 $b->pack(@args);
40 ${$me}->pack();
41}
42
43sub create_menu
44{
45 my($b,$defn) = @_;
46 my $m = $b->Menu();
47
48 foreach $elem (@{$defn})
49  {
50   if(ref($elem) && ref($elem) eq 'ARRAY' && defined($elem->[0]))
51    {
52     if(defined($elem->[1]) && ref($elem->[1]) && ref($elem->[1]) eq 'ARRAY')
53      {
54       $m->cascade('-label' => $elem->[0],
55                   '-menu'  => create_menu($m,$elem->[1])
56                  );
57      }
58     else
59      {
60       my $state = (defined($elem->[2]) && $elem->[2] == 0) ? 'disabled'
61                                                           : 'normal';
62
63       if(defined($elem->[3]) && ref($elem->[3]) eq 'SCALAR')
64        {
65         $m->checkbutton('-label'    => $elem->[0],
66                         '-variable' => $elem->[3],
67                         '-state'    => $state
68                        );
69        }
70       else
71        {
72         $m->command('-label' => $elem->[0],
73                     '-state' => $state
74                    );
75        }
76      }
77    }
78   else
79    {
80     $m->separator;
81    }
82  }
83
84 return $m;
85}
86}
87
88$top = MainWindow->new();
89
90$bar = MenuBar->new($top,@menus::menu);
91
92Tk::MainLoop; #tkmainloop;
93
94exit;
95
96BEGIN {
97package menus;
98$SEPARATOR = undef;
99
100$xile = [
101     ["Open File...\t\tX"               ,'find-file'                    ],
102     ["Open File (Read Only)...\tY"   ,'find-file'                      ],
103     ["Open File (New Screen)..."  ,'find-file-new-screen'              ],
104     ["Open Alternate File..."     ,'find-alternate-file'               ],
105     $SEPARATOR,
106     ["Include File..."            ,'insert-file'                       ],
107     $SEPARATOR,
108     ["Toggle Read Only"           ,'toggle-read-only'                  ],
109     $SEPARATOR,
110     ["Save Buffer"                ,'save-buffer'                       ],
111     ["Save Buffer As..."          ,'write-file'                        ],
112     ["Save Some Buffers"          ,'save-some-buffers'                 ],
113     ["Save Region As..."          ,'write-region'                      ],
114     ["Revert Buffer"              ,'revert-buffer'                     ],
115     $SEPARATOR,
116     ["Print Buffer"               ,'lpr-buffer'                        ],
117     ["Print Region"               ,'lpr-region'                        ],
118     $SEPARATOR,
119     ["Kill Buffer..."             ,'kill-buffer'                       ],
120     ["Exit Emacs"                 ,'save-buffers-kill-emacs'           ]
121     ];
122$readonly = 0;
123$file = [
124     ["Open File..."               ,$xile                               ],
125     ["Open File (Read Only)..."   ,'find-file'                         ],
126     ["Open File (New Screen)..."  ,'find-file-new-screen'              ],
127     ["Open Alternate File..."     ,'find-alternate-file'               ],
128     $SEPARATOR,
129     ["Include File..."            ,'insert-file'                       ],
130     $SEPARATOR,
131     ["Toggle Read Only"           ,'toggle-read-only'                  ,1,\$readonly],
132     $SEPARATOR,
133     ["Save Buffer"                ,'save-buffer'                       ],
134     ["Save Buffer As..."          ,'write-file'                        ],
135     ["Save Some Buffers"          ,'save-some-buffers'                 ],
136     ["Save Region As..."          ,'write-region'                      ],
137     ["Revert Buffer"              ,'revert-buffer'                     ],
138     $SEPARATOR,
139     ["Print Buffer"               ,'lpr-buffer'                        ],
140     ["Print Region"               ,'lpr-region'                        ],
141     $SEPARATOR,
142     ["Kill Buffer..."             ,'kill-buffer'                       ],
143     ["Exit Emacs"                 ,'save-buffers-kill-emacs'           ]
144     ];
145
146$screen = [
147     ["New Screen"                 ,'x-new-screen'                      ,1],
148     ["Delete Screen"              ,'delete-screen'                     ,0],
149     ["One Screen"                 ,'one-screen'                        ,1],
150     $SEPARATOR,
151     ["Split"                      ,'split-window-vertically'           ,1],
152     ["Un-split (Keep This)"       ,'delete-other-windows'              ,1],
153     ["Un-split (Keep Others)"     ,'delete-window'                     ,1],
154     $SEPARATOR,
155     ["Enlarge current window"     ,'enlarge-window',                ,1],
156     ["Shrink current window"      ,'shrink-window',                 ,1],
157     $SEPARATOR,
158     ["Save Configuration..."      ,'window-config-to-register'         ,1],
159     ["Restore Configuration..."   ,'register-to-window-config'         ,1],
160     $SEPARATOR,
161     ["(Un)Truncate Lines"         ,'hscroll-truncate-lines'            ,1]
162     ];
163
164
165@menu = ( "File"   => $file,
166          "Screen" => $screen,
167          "Another Screen" => $screen
168        );
169}
170
171