Commit 7ba2a744 authored by Ryan Niebur's avatar Ryan Niebur

[svn-inject] Installing original source of libio-tiecombine-perl

parents
Revision history for IO-TieCombine
1.000 2008-10-16
first release
This diff is collapsed.
Changes
LICENSE
MANIFEST
META.yml
Makefile.PL
README
lib/IO/TieCombine.pm
lib/IO/TieCombine/Handle.pm
lib/IO/TieCombine/Scalar.pm
t/basic.t
\ No newline at end of file
---
abstract: produce tied (and other) separate but combined variables
author:
- Ricardo SIGNES <rjbs@cpan.org>
generated_by: Dist::Zilla::Plugin::MetaYaml version 1.002
license: perl
name: IO-TieCombine
requires: {}
version: 1.000
use strict;
use warnings;
use ExtUtils::MakeMaker;
WriteMakefile(
DISTNAME => 'IO-TieCombine',
NAME => 'IO::TieCombine',
AUTHOR => 'Ricardo\ SIGNES\ \<rjbs\@cpan\.org\>',
ABSTRACT => 'produce tied (and other) separate but combined variables',
VERSION => '1.000',
EXE_FILES => [ qw() ],
(eval { ExtUtils::MakeMaker->VERSION(6.21) } ? (LICENSE => 'perl') : ()),
PREREQ_PM => {
},
);
This archive contains the distribution IO-TieCombine, version
1.000:
produce tied (and other) separate but combined variables
This software is copyright (c) 2008 by Ricardo SIGNES.
This is free software; you can redistribute it and/or modify it under
the same terms as perl itself.
use strict;
use warnings;
package IO::TieCombine;
our $VERSION = '1.000';
# ABSTRACT: produce tied (and other) separate but combined variables
use Carp ();
use IO::TieCombine::Handle;
use IO::TieCombine::Scalar;
use Symbol ();
sub new {
my ($class) = @_;
my $self = {
combined => \(my $str = ''),
slots => { },
};
bless $self => $class;
}
sub combined_contents {
my ($self) = @_;
return ${ $self->{combined} };
}
sub slot_contents {
my ($self, $name) = @_;
Carp::confess("no name provided for slot_contents") unless defined $name;
Carp::confess("no such output slot exists")
unless exists $self->{slots}{$name};
return ${ $self->{slots}{$name} };
}
sub _slot_ref {
my ($self, $name) = @_;
Carp::confess("no slot name provided") unless defined $name;
$self->{slots}{$name} = \(my $str = '') unless $self->{slots}{$name};
return $self->{slots}{$name};
}
sub _tie_args {
my ($self, $name) = @_;
return {
slot_name => $name,
combined_ref => $self->{combined},
output_ref => $self->_slot_ref($name),
};
}
sub fh {
my ($self, $name) = @_;
my $sym = Symbol::gensym;
my ($class, @rest) = $self->_tie_fh_args($name);
tie *$sym, $class, @rest;
return $sym;
}
sub TIEHANDLE {
my ($self, @args) = @_;
my ($class, @rest) = $self->_tie_fh_args(@args);
return $class->TIEHANDLE(@rest);
}
sub _tie_fh_args {
my ($self, $name) = @_;
return ('IO::TieCombine::Handle', $self->_tie_args($name));
}
sub scalar_ref {
my ($self, $name) = @_;
my ($class, @rest) = $self->_tie_scalar_args($name);
tie my($tie), $class, @rest;
return \$tie;
}
sub TIESCALAR {
my ($self, @args) = @_;
my ($class, @rest) = $self->_tie_scalar_args(@args);
return $class->TIESCALAR(@rest);
}
sub _tie_scalar_args {
my ($self, $name) = @_;
return ('IO::TieCombine::Scalar', $self->_tie_args($name));
}
sub callback {
my ($self, $name) = @_;
my $slot = $self->_slot_ref($name);
return sub {
my ($value) = @_;
${ $slot } .= $value;
${ $self->{combined} } .= $value;
}
}
1;
__END__
=pod
=head1 NAME
IO::TieCombine - produce tied (and other) separate but combined variables
=head1 VERSION
version 1.000
=head1 SYNOPSIS
First, we set up a bunch of access points:
my $hub = IO::TieCombine->new;
my $str_ref = $hub->scalar_ref('x');
my $fh = $hub->fh('x');
my $callback = $hub->callback('x');
tie my $scalar, $hub, 'x';
tie local *STDOUT, $hub, 'x';
tie local *STDERR, $hub, 'err';
Then we write to things:
$$str_ref .= 'And ';
print $fh "now ";
$callback->('for ');
$scalar .= 'something ';
print "completely ";
warn "different.\n";
And then:
$hub->combined_contents; # And now for something completely different.
$hub->slot_contents('x'); # And now for something completely
$hub->slot_contents('err'); # different.
=head1 METHODS
=head2 new
The constructor takes no arguments.
=head2 combined_contents
This method returns the contents of all collected data.
=head2 slot_contents
my $str = $hub->slot_contents( $slot_name );
This method returns the contents of all collected data for the named slot.
=head2 fh
my $fh = $hub->fh( $slot_name );
This method returns a reference to a tied filehandle. When printed to, output
is collected in the named slot.
=head2 scalar_ref
my $str_ref = $hub->scalar_ref( $slot_name );
This method returns a reference to scalar. When appended to, the new content
is collected in the named slot. Attempting to alter the string other than by
adding new content to its end will result in an exception.
=head2 callback
my $code = $hub->callback( $slot_name );
=head1 AUTHOR
Ricardo SIGNES <rjbs@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Ricardo SIGNES.
This is free software; you can redistribute it and/or modify it under
the same terms as perl itself.
=cut
use strict;
use warnings;
package IO::TieCombine::Handle;
our $VERSION = '1.000';
# ABSTRACT: tied filehandles for IO::TieCombine
use Carp ();
sub TIEHANDLE {
my ($class, $arg) = @_;
my $self = {
slot_name => $arg->{slot_name},
combined_ref => $arg->{combined_ref},
output_ref => $arg->{output_ref},
};
return bless $self => $class;
}
sub PRINT {
my ($self, @output) = @_;
my $joined = join((defined $, ? $, : ''), @output);
${ $self->{output_ref} } .= $joined;
${ $self->{combined_ref} } .= $joined;
return 1;
}
sub PRINTF {
my $self = shift;
my $fmt = shift;
$self->PRINT(sprintf($fmt, @_));
}
sub OPEN { return $_[0] }
sub BINMODE { return 1; }
sub FILENO { return 0 + $_[0] }
1;
__END__
=pod
=head1 NAME
IO::TieCombine::Handle - tied filehandles for IO::TieCombine
=head1 VERSION
version 1.000
=head1 AUTHOR
Ricardo SIGNES <rjbs@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Ricardo SIGNES.
This is free software; you can redistribute it and/or modify it under
the same terms as perl itself.
=cut
use strict;
use warnings;
package IO::TieCombine::Scalar;
our $VERSION = '1.000';
# ABSTRACT: tied scalars for IO::TieCombine
use Carp ();
sub TIESCALAR {
my ($class, $arg) = @_;
my $self = {
slot_name => $arg->{slot_name},
combined_ref => $arg->{combined_ref},
output_ref => $arg->{output_ref},
};
bless $self => $class;
}
sub FETCH {
return ${ $_[0]->{output_ref} }
}
sub STORE {
my ($self, $value) = @_;
my $class = ref $self;
my $output_ref = $self->{output_ref};
Carp::croak "you may only append, not reassign, a $class tie"
unless index($value, $$output_ref) == 0;
my $extra = substr $value, length $$output_ref, length $value;
${ $self->{combined_ref} } .= $extra;
return ${ $self->{output_ref} } = $value;
}
1;
__END__
=pod
=head1 NAME
IO::TieCombine::Scalar - tied scalars for IO::TieCombine
=head1 VERSION
version 1.000
=head1 AUTHOR
Ricardo SIGNES <rjbs@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Ricardo SIGNES.
This is free software; you can redistribute it and/or modify it under
the same terms as perl itself.
=cut
#!perl
use strict;
use warnings;
use IO::TieCombine;
use Test::More tests => 5;
my $hub = IO::TieCombine->new;
my $scalar_A = $hub->scalar_ref('Alpha');
my $fh_A = $hub->fh('Alpha');
my $scalar_B = $hub->scalar_ref('Beta');
my $fh_B = $hub->fh('Beta');
sub append_bar {
$_[0] .= 'bar';
}
tie my $scalar_C, $hub, 'Charlie';
$$scalar_A .= 'foo';
print $fh_B "beta1";
$$scalar_B .= 'embargo';
append_bar($$scalar_A);
eval { $$scalar_B = 'DIE!'; };
like($@, qr{append, not reassign}, "you can't assign to a slot fh");
print $fh_A "hot pants";
$$scalar_B .= 'ooga';
print $fh_B "beta2";
$scalar_C .= 'fin';
is($hub->slot_contents('Alpha'), 'foobarhot pants', 'Alpha slot');
is($hub->slot_contents('Beta'), 'beta1embargooogabeta2', 'Beta slot');
is($hub->slot_contents('Charlie'), 'fin', 'Charlie slot');
is(
$hub->combined_contents,
'foobeta1embargobarhot pantsoogabeta2fin',
'combined',
);
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment