String-BufferStack-1.15/0000755000175000017500000000000011321216521014105 5ustar chmrrchmrrString-BufferStack-1.15/MANIFEST0000644000175000017500000000062511321216504015242 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.15/META.yml0000644000175000017500000000074311321216457015372 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 0.91' license: Artistic 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 version: 1.15 String-BufferStack-1.15/SIGNATURE0000644000175000017500000000367411321216513015404 0ustar chmrrchmrrThis file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.55. 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 1ab68d7ee1ec3b46bb6b89d8611fc98a7fb224c9 Changes SHA1 1c6f06132483a26d9da6542ff45adaa64bc31bfc MANIFEST SHA1 2d7781d81024593a576c78437b29aff1bfe9c22d META.yml SHA1 7630604c507f12721ed80f4c9c2b150dde21eb6d Makefile.PL SHA1 dee3e130b392c8b6997be5ef899fd14a9370dabd README SHA1 fd5f3c4f0418efee3b9b16cf8c3902e8374909df inc/Module/Install.pm SHA1 7cd7c349afdf3f012e475507b1017bdfa796bfbd inc/Module/Install/Base.pm SHA1 ba186541bbf6439111f01fc70769cf24d22869bf inc/Module/Install/Can.pm SHA1 aaa50eca0d7751db7a4d953fac9bc72c6294e238 inc/Module/Install/Fetch.pm SHA1 3e83972921d54198d1246f7278f08664006cd65d inc/Module/Install/Makefile.pm SHA1 12bf1867955480d47d5171a9e9c6a96fabe0b58f inc/Module/Install/Metadata.pm SHA1 f7ee667e878bd2faf22ee9358a7b5a2cc8e91ba4 inc/Module/Install/Win32.pm SHA1 8ed29d6cf217e0977469575d788599cbfb53a5ca inc/Module/Install/WriteAll.pm SHA1 ff8eb2b49eb892fccf0f59facde7308777dd882e 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 v2.0.14 (GNU/Linux) iEYEARECAAYFAktFHUsACgkQMflWJZZAbqAtewCeJLXtuYvLcSihnm3/lEY+KkhU Sk4AnRVfYrs1Kfg46HqMEzT1Ehn0uJfb =EYCa -----END PGP SIGNATURE----- String-BufferStack-1.15/Changes0000644000175000017500000000145311321216117015404 0ustar chmrrchmrrRevision history for String-BufferStack 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.15/lib/0000755000175000017500000000000011321216521014653 5ustar chmrrchmrrString-BufferStack-1.15/lib/String/0000755000175000017500000000000011321216521016121 5ustar chmrrchmrrString-BufferStack-1.15/lib/String/BufferStack.pm0000644000175000017500000003072111321216015020657 0ustar chmrrchmrrpackage String::BufferStack; use strict; use warnings; use Carp; our $VERSION; $VERSION = "1.15"; =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.15/t/0000755000175000017500000000000011321216521014350 5ustar chmrrchmrrString-BufferStack-1.15/t/02-simple-stack.t0000644000175000017500000000450611225672642017372 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.15/t/05-preappend.t0000644000175000017500000000642311225672642016757 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.15/t/03-capture.t0000644000175000017500000000347011225672642016441 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.15/t/01-basic.t0000644000175000017500000000566711225672642016067 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.15/t/04-filter.t0000644000175000017500000001260511225672642016264 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.15/Makefile.PL0000644000175000017500000000040311225672642016071 0ustar chmrrchmrruse inc::Module::Install; name ('String-BufferStack'); author ('Alex Vandiver '); version_from ('lib/String/BufferStack.pm'); abstract_from('lib/String/BufferStack.pm'); license('Artistic'); requires( perl => '5.8.0'); &WriteAll; String-BufferStack-1.15/README0000644000175000017500000001452111225672642015005 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.15/inc/0000755000175000017500000000000011321216521014656 5ustar chmrrchmrrString-BufferStack-1.15/inc/Module/0000755000175000017500000000000011321216521016103 5ustar chmrrchmrrString-BufferStack-1.15/inc/Module/Install/0000755000175000017500000000000011321216521017511 5ustar chmrrchmrrString-BufferStack-1.15/inc/Module/Install/Win32.pm0000644000175000017500000000340311321216457020761 0ustar chmrrchmrr#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @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.15/inc/Module/Install/Base.pm0000644000175000017500000000176611321216457020743 0ustar chmrrchmrr#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '0.91'; } # 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->VERSION; } sub DESTROY {} package Module::Install::Base::FakeAdmin; my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 154 String-BufferStack-1.15/inc/Module/Install/Makefile.pm0000644000175000017500000001600311321216457021574 0ustar chmrrchmrr#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @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, always use defaults if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } sub makemaker_args { my $self = shift; my $args = ( $self->{makemaker_args} ||= {} ); %$args = ( %$args, @_ ); return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = sShift; 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 ); } my %test_dir = (); sub _wanted_t { /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1; } sub tests_recursive { my $self = shift; if ( $self->tests ) { die "tests_recursive will not work if tests are already defined"; } my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } %test_dir = (); require File::Find; File::Find::find( \&_wanted_t, $dir ); $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir ); } 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. $self->build_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); } 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->{VERSION} = $self->version; $args->{NAME} =~ s/-/::/g; if ( $self->tests ) { $args->{test} = { TESTS => $self->tests }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = $self->author; } if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { $args->{NO_META} = 1; } if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } # Merge both kinds of requires into prereq_pm my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_, ($self->configure_requires, $self->build_requires, $self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # merge both kinds of requires into prereq_pm my $subdirs = ($args->{DIR} ||= []); if ($self->bundles) { foreach my $bundle (@{ $self->bundles }) { my ($file, $dir) = @$bundle; push @$subdirs, $dir if -d $dir; delete $prereq->{$file}; } } 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"; } $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: $!"; my $makefile = do { local $/; }; close MAKEFILE or die $!; $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; open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; 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 394 String-BufferStack-1.15/inc/Module/Install/Fetch.pm0000644000175000017500000000462711321216457021121 0ustar chmrrchmrr#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @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.15/inc/Module/Install/WriteAll.pm0000644000175000017500000000222211321216457021600 0ustar chmrrchmrr#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91';; @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} ) { $self->makemaker_args( PL_FILES => {} ); } # 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.15/inc/Module/Install/Metadata.pm0000644000175000017500000003530411321216457021604 0ustar chmrrchmrr#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract author 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 }; 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; } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', 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()' ); $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } 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"); } # 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) ); } 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 perl_version_from { my $self = shift; if ( Module::Install::_read($_[0]) =~ m/ ^ (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; $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; $author =~ s{E}{<}g; $author =~ s{E}{>}g; $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } sub license_from { my $self = shift; if ( Module::Install::_read($_[0]) =~ m/ ( =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b .*? ) (=head\\d.*|=cut.*|) \z /ixms ) { my $license_text = $1; my @phrases = ( 'under the same (?:terms|license) as (?:perl|the perl programming language) itself' => '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, 'BSD license' => 'bsd', 1, 'Artistic license' => 'artistic', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s{\s+}{\\s+}g; if ( $license_text =~ /\b$pattern\b/i ) { $self->license($license); return 1; } } } warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } sub _extract_bugtracker { my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g; 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 on rt.cpan.org 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; } ###################################################################### # 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.15/inc/Module/Install/Can.pm0000644000175000017500000000333311321216457020562 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 = '0.91'; @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.15/inc/Module/Install.pm0000644000175000017500000002411411321216457020061 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 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 = '0.91'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } # 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 # 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)); use Cwd (); use File::Find (); use File::Path (); use FindBin; 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; } $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; 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 import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; unless ( -f $self->{file} ) { 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"}; } *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{"$self->{file}"}; delete $INC{"$self->{path}.pm"}; # Save to the singleton $MAIN = $self; return 1; } 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 ) { *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; # 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) = @_; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = delete $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; } sub _read { local *FH; if ( $] >= 5.006 ) { open( FH, '<', $_[0] ) or die "open($_[0]): $!"; } else { open( FH, "< $_[0]" ) or die "open($_[0]): $!"; } my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } 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; } sub _write { local *FH; if ( $] >= 5.006 ) { open( FH, '>', $_[0] ) or die "open($_[0]): $!"; } else { open( FH, "> $_[0]" ) or die "open($_[0]): $!"; } foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } # _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 - 2009 Adam Kennedy.