← Back to branch summary

~ubuntu-branches/ubuntu/gutsy/horae/gutsy

« back to all changes in this revision

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

  • Committer: Bazaar Package Importer
  • Author(s): Carlo Segre
  • Date: 2006-12-28 12:36:48 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20061228123648-9xnjr76wfthd92cq
Tags: 064-1
New upstream release, dropped dependency on libtk-filedialog-perl.

Show diffs side-by-side

added added

removed removed

Lines of Context:
0CPAN/Tk-Pod-0.9932/Pod/Search.pm
1
 
package Tk::Pod::Search;
2
 
 
3
 
use strict;
4
 
use vars qw(@ISA $VERSION);
5
 
 
6
 
$VERSION = sprintf("%d.%02d", q$Revision: 5.3 $ =~ /(\d+)\.(\d+)/);
7
 
 
8
 
use Carp;
9
 
use Tk::Frame;
10
 
 
11
 
Construct Tk::Widget 'PodSearch';
12
 
@ISA = 'Tk::Frame';
13
 
 
14
 
my $searchfull_history;
15
 
 
16
 
sub Populate {
17
 
    my ($cw, $args) = @_;
18
 
 
19
 
    my $Entry;
20
 
    eval {
21
 
        require Tk::HistEntry;
22
 
        $Entry = "HistEntry";
23
 
    };
24
 
    if ($@) {
25
 
        require Tk::BrowseEntry;
26
 
        $Entry = "BrowseEntry";
27
 
    }
28
 
 
29
 
    my $l = $cw->Scrolled('Listbox',-width=>40,-scrollbars=>$Tk::platform eq 'MSWin32'?'e':'w');
30
 
    #xxx BrowseEntry V1.3 does not honour -label at creation time :-(
31
 
    #my $e = $cw->BrowseEntry(-labelPack=>[-side=>'left'],-label=>'foo',
32
 
        #-listcmd=> ['_logit', 'list'],
33
 
        #-browsecmd=> ['_logit', 'browse'],
34
 
        #);
35
 
    my $f = $cw->Frame;
36
 
    my $e = $f->$Entry();
37
 
    if ($e->can('history') && $searchfull_history) {
38
 
        $e->history($searchfull_history);
39
 
    }
40
 
    my $s = $f->Label();
41
 
 
42
 
    $l->pack(-fill=>'both', -side=>'top',  -expand=>1);
43
 
    $f->pack(-fill => "x", -side => "top");
44
 
    $s->pack(-anchor => 'e', -side=>'left');
45
 
    $e->pack(-fill=>'x', -side=>'left', -expand=>1);
46
 
 
47
 
    my $current_path = delete $args->{-currentpath};
48
 
    $cw->{RestrictPod} = undef;
49
 
    my $cb;
50
 
    if (defined $current_path && $current_path ne "") {
51
 
        $cb = $cw->Checkbutton(-variable => \$cw->{RestrictPod},
52
 
                               -text => "Restrict to $current_path",
53
 
                               -anchor => "w",
54
 
                               -onvalue => $current_path,
55
 
                               -offvalue => undef,
56
 
                              )->pack(-fill => "x",
57
 
                                      -side => "top",
58
 
                                     );
59
 
    }
60
 
 
61
 
    $cw->Advertise( 'entry'     => $e->Subwidget('entry')   );
62
 
    $cw->Advertise( 'listbox'   => $l->Subwidget('listbox') );
63
 
    $cw->Advertise( 'browse'    => $e);
64
 
    $cw->Advertise( 'restrict'  => $cb) if $cb;
65
 
 
66
 
    $cw->Delegates(
67
 
                'focus' => $cw->Subwidget('entry'),
68
 
                );
69
 
 
70
 
    $cw->ConfigSpecs(
71
 
                -label =>       [{-text=>$s}, 'label',    'Label',    'Search:'],
72
 
                -indexdir =>    ['PASSIVE',   'indexDir', 'IndexDir', undef],
73
 
                -command =>     ['CALLBACK',  undef,      undef,      undef],
74
 
                -search =>      ['METHOD',    'search',   'Search',   ""],
75
 
                'DEFAULT' =>    [ $cw ],
76
 
                );
77
 
 
78
 
    foreach (qw/Return space 1/) {
79
 
        $cw->Subwidget('listbox')->bind("<$_>", [\&_load_pod, $cw]);
80
 
    }
81
 
    $cw->Subwidget('entry')->bind('<Return>',[\&_search,$cw,$l]);
82
 
 
83
 
    undef;
84
 
}
85
 
 
86
 
sub addHistory {
87
 
    my ($w, $obj) = @_;
88
 
 
89
 
    my $entry_or_browse = $w->Subwidget('browse');
90
 
    if ($entry_or_browse->can('historyAdd')) {
91
 
        $entry_or_browse->historyAdd($obj);
92
 
        $searchfull_history = [ $entry_or_browse->history ];
93
 
    } else {
94
 
        $entry_or_browse->insert(0,$obj);
95
 
    }
96
 
}
97
 
 
98
 
sub _logit { print "logit=|", join('|',@_),"|\n"; }
99
 
 
100
 
sub search {
101
 
    my $cw = shift;
102
 
    my $e = $cw->Subwidget('entry');
103
 
    if (@_) {
104
 
        my $search = shift;
105
 
        $search = join(' ', @$search) if ref($search) eq 'ARRAY';
106
 
        $e->delete(0,'end');
107
 
        $e->insert(0,$search);
108
 
        return undef;
109
 
    } else {
110
 
        return $e->get;
111
 
    }
112
 
}
113
 
 
114
 
sub _load_pod {
115
 
    my $l = shift;
116
 
    my $cw = shift;
117
 
 
118
 
    my $pod = pretty2path( $l->get(($l->curselection)[0]));
119
 
 
120
 
    $cw->Callback('-command', $pod, -searchterm => $cw->search());
121
 
}
122
 
 
123
 
 
124
 
sub _search {
125
 
    my $e = shift;
126
 
    my $w = shift;
127
 
    my $l = shift;
128
 
 
129
 
    my $find = $e->get;
130
 
    $w->addHistory($find) if $find ne '';
131
 
 
132
 
    my %args;
133
 
    if ($w->{RestrictPod}) {
134
 
        $args{-restrictpod} = $w->{RestrictPod};
135
 
    }
136
 
 
137
 
    #xxx: always open/close DBM files???
138
 
    my $idx;
139
 
    eval {
140
 
        require Tk::Pod::Search_db;
141
 
        $idx = Tk::Pod::Search_db->new($w->{Configure}{-indexdir});
142
 
    };
143
 
    if ($@) {
144
 
        $e->messageBox(-icon => 'error',
145
 
                       -title => 'perlindex error',
146
 
                       -message => <<EOF);
147
 
Can't create Tk::Pod::Search_db object:
148
 
Is perlindex installed and did you run
149
 
perlindex -index?
150
 
EOF
151
 
        die $@;
152
 
    }
153
 
    my @hits = $idx->searchWords($find, %args);
154
 
    if (@hits) {
155
 
        $l->delete(0,'end');
156
 
        while (@hits) {
157
 
            $l->insert('end', sprintf("%6.3f  %s", shift @hits,
158
 
                         path2pretty($idx->prefix . '/'. shift(@hits)) )
159
 
                        );
160
 
        }
161
 
        $l->see(0);
162
 
        $l->activate(0);
163
 
        $l->selectionSet(0);
164
 
        $l->focus;
165
 
    } else {
166
 
        my $msg = "No Pod documentation in Library matches: '$find'";
167
 
        $e->messageBox(-icon => "error",
168
 
                       -title => "No match",
169
 
                       -message => $msg);
170
 
        die $msg;
171
 
    }
172
 
}
173
 
 
174
 
# Converts  /where/ever/it/it/Mod/Sub/Name.pm
175
 
# to        Mod/Sub/Name.pm   (/where/ever/it/is)
176
 
# and vice versa.  Assumes that module subdirectories
177
 
# start with an upper case char. (xxx: Better solution
178
 
# when perlindex gives more infos.
179
 
 
180
 
sub path2pretty {
181
 
    my @path = split '/', shift, -1;
182
 
#    shift @path if $path[0] eq "";     # due to leading /
183
 
    my $pretty = pop(@path);
184
 
    while (@path) {
185
 
        last if $path[-1] !~ /^[A-Z]/;
186
 
        $pretty = pop(@path) . '/' . $pretty;
187
 
    }
188
 
    #xxx is there a min 40c_or_more format directive?
189
 
    sprintf "%-40s (%s)", $pretty, join('/',@path);
190
 
}
191
 
 
192
 
sub pretty2path {
193
 
    local($_) = shift;
194
 
    /([^\s]+) \s+\( (.*) \)/x;
195
 
    $2 . '/' . $1;
196
 
}
197
 
 
198
 
#$path = '/where/ever/it/is/Tk/Pod.pm'; print "orig|",$path, "|\n";
199
 
#$nice = path2pretty $path;             print "nice|",$nice, "|\n";
200
 
#$path =  pretty2path $nice;            print "path|",$path, "|\n";
201
 
 
202
 
 
203
 
1;
204
 
__END__
205
 
 
206
 
=head1 NAME
207
 
 
208
 
Tk::Pod::Search - Widget to access perlindex Pod full text index
209
 
 
210
 
=for section General Purpose Widget
211
 
 
212
 
=head1 SYNOPSIS
213
 
 
214
 
    use Tk::Pod::Search;
215
 
    ...
216
 
    $widget = $parent->PodSearch( ... );
217
 
    ...
218
 
    $widget->configure( -search => WORDS_TO_SEARCH );
219
 
 
220
 
 
221
 
=head1 DESCRIPTION
222
 
 
223
 
GUI interface to the full Pod text indexer B<perlindex>.
224
 
 
225
 
=head1 OPTIONS
226
 
 
227
 
=over 4
228
 
 
229
 
=item B<Class:> Search
230
 
 
231
 
=item B<Member:> search
232
 
 
233
 
=item B<Option:> -search
234
 
 
235
 
Expects a list of words (or a whitespace seperated list).
236
 
 
237
 
=item B<Class:> undef
238
 
 
239
 
=item B<Member:> undef
240
 
 
241
 
=item B<Option:> -command
242
 
 
243
 
Defines a call back that is called when the use selects
244
 
a Pod file. It gets the full path name of the Pod file
245
 
as argument.
246
 
 
247
 
=back
248
 
 
249
 
 
250
 
=head1 METHODS
251
 
 
252
 
=over 4
253
 
 
254
 
=item I<$widget>->B<method1>I<(...,?...?)>
255
 
 
256
 
=back
257
 
 
258
 
 
259
 
=head1 SEE ALSO
260
 
 
261
 
Tk::Pod::Text, tkpod, perlindex, Tk::Pod, Tk::Pod::Search_db
262
 
 
263
 
=head1 KEYWORDS
264
 
 
265
 
widget, tk, pod, search, full text
266
 
 
267
 
=head1 AUTHOR
268
 
 
269
 
Achim Bohnet <F<ach@mpe.mpg.de>>
270
 
 
271
 
Current maintainer is Slaven Rezic <F<slaven@rezic.de>>.
272
 
 
273
 
Copyright (c) 1997-1998 Achim Bohnet. All rights reserved.  This program
274
 
is free software; you can redistribute it and/or modify it under the same
275
 
terms as Perl itself.
276
 
 
277
 
=cut
278