[libfile-data-perl] 01/08: Imported Upstream version 1.20
Jonas Smedegaard
dr at jones.dk
Sat Jun 18 16:03:19 UTC 2016
This is an automated email from the git hooks/post-receive script.
js pushed a commit to branch master
in repository libfile-data-perl.
commit dd683a2aea0c152bf4622b8e04ec4d88e5a08268
Author: Jonas Smedegaard <dr at jones.dk>
Date: Sat Jun 18 11:55:49 2016 +0200
Imported Upstream version 1.20
---
META.json | 12 +-
META.yml | 17 +-
Makefile.PL | 13 +-
lib/File/Data.pm | 1376 +++++++++++++++++++++++++++---------------------------
t/test.t | 116 +++--
5 files changed, 782 insertions(+), 752 deletions(-)
diff --git a/META.json b/META.json
index 9cde391..3964b7d 100644
--- a/META.json
+++ b/META.json
@@ -4,7 +4,7 @@
"unknown"
],
"dynamic_config" : 1,
- "generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.120921",
+ "generated_by" : "ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.150005",
"license" : [
"unknown"
],
@@ -31,9 +31,15 @@
}
},
"runtime" : {
- "requires" : {}
+ "requires" : {
+ "Carp" : "1.3301",
+ "Data::Dumper" : "2.151",
+ "Fcntl" : "1.11",
+ "FileHandle" : "2.02"
+ }
}
},
"release_status" : "stable",
- "version" : "1.18"
+ "version" : "1.20",
+ "x_serialization_backend" : "JSON::PP version 2.27203"
}
diff --git a/META.yml b/META.yml
index 1a1b745..9903c46 100644
--- a/META.yml
+++ b/META.yml
@@ -3,19 +3,24 @@ abstract: unknown
author:
- unknown
build_requires:
- ExtUtils::MakeMaker: 0
+ ExtUtils::MakeMaker: '0'
configure_requires:
- ExtUtils::MakeMaker: 0
+ ExtUtils::MakeMaker: '0'
dynamic_config: 1
-generated_by: 'ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.120921'
+generated_by: 'ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.150005'
license: unknown
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
- version: 1.4
+ version: '1.4'
name: File-Data
no_index:
directory:
- t
- inc
-requires: {}
-version: 1.18
+requires:
+ Carp: '1.3301'
+ Data::Dumper: '2.151'
+ Fcntl: '1.11'
+ FileHandle: '2.02'
+version: '1.20'
+x_serialization_backend: 'CPAN::Meta::YAML version 0.012'
diff --git a/Makefile.PL b/Makefile.PL
index 11aadc9..75bc03e 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -1,8 +1,15 @@
use ExtUtils::MakeMaker;
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
# the contents of the Makefile that is written.
+
WriteMakefile(
- 'NAME' => 'File::Data',
- 'VERSION_FROM' => 'lib/File/Data.pm', # finds $VERSION
- 'PREREQ_PM' => {}, # e.g., Module::Name => 1.1
+ 'NAME' => 'File::Data',
+ 'VERSION_FROM' => 'lib/File/Data.pm',
+ 'PREREQ_PM' => {
+ Carp => 1.3301,
+ 'Data::Dumper' => 2.151,
+ Fcntl => 1.11,
+ FileHandle => 2.02,
+ },
+ 'PM' => { 'lib/File/Data.pm' => '$(INST_LIBDIR)/File/Data.pm' },
);
diff --git a/lib/File/Data.pm b/lib/File/Data.pm
index 893a336..01c34e8 100644
--- a/lib/File/Data.pm
+++ b/lib/File/Data.pm
@@ -10,7 +10,7 @@ use FileHandle;
# use Tie::File; # <- todo
# use File::stat;
use vars qw(@ISA $VERSION $AUTOLOAD);
-$VERSION = do { my @r = (q$Revision: 1.18 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+$VERSION = do { my @r = (q$Revision: 1.20 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
$| = 1;
=head1 NAME
@@ -30,32 +30,32 @@ See L<new()>
=over 4
- use strict;
+ use strict;
- use File::Data;
+ use File::Data;
- my $o_dat = File::Data->new('./t/example');
+ my $o_dat = File::Data->new('./t/example');
- $o_dat->write("complete file contents\n");
+ $o_dat->write("complete file contents\n");
- $o_dat->prepend("first line\n"); # line 0
+ $o_dat->prepend("first line\n"); # line 0
- $o_dat->append("original second (last) line\n");
+ $o_dat->append("original second (last) line\n");
- $o_dat->insert(2, "new second line\n"); # inc. zero!
+ $o_dat->insert(2, "new second line\n"); # inc. zero!
- $o_dat->replace('line', 'LINE');
+ $o_dat->replace('line', 'LINE');
- print $o_dat->READ;
+ print $o_dat->READ;
Or, perhaps more seriously :-}
- my $o_sgm = File::Data->new('./sgmlfile');
+ my $o_sgm = File::Data->new('./sgmlfile');
- print "new SGML data: ".$o_sgm->REPLACE(
- '\<\s*((?i)tag)\s*\>\s*((?s).*)\s*\<\s*((?i)\s*\/\s*tag)\s*\>',
- qq|<tag>key="val"</tag>|,
- ) if $o_sgm;
+ print "new SGML data: ".$o_sgm->REPLACE(
+ '\<\s*((?i)tag)\s*\>\s*((?s).*)\s*\<\s*((?i)\s*\/\s*tag)\s*\>',
+ qq|<tag>key="val"</tag>|,
+ ) if $o_sgm;
See L<METHODS> and L<EXAMPLES>.
@@ -65,11 +65,11 @@ See L<METHODS> and L<EXAMPLES>.
lowercase method calls return the object itself, so you can chain calls.
- my $o_obj = $o_dat->read; # ! <= object !
+ my $o_obj = $o_dat->read; # ! <= object !
UPPERCASE method calls return the data relevant to the operation.
- my @data = $o_dat->READ; # ! <= data !
+ my @data = $o_dat->READ; # ! <= data !
While this may occasionally be frustrating, using the B<principle of
least surprise>, it is at least consistent.
@@ -90,7 +90,7 @@ Approaches to opening and working with files vary so much, where
one person may wish to know if a file exists, another wishes to know
whether the target is a file, or if it is readable, or writable and so on.
Sometimes, in production code even (horror), file's are opened without any
-checks of whether the open was succesful. Then there's a loop through
+checks of whether the open was successful. Then there's a loop through
each line to find the first or many patterns to read and/or replace.
With a failure, normally the only message is 'permission denied', is
that read or write access, does the file even exist? etc.
@@ -105,15 +105,27 @@ same data.
Theoretically you can mix and match your read and writes so long as you
don't open read-only.
- my $o_dat = File::Data->new($file);
+ my $o_dat = File::Data->new($file);
- my $i_snrd = $o_dat->append($append)->REPLACE($search, $replace);
+ my $i_snrd = $o_dat->append($append)->REPLACE($search, $replace);
- print $o_dat->READ;
+ print $o_dat->READ;
+
+If you want to apply the same regex, or insert/prepend/replacement/whatever
+mechanism, to many different files, then the neatest solution may be to do
+something like the following:
+
+ foreach my $file ( @list_of_file_names ) {
+ my $o_dat = File::Data->new($file);
+
+ my $i_snrd = $o_dat->append($append)->REPLACE($search, $replace);
+
+ print $o_dat->READ;
+ }
One last thing - I'm sure this could be made more efficient, and I'd be
-receptive to any suggestions to that effect. Note though that the intention
-has been to create a simple and consistent interface, rather than a complicated
+receptive to any suggestions to that effect. Note though that the intention has
+been to create a simple and consistent interface, rather than a complicated
one.
=back
@@ -134,9 +146,9 @@ my $_METHODS = join('|', @_METHODS);
Create a new File::Data object (default read-write).
- my $o_rw = File::Data->new($filename); # read-write
+ my $o_rw = File::Data->new($filename); # read-write
- my $o_ro = File::Data->new($filename, 'ro'); # read-only
+ my $o_ro = File::Data->new($filename, 'ro'); # read-only
Each file should have it's own discrete object.
@@ -144,7 +156,7 @@ Note that if you open a file read-only and then attempt to write to it,
that will be regarded as an error, even if you change the permissions
in the meantime.
-Further: The file B<must> exist before succesful use of this method
+Further: The file B<must> exist before successful use of this method
is possible. This is B<not> a replacement for modules which create and
delete files, this is purely designed as an interface to the B<data>
of existing files. A B<create> function is a future possibility.
@@ -155,229 +167,229 @@ to the B<new()> method
=cut
sub new {
- my $class = shift;
- my $file = shift;
- my $perms = shift || $File::Data::PERMISSIONS;
- my $h_err = shift || {};
-
- my $self = bless({
- '_err' => {},
- '_var' => {
- 'backup' => 0,
- 'limbo' => '',
- 'state' => 'init',
- 'writable' => 0,
- },
- }, $class);
-
- $self->_debug("file($file), perm($perms), h_err($h_err)") if $File::Data::DEBUG;
- my $i_ok = $self->_init($file, $perms, $h_err);
-
- return $i_ok == 1 ? $self : undef;
+ my $class = shift;
+ my $file = shift;
+ my $perms = shift || $File::Data::PERMISSIONS;
+ my $h_err = shift || {};
+
+ my $self = bless({
+ '_err' => {},
+ '_var' => {
+ 'backup' => 0,
+ 'limbo' => '',
+ 'state' => 'init',
+ 'writable' => 0,
+ },
+ }, $class);
+
+ $self->_debug("file($file), perm($perms), h_err($h_err)") if $File::Data::DEBUG;
+ my $i_ok = $self->_init($file, $perms, $h_err);
+
+ return $i_ok == 1 ? $self : undef;
}
=item read
Read all data from file
- $o_dat = $o_dat->read; # !
+ $o_dat = $o_dat->read; # !
- my @data = $o_dat->READ;
+ my @data = $o_dat->READ;
=cut
sub READ {
- my $self = shift;
+ my $self = shift;
- $self->_enter('read');
- $self->_debug('in: ') if $File::Data::DEBUG;
+ $self->_enter('read');
+ $self->_debug('in: ') if $File::Data::DEBUG;
- my @ret = $self->_read;
+ my @ret = $self->_read;
- $self->_debug('out: '.Dumper(\@ret)) if $File::Data::DEBUG;
- $self->_leave('read');
+ $self->_debug('out: '.Dumper(\@ret)) if $File::Data::DEBUG;
+ $self->_leave('read');
- return @ret;
+ return @ret;
};
=item _internal
read
- does this...
+ does this...
=cut
sub _read { #
- my $self = shift;
+ my $self = shift;
- my $FH = $self->_fh;
- $FH->seek(0, 0);
- #
- my @ret = <$FH>;
+ my $FH = $self->_fh;
+ $FH->seek(0, 0);
+ #
+ my @ret = <$FH>;
- return ($File::Data::REFERENCE) ? \@ret : @ret;
+ return ($File::Data::REFERENCE) ? \@ret : @ret;
};
=item write
Write data to file
- my $o_dat = $o_dat->WRITE; # !
+ my $o_dat = $o_dat->WRITE; # !
- my @written = $o_dat->write;
+ my @written = $o_dat->write;
=cut
sub WRITE {
- my $self = shift;
- my @args = @_;
- my @ret = ();
+ my $self = shift;
+ my @args = @_;
+ my @ret = ();
- $self->_enter('write');
- $self->_debug('in: '.Dumper(\@args)) if $File::Data::DEBUG;
+ $self->_enter('write');
+ $self->_debug('in: '.Dumper(\@args)) if $File::Data::DEBUG;
- if ($self->_writable) {
- my $FH = $self->_fh;
- $FH->truncate(0);
- $FH->seek(0, 0);
- @ret = $self->_write(@args);
- }
+ if ($self->_writable) {
+ my $FH = $self->_fh;
+ $FH->truncate(0);
+ $FH->seek(0, 0);
+ @ret = $self->_write(@args);
+ }
- $self->_debug('out: '.Dumper(\@ret)) if $File::Data::DEBUG;
- $self->_leave('write');
+ $self->_debug('out: '.Dumper(\@ret)) if $File::Data::DEBUG;
+ $self->_leave('write');
- return ($File::Data::REFERENCE) ? \@ret : @ret;
+ return ($File::Data::REFERENCE) ? \@ret : @ret;
};
sub _write { #
- my $self = shift;
- my @ret = ();
-
- my $FH = $self->_fh;
- my $pos = $FH->tell;
- $self->_debug("writing at curpos: $pos") if $File::Data::DEBUG;
- foreach (@_) {
- push(@ret, $_) if print $FH $_;
+ my $self = shift;
+ my @ret = ();
+
+ my $FH = $self->_fh;
+ my $pos = $FH->tell;
+ $self->_debug("writing at curpos: $pos") if $File::Data::DEBUG;
+ foreach (@_) {
+ push(@ret, $_) if print $FH $_;
$self->_debug("wrote -->$_<--") if $File::Data::DEBUG;
- }
+ }
- return ($File::Data::REFERENCE) ? \@ret : @ret;
+ return ($File::Data::REFERENCE) ? \@ret : @ret;
};
=item prepend
Prepend to file
- my $o_dat = $o_dat->prepen(\@lines); # !
+ my $o_dat = $o_dat->prepen(\@lines); # !
- my @prepended = $o_dat->prepend(\@lines);
+ my @prepended = $o_dat->prepend(\@lines);
=cut
sub PREPEND {
- my $self = shift;
- my @ret = ();
-
- $self->_enter('prepend');
- $self->_debug('in: '.Dumper(@_)) if $File::Data::DEBUG;
-
- if ($self->_writable) {
- my $FH = $self->_fh;
- $FH->seek(0, 0);
- my @data = <$FH>;
- $FH->truncate(0);
- $FH->seek(0, 0);
- @ret = @_ if $self->_write(@_, @data);
- }
+ my $self = shift;
+ my @ret = ();
+
+ $self->_enter('prepend');
+ $self->_debug('in: '.Dumper(@_)) if $File::Data::DEBUG;
+
+ if ($self->_writable) {
+ my $FH = $self->_fh;
+ $FH->seek(0, 0);
+ my @data = <$FH>;
+ $FH->truncate(0);
+ $FH->seek(0, 0);
+ @ret = @_ if $self->_write(@_, @data);
+ }
- $self->_debug('out: '.Dumper(\@ret)) if $File::Data::DEBUG;
- $self->_leave('prepend');
+ $self->_debug('out: '.Dumper(\@ret)) if $File::Data::DEBUG;
+ $self->_leave('prepend');
- return ($File::Data::REFERENCE) ? \@ret : @ret;
+ return ($File::Data::REFERENCE) ? \@ret : @ret;
};
=item insert
Insert data at line number, starting from '0'
- my $o_dat = $o_dat->insert($i_lineno, \@lines); # !
+ my $o_dat = $o_dat->insert($i_lineno, \@lines); # !
- my @inserted = $o_dat->INSERT($i_lineno, \@lines);
+ my @inserted = $o_dat->INSERT($i_lineno, \@lines);
=cut
sub INSERT {
- my $self = shift;
- my $line = shift;
- my @ret = ();
-
- $self->_enter('insert');
- $self->_debug('in: '.Dumper(\@_)) if $File::Data::DEBUG;
-
- if ($line !~ /^\d+$/) {
- $self->_error("can't go to non-numeric line($line)");
- } else {
- if ($self->_writable) {
- my $FH = $self->_fh;
- $FH->seek(0, 0);
- my $i_cnt = -1;
- my @pre = ();
- my @post = ();
- while (<$FH>) {
- $i_cnt++; # 0..n
- my $pos = $FH->tell;
- if ($i_cnt < $line) {
- push(@pre, $_);
- } elsif ($i_cnt >= $line) {
- push(@post, $_);
- }
- }
- $i_cnt++;
- if (!($i_cnt >= $line)) {
- my $s = ($i_cnt == 1) ? '' : 's';
- $self->_error("couldn't insert($line, ...) while only $i_cnt line$s in file");
- } else {
- $FH->truncate(0);
- $FH->seek(0, 0);
- @ret = @_ if $self->_write(@pre, @_, @post);
- }
- }
- }
-
- $self->_debug('out: '.Dumper(\@ret)) if $File::Data::DEBUG;
- $self->_leave('insert');
-
- return ($File::Data::REFERENCE) ? \@ret : @ret;
+ my $self = shift;
+ my $line = shift;
+ my @ret = ();
+
+ $self->_enter('insert');
+ $self->_debug('in: '.Dumper(\@_)) if $File::Data::DEBUG;
+
+ if ($line !~ /^\d+$/) {
+ $self->_error("can't go to non-numeric line($line)");
+ } else {
+ if ($self->_writable) {
+ my $FH = $self->_fh;
+ $FH->seek(0, 0);
+ my $i_cnt = -1;
+ my @pre = ();
+ my @post = ();
+ while (<$FH>) {
+ $i_cnt++; # 0..n
+ my $pos = $FH->tell;
+ if ($i_cnt < $line) {
+ push(@pre, $_);
+ } elsif ($i_cnt >= $line) {
+ push(@post, $_);
+ }
+ }
+ $i_cnt++;
+ if (!($i_cnt >= $line)) {
+ my $s = ($i_cnt == 1) ? '' : 's';
+ $self->_error("couldn't insert($line, ...) while only $i_cnt line$s in file");
+ } else {
+ $FH->truncate(0);
+ $FH->seek(0, 0);
+ @ret = @_ if $self->_write(@pre, @_, @post);
+ }
+ }
+ }
+
+ $self->_debug('out: '.Dumper(\@ret)) if $File::Data::DEBUG;
+ $self->_leave('insert');
+
+ return ($File::Data::REFERENCE) ? \@ret : @ret;
}
=item append
Append to file
- my $o_dat = $o_dat->append(\@lines); # !
+ my $o_dat = $o_dat->append(\@lines); # !
- my @appended = $o_dat->APPEND(\@lines);
+ my @appended = $o_dat->APPEND(\@lines);
=cut
sub APPEND {
- my $self = shift;
- my @ret = ();
+ my $self = shift;
+ my @ret = ();
- $self->_enter('append');
- $self->_debug('in: '.Dumper(\@_)) if $File::Data::DEBUG;
+ $self->_enter('append');
+ $self->_debug('in: '.Dumper(\@_)) if $File::Data::DEBUG;
- if ($self->_writable) {
- my $FH = $self->_fh;
- $FH->seek(0, 2);
- @ret = @_ if $self->_write(@_);
- }
+ if ($self->_writable) {
+ my $FH = $self->_fh;
+ $FH->seek(0, 2);
+ @ret = @_ if $self->_write(@_);
+ }
- $self->_debug('out: '.Dumper(\@ret)) if $File::Data::DEBUG;
- $self->_leave('append');
+ $self->_debug('out: '.Dumper(\@ret)) if $File::Data::DEBUG;
+ $self->_leave('append');
- return ($File::Data::REFERENCE) ? \@ret : @ret;
+ return ($File::Data::REFERENCE) ? \@ret : @ret;
};
=item search
@@ -386,65 +398,66 @@ Retrieve data out of a file, simple list of all matches found are returned.
Note - you must use capturing parentheses for this to work!
- my $o_dat = $o_dat->search('/^(.*\@.*)$/'); # !
+ my $o_dat = $o_dat->search('^(.*\@.*)$'); # !
- my @addrs = $o_dat->SEARCH('/^(.*\@.*)$/');
+ my @addrs = $o_dat->SEARCH('^(.*\@.*)$');
- my @names = $o_dat->SEARCH('/^(?:[^:]:){4}([^:]+):/');
+ my @names = $o_dat->SEARCH('^(?:[^:]:){4}([^:]+):');
=cut
sub SEARCH {
- my $self = shift;
- my $search = shift;
- my @ret = ();
-
- $self->_enter('search');
- $self->_debug("in: $search") if $File::Data::DEBUG;
-
- if ($search !~ /.+/) {
- $self->_error("no search($search) given");
- } else {
- my $file = $self->_var('filename');
- my $FH = $self->_fh;
- $FH->seek(0, 0);
- my $i_cnt = 0;
- if ($File::Data::STRING) { # default
- my $orig = $/; $/ = undef; # slurp
- my $data = <$FH>; $/ = $orig;
- $self->_debug("looking at data($data)") if $File::Data::DEBUG;
- @ret = ($data =~ /$search/g);
- $i_cnt = ($data =~ tr/\n/\n/);
- } else {
- while (<$FH>) {
- $self->_debug("looking at line($_)") if $File::Data::DEBUG;
- my $line = $_;
- push(@ret, ($line =~ /$search/));
- $i_cnt++;
- }
- }
- if (scalar(@ret) >= 1) {
- $self->_debug("search($search) failed(@ret) in file($file) lines($i_cnt)");
- }
- }
-
- $self->_debug('out: '.Dumper(\@ret)) if $File::Data::DEBUG;
- $self->_leave('search');
-
- return ($File::Data::REFERENCE) ? \@ret : @ret;
+ my $self = shift;
+ my $search = shift;
+ my @ret = ();
+
+ $self->_enter('search');
+ $self->_debug("in: $search") if $File::Data::DEBUG;
+
+ if ($search !~ /.+/) {
+ $self->_error("no search($search) given");
+ } else {
+ my $file = $self->_var('filename');
+ my $FH = $self->_fh;
+ $FH->seek(0, 0);
+ my $i_cnt = 0;
+ if ($File::Data::STRING) { # default
+ my $orig = $/; $/ = undef; # slurp
+ my $data = <$FH>; $/ = $orig;
+ $self->_debug("looking at data($data)") if $File::Data::DEBUG;
+ @ret = ($data =~ /$search/g);
+ $i_cnt = ($data =~ tr/\n/\n/);
+ } else {
+ while (<$FH>) {
+ $self->_debug("looking at line($_)") if $File::Data::DEBUG;
+ my $line = $_;
+ # push(@ret, ($line =~ /$search/));
+ push(@ret, $line) if ($line =~ /$search/);
+ $i_cnt++;
+ }
+ }
+ if (scalar(@ret) >= 1) {
+ $self->_debug("search($search) in file($file) lines($i_cnt) result(@ret)");
+ }
+ }
+
+ $self->_debug('out: '.Dumper(\@ret)) if $File::Data::DEBUG;
+ $self->_leave('search');
+
+ return ($File::Data::REFERENCE) ? \@ret : @ret;
}
=item replace
Replace data in a 'search and replace' manner, returns the final data.
- my $o_dat = $o_dat->replace($search, $replace); # !
+ my $o_dat = $o_dat->replace($search, $replace); # !
- my @data = $o_dat->REPLACE($search, $replace);
+ my @data = $o_dat->REPLACE($search, $replace);
- my @data = $o_dat->REPLACE(
- q|\<a href=(['"])([^$1]+)?$1| => q|'my.sales.com'|,
- );
+ my @data = $o_dat->REPLACE(
+ q|\<a href=(['"])([^$1]+)?$1| => q|'my.sales.com'|,
+ );
This is B<simple>, in that you can do almost anything in the B<search> side,
but the B<replace> side is a bit more restricted, as we can't effect the
@@ -455,56 +468,56 @@ If you really need this, perhaps B<(?{})> can help?
=cut
sub REPLACE {
- my $self = shift;
- my %args = @_;
- my @ret = ();
-
- $self->_enter('replace');
- $self->_debug('in: '.Dumper(\%args)) if $File::Data::DEBUG;
-
- if ($self->_writable) {
- my $file = $self->_var('filename');
- my $FH = $self->_fh;
- $FH->seek(0, 0);
- my $i_cnt = 0;
- SEARCH:
- foreach my $search (keys %args) {
- my $replace = $args{$search};
- if ($File::Data::STRING) { # default
- my $orig = $/; $/ = undef; # slurp
- my $data = <$FH>; $/ = $orig;
- $self->_debug("initial ($data)") if $File::Data::DEBUG;
- if (($i_cnt = ($data =~ s/$search/$replace/g))) {
- @ret = $data;
- } else {
- print "unable($i_cnt) to search($search) and replace($replace)\n";
- }
- } else {
- while (<$FH>) {
- $self->_debug("initial line($_)") if $File::Data::DEBUG;
- my $line = $_;
- if ($line =~ s/$search/$replace/) {
- $i_cnt++;
- }
- push(@ret, $line);
- }
- }
+ my $self = shift;
+ my %args = @_;
+ my @ret = ();
+
+ $self->_enter('replace');
+ $self->_debug('in: '.Dumper(\%args)) if $File::Data::DEBUG;
+
+ if ($self->_writable) {
+ my $file = $self->_var('filename');
+ my $FH = $self->_fh;
+ $FH->seek(0, 0);
+ my $i_cnt = 0;
+ SEARCH:
+ foreach my $search (keys %args) {
+ my $replace = $args{$search};
+ if ($File::Data::STRING) { # default
+ my $orig = $/; $/ = undef; # slurp
+ my $data = <$FH>; $/ = $orig;
+ $self->_debug("initial ($data)") if $File::Data::DEBUG;
+ if (($i_cnt = ($data =~ s/$search/$replace/g))) {
+ @ret = $data;
+ } else {
+ print "unable($i_cnt) to search($search) and replace($replace)\n";
+ }
+ } else {
+ while (<$FH>) {
+ $self->_debug("initial line($_)") if $File::Data::DEBUG;
+ my $line = $_;
+ if ($line =~ s/$search/$replace/) {
+ $i_cnt++;
+ }
+ push(@ret, $line);
+ }
+ }
if (scalar(@ret) >= 1) {
$FH->seek(0, 0);
$FH->truncate(0);
$FH->seek(0, 0);
@ret = $self->_write(@ret);
}
- if (!($i_cnt >= 1)) {
- $self->_debug("nonfulfilled search($search) and replace($replace) in file($file)");
- }
- }
- }
+ if (!($i_cnt >= 1)) {
+ $self->_debug("nonfulfilled search($search) and replace($replace) in file($file)");
+ }
+ }
+ }
- $self->_debug('out: '.Dumper(\@ret)) if $File::Data::DEBUG;
- $self->_leave('replace');
+ $self->_debug('out: '.Dumper(\@ret)) if $File::Data::DEBUG;
+ $self->_leave('replace');
- return ($File::Data::REFERENCE) ? \@ret : @ret;
+ return ($File::Data::REFERENCE) ? \@ret : @ret;
}
=item xreturn
@@ -520,17 +533,17 @@ Returns the product of the given (or last) B<do()>, undef on failure.
=cut
sub RETURN {
- my $self = shift;
- my $call = uc(shift) || $self->_var('last');
-
- if ((defined($self->{'_var'}{$call}) &&
- ref($self->{'_var'}{$call}) eq 'ARRAY'
- )) {
- return @{$self->_var($call)};
- } else {
- $self->_debug("not returning invalid call($call) ref($self->{'_var'}{$call})");
- return undef;
- }
+ my $self = shift;
+ my $call = uc(shift) || $self->_var('last');
+
+ if ((defined($self->{'_var'}{$call}) &&
+ ref($self->{'_var'}{$call}) eq 'ARRAY'
+ )) {
+ return @{$self->_var($call)};
+ } else {
+ $self->_debug("not returning invalid call($call) ref($self->{'_var'}{$call})");
+ return undef;
+ }
}
=item create
@@ -540,11 +553,11 @@ placeholder - unsupported
=cut
sub create {
- my $self = shift;
+ my $self = shift;
- $self->_error("unsupported call: __FILE__(@_)");
+ $self->_error("unsupported call: __FILE__(@_)");
- return ();
+ return ();
}
=item delete
@@ -554,25 +567,25 @@ placeholder - unsupported
=cut
sub delete {
- my $self = shift;
+ my $self = shift;
- $self->_error("unsupported call: __FILE__(@_)");
+ $self->_error("unsupported call: __FILE__(@_)");
- return ();
+ return ();
}
=item close
Close the file
- my $i_closed = $o_dat->close; # 1|0
+ my $i_closed = $o_dat->close; # 1|0
=cut
sub close {
- my $self = shift;
+ my $self = shift;
- return $self->_close;
+ return $self->_close;
}
@@ -584,47 +597,47 @@ placeholder - unsupported
# Returns File::stat object for the file.
-# print 'File size: '.$o_dat->stat->size;
+# print 'File size: '.$o_dat->stat->size;
sub xFSTAT {
- my $self = shift;
- my $file = shift || '_';
+ my $self = shift;
+ my $file = shift || '_';
- # print "file($file) stat: ".Dumper(stat($file));
+ # print "file($file) stat: ".Dumper(stat($file));
- # return stat($file);
+ # return stat($file);
- return ();
+ return ();
}
sub xfstat {
- my $self = shift;
- my $file = shift || '_';
+ my $self = shift;
+ my $file = shift || '_';
- # print "file($file) stat: ".Dumper(stat($file));
+ # print "file($file) stat: ".Dumper(stat($file));
- # stat($file);
+ # stat($file);
- return ();
+ return ();
}
sub dummy {
- my $self = shift;
- my %args = @_;
- my @ret = ();
+ my $self = shift;
+ my %args = @_;
+ my @ret = ();
- $self->_enter('dummy');
- $self->_debug('in: '.Dumper(\%args)) if $File::Data::DEBUG;
+ $self->_enter('dummy');
+ $self->_debug('in: '.Dumper(\%args)) if $File::Data::DEBUG;
- # if ($self->_writable) {
- #
- # $FH->seek(0, 2);
- # }
+ # if ($self->_writable) {
+ #
+ # $FH->seek(0, 2);
+ # }
- $self->_debug('out: '.Dumper(\@ret)) if $File::Data::DEBUG;
- $self->_leave('dummy');
+ $self->_debug('out: '.Dumper(\@ret)) if $File::Data::DEBUG;
+ $self->_leave('dummy');
- return ($File::Data::REFERENCE) ? \@ret : @ret;
+ return ($File::Data::REFERENCE) ? \@ret : @ret;
}
=back
@@ -643,11 +656,11 @@ Various variables may be set affecting the behaviour of the module.
Set to 0 (default) or 1 for debugging information to be printed on STDOUT.
- $File::Data::DEBUG = 1;
+ $File::Data::DEBUG = 1;
Alternatively set to a regex of any of the prime methods to debug them individually.
- $File::Data::DEBUG = '(ap|pre)pend';
+ $File::Data::DEBUG = '(ap|pre)pend';
=cut
@@ -660,7 +673,7 @@ Will die if there is any failure in accessing the file, or reading the data.
Default = 0 (don't die - just warn);
- $File::Data::FATAL = 1; # die
+ $File::Data::FATAL = 1; # die
=cut
@@ -673,11 +686,11 @@ Will return a reference, not a list, useful with large files.
Default is 0, ie; methods normally returns a list. There may be an argument to
make returns work with references by default, feedback will decide.
- $File::Data::REFERENCE = 1;
+ $File::Data::REFERENCE = 1;
- my $a_ref = $o_dat->search('.*');
+ my $a_ref = $o_dat->search('.*');
- print "The log: \n".@{ $a_ref };
+ print "The log: \n".@{ $a_ref };
=cut
@@ -688,7 +701,7 @@ $File::Data::REFERENCE ||= $ENV{'File_Data_REFERENCE'} || 0;
Set to something other than zero if you don't want error messages ?-\
- $File::Data::SILENT = 0; # per line
+ $File::Data::SILENT = 0; # per line
=cut
@@ -702,7 +715,7 @@ single scalar string, so that, for example, B<(?ms:...)> matches are effective.
Unset if you don't want this behaviour.
- $File::Data::STRING = 0; # per line
+ $File::Data::STRING = 0; # per line
=cut
@@ -719,11 +732,11 @@ We don't support fancy permission sets, just read or write.
Read-only permissions may be explicitly set using one of these B<keys>:
- $File::Data::PERMISSIONS = 'ro'; # or readonly or <
+ $File::Data::PERMISSIONS = 'ro'; # or readonly or <
Or, equivalently, for read-write (default):
- $File::Data::PERMISSIONS = 'rw'; # or readwrite or +<
+ $File::Data::PERMISSIONS = 'rw'; # or readwrite or +<
Note that it makes no sense to have an 'append only' command (>>),
we'd have to disable all of write, search and replace, and insert,
@@ -751,7 +764,7 @@ $File::Data::PERMISSIONS ||= $ENV{'File_Data_PERMISSIONS'} || '+<';
Any unrecognised function will be passed to the FileHandle object for final
consideration, behaviour is then effectively 'o_dat ISA FileHandle'.
- $o_dat->truncate;
+ $o_dat->truncate;
=cut
@@ -760,20 +773,20 @@ sub AUTOLOAD {
return if $AUTOLOAD =~ /::DESTROY$/o; # protection
my $meth = $AUTOLOAD;
- $meth =~ s/.+::([^:]+)$/$1/;
+ $meth =~ s/.+::([^:]+)$/$1/;
- if ($meth =~ /^($_METHODS)$/io) { # convenience
- $self->_debug("rerouting: $meth(@_)");
- return $self->do(uc($meth), @_); # <-
+ if ($meth =~ /^($_METHODS)$/io) { # convenience
+ $self->_debug("rerouting: $meth(@_)");
+ return $self->do(uc($meth), @_); # <-
# return $self->do(lc($meth), @_);
- } else { # or fallback
- my $FH = $self->_fh;
- if ($FH->can($meth)) {
- return $FH->$meth(@_); # <-
- } else {
- $DB::single=2; #
- return $self->_error("no such method($meth)!"); # <-
- }
+ } else { # or fallback
+ my $FH = $self->_fh;
+ if ($FH->can($meth)) {
+ return $FH->$meth(@_); # <-
+ } else {
+ $DB::single=2; #
+ return $self->_error("no such method($meth)!"); # <-
+ }
}
}
@@ -787,29 +800,29 @@ sub AUTOLOAD {
Typical construction examples:
- my $o_rw = File::Data->new($filename, 'rw');
+ my $o_rw = File::Data->new($filename, 'rw');
- my $o_ro = File::Data->new($filename, 'ro');
+ my $o_ro = File::Data->new($filename, 'ro');
=over 4
=item complete
- my $o_dat = File::Data->new('./jabber');
+ my $o_dat = File::Data->new('./jabber');
- $o_dat->write(" Bewxre the Jabberwock my son,\n");
+ $o_dat->write(" Bewxre the Jabberwock my son,\n");
- $o_dat->prepend("The Jxbberwock by Lewis Cxrroll:\n");
+ $o_dat->prepend("The Jxbberwock by Lewis Cxrroll:\n");
- $o_dat->append(" the claws thxt snxtch,\n ...\n");
+ $o_dat->append(" the claws thxt snxtch,\n ...\n");
- $o_dat->insert(2, " the jaws which bite.\n");
+ $o_dat->insert(2, " the jaws which bite.\n");
- $o_dat->replace('x', 'a');
+ $o_dat->replace('x', 'a');
- print $o_dat->SEARCH('The.+\n')->REPLACE("The.+\n", '')->return('search');
+ print $o_dat->SEARCH('The.+\n')->REPLACE("The.+\n", '')->return('search');
- print $o_dat->READ;
+ print $o_dat->READ;
=item error
@@ -821,25 +834,25 @@ special B<init> call for initial file opening and general setting up.
Create a read-write object with a callback for all errors:
- my $o_rw = File::Data->new($filename, 'ro', {
- 'error' => \&myerror,
- });
+ my $o_rw = File::Data->new($filename, 'ro', {
+ 'error' => \&myerror,
+ });
Create a read-only object with a separate object handler for each error type:
- my $o_rw = File::Data->new($filename, 'rw', {
- 'error' => $o_generic->error_handler,
- 'insert' => $o_handler->insert_error,
- 'open' => $o_open_handler,
- 'read' => \&carp,
- 'write' => \&write_error,
- });
+ my $o_rw = File::Data->new($filename, 'rw', {
+ 'error' => $o_generic->error_handler,
+ 'insert' => $o_handler->insert_error,
+ 'open' => $o_open_handler,
+ 'read' => \&carp,
+ 'write' => \&write_error,
+ });
=item commandline
From the command line:
- C<perl -MFile::Data -e "File::Data->new('./test.txt')->write('some stuff')">
+ C<perl -MFile::Data -e "File::Data->new('./test.txt')->write('some stuff')">
And (very non-obfuscated)
@@ -855,8 +868,8 @@ And (very non-obfuscated)
>
If you still have problems, mail me the output of
-
- make test TEST_VERBOSE=1
+
+ make test TEST_VERBOSE=1
=cut
@@ -868,85 +881,85 @@ If you still have problems, mail me the output of
# Variable get/set method
#
-# my $get = $o_dat->_var($key); # get
+# my $get = $o_dat->_var($key); # get
#
-# my $set = $o_dat->_var($key, $val); # set
+# my $set = $o_dat->_var($key, $val); # set
# @_METHODS, qw(append insert prepend read replace return search write);
my $_VARS = join('|', @_METHODS, qw(
- backup error errors filename filehandle last limbo permissions state writable
+ backup error errors filename filehandle last limbo permissions state writable
));
sub _var {
- my $self = shift;
- my $key = shift;
- my $val = shift;
- my $ret = '';
-
- # if (!(grep(/^_$key$/, keys %{$self{'_var'}}))) {
- if ($key !~ /^($_VARS)$/io) {
- $self->_error("No such key($key) val($val)!");
- } else {
- if (defined($val)) {
- $self->{'_var'}{$key} = $val;
- # {"$File::Data::$key"} = $val;
- $self->_debug("set key($key) => val($val)");
- }
- $ret = $self->{'_var'}{$key};
- }
-
- return $ret;
+ my $self = shift;
+ my $key = shift;
+ my $val = shift;
+ my $ret = '';
+
+ # if (!(grep(/^_$key$/, keys %{$self{'_var'}}))) {
+ if ($key !~ /^($_VARS)$/io) {
+ $self->_error("No such key($key) val($val)!");
+ } else {
+ if (defined($val)) {
+ $self->{'_var'}{$key} = $val;
+ # {"$File::Data::$key"} = $val;
+ $self->_debug("set key($key) => val($val)");
+ }
+ $ret = $self->{'_var'}{$key};
+ }
+
+ return $ret;
}
# Print given args on STDOUT
#
-# $o_dat->_debug($msg) if $File::Data::DEBUG;
+# $o_dat->_debug($msg) if $File::Data::DEBUG;
sub _debug {
- my $self = shift;
+ my $self = shift;
- my $state = $self->{'_var'}{'state'}; # ahem
- my $debug = $File::Data::DEBUG;
+ my $state = $self->{'_var'}{'state'}; # ahem
+ my $debug = $File::Data::DEBUG;
- if (($debug =~ /^(\d+)$/o && $1 >= 1) ||
- $debug =~ /^(.+)$/o && $state =~ /$debug/
- ) {
- print ("$state: ", @_, "\n");
- }
+ if (($debug =~ /^(\d+)$/o && $1 >= 1) ||
+ $debug =~ /^(.+)$/o && $state =~ /$debug/
+ ) {
+ print ("$state: ", @_, "\n");
+ }
- return ();
+ return ();
}
# Return dumped env and object B<key> and B<values>
#
-# print $o_dat->_vars;
+# print $o_dat->_vars;
sub _vars {
- my $self = shift;
- my $h_ret = $self;
-
- no strict 'refs';
- foreach my $key (keys %{File::Data::}) {
- next unless $key =~ /^[A-Z]+$/o;
- next if $key =~ /^(BEGIN|EXPORT)/o;
- my $var = "File::Data::$key";
- $$h_ret{'_pck'}{$key} = $$var;
- }
-
- return Dumper($h_ret);
+ my $self = shift;
+ my $h_ret = $self;
+
+ no strict 'refs';
+ foreach my $key (keys %{File::Data::}) {
+ next unless $key =~ /^[A-Z]+$/o;
+ next if $key =~ /^(BEGIN|EXPORT)/o;
+ my $var = "File::Data::$key";
+ $$h_ret{'_pck'}{$key} = $$var;
+ }
+
+ return Dumper($h_ret);
}
# Get/set error handling methods/objects
#
-# my $c_sub = $o_dat->_err('insert'); # or default
+# my $c_sub = $o_dat->_err('insert'); # or default
sub _err {
- my $self = shift;
- my $state = shift || $self->_var('state');
+ my $self = shift;
+ my $state = shift || $self->_var('state');
- my $err = $self->{'_err'}{$state} || $self->{'_err'}{'default'};
+ my $err = $self->{'_err'}{$state} || $self->{'_err'}{'default'};
- return $err;
+ return $err;
}
# By default prints error to STDERR, will B<croak> if B<File::Data::FATAL> set,
@@ -954,361 +967,361 @@ sub _err {
# handlers in.
sub _error {
- my $self = shift;
- my @err = @_;
- my @ret = ();
-
- my $state = $self->_var('state');
- my $c_ref = $self->_err($state );
- my $error = $self->_var('error');
- unshift(@err, "$state ERROR: ");
- my $ref = $self->_var('errors', join("\n", @err));
-
- # $self->_debug($self->_vars) if $File::Data::DEBUG;
-
- if (ref($c_ref) eq 'CODE') {
- eval { @ret = &$c_ref(@err) };
- if ($@) {
- $File::Data::FATAL >= 1
- ? croak("$0 failed: $c_ref(@err)")
- : carp("$0 failed: $c_ref(@err)")
- ;
- }
- } elsif (ref($c_ref) && $c_ref->can($state)) {
- eval { @ret = $c_ref->$state(@err) };
- if ($@) {
- $File::Data::FATAL >= 1
- ? croak("$0 failed: $c_ref(@err)")
- : carp("$0 failed: $c_ref(@err)")
- ;
- }
- } else {
- unless ($File::Data::SILENT) {
- ($File::Data::FATAL >= 1) ? croak(@err) : carp(@err);
- }
- }
-
- return (); #
+ my $self = shift;
+ my @err = @_;
+ my @ret = ();
+
+ my $state = $self->_var('state');
+ my $c_ref = $self->_err($state );
+ my $error = $self->_var('error');
+ unshift(@err, "$state ERROR: ");
+ my $ref = $self->_var('errors', join("\n", @err));
+
+ # $self->_debug($self->_vars) if $File::Data::DEBUG;
+
+ if (ref($c_ref) eq 'CODE') {
+ eval { @ret = &$c_ref(@err) };
+ if ($@) {
+ $File::Data::FATAL >= 1
+ ? croak("$0 failed: $c_ref(@err)")
+ : carp("$0 failed: $c_ref(@err)")
+ ;
+ }
+ } elsif (ref($c_ref) && $c_ref->can($state)) {
+ eval { @ret = $c_ref->$state(@err) };
+ if ($@) {
+ $File::Data::FATAL >= 1
+ ? croak("$0 failed: $c_ref(@err)")
+ : carp("$0 failed: $c_ref(@err)")
+ ;
+ }
+ } else {
+ unless ($File::Data::SILENT) {
+ ($File::Data::FATAL >= 1) ? croak(@err) : carp(@err);
+ }
+ }
+
+ return (); #
}
-# my $file = $o_dat->_mapfile($filename);
+# my $file = $o_dat->_mapfile($filename);
sub _mapfile {
- my $self = shift;
- my $file = shift || '';
-
- $file =~ s/^\s*//o;
- $file =~ s/\s*$//o;
-
- unless ($file =~ /\w+/o) {
- $file = '';
- $self->_error("inappropriate filename($file)");
- } else {
- my $xfile = $self->_var('filename') || '';
- if ($xfile =~ /.+/o) {
- $file = '';
- $self->_error("can't reuse ".ref($self)." object($xfile) for another file($file)");
- }
- }
-
- return $file;
+ my $self = shift;
+ my $file = shift || '';
+
+ $file =~ s/^\s*//o;
+ $file =~ s/\s*$//o;
+
+ unless ($file =~ /\w+/o) {
+ $file = '';
+ $self->_error("inappropriate filename($file)");
+ } else {
+ my $xfile = $self->_var('filename') || '';
+ if ($xfile =~ /.+/o) {
+ $file = '';
+ $self->_error("can't reuse ".ref($self)." object($xfile) for another file($file)");
+ }
+ }
+
+ return $file;
}
# Maps given permissions to appropriate form for B<FileHandle>
#
-# my $perms = $o_dat->_mapperms('+<');
+# my $perms = $o_dat->_mapperms('+<');
sub _mapperms {
- my $self = shift;
- my $args = shift || '';
+ my $self = shift;
+ my $args = shift || '';
- $args =~ s/^\s*//o;
- $args =~ s/\s*$//o;
+ $args =~ s/^\s*//o;
+ $args =~ s/\s*$//o;
- my %map = ( # we only recognise
- 'ro' => '<',
- 'readonly' => '<',
- 'rw' => '+<',
- 'readwrite' => '+<',
- );
- my $ret = $map{$args} || $args;
+ my %map = ( # we only recognise
+ 'ro' => '<',
+ 'readonly' => '<',
+ 'rw' => '+<',
+ 'readwrite' => '+<',
+ );
+ my $ret = $map{$args} || $args;
- $self->_error("Inappropriate permissions($args) - use this: ".Dumper(\%map))
- unless $ret =~ /.+/o;
+ $self->_error("Inappropriate permissions($args) - use this: ".Dumper(\%map))
+ unless $ret =~ /.+/o;
- return $ret;
+ return $ret;
}
# Map error handlers, if given
#
-# my $h_errs = $o_dat->_maperrs(\%error_handlers);
+# my $h_errs = $o_dat->_maperrs(\%error_handlers);
sub _mapperrs {
- my $self = shift;
- my $h_errs = shift || {};
-
- if (ref($h_errs) ne 'HASH') {
- $self->_error("invalid error_handlers($h_errs)");
- } else {
- foreach my $key (%{$h_errs}) {
- $self->{'_err'}{$key} = $$h_errs{$key};
- }
- }
-
- return $self->{'_err'};
+ my $self = shift;
+ my $h_errs = shift || {};
+
+ if (ref($h_errs) ne 'HASH') {
+ $self->_error("invalid error_handlers($h_errs)");
+ } else {
+ foreach my $key (%{$h_errs}) {
+ $self->{'_err'}{$key} = $$h_errs{$key};
+ }
+ }
+
+ return $self->{'_err'};
}
# Mark the entering of a special section, or state
#
-# my $entered = $o_dat->enter('search');
+# my $entered = $o_dat->enter('search');
sub _enter {
- my $self = shift;
- my $sect = shift;
-
- my $last = $self->_var('state');
- $self->_var('last' => $last) unless $last eq 'limbo';
- my $next = $self->_var('state' => $sect);
+ my $self = shift;
+ my $sect = shift;
+
+ my $last = $self->_var('state');
+ $self->_var('last' => $last) unless $last eq 'limbo';
+ my $next = $self->_var('state' => $sect);
- # $self->_debug("vars") if $File::Data::DEBUG;
+ # $self->_debug("vars") if $File::Data::DEBUG;
- return $next;
+ return $next;
}
# Mark the leaving of a special section, or state
#
-# my $left = $o_dat->_leave('search');
+# my $left = $o_dat->_leave('search');
sub _leave {
- my $self = shift;
- my $sect = shift;
-
- my $last = $self->_var('state');
- $self->_var('last' => $last) unless $last eq 'limbo';
- my $next = $self->_var('state' => 'limbo');
+ my $self = shift;
+ my $sect = shift;
+
+ my $last = $self->_var('state');
+ $self->_var('last' => $last) unless $last eq 'limbo';
+ my $next = $self->_var('state' => 'limbo');
- # $self->_debug("leaving state($last) => next($next)") if $File::Data::DEBUG;
+ # $self->_debug("leaving state($last) => next($next)") if $File::Data::DEBUG;
- return $last;
+ return $last;
}
# Get and set B<FileHandle>. Returns undef otherwise.
#
-# my $FH = $o_dat->_fh($FH);
+# my $FH = $o_dat->_fh($FH);
sub _fh {
- my $self = shift;
- my $arg = shift;
+ my $self = shift;
+ my $arg = shift;
- my $FH = (defined($arg)
- ? $self->_var('filehandle', $arg)
- : $self->_var('filehandle')
- );
- $self->_error("no filehandle($FH)") unless $FH;
+ my $FH = (defined($arg)
+ ? $self->_var('filehandle', $arg)
+ : $self->_var('filehandle')
+ );
+ $self->_error("no filehandle($FH)") unless $FH;
- return $FH;
+ return $FH;
}
# ================================================================
# Return values:
#
-# 1 = success
+# 1 = success
#
-# 0 = failure
+# 0 = failure
# Setup object, open a file, with permissions.
#
-# my $i_ok = $o_dat->_init( $file, $perm, $h_errs );
+# my $i_ok = $o_dat->_init( $file, $perm, $h_errs );
sub _init {
- my $self = shift;
- my $file = shift;
- my $perm = shift;
- my $h_err= shift;
- my $i_ok = 0;
-
- # $self->_enter('init');
- $self->_debug("in: file($file), perm($perm), h_err($h_err)") if $File::Data::DEBUG;
-
- $file = $self->_mapfile($file );
- $perm = $self->_mapperms($perm ) if $file;
- $h_err = $self->_mapperrs($h_err) if $file; # if $perm
-
- if ($file) { # unless $h_err
- $i_ok = $self->_check_access($file, $perm);
- if ($i_ok == 1) {
- $file = $self->_var('filename', $file);
- $perm = $self->_var('permissions', $perm);
- $i_ok = $self->_open($file, $perm);
- $i_ok = $self->_backup() if $i_ok && $self->_var('backup');
- }
- }
- # $self->_error("failed for file($file) and perm($perm)") unless $i_ok == 1;
-
- $self->_debug("out: $i_ok") if $File::Data::DEBUG;
- $self->_leave('init');
-
- return $i_ok;
+ my $self = shift;
+ my $file = shift;
+ my $perm = shift;
+ my $h_err= shift;
+ my $i_ok = 0;
+
+ # $self->_enter('init');
+ $self->_debug("in: file($file), perm($perm), h_err($h_err)") if $File::Data::DEBUG;
+
+ $file = $self->_mapfile($file );
+ $perm = $self->_mapperms($perm ) if $file;
+ $h_err = $self->_mapperrs($h_err) if $file; # if $perm
+
+ if ($file) { # unless $h_err
+ $i_ok = $self->_check_access($file, $perm);
+ if ($i_ok == 1) {
+ $file = $self->_var('filename', $file);
+ $perm = $self->_var('permissions', $perm);
+ $i_ok = $self->_open($file, $perm);
+ $i_ok = $self->_backup() if $i_ok && $self->_var('backup');
+ }
+ }
+ # $self->_error("failed for file($file) and perm($perm)") unless $i_ok == 1;
+
+ $self->_debug("out: $i_ok") if $File::Data::DEBUG;
+ $self->_leave('init');
+
+ return $i_ok;
}
# Checks the args for existence and appropriate permissions etc.
#
-# my $i_isok = $o_dat->_check_access($filename, $permissions);
+# my $i_isok = $o_dat->_check_access($filename, $permissions);
sub _check_access {
- my $self = shift;
- my $file = shift;
- my $perm = shift;
- my $i_ok = 0;
-
- if (!($file =~ /.+/o && $perm =~ /.+/o)) {
- $self->_error("no filename($file) or permissions($perm) given!");
- } else {
- stat($file); # just once
- if (! -e _) {
- $self->_error("target($file) does not exist!");
- } else {
- if (! -f _) {
- $self->_error("target($file) is not a file!");
- } else {
- if (!-r _) {
- $self->_error("file($file) cannot be read by effective uid($>) or gid($))!");
- } else {
- if ($perm =~ /^<$/o) { # readable
- $i_ok++;
- } else {
- if (! -w $file) {
- $self->_error("file($file) cannot be written by effective uid($>) or gid($))!");
- } else { # writable
- $self->_var('writable' => 1);
- $i_ok++;
- }
- }
- }
- }
- }
- }
-
- return $i_ok;
+ my $self = shift;
+ my $file = shift;
+ my $perm = shift;
+ my $i_ok = 0;
+
+ if (!($file =~ /.+/o && $perm =~ /.+/o)) {
+ $self->_error("no filename($file) or permissions($perm) given!");
+ } else {
+ stat($file); # just once
+ if (! -e _) {
+ $self->_error("target($file) does not exist!");
+ } else {
+ if (! -f _) {
+ $self->_error("target($file) is not a file!");
+ } else {
+ if (!-r _) {
+ $self->_error("file($file) cannot be read by effective uid($>) or gid($))!");
+ } else {
+ if ($perm =~ /^<$/o) { # readable
+ $i_ok++;
+ } else {
+ if (! -w $file) {
+ $self->_error("file($file) cannot be written by effective uid($>) or gid($))!");
+ } else { # writable
+ $self->_var('writable' => 1);
+ $i_ok++;
+ }
+ }
+ }
+ }
+ }
+ }
+
+ return $i_ok;
}
# Open the file
#
-# my $i_ok = $o_dat->_open;
+# my $i_ok = $o_dat->_open;
sub _open {
- my $self = shift;
- my $file = $self->_var('filename');
- my $perm = $self->_var('permissions');
- my $i_ok = 0;
-
- my $open = "$perm $file";
- $self->_debug("using open($open)");
-
- my $FH = FileHandle->new("$perm $file") || '';
- my @file = ();
- # my $FH = tie(@file, 'Tie::File', $file) or '';
- if (!$FH) {
- $self->_error("Can't get handle($FH) for file($file) with permissions($perm)! $!");
- } else {
- # $FH = $self->_fh(\@file);
- $FH = $self->_fh($FH);
- if ($FH) {
- $i_ok++;
- $i_ok = $self->_lock(); # if $self->_writable;
- }
- $self->_debug("FH($FH) => i_ok($i_ok)");
- }
-
- return $i_ok;
+ my $self = shift;
+ my $file = $self->_var('filename');
+ my $perm = $self->_var('permissions');
+ my $i_ok = 0;
+
+ my $open = "$perm $file";
+ $self->_debug("using open($open)");
+
+ my $FH = FileHandle->new("$perm $file") || '';
+ my @file = ();
+ # my $FH = tie(@file, 'Tie::File', $file) or '';
+ if (!$FH) {
+ $self->_error("Can't get handle($FH) for file($file) with permissions($perm)! $!");
+ } else {
+ # $FH = $self->_fh(\@file);
+ $FH = $self->_fh($FH);
+ if ($FH) {
+ $i_ok++;
+ $i_ok = $self->_lock(); # if $self->_writable;
+ }
+ $self->_debug("FH($FH) => i_ok($i_ok)");
+ }
+
+ return $i_ok;
};
# Lock the file
#
-# my $i_ok = $o_dat->_lock;
+# my $i_ok = $o_dat->_lock;
sub _lock {
- my $self = shift;
- my $FH = $self->_fh;
- my $i_ok = 0;
-
- if ($FH) {
- my $file = $self->_var('filename');
- if ($self->_writable) {
- # if ($FH->flock(LOCK_EX | LOCK_NB)) {
- if (flock($FH, LOCK_EX | LOCK_NB)) {
- $i_ok++;
- } else {
- $self->_error("Can't overlock file($file) handle($FH)!");
- }
- } else {
- # if ($FH->flock(LOCK_SH | LOCK_NB)) {
- if (flock($FH, LOCK_SH | LOCK_NB)) {
- $i_ok++;
- } else {
- $self->_error("Can't lock shared file($file) handle($FH)!");
- }
- }
- }
-
- return $i_ok;
+ my $self = shift;
+ my $FH = $self->_fh;
+ my $i_ok = 0;
+
+ if ($FH) {
+ my $file = $self->_var('filename');
+ if ($self->_writable) {
+ # if ($FH->flock(LOCK_EX | LOCK_NB)) {
+ if (flock($FH, LOCK_EX | LOCK_NB)) {
+ $i_ok++;
+ } else {
+ $self->_error("Can't overlock file($file) handle($FH)!");
+ }
+ } else {
+ # if ($FH->flock(LOCK_SH | LOCK_NB)) {
+ if (flock($FH, LOCK_SH | LOCK_NB)) {
+ $i_ok++;
+ } else {
+ $self->_error("Can't lock shared file($file) handle($FH)!");
+ }
+ }
+ }
+
+ return $i_ok;
};
# Unlock the file
#
-# my $i_ok = $o_dat->_unlock;
+# my $i_ok = $o_dat->_unlock;
sub _unlock {
- my $self = shift;
- my $FH = $self->_fh;
- my $i_ok = 0;
-
- if ($FH) {
- # if (flock($FH, LOCK_UN)) { apparently there's a race, perl does it better - see close :) }
- $i_ok++;
- } else {
- my $file = $self->_var('filename');
- $self->_error("Can't unlock file($file) handle($FH)!");
- }
-
- return $i_ok;
+ my $self = shift;
+ my $FH = $self->_fh;
+ my $i_ok = 0;
+
+ if ($FH) {
+ # if (flock($FH, LOCK_UN)) { apparently there's a race, perl does it better - see close :) }
+ $i_ok++;
+ } else {
+ my $file = $self->_var('filename');
+ $self->_error("Can't unlock file($file) handle($FH)!");
+ }
+
+ return $i_ok;
}
# Close the filehandle
#
-# my $i_ok = $o_dat->_close;
+# my $i_ok = $o_dat->_close;
sub _close {
- my $self = shift;
- my $FH = $self->_fh if $self->_var('filehandle');
- my $i_ok = 0;
-
- if ($FH) {
- # $FH->untie;
- if ($FH->close) { # perl unlocks it better than we can (race)
- $i_ok++;
- } else {
- $DB::single=2; #
- my $file = $self->_var('filename');
- $self->_error("Can't close file($file) handle($FH)!");
- }
- }
-
- return $i_ok;
+ my $self = shift;
+ my $FH = $self->_fh if $self->_var('filehandle');
+ my $i_ok = 0;
+
+ if ($FH) {
+ # $FH->untie;
+ if ($FH->close) { # perl unlocks it better than we can (race)
+ $i_ok++;
+ } else {
+ $DB::single=2; #
+ my $file = $self->_var('filename');
+ $self->_error("Can't close file($file) handle($FH)!");
+ }
+ }
+
+ return $i_ok;
}
sub _writable {
- my $self = shift;
+ my $self = shift;
- my $i_ok = $self->_var('writable');
+ my $i_ok = $self->_var('writable');
- if ($i_ok != 1) {
- my $file = $self->_var('filename');
- my $perms = $self->_var('permissions');
- $self->_debug("$file not writable($i_ok) with permissions($perms)");
- }
+ if ($i_ok != 1) {
+ my $file = $self->_var('filename');
+ my $perms = $self->_var('permissions');
+ $self->_debug("$file not writable($i_ok) with permissions($perms)");
+ }
- return $i_ok;
+ return $i_ok;
}
=item do
@@ -1337,34 +1350,34 @@ L<return()>
=cut
sub DO {
- my $self = shift;
- my $call = shift;
- my @res = ();
-
- $self->_enter('do');
- $self->_debug('in: '.Dumper([$call, @_])) if $File::Data::DEBUG;
-
- if ($call !~ /^($_METHODS)$/io) {
- $self->_error("unsupported method($call)");
- } else {
- $call = uc($call);
- $self->_var($call => []);
- my @res = $self->$call(@_);
- $self->_var($call => (ref($res[0]) ? $res[0] : \@res));
- }
-
- $self->_debug('out: $self') if $File::Data::DEBUG;
- $self->_leave('do');
-
- return @res;
+ my $self = shift;
+ my $call = shift;
+ my @res = ();
+
+ $self->_enter('do');
+ $self->_debug('in: '.Dumper([$call, @_])) if $File::Data::DEBUG;
+
+ if ($call !~ /^($_METHODS)$/io) {
+ $self->_error("unsupported method($call)");
+ } else {
+ $call = uc($call);
+ $self->_var($call => []);
+ my @res = $self->$call(@_);
+ $self->_var($call => (ref($res[0]) ? $res[0] : \@res));
+ }
+
+ $self->_debug('out: $self') if $File::Data::DEBUG;
+ $self->_leave('do');
+
+ return @res;
}
sub do {
- my $self = shift;
+ my $self = shift;
- $self->DO(@_);
+ $self->DO(@_);
- return $self;
+ return $self;
}
=back
@@ -1374,13 +1387,20 @@ sub do {
# ================================================================
sub DESTROY {
- my $self = shift;
- $self->_close;
+ my $self = shift;
+ $self->_close;
}
=head1 AUTHOR
-"Richard Foley" <File.Data at rfi.net>
+Richard Foley <File.Data at rfi.net>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2016 by Richard Foley
+
+This is free software; you can redistribute it and/or modify it under the same
+terms as the Perl 5 programming language system itself.
=cut
diff --git a/t/test.t b/t/test.t
index 1297602..aa2a421 100644
--- a/t/test.t
+++ b/t/test.t
@@ -1,16 +1,15 @@
use Data::Dumper;
use lib qw( lib );
use File::Data;
-use Test;
+use Test::More;
use strict;
-plan('tests' => 16);
-
my $i_test = 0;
my $i_errs = 0;
$File::Data::FATAL=0;
$File::Data::REFERENCE=0;
+$File::Data::DEBUG=0;
my $rj = './t/japh';
my $ro = './t/read';
@@ -25,22 +24,23 @@ $i_test++; # 1
$i_errs = 0;
foreach my $perm (qw(ro > <)) {
- my $o_ro = File::Data->new($ro, $perm); # read
+ my $o_ro = File::Data->new($ro, $perm); # read
unless (ref($o_ro)) {
$i_errs++;
- print "[$i_test] failed read-only file($ro, $perm) => o_ro($o_ro)\n";
+ print "[$i_test] failed read-only file($ro, $perm) => o_ro($o_ro)\n";
}
}
-($i_errs == 0) ? ok(1) : ok(0);
+ok( !$i_errs, 'read' );
foreach my $perm ('', qw(rw +< +>)) {
my $o_rw = File::Data->new($rw, $perm); # write
unless (ref($o_rw)) {
$i_errs++;
- print "[$i_test] failed read-write file($rw, $perm) => o_rw($o_rw)\n";
+ print "[$i_test] failed read-write file($rw, $perm) => o_rw($o_rw)\n";
}
}
-($i_errs == 0) ? ok(1) : ok(0);
+ok( !$i_errs, 'write' );
+
# =============================================================================
# $o_rx = undef; # how to close the file
@@ -56,17 +56,18 @@ $i_errs = 0;
'read' => File::Data->new($ro, 'ro'),
'write' => File::Data->new($rw),
);
- foreach my $key (sort keys %file) { # cannot read/write twice
+ foreach my $key (sort keys %file) { # cannot read/write twice
my $orig = $file{$key}->_var('filename');
my $o_new = File::Data->new($orig);
if ($o_new) {
$i_errs++;
- print "[$i_test] re-read($orig) => o_new($o_new)!\n";
+ print "[$i_test] re-read($orig) => o_new($o_new)!\n";
}
}
$File::Data::SILENT=0;
}
-($i_errs == 0) ? ok(1) : ok(0);
+ok( !$i_errs, 'locked' );
+
# =============================================================================
# PERM (issions) _check_access
@@ -78,14 +79,14 @@ $i_errs = 0;
{
$File::Data::SILENT=1;
foreach my $file ('', $rt, qw()) {
- my $o_rp = File::Data->new('', '<'); # invalid filename
+ my $o_rp = File::Data->new('', '<'); # invalid filename
if ($o_rp) {
- $i_errs++;
+ $i_errs++;
print "[$i_test] invalid file() => o_rp($o_rp)\n";
}
}
}
-($i_errs == 0) ? ok(1) : ok(0);
+ok( !$i_errs, 'invalid filename' );
# invalid permissions
{ # things that _might_ look like valid permissions to someone else
@@ -93,11 +94,11 @@ $i_errs = 0;
my $o_rp = File::Data->new($rp, $perms); # invalid perms
if ($o_rp) {
$i_errs++;
- print "[$i_test] invalid permissions($perms) accepted => o_rp($o_rp)\n";
+ print "[$i_test] invalid permissions($perms) accepted => o_rp($o_rp)\n";
}
}
}
-($i_errs == 0) ? ok(1) : ok(0);
+ok( !$i_errs, 'invalid permissions' );
# directory
{
@@ -105,35 +106,35 @@ $i_errs = 0;
my $o_rp = File::Data->new($dir); # dirs
if ($o_rp) {
$i_errs++;
- print "[$i_test] invalid directory(t) accepted => o_rp($o_rp)\n";
+ print "[$i_test] invalid directory(t) accepted => o_rp($o_rp)\n";
}
}
}
-($i_errs == 0) ? ok(1) : ok(0);
+ok( !$i_errs, 'directory checks' );
# permissions
{
# $File::Data::SILENT=1;
my $root = !$<; #
- foreach my $perm ('0000'..'0777') { #
+ foreach my $perm ('0000'..'0777') { #
next if $perm =~ /[89]/; # :-\
my $i_cnt = chmod oct($perm), $rp;
if ($i_cnt != 1) {
$i_errs++;
- print "[$i_test] failed($i_cnt) to chmod($perm, $rp)\n";
+ print "[$i_test] failed($i_cnt) to chmod($perm, $rp)\n";
} else {
my $o_rp = File::Data->new($rp); # perms
- unless ((!$o_rp && $perm <= '0577' ||
- $o_rp && $root) ||
+ unless ((!$o_rp && $perm <= '0577' ||
+ $o_rp && $root) ||
( $o_rp && $perm >= '0600')) {
$i_errs++;
- print "[$i_test] invalid file($rp) perm($perm) => o_rp($o_rp)\n";
+ print "[$i_test] invalid file($rp) perm($perm) => o_rp($o_rp)\n";
}
}
}
# $File::Data::SILENT=0;
}
-($i_errs == 0) ? ok(1) : ok(0);
+ok( !$i_errs, 'set permissions' );
# =============================================================================
# READ (only)
@@ -156,11 +157,10 @@ $i_errs = 0;
my $i_RO = my @READ = File::Data->new($ro, 'ro')->read('.+')->RETURN('read');
unless ($i_RO >= 3) {
$i_errs++;
- print "[$i_test] READ contains $i_RO lines\n".Dumper(\@READ);
+ print "[$i_test] READ contains $i_RO lines\n".Dumper(\@READ);
}
}
-
-($i_errs == 0) ? ok(1) : ok(0);
+ok( !$i_errs, 'read only' );
# =============================================================================
# WRITE
@@ -177,24 +177,22 @@ $i_errs = 0;
my $i_wr = my @writ = File::Data->new($rw)->WRITE(@write);
unless ($i_wr == 4) {
$i_errs++;
- print "[$i_test] write contains $i_wr lines(@writ)\n";
+ print "[$i_test] write contains $i_wr lines(@writ)\n";
}
my $i_WR = my @WRIT = File::Data->new($rx)->write('xyz')->write(@write)->RETURN('write');
unless ($i_WR == 4) {
$i_errs++;
- print "[$i_test] WRITE contains $i_WR lines(@WRIT)\n";
+ print "[$i_test] WRITE contains $i_WR lines(@WRIT)\n";
}
}
-
-($i_errs == 0) ? ok(1) : ok(0);
+ok( !$i_errs, 'write' );
# =============================================================================
# ACCESS (write to read-only)
# =============================================================================
$i_test++; # 6
$i_errs = 0;
-
{
$File::Data::SILENT=1;
my $o_ro = File::Data->new($ro, 'ro');
@@ -207,8 +205,7 @@ $i_errs = 0;
}
$File::Data::SILENT=0;
}
-
-($i_errs == 0) ? ok(1) : ok(0);
+ok( !$i_errs, 'write to read-only' );
# =============================================================================
# PREPEND
@@ -221,67 +218,62 @@ $i_errs = 0;
my $i_pre = my @pre = $o_rw->PREPEND($pre);
unless ($pre[0] eq $pre) {
$i_errs++;
- print "[$i_test] prepend(@pre)\n";
+ print "[$i_test] prepend(@pre)\n";
}
my $o_rx = File::Data->new($rx);
my $i_PRE = my @PRE = $o_rx->prepend($pre)->RETURN('prepend');
unless ($PRE[0] eq $pre) {
$i_errs++;
- print "[$i_test] prepend(@PRE)\n";
+ print "[$i_test] prepend(@PRE)\n";
}
}
-
-($i_errs == 0) ? ok(1) : ok(0);
+ok( !$i_errs, 'prepend' );
# =============================================================================
# INSERT
# =============================================================================
$i_test++; # 8
$i_errs = 0;
-
{
my $o_rw = File::Data->new($rw);
my $ins = "inserted some stuff at line 2\n";
- my $i_ins = my @ins = $o_rw->INSERT(2, $ins);
+ my $i_ins = my @ins = $o_rw->INSERT(2, $ins);
unless ($ins[0] eq $ins) {
$i_errs++;
print "[$i_test] insert(@ins)\n";
}
my $o_rx = File::Data->new($rx);
- my $i_INS = my @INS = $o_rx->insert(2, $ins)->RETURN('insert');
+ my $i_INS = my @INS = $o_rx->insert(2, $ins)->RETURN('insert');
unless ($INS[0] eq $ins) {
$i_errs++;
- print "[$i_test] INSERT(@INS)\n";
+ print "[$i_test] INSERT(@INS)\n";
}
}
-
-($i_errs == 0) ? ok(1) : ok(0);
+ok( !$i_errs, 'insert' );
# =============================================================================
# APPEND
# =============================================================================
$i_test++; # 9
$i_errs = 0;
-
{
my $o_rw = File::Data->new($rw);
my $app = "appended that stuff\n";
my $i_app = my @app = $o_rw->APPEND($app);
unless ($app[0] eq $app) {
$i_errs++;
- print "[$i_test] append(@app)\n";
- }
+ print "[$i_test] append(@app)\n";
+ }
my $o_rx = File::Data->new($rx);
my $i_APP = my @APP = $o_rx->append($app)->RETURN('append');
unless ($APP[0] eq $app) {
$i_errs++;
- print "[$i_test] APPEND(@APP)\n";
+ print "[$i_test] APPEND(@APP)\n";
}
}
-
-($i_errs == 0) ? ok(1) : ok(0);
+ok( !$i_errs, 'append' );
# =============================================================================
# SEARCH
@@ -293,9 +285,9 @@ $i_errs = 0;
my $o_rw = File::Data->new($rw);
my $str0 = 'ed\s*(\w+\s*\w{2})uff';
my $i_str0 = my @str0 = $o_rw->SEARCH($str0);
- unless ($str0[1] eq 'some st') {
+ unless ($str0[1] =~ /inserted some stuff/) {
$i_errs++;
- print "str0($str0): err($i_errs) ".Dumper(\@str0);
+ print "str0($str0): err($i_errs) ".Dumper(\@str0);
}
$File::Data::STRING = 1;
@@ -303,12 +295,11 @@ $i_errs = 0;
my $i_str1 = my @str1 = $o_rw->SEARCH($str1);
unless ($str1[0] == 2 && $str1[1] eq 'test') {
$i_errs++;
- print "str1($str1): err($i_errs) ".Dumper(\@str1);
+ print "str1($str1): err($i_errs) ".Dumper(\@str1);
}
}
# todo - SEARCH
-
-($i_errs == 0) ? ok(1) : ok(0);
+ok( !$i_errs, 'search' );
# =============================================================================
# REPLACE
@@ -330,15 +321,13 @@ $i_errs = 0;
my $i_sea1 = my @snr1 = $o_rw->REPLACE($sea1 => $rep1);
unless ($snr1[0] =~ /insertEd some stuff at line 2/s) {
$i_errs++;
- print "sea1($sea1) rep($rep1): i($i_sea1) err($i_errs) ".Dumper(\@snr1);
+ print "sea1($sea1) rep($rep1): i($i_sea1) err($i_errs) ".Dumper(\@snr1);
}
}
-# todo - REPLACE
-
-($i_errs == 0) ? ok(1) : ok(0);
+ok( !$i_errs, 'replace' );
# =============================================================================
-# Feedback
+# Feedback
# =============================================================================
$i_test++; # 12
$i_errs = 0;
@@ -346,9 +335,11 @@ $i_errs = 0;
my $o_rw = File::Data->new($rw);
print $o_rw->_vars if $File::Data::DEBUG;
}
-($i_errs == 0) ? ok(1) : ok(0);
+ok( !$i_errs, 'debug' );
# =============================================================================
+done_testing();
+
package File::Data::Test;
sub new { return bless({}, shift); }
@@ -419,9 +410,10 @@ $i_errs++ unless ref($o_rp);
print "[$i_test] perms file($rp) => o_rp($o_rp)\n" if $i_errs;
# my $i_stat = my @stat = File::Data->new($ro)->FSTAT('_');
-# $i_errs++ unless $i_stat >= 3; #
+# $i_errs++ unless $i_stat >= 3; #
# print "[$i_test] stat(@stat): ".Dumper(\@stat) if $i_errs;
($i_errs == 0) ? ok(1) : ok(0);
# =============================================================================
=cut
+
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libfile-data-perl.git
More information about the Pkg-perl-cvs-commits
mailing list