File Coverage

blib/lib/Symbol/Approx/Sub.pm

Criterion	Covered	Total	%
statement	106	119	89.1
branch	33	44	75.0
condition			n/a
subroutine	9	9	100.0
pod			n/a
total	148	172	86.0

line	stmt	bran	sub	time	code
1					# $Id$
2
3					=head1 NAME
4
5					Symbol::Approx::Sub - Perl module for calling subroutines by approximate names!
6
7					=head1 SYNOPSIS
8
9					use Symbol::Approx::Sub;
10
11					sub a {
12					# blah...
13					}
14
15					&aa; # executes &a if &aa doesn't exist.
16
17					use Symbol::Approx::Sub (xform => 'Text::Metaphone');
18					use Symbol::Approx::Sub (xform => undef,
19					match => 'String::Approx');
20					use Symbol::Approx::Sub (xform => 'Text::Soundex');
21					use Symbol::Approx::Sub (xform => \&my_transform);
22					use Symbol::Approx::Sub (xform => [\&my_transform, 'Text::Soundex']);
23					use Symbol::Approx::Sub (xform => \&my_transform,
24					match => \&my_matcher,
25					choose => \&my_chooser);
26
27
28					=head1 DESCRIPTION
29
30					This is _really_ stupid. This module allows you to call subroutines by
31					_approximate_ names. Why you would ever want to do this is a complete
32					mystery to me. It was written as an experiment to see how well I
33					understood typeglobs and AUTOLOADing.
34
35					To use it, simply include the line:
36
37					use Symbol::Approx::Sub;
38
39					somewhere in your program. Then, each time you call a subroutine that doesn't
40					exist in the the current package, Perl will search for a subroutine with
41					approximately the same name. The meaning of 'approximately the same' is
42					configurable. The default is to find subroutines with the same Soundex
43					value (as defined by Text::Soundex) as the missing subroutine. There are
44					two other built-in matching styles using Text::Metaphone and
45					String::Approx. To use either of these use:
46
47					use Symbol::Approx::Sub (xform => 'Text::Metaphone');
48
49					or
50
51					use Symbol::Approx::Sub (xform => undef,
52					match => 'String::Approx');
53
54					when using Symbol::Approx::Sub.
55
56					=head2 Configuring The Fuzzy Matching
57
58					There are three phases to the matching process. They are:
59
60					=over 4
61
62					=item *
63
64					B<transform> - a transform subroutine applies some kind of transformation
65					to the subroutine names. For example the default transformer applies the
66					Soundex algorithm to each of the subroutine names. Other obvious
67					tranformations would be to remove all the underscores or to change the
68					names to lower case.
69
70					A transform subroutine should simply apply its transformation to each
71					item in its parameter list and return the transformed list. For example, a
72					transformer that removed underscores from its parameters would look like
73					this:
74
75					sub tranformer {
76					map { s/_//g; $_ } @_;
77					}
78
79					Transform subroutines can be chained together.
80
81					=item *
82
83					B<match> - a match subroutine takes a target string and a list of other
84					strings. It matches each of the strings against the target and determines
85					whether or not it 'matches' according to some criteria. For example, the
86					default matcher simply checks to see if the strings are equal.
87
88					A match subroutine is passed the target string as its first parameter,
89					followed by the list of potential matches. For each string that matches,
90					the matcher should return the index number from the input list. For example,
91					the default matcher is implemented like this:
92
93					sub matcher {
94					my ($sub, @subs) = @_;
95					my (@ret);
96
97					foreach (0 .. $#subs) {
98					push @ret, $_ if $sub eq $subs[$_];
99					}
100
101					@ret;
102					}
103
104					=item *
105
106					B<choose> - a chooser subroutine takes a list of matches and chooses exactly
107					one item from the list. The default matcher chooses one item at random.
108
109					A chooser subroutine is passed a list of matches and must simply return one
110					index number from that list. For example, the default chooser is implemented
111					like this:
112
113					sub chooser {
114					rand @_;
115					}
116
117					=back
118
119					You can override any of these behaviours by writing your own transformer,
120					matcher or chooser. You can either define the subroutine in your own
121					script or you can put the subroutine in a separate module which
122					Symbol::Approx::Sub can then use as a I<plug-in>. See below for more details
123					on plug-ins.
124
125					To use your own function, simply pass a reference to the subroutine to the
126					C<use Symbol::Approx::Sub> line like this:
127
128					use Symbol::Approx::Sub(xform => \&my_transform,
129					match => \&my_matcher,
130					choose => \&my_chooser);
131
132					A plug-in is simply a module that lives in the Symbol::Approx::Sub
133					namespace. For example, if you had a line of code like this:
134
135					use Symbol::Approx::Sub(xform => 'MyTransform');
136
137					then Symbol::Approx::Sub will try to load a module called
138					Symbol::Approx::Sub::MyTransform and it will use a function from within that
139					module called C<transform> as the transform function. Similarly, the
140					matcher function is called C<match> and the chooser function is called
141					C<choose>.
142
143					The default transformer, matcher and chooser are available as plug-ins
144					called Text::Soundex, String::Equal and Random.
145
146					=cut
147
148					package Symbol::Approx::Sub;
149
150					require 5.006_000;
151	12		12	402041	use strict;
	12			16
	12			229
152	12		12	37	use warnings;
	12			12
	12			452
153
154					our ($VERSION, @ISA, $AUTOLOAD);
155
156	12		12	41	use Devel::Symdump;
	12			15
	12			394
157
158					$VERSION = sprintf "%d", '$Revision$ ' =~ /(\d+)/;
159
160	12		12	38	use Carp;
	12			12
	12			1448
161
162					# List of functions that we _never_ try to match approximately.
163					my @_BARRED = qw(AUTOLOAD BEGIN CHECK INIT DESTROY END);
164					my %_BARRED = (1) x @_BARRED;
165
166					sub _pkg2file {
167	27		27	30	$_ = shift;
168	27			112	s\|::\|/\|g;
169	27			3988	"$_.pm";
170					}
171
172					# import is called when another script uses this module.
173					# All we do here is overwrite the caller's AUTOLOAD subroutine
174					# with our own.
175
176					=head1 Subroutines
177
178					=head2 import
179
180					Called when the module is C<use>d. This function installs our AUTOLOAD
181					subroutine into the caller's symbol table.
182
183					=cut
184
185					sub import {
186	14		14	69886	my $class = shift;
187
188	12		12	45	no strict 'refs'; # WARNING: Deep magic here!
	12			10
	12			9116
189
190	14			16	my %param;
191	14			13	my %CONF;
192	14	100		48	%param = @_ if @_;
193
194	14			31	my %defaults = (xform => 'Text::Soundex',
195					match => 'String::Equal',
196					choose => 'Random');
197
198					# Work out which transformer(s) to use. The valid options are:
199					# 1/ $param{xform} doesn't exist. Use default transformer.
200					# 2/ $param{xform} is undef. Use no transformers.
201					# 3/ $param{xform} is a reference to a subroutine. Use the
202					# referenced subroutine as the transformer.
203					# 4/ $param{xform} is a scalar. This is the name of a transformer
204					# module which should be loaded.
205					# 5/ $param{xform} is a reference to an array. Each element of the
206					# array is one of the previous two options.
207
208	14	100		26	if (exists $param{xform}) {
209	10	100		22	if (defined $param{xform}) {
210	7			11	my $type = ref $param{xform};
211	7	100		18	if ($type eq 'CODE') {
		100
		100
212	1			2	$CONF{xform} = [$param{xform}];
213					} elsif ($type eq '') {
214	2			4	my $mod = "Symbol::Approx::Sub::$param{xform}";
215	2			4	require(_pkg2file($mod));
216	2			4	$CONF{xform} = [\&{"${mod}::transform"}];
	2			9
217					} elsif ($type eq 'ARRAY') {
218	3			3	foreach (@{$param{xform}}) {
	3			6
219	4			7	my $type = ref $_;
220	4	100		9	if ($type eq 'CODE') {
		100
221	2			1	push @{$CONF{xform}}, $_;
	2			6
222					} elsif ($type eq '') {
223	1			1	my $mod = "Symbol::Approx::Sub::$_";
224	1			2	require(_pkg2file($mod));
225	1			1	push @{$CONF{xform}}, \&{"${mod}::transform"};
	1			2
	1			5
226					} else {
227	1			90	croak 'Invalid transformer passed to Symbol::Approx::Sub';
228					}
229					}
230					} else {
231	1			177	croak 'Invalid transformer passed to Symbol::Approx::Sub';
232					}
233					} else {
234	3			5	$CONF{xform} = [];
235					}
236					} else {
237	4			8	my $mod = "Symbol::Approx::Sub::$defaults{xform}";
238	4			8	require(_pkg2file($mod));
239	4			6	$CONF{xform} = [\&{"${mod}::transform"}];
	4			16
240					}
241
242					# Work out which matcher to use. The valid options are:
243					# 1/ $param{match} doesn't exist. Use default matcher.
244					# 2/ $param{match} is undef. Use no matcher.
245					# 3/ $param{match} is a reference to a subroutine. Use the
246					# referenced subroutine as the matcher.
247					# 4/ $param{match} is a scalar. This is the name of a matcher
248					# module which should be loaded.
249
250	12	100		27	if (exists $param{match}) {
251	4	50		7	if (defined $param{match}) {
252	4			11	my $type = ref $param{match};
253	4	50		10	if ($type eq 'CODE') {
		0
254	4			5	$CONF{match} = $param{match};
255					} elsif ($type eq '') {
256	0			0	my $mod = "Symbol::Approx::Sub::$param{match}";
257	0			0	require(_pkg2file($mod));
258	0			0	$CONF{match} = \&{"${mod}::match"};
	0			0
259					} else {
260	0			0	croak 'Invalid matcher passed to Symbol::Approx::Sub';
261					}
262					} else {
263	0			0	$CONF{match} = undef;
264					}
265					} else {
266	8			15	my $mod = "Symbol::Approx::Sub::$defaults{match}";
267	8			12	require(_pkg2file($mod));
268	8			14	$CONF{match} = \&{"${mod}::match"};
	8			29
269					}
270
271					# Work out which chooser to use. The valid options are:
272					# 1/ $param{choose} doesn't exist. Use default chooser.
273					# 2/ $param{choose} is undef. Use default chooser.
274					# 3/ $param{choose} is a reference to a subroutine. Use the
275					# referenced subroutine as the chooser.
276					# 4/ $param{choose} is a scalar. This is the name of a chooser
277					# module which should be loaded.
278
279	12	100		27	if (exists $param{choose}) {
280	1	50		2	if (defined $param{choose}) {
281	1			2	my $type = ref $param{choose};
282	1	50		2	if ($type eq 'CODE') {
		50
283	0			0	$CONF{chooser} = $param{chooser};
284					} elsif ($type eq '') {
285	1			2	my $mod = "Symbol::Approx::Sub::$param{choose}";
286	1			2	require(_pkg2file($mod));
287	1			2	$CONF{choose} = \&{"${mod}::choose"};
	1			9
288					} else {
289	0			0	croak 'Invalid chooser passed to Symbol::Approx::Sub';
290					}
291					} else {
292	0			0	my $mod = "Symbol::Approx::Sub::$defaults{choose}";
293	0			0	require(_pkg2file($mod));
294	0			0	$CONF{choose} = \&{"4mod::choose"};
	0			0
295					}
296					} else {
297	11			17	my $mod = "Symbol::Approx::Sub::$defaults{choose}";
298	11			19	require(_pkg2file($mod));
299	11			19	$CONF{choose} = \&{"${mod}::choose"};
	11			46
300					}
301
302					# Now install appropriate AUTOLOAD routine in caller's package
303
304	12			19	my $pkg = caller(0);
305	12			32	*{"${pkg}::AUTOLOAD"} = _make_AUTOLOAD(%CONF);
	12			212710
306					}
307
308					# Create a subroutine which is called when a given subroutine
309					# name can't be found in the current package. In the import subroutine
310					# above, we have already arranged that our calling package will use
311					# the AUTOLOAD created here instead of its own.
312					sub _make_AUTOLOAD {
313	12		12	37	my %CONF = @_;
314
315					return sub {
316	14		14	614658	my @c = caller(0);
317	14			90	my ($pkg, $sub) = $AUTOLOAD =~ /^(.)::(.)$/;
318
319					# Get a list of all of the subroutines in the current package
320					# using the get_subs function from GlobWalker.pm
321					# Note that we deliberately omit function names that exist
322					# in the %_BARRED hash
323	14			21	my (@subs, @orig);
324	14			11959	my $sym = Devel::Symdump->new($pkg);
325	322			558	@orig = @subs = grep { ! $_BARRED{$_} }
	322			562
326	322			387	map { s/${pkg}:://; $_ }
	333			468
327	14			636	grep { defined &{$_} } $sym->functions($pkg);
	333			259
328
329	14			117	unshift @subs, $sub;
330
331					# Transform all of the subroutine names
332	14			17	foreach (@{$CONF{xform}}) {
	14			29
333	12	50		75	croak "Invalid transformer passed to Symbol::Approx::Sub\n"
334					unless defined &$_;
335	12			98	@subs = $_->(@subs);
336					}
337
338					# Call the subroutine that will look for matches
339					# The matcher returns a list of the _indexes_ that match
340	14			87	my @match_ind;
341	14	50		33	if ($CONF{match}) {
342	14			33	croak "Invalid matcher passed to Symbol::Approx::Sub\n"
343	14	50		12	unless defined &{$CONF{match}};
344	14			80	@match_ind = $CONF{match}->(@subs);
345					} else {
346	0			0	@match_ind = @subs[1 .. $#subs];
347					}
348
349	14			71	shift @subs;
350
351	14			40	@subs = @subs[@match_ind];
352	14			45	@orig = @orig[@match_ind];
353
354					# If we've got more than one matched subroutine, then call the
355					# chooser to pick one.
356					# Call the matched subroutine using magic goto.
357					# If no match was found, die recreating Perl's usual behaviour.
358	14	100		27	if (@match_ind) {
359	13	100		27	if (@match_ind == 1) {
360	12			28	$sub = "${pkg}::" . $orig[0];
361					} else {
362	1	50		2	croak "Invalid chooser passed to Symbol::Approx::Sub\n"
363					unless defined $CONF{choose};
364	1			5	$sub = "${pkg}::" . $orig[$CONF{choose}->(@subs)];
365					}
366	13			273	goto &$sub;
367					} else {
368	1			28	die "REALLY Undefined subroutine $AUTOLOAD called at $c[1] line $c[2]\n";
369					}
370					}
371	12			95	}
372
373					1;
374					__END__
375
376					=head1 CAVEAT
377
378					I can't stress too strongly that this will make your code completely
379					unmaintainable and you really shouldn't use this module unless you're
380					doing something very stupid.
381
382					=head1 ACKNOWLEDGEMENTS
383
384					This idea came to me whilst sitting in Mark-Jason Dominus' "Tricks of
385					the Wizards" tutorial. In order to protect his reputation, I should
386					probably point out that just as the idea was forming in my head, he
387					clearly said that this kind of thing was a very bad idea.
388
389					Leon Brocard is clearly as mad as me as he pointed out some important bugs
390					and helped massively with the 'fuzzy-configurability'.
391
392					Matt Freake helped by pointing out that Perl generally does what you
393					mean, not what you think it should do.
394
395					Robin Houston spotted some nasty problems and (more importantly) supplied
396					patches.
397
398					=head1 AUTHOR
399
400					Dave Cross <dave@dave.org.uk>
401
402					With lots of help from Leon Brocard <leon@astray.com>
403
404					=head1 LICENSE
405
406					Copyright (C) 2000-2008, Magnum Solutions Ltd. All Rights Reserved.
407
408					This script is free software; you can redistribute it and/or modify it
409					under the same terms as Perl itself.
410
411					=head1 SEE ALSO
412
413					perl(1).
414
415					=cut
416