source: repository/lib/Metabrik/File/Find.pm

Last change on this file was 866:f6ad8c136b19, checked in by GomoR <gomor@…>, 4 months ago
  • update: copyright 2017
File size: 3.3 KB
Line 
1#
2# $Id$
3#
4# file::find Brik
5#
6package Metabrik::File::Find;
7use strict;
8use warnings;
9
10use base qw(Metabrik);
11
12sub brik_properties {
13   return {
14      revision => '$Revision$',
15      tags => [ qw(unstable) ],
16      author => 'GomoR <GomoR[at]metabrik.org>',
17      license => 'http://opensource.org/licenses/BSD-3-Clause',
18      attributes => {
19         path => [ qw($path_list) ],
20      },
21      attributes_default => {
22         path => [ '.' ],
23      },
24      commands => {
25         all => [ qw(directory_pattern file_pattern) ],
26         files => [ qw(directory|OPTIONAL file_pattern|OPTIONAL) ],
27      },
28      require_modules => {
29         'File::Find' => [ ],
30      },
31   };
32}
33
34sub files {
35   my $self = shift;
36   my ($directory, $filepattern) = @_;
37
38   $directory ||= '.';
39   $filepattern ||= '.*';
40   $self->brik_help_run_directory_not_found('files', $directory) or return;
41
42   my $file_regex = qr/$filepattern/;
43   my $dot_regex = qr/^\.$/;
44   my $dot2_regex = qr/^\.\.$/;
45
46   my @tmp_files = ();
47   my $sub = sub {
48      my $dir = $File::Find::dir;
49      my $name = $File::Find::name;
50      my $file = $_;
51      # Skip dot and double dot directories
52      if ($file =~ $dot_regex || $file =~ $dot2_regex) {
53      }
54      elsif ($file =~ $file_regex) {
55         push @tmp_files, $name;
56      }
57   };
58
59   {
60      no warnings;
61      File::Find::find($sub, ( $directory ));
62   };
63
64   @tmp_files = map { s/^\.\///; $_ } @tmp_files;  # Remove leading dot slash
65   my %uniq_files = map { $_ => 1 } @tmp_files;
66   my @files = sort { $a cmp $b } keys %uniq_files;
67   @files = grep { -f $_ } @files; # Keep only files
68
69   return \@files;
70}
71
72#sub directories {
73#}
74
75sub all {
76   my $self = shift;
77   my ($dirpattern, $filepattern) = @_;
78
79   my $path = $self->path;
80   $self->brik_help_run_undef_arg('all', $dirpattern) or return;
81   $self->brik_help_run_undef_arg('all', $filepattern) or return;
82   $self->brik_help_run_undef_arg('all', $path) or return;
83   $self->brik_help_run_invalid_arg('all', $path, 'ARRAY') or return;
84
85   my @dirs = ();
86   my @files = ();
87
88   # Escape dirpattern if we are searching for a directory hierarchy
89   $dirpattern =~ s/\//\\\//g;
90
91   my $dir_regex = qr/$dirpattern/;
92   my $file_regex = qr/$filepattern/;
93   my $dot_regex = qr/^\.$/;
94   my $dot2_regex = qr/^\.\.$/;
95
96   my $sub = sub {
97      my $dir = $File::Find::dir;
98      my $file = $_;
99      # Skip dot and double dot directories
100      if ($file =~ $dot_regex || $file =~ $dot2_regex) {
101      }
102      elsif ($dir =~ $dir_regex && $file =~ $file_regex) {
103         push @dirs, "$dir/";
104         push @files, "$dir/$file";
105      }
106   };
107
108   {
109      no warnings;
110      File::Find::find($sub, @$path);
111   };
112
113   my %uniq_dirs = map { $_ => 1 } @dirs;
114   my %uniq_files = map { $_ => 1 } @files;
115   @dirs = sort { $a cmp $b } keys %uniq_dirs;
116   @files = sort { $a cmp $b } keys %uniq_files;
117
118   @dirs = map { s/^\.\///; $_ } @dirs;  # Remove leading dot slash
119   @files = map { s/^\.\///; $_ } @files;  # Remove leading dot slash
120
121   return {
122      directories => \@dirs,
123      files => \@files,
124   };
125}
126
1271;
128
129__END__
130
131=head1 NAME
132
133Metabrik::File::Find - file::find Brik
134
135=head1 COPYRIGHT AND LICENSE
136
137Copyright (c) 2014-2017, Patrice E<lt>GomoRE<gt> Auffret
138
139You may distribute this module under the terms of The BSD 3-Clause License.
140See LICENSE file in the source distribution archive.
141
142=head1 AUTHOR
143
144Patrice E<lt>GomoRE<gt> Auffret
145
146=cut
Note: See TracBrowser for help on using the repository browser.