| Filename | /home/ss5/perl5/perlbrew/perls/perl-5.22.0/lib/5.22.0/File/GlobMapper.pm |
| Statements | Executed 21 statements in 991µs |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 1 | 1 | 1 | 319µs | 618µs | File::GlobMapper::BEGIN@10 |
| 1 | 1 | 1 | 7µs | 18µs | File::GlobMapper::BEGIN@341 |
| 1 | 1 | 1 | 7µs | 8µs | File::GlobMapper::BEGIN@3 |
| 1 | 1 | 1 | 4µs | 22µs | File::GlobMapper::BEGIN@5 |
| 1 | 1 | 1 | 4µs | 6µs | File::GlobMapper::BEGIN@4 |
| 0 | 0 | 0 | 0s | 0s | File::GlobMapper::_getFiles |
| 0 | 0 | 0 | 0s | 0s | File::GlobMapper::_parseBit |
| 0 | 0 | 0 | 0s | 0s | File::GlobMapper::_parseInputGlob |
| 0 | 0 | 0 | 0s | 0s | File::GlobMapper::_parseOutputGlob |
| 0 | 0 | 0 | 0s | 0s | File::GlobMapper::_retError |
| 0 | 0 | 0 | 0s | 0s | File::GlobMapper::_unmatched |
| 0 | 0 | 0 | 0s | 0s | File::GlobMapper::getFileMap |
| 0 | 0 | 0 | 0s | 0s | File::GlobMapper::getHash |
| 0 | 0 | 0 | 0s | 0s | File::GlobMapper::globmap |
| 0 | 0 | 0 | 0s | 0s | File::GlobMapper::new |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package File::GlobMapper; | ||||
| 2 | |||||
| 3 | 2 | 12µs | 2 | 9µs | # spent 8µs (7+1) within File::GlobMapper::BEGIN@3 which was called:
# once (7µs+1µs) by IO::Compress::Base::Common::BEGIN@9 at line 3 # spent 8µs making 1 call to File::GlobMapper::BEGIN@3
# spent 1µs making 1 call to strict::import |
| 4 | 2 | 12µs | 2 | 8µs | # spent 6µs (4+2) within File::GlobMapper::BEGIN@4 which was called:
# once (4µs+2µs) by IO::Compress::Base::Common::BEGIN@9 at line 4 # spent 6µs making 1 call to File::GlobMapper::BEGIN@4
# spent 2µs making 1 call to warnings::import |
| 5 | 2 | 72µs | 2 | 40µs | # spent 22µs (4+18) within File::GlobMapper::BEGIN@5 which was called:
# once (4µs+18µs) by IO::Compress::Base::Common::BEGIN@9 at line 5 # spent 22µs making 1 call to File::GlobMapper::BEGIN@5
# spent 18µs making 1 call to Exporter::import |
| 6 | |||||
| 7 | our ($CSH_GLOB); | ||||
| 8 | |||||
| 9 | BEGIN | ||||
| 10 | # spent 618µs (319+299) within File::GlobMapper::BEGIN@10 which was called:
# once (319µs+299µs) by IO::Compress::Base::Common::BEGIN@9 at line 24 | ||||
| 11 | 1 | 3µs | if ($] < 5.006) | ||
| 12 | { | ||||
| 13 | require File::BSDGlob; import File::BSDGlob qw(:glob) ; | ||||
| 14 | $CSH_GLOB = File::BSDGlob::GLOB_CSH() ; | ||||
| 15 | *globber = \&File::BSDGlob::csh_glob; | ||||
| 16 | } | ||||
| 17 | else | ||||
| 18 | { | ||||
| 19 | 2 | 40µs | 1 | 141µs | require File::Glob; import File::Glob qw(:glob) ; # spent 141µs making 1 call to File::Glob::import |
| 20 | 1 | 2µs | 1 | 400ns | $CSH_GLOB = File::Glob::GLOB_CSH() ; # spent 400ns making 1 call to File::Glob::GLOB_CSH |
| 21 | #*globber = \&File::Glob::bsd_glob; | ||||
| 22 | 1 | 500ns | *globber = \&File::Glob::csh_glob; | ||
| 23 | } | ||||
| 24 | 1 | 724µs | 1 | 618µs | } # spent 618µs making 1 call to File::GlobMapper::BEGIN@10 |
| 25 | |||||
| 26 | our ($Error); | ||||
| 27 | |||||
| 28 | our ($VERSION, @EXPORT_OK); | ||||
| 29 | 1 | 300ns | $VERSION = '1.000'; | ||
| 30 | 1 | 600ns | @EXPORT_OK = qw( globmap ); | ||
| 31 | |||||
| 32 | |||||
| 33 | our ($noPreBS, $metachars, $matchMetaRE, %mapping, %wildCount); | ||||
| 34 | 1 | 100ns | $noPreBS = '(?<!\\\)' ; # no preceding backslash | ||
| 35 | 1 | 100ns | $metachars = '.*?[](){}'; | ||
| 36 | 1 | 900ns | $matchMetaRE = '[' . quotemeta($metachars) . ']'; | ||
| 37 | |||||
| 38 | 1 | 2µs | %mapping = ( | ||
| 39 | '*' => '([^/]*)', | ||||
| 40 | '?' => '([^/])', | ||||
| 41 | '.' => '\.', | ||||
| 42 | '[' => '([', | ||||
| 43 | '(' => '(', | ||||
| 44 | ')' => ')', | ||||
| 45 | ); | ||||
| 46 | |||||
| 47 | 1 | 3µs | %wildCount = map { $_ => 1 } qw/ * ? . { ( [ /; | ||
| 48 | |||||
| 49 | sub globmap ($$;) | ||||
| 50 | { | ||||
| 51 | my $inputGlob = shift ; | ||||
| 52 | my $outputGlob = shift ; | ||||
| 53 | |||||
| 54 | my $obj = new File::GlobMapper($inputGlob, $outputGlob, @_) | ||||
| 55 | or croak "globmap: $Error" ; | ||||
| 56 | return $obj->getFileMap(); | ||||
| 57 | } | ||||
| 58 | |||||
| 59 | sub new | ||||
| 60 | { | ||||
| 61 | my $class = shift ; | ||||
| 62 | my $inputGlob = shift ; | ||||
| 63 | my $outputGlob = shift ; | ||||
| 64 | # TODO -- flags needs to default to whatever File::Glob does | ||||
| 65 | my $flags = shift || $CSH_GLOB ; | ||||
| 66 | #my $flags = shift ; | ||||
| 67 | |||||
| 68 | $inputGlob =~ s/^\s*\<\s*//; | ||||
| 69 | $inputGlob =~ s/\s*\>\s*$//; | ||||
| 70 | |||||
| 71 | $outputGlob =~ s/^\s*\<\s*//; | ||||
| 72 | $outputGlob =~ s/\s*\>\s*$//; | ||||
| 73 | |||||
| 74 | my %object = | ||||
| 75 | ( InputGlob => $inputGlob, | ||||
| 76 | OutputGlob => $outputGlob, | ||||
| 77 | GlobFlags => $flags, | ||||
| 78 | Braces => 0, | ||||
| 79 | WildCount => 0, | ||||
| 80 | Pairs => [], | ||||
| 81 | Sigil => '#', | ||||
| 82 | ); | ||||
| 83 | |||||
| 84 | my $self = bless \%object, ref($class) || $class ; | ||||
| 85 | |||||
| 86 | $self->_parseInputGlob() | ||||
| 87 | or return undef ; | ||||
| 88 | |||||
| 89 | $self->_parseOutputGlob() | ||||
| 90 | or return undef ; | ||||
| 91 | |||||
| 92 | my @inputFiles = globber($self->{InputGlob}, $flags) ; | ||||
| 93 | |||||
| 94 | if (GLOB_ERROR) | ||||
| 95 | { | ||||
| 96 | $Error = $!; | ||||
| 97 | return undef ; | ||||
| 98 | } | ||||
| 99 | |||||
| 100 | #if (whatever) | ||||
| 101 | { | ||||
| 102 | my $missing = grep { ! -e $_ } @inputFiles ; | ||||
| 103 | |||||
| 104 | if ($missing) | ||||
| 105 | { | ||||
| 106 | $Error = "$missing input files do not exist"; | ||||
| 107 | return undef ; | ||||
| 108 | } | ||||
| 109 | } | ||||
| 110 | |||||
| 111 | $self->{InputFiles} = \@inputFiles ; | ||||
| 112 | |||||
| 113 | $self->_getFiles() | ||||
| 114 | or return undef ; | ||||
| 115 | |||||
| 116 | return $self; | ||||
| 117 | } | ||||
| 118 | |||||
| 119 | sub _retError | ||||
| 120 | { | ||||
| 121 | my $string = shift ; | ||||
| 122 | $Error = "$string in input fileglob" ; | ||||
| 123 | return undef ; | ||||
| 124 | } | ||||
| 125 | |||||
| 126 | sub _unmatched | ||||
| 127 | { | ||||
| 128 | my $delimeter = shift ; | ||||
| 129 | |||||
| 130 | _retError("Unmatched $delimeter"); | ||||
| 131 | return undef ; | ||||
| 132 | } | ||||
| 133 | |||||
| 134 | sub _parseBit | ||||
| 135 | { | ||||
| 136 | my $self = shift ; | ||||
| 137 | |||||
| 138 | my $string = shift ; | ||||
| 139 | |||||
| 140 | my $out = ''; | ||||
| 141 | my $depth = 0 ; | ||||
| 142 | |||||
| 143 | while ($string =~ s/(.*?)$noPreBS(,|$matchMetaRE)//) | ||||
| 144 | { | ||||
| 145 | $out .= quotemeta($1) ; | ||||
| 146 | $out .= $mapping{$2} if defined $mapping{$2}; | ||||
| 147 | |||||
| 148 | ++ $self->{WildCount} if $wildCount{$2} ; | ||||
| 149 | |||||
| 150 | if ($2 eq ',') | ||||
| 151 | { | ||||
| 152 | return _unmatched "(" | ||||
| 153 | if $depth ; | ||||
| 154 | |||||
| 155 | $out .= '|'; | ||||
| 156 | } | ||||
| 157 | elsif ($2 eq '(') | ||||
| 158 | { | ||||
| 159 | ++ $depth ; | ||||
| 160 | } | ||||
| 161 | elsif ($2 eq ')') | ||||
| 162 | { | ||||
| 163 | return _unmatched ")" | ||||
| 164 | if ! $depth ; | ||||
| 165 | |||||
| 166 | -- $depth ; | ||||
| 167 | } | ||||
| 168 | elsif ($2 eq '[') | ||||
| 169 | { | ||||
| 170 | # TODO -- quotemeta & check no '/' | ||||
| 171 | # TODO -- check for \] & other \ within the [] | ||||
| 172 | $string =~ s#(.*?\])## | ||||
| 173 | or return _unmatched "[" ; | ||||
| 174 | $out .= "$1)" ; | ||||
| 175 | } | ||||
| 176 | elsif ($2 eq ']') | ||||
| 177 | { | ||||
| 178 | return _unmatched "]" ; | ||||
| 179 | } | ||||
| 180 | elsif ($2 eq '{' || $2 eq '}') | ||||
| 181 | { | ||||
| 182 | return _retError "Nested {} not allowed" ; | ||||
| 183 | } | ||||
| 184 | } | ||||
| 185 | |||||
| 186 | $out .= quotemeta $string; | ||||
| 187 | |||||
| 188 | return _unmatched "(" | ||||
| 189 | if $depth ; | ||||
| 190 | |||||
| 191 | return $out ; | ||||
| 192 | } | ||||
| 193 | |||||
| 194 | sub _parseInputGlob | ||||
| 195 | { | ||||
| 196 | my $self = shift ; | ||||
| 197 | |||||
| 198 | my $string = $self->{InputGlob} ; | ||||
| 199 | my $inGlob = ''; | ||||
| 200 | |||||
| 201 | # Multiple concatenated *'s don't make sense | ||||
| 202 | #$string =~ s#\*\*+#*# ; | ||||
| 203 | |||||
| 204 | # TODO -- Allow space to delimit patterns? | ||||
| 205 | #my @strings = split /\s+/, $string ; | ||||
| 206 | #for my $str (@strings) | ||||
| 207 | my $out = ''; | ||||
| 208 | my $depth = 0 ; | ||||
| 209 | |||||
| 210 | while ($string =~ s/(.*?)$noPreBS($matchMetaRE)//) | ||||
| 211 | { | ||||
| 212 | $out .= quotemeta($1) ; | ||||
| 213 | $out .= $mapping{$2} if defined $mapping{$2}; | ||||
| 214 | ++ $self->{WildCount} if $wildCount{$2} ; | ||||
| 215 | |||||
| 216 | if ($2 eq '(') | ||||
| 217 | { | ||||
| 218 | ++ $depth ; | ||||
| 219 | } | ||||
| 220 | elsif ($2 eq ')') | ||||
| 221 | { | ||||
| 222 | return _unmatched ")" | ||||
| 223 | if ! $depth ; | ||||
| 224 | |||||
| 225 | -- $depth ; | ||||
| 226 | } | ||||
| 227 | elsif ($2 eq '[') | ||||
| 228 | { | ||||
| 229 | # TODO -- quotemeta & check no '/' or '(' or ')' | ||||
| 230 | # TODO -- check for \] & other \ within the [] | ||||
| 231 | $string =~ s#(.*?\])## | ||||
| 232 | or return _unmatched "["; | ||||
| 233 | $out .= "$1)" ; | ||||
| 234 | } | ||||
| 235 | elsif ($2 eq ']') | ||||
| 236 | { | ||||
| 237 | return _unmatched "]" ; | ||||
| 238 | } | ||||
| 239 | elsif ($2 eq '}') | ||||
| 240 | { | ||||
| 241 | return _unmatched "}" ; | ||||
| 242 | } | ||||
| 243 | elsif ($2 eq '{') | ||||
| 244 | { | ||||
| 245 | # TODO -- check no '/' within the {} | ||||
| 246 | # TODO -- check for \} & other \ within the {} | ||||
| 247 | |||||
| 248 | my $tmp ; | ||||
| 249 | unless ( $string =~ s/(.*?)$noPreBS\}//) | ||||
| 250 | { | ||||
| 251 | return _unmatched "{"; | ||||
| 252 | } | ||||
| 253 | #$string =~ s#(.*?)\}##; | ||||
| 254 | |||||
| 255 | #my $alt = join '|', | ||||
| 256 | # map { quotemeta $_ } | ||||
| 257 | # split "$noPreBS,", $1 ; | ||||
| 258 | my $alt = $self->_parseBit($1); | ||||
| 259 | defined $alt or return 0 ; | ||||
| 260 | $out .= "($alt)" ; | ||||
| 261 | |||||
| 262 | ++ $self->{Braces} ; | ||||
| 263 | } | ||||
| 264 | } | ||||
| 265 | |||||
| 266 | return _unmatched "(" | ||||
| 267 | if $depth ; | ||||
| 268 | |||||
| 269 | $out .= quotemeta $string ; | ||||
| 270 | |||||
| 271 | |||||
| 272 | $self->{InputGlob} =~ s/$noPreBS[\(\)]//g; | ||||
| 273 | $self->{InputPattern} = $out ; | ||||
| 274 | |||||
| 275 | #print "# INPUT '$self->{InputGlob}' => '$out'\n"; | ||||
| 276 | |||||
| 277 | return 1 ; | ||||
| 278 | |||||
| 279 | } | ||||
| 280 | |||||
| 281 | sub _parseOutputGlob | ||||
| 282 | { | ||||
| 283 | my $self = shift ; | ||||
| 284 | |||||
| 285 | my $string = $self->{OutputGlob} ; | ||||
| 286 | my $maxwild = $self->{WildCount}; | ||||
| 287 | |||||
| 288 | if ($self->{GlobFlags} & GLOB_TILDE) | ||||
| 289 | #if (1) | ||||
| 290 | { | ||||
| 291 | $string =~ s{ | ||||
| 292 | $1 | ||||
| 293 | ? (getpwnam($1))[7] | ||||
| 294 | : ( $ENV{HOME} || $ENV{LOGDIR} ) | ||||
| 295 | }ex; | ||||
| 296 | ) | ||||
| 297 | }{ | ||||
| 298 | |||||
| - - | |||||
| 303 | } | ||||
| 304 | |||||
| 305 | # max #1 must be == to max no of '*' in input | ||||
| 306 | while ( $string =~ m/#(\d)/g ) | ||||
| 307 | { | ||||
| 308 | croak "Max wild is #$maxwild, you tried #$1" | ||||
| 309 | if $1 > $maxwild ; | ||||
| 310 | } | ||||
| 311 | |||||
| 312 | my $noPreBS = '(?<!\\\)' ; # no preceding backslash | ||||
| 313 | #warn "noPreBS = '$noPreBS'\n"; | ||||
| 314 | |||||
| 315 | #$string =~ s/${noPreBS}\$(\d)/\${$1}/g; | ||||
| 316 | $string =~ s/${noPreBS}#(\d)/\${$1}/g; | ||||
| 317 | $string =~ s#${noPreBS}\*#\${inFile}#g; | ||||
| 318 | $string = '"' . $string . '"'; | ||||
| 319 | |||||
| 320 | #print "OUTPUT '$self->{OutputGlob}' => '$string'\n"; | ||||
| 321 | $self->{OutputPattern} = $string ; | ||||
| 322 | |||||
| 323 | return 1 ; | ||||
| 324 | } | ||||
| 325 | |||||
| 326 | sub _getFiles | ||||
| 327 | { | ||||
| 328 | my $self = shift ; | ||||
| 329 | |||||
| 330 | my %outInMapping = (); | ||||
| 331 | my %inFiles = () ; | ||||
| 332 | |||||
| 333 | foreach my $inFile (@{ $self->{InputFiles} }) | ||||
| 334 | { | ||||
| 335 | next if $inFiles{$inFile} ++ ; | ||||
| 336 | |||||
| 337 | my $outFile = $inFile ; | ||||
| 338 | |||||
| 339 | if ( $inFile =~ m/$self->{InputPattern}/ ) | ||||
| 340 | { | ||||
| 341 | 2 | 113µs | 2 | 28µs | # spent 18µs (7+10) within File::GlobMapper::BEGIN@341 which was called:
# once (7µs+10µs) by IO::Compress::Base::Common::BEGIN@9 at line 341 # spent 18µs making 1 call to File::GlobMapper::BEGIN@341
# spent 10µs making 1 call to warnings::unimport |
| 342 | eval "\$outFile = $self->{OutputPattern};" ; | ||||
| 343 | |||||
| 344 | if (defined $outInMapping{$outFile}) | ||||
| 345 | { | ||||
| 346 | $Error = "multiple input files map to one output file"; | ||||
| 347 | return undef ; | ||||
| 348 | } | ||||
| 349 | $outInMapping{$outFile} = $inFile; | ||||
| 350 | push @{ $self->{Pairs} }, [$inFile, $outFile]; | ||||
| 351 | } | ||||
| 352 | } | ||||
| 353 | |||||
| 354 | return 1 ; | ||||
| 355 | } | ||||
| 356 | |||||
| 357 | sub getFileMap | ||||
| 358 | { | ||||
| 359 | my $self = shift ; | ||||
| 360 | |||||
| 361 | return $self->{Pairs} ; | ||||
| 362 | } | ||||
| 363 | |||||
| 364 | sub getHash | ||||
| 365 | { | ||||
| 366 | my $self = shift ; | ||||
| 367 | |||||
| 368 | return { map { $_->[0] => $_->[1] } @{ $self->{Pairs} } } ; | ||||
| 369 | } | ||||
| 370 | |||||
| 371 | 1 | 6µs | 1; | ||
| 372 | |||||
| 373 | __END__ |