String-BufferStack-1.16/0000755000175000017500000000000011651774007014124 5ustar chmrrchmrrString-BufferStack-1.16/lib/0000755000175000017500000000000011651774007014672 5ustar chmrrchmrrString-BufferStack-1.16/lib/String/0000755000175000017500000000000011651774007016140 5ustar chmrrchmrrString-BufferStack-1.16/lib/String/BufferStack.pm0000644000175000017500000003072111651773563020706 0ustar chmrrchmrrpackage String::BufferStack; use strict; use warnings; use Carp; our $VERSION; $VERSION = "1.16"; =head1 NAME String::BufferStack - Nested buffers for templating systems =head1 SYNOPSIS my $stack = String::BufferStack->new; $stack->push( filter => sub {return uc shift} ); $stack->append("content"); $stack->flush_output; =head1 DESCRIPTION C provides a framework for storing nested buffers. By default, all of the buffers flow directly to the output method, but individual levels of the stack can apply filters, or store their output in a scalar reference. =head1 METHODS =head2 new PARAMHASH Creates a new buffer stack and returns it. Possible arguments include: =over =item prealoc Preallocate this many bytes in the output buffer. This can reduce reallocations, and thus speed up appends. =item out_method The method to call when output trickles down to the bottom-most buffer and is flushed via L. The default C prints the content to C. This method will always be called with non-undef, non-zero length content. =item use_length Calculate length of each buffer as it is built. This imposes a significant runtime cost, so should be avoided if at all possible. Defaults to off. =back =cut sub new { my $class = shift; my %args = @_; my $output = " "x($args{prealloc} || 0); $output = ''; return bless { stack => [], top => undef, output => \$output, out_method => $args{out_method} || sub { print STDOUT @_ }, pre_appends => {}, use_length => $args{use_length}, }, $class; } =head2 push PARAMHASH Pushes a new frame onto the buffer stack. By default, the output from this new frame connects to the input of the previous frame. There are a number of possible options: =over =item buffer A string reference, into which the output from this stack frame will appear. By default, this is the input buffer of the previous frame. =item private If a true value is passed for C, it creates a private string reference, and uses that as the buffer -- this is purely for convenience. That is, the following blocks are equivilent: my $buffer = ""; $stack->push( buffer => \$buffer ); # ... $stack->pop; print $buffer; $stack->push( private => 1 ); # ... print $stack->pop; =item pre_append A callback, which will be called with a reference to the C object, and the arguments to append, whenever this stack frame has anything appended to the input buffer, directly or indirectly. Within the context of the pre-append callback, L, L, and L function on the frame the pre-append is attached to, not the topmost trame. Using L within the pre-append callback is not suggested; use L instead. L can be used to alter or remove the pre-append callback itself -- this is not uncommon, in the case where the first append is the only one which needs be watched for, for instance. =item filter A callback, used to process data which is appended to the stack frame. By default, filters are lazy, being called only when a frame is popped. They can be forced at any time by calling L, however. =back =cut sub push { my $self = shift; my $frame = { buffer => $self->{top} ? $self->{top}{pre_filter} : $self->{output}, @_ }; my $filter = ""; my $buffer = ""; $frame->{buffer} = \$buffer if delete $frame->{private}; $frame->{length} = (defined ${$frame->{buffer}}) ? CORE::length(${$frame->{buffer}}) : 0 if $self->{use_length} or $frame->{use_length}; $frame->{pre_filter} = $frame->{filter} ? \$filter : $frame->{buffer}; $self->{top} = $frame; local $self->{local_frame} = $frame; $self->set_pre_append(delete $frame->{pre_append}) if defined $frame->{pre_append}; CORE::push(@{$self->{stack}}, $frame); } =head2 depth Returns the current depth of the stack. This starts at 0, when no frames have been pushed, and increases by one for each frame pushed. =cut sub depth { my $self = shift; return scalar @{$self->{stack}}; } =head2 append STRING [, STRING, ...] Appends the given strings to the input side of the topmost buffer. This will call all pre-append hooks attached to it, as well. Note that if the frame has a filter, the filter will not immediately run, but will be delayed until the frame is L'd, or L is called. When called with no frames on the stack, appends the stringins directly to the L. =cut sub append { my $self = shift; my $frame = $self->{local_frame} || $self->{top}; if ($frame) { my $ref = $frame->{pre_filter}; if (exists $self->{pre_appends}{$frame->{buffer}} and not $frame->{filter}) { # This is an append to the output buffer, signal all pre_append hooks for it for my $frame (@{$self->{pre_appends}{$frame->{buffer}}}) { die unless $frame->{pre_append}; local $self->{local_frame} = $frame; $frame->{pre_append}->($self, @_); } } for (@_) { $$ref .= $_ if defined; } } else { my $ref = $self->{output}; for (@_) { $$ref .= $_ if defined; } } } =head2 direct_append STRING [, STRING, ...] Similar to L, but appends the strings to the output side of the frame, skipping pre-append callbacks and filters. When called with no frames on the stack, appends the strings directly to the L. =cut sub direct_append { my $self = shift; my $frame = $self->{local_frame} || $self->{top}; my $ref = $frame ? $frame->{buffer} : $self->{output}; for (@_) { $$ref .= $_ if defined; } } =head2 pop Removes the topmost frame on the stack, flushing the topmost filters in the process. Returns the output buffer of the frame -- note that this may not contain only strings appended in the current frame, but also those from before, as a speed optimization. That is: $stack->append("one"); $stack->push; $stack->append(" two"); $stack->pop; # returns "one two" This operation is a no-op if there are no frames on the stack. =cut sub pop { my $self = shift; return unless $self->{top}; $self->filter; my $frame = CORE::pop(@{$self->{stack}}); local $self->{local_frame} = $frame; $self->set_pre_append(undef); $self->{top} = @{$self->{stack}} ? $self->{stack}[-1] : undef; return ${$frame->{buffer}}; } =head2 set_pre_append CALLBACK Alters the pre-append callback on the topmost frame. The callback will be called before text is appended to the input buffer of the frame, and will be passed the C and the arguments to L. =cut sub set_pre_append { my $self = shift; my $hook = shift; my $frame = $self->{local_frame} || $self->{top}; return unless $frame; if ($hook and not $frame->{pre_append}) { CORE::push(@{$self->{pre_appends}{$frame->{buffer}}}, $frame); } elsif (not $hook and $frame->{pre_append}) { $self->{pre_appends}{ $frame->{buffer} } = [ grep { $_ ne $frame } @{ $self->{pre_appends}{ $frame->{buffer} } } ]; delete $self->{pre_appends}{ $frame->{buffer} } unless @{ $self->{pre_appends}{ $frame->{buffer} } }; } $frame->{pre_append} = $hook; } =head2 set_filter FILTER Alters the filter on the topmost frame. Doing this flushes the filters on the topmost frame. =cut sub set_filter { my $self = shift; my $filter = shift; return unless $self->{top}; $self->filter; if (defined $self->{top}{filter} and not defined $filter) { # Removing a filter, flush, then in = out $self->{top}{pre_filter} = $self->{top}{buffer}; } elsif (not defined $self->{top}{filter} and defined $filter) { # Adding a filter, add a pre_filter stage my $pre_filter = ""; $self->{top}{pre_filter} = \$pre_filter; } $self->{top}{filter} = $filter; } =head2 filter Filters the topmost stack frame, if it has outstanding unfiltered data. This will propagate content to lower frames, possibly calling their pre-append hooks. =cut sub filter { my $self = shift; my $frame = shift || $self->{top}; return unless $frame and $frame->{filter} and CORE::length(${$frame->{pre_filter}}); # We remove the input before we shell out to the filter, so we # don't get into infinite loops. my $input = ${$frame->{pre_filter}}; ${$frame->{pre_filter}} = ''; my $output = $frame->{filter}->($input); if (exists $self->{pre_appends}{$frame->{buffer}}) { for my $frame (@{$self->{pre_appends}{$frame->{buffer}}}) { local $self->{local_frame} = $frame; $frame->{pre_append}->($self, $output); } } ${$frame->{buffer}} .= $output; } =head2 flush If there are no frames on the stack, calls L. Otherwise, calls L. =cut sub flush { my $self = shift; # Flushing with no stack flushes the output return $self->flush_output unless $self->depth; # Otherwise it just flushes the filters $self->flush_filters; } =head2 flush_filters Flushes all filters. This does not flush output from the output buffer; see L. =cut sub flush_filters { my $self = shift; # Push content through filters -- reverse so the top one is first for my $frame (reverse @{$self->{stack}}) { $self->filter($frame); } } =head2 buffer Returns the contents of the output buffer of the topmost frame; if there are no frames, returns the output buffer. =cut sub buffer { my $self = shift; return $self->{top} ? ${$self->{top}{buffer}} : ${$self->{output}}; } =head2 buffer_ref Returns a reference to the output buffer of the topmost frame; if there are no frames, returns a reference to the output buffer. Note that adjusting this skips pre-append and filter hooks. =cut sub buffer_ref { my $self = shift; return $self->{top} ? $self->{top}{buffer} : $self->{output}; } =head2 length If C was enabled in the buffer stack's constructor, returns the number of characters appended to the current frame; if there are no frames, returns the length of the output buffer. If C was not enabled, warns and returns 0. =cut sub length { my $self = shift; carp("String::BufferStack object didn't enable use_length") and return 0 unless $self->{use_length} or ($self->{top} and $self->{top}{use_length}); return $self->{top} ? CORE::length(${$self->{top}{buffer}}) - $self->{top}{length} : CORE::length(${$self->{output}}); } =head2 flush_output Flushes all filters using L, then flushes output from the output buffer, using the configured L. =cut sub flush_output { my $self = shift; $self->flush_filters; # Look at what we have at the end return unless CORE::length(${$self->{output}}); $self->{out_method}->(${$self->{output}}); ${$self->{output}} = ""; return ""; } =head2 output_buffer Returns the pending output buffer, which sits below all existing frames. =cut sub output_buffer { my $self = shift; return ${$self->{output}}; } =head2 output_buffer_ref Returns a reference to the pending output buffer, allowing you to modify it. =cut sub output_buffer_ref { my $self = shift; return $self->{output}; } =head2 clear Clears I buffers in the stack, including the output buffer. =cut sub clear { my $self = shift; ${$self->{output}} = ""; ${$_->{pre_filter}} = ${$_->{buffer}} = "" for @{$self->{stack}}; return ""; } =head2 clear_top Clears the topmost buffer in the stack; if there are no frames on the stack, clears the output buffer. =cut sub clear_top { my $self = shift; if ($self->{top}) { ${$self->{top}{pre_filter}} = ${$self->{top}{buffer}} = ""; } else { ${$self->{output}} = ""; } return ""; } =head2 out_method [CALLBACK] Gets or sets the output method callback, which is given content from the pending output buffer, which sits below all frames. =cut sub out_method { my $self = shift; $self->{out_method} = shift if @_; return $self->{out_method}; } =head1 SEE ALSO Many concepts were originally taken from L's internal buffer stack. =head1 AUTHORS Alex Vandiver C<< alexmv@bestpractical.com >> =head1 LICENSE Copyright 2008-2009, Best Practical Solutions. This package is distributed under the same terms as Perl itself. =cut 1; String-BufferStack-1.16/Changes0000644000175000017500000000157711651773670015436 0ustar chmrrchmrrRevision history for String-BufferStack 1.16 Wed Oct 26 08:05:17 2011 * No code changes; fix license in META.yml 1.15 Wed Jan 6 18:26:17 2009 * Don't calculate buffer length as it is built, unless we ask for it; it has serious runtime cost 1.14 Mon Mar 2 20:21:17 2009 * No code changes; make tests pass on 5.6 1.13 Fri Feb 27 19:19:17 2009 * No code changes; add LICENSE and AUTHOR to POD 1.12 Wed Feb 4 14:41:17 2009 * Add buffer_ref * Documentation adjustments 1.10 Thu Jan 15 23:37:17 2009 * Remove support for data stack 1.03 Sun Nov 23 01:00:30 2008 * Require 5.8.0 or higher (for three-arg open and local *STDOUT in tests) 1.02 Sun Nov 23 01:00:30 2008 * Releng fixes 1.01 Sun Nov 23 00:51:30 2008 * Test fixes 1.00 Thu Nov 6 22:28:19 2008 * First release String-BufferStack-1.16/README0000644000175000017500000001452111225672642015006 0ustar chmrrchmrrNAME String::BufferStack - Nested buffers for templating systems SYNOPSIS my $stack = String::BufferStack->new; $stack->push( filter => sub {return uc shift} ); $stack->append("content"); $stack->flush_output; DESCRIPTION "String::BufferStack" provides a framework for storing nested buffers. By default, all of the buffers flow directly to the output method, but individual levels of the stack can apply filters, or store their output in a scalar reference. METHODS new PARAMHASH Creates a new buffer stack and returns it. Possible arguments include: prealoc Preallocate this many bytes in the output buffer. This can reduce reallocations, and thus speed up appends. out_method The method to call when output trickles down to the bottom-most buffer and is flushed via flush_output. The default "out_method" prints the content to "STDOUT". This method will always be called with non-undef, non-zero length content. push PARAMHASH Pushes a new frame onto the buffer stack. By default, the output from this new frame connects to the input of the previous frame. There are a number of possible options: buffer A string reference, into which the output from this stack frame will appear. By default, this is the input buffer of the previous frame. private If a true value is passed for "private", it creates a private string reference, and uses that as the buffer -- this is purely for convenience. That is, the following blocks are equivilent: my $buffer = ""; $stack->push( buffer => \$buffer ); # ... $stack->pop; print $buffer; $stack->push( private => 1 ); # ... print $stack->pop; pre_append A callback, which will be called with a reference to the "String::BufferStack" object, and the arguments to append, whenever this stack frame has anything appended to the input buffer, directly or indirectly. Within the context of the pre-append callback, "append", "direct_append", and "set_pre_append" function on the frame the pre-append is attached to, not the topmost trame. Using "append" within the pre-append callback is not suggested; use "direct_append" instead. "set_pre_append" can be used to alter or remove the pre-append callback itself -- this is not uncommon, in the case where the first append is the only one which needs be watched for, for instance. filter A callback, used to process data which is appended to the stack frame. By default, filters are lazy, being called only when a frame is popped. They can be forced at any time by calling "flush_filters", however. depth Returns the current depth of the stack. This starts at 0, when no frames have been pushed, and increases by one for each frame pushed. append STRING [, STRING, ...] Appends the given strings to the input side of the topmost buffer. This will call all pre-append hooks attached to it, as well. Note that if the frame has a filter, the filter will not immediately run, but will be delayed until the frame is "pop"'d, or "flush_filters" is called. When called with no frames on the stack, appends the stringins directly to the "output_buffer". direct_append STRING [, STRING, ...] Similar to "append", but appends the strings to the output side of the frame, skipping pre-append callbacks and filters. When called with no frames on the stack, appends the strings directly to the "output_buffer". pop Removes the topmost frame on the stack, flushing the topmost filters in the process. Returns the output buffer of the frame -- note that this may not contain only strings appended in the current frame, but also those from before, as a speed optimization. That is: $stack->append("one"); $stack->push; $stack->append(" two"); $stack->pop; # returns "one two" This operation is a no-op if there are no frames on the stack. set_pre_append CALLBACK Alters the pre-append callback on the topmost frame. The callback will be called before text is appended to the input buffer of the frame, and will be passed the "String::BufferStack" and the arguments to "append". set_filter FILTER Alters the filter on the topmost frame. Doing this flushes the filters on the topmost frame. filter Filters the topmost stack frame, if it has outstanding unfiltered data. This will propagate content to lower frames, possibly calling their pre-append hooks. flush If there are no frames on the stack, calls "flush_output". Otherwise, calls "flush_filters". flush_filters Flushes all filters. This does not flush output from the output buffer; see "flush_output". buffer Returns the contents of the output buffer of the topmost frame; if there are no frames, returns the output buffer. buffer_ref Returns a reference to the output buffer of the topmost frame; if there are no frames, returns a reference to the output buffer. Note that adjusting this skips pre-append and filter hooks. length Returns the number of characters appended to the current frame; if there are no frames, returns the length of the output buffer. flush_output Flushes all filters using "flush_filters", then flushes output from the output buffer, using the configured "out_method". output_buffer Returns the pending output buffer, which sits below all existing frames. output_buffer_ref Returns a reference to the pending output buffer, allowing you to modify it. clear Clears *all* buffers in the stack, including the output buffer. clear_top Clears the topmost buffer in the stack; if there are no frames on the stack, clears the output buffer. out_method [CALLBACK] Gets or sets the output method callback, which is given content from the pending output buffer, which sits below all frames. SEE ALSO Many concepts were originally taken from HTML::Mason's internal buffer stack. AUTHORS Alex Vandiver "alexmv@bestpractical.com" LICENSE Copyright 2008-2009, Best Practical Solutions. This package is distributed under the same terms as Perl itself. String-BufferStack-1.16/inc/0000755000175000017500000000000011651774007014675 5ustar chmrrchmrrString-BufferStack-1.16/inc/Module/0000755000175000017500000000000011651774007016122 5ustar chmrrchmrrString-BufferStack-1.16/inc/Module/Install.pm0000644000175000017500000003013511651773771020077 0ustar chmrrchmrr#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.01'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[0]) <=> _version($_[1]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2011 Adam Kennedy. String-BufferStack-1.16/inc/Module/Install/0000755000175000017500000000000011651774007017530 5ustar chmrrchmrrString-BufferStack-1.16/inc/Module/Install/Fetch.pm0000644000175000017500000000462711651773771021137 0ustar chmrrchmrr#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; String-BufferStack-1.16/inc/Module/Install/Base.pm0000644000175000017500000000214711651773771020753 0ustar chmrrchmrr#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.01'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 String-BufferStack-1.16/inc/Module/Install/Can.pm0000644000175000017500000000333311651773771020600 0ustar chmrrchmrr#line 1 package Module::Install::Can; use strict; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 156 String-BufferStack-1.16/inc/Module/Install/Makefile.pm0000644000175000017500000002703211651773771021616 0ustar chmrrchmrr#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/; $self->build_requires( 'ExtUtils::MakeMaker' => $v ); $self->configure_requires( 'ExtUtils::MakeMaker' => $v ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT $DB::single = 1; if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 541 String-BufferStack-1.16/inc/Module/Install/WriteAll.pm0000644000175000017500000000237611651773771021630 0ustar chmrrchmrr#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; String-BufferStack-1.16/inc/Module/Install/Metadata.pm0000644000175000017500000004312311651773771021620 0ustar chmrrchmrr#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config\n"; return $self; } $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; return 1; } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the reall old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; String-BufferStack-1.16/inc/Module/Install/Win32.pm0000644000175000017500000000340311651773771020777 0ustar chmrrchmrr#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; String-BufferStack-1.16/t/0000755000175000017500000000000011651774007014367 5ustar chmrrchmrrString-BufferStack-1.16/t/01-basic.t0000644000175000017500000000566711225672642016070 0ustar chmrrchmrruse warnings; use strict; use Test::More tests => 35; use vars qw/$BUFFER/; $BUFFER = ""; use_ok 'String::BufferStack'; # Test printing to STDOUT my $stack = String::BufferStack->new; ok($stack, "Made an object"); isa_ok($stack, 'String::BufferStack'); SKIP: { skip "Perl 5.6 doesn't support three arg open to a string", 2 unless $] >= 5.008; open my $output, '>>', \$BUFFER; local *STDOUT = $output; $stack->append("Content"); is($BUFFER, "", "No output after append"); $stack->flush; is($BUFFER, "Content", "Saw content on STDOUT"); } # Tests with no buffer stack $stack = String::BufferStack->new( out_method => sub { $BUFFER .= join("", @_) }); $BUFFER = ""; $stack->append("Some string"); is($stack->buffer, "Some string", "No stack, append goes through to output"); is($stack->output_buffer, "Some string", "Same as output buffer"); is($BUFFER, "", "Without flush, doesn't output"); # Another append does exactly that $stack->append(", and more"); is($stack->buffer, "Some string, and more", "No stack, append goes through to output"); is($stack->output_buffer, "Some string, and more", "Same as output buffer"); is($BUFFER, "", "Without flush, doesn't output"); # Can inspect and modify the output buffer isa_ok($stack->output_buffer_ref, "SCALAR", "Output ref is a ref to a scalar"); is(${$stack->output_buffer_ref}, "Some string, and more", "Dereferencing shows content"); ${$stack->output_buffer_ref} = "Moose"; is(${$stack->output_buffer_ref}, "Moose", "Altering it changes output ref, deref'd"); is($stack->output_buffer, "Moose", "Altering it changes output itself"); is($stack->buffer, "Moose", "Also top buffer"); # Flush the output $stack->flush; is($stack->buffer, "", "Flush clears output"); is($stack->output_buffer, "", "Also output buffer"); is($BUFFER, "Moose", "Flush moved to output"); # Ensure no saved state $BUFFER = ""; $stack->append("More"); is($stack->buffer, "More", "Append after flush goes through"); is($stack->output_buffer, "More", "Same as output buffer"); is($BUFFER, "", "Without flush, doesn't output"); $stack->flush; is($stack->buffer, "", "Flush clears output"); is($stack->output_buffer, "", "Also output buffer"); is($BUFFER, "More", "Flush moved to output"); # Clear $BUFFER = ""; $stack->append("Never seen"); is($stack->buffer, "Never seen", "See the append"); is($stack->output_buffer, "Never seen", "Same as output buffer"); $stack->clear; is($stack->buffer, "", "Clear empties the buffers"); is($stack->output_buffer, "", "output buffer as well"); $stack->flush; is($BUFFER, "", "No buffers, no output after flush"); # Clear top is same, with no capture $stack->append("Never seen"); is($stack->buffer, "Never seen", "See the append"); is($stack->output_buffer, "Never seen", "Same as output buffer"); $stack->clear_top; is($stack->buffer, "", "Clear empties the buffers"); is($stack->output_buffer, "", "output buffer as well"); $stack->flush; is($BUFFER, "", "No buffers, no output after flush"); String-BufferStack-1.16/t/05-preappend.t0000644000175000017500000000642311225672642016760 0ustar chmrrchmrruse warnings; use strict; use Test::More tests => 26; use vars qw/$BUFFER/; use_ok 'String::BufferStack'; my $stack = String::BufferStack->new( out_method => sub { $BUFFER .= join("", @_) }); ok($stack, "Made an object"); isa_ok($stack, 'String::BufferStack'); $stack->append(q{push( pre_append => sub { my $stack = shift; $stack->set_pre_append(undef); $closed = 1; $stack->direct_append(">"); } ); $stack->append("Content!"); is($closed, 1); $stack->pop; is($stack->buffer, q{Content!}); $stack->append($closed ? q{} : q{ />}); is($stack->buffer, q{Content!}); $stack->clear; $stack->append(q{push( pre_append => sub { my $stack = shift; $stack->set_pre_append(undef); $closed = 1; $stack->direct_append(">"); } ); $stack->pop; $stack->append($closed ? q{} : q{ />}); is($stack->buffer, q{}); $stack->clear; # Filters and pre_appends $stack->append(q{push( pre_append => sub { my $stack = shift; $stack->set_pre_append(undef); $closed = 1; $stack->direct_append(' hi="there">'); }, filter => sub { return uc shift; } ); $stack->append("Content!"); $stack->pop; $stack->append($closed ? q{} : q{ />}); is($stack->buffer, q{CONTENT!}); $stack->clear; # Multiple pre_appends for a single buffer my $first = 0; my $second = 0; $stack->push( pre_append => sub { $first++ } ); $stack->append("Whee!"); is($first, 1, "First pre-append seen"); $stack->push( pre_append => sub { $second++ } ); $stack->append("More!"); is($first, 2, "First pre-append seen again"); is($second, 1, "Second pre-append seen as well"); $stack->pop; $stack->append("Almost done!"); is($first, 3, "First pre-append seen yet again"); is($second, 1, "But not second"); $stack->pop; $stack->append("Done!"); is($first, 3, "No change in first"); is($second, 1, "Nor second"); $stack->clear; # Altering pre_appends mid-course $first = $second = 0; $stack->push( pre_append => sub {shift->set_pre_append(undef) if ++$first >= 3}); $stack->append("one"); is($first, 1, "First pre-append seen"); $stack->push( pre_append => sub {shift->set_pre_append(undef) if ++$second >= 3}); $stack->append("two"); is($first, 2, "First pre-append seen again"); is($second, 1, "Second pre-append seen as well"); $stack->append("three"); is($first, 3, "First hits again!"); is($second, 2, "Second as well"); $stack->append("four"); is($first, 3, "First is done"); is($second, 3, "Second still going strong"); $stack->append("five"); is($first, 3, "First is done"); is($second, 3, "Second is also done"); $stack->pop; $stack->append("popped"); is($first, 3, "First is still done"); is($second, 3, "Second is also done"); $stack->pop; String-BufferStack-1.16/t/03-capture.t0000644000175000017500000000347011225672642016442 0ustar chmrrchmrruse warnings; use strict; use Test::More tests => 22; use vars qw/$BUFFER $DEEPER/; use_ok 'String::BufferStack'; my $stack = String::BufferStack->new( out_method => sub { $BUFFER .= join("", @_) }); ok($stack, "Made an object"); isa_ok($stack, 'String::BufferStack'); # Tests with no buffer stack $BUFFER = ""; $stack->append("Some string"); is($stack->buffer, "Some string", "No stack, append goes through to output"); is($stack->output_buffer, "Some string", "Same as output buffer"); is($BUFFER, "", "Without flush, doesn't output"); # Add to the stack $DEEPER = ""; $stack->push(buffer => \$DEEPER); # Another tacks onto $DEEPER $stack->append(", and more"); is($stack->buffer, ", and more", "One step down, append doesn't go through"); is($stack->output_buffer, "Some string", "Output is different"); is($DEEPER, ", and more", "Append caught by lower level"); is($BUFFER, "", "Without flush, doesn't output"); # Pop it $stack->pop; # Rest of stack unchanged is($stack->buffer, "Some string", "Back to as it was"); is($stack->output_buffer, "Some string", "As well"); # Push it again $DEEPER = ""; $stack->push(buffer => \$DEEPER); $stack->append(", again"); is($DEEPER, ", again", "Append has effect"); $stack->clear_top; is($stack->output_buffer, "Some string", "Output buffer unchanged"); is($stack->buffer, "", "clear_top only affects top buffer"); is($DEEPER, "", "Referenced buffer is cleared"); # Write and try a flush $stack->append(", again"); $stack->flush; is($stack->output_buffer, "Some string", "With depth, flush is just filters"); is($BUFFER, "", "Hence no output seen"); $stack->flush_output; is($stack->output_buffer, "", "flush_all pushes the output buffer"); is($stack->buffer, ", again", "But not non-output buffers"); is($DEEPER, ", again", "..nor their variables"); is($BUFFER, "Some string", "Output seen"); String-BufferStack-1.16/t/04-filter.t0000644000175000017500000001260511225672642016265 0ustar chmrrchmrruse warnings; use strict; use Test::More tests => 54; use vars qw/$BUFFER $DEEPER/; use_ok 'String::BufferStack'; my $stack = String::BufferStack->new( out_method => sub { $BUFFER .= join("", @_) }); ok($stack, "Made an object"); isa_ok($stack, 'String::BufferStack'); # Tests with no buffer stack $BUFFER = ""; $stack->append("Some string"); is($stack->buffer, "Some string", "No stack, append goes through to output"); is($stack->output_buffer, "Some string", "Same as output buffer"); is($BUFFER, "", "Without flush, doesn't output"); # Add to the stack a no-op filter $stack->push(filter => sub {return shift} ); # Without flush_filters, doesn't appear in output $stack->append(", and more"); is($stack->buffer, "Some string", "Buffer is shared with output, nothing yet"); is($stack->output_buffer, "Some string", "Output is still there"); is($BUFFER, "", "Without flush, doesn't output"); # Flushing filters shoves it into buffer, and output $stack->flush_filters; is($stack->buffer, "Some string, and more", "Flushing filters gets to buffer"); is($stack->output_buffer, "Some string, and more", "Which is also output"); is($BUFFER, "", "..but not flushed"); # Pop it $stack->pop; is($stack->buffer, "Some string, and more", "Unchanged after pop"); is($stack->output_buffer, "Some string, and more", "Also output is"); # Add a upper-case filter $stack->push(filter => sub {return uc shift} ); $stack->append(", now!"); is($stack->buffer, "Some string, and more", "Nothing yet"); is($stack->output_buffer, "Some string, and more", "Also nothing in output"); is($BUFFER, "", "Without flush, doesn't output"); # Flushing filters shoves it into buffer, and output $stack->flush_filters; is($stack->buffer, "Some string, and more, NOW!", "See upper-case filter output"); is($stack->output_buffer, "Some string, and more, NOW!", "Also in output"); # Popping flushes filters $stack->append(" Whee!"); $stack->pop; is($stack->buffer, "Some string, and more, NOW! WHEE!", "See filter output"); is($stack->output_buffer, "Some string, and more, NOW! WHEE!", "Also in output"); $stack->clear; # Test clearing in the middle of everything $stack->append("First "); $stack->push(filter => sub {return ">>".shift(@_)."<<"} ); $stack->append("second"); $stack->clear; is($stack->buffer, "", "Clear emptied it out"); $stack->append("third"); is($stack->buffer, "", "Still empty"); $stack->pop; is($stack->buffer, ">>third<<", "See last append after clear"); $stack->clear; # Repeated flushes don't call the filter $stack->push(filter => sub {return ">>".shift(@_)."<<"} ); $stack->flush_filters; is($stack->buffer, "", "No input, no output"); $stack->flush_filters; is($stack->buffer, "", "Still no input, no output"); $stack->append("here"); is($stack->buffer, "", "Input, but not flushed"); $stack->flush_filters; is($stack->buffer, ">>here<<", "Flushed once, get output"); $stack->flush_filters; is($stack->buffer, ">>here<<", "Flushed again, no more"); $stack->append(""); is($stack->buffer, ">>here<<", "Appending nothing does nothing"); $stack->append(undef); is($stack->buffer, ">>here<<", "Appending undef does nothing"); $stack->pop; $stack->clear; # Filter nesting! $stack->push(filter => sub {return ">>".shift(@_)."<<"} ); $stack->append("first"); is($stack->buffer, "", "Nothing yet"); $stack->flush_filters; is($stack->buffer, ">>first<<", "First filter output"); is($stack->output_buffer, ">>first<<", "Output buffer as well"); $stack->push(filter => sub {$_[0] =~ tr/a-z/b-za/; $_[0]} ); is($stack->buffer, "", "Nothing on the new buffer"); is($stack->output_buffer, ">>first<<", "Nothing more yet"); $stack->append("second"); is($stack->buffer, "", "Nothing on the new buffer"); is($stack->output_buffer, ">>first<<", "Nothing more yet"); $stack->filter; is($stack->buffer, "tfdpoe", "Pushes output through"); is($stack->output_buffer, ">>first<<", "Output unchanged yet"); $stack->flush_filters; is($stack->buffer, "", "Flushing all of them clears the buffer"); is($stack->output_buffer, ">>first<<>>tfdpoe<<", "And adds to output"); $stack->pop; $stack->pop; is($stack->buffer, ">>first<<>>tfdpoe<<", "Unchanged after pop"); is($stack->output_buffer, ">>first<<>>tfdpoe<<", "Also output"); $stack->append("verbatim"); is($stack->output_buffer, ">>first<<>>tfdpoe<filter; is($stack->output_buffer, ">>first<<>>tfdpoe<clear; ## Modifying filters mid-runtime $stack->push(filter => sub {return ">>".shift(@_)."<<"}); $stack->append("first"); $stack->flush; is($stack->buffer, ">>first<<", "First filter output"); $stack->append("second"); is($stack->buffer, ">>first<<", "Without flush, no result yet"); # Unsetting filter $stack->set_filter(undef); is($stack->buffer, ">>first<<>>second<<", "Unsetting filter flushes"); $stack->append("third"); is($stack->buffer, ">>first<<>>second<set_filter(undef); is($stack->buffer, ">>first<<>>second<set_filter(sub {return uc shift}); $stack->append("hi"); is($stack->buffer, ">>first<<>>second<set_filter(sub {return "(content)"}); is($stack->buffer, ">>first<<>>second<append("This doesn't matter"); $stack->flush; is($stack->buffer, ">>first<<>>second<pop; String-BufferStack-1.16/t/02-simple-stack.t0000644000175000017500000000450611225672642017373 0ustar chmrrchmrruse warnings; use strict; use Test::More tests => 32; use vars qw/$BUFFER/; use_ok 'String::BufferStack'; my $stack = String::BufferStack->new( out_method => sub { $BUFFER .= join("", @_) }); ok($stack, "Made an object"); isa_ok($stack, 'String::BufferStack'); # Tests with no buffer stack $BUFFER = ""; $stack->append("Some string"); is($stack->buffer, "Some string", "No stack, append goes through to output"); is($stack->output_buffer, "Some string", "Same as output buffer"); is($BUFFER, "", "Without flush, doesn't output"); # Add to the stack is($stack->depth, 0, "Has no depth yet"); $stack->push; is($stack->depth, 1, "Has a frame"); # Another append does exactly that $stack->append(", and more"); is($stack->buffer, "Some string, and more", "One step down, append goes through to output"); is($stack->output_buffer, "Some string, and more", "Same as output buffer"); is($BUFFER, "", "Without flush, doesn't output"); # Pop it is($stack->depth, 1, "Still has a frame"); $stack->pop; is($stack->depth, 0, "No frames anymore"); # State is unchanged is($stack->buffer, "Some string, and more", "One step down, append goes through to output"); is($stack->output_buffer, "Some string, and more", "Same as output buffer"); is($BUFFER, "", "Without flush, doesn't output"); # Flush the output $stack->flush; is($stack->buffer, "", "Flush clears output"); is($stack->output_buffer, "", "Also output buffer"); is($BUFFER, "Some string, and more", "Flush moved to output"); # Popping again does nothing is($stack->pop, undef, "Popping again returns undef"); is($stack->depth, 0, "And leaves depth unchanged"); is($stack->buffer, "", "Buffer is still empty"); is($stack->output_buffer, "", "Also output buffer"); # Nested pushes do the right thing $stack->push; $stack->push; $stack->append("Nested"); is($stack->buffer, "Nested", "Nested append"); is($stack->output_buffer, "Nested", "Nested append carried through to output"); is($stack->pop, "Nested", "Popping produces correct content"); is($stack->buffer, "Nested", "Nested append"); is($stack->output_buffer, "Nested", "Nested append carried through to output"); is($stack->pop, "Nested", "Popping produces correct content"); is($stack->buffer, "Nested", "Nested append"); is($stack->output_buffer, "Nested", "Nested append carried through to output"); is($stack->pop, undef, "Too many pops returns undef"); String-BufferStack-1.16/SIGNATURE0000644000175000017500000000367411651774007015422 0ustar chmrrchmrrThis file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.68. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 SHA1 15c9b2642d2965257202808aad9daca4c45df675 Changes SHA1 1c6f06132483a26d9da6542ff45adaa64bc31bfc MANIFEST SHA1 b82635e2bf3d456e38a1d388fd1fd606b563b5fe META.yml SHA1 9c5cf7ada3d40313a3c1083818397cdeba816759 Makefile.PL SHA1 dee3e130b392c8b6997be5ef899fd14a9370dabd README SHA1 7b4ae50ebac72d20761171c4c2b50c206344ea40 inc/Module/Install.pm SHA1 d9fe55a427fe2fd75b5029afeeaa61b592e07f79 inc/Module/Install/Base.pm SHA1 62d3922826d9f89f20c185e7031ac8f028504745 inc/Module/Install/Can.pm SHA1 dc809f64fb70a26b069a36f8d3d353d520dbb7e1 inc/Module/Install/Fetch.pm SHA1 73ab91490a628452cc140db72ef9d13a1326d211 inc/Module/Install/Makefile.pm SHA1 8ce3f2b414e4617e6233dd4ba10830f8c5d672ec inc/Module/Install/Metadata.pm SHA1 3b0acd2eeac93a0afe48120f5648f0db362e5bbf inc/Module/Install/Win32.pm SHA1 f08924f051e623f8e09fa6a121993c4a9cf7d9eb inc/Module/Install/WriteAll.pm SHA1 d03c3b96a2d67d43903bb2e5f8bc2ef86d531a9f lib/String/BufferStack.pm SHA1 3d95f77905fe38ffb6b2c9277144f1867e2200eb t/01-basic.t SHA1 44ef8aa5cf63e875a4eea5b8043a1df9b8ff4fed t/02-simple-stack.t SHA1 2facb62ae74edb458c201635cf9156ffa63dcb16 t/03-capture.t SHA1 f02330a5471c2385ddbfe6167e2d971b255ad9e7 t/04-filter.t SHA1 bf5f3e896350661bcbf1f03d97f7eda15c5bfdf8 t/05-preappend.t -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.11 (GNU/Linux) iEYEARECAAYFAk6n+AcACgkQMflWJZZAbqAb4wCdEhO4BwiV4yGidvIRxCeGc7Ol 3MEAoIXXtbqdcBjkeTHXq9VygQjx8RSE =6HbE -----END PGP SIGNATURE----- String-BufferStack-1.16/MANIFEST0000644000175000017500000000062511321216504015243 0ustar chmrrchmrrChanges inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/String/BufferStack.pm Makefile.PL MANIFEST This list of files META.yml README SIGNATURE t/01-basic.t t/02-simple-stack.t t/03-capture.t t/04-filter.t t/05-preappend.t String-BufferStack-1.16/Makefile.PL0000644000175000017500000000044011651773507016100 0ustar chmrrchmrruse inc::Module::Install; name ('String-BufferStack'); author ('Alex Vandiver '); abstract_from ('lib/String/BufferStack.pm'); version_from ('lib/String/BufferStack.pm'); license_from ('lib/String/BufferStack.pm'); requires( perl => '5.8.0'); sign; WriteAll; String-BufferStack-1.16/META.yml0000644000175000017500000000102311651773771015400 0ustar chmrrchmrr--- abstract: 'Nested buffers for templating systems' author: - 'Alex Vandiver ' build_requires: ExtUtils::MakeMaker: 6.42 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 1.01' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: String-BufferStack no_index: directory: - inc - t requires: perl: 5.8.0 resources: license: http://dev.perl.org/licenses/ version: 1.16