Spoon-0.24/0000755000076500007650000000000010536643153012513 5ustar ingyingy00000000000000Spoon-0.24/Changes0000644000076500007650000000662510477052414014015 0ustar ingyingy00000000000000--- version: 0.24 date: Wed Aug 30 10:45:22 PDT 2006 changes: - Include Time::HiRes dependency into Makefile.PL (RT #19291) - Include URI and DB_File dependency into Makefile.PL (RT #15036) - Upgraded to Module::Install 0.64 - Added File::Spec path name portability fixes all over the place. - Incorporated parts of Barbie's patch to fix tests on Win32 Perl 5.6 (RT #17506) --- version: 0.23 date: Mon Apr 4 09:11:51 PDT 2005 changes: - Makefile.PL was missing :( --- version: 0.22 date: Mon Apr 4 03:15:32 PDT 2005 changes: - Added tests for UTF8 handling internally and in files via ContentObject. - Added CGI tests. - All CGI parameters are now decoded as UTF8. The -utf8 flag is now deprecated, but will continue to work as a no-op for now. - socialtext changes to allow formatter hooking - Changes for themes - -compress works better - Fix the mixin problem with resolve_install_path - Refactors to get rid of hub connections - Kwid Formatter for Spork - make sure the module_path comes from lib under cwd - Make installer better - Miyagawa's patch to bake cookies in redirect - CGI patch from cdent - Miyagawa added jar_opt support for different expires for each cookies - Miyagawa added unit test for Spoon::Cookie - fix deep-recursion bug on 'kwiki -update' --- version: 0.21 date: Tue Jan 11 07:28:06 PST 2005 changes: - WAFL blocks and phrase matching is now case-insensitive, and dashes (-) are converted to underscores. (Dave Rolsky) - Redo Spoon::Hook into Spoon::Hooks - Call $hub->add_hook - Hooks removed when hub goes out scope - Spoon::Config can take glob params - Add hook points to support KwikiPagePrivacy - Add a domain field to cookies - AUTOLOAD class object pointers. replaces load_class in most cases. - Add pre_process and post_process hook points in hub - Have a load_dynamic method for Registry --- version: 0.20 date: Sat Dec 18 00:39:23 PST 2004 changes: - Only require TemplateToolkit 2.10 because of Debian stable - 'hub' in Spoon::Installer caused memory cycles in Kwiki --- version: 0.19 date: Wed Dec 15 13:13:10 PST 2004 changes: - Spoon is now memory cycle free, which makes it much more suitable for use under mod_perl (Dave Rolsky) - Added Spoon::Trace tracing and benchmarking facility - Added Spoon::Hook method hooking facility - Added assert, clone, conf functions to base - WARNING: Removed old hook facility!! - Split Spoon::Cookie into Spoon::Headers - Redo how redirects work. Use a redirect method. - -quiet mode for file installation - Add BEGIN/END comments to html templates automatically - Use template toolkit caching. Big speed improvement. (Chris Dent) --- version: 0.18 date: Sun Aug 8 23:02:27 PDT 2004 changes: - Use Spiffy::new for constructor instead of special Spoon::Base one. - unicode fixes --- version: 0.17 date: Fri Jul 16 23:42:53 PDT 2004 changes: - Use only the UTF8 character encoding --- version: 0.16 date: Tue Jun 22 10:14:45 PDT 2004 changes: - Support locked files in Installer --- version: 0.15 date: Sun Jun 20 20:32:01 PDT 2004 changes: - Support for Kwiki 0.30 release --- version: 0.13 date: Fri May 7 00:57:06 PDT 2004 changes: - Support for Kwiki release --- version: 0.12 date: Wed Mar 31 00:16:13 CST 2004 changes: - Refactoring for Spork-0.12 --- version: 0.11 date: Sun Mar 21 12:45:18 PST 2004 changes: - Added Spoon::debug - Added Spoon::Installer --- version: 0.10 date: Sun Mar 21 01:58:22 PST 2004 changes: - Initial release. Spoon-0.24/inc/0000755000076500007650000000000010536643153013264 5ustar ingyingy00000000000000Spoon-0.24/inc/Module/0000755000076500007650000000000010536643153014511 5ustar ingyingy00000000000000Spoon-0.24/inc/Module/Install/0000755000076500007650000000000010536643153016117 5ustar ingyingy00000000000000Spoon-0.24/inc/Module/Install/Base.pm0000644000076500007650000000203510536643011017320 0ustar ingyingy00000000000000#line 1 package Module::Install::Base; $VERSION = '0.64'; # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } ### This is the ONLY module that shouldn't have strict on # use strict; #line 41 sub new { my ($class, %args) = @_; foreach my $method ( qw(call load) ) { *{"$class\::$method"} = sub { shift()->_top->$method(@_); } unless defined &{"$class\::$method"}; } bless( \%args, $class ); } #line 61 sub AUTOLOAD { my $self = shift; local $@; my $autoload = eval { $self->_top->autoload } or return; goto &$autoload; } #line 76 sub _top { $_[0]->{_top} } #line 89 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } 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 138 Spoon-0.24/inc/Module/Install/Can.pm0000644000076500007650000000337410536643011017156 0ustar ingyingy00000000000000#line 1 package Module::Install::Can; use strict; use Module::Install::Base; use Config (); ### This adds a 5.005 Perl version dependency. ### This is a bug and will be fixed. use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.64'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } # 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}), '.') { 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 157 Spoon-0.24/inc/Module/Install/Fetch.pm0000644000076500007650000000463010536643011017502 0ustar ingyingy00000000000000#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.64'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } 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; Spoon-0.24/inc/Module/Install/Makefile.pm0000644000076500007650000001337310536643011020172 0ustar ingyingy00000000000000#line 1 package Module::Install::Makefile; use strict 'vars'; use Module::Install::Base; use ExtUtils::MakeMaker (); use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.64'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } 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, @_ ) if @_; $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 write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args); $args->{VERSION} = $self->version || $self->determine_VERSION($args); $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->build_requires, $self->requires) ); # 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"; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args; if ($self->admin->preop) { $args{dist} = $self->admin->preop; } 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 334 Spoon-0.24/inc/Module/Install/Metadata.pm0000644000076500007650000001747610536643011020205 0ustar ingyingy00000000000000#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.64'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } my @scalar_keys = qw{ name module_name abstract author version license distribution_type perl_version tests }; my @tuple_keys = qw{ build_requires requires recommends bundles }; sub Meta { shift } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } 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 (@tuple_keys) { *$key = sub { my $self = shift; return $self->{values}{$key} unless @_; my @rv; while (@_) { my $module = shift or last; my $version = shift || 0; if ( $module eq 'perl' ) { $version =~ s{^(\d+)\.(\d+)\.(\d+)} {$1 + $2/1_000 + $3/1_000_000}e; $self->perl_version($version); next; } my $rv = [ $module, $version ]; push @rv, $rv; } push @{ $self->{values}{$key} }, @rv; @rv; }; } sub sign { my $self = shift; return $self->{'values'}{'sign'} if defined wantarray and !@_; $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 ); return $self; } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n"; return $self; } $self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0; return $self; } 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; die "all_from: cannot find $file from $name" unless -e $file; } $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; # The remaining probes read from POD sections; if the file # has an accompanying .pod, use that instead my $pod = $file; if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) { $file = $pod; } $self->author_from($file) unless $self->author; $self->license_from($file) unless $self->license; $self->abstract_from($file) unless $self->abstract; } 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', 0 ); require YAML; my $data = YAML::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 { my ( $self, $file ) = @_; require ExtUtils::MM_Unix; $self->version( ExtUtils::MM_Unix->parse_version($file) ); } sub abstract_from { my ( $self, $file ) = @_; require ExtUtils::MM_Unix; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } sub _slurp { my ( $self, $file ) = @_; local *FH; open FH, "< $file" or die "Cannot open $file.pod: $!"; do { local $/; }; } sub perl_version_from { my ( $self, $file ) = @_; if ( $self->_slurp($file) =~ m/ ^ use \s* v? ([\d_\.]+) \s* ; /ixms ) { my $v = $1; $v =~ s{_}{}g; $self->perl_version($1); } else { warn "Cannot determine perl version info from $file\n"; return; } } sub author_from { my ( $self, $file ) = @_; my $content = $self->_slurp($file); 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 $file\n"; } } sub license_from { my ( $self, $file ) = @_; if ( $self->_slurp($file) =~ 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 itself' => 'perl', 'GNU public license' => 'gpl', 'GNU lesser public license' => 'gpl', 'BSD license' => 'bsd', 'Artistic license' => 'artistic', 'GPL' => 'gpl', 'LGPL' => 'lgpl', 'BSD' => 'bsd', 'Artistic' => 'artistic', ); while ( my ( $pattern, $license ) = splice( @phrases, 0, 2 ) ) { $pattern =~ s{\s+}{\\s+}g; if ( $license_text =~ /\b$pattern\b/i ) { $self->license($license); return 1; } } } warn "Cannot determine license info from $file\n"; return 'unknown'; } 1; Spoon-0.24/inc/Module/Install/Win32.pm0000644000076500007650000000341610536643011017354 0ustar ingyingy00000000000000#line 1 package Module::Install::Win32; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.64'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } # 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, ); if (!$rv) { die <<'END_MESSAGE'; ------------------------------------------------------------------------------- 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; Spoon-0.24/inc/Module/Install/WriteAll.pm0000644000076500007650000000162410536643011020174 0ustar ingyingy00000000000000#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.64'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_ ); $self->sign(1) if $args{sign}; $self->Meta->write if $args{meta}; $self->admin->WriteAll(%args) if $self->is_admin; if ( $0 =~ /Build.PL$/i ) { $self->Build->write; } else { $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{'PL_FILES'} ) { $self->makemaker_args( PL_FILES => {} ); } if ($args{inline}) { $self->Inline->write; } else { $self->Makefile->write; } } } 1; Spoon-0.24/inc/Module/Install.pm0000644000076500007650000001761110536643011016454 0ustar ingyingy00000000000000#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.004; use strict 'vars'; use vars qw{$VERSION}; 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.64'; } # 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 and (stat($0))[9] > time ) { die << "END_DIE"; Your installer $0 has a modification time in the future. This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } use Cwd (); use File::Find (); use File::Path (); use FindBin; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; 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"; unshift @_, ($self, $1); goto &{$self->can('call')} unless uc($1) eq $1; }; } 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"}; } sub preload { my ($self) = @_; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { my $admin = $self->{admin}; @exts = $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"; 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 { 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) ) { open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!"; my $in_pod = 0; while ( ) { $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; } } close PKGFILE; } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } 1; Spoon-0.24/lib/0000755000076500007650000000000010536643153013261 5ustar ingyingy00000000000000Spoon-0.24/lib/Spoon/0000755000076500007650000000000010536643153014357 5ustar ingyingy00000000000000Spoon-0.24/lib/Spoon/Base.pm0000644000076500007650000002017610524500210015554 0ustar ingyingy00000000000000package Spoon::Base; use Spiffy 0.24 -Base; use Spiffy qw(-yaml); use Spiffy qw(WWW XXX YYY ZZZ); # WWW - Creating a wrapper sub to require() IO::All caused spurious segfaults use IO::All 0.32; our @EXPORT = qw(io trace WWW XXX YYY ZZZ); our @EXPORT_OK = qw(conf); field used_classes => []; field 'encoding'; const plugin_base_directory => './plugin'; field using_debug => 0; field config_class => 'Spoon::Config'; sub hub { return $Spoon::Base::HUB if defined($Spoon::Base::HUB) and not @_; Carp::confess "Too late to create a new hub. One already exists" if defined $Spoon::Base::HUB; my ($args, @config_files); { no warnings; local *paired_arguments = sub { qw(-config_class) }; ($args, @config_files) = $self->parse_arguments(@_); } my $config_class = $args->{-config_class} || $self->can('config_class') ? $self->config_class : 'Spoon::Config'; eval "require $config_class"; die $@ if $@; my $config = $config_class->new(@config_files); my $hub_class = $config->hub_class; eval "require $hub_class"; my $hub = $hub_class->new( config => $config, config_files => \@config_files, ); } sub destroy_hub { undef $Spoon::Base::HUB; } sub init { } sub assert { die "Assertion failed" unless shift; } sub trace() { require Spoon::Trace; no warnings; *trace = \ &Spoon::Trace::trace; goto &trace; } sub t { trace->mark; return $self; } sub conf() { my ($name, $default) = @_; my $package = caller; no strict 'refs'; *{$package . '::' . $name} = sub { my $self = shift; return $self->{$name} if exists $self->{$name}; $self->{$name} = exists($self->hub->config->{$name}) ? $self->hub->config->{$name} : $default; }; } sub clone { return bless {%$self}, ref $self; } sub is_in_cgi { defined $ENV{GATEWAY_INTERFACE}; } sub is_in_test { defined $ENV{SPOON_TEST}; } sub have_plugin { my $hub = $self->class_id eq 'hub' ? $self : $self->hub; local $@; eval { $hub->load_class(shift) } } sub plugin_directory { my $dir = join '/', $self->plugin_base_directory, $self->class_id, ; mkdir $dir unless -d $dir; return $dir; } sub debug { no warnings; if ($self->is_in_cgi) { eval 'use CGI::Carp qw(fatalsToBrowser)'; die $@ if $@; $SIG{__DIE__} = sub { CGI::Carp::confess(@_) } } else { require Carp; $SIG{__DIE__} = sub { Carp::confess(@_) } } $self->using_debug(1) if ref $self; return $self; } our ($UPPER, $LOWER, $ALPHA, $NUM, $ALPHANUM, $WORD, $WIKIWORD); push @EXPORT_OK, qw($UPPER $LOWER $ALPHA $NUM $ALPHANUM $WORD $WIKIWORD); our %EXPORT_TAGS = (char_classes => [@EXPORT_OK]); if ($] < 5.008) { $UPPER = 'A-Z\xc0-\xde'; $LOWER = 'a-z\xdf-\xff'; $ALPHA = $UPPER . $LOWER; $NUM = '0-9'; $ALPHANUM = $ALPHA . $NUM; $WORD = $ALPHANUM . '_'; $WIKIWORD = $WORD; } else { $UPPER = '\p{UppercaseLetter}'; $LOWER = '\p{LowercaseLetter}'; $ALPHA = '\p{Letter}'; $NUM = '\p{Number}'; $ALPHANUM = '\p{Letter}\p{Number}\pM'; $WORD = '\p{Letter}\p{Number}\p{ConnectorPunctuation}\pM'; $WIKIWORD = "$UPPER$LOWER$NUM" . '\p{ConnectorPunctuation}\pM'; } sub env_check { my $variable = shift; die "Environment variable '$variable' not set" unless defined $ENV{$variable}; } sub dumper_to_file { my $path = shift; require Data::Dumper; no warnings; local $Data::Dumper::Indent = 1; local $Data::Dumper::Terse = (@_ == 1) ? 1 : 0; local $Data::Dumper::Sortkeys = 1; io("$path")->assert->print(Data::Dumper::Dumper(@_)); } # Codecs and Escaping my $has_utf8; sub has_utf8 { $has_utf8 = shift if @_; return $has_utf8 if defined($has_utf8); $has_utf8 = $] < 5.008 ? 0 : 1; require Encode if $has_utf8; } sub utf8_decode { $_[0] = Encode::decode('utf8', $_[0]) if $self->has_utf8 and defined $_[0] and not Encode::is_utf8($_[0]); return $_[0]; } sub utf8_encode { $_[0] = Encode::encode('utf8', $_[0]) if $self->has_utf8 and defined $_[0]; return $_[0]; } sub uri_escape { require CGI::Util; my $data = shift; $self->utf8_encode($data); return CGI::Util::escape($data); } sub uri_unescape { require CGI::Util; my $data = shift; $data = CGI::Util::unescape($data); $self->utf8_decode($data); return $data; } # WWW - The CGI.pm version is broken in Chinese sub html_escape { my $val = shift; $val =~ s/&/&/g; $val =~ s//>/g; $val =~ s/\(/(/g; $val =~ s/\)/)/g; $val =~ s/"/"/g; $val =~ s/'/'/g; return $val; } sub html_unescape { CGI::unescapeHTML(shift); } sub base64_encode { require MIME::Base64; MIME::Base64::encode_base64(@_); } sub base64_decode { require MIME::Base64; MIME::Base64::decode_base64(@_); } # XXX Move to IO::All. Make more robust. Use Damian's prompting module. package IO::All; sub prompt { print shift; io('-')->chomp->getline; } __END__ =head1 NAME Spoon::Base - Generic Spoon Base Class =head1 SYNOPSIS use Spoon::Base '-Base'; =head1 DESCRIPTION Base class for application plugins. Provides basic functionality to all modules inheriting from this class. =head1 SUBROUTINES These subroutines are meant to be called bare, not as an object-method call. =head2 trace See Spoon::Trace::trace(). =head2 conf(name, default) Returns the configuration value for "name", if it can be found in the config ($self->hub->config). Returns $default, otherwise. =head1 METHODS =head2 hub Return the application's hub object. See Spoon::Hub. =head2 init Inherited by all subclasses. Put your class initialization stuff here. =head2 assert(boolean) Die if the supplied argument is false. =head2 t([label]) Calls Spoon::Trace::mark(). See Spoon::Trace. =head2 clone Copies a class instance. The copy is only a shallow one. =head2 is_in_cgi Returns a boolean, indicating whether we were called from a CGI interface. =head2 is_in_test Returns a boolean, indicating whether we were called from a test suite. =head2 have_plugin(class_id) Tries to load a plugin. See Spoon::Hub::load_class(). =head2 plugin_directory Returns your plugin's directory. You can use this directory to store state. =head2 env_check(variable_name) Sanity check: ensure the specified variable exists in %ENV. If the variable is not found, dies with a useful error message. =head2 dumper_to_file(filepath, variable1 [, variable2...]) Uses Data::Dumper to save a dump of one or more variables to the specified file. =head2 has_utf8 Returns a boolean, indicating whether utf8 is available on this platform and version of perl. =head2 utf8_encode(string) Encodes the string in utf8, if utf8 is available. Otherwise, returns $string unmodified. See Encode::encode(). =head2 utf8_decode(string) Decodes the string from utf8, if utf8 is available. Otherwise, returns $string unmodified. See Encode::decode(). =head2 uri_escape(string) Escapes all invalid URI characters. See CGI::Util::escape(). =head2 uri_unescape(string) Unescapes all invalid URI characters. See CGI::Util::unescape(). =head2 html_escape(string) Escapes all reserved characters. The result is suitable for including verbatim in an HTML document. See CGI::escapeHTML(). =head2 html_unescape(string) Escapes all reserved characters. The result is suitable for including verbatim in an HTML document. See CGI::unescapeHTML(). =head2 base64_encode(string) Encodes the specified string into Base64. See MIME::Base64::encode_base64(). =head2 base64_encode(base64_data) Decodes the specified data from Base64. See MIME::Base64::decode_base64(). =head1 TODO * Document what Spoon::Base->debug() does. =head1 AUTHOR Brian Ingerson =head1 COPYRIGHT Copyright (c) 2004. Brian Ingerson. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut Spoon-0.24/lib/Spoon/CGI.pm0000644000076500007650000000560410474067450015325 0ustar ingyingy00000000000000package Spoon::CGI; use Spoon::Base -Base; use CGI -no_debug, -nosticky; our @EXPORT = qw(cgi); my $all_params_by_class = {}; const class_id => 'cgi'; sub cgi() { my $package = caller; my ($field, $is_upload, @flags); for (@_) { if ($_ eq '-upload') { $is_upload = 1; next; } (push @flags, $1), next if /^-(\w+)$/; $field ||= $_; } die "Cannot apply flags to upload field ($field)" if $is_upload and @flags; push @{$all_params_by_class->{$package}}, $field; no strict 'refs'; no warnings; *{"$package\::$field"} = $is_upload ? sub { my $self = shift; $self->_get_upload($field); } : @flags ? sub { my $self = shift; die "Setting CGI params not implemented" if @_; my $param = $self->_get_raw($field); for my $flag (@flags) { my $method = "_${flag}_filter"; $self->$method($param); } return $param; } : sub { my $self = shift; die "Setting CGI params not implemented" if @_; $self->_get_raw($field); } } sub add_params { my $class = ref($self); push @{$all_params_by_class->{$class}}, @_; } sub defined { my $param = shift; defined CGI::param($param) or defined CGI::url_param($param); } sub all { my $class = ref($self); map { ($_, scalar $self->$_) } @{$all_params_by_class->{$class}}; } sub vars { map $self->utf8_decode($_), CGI::Vars(); } sub _get_raw { my $field = shift; my @values; if (defined(my $value = $self->{$field})) { @values = ref($value) ? @$value : $value; } else { @values = defined CGI::param($field) ? CGI::param($field) : CGI::url_param($field); $self->utf8_decode($_) for grep defined, @values; $self->{$field} = @values > 1 ? \@values : $values[0]; } return wantarray ? @values : defined $values[0] ? $values[0] : ''; } sub _get_upload { my $handle = CGI::upload($_[0]) or return; {handle => $handle, filename => $handle, %{CGI::uploadInfo($handle) || {}}}; } sub _utf8_filter { # This is left in for backwards compatibility } sub _trim_filter { $_[0] =~ s/^\s*(.*?)\s*$/$1/mg; $_[0] =~ s/\s+/ /g; } sub _newlines_filter { if (length $_[0]) { $_[0] =~ s/\015\012/\n/g; $_[0] =~ s/\015/\n/g; $_[0] .= "\n" unless $_[0] =~ /\n\z/; } } __END__ =head1 NAME Spoon::CGI - Spoon CGI Base Class =head1 SYNOPSIS =head1 DESCRIPTION =head1 AUTHOR Brian Ingerson =head1 COPYRIGHT Copyright (c) 2004. Brian Ingerson. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut Spoon-0.24/lib/Spoon/Command.pm0000644000076500007650000000366710474067450016310 0ustar ingyingy00000000000000package Spoon::Command; use Spoon::Base -Base; field quiet => 0; sub process { no warnings 'once'; local *boolean_arguments = sub { qw( -q -quiet ) }; my ($args, @values) = $self->parse_arguments(@_); $self->quiet(1) if $args->{-q} || $args->{-quiet}; my $action = $self->get_action(shift(@values)) || sub { $self->default_action(@_) }; $action->(@values); return $self; } sub get_action { my $action = shift or return; $action =~ s/^-// or return; my $method = "handle_$action"; return sub { $self->$method(@_); } if $self->can($method); my $array = $self->hub->registry->lookup->{command}{$action} or return; my $class_id = shift @$array; my $object = $self->hub->$class_id; return sub { $object->$method(@_); }; } sub default_action { $self->usage; } sub command_usage { my $pattern = shift; my $lookup = $self->hub->registry->lookup; my $commands = $lookup->{command} || {}; my %descriptions = map { my $array = $commands->{$_}; shift @$array; my %hash = @$array; my $description = $hash{description} || ''; ($_, $description); } keys %$commands; my $usage = ''; for my $plugin (@{$lookup->plugins}) { my $class_id = $plugin->{id}; for my $command (@{$lookup->add_order->{$class_id}{command}}) { $usage .= sprintf($pattern, $command, $descriptions{$command}); } } return $usage; } sub msg { warn @_ unless $self->quiet; } __DATA__ =head1 NAME Spoon::Command - Spoon Command Line Tool Module =head1 SYNOPSIS =head1 DESCRIPTION =head1 AUTHOR Brian Ingerson =head1 COPYRIGHT Copyright (c) 2004. Brian Ingerson. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut Spoon-0.24/lib/Spoon/Config.pm0000644000076500007650000000542410474067450016130 0ustar ingyingy00000000000000package Spoon::Config; use Spoon::Base -Base; const class_id => 'config'; sub all { return %$self; } sub default_configs { return } sub new() { my $class = shift; my $self = bless {}, $class; my (@configs) = map { /\*/ ? (sort glob) : ($_) } @_ ? @_ : $self->default_configs; $self->add_config($self->default_config, 1); for my $config (@configs) { $self->rebless($self->add_config($config)); } $self->init; return $self; } sub add_field { my ($field, $default) = @_; field $field => $default; } sub add_config { my $config = shift; my $hash = ref $config ? $config : $self->hash_from_file($config); for my $key (keys %$hash) { field $key; $self->{$key} = $hash->{$key}; } return $hash; } sub rebless { my $hash = shift; if (defined (my $config_class = $hash->{config_class})) { eval qq{ require $config_class }; die $@ if $@; bless $self, $config_class; } } sub hash_from_file { my $config = shift; die "Invalid name for config file '$config'\n" unless $config =~ /\.(\w+)$/; my $extension = lc("$1"); # quotes fix 5.8.0 perl bug my $method = "parse_${extension}_file"; -f $config ? $self->$method($config) : {}; } sub parse_file { $self->parse_yaml_file(@_); } sub parse_yaml_file { my $file = shift; $self->parse_yaml(io($file)->utf8->all); } sub parse_yaml { my $yaml = shift; my $hash = {}; my $latest_key = ''; for (split /\n/, $yaml) { next if (/^#/); if (/^-\s*(.*)$/) { $hash->{$latest_key} = [] unless ref $hash->{$latest_key}; push @{$hash->{$latest_key}}, $1; } elsif (/(.*?)\s*:\s+(.*?)\s*$/ or /(.*?):()\s*$/) { $hash->{$1} = $2; $latest_key = $1; } } return $hash; } sub default_config { +{ $self->default_classes, plugin_classes => [$self->default_plugin_classes], } } sub default_classes { ( cgi_class => 'Spoon::CGI', config_class => 'Spoon::Config', formatter_class => 'Spoon::Formatter', headers_class => 'Spoon::Headers', hooks_class => 'Spoon::Hooks', hub_class => 'Spoon::Hub', main_class => 'Spoon', registry_class => 'Spoon::Registry', template_class => 'Spoon::Template', ) } sub default_plugin_classes { () } __END__ =head1 NAME Spoon::Config - Spoon Configuration Base Class =head1 SYNOPSIS =head1 DESCRIPTION =head1 AUTHOR Brian Ingerson =head1 COPYRIGHT Copyright (c) 2004. Brian Ingerson. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut Spoon-0.24/lib/Spoon/ContentObject.pm0000644000076500007650000000437510474067450017470 0ustar ingyingy00000000000000package Spoon::ContentObject; use Spoon::DataObject -Base; stub 'content'; stub 'metadata'; const is_readable => 1; const is_writable => 1; sub force { if (@_) { $self->{force} = shift; return $self; } $self->{force} ||= 0; } sub database_directory { join '/', $self->hub->config->database_directory, $self->class_id; } sub file_path { join '/', $self->database_directory, $self->id; } sub exists { -e $self->file_path; } sub deleted { -z $self->file_path; } sub active { return $self->exists && not $self->deleted; } sub assert_readable { if (not $self->is_readable) { my $id = $self->id; die "$id is not readable"; } } sub assert_writable { if (not $self->is_writable) { my $id = $self->id; die "$id is not writable"; } } sub load { $self->load_content; $self->load_metadata; return $self; } sub load_content { $self->assert_readable; my $content = $self->active ? io($self->file_path)->utf8->all : ''; $self->content($content); return $self; } sub load_metadata { my $metadata = $self->{metadata} or die "No metadata object in content object"; $metadata->load; return $self; } sub store { $self->assert_writable; $self->store_content or return; $self->store_metadata; return if $self->force; return $self; } sub store_content { my $content = $self->content; if ($content) { $content =~ s/\r//g; $content =~ s/\n*\z/\n/; } my $file = io->file($self->file_path)->utf8; unless ($self->force) { return if $file->exists and $content eq $file->all; } $file->print($content); return $self; } sub store_metadata { my $metadata = $self->{metadata} or die "No metadata for content object"; $metadata->store; return $self; } __DATA__ =head1 NAME Spoon::ContentObject - Spoon Content Object Base Class =head1 SYNOPSIS =head1 DESCRIPTION =head1 AUTHOR Brian Ingerson =head1 COPYRIGHT Copyright (c) 2004. Brian Ingerson. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut Spoon-0.24/lib/Spoon/Cookie.pm0000644000076500007650000000335110474067450016131 0ustar ingyingy00000000000000package Spoon::Cookie; use Spoon::Base -Base; use CGI; field 'preferences'; field 'jar' => {}; field 'jar_opt' => {}; const expires => '+5y'; const path => '/'; const prefix => 'Spoon-'; const domain => ''; sub init { $self->fetch(); } sub write { my ($cookie_name, $hash, $opt) = @_; require Storable; $self->jar->{$cookie_name} = $hash; $self->jar_opt->{$cookie_name} = $opt if $opt; } sub read { my $cookie_name = shift; my $jar = $self->jar; my $cookie = $jar->{$cookie_name}; $cookie ||= {}; return $cookie; } sub set_cookie_headers { my $jar = $self->jar; return () unless keys %$jar; my $cookies = []; @$cookies = map { CGI::cookie( -name => $self->prefix . $_, -value => Storable::freeze($jar->{$_} || {}), -path => $self->path, -expires => $self->expires, -domain => $self->domain, %{$self->jar_opt->{$_} || {}}, ); } keys %$jar; return @$cookies ? (-cookie => $cookies) : (); } sub fetch { require Storable; my $prefix = $self->prefix; my $jar = { map { (my $key = $_) =~ s/^\Q$prefix\E//; my $object = eval { Storable::thaw(CGI::cookie($_)) }; $@ ? () : ($key => $object) } grep { /^\Q$prefix\E/ } CGI::cookie() }; $self->jar($jar); } __END__ =head1 NAME Spoon::Cookie - Spoon Cookie Base Class =head1 SYNOPSIS =head1 DESCRIPTION =head1 AUTHOR Brian Ingerson =head1 COPYRIGHT Copyright (c) 2004. Brian Ingerson. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut Spoon-0.24/lib/Spoon/DataObject.pm0000644000076500007650000000116210474067450016716 0ustar ingyingy00000000000000package Spoon::DataObject; use Spoon::Base -Base; stub 'class_id'; field 'id'; sub name { $self->{name} = shift if @_; return $self->{name} if defined $self->name; $self->{name} = $self->uri_unescape($self->id); } __DATA__ =head1 NAME Spoon::DataObject - Spoon Data Object Base Class =head1 SYNOPSIS =head1 DESCRIPTION =head1 AUTHOR Brian Ingerson =head1 COPYRIGHT Copyright (c) 2004. Brian Ingerson. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut Spoon-0.24/lib/Spoon/Formatter.pm0000644000076500007650000002370110474067450016664 0ustar ingyingy00000000000000package Spoon::Formatter; use Spoon::Base -Base; const class_id => 'formatter'; stub 'top_class'; sub new { $self = super; $self->hub; return $self; } sub text_to_html { $self->text_to_parsed(@_)->to_html; } sub text_to_parsed { $self->top_class->new(text => shift)->parse; } sub table { $self->{table} ||= $self->create_table } sub create_table { my $class_prefix = $self->class_prefix; my %table = map { my $class = /::/ ? $_ : "$class_prefix$_"; $class->can('formatter_id') ? ($class->formatter_id, $class) : (); } $self->formatter_classes; \ %table; } sub wafl_table { $self->{wafl_table} ||= $self->create_wafl_table } sub create_wafl_table { my $class_prefix = $self->class_prefix; my %table = map { my $class = /::/ ? $_ : "$class_prefix$_"; $class->can('wafl_id') ? ($class->wafl_id, $class) : (); } $self->wafl_classes; $self->add_external_wafl(\ %table); \ %table; } sub add_external_wafl { return unless $self->hub->registry_loaded; my $table = shift; my $map = $self->hub->registry->lookup->wafl; for my $wafl_id (keys %$map) { $table->{$wafl_id} = $map->{$wafl_id}; } } sub wafl_classes { () } package Spoon::Formatter::Unit; use Spoon::Base -Base; use Scalar::Util qw(weaken); const formatter_id => ''; const html_start => ''; const html_end => ''; const contains_blocks => []; const contains_phrases => []; # stub 'pattern_start'; # XXX messes multiple inheritance const pattern_end => qr/.*?/; field text => ''; field units => []; field start_offset => 0; field start_end_offset => 0; # XXX this field is never used #field end_start_offset => 0; field end_offset => 0; field matched => ''; field -weak => 'next_unit'; field -weak => 'prev_unit'; sub parse { $self->parse_blocks; my $units = $self->units; if (@$units == 1 and not ref $units->[0] and @{$self->contains_phrases}) { $self->text(shift @$units); $self->start_offset(0); $self->end_offset(0); $self->parse_phrases; } return $self; } sub link_units { my $units = shift; for (my $i = 0; $i < @$units; $i++) { next unless ref $units->[$i]; $units->[$i]->next_unit($units->[$i + 1]); $units->[$i]->prev_unit($units->[$i - 1]) if $i; } } # XXX extracted to allow performance analysis # very similar to match_phrase_format_id, so # room for refactor there # # Instead of calling $unit->match make it # possible to call $class->match and have it # work sub match_block_format_id { my ($contains, $table, $text) = @_; my $match; for my $format_id (@$contains) { my $class = $table->{$format_id} or die "No class for $format_id"; my $unit = $class->new; $unit->text($text); $unit->match or next; $match = $unit if not defined $match or $unit->start_offset < $match->start_offset; last unless $match->start_offset; } return $match; } sub parse_blocks { my $text = $self->text; $self->text(undef); my $units = $self->units; my $table = $self->hub->formatter->table; my $contains = $self->contains_blocks; while ($text) { my $match = $self->match_block_format_id($contains, $table, $text); if (not defined $match) { push @$units, $text; last; } push @$units, substr($text, 0, $match->start_offset) if $match->start_offset; $text = substr($text, $match->end_offset); $match->unit_match; push @$units, $match; } $self->link_units($units); $_->parse for grep ref($_), @{$self->units}; } sub match { return unless $self->text =~ $self->pattern_block; $self->set_match; } # XXX extracted to allow performance analysis # very similar to match_block_format_id, so # room for refactor sub match_phrase_format_id { my ($contains, $table, $text) = @_; my $match; for my $format_id (@$contains) { my $class = $table->{$format_id} or die "No class for $format_id"; # XXX why do we make a new one every time, instead of # just setting text and doing the match? Ah, tests # show they carry some state. oh well my $unit = $class->new; $unit->text($text); $unit->match_phrase or next; $match = $unit if not defined $match or $unit->start_offset < $match->start_offset; last if $match->start_offset == 0; } return $match; } sub parse_phrases { my $text = $self->text; $self->text(undef); my $units = $self->units; my $table = $self->hub->formatter->table; my $contains = $self->contains_phrases; while ($text) { my $match = $self->match_phrase_format_id($contains, $table, $text); if ($self->start_end_offset) { if ($text =~ $self->pattern_end) { if (not defined $match or $-[0] < $match->start_offset) { push @$units, substr($text, 0, $-[0]); return substr($text, $+[0]); } } else { $self->end_offset(length $text); push @$units, $text; return ''; } } if (not defined $match) { push @$units, $text; return ''; } # XXX: this code is never called (as far as we know...) # if ($match->end_start_offset) { # push @$units, $match; # $text = substr($text, $match->end_offset); # next; # } push @$units, substr($text, 0, $match->start_offset) if $match->start_offset; $text = substr($text, $match->start_end_offset); $match->text($text); $text = $match->parse_phrases; $match->unit_match; push @$units, $match; } } # empty for hooking sub unit_match { } sub match_phrase { return unless $self->text =~ $self->pattern_start; $self->start_offset($-[0]); $self->start_end_offset($+[0]); $self->matched(substr($self->text, $-[0], $+[0] - $-[0])); my $pattern_end = $self->pattern_end or return 1; return substr($self->text, $+[0]) =~ $pattern_end; } sub set_match { my ($text, $start, $end) = @_; $text = $1 unless defined $text; $text = '' unless defined $text; $start = $-[0] unless defined $start; $end = $+[0] unless defined $end; $self->text($text); $self->start_offset($start); $self->end_offset($end); return 1; } sub to_html { my $units = $self->units; for (my $i = 0; $i < @$units; $i ++) { $units->[$i] = $self->escape_html($units->[$i]) unless ref $units->[$i]; } $self->html; } sub html { my $inner = $self->text_filter(join '', map { ref($_) ? $_->to_html : $_; } @{$self->units} ); $self->html_start . $inner . $self->html_end; } sub text_filter { shift } sub escape_html { $self->html_escape(shift) } ################################################################################ package Spoon::Formatter::Container; use base 'Spoon::Formatter::Unit'; sub contains_blocks { $self->hub->formatter->all_blocks; } ################################################################################ package Spoon::Formatter::Block; use base 'Spoon::Formatter::Unit'; sub contains_phrases { $self->hub->formatter->all_phrases; } ################################################################################ package Spoon::Formatter::Phrase; use base 'Spoon::Formatter::Unit'; sub contains_phrases { my $id = $self->formatter_id; [ grep {$_ ne $id} @{$self->hub->formatter->all_phrases} ]; } ################################################################################ package Spoon::Formatter::Wafl; use Spoon::Base -base; const contains_phrases => []; sub bless_wafl_class { my $package = caller; my $class = $self->hub->formatter->wafl_table->{$self->method}; if (ref $class) { my $class_id; ($class_id, $class) = @$class; $self->hub->load_class($class_id); } bless $self, $class if defined $class and $class->isa($package); return 1; } ################################################################################ package Spoon::Formatter::WaflBlock; use base 'Spoon::Formatter::Wafl'; use base 'Spoon::Formatter::Block'; const formatter_id => 'wafl_block'; const html_end => "\n"; field 'method'; field 'arguments'; sub html_start { '
'; } sub match { return unless $self->text =~ /(?:^\.([\w\-]+)\ *\n)((?:.*\n)*?)(?:^\.\1\ *\n|\z)/m; $self->set_match($2); my $method = lc $1; $method =~ s/-/_/g; $self->method($method); $self->matched($2); $self->bless_wafl_class; } sub block_text { $self->units->[0]; } ################################################################################ package Spoon::Formatter::WaflPhrase; use base 'Spoon::Formatter::Wafl'; use base 'Spoon::Formatter::Unit'; const formatter_id => 'wafl_phrase'; const pattern_start => qr/(^|(?<=[\s\-]))\{[\w-]+(\s*:)?\s*.*?\}(?=[^A-Za-z0-9]|\z)/; field 'method'; field 'arguments'; sub html_start { '' . $self->arguments . ''; } sub match_phrase { return unless super; return unless $self->matched =~ /^\{([\w\-]+)(?:\s*\:)?\s*(.*)\}$/; $self->arguments($2); my $method = lc $1; $method =~ s/-/_/g; $self->method($method); $self->bless_wafl_class; } sub wafl_error { join '', '{', $self->method, ': ', $self->arguments, '}'; } __END__ =head1 NAME Spoon::Formatter - Spoon Formatter Base Class =head1 SYNOPSIS =head1 DESCRIPTION =head1 AUTHOR Brian Ingerson =head1 COPYRIGHT Copyright (c) 2004. Brian Ingerson. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut Spoon-0.24/lib/Spoon/Headers.pm0000644000076500007650000000236110474067450016273 0ustar ingyingy00000000000000package Spoon::Headers; use Spoon::Base -Base; field content_type => 'text/html'; field charset => 'UTF-8'; field expires => 'now'; field pragma => 'no-cache'; field cache_control => 'no-cache'; field redirect => ''; sub print { my $headers = $self->get; $self->utf8_encode($headers); print $headers; } sub get { $self->redirect ? CGI::redirect($self->redirect_value) : CGI::header($self->value); } sub redirect_value { ( $self->hub->cookie->set_cookie_headers, -location => $self->redirect, ); } sub value { ( $self->hub->cookie->set_cookie_headers, -charset => $self->charset, -type => $self->content_type, -expires => $self->expires, -pragma => $self->pragma, -cache_control => $self->cache_control, -last_modified => $self->last_modified, ); } sub last_modified { scalar gmtime; } Spoon-0.24/lib/Spoon/Hooks.pm0000644000076500007650000000670710474067450016013 0ustar ingyingy00000000000000package Spoon::Hooks; use Spoon::Base -Base; const hook_class => 'Spoon::Hook'; const hooked_class => 'Spoon::Hooked'; sub add { my ($target, %hooks) = @_; my $original = $self->assert_method($target); my $pre = $self->assert_method($hooks{pre}); my $post = $self->assert_method($hooks{post}); my $replacement = $self->new_hook_sub($original, $pre, $post); my $hook_point = $self->get_full_name($target); no warnings 'redefine'; no strict 'refs'; *$hook_point = $replacement; return $self->hooked_class->new( hook_point => $hook_point, original => $original, replacement => $replacement, ); } sub new_hook_sub { my ($original, $pre, $post) = @_; sub { my $hook = $self->hook_class->new( code => $original, pre => $pre, post => $post, ); $hook->returned([$hook->pre->(@_, $hook)]) if $pre; my $code = $hook->code or return $hook->returned; my $new_args = $hook->new_args; @_ = @$new_args if $new_args; $hook->returned([&$code(@_)]); return $hook->post->(@_, $hook) if $hook->post; return $hook->returned; } } sub assert_method { return shift if not defined($_[0]) or ref($_[0]); my $full_name = $self->get_full_name(shift); my ($package, $method) = ($full_name) =~ /(.*)::(.*)/ or die "Can't hook invalid fully qualified method name: '$full_name'"; unless ($package->can('new')) { eval "require $package"; undef($@); die "Can't hook $full_name. Can't find package '$package'" unless $package->can('new'); } my $sub = $full_name; return \&$sub if defined &$sub; no strict 'refs'; *$sub = eval <SUPER::$method(\@_); }; END return \&$sub; } sub get_full_name { my $name = shift; return $name if $name =~ /::/; if ($name =~ /(.*):(.*)/) { my ($class_id, $method) = ($1, $2); my $package = $self->hub->registry->lookup->classes->{$class_id}; return $package . '::' . $method; } return ''; } package Spoon::Hooked; use Spoon::Base -Base; field 'hook_point'; field 'original'; field 'replacement'; sub unhook { my ($hook_point, $original, $replacement) = @{$self}{qw(hook_point original replacement)}; %$self = (); return unless defined $hook_point; no strict 'refs'; my $current = *$hook_point{CODE}; die "Unhooking error for $hook_point" unless "$current" eq "$replacement"; no warnings; *$hook_point = $original; return 1; } sub DESTROY { $self->unhook; } package Spoon::Hook; use Spoon::Base -Base; field 'code'; field 'pre'; field 'post'; field 'new_args'; sub returned { $self->{returned} = shift if @_; $self->{returned} ||= []; wantarray ? (@{$self->{returned}}) : $self->{returned}[0]; } sub returned_true { @{$self->{returned}} && $self->{returned}[0] && 1; } sub cancel { $self->code(undef); return (); } __END__ =head1 NAME Spoon::Hook - Spoon Method Hooking Facility =head1 SYNOPSIS =head1 DESCRIPTION =head1 AUTHOR Brian Ingerson =head1 COPYRIGHT Copyright (c) 2004. Brian Ingerson. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut Spoon-0.24/lib/Spoon/Hub.pm0000644000076500007650000000652210474067450015441 0ustar ingyingy00000000000000package Spoon::Hub; use Spoon::Base -Base; const class_id => 'hub'; field action => '_default_'; field main => -weak; field config_files => []; field all_hooks => []; sub new { $self = super; $self->init; $Spoon::Base::HUB = $self; } our $AUTOLOAD; sub AUTOLOAD { $AUTOLOAD =~ /.*::(.*)/ or die "Can't AUTOLOAD '$AUTOLOAD'"; my $class_id = $1; return if $class_id eq 'DESTROY'; field $class_id => -init => "\$self->load_class('$class_id')"; $self->$class_id(@_); } sub pre_process {} sub post_process {} sub process { $self->preload; my $action = $self->action; die "No plugin for action '$action'" unless defined $self->registry->lookup->action->{$action}; my ($class_id, $method) = @{$self->registry->lookup->action->{$action}}; $method ||= $action; return $self->$class_id->$method; } sub preload { my $preload = $self->registry->lookup->preload; map { $self->load_class($_->[0]) } sort { $b->[1] <=> $a->[1] } map { my %hash = @{$preload->{$_}}[1..$#{$preload->{$_}}]; [$_, $hash{priority} || 0]; } keys %$preload; return $self; } sub load_class { my $class_id = shift; return $self if $class_id eq 'hub'; return $self->$class_id if $self->can($class_id) and defined $self->{$class_id}; my $class_class = $class_id . '_class'; my $class_name = $self->config->can($class_class) ? $self->config->$class_class : $self->registry_loaded ? $self->registry->lookup->classes->{$class_id} : Carp::confess "Can't find a class for class_id '$class_id'"; Carp::confess "No class defined for class_id '$class_id'" unless $class_name; unless ($class_name->can('new')) { eval "require $class_name"; die $@ if $@; } $self->add_hooks unless $class_id eq 'hooks'; my $object = $class_name->new or die "Can't create new '$class_name' object"; $class_id ||= $object->class_id; die "No class_id defined for class: '$class_name'\n" unless $class_id; field $class_id => -init => "\$self->load_class('$class_id')"; $self->$class_id($object); $object->init; return $object; } sub add_hooks { return unless $self->registry_loaded; my $hooks = $self->registry->lookup->{hook} or return; for my $class_name (keys %$hooks) { next unless $class_name->can('new'); $self->add_hook(@$_) for @{$hooks->{$class_name} || []}; delete $hooks->{$class_name}; } delete $self->registry->lookup->{hook} if not keys %$hooks; } sub add_hook { my $hooks = $self->all_hooks; push @$hooks, $self->hooks->add(@_); return $hooks->[-1]; } sub remove_hooks { my $hooks = $self->all_hooks; while (@$hooks) { pop(@$hooks)->unhook; } } sub registry_loaded { defined $self->{registry} && defined $self->{registry}{lookup}; } sub DESTROY { $self->remove_hooks; } __END__ =head1 NAME Spoon::Hub - Spoon Hub Base Class =head1 SYNOPSIS =head1 DESCRIPTION =head1 AUTHOR Brian Ingerson =head1 COPYRIGHT Copyright (c) 2004. Brian Ingerson. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut Spoon-0.24/lib/Spoon/IndexList.pm0000644000076500007650000000173710474067450016631 0ustar ingyingy00000000000000package Spoon::IndexList; use Spiffy -selfless; use IO::All; use DB_File; sub index_list { my $list = io(shift); my $index = io($list . '.db')->dbm('DB_File')->rdonly; unless ($index->exists) { $index->assert->open; $index->close; } unless ($list->exists) { my $mtime = $index->mtime; $list->print(''); for (sort keys %$index) { $list->print("$_\n"); } $index->close; $list->close; $list->utime($mtime - 1); } if ($list->mtime > $index->mtime) { my %copy = %$index; $index->close; $index->rdonly(0)->rdwr(1)->open; for my $key ($list->chomp->slurp) { $key =~ s/^\s*(.*?)\s*$/$1/; next unless $key; $index->{$key} = 1; delete $copy{$key}; } for my $key (keys %copy) { delete $index->{$key}; } $index->rdonly(1)->rdwr(0)->close; } return $index; } Spoon-0.24/lib/Spoon/Installer.pm0000644000076500007650000001456110474067450016662 0ustar ingyingy00000000000000package Spoon::Installer; use Spiffy -Base; use IO::All; use Spoon::Base -mixin => qw(hub); const extract_to => '.'; field quiet => 0; sub compress_from { $self->extract_to; } sub extract_files { my @files = $self->get_packed_files; while (@files) { my ($file_name, $file_contents) = splice(@files, 0, 2); my $locked = $file_name =~ s/^!//; my $file_path = join '/', $self->extract_to, $file_name; my $file = io->file($file_path)->assert; if ($locked and -f $file_path) { warn " Skipping $file (already exists)\n" unless $self->quiet; next; } my $content = $self->set_file_content($file_path, $file_contents); if ($file->exists and $file->all eq $content) { warn " Skipping $file (unchanged)\n" unless $self->quiet; next; } warn " - $file\n" unless $self->quiet; $file->binary if $self->file_is_binary($file_path); $file->assert->print($content); } } sub set_file_content { my $path = shift; my $content = shift; $content = $self->base64_decode($content) if $self->file_is_binary($path); $content = $self->fix_hashbang($content) if $self->file_is_executable($path); $content = $self->wrap_html($content, $path) if $self->file_is_html($path); return $content; } sub file_is_binary { my $path = shift; $path =~ /\.(gif|jpg|png)$/; } sub file_is_executable { my $path = shift; $path =~ /\.(pl|cgi)$/; } sub file_is_html { my $path = shift; $path =~ /\.html$/; } sub fix_hashbang { require Config; my $content = shift; $content =~ s/^#!.*\n/$Config::Config{startperl} -w\n/; return $content; } sub wrap_html { my ($content, $path) = @_; $path =~ s/^.*\/(.*)$/$1/; $path =~ s/\.html$//; $content = $self->strip_html($content); $content = "\n$content" unless $content =~ /^\s/; $content = "$content\n" unless $content =~ /\s\n\z/; return $content; } sub get_packed_files { my %seen; my @return; for my $class (@{Spiffy::all_my_bases(ref $self)}) { next if $class =~ /-/; last if $class =~ /^Spoon/; my $data = $self->data($class) or next; my @files = split /^__(.+)__\n/m, $data; shift @files; while (@files) { my ($name, $content) = splice(@files, 0, 2); $name = $self->resolve_install_path($name) if $self->can('resolve_install_path'); my $name2 = $name; $name2 =~ s/^\!//; next if $seen{$name2}++; $content ||= ''; push @return, $name, $content if length $content; } } return @return; } sub get_local_packed_files { my @return; my $class = ref $self; my $data = $self->data($class) or return; my @files = split /^__(.+)__\n/m, $data; shift @files; while (@files) { my ($name, $content) = splice(@files, 0, 2); $name = $self->resolve_install_path($name) if $self->can('resolve_install_path'); push @return, $name, $content; } return @return; } sub data { my $package = shift || ref($self); local $SIG{__WARN__} = sub {}; local $/; eval "package $package; "; } sub compress_files { require File::Spec; my $source_dir = shift; my $new_pack = ''; my @files = $self->get_local_packed_files; my $first_file = $files[0] or return; my $directory = $self->compress_from; while (@files) { my ($file_name, $file_contents) = splice(@files, 0, 2); my $locked = $file_name =~ s/^!// ? '!' : ''; my $source_path = File::Spec->canonpath("$source_dir/$directory/$file_name"); die "$file_name does not exist as $source_path" unless -f $source_path; my $content = $locked ? $file_contents : $self->get_file_content($source_path); $content =~ s/\r\n/\n/g; $content =~ s/\r/\n/g; $new_pack .= "__$locked${file_name}__\n$content"; } my $module = ref($self) . '.pm'; $module =~ s/::/\//g; my $module_path = $INC{$module} or die; my $module_text = io($module_path)->all; my ($module_code) = split /^__\Q$first_file\E__\n/m, $module_text; ($module_code . $new_pack) > io($module_path); } sub get_file_content { my $path = shift; my $content = io($path)->all; $content = $self->base64_encode($content) if $self->file_is_binary($path); $content = $self->unfix_hashbang($content) if $self->file_is_executable($path); $content = $self->strip_html($content) if $self->file_is_html($path); $content .= "\n" unless $content =~ /\n\z/; return $content; } sub unfix_hashbang { my $content = shift; $content =~ s/^#!.*\n/#!\/usr\/bin\/perl\n/; return $content; } sub strip_html { my $content = shift; $content =~ s/^\n//; $content =~ s/(?<=\n)\n\z//; return $content; } sub compress_lib { die "Must be run from the module source code directory\n" unless -d 'lib' and -f 'Makefile.PL'; unshift @INC,'lib'; my $source_dir = shift or die "No source directory specified\n"; die "Invalid source directory '$source_dir'\n" unless -d $source_dir; map { my $class_name = $_; my $class_id = $class_name->class_id; $self->hub->config->add_config( +{ "${class_id}_class" => $class_name } ); warn "Compressing $class_name\n" unless $self->quiet; $self->hub->$class_id->compress_files($source_dir); } grep { my $name = $_; eval "require $name"; die $@ if $@; UNIVERSAL::can($name, 'compress_files') and $name !~ /::(Installer)$/; } map { my $name = $_->name; ($name =~ s/^lib\/(.*)\.pm$/$1/) ? do { $name =~ s/\//::/g; $name; } : (); } io('lib')->All_Files; } __END__ =head1 NAME Spoon::Installer - Spoon Installer Class =head1 SYNOPSIS =head1 DESCRIPTION =head1 AUTHOR Brian Ingerson =head1 COPYRIGHT Copyright (c) 2004. Brian Ingerson. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut Spoon-0.24/lib/Spoon/MetadataObject.pm0000644000076500007650000000223410474067450017566 0ustar ingyingy00000000000000package Spoon::MetadataObject; use Spoon::DataObject -Base; const class_id => 'metadata'; sub parse_yaml_file { $self->hub->config->parse_yaml_file(shift); } sub print_yaml_file { my $file = shift; my $hash = shift; my $yaml = ''; for my $key ($self->sort_order) { my $value = $hash->{$key}; $value = '' unless defined $value; $yaml .= "$key: $value\n"; } $yaml =~ s/\s+(?=\n)//g; io($file)->utf8->print($yaml); return $self; } sub from_hash { my $hash = shift; exists $hash->{$_} and $self->$_($hash->{$_}) for $self->sort_order; return $self; } sub to_hash { my $hash = {}; $hash->{$_} = $self->$_ for $self->sort_order; return $hash; } sub update { return $self; } __DATA__ =head1 NAME Spoon::MetadataObject - Spoon Metadata Object Base Class =head1 SYNOPSIS =head1 DESCRIPTION =head1 AUTHOR Brian Ingerson =head1 COPYRIGHT Copyright (c) 2004. Brian Ingerson. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut Spoon-0.24/lib/Spoon/Plugin.pm0000644000076500007650000000147510474067450016163 0ustar ingyingy00000000000000package Spoon::Plugin; use Spoon::Base -Base; sub class_title_prefix { () } sub class_id { my $package = ref $self; $package =~ s/.*:://; lc($package); } sub class_title { join ' ', map { s/(.*)/\u$1/; $_; } $self->class_title_prefix, split '_', $self->class_id; } sub register { $self->hub->registry->add(action => $self->class_id, 'process') if $self->can('process'); return $self; } __END__ =head1 NAME Spoon::Plugin - Spoon Plugin Base Class =head1 SYNOPSIS =head1 DESCRIPTION =head1 AUTHOR Brian Ingerson =head1 COPYRIGHT Copyright (c) 2004. Brian Ingerson. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut Spoon-0.24/lib/Spoon/Registry.pm0000644000076500007650000001126110474067450016527 0ustar ingyingy00000000000000package Spoon::Registry; use Spoon::Base -Base; const class_id => 'registry'; const registry_file => 'registry.dd'; const registry_directory => '.'; const lookup_class => 'Spoon::Lookup'; field lookup => -init => '$self->load'; field 'temp_lookup'; field 'current_class_id'; sub registry_path { join '/', $self->registry_directory, $self->registry_file; } sub load { my $path = $self->registry_path; my $lookup; if (-e $path) { $lookup = eval io($path)->all; die "$path seems to be corrupt:\n$@" if $@; } else { $lookup = $self->update->lookup; } $self->lookup(bless $lookup, $self->lookup_class); return $self->lookup; } sub update { my $lookup = {}; $self->temp_lookup($lookup); $self->set_core_classes; for my $class_name (@{$self->hub->config->plugin_classes}) { my $object = $self->load_class($class_name); $self->not_a_plugin($class_name) unless $object->can('register'); my $class_id = $self->$set_class_info($object); $self->current_class_id($class_id); $object->register($self); } $self->transform; $self->lookup($self->temp_lookup); return $self; } sub not_a_plugin { my $class_name = shift; die "$class_name is not a plugin\n"; } sub load_class { my $class_name = shift; eval "require $class_name"; die $@ if $@; $class_name->new; } sub set_core_classes { my %all = $self->hub->config->all; my $hub = $self->hub; for my $key (keys %all) { next unless $key =~ /(.*)_class$/; my $class_id = $1; my $class_name = $all{$key}; $self->temp_lookup->{classes}{$class_id} = $class_name; my $object = $hub->can($class_id) && $hub->$class_id || $self->load_class($class_name); $self->add_classes($object); } } my sub set_class_info { my $object = shift; my $lookup = $self->temp_lookup; my $class_name = ref $object; my $class_id = $object->class_id or die "No class_id for $class_name\n"; if (my $prev_name = $lookup->{classes}{$class_id}) { $self->plugin_redefined($class_id, $class_name, $prev_name); } $lookup->{classes}{$class_id} = $class_name; $self->add_classes($object); push @{$lookup->{plugins}}, { id => $class_id, title => $object->class_title, }; return $class_id; } sub add_classes { my $object = shift; return unless $object->can('inline_classes'); my $classes = $self->temp_lookup->{classes}; for my $class_name (@{$object->inline_classes}) { my $object = $class_name->new; $classes->{$object->class_id} = $class_name; } } sub plugin_redefined {} sub add { my $class_id = $self->current_class_id; my $key = shift; if ($key eq 'hook') { push @{$self->temp_lookup->{$key}}, [$class_id, @_]; } else { my $value = shift; $self->temp_lookup->{$key}{$value} = [ $class_id, @_ ]; push @{$self->temp_lookup->{add_order}{$class_id}{$key}}, $value; } } sub write { $self->dumper_to_file($self->registry_path, $self->lookup); } sub transform { $self->transform_hook; } sub transform_hook { my $lookup = $self->temp_lookup; return unless defined $lookup->{hook}; my @hooks = @{$lookup->{hook}}; my $new_hooks = {}; for my $hook (@hooks) { my ($class_id, $target, %args) = @$hook; my $class_name = $lookup->{classes}{$class_id}; my ($target_class_id, $target_method) = $target =~ /^(\w+):(\w+)$/; my $target_class_name = $lookup->{classes}{$target_class_id}; die "Invalid hook '$target' in class '$class_id'\n" unless $target_class_id and $target_class_name and ($args{pre} or $args{post}); push @{$new_hooks->{$target_class_name}}, [ $target_class_name . '::' .$target_method, map { my $method = $args{$_}; ($_, $class_name . '::' . $method); } (keys %args), ]; } $self->temp_lookup->{hook} = $new_hooks; } package Spoon::Lookup; use Spiffy -base; # XXX consider an AUTOLOAD here. field action => {}; field add_order => {}; field classes => {}; field plugins => []; field preference => {}; field preload => {}; field wafl => {}; __END__ =head1 NAME Spoon::Registry - Spoon Registry Base Class =head1 SYNOPSIS =head1 DESCRIPTION =head1 AUTHOR Brian Ingerson =head1 COPYRIGHT Copyright (c) 2004. Brian Ingerson. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut Spoon-0.24/lib/Spoon/Template/0000755000076500007650000000000010536643153016132 5ustar ingyingy00000000000000Spoon-0.24/lib/Spoon/Template/TT2.pm0000644000076500007650000000222710474067450017105 0ustar ingyingy00000000000000package Spoon::Template::TT2; use Spoon::Template -Base; field template_object => -init => '$self->create_template_object'; sub compile_dir { my $dir = $self->plugin_directory . '/ttc'; mkdir $dir unless -d $dir; return $dir; } sub create_template_object { require Template; # XXX Make template caching a configurable option Template->new({ INCLUDE_PATH => $self->path, TOLERANT => 0, COMPILE_DIR => $self->compile_dir, COMPILE_EXT => '.ttc', }); } sub render { my $template = shift; my $output; my $t = $self->template_object; eval { $t->process($template, {@_}, \$output) or die $t->error; }; die "Template Toolkit error:\n$@" if $@; return $output; } __DATA__ =head1 NAME Spoon::Template::TT2 - Spoon Template Toolkit Base Class =head1 SYNOPSIS =head1 DESCRIPTION =head1 AUTHOR Brian Ingerson =head1 COPYRIGHT Copyright (c) 2004. Brian Ingerson. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut Spoon-0.24/lib/Spoon/Template.pm0000644000076500007650000000254610474067450016500 0ustar ingyingy00000000000000package Spoon::Template; use Spoon::Base -Base; use Template; const class_id => 'template'; const template_path => [ './template' ]; field path => []; stub 'render'; field config => -init => '$self->hub->config'; field cgi => -init => '$self->hub->cgi'; sub init { $self->add_path(@{$self->template_path}); } sub all { return ( $self->config->all, $self->is_in_cgi ? ($self->cgi->all) : (), hub => $self->hub, ); } sub add_path { for (reverse @_) { $self->remove_path($_); unshift @{$self->path}, $_; } } sub append_path { for (@_) { $self->remove_path($_); push @{$self->path}, $_; } } sub remove_path { my $path = shift; $self->path([grep {$_ ne $path} @{$self->path}]); } sub process { my $template = shift; my @templates = (ref $template eq 'ARRAY') ? @$template : $template; return join '', map { $self->render($_, $self->all, @_) } @templates; } __END__ =head1 NAME Spoon::Template - Spoon Template Base Class =head1 SYNOPSIS =head1 DESCRIPTION =head1 AUTHOR Brian Ingerson =head1 COPYRIGHT Copyright (c) 2004. Brian Ingerson. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut Spoon-0.24/lib/Spoon/Trace.pm0000644000076500007650000000320710474067450015756 0ustar ingyingy00000000000000package Spoon::Trace; use Spiffy -Base; use Time::HiRes qw(gettimeofday); my $global_self; field data => []; field show_num => 1; field show_time => 1; field auto_print => 0; field auto_warn => 0; field add_label => 0; sub mode1 { $self->show_num(0); $self->show_time(0); $self->add_label(1); return $self; } sub trace() { $global_self = defined $global_self ? $global_self : Spoon::Trace->new; } sub mark { my $label = @_ ? join(' ', @_) . ($self->add_label && "\t(" . $self->get_label . ')') : $self->get_label; my $data = $self->data; my ($seconds, $microseconds) = gettimeofday; push @$data, +{ label => $label, time => $seconds + $microseconds / 1000000, }; return $self; } sub get_label { my $i = (caller(2))[3] eq 'Spoon::Base::t' ? 1 : 0; my $line = (caller(1 + $i))[2]; my $sub = (caller(2 + $i))[3]; return "$sub,$line"; } sub clear { $global_self = undef; $self->data([]); return $self; } sub report { my $data = $self->data; my $output = ''; return $output unless @$data; my $base_time = $data->[0]{time}; for (my $i = 0; $i < @$data; $i++) { if ($self->show_num) { $output .= sprintf "%03d) ", $i + 1; } if ($self->show_time) { $output .= sprintf "%2.4f %2.2f ", $i ? $data->[$i]{time} - $data->[$i - 1]{time} : 0, $data->[$i]{time} - $base_time; } $output .= $data->[$i]{label} . "\n"; } return $output; } sub DESTROY { print $self->report if $self->auto_print; warn $self->report if $self->auto_warn; } Spoon-0.24/lib/Spoon/Utils.pm0000644000076500007650000000161310474067450016017 0ustar ingyingy00000000000000package Spoon::Utils; use Spiffy -Base; const directory_perms => 0755; sub assert_filepath { my $filepath = shift; return unless $filepath =~ s/(.*)[\/\\].*/$1/; return if -e $filepath; $self->assert_directory($filepath); } sub assert_directory { my $directory = shift; require File::Path; umask 0000; File::Path::mkpath($directory, 0, $self->directory_perms); } sub remove_tree { my $directory = shift; require File::Path; umask 0000; File::Path::rmtree($directory); } __END__ =head1 NAME Spoon::Utils - Spoon Utilities Class =head1 SYNOPSIS =head1 DESCRIPTION =head1 AUTHOR Brian Ingerson =head1 COPYRIGHT Copyright (c) 2004. Brian Ingerson. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut Spoon-0.24/lib/Spoon.pm0000644000076500007650000000300510536642412014710 0ustar ingyingy00000000000000package Spoon; use Spoon::Base -Base; our $VERSION = '0.24'; const class_id => 'main'; sub load_hub { $self->destroy_hub; my $hub = $self->hub(@_); $hub->main($self); $self->init; return $hub; } __END__ =head1 NAME Spoon - A Spiffy Application Building Framework =head1 SYNOPSIS Out of the Cutlery Drawer And onto the Dinner Table =head1 DESCRIPTION Spoon is an Application Framework that is designed primarily for building Social Software web applications. The Kwiki wiki software is built on top of Spoon. Spoon::Base is the primary base class for all the Spoon::* modules. Spoon.pm inherits from Spiffy.pm. Spoon is not an application in and of itself. (As compared to Kwiki) You need to build your own applications from it. =head1 SEE ALSO Kwiki, Spork, Spiffy, IO::All =head1 DEDICATION This project is dedicated to the memory of Iain "Spoon" Truskett. =head1 CREDIT Dave Rolsky and Chris Dent have made major contributions to this code base. Of particular note, Dave removed the memory cycles from the hub architecture, allowing safe use with mod_perl. (Dave, Chris and myself currently work at Socialtext, where this framework is heavily used.) =head1 AUTHOR Ingy döt Net =head1 COPYRIGHT Copyright (c) 2004. Brian Ingerson. All rights reserved. Copyright (c) 2006. Ingy döt Net. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut Spoon-0.24/Makefile.PL0000644000076500007650000000050310536643006014460 0ustar ingyingy00000000000000use inc::Module::Install; require File::Spec; name 'Spoon'; all_from 'lib/Spoon.pm'; requires(qw( perl 5.6.1 Spiffy 0.22 IO::All 0.32 Template 2.10 Time::HiRes 0 URI 0 DB_File 0 )); clean_files( File::Spec->catdir(qw(t tmp)), File::Spec->catdir(qw(t output)), ); WriteAll; Spoon-0.24/MANIFEST0000644000076500007650000000170110474067450013644 0ustar ingyingy00000000000000Changes 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/Spoon.pm lib/Spoon/Base.pm lib/Spoon/CGI.pm lib/Spoon/Command.pm lib/Spoon/Config.pm lib/Spoon/ContentObject.pm lib/Spoon/Cookie.pm lib/Spoon/DataObject.pm lib/Spoon/Formatter.pm lib/Spoon/Headers.pm lib/Spoon/Hooks.pm lib/Spoon/Hub.pm lib/Spoon/IndexList.pm lib/Spoon/Installer.pm lib/Spoon/MetadataObject.pm lib/Spoon/Plugin.pm lib/Spoon/Registry.pm lib/Spoon/Template.pm lib/Spoon/Template/TT2.pm lib/Spoon/Trace.pm lib/Spoon/Utils.pm Makefile.PL MANIFEST This list of files META.yml README t/cgi.t t/compile.t t/content/test1 t/content/test2 t/Cookie.t t/cycle.t t/data_inherit.t t/formatter-wafl.t t/Formatter.pm t/hook.t t/html_wrap.t t/load.t t/TestA.pm t/TestB.pm t/TestC.pm t/TestHook.pm t/utf8-content.t t/utf8.t Spoon-0.24/META.yml0000644000076500007650000000053710536643011013762 0ustar ingyingy00000000000000abstract: A Spiffy Application Building Framework author: 'Ingy döt Net ' distribution_type: module generated_by: Module::Install version 0.64 license: perl name: Spoon no_index: directory: - inc - t requires: DB_File: 0 IO::All: 0.32 Spiffy: 0.22 Template: 2.10 Time::HiRes: 0 URI: 0 perl: 5.6.1 version: 0.24 Spoon-0.24/README0000644000076500007650000000247110536642446013403 0ustar ingyingy00000000000000NAME Spoon - A Spiffy Application Building Framework SYNOPSIS Out of the Cutlery Drawer And onto the Dinner Table DESCRIPTION Spoon is an Application Framework that is designed primarily for building Social Software web applications. The Kwiki wiki software is built on top of Spoon. Spoon::Base is the primary base class for all the Spoon::* modules. Spoon.pm inherits from Spiffy.pm. Spoon is not an application in and of itself. (As compared to Kwiki) You need to build your own applications from it. SEE ALSO Kwiki, Spork, Spiffy, IO::All DEDICATION This project is dedicated to the memory of Iain "Spoon" Truskett. CREDIT Dave Rolsky and Chris Dent have made major contributions to this code base. Of particular note, Dave removed the memory cycles from the hub architecture, allowing safe use with mod_perl. (Dave, Chris and myself currently work at Socialtext, where this framework is heavily used.) AUTHOR Ingy döt Net COPYRIGHT Copyright (c) 2004. Brian Ingerson. All rights reserved. Copyright (c) 2006. Ingy döt Net. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html Spoon-0.24/t/0000755000076500007650000000000010536643153012756 5ustar ingyingy00000000000000Spoon-0.24/t/cgi.t0000644000076500007650000000405410477052414013706 0ustar ingyingy00000000000000use lib 't', 'lib'; use strict; use warnings; use Test::More; eval "use Encode"; my $enc = ! $@; use Spoon::CGI; use URI::Escape; plan tests => 10; { package Test1; use Spoon::CGI -base; cgi 'param1'; cgi 'param2' => '-utf8'; cgi 'trimmed' => '-trim'; cgi 'nl' => '-newlines'; } $ENV{REQUEST_METHOD} = 'GET'; { $ENV{QUERY_STRING} = "param1=2;foo=bar"; my $test1 = Test1->new; SKIP: { skip "Encode not installed", 1 unless($enc); ok( Encode::is_utf8($test1->param1), 'param1 is marked as utf8' ); } is( $test1->param1, 2, 'param1 value is 2' ); } { CGI->_reset_globals; $ENV{QUERY_STRING} = 'param1=%E1%9A%A0%E1%9B%87%E1%9A%BB;foo=bar'; my $test1 = Test1->new; SKIP: { skip "Encode not installed", 1 unless($enc); ok( Encode::is_utf8($test1->param1), 'param1 is marked as utf8' ); } is( $test1->param1, "\x{16A0}\x{16C7}\x{16BB}", 'param1 value is \x{16A0}\x{16C7}\x{16BB}' ); } { CGI->_reset_globals; $ENV{QUERY_STRING} = 'param2=%E1%9A%A0%E1%9B%87%E1%9A%BB;foo=bar'; my $test1 = Test1->new; SKIP: { skip "Encode not installed", 1 unless($enc); ok( Encode::is_utf8($test1->param2), 'param2 is marked as utf8' ); } is( $test1->param2, "\x{16A0}\x{16C7}\x{16BB}", 'param2 value is \x{16A0}\x{16C7}\x{16BB}' ); } { CGI->_reset_globals; $ENV{QUERY_STRING} = 'trimmed=%20%20trim%20me%20%20;foo=bar'; my $test1 = Test1->new; SKIP: { skip "Encode not installed", 1 unless($enc); ok( Encode::is_utf8($test1->trimmed), 'trimmed is marked as utf8' ); } is( $test1->trimmed, "trim me", 'trimmed value is "trim me"' ); } { CGI->_reset_globals; $ENV{QUERY_STRING} = 'nl=line1%0d%0aline2%0dline3;foo=bar'; my $test1 = Test1->new; SKIP: { skip "Encode not installed", 1 unless($enc); ok( Encode::is_utf8($test1->nl), 'nl is marked as utf8' ); } is( $test1->nl, "line1\nline2\nline3\n", 'nl only contains unix newlines' ); } Spoon-0.24/t/compile.t0000644000076500007650000000107010477052413014566 0ustar ingyingy00000000000000use lib 't', 'lib'; use strict; use warnings; use Test::More 'no_plan'; use IO::All; use File::Spec; for (grep {! /CVS/ && ! /(?:~|\.swp)$/ && ! /.svn/} io('lib')->All_Files) { my $name = $_->name; my ($vol, $path, $file) = File::Spec->splitpath($name); my @dirs = File::Spec->splitdir($path); shift @dirs if $dirs[0] eq 'lib'; pop @dirs while @dirs and (not defined $dirs[-1] or $dirs[-1] =~ /^\s*$/); $file =~ s/\.pm$//; push @dirs, $file; $name = join('::', @dirs); eval "require $name; 1"; is($@, '', "Compile $name"); } Spoon-0.24/t/content/0000755000076500007650000000000010536643153014430 5ustar ingyingy00000000000000Spoon-0.24/t/content/test10000644000076500007650000000003510474067450015412 0ustar ingyingy00000000000000This file has no utf8 in it. Spoon-0.24/t/content/test20000644000076500007650000000004610474067450015415 0ustar ingyingy00000000000000This file has utf8 in it - ᚠᛇᚻ. Spoon-0.24/t/Cookie.t0000644000076500007650000000062210474067450014355 0ustar ingyingy00000000000000use strict; use Test::More tests => 2; use Spoon::Cookie; my $cookie = Spoon::Cookie->new; $cookie->write("foo", { bar => "baz" }); my @cookies = $cookie->set_cookie_headers; like $cookies[1]->[0]->as_string, qr/foo=/; $cookie->write("foo", { bar => "baz" }, { -domain => "www.example.com" }); @cookies = $cookie->set_cookie_headers; like $cookies[1]->[0]->as_string, qr/domain=www\.example\.com/; Spoon-0.24/t/cycle.t0000644000076500007650000000234310474067450014245 0ustar ingyingy00000000000000use lib 't', 'lib'; use strict; use warnings; use Test::More; BEGIN { eval "use Test::Memory::Cycle"; if ($@) { plan skip_all => 'These tests require Test::Memory::Cycle'; } else { plan tests => 13; } } use Spoon; { my $spoon = Spoon->new; my $hub = $spoon->load_hub; memory_cycle_ok($spoon, 'check for cycles in Spoon object'); memory_cycle_ok($hub, 'check for cycles in Spoon::Hub object'); } { my $spoon = Spoon->new; { my $hub = $spoon->load_hub; } ok($spoon->hub, 'Hub does not get destroyed before main goes out of scope'); } { my %classes = (cgi_class => 'Spoon::CGI', headers_class => 'Spoon::Headers', cookie_class => 'Spoon::Cookie', formatter_class => 'Spoon::Formatter', template_class => 'Spoon::Template::TT2', ); my $spoon = Spoon->new; my $hub = $spoon->load_hub(\%classes); foreach my $key (keys %classes) { (my $id = $key) =~ s/_class$//; my $object = $hub->$id; memory_cycle_ok($hub, 'check for cycles in Spoon::Hub object'); memory_cycle_ok($object, "check for cycles in $classes{$key} object"); } } Spoon-0.24/t/data_inherit.t0000644000076500007650000000067310474067450015605 0ustar ingyingy00000000000000use lib 'lib', 't'; use warnings; use strict; use Test::More tests => 6; use IO::All; io->dir('t/output')->rmtree; require TestB; my $test = TestB->new; no strict 'refs'; $test->quiet(1); $test->extract_files(1); ok(io('t/output/file1')->exists); ok(io('t/output/file2')->exists); ok(io('t/output/file3')->exists); is(io('t/output/file1')->all, "TestA\n"); is(io('t/output/file2')->all, "TestB\n"); is(io('t/output/file3')->all, "TestB\n"); Spoon-0.24/t/formatter-wafl.t0000644000076500007650000000261010474067450016075 0ustar ingyingy00000000000000use lib 't', 'lib'; use strict; use warnings; use Spoon; use Test::More tests => 6; use Formatter; my $hub = Spoon->new->load_hub( { formatter_class => 'Test::Formatter', } ); my $formatter = $hub->formatter; { my $html = $formatter->text_to_html(<<'EOF'); {phrase1: testing} EOF like( $html, qr{testing}, 'Basic WAFL phrase formatting' ); } { my $html = $formatter->text_to_html(<<'EOF'); {Phrase1: testing} EOF like( $html, qr{testing}, 'Basic WAFL phrase formatting - case insensitive' ); } { my $html = $formatter->text_to_html(<<'EOF'); .block1 block contents .block1 EOF like( $html, qr{
\s*block contents\s*
}s, 'Basic WAFL block formatting' ); } { my $html = $formatter->text_to_html(<<'EOF'); .blOCK1 block contents .blOCK1 EOF like( $html, qr{
\s*block contents\s*
}s, 'Basic WAFL block formatting - case insensitive' ); } { my $html = $formatter->text_to_html(<<'EOF'); {underline_name: testing} EOF like( $html, qr{testing}s, 'underline in wafl name' ); } { my $html = $formatter->text_to_html(<<'EOF'); {underline-name: testing} EOF like( $html, qr{testing}s, 'dash in wafl name' ); } Spoon-0.24/t/Formatter.pm0000644000076500007650000000114410474067450015260 0ustar ingyingy00000000000000################################################################################ package Test::Formatter; use Spoon::Formatter -Base; const top_class => 'Test::Formatter::Top'; const class_prefix => 'Test::Formatter::'; const all_blocks => [qw(wafl_block)]; const all_phrases => [qw(wafl_phrase)]; sub formatter_classes { qw(Spoon::Formatter::WaflBlock Spoon::Formatter::WaflPhrase) } ################################################################################ package Test::Formatter::Top; use base 'Spoon::Formatter::Container'; const formatter_id => 'top'; const contains_phrases => [qw(wafl_phrase)]; Spoon-0.24/t/hook.t0000644000076500007650000000216510474067450014110 0ustar ingyingy00000000000000use lib 't', 'lib'; use strict; use warnings; use Test::More tests => 11; use Spoon; Spoon->debug; my %classes = ( test_class => 'TestHook', ); { my $hub = Spoon->new->load_hub(\%classes); is($hub->test->number, 42); $hub->add_hook('test:number' => post => sub { 43 }); is($hub->test->number, 43); my $h1 = $hub->add_hook('test:number' => post => sub { 44 }); is($hub->test->number, 44); $h1->unhook; is($hub->test->number, 43); } { my $hub = Spoon->new->load_hub(\%classes); is($hub->test->number, 42); my $h1 = $hub->add_hook('test:number' => post => 'test:other'); is($hub->test->number, 45); my $h2 = $hub->add_hook('test:number' => pre => 'Tweak::two'); is($hub->test->number, 48); $h2->unhook; my $h3 = $hub->add_hook('test:number' => pre => 'Tweak::one'); is($hub->test->number, 45); my $h4 = $hub->add_hook('test:number' => post => 'Tweak::one'); is($hub->test->number, 47); $h4->unhook; $h3->unhook; is($hub->test->number, 45); } { my $main = Spoon->new; my $hub = $main->load_hub(\%classes); is($hub->test->number, 42); } Spoon-0.24/t/html_wrap.t0000644000076500007650000000145010474067450015141 0ustar ingyingy00000000000000use lib 'lib', 't'; use warnings; use strict; use Test::More tests => 10; use IO::All; io->dir('t/output')->rmtree; require TestC; my $test = TestC->new; no strict 'refs'; $test->quiet(1); $test->extract_files(1); ok(io('t/output/file1.html')->exists); ok(io('t/output/file2.html')->exists); ok(io('t/output/file3.html')->exists); ok(io('t/output/file4.html')->exists); ok(io('t/output/file5.html')->exists); is(io('t/output/file1.html')->all, "\n
\n\n" ); is(io('t/output/file2.html')->all, "\n
\n\n" ); is(io('t/output/file3.html')->all, "
\n\n" ); is(io('t/output/file4.html')->all, "\n
\n" ); is(io('t/output/file5.html')->all, "
\n\n" ); Spoon-0.24/t/load.t0000644000076500007650000000061310474067450014063 0ustar ingyingy00000000000000use lib 't', 'lib'; use strict; use warnings; BEGIN { $^W = 1 } use Test::More 'no_plan'; ok(eval {require Spoon; 1}); my $spoon = Spoon->new; my $hub; ok($hub = $spoon->load_hub); $hub = $spoon->hub; ok($hub); ok($hub->config); my %config = $hub->config->all; my @classes = grep { s/_class$// and not /^registry$/; } keys %config; for my $class (@classes) { ok($hub->$class); } Spoon-0.24/t/TestA.pm0000644000076500007650000000017610474067450014341 0ustar ingyingy00000000000000package TestA; use Spoon '-Base'; use Spoon::Installer '-mixin'; __DATA__ __t/output/file1__ TestA __t/output/file2__ TestA Spoon-0.24/t/TestB.pm0000644000076500007650000000013710474067450014337 0ustar ingyingy00000000000000package TestB; use TestA '-Base'; __DATA__ __t/output/file2__ TestB __t/output/file3__ TestB Spoon-0.24/t/TestC.pm0000644000076500007650000000041110474067450014333 0ustar ingyingy00000000000000package TestC; use Spoon '-Base'; use Spoon::Installer '-mixin'; __DATA__ __t/output/file1.html__
__t/output/file2.html__
__t/output/file3.html__
__t/output/file4.html__
__t/output/file5.html__
Spoon-0.24/t/TestHook.pm0000644000076500007650000000037310474067450015060 0ustar ingyingy00000000000000package TestHook; use Spoon::Base -Base; sub number { 42; } sub other { 45; } package TestHookA; use base 'Spoon::Base'; sub one { 47; } package Tweak; use base 'TestHookA'; sub two { my $hook = pop; $hook->cancel; 48; } Spoon-0.24/t/utf8-content.t0000644000076500007650000000371510477052414015505 0ustar ingyingy00000000000000use lib 't', 'lib'; use strict; use warnings; use Test::More; eval "use Encode"; my $enc = ! $@; use Spoon::ContentObject; plan tests => 8; my $database_directory; { no warnings; package Spoon::ContentObject; sub database_directory { $database_directory } undef &Spoon::ContentObject::content; field 'content'; } { $database_directory = 't/content'; my $object = Spoon::ContentObject->new(id => 'test1'); $object->load_content; SKIP: { skip "Encode not installed", 1 unless($enc); ok( Encode::is_utf8( $object->content ), 'object content is utf8' ); } is( $object->content, "This file has no utf8 in it.\n", 'test content was loaded' ); io->dir('t/tmp')->mkpath; $database_directory = 't/tmp'; $object->force(1); $object->store_content; $object->load_content; SKIP: { skip "Encode not installed", 1 unless($enc); ok( Encode::is_utf8( $object->content ), 'object content is utf8 after save/load' ); } is( $object->content, "This file has no utf8 in it.\n", 'test content was loaded after save/load' ); } { $database_directory = 't/content'; my $object = Spoon::ContentObject->new(id => 'test2'); $object->load_content; SKIP: { skip "Encode not installed", 1 unless($enc); ok( Encode::is_utf8( $object->content ), 'object content is utf8' ); } is( $object->content, "This file has utf8 in it - \x{16A0}\x{16C7}\x{16BB}.\n", 'test content was loaded' ); io->dir('t/tmp')->mkpath; $database_directory = 't/tmp'; $object->force(1); $object->store_content; $object->load_content; SKIP: { skip "Encode not installed", 1 unless($enc); ok( Encode::is_utf8( $object->content ), 'object content is utf8 after save/load' ); } is( $object->content, "This file has utf8 in it - \x{16A0}\x{16C7}\x{16BB}.\n", 'test content was loaded after save/load' ); } Spoon-0.24/t/utf8.t0000644000076500007650000000107410477052413014030 0ustar ingyingy00000000000000use lib 't', 'lib'; use strict; use warnings; use Test::More; eval "use Encode"; if($@) { plan skip_all => "Encode not installed."; } use Spoon::Base; plan tests => 5; my $data = "\xE1\x9A\xA0\xE1\x9B\x87\xE1\x9A\xBB"; ok( ! Encode::is_utf8($data), 'data is not marked as UTF8' ); is( length $data, 9, 'undecoded data is 9 chars long' ); Spoon::Base->utf8_decode($data); ok( Encode::is_utf8($data), 'data is marked as UTF8' ); is( length $data, 3, 'decoded data is 3 chars long' ); is( $data, "\x{16A0}\x{16C7}\x{16BB}", 'check string content after decoding' );