← Back to branch summary

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

« back to all changes in this revision

Viewing changes to 0CPAN/Text-Glob-0.06/lib/Text/Glob.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/Text-Glob-0.06/lib/Text/Glob.pm
1
 
package Text::Glob;
2
 
use strict;
3
 
use Exporter;
4
 
use vars qw/$VERSION @ISA @EXPORT_OK
5
 
            $strict_leading_dot $strict_wildcard_slash/;
6
 
$VERSION = '0.06';
7
 
@ISA = 'Exporter';
8
 
@EXPORT_OK = qw( glob_to_regex match_glob );
9
 
 
10
 
$strict_leading_dot    = 1;
11
 
$strict_wildcard_slash = 1;
12
 
 
13
 
use constant debug => 0;
14
 
 
15
 
sub glob_to_regex {
16
 
    my $glob = shift;
17
 
    my ($regex, $in_curlies, $escaping);
18
 
    local $_;
19
 
    my $first_byte = 1;
20
 
    for ($glob =~ m/(.)/gs) {
21
 
        if ($first_byte) {
22
 
            if ($strict_leading_dot) {
23
 
                $regex .= '(?=[^\.])' unless $_ eq '.';
24
 
            }
25
 
            $first_byte = 0;
26
 
        }
27
 
        if ($_ eq '/') {
28
 
            $first_byte = 1;
29
 
        }
30
 
        if ($_ eq '.' || $_ eq '(' || $_ eq ')' || $_ eq '|' ||
31
 
            $_ eq '+' || $_ eq '^' || $_ eq '$' ) {
32
 
            $regex .= "\\$_";
33
 
        }
34
 
        elsif ($_ eq '*') {
35
 
            $regex .= $escaping ? "\\*" :
36
 
              $strict_wildcard_slash ? "[^/]*" : ".*";
37
 
        }
38
 
        elsif ($_ eq '?') {
39
 
            $regex .= $escaping ? "\\?" :
40
 
              $strict_wildcard_slash ? "[^/]" : ".";
41
 
        }
42
 
        elsif ($_ eq '{') {
43
 
            $regex .= $escaping ? "\\{" : "(";
44
 
            ++$in_curlies unless $escaping;
45
 
        }
46
 
        elsif ($_ eq '}' && $in_curlies) {
47
 
            $regex .= $escaping ? "}" : ")";
48
 
            --$in_curlies unless $escaping;
49
 
        }
50
 
        elsif ($_ eq ',' && $in_curlies) {
51
 
            $regex .= $escaping ? "," : "|";
52
 
        }
53
 
        elsif ($_ eq "\\") {
54
 
            if ($escaping) {
55
 
                $regex .= "\\\\";
56
 
                $escaping = 0;
57
 
            }
58
 
            else {
59
 
                $escaping = 1;
60
 
            }
61
 
            next;
62
 
        }
63
 
        else {
64
 
            $regex .= $_;
65
 
            $escaping = 0;
66
 
        }
67
 
        $escaping = 0;
68
 
    }
69
 
    print "# $glob $regex\n" if debug;
70
 
    qr/^$regex$/;
71
 
}
72
 
 
73
 
sub match_glob {
74
 
    print "# ", join(', ', map { "'$_'" } @_), "\n" if debug;
75
 
    my $glob = shift;
76
 
    my $regex = glob_to_regex $glob;
77
 
    local $_;
78
 
    grep { $_ =~ $regex } @_;
79
 
}
80
 
 
81
 
1;
82
 
__END__
83
 
 
84
 
=head1 NAME
85
 
 
86
 
Text::Glob - match globbing patterns against text
87
 
 
88
 
=head1 SYNOPSIS
89
 
 
90
 
 use Text::Glob qw( match_glob glob_to_regex );
91
 
 
92
 
 print "matched\n" if match_glob( "foo.*", "foo.bar" );
93
 
 
94
 
 # prints foo.bar and foo.baz
95
 
 my $regex = glob_to_regex( "foo.*" );
96
 
 for ( qw( foo.bar foo.baz foo bar ) ) {
97
 
     print "matched: $_\n" if /$regex/;
98
 
 }
99
 
 
100
 
=head1 DESCRIPTION
101
 
 
102
 
Text::Glob implements glob(3) style matching that can be used to match
103
 
against text, rather than fetching names from a filesystem.  If you
104
 
want to do full file globbing use the File::Glob module instead.
105
 
 
106
 
=head2 Routines
107
 
 
108
 
=over
109
 
 
110
 
=item match_glob( $glob, @things_to_test )
111
 
 
112
 
Returns the list of things which match the glob from the source list.
113
 
 
114
 
=item glob_to_regex( $glob )
115
 
 
116
 
Returns a compiled regex which is the equiavlent of the globbing
117
 
pattern.
118
 
 
119
 
=back
120
 
 
121
 
=head1 SYNTAX
122
 
 
123
 
The following metacharacters and rules are respected.
124
 
 
125
 
=over
126
 
 
127
 
=item C<*> - match zero or more characters
128
 
 
129
 
C<a*> matches C<a>, C<aa>, C<aaaa> and many many more.
130
 
 
131
 
=item C<?> - match exactly one character
132
 
 
133
 
C<a?> matches C<aa>, but not C<a>, or C<aa>
134
 
 
135
 
=item Character sets/ranges
136
 
 
137
 
C<example.[ch]> matches C<example.c> and C<example.h>
138
 
 
139
 
C<demo.[a-c]> matches C<demo.a>, C<demo.b>, and C<demo.c>
140
 
 
141
 
=item alternation
142
 
 
143
 
C<example.{foo,bar,baz}> matches C<example.foo>, C<example.bar>, and
144
 
C<example.baz>
145
 
 
146
 
=item leading . must be explictly matched
147
 
 
148
 
C<*.foo> does not match C<.bar.foo>.  For this you must either specify
149
 
the leading . in the glob pattern (C<.*.foo>), or set
150
 
C<$Text::Glob::strict_leading_dot> to a false value while compiling
151
 
the regex.
152
 
 
153
 
=item C<*> and C<?> do not match /
154
 
 
155
 
C<*.foo> does not match C<bar/baz.foo>.  For this you must either
156
 
explicitly match the / in the glob (C<*/*.foo>), or set
157
 
C<$Text::Glob::strict_wildcard_slash> to a false value with compiling
158
 
the regex.
159
 
 
160
 
=back
161
 
 
162
 
=head1 BUGS
163
 
 
164
 
The code uses qr// to produce compiled regexes, therefore this module
165
 
requires perl version 5.005_03 or newer.
166
 
 
167
 
=head1 AUTHOR
168
 
 
169
 
Richard Clamp <richardc@unixbeard.net>
170
 
 
171
 
=head1 COPYRIGHT
172
 
 
173
 
Copyright (C) 2002 Richard Clamp.  All Rights Reserved.
174
 
 
175
 
This module is free software; you can redistribute it and/or modify it
176
 
under the same terms as Perl itself.
177
 
 
178
 
=head1 SEE ALSO
179
 
 
180
 
L<File::Glob>, glob(3)
181
 
 
182
 
=cut