[libio-all-perl] 12/14: Basic structure set up
Axel Beckert
abe at deuxchevaux.org
Sun Apr 26 22:25:28 UTC 2015
This is an automated email from the git hooks/post-receive script.
abe pushed a commit to tag alt-io-all-new-0.00
in repository libio-all-perl.
commit be0cd7e70fd2a14c6f58092096ce8a21167892f5
Author: Ingy döt Net <ingy at ingy.net>
Date: Mon Jul 16 23:55:28 2012 -0700
Basic structure set up
all tests pass
---
lib/IO/All.pm | 120 ++++++++++++++++++++++++++++++++++++++------------
lib/IO/All/Dir.pm | 41 +++++++++++++++++
lib/IO/All/File.pm | 40 +++++++++--------
lib/IO/All/Filesys.pm | 22 +++++++++
lib/IO/All/Node.pm | 22 +++++++++
lib/IO/All/OO.pm | 37 +++++++++++++---
lib/IO/All/Plugin.pm | 11 -----
t/expectations.t | 2 +
t/usage.t | 7 ++-
t/use.t | 14 ++++--
10 files changed, 248 insertions(+), 68 deletions(-)
diff --git a/lib/IO/All.pm b/lib/IO/All.pm
index e337d2d..72cbd07 100644
--- a/lib/IO/All.pm
+++ b/lib/IO/All.pm
@@ -1,7 +1,7 @@
##
# name: IO::All
# author: Ingy döt Net
-# abstract: I Owe All of it to Graham and Damian!
+# abstract: I Owe All to Larry Wall!
# license: perl
# copyright: 2004, 2006, 2008, 2010, 2012
@@ -11,51 +11,115 @@ use strict;
our $VERSION = 0.44;
-use XXX;
-
-use constant registry => {};
-
-has plugins => (
- default => sub {
- [qw(
- IO::All::File
- IO::All::Dir
- )];
- }
+has location => ();
+has plugin_classes => (
+ default => sub { [qw(
+ IO::All::File
+ IO::All::Dir
+ )] }
);
+option 'strict';
+option 'overload';
+
+has methods => ( default => sub { +{} } );
my $arg_key_pattern = qr/^-(\w+)$/;
sub import {
my $class = shift;
+ my $caller = caller;
+ no strict 'refs';
+ *{"${caller}::io"} = $class->make_constructor(@_);
+}
+
+sub make_constructor {
+ my $class = shift;
+ my $scope_args = $class->parse_args(@_);
+ return sub {
+ $class->throw("'io' constructor takes zero or one arguments")
+ if @_ > 1;
+ my $location = @_ ? shift(@_) : undef;
+ $class->new([-location => $location], @$scope_args);
+ };
+}
+
+{
+ no warnings 'redefine';
+ sub new {
+ my $class = shift;
+ my $self = bless {}, $class;
+ for (@_) {
+ my $property = shift(@$_);
+ $property =~ s/^-//;
+ $self->$property(@$_);
+ }
+ for my $plugin_class (@{$self->plugin_classes}) {
+ eval "require $plugin_class; 1"
+ or $self->throw("Can't require $plugin_class: $@");
+ $self->register_methods($plugin_class);
+ $self->register_overloads($plugin_class);
+ if (ref($self) eq $class) {
+ if ($plugin_class->can_upgrade($self)) {
+ $self->rebless($plugin_class);
+ }
+ }
+ }
+ return $self;
+ }
+}
+
+# Parse
+# use IO::All -foo, -bar => 'x', 'y', -baz => 0;
+# Into
+# [ ['-foo'], ['-bar', 'x', 'y'], ['-baz, 0] ]
+sub parse_args {
+ my $class = shift;
my $args = [];
- my $insert;
while (@_) {
my $key = shift(@_);
- die "Unknown argument '$key' for $class usage"
+ die "Unknown argument '$key' for '$class' usage"
unless $key =~ $arg_key_pattern;
my $arg = [$1];
- while (@_ and $_[0] !~ $arg_key_pattern) {
- push @$arg, shift(@_);
- }
+ push @$arg, shift(@_)
+ while @_ and $_[0] !~ $arg_key_pattern;
push @$args, $arg;
}
- my $caller = caller;
- no strict 'refs';
- *{"${caller}::io"} = $class->make_constructor($args);
+ return $args;
}
-sub make_constructor {
- my ($class, $args) = @_;
- return sub {
- $class->new(%$args);
- };
+sub with {
+ my $self = shift;
+ $self->plugin_classes([
+ map { /::/ ? $_ : __PACKAGE__ . "::$_" } @_
+ ]);
+}
+
+sub register_methods {
+ my ($self, $plugin_class) = @_;
+ for my $method (@{$plugin_class->upgrade_methods}) {
+ $self->methods->{$method} = $plugin_class;
+ }
+}
+
+sub register_overloads {
+ my ($self, $plugin_class) = @_;
}
-sub new {
- my ($class, $object, $args) = @_;
+sub AUTOLOAD {
+ my $self = shift;
+ (my $method = $IO::All::AUTOLOAD) =~ s/.*:://;
+ my $plugin_class = $self->methods->{$method}
+ or $self->throw("Can't locate object method '$method'");
+ $self->rebless($plugin_class);
+ $self->$method(@_);
}
-sub BUILD {
+sub rebless {
+ my ($self, $plugin_class) = @_;
+ delete $self->{plugin_classes};
+ bless $self, $plugin_class;
+ $self->upgrade;
}
+sub DESTROY {}
+
1;
diff --git a/lib/IO/All/Dir.pm b/lib/IO/All/Dir.pm
new file mode 100644
index 0000000..983e066
--- /dev/null
+++ b/lib/IO/All/Dir.pm
@@ -0,0 +1,41 @@
+##
+# name: IO::All::Dir
+# author: Ingy döt Net
+# abstract: Directory Plugin For IO::All
+# license: perl
+# copyright: 2004, 2006, 2008, 2010, 2012
+
+package IO::All::Dir;
+use IO::All::OO;
+extends 'IO::All::Filesys';
+
+# Upgrade from IO::All to IO::All::Dir
+use constant upgrade_methods => [qw(dir mkdir)];
+
+sub can_upgrade {
+ my ($self, $object) = @_;
+ my $location = $object->location;
+ return if
+ not defined $location or
+ not length $location;
+ -d $location;
+}
+
+sub dir {
+ my $self = shift;
+ $self->name(shift) if @_;
+ return $self;
+}
+
+sub mkdir {
+ my ($self) = @_;
+ my $name = $self->name;
+ my $strict = $self->{_strict};
+ if (-d $name) {
+ return unless $strict;
+ $self->throw("Can't mkdir $name. Directory already exists.");
+ }
+ CORE::mkdir($name) or $self->throw("mkdir $name failed: $!");
+}
+
+1;
diff --git a/lib/IO/All/File.pm b/lib/IO/All/File.pm
index 2fe0288..57437c6 100644
--- a/lib/IO/All/File.pm
+++ b/lib/IO/All/File.pm
@@ -1,5 +1,5 @@
##
-# name: IO::All
+# name: IO::All::File
# author: Ingy döt Net
# abstract: File Plugin For IO::All
# license: perl
@@ -7,31 +7,35 @@
package IO::All::File;
use IO::All::OO;
-extends 'IO::All::Plugin';
+extends 'IO::All::Filesys';
-sub io_upgrade {
- my ($self) = @_;
- $self->file if
- defined $self->name and
- -e $self->name;
-}
+option 'utf8';
+
+# Upgrade from IO::All to IO::All::Dir
+use constant upgrade_methods => [qw(file print)];
-use constant io_methods => [qw(file print)];
+sub can_upgrade {
+ my ($self, $object) = @_;
+ my $location = $object->location;
+ return if
+ not defined $location or
+ not length $location;
+ -f $location;
+}
-use constant io_overloads => {
- 'file > file' => 'overload_file_to_file',
- 'file < file' => 'overload_file_from_file',
- '${} file' => 'overload_file_as_scalar',
- '@{} file' => 'overload_file_as_array',
- '%{} file' => 'overload_file_as_dbm',
-};
+#
+# Worker Methods:
+#
sub file {
my $self = shift;
- bless $self, __PACKAGE__;
$self->name(shift) if @_;
return $self;
- return $self->_init;
+}
+
+sub print {
+ my $self = shift;
+ CORE::print(@_);
}
1;
diff --git a/lib/IO/All/Filesys.pm b/lib/IO/All/Filesys.pm
new file mode 100644
index 0000000..119da43
--- /dev/null
+++ b/lib/IO/All/Filesys.pm
@@ -0,0 +1,22 @@
+##
+# name: IO::All::Filesys
+# author: Ingy döt Net
+# abstract: Filesys Base Class
+# license: perl
+# copyright: 2004, 2006, 2008, 2010, 2012
+
+package IO::All::Filesys;
+use IO::All::OO;
+extends 'IO::All::Node';
+
+has name => ();
+option overload => ();
+
+sub upgrade {
+ my $self = shift;
+ $self->{name} = delete $self->{location}
+ if $self->{location};
+ $self->SUPER::upgrade(@_);
+}
+
+1;
diff --git a/lib/IO/All/Node.pm b/lib/IO/All/Node.pm
new file mode 100644
index 0000000..ad818c7
--- /dev/null
+++ b/lib/IO/All/Node.pm
@@ -0,0 +1,22 @@
+##
+# name: IO::All::Node
+# author: Ingy döt Net
+# abstract: Base Class for Various IO::All Objects
+# license: perl
+# copyright: 2012
+
+package IO::All::Node;
+use IO::All::OO;
+
+has upgrade_methods => ( default => sub { [] } );
+
+sub upgrade {
+ my ($self) = @_;
+ for my $key (keys %$self) {
+ next if $key =~ /^_/;
+ delete $self->{$key}
+ unless $self->can($key);
+ }
+}
+
+1;
diff --git a/lib/IO/All/OO.pm b/lib/IO/All/OO.pm
index fb87831..882cdad 100644
--- a/lib/IO/All/OO.pm
+++ b/lib/IO/All/OO.pm
@@ -7,10 +7,10 @@
package IO::All::OO;
-# use Mo qw'default build import exporter';
+# use Mo qw'default build import exporter xxx';
# The following line of code was produced from the previous line by
# Mo::Inline version 0.31
-no warnings;my$M=__PACKAGE__.'::';*{$M.Object::new}=sub{bless{@_[1..$#_]},$_[0]};*{$M.import}=sub{import warnings;$^H|=1538;my($P,%e,%o)=caller.'::';shift;eval"no Mo::$_",&{$M.$_.::e}($P,\%e,\%o,\@_)for at _;return if$e{M};%e=(extends,sub{eval"no $_[0]()";@{$P.ISA}=$_[0]},has,sub{my$n=shift;my$m=sub{$#_?$_[0]{$n}=$_[1]:$_[0]{$n}};$m=$o{$_}->($m,$n, at _)for sort keys%o;*{$P.$n}=$m},%e,);*{$P.$_}=$e{$_}for keys%e;@{$P.ISA}=$M.Object};*{$M.'default::e'}=sub{my($P,$e,$o)=@_;$o->{default}=sub{my($ [...]
+no warnings;my$M=__PACKAGE__.'::';*{$M.Object::new}=sub{bless{@_[1..$#_]},$_[0]};*{$M.import}=sub{import warnings;$^H|=1538;my($P,%e,%o)=caller.'::';shift;eval"no Mo::$_",&{$M.$_.::e}($P,\%e,\%o,\@_)for at _;return if$e{M};%e=(extends,sub{eval"no $_[0]()";@{$P.ISA}=$_[0]},has,sub{my$n=shift;my$m=sub{$#_?$_[0]{$n}=$_[1]:$_[0]{$n}};$m=$o{$_}->($m,$n, at _)for sort keys%o;*{$P.$n}=$m},%e,);*{$P.$_}=$e{$_}for keys%e;@{$P.ISA}=$M.Object};*{$M.'default::e'}=sub{my($P,$e,$o)=@_;$o->{default}=sub{my($ [...]
our @EXPORT = qw(chain option);
@@ -23,7 +23,7 @@ sub option {
*{"${package}::$field"} =
sub {
my $self = shift;
- *$self->{"_$field"} = @_ ? shift(@_) : 1;
+ $self->{"_$field"} = @_ ? shift(@_) : 1;
return $self;
};
}
@@ -36,12 +36,37 @@ sub chain {
sub {
my $self = shift;
if (@_) {
- *$self->{$field} = shift;
+ $self->{$field} = shift;
return $self;
}
- return $default unless exists *$self->{$field};
- return *$self->{$field};
+ return $default unless exists $self->{$field};
+ return $self->{$field};
};
}
+sub field {
+ my $package = caller;
+ my ($field, $default) = @_;
+ no strict 'refs';
+ return if defined &{"${package}::$field"};
+ *{"${package}::$field"} =
+ sub {
+ my $self = shift;
+ unless (exists $self->{$field}) {
+ $self->{$field} =
+ ref($default) eq 'ARRAY' ? [] :
+ ref($default) eq 'HASH' ? {} :
+ $default;
+ }
+ return $self->{$field} unless @_;
+ $self->{$field} = shift;
+ };
+}
+
+sub throw {
+ my $self = shift;
+ require Carp;
+ Carp::croak(@_);
+}
+
1;
diff --git a/lib/IO/All/Plugin.pm b/lib/IO/All/Plugin.pm
deleted file mode 100644
index c044252..0000000
--- a/lib/IO/All/Plugin.pm
+++ /dev/null
@@ -1,11 +0,0 @@
-##
-# name: IO::All::Plugin
-# author: Ingy döt Net
-# abstract: Base Class for IO::All Plugins
-# license: perl
-# copyright: 2012
-
-package IO::All::Plugin;
-use IO::All::OO;
-
-1;
diff --git a/t/expectations.t b/t/expectations.t
index 4b980b0..70242c7 100644
--- a/t/expectations.t
+++ b/t/expectations.t
@@ -20,6 +20,8 @@ Plan = 4;
setup(*setup).eval_perl(*perl, *expect).Catch == *expect;
+setup('rm -f foo');
+
=== foo doesn't exist
--- setup: rm -f foo
--- perl: io('foo')->appends
diff --git a/t/usage.t b/t/usage.t
index 4d8ba32..65c3163 100644
--- a/t/usage.t
+++ b/t/usage.t
@@ -2,8 +2,13 @@ use TestML -run;
__END__
+%TestML 1.0
-*perl.eval.manifest == *with;
+Plan = 1;
+
+1 == 1;
+
+# *perl.eval.manifest == *with;
=== No plugin modules asked for
--- perl
diff --git a/t/use.t b/t/use.t
index b5a3997..120631b 100644
--- a/t/use.t
+++ b/t/use.t
@@ -1,7 +1,13 @@
-use Test::More tests => 1;
+use Test::More tests => 3;
-use IO::All -with => qw(Foo Bar), -strict, -overload => 0;
+use IO::All -with => qw(Dir File), -strict, -overload => 0;
-use XXX;
+system("touch foo");
-XXX io('foo', 0);
+my $io = io('foo');
+
+is $io->{name}, 'foo';
+is $io->{_strict}, 1;
+is $io->{_overload}, 0;
+
+system("rm -f foo");
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libio-all-perl.git
More information about the Pkg-perl-cvs-commits
mailing list