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