package File::CodeSearch::Files;
# Created on: 2009-08-11 06:20:53
# Create by: Ivan Wills
# $Id$
# $Revision$, $HeadURL$, $Date$
# $Revision$, $Source$, $Date$
use Moose;
use warnings;
use version;
use Readonly;
use Data::Dumper;
use Carp;
use English qw{ -no_match_vars };
use Config::General;
our $VERSION = version->new('0.5.8');
our %warned_once;
has ignore => (
is => 'rw',
isa => 'ArrayRef[Str]',
default => sub{[qw{ ignore }]},
);
has include => (
is => 'rw',
isa => 'ArrayRef[Str]',
);
has exclude => (
is => 'rw',
isa => 'ArrayRef[Str]',
);
has include_type => (
is => 'rw',
isa => 'ArrayRef[Str]',
default => sub{[]},
);
has exclude_type => (
is => 'rw',
isa => 'ArrayRef[Str]',
default => sub{[]},
);
has symlinks => (
is => 'rw',
isa => 'Bool',
default => 0,
);
has links => (
is => 'rw',
isa => 'HashRef',
default => sub {{}},
);
has type_suffixes => (
is => 'rw',
isa => 'HashRef',
default => sub {{
ignore => {
definite => [qw{ }],
possible => [qw{ }],
other_types => [qw{ build backups vcs images logs editors }],
none => 0,
},
editors => {
definite => [qw{ ~\d*$ }],
possible => [qw{ }],
other_types => [qw{ vim }],
none => 0,
},
vim => {
definite => [qw{ (^|/)[.][^/]+[.]sw[ponx]$ }],
possible => [qw{ }],
other_types => [qw{ }],
none => 0,
},
images => {
definite => [qw{ [.]png$ [.]jpe?g$ [.]gif$ [.]swf$ [.]ttf$ }],
possible => [qw{ }],
other_types => [qw{ }],
none => 0,
},
logs => {
definite => [qw{ logs?(?:$|/) }],
possible => [qw{ }],
other_types => [qw{ }],
none => 0,
},
backups => {
definite => [qw{ [.]orig$ [.]copy$ ~\d*$ }],
possible => [qw{ }],
other_types => [qw{ }],
none => 0,
},
vcs => {
definite => [qw{ [.]git [.]bzr [.]svn CVS RCS }, ',v$' ],
possible => [qw{ }],
other_types => [qw{ }],
none => 0,
},
build => {
definite => [qw{ _build blib (MY)?META[.](yml|json) LICENCE Changes Build([.]PL)? MANIFEST([.]SKIP)? README }],
possible => [qw{ }],
other_types => [qw{ }],
none => 0,
},
perl => {
definite => [qw{ [.]pl$ [.]pm$ [.]pod$ [.]PL$ }],
possible => [qw{ [.]t$ [.]cgi$ }],
other_types => [qw{ }],
none => 1,
bang => 'perl',
},
php => {
definite => [qw{ [.]php$ }],
possible => [qw{ [.]lib$ [.]pkg$ [.]t$ }],
other_types => [qw{ }],
none => 0,
},
c => {
definite => [qw{ [.]c$ [.]cpp$ [.]c[+][+]$ [.]h$ [.]hpp$ [.]hxx$ [.]h[+][+]$ }],
possible => [qw{ }],
other_types => [qw{ }],
none => 0,
},
html => {
definite => [qw{ [.]html$ [.]xhtml$ }],
possible => [qw{ [.]xml$ }],
other_types => [qw{ }],
none => 0,
},
test => {
definite => [qw{ \/tx?\/[.]t$ test[.]pl$ }],
possible => [qw{ }],
other_types => [qw{ }],
none => 0,
},
svg => {
definite => [qw{ svg }],
possible => [qw{ }],
other_types => [qw{ }],
none => 0,
},
sql => {
definite => [qw{ [.]sql$ [.]plsql$ }],
possible => [qw{ }],
other_types => [qw{ }],
none => 0,
},
css => {
definite => [qw{ [.]css$ }],
possible => [qw{ }],
other_types => [qw{ }],
none => 0,
},
javascript => {
definite => [qw{ [.]js$ }],
possible => [qw{ }],
other_types => [qw{ }],
none => 0,
},
js => {
definite => [qw{ }],
possible => [qw{ }],
other_types => [qw{ javascript }],
none => 0,
},
xml => {
definite => [qw{ xml$ [.]xsd$ [.]xslt$ [.]dtd }],
possible => [qw{ }],
other_types => [qw{ svg }],
none => 0,
},
web => {
definite => [qw{ }],
possible => [qw{ }],
other_types => [qw{ html svg css javascript }],
none => 0,
},
scripting => {
definite => [qw{ }],
possible => [qw{ }],
other_types => [qw{ perl php javascript }],
none => 0,
},
programing => {
definite => [qw{ }],
possible => [qw{ }],
other_types => [qw{ scripting c }],
none => 0,
},
package => {
definite => [qw{ [.]PL$ MANIFEST$ MANIFEST.SKIP$ META.yml$ MYMETA.yml$ README$ Changes$ Debian_CPANTS.txt$ Makefile$ LICENSE$ }],
possible => [qw{ }],
other_types => [qw{ }],
none => 0,
},
config => {
definite => [qw{ }],
possible => [qw{ rc$ tab$ [.]cfg$ [.]conf$ [.]config$ [.]yml$ }],
other_types => [qw{ }],
none => 0,
},
binary => {
definite => [qw{ [.]jpe?g$ [.]png$ [.]gif$ [.]bmp$ [.]swf$ [.]psd$ [.]exe$ }],
possible => [qw{ }],
other_types => [qw{ }],
none => 0,
},
}},
);
sub BUILD {
my ($self) = @_;
$ENV{HOME} ||= $ENV{USERPROFILE};
my $conf_file = "$ENV{HOME}/.csrc";
return if !-r $conf_file;
my $conf = Config::General->new($conf_file);
my %conf = $conf->getall();
$conf{file_types} ||= {};
for my $file_type ( keys %{ $conf{file_types} } ) {
$self->type_suffixes->{$file_type} ||= {};
for my $setting ( keys %{ $conf{file_types}{$file_type} } ) {
if ( $setting =~ s/^[+]//xms ) {
push @{ $self->type_suffixes->{$file_type}{$setting} }
, ref $conf{file_types}{$file_type}{$setting} eq 'ARRAY'
? @{ $conf{file_types}{$file_type}{$setting} }
: $conf{file_types}{$file_type}{$setting};
}
else {
$self->type_suffixes->{$file_type}{$setting}
= ref $conf{file_types}{$file_type}{$setting} eq 'ARRAY'
? $conf{file_types}{$file_type}{$setting}
: [ $conf{file_types}{$file_type}{$setting} ];
}
}
}
}
sub file_ok {
my ($self, $file) = @_;
for my $ignore (@{ $self->ignore }) {
return 0 if $self->types_match($file, $ignore);
}
return 1 if -d $file;
my $possible = 0;
my $matched = 0;
if ( @{ $self->include_type }) {
for my $type (@{ $self->include_type }) {
my $match = $self->types_match($file, $type);
$possible-- if $match == 2;
$matched += $match;
}
return 0 if $matched <= 0;
}
if (!$matched) {
for my $type (@{ $self->exclude_type }) {
my $match = $self->types_match($file, $type);
return 0 if $match && $match != 2;
$possible++ if $match == 2;
}
return 0 if $possible > 0;
}
if ($self->include) {
my $matches = 0;
for my $include (@{ $self->include }) {
$matches ||= $file =~ /$include/;
last if $matches;
}
return 0 if !$matches;
}
if ($self->exclude) {
for my $exclude (@{ $self->exclude }) {
return 0 if $file =~ /$exclude/;
}
}
return 1;
}
sub types_match {
my ($self, $file, $type) = @_;
my $types = $self->type_suffixes;
warn "No type $type" if !exists $types->{$type} && !$warned_once{$type}++;
return 0 if !exists $types->{$type};
for my $suffix ( @{ $types->{$type}{definite} } ) {
return 3 if $file =~ /$suffix/;
}
for my $suffix ( @{ $types->{$type}{possible} } ) {
return 2 if $file =~ /$suffix/;
}
if ( $types->{$type}{bang} ) {
if ( open my $fh, '<', $file ) {
my $line = <$fh>;
close $fh;
return 3 if $line && $line =~ /$types->{$type}{bang}/;
}
}
return 1 if $types->{$type}{none} && $file !~ m{ [^/] [.] [^/]+ $}xms;
for my $other ( @{ $types->{$type}{other_types} } ) {
my $match = $self->types_match($file, $other);
return $match if $match;
}
return 0;
}
1;
__END__
=head1 NAME
File::CodeSearch::Files - Handles the testing file types, symlinks and file name positive & negative matching.
=head1 VERSION
This documentation refers to File::CodeSearch::Files version 0.5.8.
=head1 SYNOPSIS
use File::CodeSearch::Files;
# Brief but working code example(s) here showing the most common usage(s)
# This section will be as far as many users bother reading, so make it as
# educational and exemplary as possible.
=head1 DESCRIPTION
=head1 SUBROUTINES/METHODS
=head2 C<BUILD>
Applies any configuration details found in the ~/.csrc file
=head2 C<file_ok ($file)>
Determines weather B<$file> should be searched
=head2 C<types_match ($file, $type)>
Checks that the file $file is of type $type and returns true if it is false
otherwise
=head1 DIAGNOSTICS
=head1 CONFIGURATION AND ENVIRONMENT
=head1 DEPENDENCIES
=head1 INCOMPATIBILITIES
=head1 BUGS AND LIMITATIONS
There are no known bugs in this module.
Please report problems to Ivan Wills (ivan.wills@gmail.com).
Patches are welcome.
=head1 AUTHOR
Ivan Wills - (ivan.wills@gmail.com)
=head1 LICENSE AND COPYRIGHT
Copyright (c) 2009 Ivan Wills (14 Mullion Close, Hornsby Heights, NSW Australia 2077).
All rights reserved.
This module is free software; you can redistribute it and/or modify it under
the same terms as Perl itself. See L<perlartistic>. This program is
distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.
=cut