Subversion Repositories DevTools

Rev

Rev 6387 | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 6387 Rev 7418
Line 14... Line 14...
14
#
14
#
15
# Usage:
15
# Usage:
16
#               my $search = JatsLocateFiles::new('JatsLocateFiles');
16
#               my $search = JatsLocateFiles::new('JatsLocateFiles');
17
#               my $search = JatsLocateFiles->new();
17
#               my $search = JatsLocateFiles->new();
18
#                  $search->recurse ( );
18
#                  $search->recurse ( );
19
#                  $search->filter_in ( );
19
#                  $search->filter_in ( );          -- Supports multiple arguments
20
#                  $search->filter_in_re ( );
20
#                  $search->filter_in_re ( );       -- Supports multiple arguments
21
#                  $search->filter_out ( );
21
#                  $search->filter_out ( );         -- Supports multiple arguments
22
#                  $search->filter_out_re ( );
22
#                  $search->filter_out_re ( );      -- Supports multiple arguments
23
#                  $search->base_dir ()
23
#                  $search->base_dir ()
24
#                  $search->has_filter ( );
24
#                  $search->has_filter ( );
-
 
25
#                  $search->has_in_filter ( );
-
 
26
#                  $search->has_out_filter ( );
25
#                  $search->full_path ( );
27
#                  $search->full_path ( );
26
#                  $search->dirs_only ( );
28
#                  $search->dirs_only ( );
27
#                  $search->dirs_too();             # Dirs have '/' appended
29
#                  $search->dirs_too();             # Dirs have '/' appended
28
#                  $search->search ( );
30
#                  $search->search ( );
29
#                  $search->results ( );
31
#                  $search->results ( );
-
 
32
#                  $search->set_list ( arrayRef );
30
#
33
#
31
#......................................................................#
34
#......................................................................#
32
 
35
 
33
require 5.006_001;
36
require 5.006_001;
34
use strict;
37
use strict;
Line 63... Line 66...
63
    $self->{dirs_only}  = 0;
66
    $self->{dirs_only}  = 0;
64
    $self->{dirs_too} = 0;
67
    $self->{dirs_too} = 0;
65
    $self->{exclude}  = [];
68
    $self->{exclude}  = [];
66
    $self->{include}  = [];
69
    $self->{include}  = [];
67
    $self->{base_dir} = undef;
70
    $self->{base_dir} = undef;
-
 
71
    $self->{search_list} = undef;
68
    $self->{results}  = [];
72
    $self->{results}  = [];
69
    bless ($self, $class);
73
    bless ($self, $class);
70
 
74
 
71
    #
75
    #
72
    #   Process user arguments.
76
    #   Process user arguments.
Line 87... Line 91...
87
#                   filter_in_re
91
#                   filter_in_re
88
#                   filter_out
92
#                   filter_out
89
#                   filter_out_re
93
#                   filter_out_re
90
#                   base_dir
94
#                   base_dir
91
#                   has_filter
95
#                   has_filter
-
 
96
#                   has_in_filter;
-
 
97
#                   has_out_filter;
92
#                   results
98
#                   results
93
#                   full_path
99
#                   full_path
94
#                   dirs_only
100
#                   dirs_only
95
#                   dirs_too                    - Include dirs in the search
101
#                   dirs_too                    - Include dirs in the search
-
 
102
#                   set_list
96
#
103
#
97
# Description     : Accessor functions
104
# Description     : Accessor functions
98
#
105
#
99
# Inputs          : class
106
# Inputs          : class
100
#                   One argument (optional)
107
#                   One argument (optional)
Line 130... Line 137...
130
}
137
}
131
 
138
 
132
sub filter_in
139
sub filter_in
133
{
140
{
134
    my $self = shift;
141
    my $self = shift;
135
    if (@_) { push @{$self->{include}}, glob2pat( shift ) }
142
    foreach (@_) { push @{$self->{include}}, glob2pat( $_ ) };
136
    return $self->{include};
143
    return $self->{include};
137
}
144
}
138
 
145
 
139
sub filter_in_re
146
sub filter_in_re
140
{
147
{
141
    my $self = shift;
148
    my $self = shift;
142
    if (@_) { push @{$self->{include}}, shift }
149
    foreach (@_) { push @{$self->{include}}, $_ };
143
    return $self->{include};
150
    return $self->{include};
144
}
151
}
145
 
152
 
146
sub filter_out
153
sub filter_out
147
{
154
{
148
    my $self = shift;
155
    my $self = shift;
149
    if (@_) { push @{$self->{exclude}}, glob2pat( shift ) }
156
    foreach (@_) { push @{$self->{exclude}}, glob2pat( $_ ) };
150
    return $self->{exclude};
157
    return $self->{exclude};
151
}
158
}
152
 
159
 
153
sub filter_out_re
160
sub filter_out_re
154
{
161
{
155
    my $self = shift;
162
    my $self = shift;
156
    if (@_) { push @{$self->{exclude}}, shift }
163
    foreach (@_) { push @{$self->{exclude}}, $_ };
157
    return $self->{exclude};
164
    return $self->{exclude};
158
}
165
}
159
 
166
 
160
sub base_dir
167
sub base_dir
161
{
168
{
Line 168... Line 175...
168
{
175
{
169
    my $self = shift;
176
    my $self = shift;
170
    return ( ( @{$self->{include}} || @{$self->{exclude}} ) );
177
    return ( ( @{$self->{include}} || @{$self->{exclude}} ) );
171
}
178
}
172
 
179
 
-
 
180
sub has_in_filter
-
 
181
{
-
 
182
    my $self = shift;
-
 
183
    return ( @{$self->{include}} );
-
 
184
}
-
 
185
 
-
 
186
sub has_out_filter
-
 
187
{
-
 
188
    my $self = shift;
-
 
189
    return ( @{$self->{exclude}} );
-
 
190
}
-
 
191
 
173
sub results
192
sub results
174
{
193
{
175
    my $self = shift;
194
    my $self = shift;
176
    $self->{results} = \() unless ( exists $self->{results} );
195
    $self->{results} = \() unless ( exists $self->{results} );
177
    return wantarray ? @{$self->{results}} : 1 + $#{$self->{results}};
196
    return wantarray ? @{$self->{results}} : 1 + $#{$self->{results}};
178
}
197
}
179
 
198
 
-
 
199
sub set_list
-
 
200
{
-
 
201
    my $self = shift;
-
 
202
    if (@_) { $self->{search_list} = shift};
-
 
203
    Error('JatsLocateFiles:set_list expects an ARRAY ref') unless (ref $self->{search_list} eq 'ARRAY' );
-
 
204
 
-
 
205
}
-
 
206
 
180
#-------------------------------------------------------------------------------
207
#-------------------------------------------------------------------------------
181
# Function        : option
208
# Function        : option
182
#
209
#
183
# Description     : Function to simplify the processing of search arguments
210
# Description     : Function to simplify the processing of search arguments
184
#                   Given an argument this function will act on it or
211
#                   Given an argument this function will act on it or
Line 233... Line 260...
233
        $self->filter_out ( $1 );
260
        $self->filter_out ( $1 );
234
 
261
 
235
    } elsif ( $opt =~ m/^--FilterOutRe=(.+)/ ) {
262
    } elsif ( $opt =~ m/^--FilterOutRe=(.+)/ ) {
236
        $self->filter_out_re ( $1 );
263
        $self->filter_out_re ( $1 );
237
 
264
 
-
 
265
    } elsif ( $opt =~ m/^--SetList=(.+)/ ) {
-
 
266
        $self->set_list ( $1 );
-
 
267
 
238
    } else {
268
    } else {
239
        $result = 0;
269
        $result = 0;
240
 
270
 
241
    }
271
    }
242
 
272
 
Line 269... Line 299...
269
    $self->{results} = ();
299
    $self->{results} = ();
270
 
300
 
271
    #
301
    #
272
    #   Ensure user has provided enough info
302
    #   Ensure user has provided enough info
273
    #
303
    #
274
    Error ("JatsLocateFiles: No base directory provided") unless ( $self->{base_dir} );
304
    Error ("JatsLocateFiles: No base directory provided") unless ( $self->{base_dir} || $self->{search_list} );
275
 
-
 
276
    #
-
 
277
    #   Clean up the user dir. Remove any trailing / as we will be adding it back
-
 
278
    #
-
 
279
    $self->{base_dir} =~ s~/*$~~g;
-
 
280
 
305
 
281
    #
-
 
282
    #   Init recursion information
-
 
283
    #   Needed to avoid closure interactions
-
 
284
    #
-
 
285
    @search_list = ();
306
    @search_list = ();
286
    $search_len = 1 + length( $self->{base_dir} );
307
    if ( $self->{base_dir} ) {
-
 
308
        #
-
 
309
        #   Clean up the user dir. Remove any trailing / as we will be adding it back
-
 
310
        #
-
 
311
        $self->{base_dir} =~ s~/*$~~g;
287
 
312
 
-
 
313
        #
-
 
314
        #   Init recursion information
-
 
315
        #   Needed to avoid closure interactions
288
    #
316
        #
-
 
317
        $search_len = 1 + length( $self->{base_dir} );
-
 
318
 
-
 
319
        #
289
    #   Create a list of candidate files
320
        #   Create a list of candidate files
290
    #   If we are recursing the subtree, then this is a little harder
321
        #   If we are recursing the subtree, then this is a little harder
291
    #   If we are not recursing then we can't simply glob the directory as
322
        #   If we are not recursing then we can't simply glob the directory as
292
    #   not all files are processed.
323
        #   not all files are processed.
293
    #
324
        #
294
    #   Will end up with a list of files that don't include $dir
325
        #   Will end up with a list of files that don't include $dir
295
    #
326
        #
296
    if ( -d $self->{base_dir} )
327
        if ( -d $self->{base_dir} )
297
    {
-
 
298
        if ( $self->{recurse} )
-
 
299
        {
328
        {
300
            $search_dirs_too = $self->{dirs_too};
-
 
301
            $search_base_dir = $self->{base_dir};
329
            if ( $self->{recurse} )
302
            $search_no_files = ($self->{dirs_only} == 2);
-
 
303
            sub find_file_wanted
-
 
304
            {
330
            {
-
 
331
                $search_dirs_too = $self->{dirs_too};
-
 
332
                $search_base_dir = $self->{base_dir};
-
 
333
                $search_no_files = ($self->{dirs_only} == 2);
-
 
334
                sub find_file_wanted
-
 
335
                {
305
                return if ( $search_no_files && ! -d $_ );              # skip if current is not a dir (assume file) and we only match dirs
336
                    return if ( $search_no_files && ! -d $_ );              # skip if current is not a dir (assume file) and we only match dirs
306
                return if ( !$search_dirs_too && -d $_ );               # skip if current is dir and we are not including dirs
337
                    return if ( !$search_dirs_too && -d $_ );               # skip if current is dir and we are not including dirs
307
                return if ( $search_base_dir eq $File::Find::name );    # skip if current is base_dir as we dont include it
338
                    return if ( $search_base_dir eq $File::Find::name );    # skip if current is base_dir as we dont include it
308
                my $file = $File::Find::name;
339
                    my $file = $File::Find::name;
309
                $file .= '/' if ( -d $_ && ! $search_no_files);
340
                    $file .= '/' if ( -d $_ && ! $search_no_files);
310
                push @search_list, substr($file, $search_len );
341
                    push @search_list, substr($file, $search_len );
311
            }
342
                }
312
 
343
 
313
            #
344
                #
314
            #       Under Unix we need to follow symbolic links, but Perl's
345
                #       Under Unix we need to follow symbolic links, but Perl's
315
            #       Find:find does not work with -follow under windows if the source
346
                #       Find:find does not work with -follow under windows if the source
316
            #       path contains a drive letter.
347
                #       path contains a drive letter.
317
            #
348
                #
318
            #       Solution. Only use follow under non-windows systems.
349
                #       Solution. Only use follow under non-windows systems.
319
            #                 Works as Windows does not have symlinks (yet).
350
                #                 Works as Windows does not have symlinks (yet).
320
            #
351
                #
321
            my $follow_opt =  ($ENV{GBE_UNIX}  > 0);
352
                my $follow_opt =  ($ENV{GBE_UNIX}  > 0);
322
        
353
            
323
            File::Find::find( {wanted => \&find_file_wanted, follow_fast => $follow_opt, follow_skip => 2 }, $self->{base_dir} );
354
                File::Find::find( {wanted => \&find_file_wanted, follow_fast => $follow_opt, follow_skip => 2 }, $self->{base_dir} );
324
        }
355
            }
325
        else
356
            else
326
        {
-
 
327
            local *DIR ;
-
 
328
            opendir DIR, $self->{base_dir} || die ("Cannot open $self->{base_dir}");
-
 
329
            foreach ( readdir( DIR ) )
-
 
330
            {
357
            {
-
 
358
                local *DIR ;
-
 
359
                opendir DIR, $self->{base_dir} || die ("Cannot open $self->{base_dir}");
-
 
360
                foreach ( readdir( DIR ) )
-
 
361
                {
331
                next if /^\Q.\E$/;
362
                    next if /^\Q.\E$/;
332
                next if /^\Q..\E$/;
363
                    next if /^\Q..\E$/;
333
                next if ( !$self->{dirs_too} && -d "$self->{base_dir}/$_" );
364
                    next if ( !$self->{dirs_too} && -d "$self->{base_dir}/$_" );
334
                push @search_list, $_;
365
                    push @search_list, $_;
-
 
366
                }
-
 
367
                closedir DIR;
335
            }
368
            }
336
            closedir DIR;
-
 
337
        }
369
        }
338
    }
370
    }
-
 
371
    else
-
 
372
    {
-
 
373
        # User has provided the search list to be processed
-
 
374
        $self->{full_path} = 0;
-
 
375
        @search_list = @{$self->{search_list}};
-
 
376
    }
339
 
377
 
340
 
378
 
341
    my @result;
379
    my @result;
342
    if ( @{$self->{include}} || @{$self->{exclude}} )
380
    if ( @{$self->{include}} || @{$self->{exclude}} )
343
    {
381
    {
Line 384... Line 422...
384
    else
422
    else
385
    {
423
    {
386
        @result = @search_list ;
424
        @result = @search_list ;
387
    }
425
    }
388
    @search_list = ();
426
    @search_list = ();
389
    $self->{results} = [];;
427
    $self->{results} = [];
390
 
428
 
391
    #
429
    #
392
    #   Reattach the base directory, if required
430
    #   Reattach the base directory, if required
393
    #       full_path  : Prepend full path
431
    #       full_path  : Prepend full path
394
    #       dirs_only  : return list of dirs that have files
432
    #       dirs_only  : return list of dirs that have files