← Back to branch summary

~ubuntu-branches/ubuntu/trusty/horae/trusty

« back to all changes in this revision

Viewing changes to 0CPAN/Tk-Pod-0.9932/Pod.pm

  • Committer: Bazaar Package Importer
  • Author(s): Carlo Segre
  • Date: 2008-02-23 23:13:02 UTC
  • mfrom: (2.1.2 hardy)
  • Revision ID: james.westby@ubuntu.com-20080223231302-mnyyxs3icvrus4ke
Tags: 066-3
Apply patch to athena_parts/misc.pl for compatibility with 
perl-tk 804.28.

Show diffs side-by-side

added added

removed removed

Lines of Context:
0CPAN/Tk-Pod-0.9932/Pod.pm
1
 
package Tk::Pod;
2
 
use strict;
3
 
use Tk ();
4
 
use Tk::Toplevel;
5
 
 
6
 
use vars qw($VERSION $DIST_VERSION @ISA);
7
 
$VERSION = sprintf("%d.%02d", q$Revision: 5.10 $ =~ /(\d+)\.(\d+)/);
8
 
$DIST_VERSION = "0.9932";
9
 
 
10
 
@ISA = qw(Tk::Toplevel);
11
 
 
12
 
Construct Tk::Widget 'Pod';
13
 
 
14
 
my $openpod_history;
15
 
my $searchfaq_history;
16
 
 
17
 
sub Pod_Text_Widget { "PodText" }
18
 
sub Pod_Text_Module { "Tk::Pod::Text" }
19
 
 
20
 
sub Pod_Tree_Widget { "PodTree" }
21
 
sub Pod_Tree_Module { "Tk::Pod::Tree" }
22
 
 
23
 
sub Populate
24
 
{
25
 
 my ($w,$args) = @_;
26
 
 
27
 
 if ($w->Pod_Text_Module)
28
 
  {
29
 
   eval q{ require } . $w->Pod_Text_Module;
30
 
   die $@ if $@;
31
 
  }
32
 
 if ($w->Pod_Tree_Module)
33
 
  {
34
 
   eval q{ require } . $w->Pod_Tree_Module;
35
 
   die $@ if $@;
36
 
  }
37
 
 
38
 
 $w->SUPER::Populate($args);
39
 
 
40
 
 my $tree = $w->Scrolled($w->Pod_Tree_Widget,
41
 
                         -scrollbars => 'oso'.($Tk::platform eq 'MSWin32'?'e':'w')
42
 
                        );
43
 
 $w->Advertise('tree' => $tree);
44
 
 
45
 
 my $searchcase = 0;
46
 
 my $p = $w->Component($w->Pod_Text_Widget => 'pod', -searchcase => $searchcase)->pack(-expand => 1, -fill => 'both');
47
 
 
48
 
 my $exitbutton = delete $args->{-exitbutton} || 0;
49
 
 
50
 
 # Experimental menu compound images:
51
 
 # XXX Maybe there should be a way to turn this off, as the extra
52
 
 # icons might be memory consuming...
53
 
 my $compound = sub { ($_[0]) };
54
 
 if ($Tk::VERSION >= 800 && eval { require Tk::ToolBar; 1 }) {
55
 
     $w->ToolBar->destroy; # hack to load images
56
 
     if (!$Tk::Pod::empty_image_16) { # XXX multiple MainWindows?
57
 
         $Tk::Pod::empty_image_16 = $w->MainWindow->Photo(-data => <<EOF);
58
 
R0lGODlhEAAQAIAAAP///////yH+FUNyZWF0ZWQgd2l0aCBUaGUgR0lNUAAh+QQBCgABACwA
59
 
AAAAEAAQAAACDoyPqcvtD6OctNqLsz4FADs=
60
 
EOF
61
 
     }
62
 
     if ($Tk::VERSION >= 804) {
63
 
         # Tk804 has native menu item compounds
64
 
         $compound = sub {
65
 
             my($text, $image) = @_;
66
 
             if ($image) {
67
 
                 ($text, -image => $image . "16", -compound => "left");
68
 
             } else {
69
 
                 ($text, -image => $Tk::Pod::empty_image_16, -compound => "left");
70
 
             }
71
 
         };
72
 
     } elsif (eval { require Tk::Compound; 1 }) {
73
 
         # For Tk800 we have to create our own compounds using Tk::Compund
74
 
         # get the default font (taken from bbbike):
75
 
         my $std_font = $w->optionGet('font', 'Font');
76
 
         if (!defined $std_font || $std_font eq '') {
77
 
             my $l = $w->Label;
78
 
             $std_font = $l->cget(-font);
79
 
             $l->destroy;
80
 
         }
81
 
         my %std_font = $w->fontActual($std_font);
82
 
         # create an underlined font which matches the default font
83
 
         my $underline_font = join(" ", map { "{" . $std_font{$_} . "}" } qw(-family -size -weight -slant));
84
 
         $underline_font .= " overstrike" if $std_font{-overstrike};
85
 
         $underline_font .= " underline";
86
 
         $compound = sub {
87
 
             my($text, $image) = @_;
88
 
             my $c = $w->MainWindow->Compound; # XXX multiple MainWindows?
89
 
             if ($image) {
90
 
                 $c->Image(-image => $image."16");
91
 
             } else {
92
 
                 $c->Image(-image => $Tk::Pod::empty_image_16);
93
 
             }
94
 
             $c->Space(-width => 4);
95
 
             my($text_before, $underlined_text, $text_after) = $text =~ /^(.*)~(.)(.*)/;
96
 
             if (defined $underlined_text) {
97
 
                 $c->Text(-text => $text_before) if $text_before ne "";
98
 
                 $c->Text(-text => $underlined_text, -font => $underline_font);
99
 
                 $c->Text(-text => $text_after) if $text_after ne "";
100
 
             } else {
101
 
                 $c->Text(-text => $text);
102
 
             }
103
 
             ($text, -image => $c);
104
 
         };
105
 
     }
106
 
 }
107
 
 
108
 
 my $menuitems =
109
 
 [
110
 
 
111
 
  [Cascade => '~File', -menuitems =>
112
 
   [
113
 
    [Button => $compound->('~Open File...', "fileopen"),
114
 
     '-accelerator' => 'F3',
115
 
     '-command' => ['openfile',$w],
116
 
    ],
117
 
    [Button => $compound->('Open ~by Name...'),
118
 
     '-accelerator' => 'Ctrl+O',
119
 
     '-command' => ['openpod',$w,$p],
120
 
    ],
121
 
    [Button => $compound->('~New Window...'),
122
 
     '-accelerator' => 'Ctrl+N',
123
 
     '-command' => ['newwindow',$w,$p],
124
 
    ],
125
 
    [Button => $compound->('~Reload', "actreload"),
126
 
     '-accelerator' => 'Ctrl+R',
127
 
     '-command' => ['reload',$p],
128
 
    ],
129
 
    [Button => $compound->('~Edit', "edit"),
130
 
     '-command' => ['edit',$p],
131
 
    ],
132
 
    [Button => $compound->('Edit with p~tked'),
133
 
     '-command' => ['edit',$p,'ptked'],
134
 
    ],
135
 
    [Button => $compound->('~Print'. ($p->PrintHasDialog ? '...' : ''), "fileprint"),
136
 
     '-accelerator' => 'Ctrl+P',
137
 
     '-command' => ['Print',$p],
138
 
    ],
139
 
    [Separator => ""],
140
 
    [Button => $compound->('~Close', "fileclose"),
141
 
     '-accelerator' => 'Ctrl+W',
142
 
     '-command' => ['quit',$w],
143
 
    ],
144
 
    ($exitbutton
145
 
     ? [Button => $compound->('E~xit', "actexit"),
146
 
        '-accelerator' => 'Ctrl+Q',
147
 
        '-command' => sub { $p->MainWindow->destroy },
148
 
       ]
149
 
     : ()
150
 
    ),
151
 
   ]
152
 
  ],
153
 
 
154
 
  [Cascade => '~View', -menuitems =>
155
 
   [
156
 
    [Checkbutton => $compound->('~Pod Tree'),
157
 
     '-variable' => \$w->{Tree_on},
158
 
     '-command' => sub { $w->tree($w->{Tree_on}) },
159
 
    ],
160
 
    '-',
161
 
    [Button => $compound->("Zoom ~in", "viewmag+"),
162
 
     '-accelerator' => 'Ctrl++',
163
 
     '-command' => [$w, 'zoom_in'],
164
 
    ],
165
 
    [Button => $compound->("~Normal"),
166
 
     '-command' => [$w, 'zoom_normal'],
167
 
    ],
168
 
    [Button => $compound->("Zoom ~out", "viewmag-"),
169
 
     '-accelerator' => 'Ctrl+-',
170
 
     '-command' => [$w, 'zoom_out'],
171
 
    ],
172
 
   ]
173
 
  ],
174
 
 
175
 
  [Cascade => '~Search', -menuitems =>
176
 
   [
177
 
    [Button => $compound->('~Search', "viewmag"),
178
 
     '-accelerator' => '/',
179
 
     '-command' => ['Search', $p, 'Next'],
180
 
    ],
181
 
    [Button => $compound->('Search ~backwards'),
182
 
     '-accelerator' => '?',
183
 
     '-command' => ['Search', $p, 'Prev'],
184
 
    ],
185
 
    [Button => $compound->('~Repeat search'),
186
 
     '-accelerator' => 'n',
187
 
     '-command' => ['ShowMatch', $p, 'Next'],
188
 
    ],
189
 
    [Button => $compound->('R~epeat backwards'),
190
 
     '-accelerator' => 'N',
191
 
     '-command' => ['ShowMatch', $p, 'Prev'],
192
 
    ],
193
 
    [Checkbutton => $compound->('~Case sensitive'),
194
 
     '-variable' => \$searchcase,
195
 
     '-command' => sub { $p->configure(-searchcase => $searchcase) },
196
 
    ],
197
 
    [Separator => ""],
198
 
    [Button => $compound->('Search ~full text', "filefind"),
199
 
     '-command' => ['SearchFullText', $p],
200
 
    ],
201
 
    [Button => $compound->('Search FA~Q'),
202
 
     '-command' => ['SearchFAQ', $w, $p],
203
 
    ],
204
 
   ]
205
 
  ],
206
 
 
207
 
  [Cascade => 'H~istory', -menuitems =>
208
 
   [
209
 
    [Button => $compound->('~Back', "navback"),
210
 
     '-accelerator' => 'Alt-Left',
211
 
     '-command' => ['history_move', $p, -1],
212
 
    ],
213
 
    [Button => $compound->('~Forward', "navforward"),
214
 
     '-accelerator' => 'Alt-Right',
215
 
     '-command' => ['history_move', $p, +1],
216
 
    ],
217
 
    [Button => $compound->('~View'),
218
 
     '-command' => ['history_view', $p],
219
 
    ],
220
 
    '-',
221
 
    [Button => $compound->('Clear cache'),
222
 
     '-command' => ['clear_cache', $p],
223
 
    ],
224
 
   ]
225
 
  ],
226
 
 
227
 
  [Cascade => '~Help', -menuitems =>
228
 
   [
229
 
    # XXX restructure to not reference to tkpod
230
 
    [Button => '~Usage...',       -command => ['help', $w]],
231
 
    [Button => '~Programming...', -command => ['help_programming', $w]],
232
 
    [Button => '~About...', -command => ['about', $w]],
233
 
    ($ENV{'TKPODDEBUG'}
234
 
     ? ('-',
235
 
        [Button => 'WidgetDump', -command => sub { $w->WidgetDump }],
236
 
        (defined &Tk::App::Reloader::reload_new_modules
237
 
         ? [Button => 'Reloader', -command => sub { Tk::App::Reloader::reload_new_modules() }]
238
 
         : ()
239
 
        ),
240
 
       )
241
 
     : ()
242
 
    ),
243
 
   ]
244
 
  ]
245
 
 ];
246
 
 
247
 
 my $mbar = $w->Menu(-menuitems => $menuitems);
248
 
 $w->configure(-menu => $mbar);
249
 
 $w->Advertise(menubar => $mbar);
250
 
 
251
 
 $w->Delegates('Menubar' => $mbar);
252
 
 $w->ConfigSpecs(
253
 
    -tree => ['METHOD', 'tree', 'Tree', 0],
254
 
    -exitbutton => ['PASSIVE', 'exitButton', 'ExitButton', $exitbutton],
255
 
    -background => ['PASSIVE'], # XXX see comment in Tk::More
256
 
    -cursor => ['CHILDREN'],
257
 
    'DEFAULT' => [$p],
258
 
 );
259
 
 
260
 
 {
261
 
  my $path = $w->toplevel->PathName;
262
 
  foreach my $mod (qw(Alt Meta))
263
 
   {
264
 
    $w->bind($path, "<$mod-Left>"  => [$p, 'history_move', -1]);
265
 
    $w->bind($path, "<$mod-Right>" => [$p, 'history_move', +1]);
266
 
   }
267
 
 
268
 
  $w->bind($path, "<Control-minus>" => [$w, 'zoom_out']);
269
 
  $w->bind($path, "<Control-plus>" => [$w, 'zoom_in']);
270
 
  $w->bind($path, "<F3>" => [$w,'openfile']);
271
 
  $w->bind($path, "<Control-o>" => [$w,'openpod',$p]);
272
 
  $w->bind($path, "<Control-n>" => [$w,'newwindow',$p]);
273
 
  $w->bind($path, "<Control-r>" => [$p, 'reload']);
274
 
  $w->bind($path, "<Control-p>" => [$p, 'Print']);
275
 
  $w->bind($path, "<Control-w>" => [$w, 'quit']);
276
 
  $w->bind($path, "<Control-q>" => sub { $p->MainWindow->destroy })
277
 
      if $exitbutton;
278
 
 }
279
 
 
280
 
 $w->protocol('WM_DELETE_WINDOW',['quit',$w]);
281
 
}
282
 
 
283
 
my $fsbox;
284
 
 
285
 
sub openfile {
286
 
    my ($cw,$p) = @_;
287
 
    my $file;
288
 
    if ($cw->can("getOpenFile")) {
289
 
        $file = $cw->getOpenFile
290
 
            (-title => "Choose Pod file",
291
 
             -filetypes => [['Pod containing files', ['*.pod',
292
 
                                                      '*.pl',
293
 
                                                      '*.pm']],
294
 
                            ['Pod files', '*.pod'],
295
 
                            ['Perl scripts', '*.pl'],
296
 
                            ['Perl modules', '*.pm'],
297
 
                            ['All files', '*']]);
298
 
    } else {
299
 
        unless (defined $fsbox && $fsbox->IsWidget) {
300
 
            require Tk::FileSelect;
301
 
            $fsbox = $cw->FileSelect();
302
 
        }
303
 
        $file = $fsbox->Show();
304
 
    }
305
 
    $cw->configure(-file => $file) if defined $file && -r $file;
306
 
}
307
 
 
308
 
sub openpod {
309
 
    my($cw,$p) = @_;
310
 
    my $t = $cw->Toplevel(-title => "Open Pod by Name");
311
 
    $t->transient($cw);
312
 
    $t->grab;
313
 
    my($pod, $e, $go);
314
 
    {
315
 
        my $Entry = 'Entry';
316
 
        eval {
317
 
            require Tk::HistEntry;
318
 
            Tk::HistEntry->VERSION(0.40);
319
 
            $Entry = "HistEntry";
320
 
        };
321
 
 
322
 
        my $f = $t->Frame->pack(-fill => "x");
323
 
        $f->Label(-text => "Pod:")->pack(-side => "left");
324
 
        $e = $f->$Entry(-textvariable => \$pod)->pack(-side => "left", -fill => "x", -expand => 1);
325
 
        if ($e->can('history') && $openpod_history) {
326
 
            $e->history($openpod_history);
327
 
        }
328
 
        $e->focus;
329
 
        $go = 0;
330
 
        $e->bind("<Return>" => sub { $go = 1 });
331
 
        $e->bind("<Escape>" => sub { $go = -1 });
332
 
    }
333
 
 
334
 
    {
335
 
        my $f = $t->Frame->pack;
336
 
        Tk::grid($f->Label(-text => "Use 'Module::Name' for module documentation"), -sticky => "w");
337
 
        Tk::grid($f->Label(-text => "Use '-f function' for function documentation"), -sticky => "w");
338
 
        Tk::grid($f->Label(-text => "Use '-q terms' for FAQ entries"), -sticky => "w");
339
 
    }
340
 
 
341
 
    {
342
 
        my $f = $t->Frame->pack;
343
 
        $f->Button(-text => "OK",
344
 
                   -command => sub { $go = 1 })->pack(-side => "left");
345
 
        $f->Button(-text => "New window",
346
 
                   -command => sub { $go = 2 })->pack(-side => "left");
347
 
        $f->Button(-text => "Cancel",
348
 
                   -command => sub { $go = -1 })->pack(-side => "left");
349
 
    }
350
 
    $t->Popup(-popover => $cw);
351
 
    $t->OnDestroy(sub { $go = -1 unless $go });
352
 
    $t->waitVariable(\$go);
353
 
    if (Tk::Exists($t)) {
354
 
        if (defined $pod && $pod ne "" && $go > 0 && $e->can('historyAdd')) {
355
 
            $e->historyAdd($pod);
356
 
            $openpod_history = [ $e->history ];
357
 
        }
358
 
        $t->grabRelease;
359
 
        $t->destroy;
360
 
    }
361
 
 
362
 
    my %pod_args;
363
 
    if (defined $pod && $pod =~ /^(-[fq])\s+(.+)/) {
364
 
        my $switch = $1;
365
 
        my $func = $2;
366
 
        %pod_args = $cw->getpodargs($switch, $func);
367
 
    } else {
368
 
        %pod_args = $cw->getpodargs($pod);
369
 
    }
370
 
 
371
 
    if (defined $pod && $pod ne "") {
372
 
        if ($go == 1) {
373
 
            $cw->configure(%pod_args);
374
 
        } elsif ($go == 2) {
375
 
            my $new_cw = $cw->clone(%pod_args);
376
 
        }
377
 
    }
378
 
}
379
 
 
380
 
sub getpodargs {
381
 
    my($cw, @args) = @_;
382
 
    my @pod_args;
383
 
    if (@args == 1) {
384
 
        @pod_args = ('-file' => $args[0]);
385
 
    } elsif (@args == 2 && $args[0] =~ /^-([fq])$/) {
386
 
        my $switch = $1;
387
 
        my $func = $args[1];
388
 
        my $func_pod = "";
389
 
        open(FUNCPOD, "-|") or do {
390
 
            exec "perldoc", "-u", "-$switch", $func;
391
 
            warn "Can't execute perldoc: $!";
392
 
            CORE::exit(1);
393
 
        };
394
 
        local $/ = undef;
395
 
        $func_pod = join "", <FUNCPOD>;
396
 
        close FUNCPOD;
397
 
        if ($func_pod ne "") {
398
 
            push @pod_args, '-text' => $func_pod;
399
 
            if ($switch eq "f") {
400
 
                push @pod_args, '-title' => "Function $func";
401
 
            } else {
402
 
                push @pod_args, '-title' => "FAQ $func";
403
 
            }
404
 
        }
405
 
    }
406
 
    @pod_args;
407
 
}
408
 
 
409
 
sub newwindow {
410
 
    shift->clone;
411
 
}
412
 
 
413
 
sub Dir {
414
 
    require Tk::Pod::Text;
415
 
    require Tk::Pod::Tree;
416
 
    Tk::Pod::Text::Dir(@_);
417
 
    Tk::Pod::Tree::Dir(@_);
418
 
}
419
 
 
420
 
 
421
 
sub quit { shift->destroy }
422
 
 
423
 
sub help {
424
 
    my $w = shift;
425
 
    $w->clone('-tree' => 0,
426
 
              '-file' => 'Tk::Pod_usage.pod',
427
 
             );
428
 
}
429
 
 
430
 
sub help_programming {
431
 
    my $w = shift;
432
 
    $w->clone('-tree' => 0,
433
 
              '-file' => 'Tk/Pod.pm',
434
 
              );
435
 
}
436
 
 
437
 
sub about {
438
 
    my $w = shift;
439
 
    require Tk::DialogBox;
440
 
    require Tk::ROText;
441
 
    my $d = $w->DialogBox(-title => "About Tk::Pod",
442
 
                          -buttons => ["OK"],
443
 
                         );
444
 
    my $message = <<EOF;
445
 
Tk::Pod - a Pod viewer written in Perl/Tk
446
 
 
447
 
Version information:
448
 
    Tk-Pod distribution $DIST_VERSION
449
 
    Tk::Pod module $VERSION
450
 
 
451
 
System information:
452
 
    @{[ $Pod::Simple::VERSION ? "Pod::Simple $Pod::Simple::VERSION\n"
453
 
                          : ""
454
 
]}    Tk $Tk::VERSION
455
 
    Perl $]
456
 
    OS $^O
457
 
 
458
 
Please contact <srezic\@cpan.org> in case of problems.
459
 
Send the contents of this window for diagnostics.
460
 
 
461
 
EOF
462
 
    my @lines = split /\n/, $message, -1;
463
 
    my $width = 0;
464
 
    for (@lines) {
465
 
        $width = length $_ if length $_ > $width;
466
 
    }
467
 
    my $txt = $d->add("Scrolled", "ROText",
468
 
                      -height => scalar @lines,
469
 
                      -width => $width + 1,
470
 
                      -relief => "flat",
471
 
                      -scrollbars => "oe",
472
 
                     )->pack(-expand => 1, -fill => "both");
473
 
    $txt->insert("end", $message);
474
 
    $d->Show;
475
 
}
476
 
 
477
 
sub add_section_menu {
478
 
    my($pod) = @_;
479
 
 
480
 
    my $screenheight = $pod->screenheight;
481
 
    my $mbar = $pod->Subwidget('menubar');
482
 
    my $sectionmenu = $mbar->Subwidget('sectionmenu');
483
 
    if (defined $sectionmenu) {
484
 
        $sectionmenu->delete(0, 'end');
485
 
    } else {
486
 
        $mbar->insert($mbar->index("last"), "cascade",
487
 
                      '-label' => 'Section', -underline => 1);
488
 
        $sectionmenu = $mbar->Menu;
489
 
        $mbar->entryconfigure($mbar->index("last")-1, -menu => $sectionmenu);
490
 
        $mbar->Advertise(sectionmenu => $sectionmenu);
491
 
    }
492
 
 
493
 
    my $podtext = $pod->Subwidget('pod');
494
 
    my $text    = $podtext->Subwidget('more')->Subwidget('text');
495
 
 
496
 
    $text->tag('configure', '_section_mark',
497
 
               -background => 'red',
498
 
               -foreground => 'black',
499
 
              );
500
 
 
501
 
    my $sdef;
502
 
    foreach $sdef (@{$podtext->{'sections'}}) {
503
 
        my($head_level, $subject, $pos) = @$sdef;
504
 
 
505
 
        my @args;
506
 
        if ($sectionmenu &&
507
 
            $sectionmenu->yposition("last") > $screenheight-40) {
508
 
            push @args, -columnbreak => 1;
509
 
        }
510
 
 
511
 
        $sectionmenu->command
512
 
          (-label => ("  " x ($head_level-1)) . $subject,
513
 
           -command => sub {
514
 
               my($line) = split(/\./, $pos);
515
 
               $text->tag('remove', '_section_mark', qw/0.0 end/);
516
 
               $text->tag('add', '_section_mark',
517
 
                          $line-1 . ".0",
518
 
                          $line-1 . ".0 lineend");
519
 
               $text->yview("_section_mark.first");
520
 
               $text->after(500, [$text, qw/tag remove _section_mark 0.0 end/]);
521
 
           },
522
 
           @args,
523
 
          );
524
 
    }
525
 
}
526
 
 
527
 
sub tree {
528
 
    my $w = shift;
529
 
    if (@_) {
530
 
        my $val = shift;
531
 
        $w->{Tree_on} = $val;
532
 
        my $tree = $w->Subwidget('tree');
533
 
        my $p = $w->Subwidget("pod");
534
 
        if ($val) {
535
 
            $p->packForget;
536
 
            $tree->packAdjust(-side => 'left', -fill => 'y');
537
 
            $p->pack(-side => "left", -expand => 1, -fill => 'both');
538
 
            if (!$tree->Filled) {
539
 
                $w->_configure_tree;
540
 
                $w->Busy(-recurse => 1);
541
 
                eval {
542
 
                    $tree->Fill;
543
 
                };
544
 
                my $err = $@;
545
 
                $w->Unbusy;
546
 
                if ($err) {
547
 
                    die $err;
548
 
                }
549
 
            }
550
 
            $tree->SeePath("file:" . $p->cget(-path)) if $p->cget(-path);
551
 
        } else {
552
 
            if ($tree && $tree->manager) {
553
 
                $tree->packForget;
554
 
                $p->packForget;
555
 
                eval {
556
 
                    $w->Walk
557
 
                        (sub {
558
 
                             my $w = shift;
559
 
                             if ($w->isa('Tk::Adjuster') &&
560
 
                                 $w->cget(-widget) eq $tree) {
561
 
                                 $w->destroy;
562
 
                                 die;
563
 
                             }
564
 
                         });
565
 
                };
566
 
                $p->pack(-side => "left", -expand => 1, -fill => 'both');
567
 
            }
568
 
        }
569
 
    }
570
 
    $w->{Tree_on};
571
 
}
572
 
 
573
 
sub _configure_tree {
574
 
    my($w) = @_;
575
 
    my $tree = $w->Subwidget("tree");
576
 
    my $p    = $w->Subwidget("pod");
577
 
 
578
 
    my $common_showcommand = sub {
579
 
        my($e) = @_;
580
 
        my $uri = $e->uri;
581
 
        my $type = $e->type;
582
 
        if (defined $type && $type eq 'func') {
583
 
            my $text = $Tk::Pod::Tree::FindPods->function_pod($e->name);
584
 
            (-text => $text, -title => $e->name);
585
 
        } elsif (defined $uri && $uri =~ /^file:(.*)/) {
586
 
            (-file => $1);
587
 
        } else {
588
 
            # ignore
589
 
        }
590
 
    };
591
 
 
592
 
    $tree->configure
593
 
        (-showcommand  => sub {
594
 
             my $e = $_[1];
595
 
             my %args = $common_showcommand->($e);
596
 
             my $title = delete $args{-title};
597
 
             $p->configure(-title => $title) if defined $title;
598
 
             $p->configure(%args);
599
 
         },
600
 
         -showcommand2 => sub {
601
 
             my $e = $_[1];
602
 
             my @args = $common_showcommand->($e);
603
 
             # XXX -title?
604
 
             $w->clone(-tree => !!$tree,
605
 
                       @args);
606
 
         },
607
 
        );
608
 
}
609
 
 
610
 
sub SearchFAQ {
611
 
    my($cw, $p) = @_;
612
 
    my $t = $cw->Toplevel(-title => "Perl FAQ Search");
613
 
    $t->transient($cw);
614
 
    $t->grab;
615
 
    my($keyword, $go, $e);
616
 
    {
617
 
        my $Entry = 'Entry';
618
 
        eval {
619
 
            require Tk::HistEntry;
620
 
            Tk::HistEntry->VERSION(0.40);
621
 
            $Entry = "HistEntry";
622
 
        };
623
 
 
624
 
        my $f = $t->Frame->pack(-fill => "x");
625
 
        $f->Label(-text => "FAQ keyword:")->pack(-side => "left");
626
 
        $e = $f->$Entry(-textvariable => \$keyword)->pack(-side => "left");
627
 
        if ($e->can('history') && $searchfaq_history) {
628
 
            $e->history($searchfaq_history);
629
 
        }
630
 
        $e->focus;
631
 
        $go = 0;
632
 
        $e->bind("<Return>" => sub { $go = 1 });
633
 
        $e->bind("<Escape>" => sub { $go = -1 });
634
 
    }
635
 
    {
636
 
        my $f = $t->Frame->pack;
637
 
        $f->Button(-text => "OK",
638
 
                   -command => sub { $go = 1 })->pack(-side => "left");
639
 
        $f->Button(-text => "New window",
640
 
                   -command => sub { $go = 2 })->pack(-side => "left");
641
 
        $f->Button(-text => "Cancel",
642
 
                   -command => sub { $go = -1 })->pack(-side => "left");
643
 
    }
644
 
    $t->Popup(-popover => $cw);
645
 
    $t->OnDestroy(sub { $go = -1 unless $go });
646
 
    $t->waitVariable(\$go);
647
 
    if (Tk::Exists($t)) {
648
 
        if (defined $keyword && $keyword ne "" && $go > 0 && $e->can('historyAdd')) {
649
 
            $e->historyAdd($keyword);
650
 
            $searchfaq_history = [ $e->history ];
651
 
        }
652
 
        $t->grabRelease;
653
 
        $t->destroy;
654
 
    }
655
 
    if (defined $keyword && $keyword ne "") {
656
 
        if ($go) {
657
 
            require File::Temp;
658
 
            my($fh, $pod) = File::Temp::tempfile(UNLINK => 1,
659
 
                                                 SUFFIX => ".pod");
660
 
            my $out = `perldoc -u -q $keyword`; # XXX protect keyword
661
 
            print $fh $out;
662
 
            close $fh;
663
 
 
664
 
            if (-z $pod) {
665
 
                $cw->messageBox(-title   => "No FAQ keyword",
666
 
                                -icon    => "error",
667
 
                                -message => "FAQ keyword not found",
668
 
                               );
669
 
            } else {
670
 
                if ($go == 1) {
671
 
                    $cw->configure(-file => $pod);
672
 
                } elsif ($go == 2) {
673
 
                    my $new_cw = $cw->clone('-file' => $pod);
674
 
                }
675
 
            }
676
 
        }
677
 
    }
678
 
}
679
 
 
680
 
sub zoom {
681
 
    my($w, $method) = @_;
682
 
    my $p = $w->Subwidget("pod");
683
 
    $p->$method();
684
 
    $w->set_base_font_size($p->base_font_size);
685
 
}
686
 
 
687
 
sub zoom_in     { shift->zoom("zoom_in") }
688
 
sub zoom_out    { shift->zoom("zoom_out") }
689
 
sub zoom_normal { shift->zoom("zoom_normal") }
690
 
 
691
 
sub base_font_size {
692
 
    my $w = shift;
693
 
    $w->{Base_Font_Size};
694
 
}
695
 
 
696
 
sub set_base_font_size {
697
 
    my($w, $font_size) = @_;
698
 
    $w->{Base_Font_Size} = $font_size;
699
 
}
700
 
 
701
 
sub clone {
702
 
    my($w, %pod_args) = @_;
703
 
    my %pre_args;
704
 
    for ('-tree', '-exitbutton') {
705
 
        if (exists $pod_args{$_}) {
706
 
            $pre_args{$_} = delete $pod_args{$_};
707
 
        } else {
708
 
            $pre_args{$_} = $w->cget($_);
709
 
        }
710
 
    }
711
 
    my $new_w = $w->MainWindow->Pod
712
 
        (%pre_args,
713
 
         '-basefontsize' => $w->base_font_size,
714
 
        );
715
 
    $new_w->configure(%pod_args) if %pod_args;
716
 
    $new_w;
717
 
}
718
 
 
719
 
1;
720
 
 
721
 
__END__
722
 
 
723
 
=head1 NAME
724
 
 
725
 
Tk::Pod - Pod browser toplevel widget
726
 
 
727
 
 
728
 
=head1 SYNOPSIS
729
 
 
730
 
    use Tk::Pod
731
 
 
732
 
    Tk::Pod->Dir(@dirs)                 # add dirs to search path for Pod
733
 
 
734
 
    $pod = $parent->Pod(
735
 
                -file = > $name,        # search and display Pod for name
736
 
                -tree = > $bool         # display pod file tree
737
 
                );
738
 
 
739
 
 
740
 
=head1 DESCRIPTION
741
 
 
742
 
Simple Pod browser with hypertext capabilities in a C<Toplevel> widget
743
 
 
744
 
=head1 OPTIONS
745
 
 
746
 
=over
747
 
 
748
 
=item -tree
749
 
 
750
 
Set tree view by default on or off. Default is false.
751
 
 
752
 
=item -exitbutton
753
 
 
754
 
Add to the menu an exit entry. This is only useful for standalone pod
755
 
readers. Default is false. This option can only be set on construction
756
 
time.
757
 
 
758
 
=back
759
 
 
760
 
Other options are propagated to the embedded L<Tk::Pod::Text> widget.
761
 
 
762
 
=head1 BUGS
763
 
 
764
 
If you set C<-file> while creating the Pod widget,
765
 
 
766
 
    $parent->Pod(-tree => 1, -file => $pod);
767
 
 
768
 
then the title will not be displayed correctly. This is because the
769
 
internal setting of C<-title> may override the title setting caused by
770
 
C<-file>. So it is better to configure C<-file> separately:
771
 
 
772
 
    $pod = $parent->Pod(-tree => 1);
773
 
    $pod->configure(-file => $pod);
774
 
 
775
 
=head1 SEE ALSO
776
 
 
777
 
L<Tk::Pod_usage|Tk::Pod_usage>
778
 
L<Tk::Pod::Text|Tk::Pod::Text>
779
 
L<tkpod|tkpod>
780
 
L<perlpod|perlpod>
781
 
 
782
 
=head1 AUTHOR
783
 
 
784
 
Nick Ing-Simmons <F<nick@ni-s.u-net.com>>
785
 
 
786
 
Current maintainer is Slaven Rezic <F<slaven@rezic.de>>.
787
 
 
788
 
Copyright (c) 1997-1998 Nick Ing-Simmons.  All rights reserved.  This program
789
 
is free software; you can redistribute it and/or modify it under the same
790
 
terms as Perl itself.
791
 
 
792
 
=cut