diff --git a/.gitignore b/.gitignore index ecf66f8..1f576a8 100644 --- a/.gitignore +++ b/.gitignore @@ -1,35 +1,11 @@ -!Build/ -.last_cover_stats -/META.yml -/META.json -/MYMETA.* -*.o -*.pm.tdy -*.bs - -# Devel::Cover -cover_db/ - -# Devel::NYTProf -nytprof.out - -# Dizt::Zilla -/.build/ - -# Module::Build -_build/ -Build -Build.bat - -# Module::Install -inc/ - -# ExtUtils::MakeMaker -/blib/ -/_eumm/ -/*.gz -/Makefile -/Makefile.old -/MANIFEST.bak -/pm_to_blib -/*.zip +config +logs/ +logs +*.log +config/log4perl.conf +lib/Custom/ +test_Script +uploads/finished/ +uploads/ +.*.log.LCK +lib/Conf.pm diff --git a/bin/app.psgi b/bin/app.psgi new file mode 100644 index 0000000..5566723 --- /dev/null +++ b/bin/app.psgi @@ -0,0 +1,46 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use lib '/developer_dashboard/cpanlib'; +use lib '/developer_dashboard/lib'; +use File::FindLib 'lib'; +use File::FindLib 'cpanlib'; +# use this block if you don't need middleware, and only have a single target Dancer app to run here +use developerdashboard; + + +developerdashboard->to_app; + +=begin comment +# use this block if you want to include middleware such as Plack::Middleware::Deflater + +use developerdashboard; +use Plack::Builder; + +builder { + enable 'Deflater'; + developerdashboard->to_app; +} + +=end comment + +=cut + +=begin comment +# use this block if you want to mount several applications on different path + +use developerdashboard; +use developerdashboard_admin; + +use Plack::Builder; + +builder { + mount '/' => developerdashboard->to_app; + mount '/admin' => developerdashboard_admin->to_app; +} + +=end comment + +=cut + diff --git a/bin/config.yml b/bin/config.yml new file mode 100644 index 0000000..08cd164 --- /dev/null +++ b/bin/config.yml @@ -0,0 +1,21 @@ +--- +environment : production +appname: developerdashboard +charset: UTF-8 +engines: + session: + YAML: + cookie_name: eshop.session + is_http_only: 1 + is_secure: 1 + JSON: + allow_blessed: '1' + canonical: '1' + convert_blessed: '1' + allow_nonref: '1' +layout: main +port: 6776 +template: template_toolkit +logger: file +log_path : '/home/ubuntu/test_dancer/logs' +log_file : 'Applog.log' diff --git a/config.yaml b/config.yaml new file mode 100644 index 0000000..e80e137 --- /dev/null +++ b/config.yaml @@ -0,0 +1,10 @@ +--- +environment : production +appname: developerdashboard +charset: UTF-8 +template: template_toolkit +engines: + session: + Simple: + cookie_name: dashboard.user + cookie_duration: '1 hours' diff --git a/config/log4perl.conf b/config/log4perl.conf new file mode 100644 index 0000000..3a57dd3 --- /dev/null +++ b/config/log4perl.conf @@ -0,0 +1,23 @@ +log4perl.category.dashboardlog = ALL, Logfile +log4perl.appender.Logfile = Log::Dispatch::FileRotate + +log4perl.appender.Logfile.Threshold = ALL +log4perl.appender.Logfile.filename = /developer-dashboard-for-jira/developerdashboard.log +log4perl.appender.Logfile.max = 50 +log4perl.appender.Logfile.DatePattern = yyyy-MM-dd +log4perl.appender.Logfile.TZ = UTC +log4perl.appender.Logfile.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.Logfile.layout.ConversionPattern = [%d] [%P] [%F] [%L] [%C] [%5p] %m%n +log4perl.appender.Logfile.mode = append + +log4perl.category.dblog = ALL, DBlogs + +log4perl.appender.DBlogs = Log::Dispatch::FileRotate +log4perl.appender.DBlogs.Threshold = ALL +log4perl.appender.DBlogs.filename = /developer-dashboard-for-jira/logs/DB.log +log4perl.appender.DBlogs.max = 50 +log4perl.appender.DBlogs.DatePattern = yyyy-MM-dd +log4perl.appender.DBlogs.TZ = UTC +log4perl.appender.DBlogs.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.DBlogs.layout.ConversionPattern = [%d] [%P] [%F] [%L] [%C] [%5p] %m%n +log4perl.appender.DBlogs.mode = append diff --git a/cpanlib/B/Hooks/EndOfScope.pm b/cpanlib/B/Hooks/EndOfScope.pm new file mode 100644 index 0000000..d5de63f --- /dev/null +++ b/cpanlib/B/Hooks/EndOfScope.pm @@ -0,0 +1,177 @@ +package B::Hooks::EndOfScope; # git description: 0.23-2-ga391106 +# ABSTRACT: Execute code after a scope finished compilation +# KEYWORDS: code hooks execution scope + +use strict; +use warnings; + +our $VERSION = '0.24'; + +use 5.006001; + +BEGIN { + use Module::Implementation 0.05; + Module::Implementation::build_loader_sub( + implementations => [ 'XS', 'PP' ], + symbols => [ 'on_scope_end' ], + )->(); +} + +use Sub::Exporter::Progressive 0.001006 -setup => { + exports => [ 'on_scope_end' ], + groups => { default => ['on_scope_end'] }, +}; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +B::Hooks::EndOfScope - Execute code after a scope finished compilation + +=head1 VERSION + +version 0.24 + +=head1 SYNOPSIS + + on_scope_end { ... }; + +=head1 DESCRIPTION + +This module allows you to execute code when perl finished compiling the +surrounding scope. + +=head1 FUNCTIONS + +=head2 on_scope_end + + on_scope_end { ... }; + + on_scope_end $code; + +Registers C<$code> to be executed after the surrounding scope has been +compiled. + +This is exported by default. See L on how to customize it. + +=head1 LIMITATIONS + +=head2 Pure-perl mode caveat + +This caveat applies to B version of perl where L +is unavailable or otherwise disabled. + +While L has access to some very dark sorcery to make it +possible to throw an exception from within a callback, the pure-perl +implementation does not have access to these hacks. Therefore, what +would have been a B is instead B, and your execution will continue as if the exception never +happened. + +To explicitly request an XS (or PP) implementation one has two choices. Either +to import from the desired implementation explicitly: + + use B::Hooks::EndOfScope::XS + or + use B::Hooks::EndOfScope::PP + +or by setting C<$ENV{B_HOOKS_ENDOFSCOPE_IMPLEMENTATION}> to either C or +C. + +=head2 Perl 5.8.0 ~ 5.8.3 + +Due to a L present in +older perl versions, the implementation of B::Hooks::EndOfScope deliberately +leaks a single empty hash for every scope being cleaned. This is done to +avoid the memory corruption associated with the bug mentioned above. + +In order to stabilize this workaround use of L is disabled +on perls prior to version 5.8.4. On such systems loading/requesting +L explicitly will result in a compile-time +exception. + +=head2 Perl versions 5.6.x + +Versions of perl before 5.8.0 lack a feature allowing changing the visibility +of C<%^H> via setting bit 17 within C<$^H>. As such the only way to achieve +the effect necessary for this module to work, is to use the C operator +explicitly on these platforms. This might lead to unexpected interference +with other scope-driven libraries relying on the same mechanism. On the flip +side there are no such known incompatibilities at the time this note was +written. + +For further details on the unavailable behavior please refer to the test +file F included with the distribution. + +=head1 SEE ALSO + +L + +L + +=head1 SUPPORT + +Bugs may be submitted through L +(or L). + +=head1 AUTHORS + +=over 4 + +=item * + +Florian Ragwitz + +=item * + +Peter Rabbitson + +=back + +=head1 CONTRIBUTORS + +=for stopwords Karen Etheridge Tatsuhiko Miyagawa Christian Walde Tomas Doran Graham Knop Simon Wilper + +=over 4 + +=item * + +Karen Etheridge + +=item * + +Tatsuhiko Miyagawa + +=item * + +Christian Walde + +=item * + +Tomas Doran + +=item * + +Graham Knop + +=item * + +Simon Wilper + +=back + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2008 by Florian Ragwitz. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/B/Hooks/EndOfScope/PP.pm b/cpanlib/B/Hooks/EndOfScope/PP.pm new file mode 100644 index 0000000..8afa453 --- /dev/null +++ b/cpanlib/B/Hooks/EndOfScope/PP.pm @@ -0,0 +1,110 @@ +package B::Hooks::EndOfScope::PP; +# ABSTRACT: Execute code after a scope finished compilation - PP implementation + +use warnings; +use strict; + +our $VERSION = '0.24'; + +use constant _PERL_VERSION => "$]"; + +BEGIN { + if (_PERL_VERSION =~ /^5\.009/) { + # CBA to figure out where %^H got broken and which H::U::HH is sane enough + die "By design B::Hooks::EndOfScope does not operate in pure-perl mode on perl 5.9.X\n" + } + elsif (_PERL_VERSION < '5.010') { + require B::Hooks::EndOfScope::PP::HintHash; + *on_scope_end = \&B::Hooks::EndOfScope::PP::HintHash::on_scope_end; + } + else { + require B::Hooks::EndOfScope::PP::FieldHash; + *on_scope_end = \&B::Hooks::EndOfScope::PP::FieldHash::on_scope_end; + } +} + +use Sub::Exporter::Progressive 0.001006 -setup => { + exports => ['on_scope_end'], + groups => { default => ['on_scope_end'] }, +}; + +sub __invoke_callback { + local $@; + eval { $_[0]->(); 1 } or do { + my $err = $@; + require Carp; + Carp::cluck( (join ' ', + 'A scope-end callback raised an exception, which can not be propagated when', + 'B::Hooks::EndOfScope operates in pure-perl mode. Your program will CONTINUE', + 'EXECUTION AS IF NOTHING HAPPENED AFTER THIS WARNING. Below is the complete', + 'exception text, followed by a stack-trace of the callback execution:', + ) . "\n\n$err\n\r" ); + + sleep 1 if -t *STDERR; # maybe a bad idea...? + }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +B::Hooks::EndOfScope::PP - Execute code after a scope finished compilation - PP implementation + +=head1 VERSION + +version 0.24 + +=head1 DESCRIPTION + +This is the pure-perl implementation of L based only on +modules available as part of the perl core. Its leaner sibling +L will be automatically preferred if all +dependencies are available and C<$ENV{B_HOOKS_ENDOFSCOPE_IMPLEMENTATION}> is +not set to C<'PP'>. + +=head1 FUNCTIONS + +=head2 on_scope_end + + on_scope_end { ... }; + + on_scope_end $code; + +Registers C<$code> to be executed after the surrounding scope has been +compiled. + +This is exported by default. See L on how to customize it. + +=head1 SUPPORT + +Bugs may be submitted through L +(or L). + +=head1 AUTHORS + +=over 4 + +=item * + +Florian Ragwitz + +=item * + +Peter Rabbitson + +=back + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2008 by Florian Ragwitz. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/B/Hooks/EndOfScope/PP/FieldHash.pm b/cpanlib/B/Hooks/EndOfScope/PP/FieldHash.pm new file mode 100644 index 0000000..11aa962 --- /dev/null +++ b/cpanlib/B/Hooks/EndOfScope/PP/FieldHash.pm @@ -0,0 +1,45 @@ +# Implementation of a pure-perl on_scope_end for perls > 5.10 +# (relies on Hash::Util:FieldHash) + +package # hide from pause + B::Hooks::EndOfScope::PP::FieldHash; + +use strict; +use warnings; + +our $VERSION = '0.24'; + +use Tie::Hash (); +use Hash::Util::FieldHash 'fieldhash'; + +# Here we rely on a combination of several behaviors: +# +# * %^H is deallocated on scope exit, so any references to it disappear +# * A lost weakref in a fieldhash causes the corresponding key to be deleted +# * Deletion of a key on a tied hash triggers DELETE +# +# Therefore the DELETE of a tied fieldhash containing a %^H reference will +# be the hook to fire all our callbacks. + +fieldhash my %hh; +{ + package # hide from pause too + B::Hooks::EndOfScope::PP::_TieHintHashFieldHash; + our @ISA = ( 'Tie::StdHash' ); # in Tie::Hash, in core + sub DELETE { + my $ret = shift->SUPER::DELETE(@_); + B::Hooks::EndOfScope::PP::__invoke_callback($_) for @$ret; + $ret; + } +} + +sub on_scope_end (&) { + $^H |= 0x020000; + + tie(%hh, 'B::Hooks::EndOfScope::PP::_TieHintHashFieldHash') + unless tied %hh; + + push @{ $hh{\%^H} ||= [] }, $_[0]; +} + +1; diff --git a/cpanlib/B/Hooks/EndOfScope/PP/HintHash.pm b/cpanlib/B/Hooks/EndOfScope/PP/HintHash.pm new file mode 100644 index 0000000..ae17950 --- /dev/null +++ b/cpanlib/B/Hooks/EndOfScope/PP/HintHash.pm @@ -0,0 +1,94 @@ +# Implementation of a pure-perl on_scope_end for perls < 5.10 +# (relies on lack of compile/runtime duality of %^H before 5.10 +# which makes guard object operation possible) + +package # hide from the pauses + B::Hooks::EndOfScope::PP::HintHash; + +use strict; +use warnings; + +our $VERSION = '0.24'; + +use Scalar::Util (); +use constant _NEEDS_MEMORY_CORRUPTION_FIXUP => ( + "$]" >= 5.008 + and + "$]" < 5.008004 +) ? 1 : 0; + + +use constant _PERL_VERSION => "$]"; + +# This is the original implementation, which sadly is broken +# on perl 5.10+ within string evals +sub on_scope_end (&) { + + # the scope-implicit %^H localization is a 5.8+ feature + $^H |= 0x020000 + if _PERL_VERSION >= 5.008; + + # the explicit localization of %^H works on anything < 5.10 + # but we use it only on 5.6 where fiddling $^H has no effect + local %^H = %^H + if _PERL_VERSION < 5.008; + + # Workaround for memory corruption during implicit $^H-induced + # localization of %^H on 5.8.0~5.8.3, see extended comment below + bless \%^H, 'B::Hooks::EndOfScope::PP::HintHash::__GraveyardTransport' if ( + _NEEDS_MEMORY_CORRUPTION_FIXUP + and + ref \%^H eq 'HASH' # only bless if it is a "pure hash" to start with + ); + + # localised %^H behaves funny on 5.8 - a + # 'local %^H;' + # is in effect the same as + # 'local %^H = %^H;' + # therefore make sure we use different keys so that things do not + # fire too early due to hashkey overwrite + push @{ + $^H{sprintf '__B_H_EOS__guardstack_0X%x', Scalar::Util::refaddr(\%^H) } + ||= bless ([], 'B::Hooks::EndOfScope::PP::_SG_STACK') + }, $_[0]; +} + +sub B::Hooks::EndOfScope::PP::_SG_STACK::DESTROY { + B::Hooks::EndOfScope::PP::__invoke_callback($_) for @{$_[0]}; +} + +# This scope implements a clunky yet effective workaround for a core perl bug +# https://rt.perl.org/Public/Bug/Display.html?id=27040#txn-82797 +# +# While we can not prevent the hinthash being marked for destruction twice, +# we *can* intercept the first DESTROY pass, and squirrel away the entire +# structure, until a time it can (hopefully) no longer do any visible harm +# +# There still *will* be corruption by the time we get to free it for real, +# since we can not prevent Perl's erroneous SAVEFREESV mark. What we hope is +# that by then the corruption will no longer matter +# +# Yes, this code does leak by design. Yes it is better than the alternative. +{ + my @Hint_Hash_Graveyard; + + # "Leak" this entire structure: ensures it and its contents will not be + # garbage collected until the very very very end + push @Hint_Hash_Graveyard, \@Hint_Hash_Graveyard + if _NEEDS_MEMORY_CORRUPTION_FIXUP; + + sub B::Hooks::EndOfScope::PP::HintHash::__GraveyardTransport::DESTROY { + + # Resurrect the hinthash being destroyed, persist it into the graveyard + push @Hint_Hash_Graveyard, $_[0]; + + # ensure we won't try to re-resurrect during GlobalDestroy + bless $_[0], 'B::Hooks::EndOfScope::PP::HintHash::__DeactivateGraveyardTransport'; + + # Perform explicit free of elements (if any) triggering all callbacks + # This is what would have happened without this code being active + %{$_[0]} = (); + } +} + +1; diff --git a/cpanlib/B/Hooks/EndOfScope/XS.pm b/cpanlib/B/Hooks/EndOfScope/XS.pm new file mode 100644 index 0000000..1f7e3a0 --- /dev/null +++ b/cpanlib/B/Hooks/EndOfScope/XS.pm @@ -0,0 +1,108 @@ +package B::Hooks::EndOfScope::XS; +# ABSTRACT: Execute code after a scope finished compilation - XS implementation + +use strict; +use warnings; + +our $VERSION = '0.24'; + +# Limit the V::M-based (XS) version to perl 5.8.4+ +# +# Given the unorthodox stuff we do to work around the hinthash double-free +# might as well play it safe and only implement it in the PP version +# and leave it at that +# https://rt.perl.org/Public/Bug/Display.html?id=27040#txn-82797 +# +use 5.008004; + +use Variable::Magic 0.48 (); +use Sub::Exporter::Progressive 0.001006 -setup => { + exports => ['on_scope_end'], + groups => { default => ['on_scope_end'] }, +}; + +my $wiz = Variable::Magic::wizard + data => sub { [$_[1]] }, + free => sub { $_->() for @{ $_[1] }; () }, + # When someone localise %^H, our magic doesn't want to be copied + # down. We want it to be around only for the scope we've initially + # attached ourselves to. Merely having MGf_LOCAL and a noop svt_local + # callback achieves this. If anything wants to attach more magic of our + # kind to a localised %^H, things will continue to just work as we'll be + # attached with a new and empty callback list. + local => \undef +; + +sub on_scope_end (&) { + $^H |= 0x020000; + + if (my $stack = Variable::Magic::getdata %^H, $wiz) { + push @{ $stack }, $_[0]; + } + else { + Variable::Magic::cast %^H, $wiz, $_[0]; + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +B::Hooks::EndOfScope::XS - Execute code after a scope finished compilation - XS implementation + +=head1 VERSION + +version 0.24 + +=head1 DESCRIPTION + +This is the implementation of L based on +L, which is an XS module dependent on a compiler. It will +always be automatically preferred if L is available. + +=head1 FUNCTIONS + +=head2 on_scope_end + + on_scope_end { ... }; + + on_scope_end $code; + +Registers C<$code> to be executed after the surrounding scope has been +compiled. + +This is exported by default. See L on how to customize it. + +=head1 SUPPORT + +Bugs may be submitted through L +(or L). + +=head1 AUTHORS + +=over 4 + +=item * + +Florian Ragwitz + +=item * + +Peter Rabbitson + +=back + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2008 by Florian Ragwitz. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Class/Data/Inheritable.pm b/cpanlib/Class/Data/Inheritable.pm new file mode 100644 index 0000000..396d631 --- /dev/null +++ b/cpanlib/Class/Data/Inheritable.pm @@ -0,0 +1,150 @@ +package Class::Data::Inheritable; + +use strict qw(vars subs); +use vars qw($VERSION); +$VERSION = '0.08'; + +sub mk_classdata { + my ($declaredclass, $attribute, $data) = @_; + + if( ref $declaredclass ) { + require Carp; + Carp::croak("mk_classdata() is a class method, not an object method"); + } + + my $accessor = sub { + my $wantclass = ref($_[0]) || $_[0]; + + return $wantclass->mk_classdata($attribute)->(@_) + if @_>1 && $wantclass ne $declaredclass; + + $data = $_[1] if @_>1; + return $data; + }; + + my $alias = "_${attribute}_accessor"; + *{$declaredclass.'::'.$attribute} = $accessor; + *{$declaredclass.'::'.$alias} = $accessor; +} + +1; + +__END__ + +=head1 NAME + +Class::Data::Inheritable - Inheritable, overridable class data + +=head1 SYNOPSIS + + package Stuff; + use base qw(Class::Data::Inheritable); + + # Set up DataFile as inheritable class data. + Stuff->mk_classdata('DataFile'); + + # Declare the location of the data file for this class. + Stuff->DataFile('/etc/stuff/data'); + + # Or, all in one shot: + Stuff->mk_classdata(DataFile => '/etc/stuff/data'); + +=head1 DESCRIPTION + +Class::Data::Inheritable is for creating accessor/mutators to class +data. That is, if you want to store something about your class as a +whole (instead of about a single object). This data is then inherited +by your subclasses and can be overriden. + +For example: + + Pere::Ubu->mk_classdata('Suitcase'); + +will generate the method Suitcase() in the class Pere::Ubu. + +This new method can be used to get and set a piece of class data. + + Pere::Ubu->Suitcase('Red'); + $suitcase = Pere::Ubu->Suitcase; + +The interesting part happens when a class inherits from Pere::Ubu: + + package Raygun; + use base qw(Pere::Ubu); + + # Raygun's suitcase is Red. + $suitcase = Raygun->Suitcase; + +Raygun inherits its Suitcase class data from Pere::Ubu. + +Inheritance of class data works analogous to method inheritance. As +long as Raygun does not "override" its inherited class data (by using +Suitcase() to set a new value) it will continue to use whatever is set +in Pere::Ubu and inherit further changes: + + # Both Raygun's and Pere::Ubu's suitcases are now Blue + Pere::Ubu->Suitcase('Blue'); + +However, should Raygun decide to set its own Suitcase() it has now +"overridden" Pere::Ubu and is on its own, just like if it had +overriden a method: + + # Raygun has an orange suitcase, Pere::Ubu's is still Blue. + Raygun->Suitcase('Orange'); + +Now that Raygun has overridden Pere::Ubu futher changes by Pere::Ubu +no longer effect Raygun. + + # Raygun still has an orange suitcase, but Pere::Ubu is using Samsonite. + Pere::Ubu->Suitcase('Samsonite'); + +=head1 Methods + +=head2 mk_classdata + + Class->mk_classdata($data_accessor_name); + Class->mk_classdata($data_accessor_name => $value); + +This is a class method used to declare new class data accessors. +A new accessor will be created in the Class using the name from +$data_accessor_name, and optionally initially setting it to the given +value. + +To facilitate overriding, mk_classdata creates an alias to the +accessor, _field_accessor(). So Suitcase() would have an alias +_Suitcase_accessor() that does the exact same thing as Suitcase(). +This is useful if you want to alter the behavior of a single accessor +yet still get the benefits of inheritable class data. For example. + + sub Suitcase { + my($self) = shift; + warn "Fashion tragedy" if @_ and $_[0] eq 'Plaid'; + + $self->_Suitcase_accessor(@_); + } + +=head1 AUTHOR + +Original code by Damian Conway. + +Maintained by Michael G Schwern until September 2005. + +Now maintained by Tony Bowden. + +=head1 BUGS and QUERIES + +Please direct all correspondence regarding this module to: + bug-Class-Data-Inheritable@rt.cpan.org + +=head1 COPYRIGHT and LICENSE + +Copyright (c) 2000-2005, Damian Conway and Michael G Schwern. +All Rights Reserved. + +This module is free software. It may be used, redistributed and/or +modified under the same terms as Perl itself. + +=head1 SEE ALSO + +L has a very elaborate discussion of class data in Perl. + diff --git a/cpanlib/Class/Factory/Util.pm b/cpanlib/Class/Factory/Util.pm new file mode 100644 index 0000000..1bae8d0 --- /dev/null +++ b/cpanlib/Class/Factory/Util.pm @@ -0,0 +1,118 @@ +package Class::Factory::Util; + +use strict; +use vars qw($VERSION); + +use Carp qw(confess); + +$VERSION = '1.7'; + +1; + +sub import +{ + my $caller = caller(0); + + { + no strict 'refs'; + *{"${caller}::subclasses"} = \&_subclasses; + } +} + +# deprecated +sub subclasses { _subclasses(@_) } + +sub _subclasses +{ + my $base = shift; + + $base =~ s,::,/,g; + + my %dirs = map { $_ => 1 } @INC; + + my $dir = substr( $INC{"$base.pm"}, 0, (length $INC{"$base.pm"}) - 3 ); + + $dirs{$dir} = 1; + + my @packages = map { _scandir( "$_/$base" ) } keys %dirs; + + # Make list of unique elements + my %packages = map { $_ => 1 } @packages; + + return sort keys %packages; +} + +sub _scandir +{ + my $dir = shift; + + return unless -d $dir; + + opendir DIR, $dir + or confess ("Cannot open directory $dir: $!"); + + my @packages = + ( map { substr($_, 0, length($_) - 3) } + grep { substr($_, -3) eq '.pm' && -f "$dir/$_" } + readdir DIR + ); + + closedir DIR + or confess("Cannot close directory $dir: $!" ); + + return @packages; +} + +__END__ + +=head1 NAME + +Class::Factory::Util - Provide utility methods for factory classes + +=head1 SYNOPSIS + + package My::Class; + + use Class::Factory::Util; + + My::Class->subclasses; + +=head1 DESCRIPTION + +This module exports a method that is useful for factory classes. + +=head1 USAGE + +When this module is loaded, it creates a method in its caller named +C. This method returns a list of the available +subclasses for the package. It does this by looking in C<@INC> as +well as the directory containing the caller, and finding any modules +in the immediate subdirectories of the calling module. + +So if you have the modules "Foo::Base", "Foo::Base::Bar", and +"Foo::Base::Baz", then the return value of C<< Foo::Base->subclasses() +>> would be "Bar" and "Baz". + +=head1 SUPPORT + +Please submit bugs to the CPAN RT system at +http://rt.cpan.org/NoAuth/ReportBug.html?Queue=class-factory-util or +via email at bug-class-factory-util@rt.cpan.org. + +=head1 AUTHOR + +Dave Rolsky, . + +Removed from Alzabo and packaged by Terrence Brannon, +. + +=head1 COPYRIGHT + +Copyright (c) 2003-2007 David Rolsky. All rights reserved. This +program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +The full text of the license can be found in the LICENSE file included +with this module. + +=cut diff --git a/cpanlib/Class/Inspector.pm b/cpanlib/Class/Inspector.pm new file mode 100644 index 0000000..83bdab7 --- /dev/null +++ b/cpanlib/Class/Inspector.pm @@ -0,0 +1,656 @@ +package Class::Inspector; + +use 5.006; +# We don't want to use strict refs anywhere in this module, since we do a +# lot of things in here that aren't strict refs friendly. +use strict qw{vars subs}; +use warnings; +use File::Spec (); + +# ABSTRACT: Get information about a class and its structure +our $VERSION = '1.32'; # VERSION + + +# If Unicode is available, enable it so that the +# pattern matches below match unicode method names. +# We can safely ignore any failure here. +BEGIN { + local $@; + eval "require utf8; utf8->import"; +} + +# Predefine some regexs +our $RE_IDENTIFIER = qr/\A[^\W\d]\w*\z/s; +our $RE_CLASS = qr/\A[^\W\d]\w*(?:(?:\'|::)\w+)*\z/s; + +# Are we on something Unix-like? +our $UNIX = !! ( $File::Spec::ISA[0] eq 'File::Spec::Unix' ); + + +##################################################################### +# Basic Methods + + +sub _resolved_inc_handler { + my $class = shift; + my $filename = $class->_inc_filename(shift) or return undef; + + foreach my $inc ( @INC ) { + my $ref = ref $inc; + if($ref eq 'CODE') { + my @ret = $inc->($inc, $filename); + if(@ret) { + return 1; + } + } + elsif($ref eq 'ARRAY' && ref($inc->[0]) eq 'CODE') { + my @ret = $inc->[0]->($inc, $filename); + if(@ret) { + return 1; + } + } + elsif($ref && eval { $inc->can('INC') }) { + my @ret = $inc->INC($filename); + if(@ret) { + return 1; + } + } + } + + ''; +} + +sub installed { + my $class = shift; + !! ($class->loaded_filename($_[0]) or $class->resolved_filename($_[0]) or $class->_resolved_inc_handler($_[0])); +} + + +sub loaded { + my $class = shift; + my $name = $class->_class(shift) or return undef; + $class->_loaded($name); +} + +sub _loaded { + my $class = shift; + my $name = shift; + + # Handle by far the two most common cases + # This is very fast and handles 99% of cases. + return 1 if defined ${"${name}::VERSION"}; + return 1 if @{"${name}::ISA"}; + + # Are there any symbol table entries other than other namespaces + foreach ( keys %{"${name}::"} ) { + next if substr($_, -2, 2) eq '::'; + return 1 if defined &{"${name}::$_"}; + } + + # No functions, and it doesn't have a version, and isn't anything. + # As an absolute last resort, check for an entry in %INC + my $filename = $class->_inc_filename($name); + return 1 if defined $INC{$filename}; + + ''; +} + + +sub filename { + my $class = shift; + my $name = $class->_class(shift) or return undef; + File::Spec->catfile( split /(?:\'|::)/, $name ) . '.pm'; +} + + +sub resolved_filename { + my $class = shift; + my $filename = $class->_inc_filename(shift) or return undef; + my @try_first = @_; + + # Look through the @INC path to find the file + foreach ( @try_first, @INC ) { + my $full = "$_/$filename"; + next unless -e $full; + return $UNIX ? $full : $class->_inc_to_local($full); + } + + # File not found + ''; +} + + +sub loaded_filename { + my $class = shift; + my $filename = $class->_inc_filename(shift); + $UNIX ? $INC{$filename} : $class->_inc_to_local($INC{$filename}); +} + + + + + +##################################################################### +# Sub Related Methods + + +sub functions { + my $class = shift; + my $name = $class->_class(shift) or return undef; + return undef unless $class->loaded( $name ); + + # Get all the CODE symbol table entries + my @functions = sort grep { /$RE_IDENTIFIER/o } + grep { defined &{"${name}::$_"} } + keys %{"${name}::"}; + \@functions; +} + + +sub function_refs { + my $class = shift; + my $name = $class->_class(shift) or return undef; + return undef unless $class->loaded( $name ); + + # Get all the CODE symbol table entries, but return + # the actual CODE refs this time. + my @functions = map { \&{"${name}::$_"} } + sort grep { /$RE_IDENTIFIER/o } + grep { defined &{"${name}::$_"} } + keys %{"${name}::"}; + \@functions; +} + + +sub function_exists { + my $class = shift; + my $name = $class->_class( shift ) or return undef; + my $function = shift or return undef; + + # Only works if the class is loaded + return undef unless $class->loaded( $name ); + + # Does the GLOB exist and its CODE part exist + defined &{"${name}::$function"}; +} + + +sub methods { + my $class = shift; + my $name = $class->_class( shift ) or return undef; + my @arguments = map { lc $_ } @_; + + # Process the arguments to determine the options + my %options = (); + foreach ( @arguments ) { + if ( $_ eq 'public' ) { + # Only get public methods + return undef if $options{private}; + $options{public} = 1; + + } elsif ( $_ eq 'private' ) { + # Only get private methods + return undef if $options{public}; + $options{private} = 1; + + } elsif ( $_ eq 'full' ) { + # Return the full method name + return undef if $options{expanded}; + $options{full} = 1; + + } elsif ( $_ eq 'expanded' ) { + # Returns class, method and function ref + return undef if $options{full}; + $options{expanded} = 1; + + } else { + # Unknown or unsupported options + return undef; + } + } + + # Only works if the class is loaded + return undef unless $class->loaded( $name ); + + # Get the super path ( not including UNIVERSAL ) + # Rather than using Class::ISA, we'll use an inlined version + # that implements the same basic algorithm. + my @path = (); + my @queue = ( $name ); + my %seen = ( $name => 1 ); + while ( my $cl = shift @queue ) { + push @path, $cl; + unshift @queue, grep { ! $seen{$_}++ } + map { s/^::/main::/; s/\'/::/g; $_ } + ( @{"${cl}::ISA"} ); + } + + # Find and merge the function names across the entire super path. + # Sort alphabetically and return. + my %methods = (); + foreach my $namespace ( @path ) { + my @functions = grep { ! $methods{$_} } + grep { /$RE_IDENTIFIER/o } + grep { defined &{"${namespace}::$_"} } + keys %{"${namespace}::"}; + foreach ( @functions ) { + $methods{$_} = $namespace; + } + } + + # Filter to public or private methods if needed + my @methodlist = sort keys %methods; + @methodlist = grep { ! /^\_/ } @methodlist if $options{public}; + @methodlist = grep { /^\_/ } @methodlist if $options{private}; + + # Return in the correct format + @methodlist = map { "$methods{$_}::$_" } @methodlist if $options{full}; + @methodlist = map { + [ "$methods{$_}::$_", $methods{$_}, $_, \&{"$methods{$_}::$_"} ] + } @methodlist if $options{expanded}; + + \@methodlist; +} + + + + + +##################################################################### +# Search Methods + + +sub subclasses { + my $class = shift; + my $name = $class->_class( shift ) or return undef; + + # Prepare the search queue + my @found = (); + my @queue = grep { $_ ne 'main' } $class->_subnames(''); + while ( @queue ) { + my $c = shift(@queue); # c for class + if ( $class->_loaded($c) ) { + # At least one person has managed to misengineer + # a situation in which ->isa could die, even if the + # class is real. Trap these cases and just skip + # over that (bizarre) class. That would at limit + # problems with finding subclasses to only the + # modules that have broken ->isa implementation. + local $@; + eval { + if ( $c->isa($name) ) { + # Add to the found list, but don't add the class itself + push @found, $c unless $c eq $name; + } + }; + } + + # Add any child namespaces to the head of the queue. + # This keeps the queue length shorted, and allows us + # not to have to do another sort at the end. + unshift @queue, map { "${c}::$_" } $class->_subnames($c); + } + + @found ? \@found : ''; +} + +sub _subnames { + my ($class, $name) = @_; + return sort + grep { + substr($_, -2, 2, '') eq '::' + and + /$RE_IDENTIFIER/o + } + keys %{"${name}::"}; +} + + + + + +##################################################################### +# Children Related Methods + +# These can go undocumented for now, until I decide if its best to +# just search the children in namespace only, or if I should do it via +# the file system. + +# Find all the loaded classes below us +sub children { + my $class = shift; + my $name = $class->_class(shift) or return (); + + # Find all the Foo:: elements in our symbol table + no strict 'refs'; + map { "${name}::$_" } sort grep { s/::$// } keys %{"${name}::"}; +} + +# As above, but recursively +sub recursive_children { + my $class = shift; + my $name = $class->_class(shift) or return (); + my @children = ( $name ); + + # Do the search using a nicer, more memory efficient + # variant of actual recursion. + my $i = 0; + no strict 'refs'; + while ( my $namespace = $children[$i++] ) { + push @children, map { "${namespace}::$_" } + grep { ! /^::/ } # Ignore things like ::ISA::CACHE:: + grep { s/::$// } + keys %{"${namespace}::"}; + } + + sort @children; +} + + + + + +##################################################################### +# Private Methods + +# Checks and expands ( if needed ) a class name +sub _class { + my $class = shift; + my $name = shift or return ''; + + # Handle main shorthand + return 'main' if $name eq '::'; + $name =~ s/\A::/main::/; + + # Check the class name is valid + $name =~ /$RE_CLASS/o ? $name : ''; +} + +# Create a INC-specific filename, which always uses '/' +# regardless of platform. +sub _inc_filename { + my $class = shift; + my $name = $class->_class(shift) or return undef; + join( '/', split /(?:\'|::)/, $name ) . '.pm'; +} + +# Convert INC-specific file name to local file name +sub _inc_to_local { + # Shortcut in the Unix case + return $_[1] if $UNIX; + + # On other places, we have to deal with an unusual path that might look + # like C:/foo/bar.pm which doesn't fit ANY normal pattern. + # Putting it through splitpath/dir and back again seems to normalise + # it to a reasonable amount. + my $class = shift; + my $inc_name = shift or return undef; + my ($vol, $dir, $file) = File::Spec->splitpath( $inc_name ); + $dir = File::Spec->catdir( File::Spec->splitdir( $dir || "" ) ); + File::Spec->catpath( $vol, $dir, $file || "" ); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::Inspector - Get information about a class and its structure + +=head1 VERSION + +version 1.32 + +=head1 SYNOPSIS + + use Class::Inspector; + + # Is a class installed and/or loaded + Class::Inspector->installed( 'Foo::Class' ); + Class::Inspector->loaded( 'Foo::Class' ); + + # Filename related information + Class::Inspector->filename( 'Foo::Class' ); + Class::Inspector->resolved_filename( 'Foo::Class' ); + + # Get subroutine related information + Class::Inspector->functions( 'Foo::Class' ); + Class::Inspector->function_refs( 'Foo::Class' ); + Class::Inspector->function_exists( 'Foo::Class', 'bar' ); + Class::Inspector->methods( 'Foo::Class', 'full', 'public' ); + + # Find all loaded subclasses or something + Class::Inspector->subclasses( 'Foo::Class' ); + +=head1 DESCRIPTION + +Class::Inspector allows you to get information about a loaded class. Most or +all of this information can be found in other ways, but they aren't always +very friendly, and usually involve a relatively high level of Perl wizardry, +or strange and unusual looking code. Class::Inspector attempts to provide +an easier, more friendly interface to this information. + +=head1 METHODS + +=head2 installed + + my $bool = Class::Inspector->installed($class); + +The C static method tries to determine if a class is installed +on the machine, or at least available to Perl. It does this by wrapping +around C. + +Returns true if installed/available, false if the class is not installed, +or C if the class name is invalid. + +=head2 loaded + + my $bool = Class::Inspector->loaded($class); + +The C static method tries to determine if a class is loaded by +looking for symbol table entries. + +This method it uses to determine this will work even if the class does not +have its own file, but is contained inside a single file with multiple +classes in it. Even in the case of some sort of run-time loading class +being used, these typically leave some trace in the symbol table, so an +L or L-based class should correctly appear +loaded. + +Returns true if the class is loaded, false if not, or C if the +class name is invalid. + +=head2 filename + + my $filename = Class::Inspector->filename($class); + +For a given class, returns the base filename for the class. This will NOT +be a fully resolved filename, just the part of the filename BELOW the +C<@INC> entry. + + print Class->filename( 'Foo::Bar' ); + > Foo/Bar.pm + +This filename will be returned with the right separator for the local +platform, and should work on all platforms. + +Returns the filename on success or C if the class name is invalid. + +=head2 resolved_filename + + my $filename = Class::Inspector->resolved_filename($class); + my $filename = Class::Inspector->resolved_filename($class, @try_first); + +For a given class, the C static method returns the fully +resolved filename for a class. That is, the file that the class would be +loaded from. + +This is not necessarily the file that the class WAS loaded from, as the +value returned is determined each time it runs, and the C<@INC> include +path may change. + +To get the actual file for a loaded class, see the C +method. + +Returns the filename for the class, or C if the class name is +invalid. + +=head2 loaded_filename + + my $filename = Class::Inspector->loaded_filename($class); + +For a given loaded class, the C static method determines +(via the C<%INC> hash) the name of the file that it was originally loaded +from. + +Returns a resolved file path, or false if the class did not have it's own +file. + +=head2 functions + + my $arrayref = Class::Inspector->functions($class); + +For a loaded class, the C static method returns a list of the +names of all the functions in the classes immediate namespace. + +Note that this is not the METHODS of the class, just the functions. + +Returns a reference to an array of the function names on success, or C +if the class name is invalid or the class is not loaded. + +=head2 function_refs + + my $arrayref = Class::Inspector->function_refs($class); + +For a loaded class, the C static method returns references to +all the functions in the classes immediate namespace. + +Note that this is not the METHODS of the class, just the functions. + +Returns a reference to an array of C refs of the functions on +success, or C if the class is not loaded. + +=head2 function_exists + + my $bool = Class::Inspector->function_exists($class, $functon); + +Given a class and function name the C static method will +check to see if the function exists in the class. + +Note that this is as a function, not as a method. To see if a method +exists for a class, use the C method for any class or object. + +Returns true if the function exists, false if not, or C if the +class or function name are invalid, or the class is not loaded. + +=head2 methods + + my $arrayref = Class::Inspector->methods($class, @options); + +For a given class name, the C static method will returns ALL +the methods available to that class. This includes all methods available +from every class up the class' C<@ISA> tree. + +Returns a reference to an array of the names of all the available methods +on success, or C if the class name is invalid or the class is not +loaded. + +A number of options are available to the C method that will alter +the results returned. These should be listed after the class name, in any +order. + + # Only get public methods + my $method = Class::Inspector->methods( 'My::Class', 'public' ); + +=over 4 + +=item public + +The C option will return only 'public' methods, as defined by the Perl +convention of prepending an underscore to any 'private' methods. The C +option will effectively remove any methods that start with an underscore. + +=item private + +The C options will return only 'private' methods, as defined by the +Perl convention of prepending an underscore to an private methods. The +C option will effectively remove an method that do not start with an +underscore. + +B and C options are mutually exclusive> + +=item full + +C normally returns just the method name. Supplying the C option +will cause the methods to be returned as the full names. That is, instead of +returning C<[ 'method1', 'method2', 'method3' ]>, you would instead get +C<[ 'Class::method1', 'AnotherClass::method2', 'Class::method3' ]>. + +=item expanded + +The C option will cause a lot more information about method to be +returned. Instead of just the method name, you will instead get an array +reference containing the method name as a single combined name, a la C, +the separate class and method, and a CODE ref to the actual function ( if +available ). Please note that the function reference is not guaranteed to +be available. C is intended at some later time, to work +with modules that have some kind of common run-time loader in place ( e.g +C or C for example. + +The response from C would look something like +the following. + + [ + [ 'Class::method1', 'Class', 'method1', \&Class::method1 ], + [ 'Another::method2', 'Another', 'method2', \&Another::method2 ], + [ 'Foo::bar', 'Foo', 'bar', \&Foo::bar ], + ] + +=back + +=head2 subclasses + + my $arrayref = Class::Inspector->subclasses($class); + +The C static method will search then entire namespace (and thus +B currently loaded classes) to find all classes that are subclasses +of the class provided as a the parameter. + +The actual test will be done by calling C on the class as a static +method. (i.e. Cisa($class)>. + +Returns a reference to a list of the loaded classes that match the class +provided, or false is none match, or C if the class name provided +is invalid. + +=head1 SEE ALSO + +L, L, L + +=head1 AUTHOR + +Original author: Adam Kennedy Eadamk@cpan.orgE + +Current maintainer: Graham Ollis Eplicease@cpan.orgE + +Contributors: + +Tom Wyant + +Steffen Müller + +Kivanc Yazan (KYZN) + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2016 by Adam Kennedy. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Class/Inspector/Functions.pm b/cpanlib/Class/Inspector/Functions.pm new file mode 100644 index 0000000..187a340 --- /dev/null +++ b/cpanlib/Class/Inspector/Functions.pm @@ -0,0 +1,137 @@ +package Class::Inspector::Functions; + +use 5.006; +use strict; +use warnings; +use Exporter (); +use Class::Inspector (); + +# ABSTRACT: Get information about a class and its structure +our $VERSION = '1.32'; # VERSION + +BEGIN { + our @ISA = 'Exporter'; + + + our @EXPORT = qw( + installed + loaded + + filename + functions + methods + + subclasses + ); + + our @EXPORT_OK = qw( + resolved_filename + loaded_filename + + function_refs + function_exists + ); + #children + #recursive_children + + our %EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] ); + + foreach my $meth (@EXPORT, @EXPORT_OK) { + my $sub = Class::Inspector->can($meth); + no strict 'refs'; + *{$meth} = sub {&$sub('Class::Inspector', @_)}; + } + +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::Inspector::Functions - Get information about a class and its structure + +=head1 VERSION + +version 1.32 + +=head1 SYNOPSIS + + use Class::Inspector::Functions; + # Class::Inspector provides a non-polluting, + # method based interface! + + # Is a class installed and/or loaded + installed( 'Foo::Class' ); + loaded( 'Foo::Class' ); + + # Filename related information + filename( 'Foo::Class' ); + resolved_filename( 'Foo::Class' ); + + # Get subroutine related information + functions( 'Foo::Class' ); + function_refs( 'Foo::Class' ); + function_exists( 'Foo::Class', 'bar' ); + methods( 'Foo::Class', 'full', 'public' ); + + # Find all loaded subclasses or something + subclasses( 'Foo::Class' ); + +=head1 DESCRIPTION + +Class::Inspector::Functions is a function based interface of +L. For a thorough documentation of the available +functions, please check the manual for the main module. + +=head2 Exports + +The following functions are exported by default. + + installed + loaded + filename + functions + methods + subclasses + +The following functions are exported only by request. + + resolved_filename + loaded_filename + function_refs + function_exists + +All the functions may be imported using the C<:ALL> tag. + +=head1 SEE ALSO + +L, L, L + +=head1 AUTHOR + +Original author: Adam Kennedy Eadamk@cpan.orgE + +Current maintainer: Graham Ollis Eplicease@cpan.orgE + +Contributors: + +Tom Wyant + +Steffen Müller + +Kivanc Yazan (KYZN) + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2016 by Adam Kennedy. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Class/Load.pm b/cpanlib/Class/Load.pm new file mode 100644 index 0000000..cf456a3 --- /dev/null +++ b/cpanlib/Class/Load.pm @@ -0,0 +1,420 @@ +use strict; +use warnings; +package Class::Load; # git description: v0.24-5-g22a44fd +# ABSTRACT: A working (require "Class::Name") and more +# KEYWORDS: class module load require use runtime + +our $VERSION = '0.25'; + +use base 'Exporter'; +use Data::OptList 0.110 (); +use Module::Implementation 0.04; +use Module::Runtime 0.012 (); +use Try::Tiny; + +{ + my $loader = Module::Implementation::build_loader_sub( + implementations => [ 'XS', 'PP' ], + symbols => ['is_class_loaded'], + ); + + $loader->(); +} + +our @EXPORT_OK = qw/load_class load_optional_class try_load_class is_class_loaded load_first_existing_class/; +our %EXPORT_TAGS = ( + all => \@EXPORT_OK, +); + +our $ERROR; + +sub load_class { + my $class = shift; + my $options = shift; + + my ($res, $e) = try_load_class($class, $options); + return $class if $res; + + _croak($e); +} + +sub load_first_existing_class { + my $classes = Data::OptList::mkopt(\@_) + or return; + + foreach my $class (@{$classes}) { + Module::Runtime::check_module_name($class->[0]); + } + + for my $class (@{$classes}) { + my ($name, $options) = @{$class}; + + # We need to be careful not to pass an undef $options to this sub, + # since the XS version will blow up if that happens. + return $name if is_class_loaded($name, ($options ? $options : ())); + + my ($res, $e) = try_load_class($name, $options); + + return $name if $res; + + my $file = Module::Runtime::module_notional_filename($name); + + next if $e =~ /^Can't locate \Q$file\E in \@INC/; + next + if $options + && defined $options->{-version} + && $e =~ _version_fail_re($name, $options->{-version}); + + _croak("Couldn't load class ($name) because: $e"); + } + + my @list = map { + $_->[0] + . ( $_->[1] && defined $_->[1]{-version} + ? " (version >= $_->[1]{-version})" + : q{} ) + } @{$classes}; + + my $err + .= q{Can't locate } + . _or_list(@list) + . " in \@INC (\@INC contains: @INC)."; + _croak($err); +} + +sub _version_fail_re { + my $name = shift; + my $vers = shift; + + return qr/\Q$name\E version \Q$vers\E required--this is only version/; +} + +sub _nonexistent_fail_re { + my $name = shift; + + my $file = Module::Runtime::module_notional_filename($name); + return qr/Can't locate \Q$file\E in \@INC/; +} + +sub _or_list { + return $_[0] if @_ == 1; + + return join ' or ', @_ if @_ ==2; + + my $last = pop; + + my $list = join ', ', @_; + $list .= ', or ' . $last; + + return $list; +} + +sub load_optional_class { + my $class = shift; + my $options = shift; + + Module::Runtime::check_module_name($class); + + my ($res, $e) = try_load_class($class, $options); + return 1 if $res; + + return 0 + if $options + && defined $options->{-version} + && $e =~ _version_fail_re($class, $options->{-version}); + + return 0 + if $e =~ _nonexistent_fail_re($class); + + _croak($e); +} + +sub try_load_class { + my $class = shift; + my $options = shift; + + Module::Runtime::check_module_name($class); + + local $@; + undef $ERROR; + + if (is_class_loaded($class)) { + # We need to check this here rather than in is_class_loaded() because + # we want to return the error message for a failed version check, but + # is_class_loaded just returns true/false. + return 1 unless $options && defined $options->{-version}; + return try { + $class->VERSION($options->{-version}); + 1; + } + catch { + _error($_); + }; + } + + my $file = Module::Runtime::module_notional_filename($class); + # This says "our diagnostics of the package + # say perl's INC status about the file being loaded are + # wrong", so we delete it from %INC, so when we call require(), + # perl will *actually* try reloading the file. + # + # If the file is already in %INC, it won't retry, + # And on 5.8, it won't fail either! + # + # The extra benefit of this trick, is it helps even on + # 5.10, as instead of dying with "Compilation failed", + # it will die with the actual error, and that's a win-win. + delete $INC{$file}; + return try { + local $SIG{__DIE__} = 'DEFAULT'; + if ($options && defined $options->{-version}) { + Module::Runtime::use_module($class, $options->{-version}); + } + else { + Module::Runtime::require_module($class); + } + 1; + } + catch { + _error($_); + }; +} + +sub _error { + my $e = shift; + + $e =~ s/ at .+?Runtime\.pm line [0-9]+\.$//; + chomp $e; + + $ERROR = $e; + return 0 unless wantarray; + return 0, $ERROR; +} + +sub _croak { + require Carp; + local $Carp::CarpLevel = $Carp::CarpLevel + 2; + Carp::croak(shift); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::Load - A working (require "Class::Name") and more + +=head1 VERSION + +version 0.25 + +=head1 SYNOPSIS + + use Class::Load ':all'; + + try_load_class('Class::Name') + or plan skip_all => "Class::Name required to run these tests"; + + load_class('Class::Name'); + + is_class_loaded('Class::Name'); + + my $baseclass = load_optional_class('Class::Name::MightExist') + ? 'Class::Name::MightExist' + : 'Class::Name::Default'; + +=head1 DESCRIPTION + +C only accepts C style module names, not +C. How frustrating! For that, we provide +C. + +It's often useful to test whether a module can be loaded, instead of throwing +an error when it's not available. For that, we provide +C. + +Finally, sometimes we need to know whether a particular class has been loaded. +Asking C<%INC> is an option, but that will miss inner packages and any class +for which the filename does not correspond to the package name. For that, we +provide C. + +=head1 FUNCTIONS + +=head2 load_class Class::Name, \%options + +C will load C or throw an error, much like C. + +If C is already loaded (checked with C) then it +will not try to load the class. This is useful when you have inner packages +which C does not check. + +The C<%options> hash currently accepts one key, C<-version>. If you specify a +version, then this subroutine will call C<< Class::Name->VERSION( +$options{-version} ) >> internally, which will throw an error if the class's +version is not equal to or greater than the version you requested. + +This method will return the name of the class on success. + +=head2 try_load_class Class::Name, \%options -> (0|1, error message) + +Returns 1 if the class was loaded, 0 if it was not. If the class was not +loaded, the error will be returned as a second return value in list context. + +Again, if C is already loaded (checked with C) +then it will not try to load the class. This is useful when you have inner +packages which C does not check. + +Like C, you can pass a C<-version> in C<%options>. If the version +is not sufficient, then this subroutine will return false. + +=head2 is_class_loaded Class::Name, \%options -> 0|1 + +This uses a number of heuristics to determine if the class C is +loaded. There heuristics were taken from L's old pure-perl +implementation. + +Like C, you can pass a C<-version> in C<%options>. If the version +is not sufficient, then this subroutine will return false. + +=head2 load_first_existing_class Class::Name, \%options, ... + +This attempts to load the first loadable class in the list of classes +given. Each class name can be followed by an options hash reference. + +If any one of the classes loads and passes the optional version check, that +class name will be returned. If I of the classes can be loaded (or none +pass their version check), then an error will be thrown. + +If, when attempting to load a class, it fails to load because of a syntax +error, then an error will be thrown immediately. + +=head2 load_optional_class Class::Name, \%options -> 0|1 + +C is a lot like C, but also a lot like +C. + +If the class exists, and it works, then it will return 1. If you specify a +version in C<%options>, then the version check must succeed or it will return +0. + +If the class doesn't exist, and it appears to not exist on disk either, it +will return 0. + +If the class exists on disk, but loading from disk results in an error +(e.g.: a syntax error), then it will C with that error. + +This is useful for using if you want a fallback module system, i.e.: + + my $class = load_optional_class($foo) ? $foo : $default; + +That way, if $foo does exist, but can't be loaded due to error, you won't +get the behaviour of it simply not existing. + +=head1 CAVEATS + +Because of some of the heuristics that this module uses to infer whether a +module has been loaded, some false positives may occur in C +checks (which are also performed internally in other interfaces) -- if a class +has started to be loaded but then dies, it may appear that it has already been +loaded, which can cause other things to make the wrong decision. +L doesn't have this issue, but it also doesn't do some things +that this module does -- for example gracefully handle packages that have been +defined inline in the same file as another package. + +=head1 SEE ALSO + +=over 4 + +=item L + +This blog post is a good overview of the current state of the existing modules +for loading other modules in various ways. + +=item L + +This blog post describes how to handle optional modules with L. + +=item L + +This Japanese blog post describes why L now uses L +over its competitors. + +=item L, L, L, etc + +This module was designed to be used anywhere you have +C, which occurs in many large projects. + +=item L + +A leaner approach to loading modules + +=back + +=head1 SUPPORT + +Bugs may be submitted through L +(or L). + +There is also a mailing list available for users of this distribution, at +L. + +There is also an irc channel available for users of this distribution, at +L on C|irc://irc.perl.org/#moose>. + +=head1 AUTHOR + +Shawn M Moore + +=head1 CONTRIBUTORS + +=for stopwords Dave Rolsky Karen Etheridge Shawn Moore Jesse Luehrs Kent Fredric Paul Howarth Olivier Mengué Caleb Cushing + +=over 4 + +=item * + +Dave Rolsky + +=item * + +Karen Etheridge + +=item * + +Shawn Moore + +=item * + +Jesse Luehrs + +=item * + +Kent Fredric + +=item * + +Paul Howarth + +=item * + +Olivier Mengué + +=item * + +Caleb Cushing + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2008 by Shawn M Moore. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Class/Load/PP.pm b/cpanlib/Class/Load/PP.pm new file mode 100644 index 0000000..a6b37ef --- /dev/null +++ b/cpanlib/Class/Load/PP.pm @@ -0,0 +1,59 @@ +use strict; +use warnings; +package Class::Load::PP; + +our $VERSION = '0.25'; + +use Module::Runtime (); +use Package::Stash 0.14; +use Scalar::Util (); +use Try::Tiny; + +sub is_class_loaded { + my $class = shift; + my $options = shift; + + my $loaded = _is_class_loaded($class); + + return $loaded if ! $loaded; + return $loaded unless $options && $options->{-version}; + + return try { + $class->VERSION($options->{-version}); + 1; + } + catch { + 0; + }; +} + +sub _is_class_loaded { + my $class = shift; + + return 0 unless Module::Runtime::is_module_name($class); + + my $stash = Package::Stash->new($class); + + if ($stash->has_symbol('$VERSION')) { + my $version = ${ $stash->get_symbol('$VERSION') }; + if (defined $version) { + return 1 if ! ref $version; + # Sometimes $VERSION ends up as a reference to undef (weird) + return 1 if ref $version && Scalar::Util::reftype $version eq 'SCALAR' && defined ${$version}; + # a version object + return 1 if Scalar::Util::blessed $version; + } + } + + if ($stash->has_symbol('@ISA')) { + return 1 if @{ $stash->get_symbol('@ISA') }; + } + + # check for any method + return 1 if $stash->list_all_symbols('CODE'); + + # fail + return 0; +} + +1; diff --git a/cpanlib/Class/Method/Modifiers.pm b/cpanlib/Class/Method/Modifiers.pm new file mode 100644 index 0000000..0dbcef6 --- /dev/null +++ b/cpanlib/Class/Method/Modifiers.pm @@ -0,0 +1,565 @@ +use strict; +use warnings; +package Class::Method::Modifiers; # git description: v2.11-20-g6902f76 +# ABSTRACT: Provides Moose-like method modifiers +# KEYWORDS: method wrap modification patch +# vim: set ts=8 sts=4 sw=4 tw=115 et : + +our $VERSION = '2.12'; + +use base 'Exporter'; + +our @EXPORT = qw(before after around); +our @EXPORT_OK = (@EXPORT, qw(fresh install_modifier)); +our %EXPORT_TAGS = ( + moose => [qw(before after around)], + all => \@EXPORT_OK, +); + +BEGIN { + *_HAS_READONLY = $] >= 5.008 ? sub(){1} : sub(){0}; +} + +our %MODIFIER_CACHE; + +# for backward compatibility +sub _install_modifier; # -w +*_install_modifier = \&install_modifier; + +sub install_modifier { + my $into = shift; + my $type = shift; + my $code = pop; + my @names = @_; + + @names = @{ $names[0] } if ref($names[0]) eq 'ARRAY'; + + return _fresh($into, $code, @names) if $type eq 'fresh'; + + for my $name (@names) { + my $hit = $into->can($name) or do { + require Carp; + Carp::confess("The method '$name' is not found in the inheritance hierarchy for class $into"); + }; + + my $qualified = $into.'::'.$name; + my $cache = $MODIFIER_CACHE{$into}{$name} ||= { + before => [], + after => [], + around => [], + }; + + # this must be the first modifier we're installing + if (!exists($cache->{"orig"})) { + no strict 'refs'; + + # grab the original method (or undef if the method is inherited) + $cache->{"orig"} = *{$qualified}{CODE}; + + # the "innermost" method, the one that "around" will ultimately wrap + $cache->{"wrapped"} = $cache->{"orig"} || $hit; #sub { + # # we can't cache this, because new methods or modifiers may be + # # added between now and when this method is called + # for my $package (@{ mro::get_linear_isa($into) }) { + # next if $package eq $into; + # my $code = *{$package.'::'.$name}{CODE}; + # goto $code if $code; + # } + # require Carp; + # Carp::confess("$qualified\::$name disappeared?"); + #}; + } + + # keep these lists in the order the modifiers are called + if ($type eq 'after') { + push @{ $cache->{$type} }, $code; + } + else { + unshift @{ $cache->{$type} }, $code; + } + + # wrap the method with another layer of around. much simpler than + # the Moose equivalent. :) + if ($type eq 'around') { + my $method = $cache->{wrapped}; + my $attrs = _sub_attrs($code); + # a bare "sub :lvalue {...}" will be parsed as a label and an + # indirect method call. force it to be treated as an expression + # using + + $cache->{wrapped} = eval "package $into; +sub $attrs { \$code->(\$method, \@_); };"; + } + + # install our new method which dispatches the modifiers, but only + # if a new type was added + if (@{ $cache->{$type} } == 1) { + + # avoid these hash lookups every method invocation + my $before = $cache->{"before"}; + my $after = $cache->{"after"}; + + # this is a coderef that changes every new "around". so we need + # to take a reference to it. better a deref than a hash lookup + my $wrapped = \$cache->{"wrapped"}; + + my $attrs = _sub_attrs($cache->{wrapped}); + + my $generated = "package $into;\n"; + $generated .= "sub $name $attrs {"; + + # before is easy, it doesn't affect the return value(s) + if (@$before) { + $generated .= ' + for my $method (@$before) { + $method->(@_); + } + '; + } + + if (@$after) { + $generated .= ' + my $ret; + if (wantarray) { + $ret = [$$wrapped->(@_)]; + '.(_HAS_READONLY ? 'Internals::SvREADONLY(@$ret, 1);' : '').' + } + elsif (defined wantarray) { + $ret = \($$wrapped->(@_)); + } + else { + $$wrapped->(@_); + } + + for my $method (@$after) { + $method->(@_); + } + + wantarray ? @$ret : $ret ? $$ret : (); + ' + } + else { + $generated .= '$$wrapped->(@_);'; + } + + $generated .= '}'; + + no strict 'refs'; + no warnings 'redefine'; + no warnings 'closure'; + eval $generated; + }; + } +} + +sub before { + _install_modifier(scalar(caller), 'before', @_); +} + +sub after { + _install_modifier(scalar(caller), 'after', @_); +} + +sub around { + _install_modifier(scalar(caller), 'around', @_); +} + +sub fresh { + my $code = pop; + my @names = @_; + + @names = @{ $names[0] } if ref($names[0]) eq 'ARRAY'; + + _fresh(scalar(caller), $code, @names); +} + +sub _fresh { + my ($into, $code, @names) = @_; + + for my $name (@names) { + if ($name !~ /\A [a-zA-Z_] [a-zA-Z0-9_]* \z/xms) { + require Carp; + Carp::confess("Invalid method name '$name'"); + } + if ($into->can($name)) { + require Carp; + Carp::confess("Class $into already has a method named '$name'"); + } + + # We need to make sure that the installed method has its CvNAME in + # the appropriate package; otherwise, it would be subject to + # deletion if callers use namespace::autoclean. If $code was + # compiled in the target package, we can just install it directly; + # otherwise, we'll need a different approach. Using Sub::Name would + # be fine in all cases, at the cost of introducing a dependency on + # an XS-using, non-core module. So instead we'll use string-eval to + # create a new subroutine that wraps $code. + if (_is_in_package($code, $into)) { + no strict 'refs'; + *{"$into\::$name"} = $code; + } + else { + no warnings 'closure'; # for 5.8.x + my $attrs = _sub_attrs($code); + eval "package $into; sub $name $attrs { \$code->(\@_) }"; + } + } +} + +sub _sub_attrs { + my ($coderef) = @_; + local *_sub = $coderef; + local $@; + (eval 'sub { _sub = 1 }') ? ':lvalue' : ''; +} + +sub _is_in_package { + my ($coderef, $package) = @_; + require B; + my $cv = B::svref_2object($coderef); + return $cv->GV->STASH->NAME eq $package; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::Method::Modifiers - Provides Moose-like method modifiers + +=head1 VERSION + +version 2.12 + +=head1 SYNOPSIS + + package Child; + use parent 'Parent'; + use Class::Method::Modifiers; + + sub new_method { } + + before 'old_method' => sub { + carp "old_method is deprecated, use new_method"; + }; + + around 'other_method' => sub { + my $orig = shift; + my $ret = $orig->(@_); + return $ret =~ /\d/ ? $ret : lc $ret; + }; + + after 'private', 'protected' => sub { + debug "finished calling a dangerous method"; + }; + + use Class::Method::Modifiers qw(fresh); + + fresh 'not_in_hierarchy' => sub { + warn "freshly added method\n"; + }; + +=head1 DESCRIPTION + +=for stopwords CLOS + +Method modifiers are a convenient feature from the CLOS (Common Lisp Object +System) world. + +In its most basic form, a method modifier is just a method that calls +C<< $self->SUPER::foo(@_) >>. I for one have trouble remembering that exact +invocation, so my classes seldom re-dispatch to their base classes. Very bad! + +C provides three modifiers: C, C, and +C. C and C are run just before and after the method they +modify, but can not really affect that original method. C is run in +place of the original method, with a hook to easily call that original method. +See the C section for more details on how the particular modifiers +work. + +One clear benefit of using C is that you can define +multiple modifiers in a single namespace. These separate modifiers don't need +to know about each other. This makes top-down design easy. Have a base class +that provides the skeleton methods of each operation, and have plugins modify +those methods to flesh out the specifics. + +Parent classes need not know about C. This means you +should be able to modify methods in I subclass. See +L for an example of subclassing with +C. + +In short, C solves the problem of making sure you +call C<< $self->SUPER::foo(@_) >>, and provides a cleaner interface for it. + +As of version 1.00, C is faster in some cases than +L. See C in the L distribution. + +C also provides an additional "modifier" type, +C; see below. + +=head1 MODIFIERS + +All modifiers let you modify one or multiple methods at a time. The names of +multiple methods can be provided as a list or as an array-reference. Examples: + + before 'method' => sub { ... }; + before 'method1', 'method2' => sub { ... }; + before [ 'method1', 'method2' ] => sub { ... }; + +=head2 before method(s) => sub { ... }; + +C is called before the method it is modifying. Its return value is +totally ignored. It receives the same C<@_> as the method it is modifying +would have received. You can modify the C<@_> the original method will receive +by changing C<$_[0]> and friends (or by changing anything inside a reference). +This is a feature! + +=head2 after method(s) => sub { ... }; + +C is called after the method it is modifying. Its return value is +totally ignored. It receives the same C<@_> as the method it is modifying +received, mostly. The original method can modify C<@_> (such as by changing +C<$_[0]> or references) and C will see the modified version. If you +don't like this behavior, specify both a C and C, and copy the +C<@_> during C for C to use. + +=head2 around method(s) => sub { ... }; + +C is called instead of the method it is modifying. The method you're +overriding is passed in as the first argument (called C<$orig> by convention). +Watch out for contextual return values of C<$orig>. + +You can use C to: + +=over 4 + +=item Pass C<$orig> a different C<@_> + + around 'method' => sub { + my $orig = shift; + my $self = shift; + $orig->($self, reverse @_); + }; + +=item Munge the return value of C<$orig> + + around 'method' => sub { + my $orig = shift; + ucfirst $orig->(@_); + }; + +=item Avoid calling C<$orig> -- conditionally + + around 'method' => sub { + my $orig = shift; + return $orig->(@_) if time() % 2; + return "no dice, captain"; + }; + +=back + +=head2 fresh method(s) => sub { ... }; + +(Available since version 2.00) + +Unlike the other modifiers, this does not modify an existing method. +Ordinarily, C merely installs the coderef as a method in the +appropriate class; but if the class hierarchy already contains a method of +the same name, an exception is thrown. The idea of this "modifier" is to +increase safety when subclassing. Suppose you're writing a subclass of a +class Some::Base, and adding a new method: + + package My::Subclass; + use base 'Some::Base'; + + sub foo { ... } + +If a later version of Some::Base also adds a new method named C, your +method will shadow that method. Alternatively, you can use C +to install the additional method into your subclass: + + package My::Subclass; + use base 'Some::Base'; + + use Class::Method::Modifiers 'fresh'; + + fresh 'foo' => sub { ... }; + +Now upgrading Some::Base to a version with a conflicting C method will +cause an exception to be thrown; seeing that error will give you the +opportunity to fix the problem (perhaps by picking a different method name +in your subclass, or similar). + +Creating fresh methods with C (see below) provides a way +to get similar safety benefits when adding local monkeypatches to existing +classes; see L. + +For API compatibility reasons, this function is exported only when you ask +for it specifically, or for C<:all>. + +=head2 install_modifier $package, $type, @names, sub { ... } + +C is like C, C, C, and C but +it also lets you dynamically select the modifier type ('before', 'after', +'around', 'fresh') +and package that the method modifiers are installed into. This expert-level +function is exported only when you ask for it specifically, or for C<:all>. + +=head1 NOTES + +All three normal modifiers; C, C, and C; are exported +into your namespace by default. You may C to +avoid modifying your namespace. I may steal more features from L, namely +C, C, C, C, and whatever the L folks +come up with next. + +Note that the syntax and semantics for these modifiers is directly borrowed +from L (the implementations, however, are not). + +L shares a few similarities with C, +and they even have some overlap in purpose -- both can be used to implement +highly pluggable applications. The difference is that L +provides a mechanism for easily letting parent classes to invoke hooks defined +by other code. C provides a way of +overriding/augmenting methods safely, and the parent class need not know about +it. + +=head2 :lvalue METHODS + +When adding C or C modifiers, the wrapper method will be +an lvalue method if the wrapped sub is, and assigning to the method +will propagate to the wrapped method as expected. For C +modifiers, it is the modifier sub that determines if the wrapper +method is an lvalue method. + +=head1 CAVEATS + +It is erroneous to modify a method that doesn't exist in your class's +inheritance hierarchy. If this occurs, an exception will be thrown when +the modifier is defined. + +It doesn't yet play well with C. There are some C tests for this. +Don't get your hopes up though! + +Applying modifiers to array lvalue methods is not fully supported. Attempting +to assign to an array lvalue method that has an C modifier applied will +result in an error. Array lvalue methods are not well supported by perl in +general, and should be avoided. + +=head1 MAJOR VERSION CHANGES + +=for stopwords reimplementation + +This module was bumped to 1.00 following a complete reimplementation, to +indicate breaking backwards compatibility. The "guard" modifier was removed, +and the internals are completely different. + +The new version is a few times faster with half the code. It's now even faster +than Moose. + +Any code that just used modifiers should not change in behavior, except to +become more correct. And, of course, faster. :) + +=head1 SEE ALSO + +=over 4 + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L, + +=item * + +L + +=back + +=head1 ACKNOWLEDGEMENTS + +=for stopwords Stevan + +Thanks to Stevan Little for L, I would never have known about +method modifiers otherwise. + +Thanks to Matt Trout and Stevan Little for their advice. + +=head1 SUPPORT + +Bugs may be submitted through L +(or L). + +=head1 AUTHOR + +Shawn M Moore + +=head1 CONTRIBUTORS + +=for stopwords Karen Etheridge Shawn M Moore Graham Knop Aaron Crane Peter Rabbitson Justin Hunter David Steinbrunner gfx mannih + +=over 4 + +=item * + +Karen Etheridge + +=item * + +Shawn M Moore + +=item * + +Graham Knop + +=item * + +Aaron Crane + +=item * + +Peter Rabbitson + +=item * + +Justin Hunter + +=item * + +David Steinbrunner + +=item * + +gfx + +=item * + +mannih + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2007 by Shawn M Moore. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Class/Singleton.pm b/cpanlib/Class/Singleton.pm new file mode 100644 index 0000000..0389301 --- /dev/null +++ b/cpanlib/Class/Singleton.pm @@ -0,0 +1,382 @@ +#============================================================================ +# +# Class::Singleton.pm +# +# Implementation of a "singleton" module which ensures that a class has +# only one instance and provides global access to it. For a description +# of the Singleton class, see "Design Patterns", Gamma et al, Addison- +# Wesley, 1995, ISBN 0-201-63361-2 +# +# Written by Andy Wardley +# +# Copyright (C) 1998-2008 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998 Canon Research Centre Europe Ltd. +# +#============================================================================ + +package Class::Singleton; +require 5.004; +use strict; +use warnings; + +our $VERSION = 1.5; +my %_INSTANCES = (); + + +#======================================================================== +# +# instance() +# +# Module constructor. Creates an Class::Singleton (or derived) instance +# if one doesn't already exist. The instance reference is stored in the +# %_INSTANCES hash of the Class::Singleton package. The impact of this is +# that you can create any number of classes derived from Class::Singleton +# and create a single instance of each one. If the instance reference +# was stored in a scalar $_INSTANCE variable, you could only instantiate +# *ONE* object of *ANY* class derived from Class::Singleton. The first +# time the instance is created, the _new_instance() constructor is called +# which simply returns a reference to a blessed hash. This can be +# overloaded for custom constructors. Any addtional parameters passed to +# instance() are forwarded to _new_instance(). +# +# Returns a reference to the existing, or a newly created Class::Singleton +# object. If the _new_instance() method returns an undefined value +# then the constructer is deemed to have failed. +# +#======================================================================== + +sub instance { + my $class = shift; + + # already got an object + return $class if ref $class; + + # we store the instance against the $class key of %_INSTANCES + my $instance = $_INSTANCES{$class}; + unless(defined $instance) { + $_INSTANCES{$class} = $instance = $class->_new_instance(@_); + } + return $instance; +} + + +#======================================================================= +# has_instance() +# +# Public method to return the current instance if it exists. +#======================================================================= + +sub has_instance { + my $class = shift; + $class = ref $class || $class; + return $_INSTANCES{$class}; +} + + +#======================================================================== +# _new_instance(...) +# +# Simple constructor which returns a hash reference blessed into the +# current class. May be overloaded to create non-hash objects or +# handle any specific initialisation required. +#======================================================================== + +sub _new_instance { + my $class = shift; + my %args = @_ && ref $_[0] eq 'HASH' ? %{ $_[0] } : @_; + bless { %args }, $class; +} + + +#======================================================================== +# END() +# +# END block to explicitly destroy all Class::Singleton objects since +# destruction order at program exit is not predictable. See CPAN RT +# bugs #23568 and #68526 for examples of what can go wrong without this. +#======================================================================== + +END { + # dereferences and causes orderly destruction of all instances + undef(%_INSTANCES); +} + + +1; + +__END__ + +=head1 NAME + +Class::Singleton - Implementation of a "Singleton" class + +=head1 SYNOPSIS + + use Class::Singleton; + + my $one = Class::Singleton->instance(); # returns a new instance + my $two = Class::Singleton->instance(); # returns same instance + +=head1 DESCRIPTION + +This is the C module. A Singleton describes an object class +that can have only one instance in any system. An example of a Singleton +might be a print spooler or system registry. This module implements a +Singleton class from which other classes can be derived. By itself, the +C module does very little other than manage the instantiation +of a single object. In deriving a class from C, your module +will inherit the Singleton instantiation method and can implement whatever +specific functionality is required. + +For a description and discussion of the Singleton class, see +"Design Patterns", Gamma et al, Addison-Wesley, 1995, ISBN 0-201-63361-2. + +=head1 PREREQUISITES + +C requires Perl version 5.004 or later. If you have an older +version of Perl, please upgrade to latest version, available from your nearest +CPAN site (see L below). + +=head1 INSTALLATION + +The C module is available from CPAN. As the 'perlmod' man +page explains: + + CPAN stands for the Comprehensive Perl Archive Network. + This is a globally replicated collection of all known Perl + materials, including hundreds of unbunded modules. + + [...] + + For an up-to-date listing of CPAN sites, see + http://www.perl.com/perl/ or ftp://ftp.perl.com/perl/ . + +The module is available in the following directories: + + /modules/by-module/Class/Class-Singleton-.tar.gz + /authors/id/ABW/Class-Singleton-.tar.gz + +C is distributed as a single gzipped tar archive file: + + Class-Singleton-.tar.gz + +Note that "" represents the current version number, of the +form "C<1.23>". See L below to determine the current version +number for C. + +Unpack the archive to create an installation directory: + + gunzip Class-Singleton-.tar.gz + tar xvf Class-Singleton-.tar + +'cd' into that directory, make, test and install the module: + + cd Class-Singleton- + perl Makefile.PL + make + make test + make install + +The 'C' will install the module on your system. You may need +root access to perform this task. If you install the module in a local +directory (for example, by executing "C" in the +above - see C for full details), you will need to ensure +that the C environment variable is set to include the location, or +add a line to your scripts explicitly naming the library location: + + use lib '/local/path/to/lib'; + +=head1 USING THE CLASS::SINGLETON MODULE + +To import and use the C module the following line should +appear in your Perl program: + + use Class::Singleton; + +The L method is used to create a new C instance, +or return a reference to an existing instance. Using this method, it is only +possible to have a single instance of the class in any system. + + my $highlander = Class::Singleton->instance(); + +Assuming that no C object currently exists, this first call +to L will create a new C and return a reference +to it. Future invocations of L will return the same reference. + + my $macleod = Class::Singleton->instance(); + +In the above example, both C<$highlander> and C<$macleod> contain the same +reference to a C instance. There can be only one. + +=head1 DERIVING SINGLETON CLASSES + +A module class may be derived from C and will inherit the +L method that correctly instantiates only one object. + + package PrintSpooler; + use base 'Class::Singleton'; + + # derived class specific code + sub submit_job { + ... + } + + sub cancel_job { + ... + } + +The C class defined above could be used as follows: + + use PrintSpooler; + + my $spooler = PrintSpooler->instance(); + + $spooler->submit_job(...); + +The L method calls the L<_new_instance()> constructor method the +first and only time a new instance is created. All parameters passed to the +L method are forwarded to L<_new_instance()>. In the base class +the L<_new_instance()> method returns a blessed reference to a hash array +containing any arguments passed as either a hash reference or list of named +parameters. + + package MyConfig; + use base 'Class::Singleton'; + + sub foo { + shift->{ foo }; + } + + sub bar { + shift->{ bar }; + } + + package main; + + # either: hash reference of named parameters + my $config = MyConfig->instance({ foo => 10, bar => 20 }); + + # or: list of named parameters + my $config = MyConfig->instance( foo => 10, bar => 20 ); + + print $config->foo(); # 10 + print $config->bar(); # 20 + +Derived classes may redefine the L<_new_instance()> method to provide more +specific object initialisation or change the underlying object type (to a list +reference, for example). + + package MyApp::Database; + use base 'Class::Singleton'; + use DBI; + + # this only gets called the first time instance() is called + sub _new_instance { + my $class = shift; + my $self = bless { }, $class; + my $db = shift || "myappdb"; + my $host = shift || "localhost"; + + $self->{ DB } = DBI->connect("DBI:mSQL:$db:$host") + || die "Cannot connect to database: $DBI::errstr"; + + # any other initialisation... + + return $self; + } + +The above example might be used as follows: + + use MyApp::Database; + + # first use - database gets initialised + my $database = MyApp::Database->instance(); + +Some time later on in a module far, far away... + + package MyApp::FooBar + use MyApp::Database; + + # this FooBar object needs access to the database; the Singleton + # approach gives a nice wrapper around global variables. + + sub new { + my $class = shift; + bless { + database => MyApp::Database->instance(), + }, $class; + } + +The C L method uses a private hash to store +a reference to any existing instance of the object, keyed against the derived +class package name. + +This allows different classes to be derived from C that can +co-exist in the same system, while still allowing only one instance of any one +class to exist. For example, it would be possible to derive both +'C' and 'C' from C and have a +single instance of I in a system, rather than a single instance of +I. + +You can use the L method to find out if a particular class +already has an instance defined. A reference to the instance is returned or +C if none is currently defined. + + my $instance = MyApp::Database->has_instance() + || warn "No instance is defined yet"; + +=head1 METHODS + +=head2 instance() + +This method is called to return a current object instance or create a new +one by calling L<_new_instance()>. + +=head2 has_instance() + +This method returns a reference to any existing instance or C if none +is defined. + + my $testing = MySingleton1->has_instance() + || warn "No instance defined for MySingleton1"; + +=head2 _new_instance() + +This "private" method is called by L to create a new object +instance if one doesn't already exist. It is not intended to be called +directly (although there's nothing to stop you from calling it if you're +really determined to do so). + +It creates a blessed hash reference containing any arguments passed to the +method as either a hash reference or list of named parameters. + + # either: hash reference of named parameters + my $example1 = MySingleton1->new({ pi => 3.14, e => 2.718 }); + + # or: list of named parameters + my $example2 = MySingleton2->new( pi => 3.14, e => 2.718 ); + +It is important to remember that the L method will I call +the I<_new_instance()> method once, so any arguments you pass may be silently +ignored if an instance already exists. You can use the L +method to determine if an instance is already defined. + +=head1 AUTHOR + +Andy Wardley Eabw@wardley.orgE L + +Thanks to Andreas Koenig for providing some significant speedup patches and +other ideas. + +=head1 VERSION + +This is version 1.5, released November 2014 + +=head1 COPYRIGHT + +Copyright Andy Wardley 1998-2007. All Rights Reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/cpanlib/Class/Singleton/.packlist b/cpanlib/Class/Singleton/.packlist new file mode 100644 index 0000000..ab844f5 --- /dev/null +++ b/cpanlib/Class/Singleton/.packlist @@ -0,0 +1,2 @@ +/home/smarty/CPANLIB/lib/Class/Singleton.pm +/home/smarty/CPANLIB/man/man3/Class::Singleton.3pm diff --git a/cpanlib/Class/Tiny.pm b/cpanlib/Class/Tiny.pm new file mode 100644 index 0000000..2df92d0 --- /dev/null +++ b/cpanlib/Class/Tiny.pm @@ -0,0 +1,627 @@ +use 5.006; +use strict; +no strict 'refs'; +use warnings; + +package Class::Tiny; +# ABSTRACT: Minimalist class construction + +our $VERSION = '1.006'; + +use Carp (); + +# load as .pm to hide from min version scanners +require( $] >= 5.010 ? "mro.pm" : "MRO/Compat.pm" ); ## no critic: + +my %CLASS_ATTRIBUTES; + +sub import { + my $class = shift; + my $pkg = caller; + $class->prepare_class($pkg); + $class->create_attributes( $pkg, @_ ) if @_; +} + +sub prepare_class { + my ( $class, $pkg ) = @_; + @{"${pkg}::ISA"} = "Class::Tiny::Object" unless @{"${pkg}::ISA"}; +} + +# adapted from Object::Tiny and Object::Tiny::RW +sub create_attributes { + my ( $class, $pkg, @spec ) = @_; + my %defaults = map { ref $_ eq 'HASH' ? %$_ : ( $_ => undef ) } @spec; + my @attr = grep { + defined and !ref and /^[^\W\d]\w*$/s + or Carp::croak "Invalid accessor name '$_'" + } keys %defaults; + $CLASS_ATTRIBUTES{$pkg}{$_} = $defaults{$_} for @attr; + $class->_gen_accessor( $pkg, $_ ) for grep { !*{"$pkg\::$_"}{CODE} } @attr; + Carp::croak("Failed to generate attributes for $pkg: $@\n") if $@; +} + +sub _gen_accessor { + my ( $class, $pkg, $name ) = @_; + my $outer_default = $CLASS_ATTRIBUTES{$pkg}{$name}; + + my $sub = + $class->__gen_sub_body( $name, defined($outer_default), ref($outer_default) ); + + # default = outer_default avoids "won't stay shared" bug + eval "package $pkg; my \$default=\$outer_default; $sub"; ## no critic + Carp::croak("Failed to generate attributes for $pkg: $@\n") if $@; +} + +# NOTE: overriding __gen_sub_body in a subclass of Class::Tiny is risky and +# could break if the internals of Class::Tiny need to change for any +# reason. That said, I currently see no reason why this would be likely to +# change. +# +# The generated sub body should assume that a '$default' variable will be +# in scope (i.e. when the sub is evaluated) with any default value/coderef +sub __gen_sub_body { + my ( $self, $name, $has_default, $default_type ) = @_; + + if ( $has_default && $default_type eq 'CODE' ) { + return << "HERE"; +sub $name { + return ( + ( \@_ == 1 && exists \$_[0]{$name} ) + ? ( \$_[0]{$name} ) + : ( \$_[0]{$name} = ( \@_ == 2 ) ? \$_[1] : \$default->( \$_[0] ) ) + ); +} +HERE + } + elsif ($has_default) { + return << "HERE"; +sub $name { + return ( + ( \@_ == 1 && exists \$_[0]{$name} ) + ? ( \$_[0]{$name} ) + : ( \$_[0]{$name} = ( \@_ == 2 ) ? \$_[1] : \$default ) + ); +} +HERE + } + else { + return << "HERE"; +sub $name { + return \@_ == 1 ? \$_[0]{$name} : ( \$_[0]{$name} = \$_[1] ); +} +HERE + } +} + +sub get_all_attributes_for { + my ( $class, $pkg ) = @_; + my %attr = + map { $_ => undef } + map { keys %{ $CLASS_ATTRIBUTES{$_} || {} } } @{ mro::get_linear_isa($pkg) }; + return keys %attr; +} + +sub get_all_attribute_defaults_for { + my ( $class, $pkg ) = @_; + my $defaults = {}; + for my $p ( reverse @{ mro::get_linear_isa($pkg) } ) { + while ( my ( $k, $v ) = each %{ $CLASS_ATTRIBUTES{$p} || {} } ) { + $defaults->{$k} = $v; + } + } + return $defaults; +} + +package Class::Tiny::Object; +# ABSTRACT: Base class for classes built with Class::Tiny + +our $VERSION = '1.006'; + +my ( %HAS_BUILDARGS, %BUILD_CACHE, %DEMOLISH_CACHE, %ATTR_CACHE ); + +my $_PRECACHE = sub { + no warnings 'once'; # needed to avoid downstream warnings + my ($class) = @_; + my $linear_isa = + @{"$class\::ISA"} == 1 && ${"$class\::ISA"}[0] eq "Class::Tiny::Object" + ? [$class] + : mro::get_linear_isa($class); + $DEMOLISH_CACHE{$class} = [ + map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } + map { "$_\::DEMOLISH" } @$linear_isa + ]; + $BUILD_CACHE{$class} = [ + map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } + map { "$_\::BUILD" } reverse @$linear_isa + ]; + $HAS_BUILDARGS{$class} = $class->can("BUILDARGS"); + return $ATTR_CACHE{$class} = + { map { $_ => 1 } Class::Tiny->get_all_attributes_for($class) }; +}; + +sub new { + my $class = shift; + my $valid_attrs = $ATTR_CACHE{$class} || $_PRECACHE->($class); + + # handle hash ref or key/value arguments + my $args; + if ( $HAS_BUILDARGS{$class} ) { + $args = $class->BUILDARGS(@_); + } + else { + if ( @_ == 1 && ref $_[0] ) { + my %copy = eval { %{ $_[0] } }; # try shallow copy + Carp::croak("Argument to $class->new() could not be dereferenced as a hash") if $@; + $args = \%copy; + } + elsif ( @_ % 2 == 0 ) { + $args = {@_}; + } + else { + Carp::croak("$class->new() got an odd number of elements"); + } + } + + # create object and invoke BUILD (unless we were given __no_BUILD__) + my $self = + bless { map { $_ => $args->{$_} } grep { exists $valid_attrs->{$_} } keys %$args }, + $class; + $self->BUILDALL($args) if !delete $args->{__no_BUILD__} && @{ $BUILD_CACHE{$class} }; + + return $self; +} + +sub BUILDALL { $_->(@_) for @{ $BUILD_CACHE{ ref $_[0] } } } + +# Adapted from Moo and its dependencies +require Devel::GlobalDestruction unless defined ${^GLOBAL_PHASE}; + +sub DESTROY { + my $self = shift; + my $class = ref $self; + my $in_global_destruction = + defined ${^GLOBAL_PHASE} + ? ${^GLOBAL_PHASE} eq 'DESTRUCT' + : Devel::GlobalDestruction::in_global_destruction(); + for my $demolisher ( @{ $DEMOLISH_CACHE{$class} } ) { + my $e = do { + local ( $?, $@ ); + eval { $demolisher->( $self, $in_global_destruction ) }; + $@; + }; + no warnings 'misc'; # avoid (in cleanup) warnings + die $e if $e; # rethrow + } +} + +1; + + +# vim: ts=4 sts=4 sw=4 et: + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::Tiny - Minimalist class construction + +=head1 VERSION + +version 1.006 + +=head1 SYNOPSIS + +In F: + + package Person; + + use Class::Tiny qw( name ); + + 1; + +In F: + + package Employee; + use parent 'Person'; + + use Class::Tiny qw( ssn ), { + timestamp => sub { time } # attribute with default + }; + + 1; + +In F: + + use Employee; + + my $obj = Employee->new( name => "Larry", ssn => "111-22-3333" ); + + # unknown attributes are ignored + my $obj = Employee->new( name => "Larry", OS => "Linux" ); + # $obj->{OS} does not exist + +=head1 DESCRIPTION + +This module offers a minimalist class construction kit in around 120 lines of +code. Here is a list of features: + +=over 4 + +=item * + +defines attributes via import arguments + +=item * + +generates read-write accessors + +=item * + +supports lazy attribute defaults + +=item * + +supports custom accessors + +=item * + +superclass provides a standard C constructor + +=item * + +C takes a hash reference or list of key/value pairs + +=item * + +C supports providing C to customize constructor options + +=item * + +C calls C for each class from parent to child + +=item * + +superclass provides a C method + +=item * + +C calls C for each class from child to parent + +=back + +Multiple-inheritance is possible, with superclass order determined via +L. + +It uses no non-core modules for any recent Perl. On Perls older than v5.10 it +requires L. On Perls older than v5.14, it requires +L. + +=head1 USAGE + +=head2 Defining attributes + +Define attributes as a list of import arguments: + + package Foo::Bar; + + use Class::Tiny qw( + name + id + height + weight + ); + +For each attribute, a read-write accessor is created unless a subroutine of that +name already exists: + + $obj->name; # getter + $obj->name( "John Doe" ); # setter + +Attribute names must be valid subroutine identifiers or an exception will +be thrown. + +You can specify lazy defaults by defining attributes with a hash reference. +Keys define attribute names and values are constants or code references that +will be evaluated when the attribute is first accessed if no value has been +set. The object is passed as an argument to a code reference. + + package Foo::WithDefaults; + + use Class::Tiny qw/name id/, { + title => 'Peon', + skills => sub { [] }, + hire_date => sub { $_[0]->_build_hire_date }, + }; + +When subclassing, if multiple accessors of the same name exist in different +classes, any default (or lack of default) is determined by standard +method resolution order. + +To make your own custom accessors, just pre-declare the method name before +loading Class::Tiny: + + package Foo::Bar; + + use subs 'id'; + + use Class::Tiny qw( name id ); + + sub id { ... } + +Even if you pre-declare a method name, you must include it in the attribute +list for Class::Tiny to register it as a valid attribute. + +If you set a default for a custom accessor, your accessor will need to retrieve +the default and do something with it: + + package Foo::Bar; + + use subs 'id'; + + use Class::Tiny qw( name ), { id => sub { int(rand(2*31)) } }; + + sub id { + my $self = shift; + if (@_) { + return $self->{id} = shift; + } + elsif ( exists $self->{id} ) { + return $self->{id}; + } + else { + my $defaults = + Class::Tiny->get_all_attribute_defaults_for( ref $self ); + return $self->{id} = $defaults->{id}->(); + } + } + +=head2 Class::Tiny::Object is your base class + +If your class B already inherit from some class, then +Class::Tiny::Object will be added to your C<@ISA> to provide C and +C. + +If your class B inherit from something, then no additional inheritance is +set up. If the parent subclasses Class::Tiny::Object, then all is well. If +not, then you'll get accessors set up but no constructor or destructor. Don't +do that unless you really have a special need for it. + +Define subclasses as normal. It's best to define them with L, L +or L before defining attributes with Class::Tiny so the C<@ISA> +array is already populated at compile-time: + + package Foo::Bar::More; + + use parent 'Foo::Bar'; + + use Class::Tiny qw( shoe_size ); + +=head2 Object construction + +If your class inherits from Class::Tiny::Object (as it should if you followed +the advice above), it provides the C constructor for you. + +Objects can be created with attributes given as a hash reference or as a list +of key/value pairs: + + $obj = Foo::Bar->new( name => "David" ); + + $obj = Foo::Bar->new( { name => "David" } ); + +If a reference is passed as a single argument, it must be able to be +dereferenced as a hash or an exception is thrown. + +Unknown attributes in the constructor arguments will be ignored. Prior to +version 1.000, unknown attributes were an error, but this made it harder for +people to cleanly subclass Class::Tiny classes so this feature was removed. + +You can define a C method to change how arguments to new are +handled. It will receive the constructor arguments as they were provided and +must return a hash reference of key/value pairs (or else throw an +exception). + + sub BUILDARGS { + my $class = shift; + my $name = shift || "John Doe"; + return { name => $name }; + }; + + Foo::Bar->new( "David" ); + Foo::Bar->new(); # "John Doe" + +Unknown attributes returned from C will be ignored. + +=head2 BUILD + +If your class or any superclass defines a C method, it will be called +by the constructor from the furthest parent class down to the child class after +the object has been created. + +It is passed the constructor arguments as a hash reference. The return value +is ignored. Use C for validation, checking required attributes or +setting default values that depend on other attributes. + + sub BUILD { + my ($self, $args) = @_; + + for my $req ( qw/name age/ ) { + croak "$req attribute required" unless defined $self->$req; + } + + croak "Age must be non-negative" if $self->age < 0; + + $self->msg( "Hello " . $self->name ); + } + +The argument reference is a copy, so deleting elements won't affect data in the +original (but changes will be passed to other BUILD methods in C<@ISA>). + +=head2 DEMOLISH + +Class::Tiny provides a C method. If your class or any superclass +defines a C method, they will be called from the child class to the +furthest parent class during object destruction. It is provided a single +boolean argument indicating whether Perl is in global destruction. Return +values and errors are ignored. + + sub DEMOLISH { + my ($self, $global_destruct) = @_; + $self->cleanup(); + } + +=head2 Introspection and internals + +You can retrieve an unsorted list of valid attributes known to Class::Tiny +for a class and its superclasses with the C class +method. + + my @attrs = Class::Tiny->get_all_attributes_for("Employee"); + # returns qw/name ssn timestamp/ + +Likewise, a hash reference of all valid attributes and default values (or code +references) may be retrieved with the C class +method. Any attributes without a default will be C. + + my $def = Class::Tiny->get_all_attribute_defaults_for("Employee"); + # returns { + # name => undef, + # ssn => undef + # timestamp => $coderef + # } + +The C method uses two class methods, C and +C to set up the C<@ISA> array and attributes. Anyone +attempting to extend Class::Tiny itself should use these instead of mocking up +a call to C. + +When the first object is created, linearized C<@ISA>, the valid attribute list +and various subroutine references are cached for speed. Ensure that all +inheritance and methods are in place before creating objects. (You don't want +to be changing that once you create objects anyway, right?) + +=for Pod::Coverage new get_all_attributes_for get_all_attribute_defaults_for +prepare_class create_attributes + +=head1 RATIONALE + +=head2 Why this instead of Object::Tiny or Class::Accessor or something else? + +I wanted something so simple that it could potentially be used by core Perl +modules I help maintain (or hope to write), most of which either use +L or roll-their-own OO framework each time. + +L and L were close to what I wanted, but +lacking some features I deemed necessary, and their maintainers have an even +more strict philosophy against feature creep than I have. + +I also considered L, which has been around a long time and is +heavily used, but it, too, lacked features I wanted and did things in ways I +considered poor design. + +I looked for something else on CPAN, but after checking a dozen class creators +I realized I could implement exactly what I wanted faster than I could search +CPAN for something merely sufficient. + +In general, compared to most things on CPAN (other than Object::Tiny), +Class::Tiny is smaller in implementation and simpler in API. + +Specifically, here is how Class::Tiny ("C::T") compares to Object::Tiny +("O::T") and Class::Accessor ("C::A"): + + FEATURE C::T O::T C::A + -------------------------------------------------------------- + attributes defined via import yes yes no + read/write accessors yes no yes + lazy attribute defaults yes no no + provides new yes yes yes + provides DESTROY yes no no + new takes either hashref or list yes no (list) no (hash) + Moo(se)-like BUILD/DEMOLISH yes no no + Moo(se)-like BUILDARGS yes no no + no extraneous methods via @ISA yes yes no + +=head2 Why this instead of Moose or Moo? + +L and L are both excellent OO frameworks. Moose offers a powerful +meta-object protocol (MOP), but is slow to start up and has about 30 non-core +dependencies including XS modules. Moo is faster to start up and has about 10 +pure Perl dependencies but provides no true MOP, relying instead on its ability +to transparently upgrade Moo to Moose when Moose's full feature set is +required. + +By contrast, Class::Tiny has no MOP and has B non-core dependencies for +Perls in the L. It has far less code, less +complexity and no learning curve. If you don't need or can't afford what Moo or +Moose offer, this is intended to be a reasonable fallback. + +That said, Class::Tiny offers Moose-like conventions for things like C +and C for some minimal interoperability and an easier upgrade path. + +=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan + +=head1 SUPPORT + +=head2 Bugs / Feature Requests + +Please report any bugs or feature requests through the issue tracker +at L. +You will be notified automatically of any progress on your issue. + +=head2 Source Code + +This is open source software. The code repository is available for +public review and contribution under the terms of the license. + +L + + git clone https://github.com/dagolden/Class-Tiny.git + +=head1 AUTHOR + +David Golden + +=head1 CONTRIBUTORS + +=for stopwords Dagfinn Ilmari Mannsåker David Golden Gelu Lupas Karen Etheridge Olivier Mengué Toby Inkster + +=over 4 + +=item * + +Dagfinn Ilmari Mannsåker + +=item * + +David Golden + +=item * + +Gelu Lupas + +=item * + +Karen Etheridge + +=item * + +Olivier Mengué + +=item * + +Toby Inkster + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is Copyright (c) 2013 by David Golden. + +This is free software, licensed under: + + The Apache License, Version 2.0, January 2004 + +=cut diff --git a/cpanlib/Class/Tiny/.packlist b/cpanlib/Class/Tiny/.packlist new file mode 100644 index 0000000..078b877 --- /dev/null +++ b/cpanlib/Class/Tiny/.packlist @@ -0,0 +1,2 @@ +/home/smarty/CPANLIB/lib/Class/Tiny.pm +/home/smarty/CPANLIB/man/man3/Class::Tiny.3pm diff --git a/cpanlib/Crypt/SaltedHash.pm b/cpanlib/Crypt/SaltedHash.pm new file mode 100644 index 0000000..b0e9cf1 --- /dev/null +++ b/cpanlib/Crypt/SaltedHash.pm @@ -0,0 +1,433 @@ +package Crypt::SaltedHash; + +use strict; +use MIME::Base64 (); +use Digest (); + +use vars qw($VERSION); + +$VERSION = '0.09'; + +=encoding latin1 + +=head1 NAME + +Crypt::SaltedHash - Perl interface to functions that assist in working +with salted hashes. + +=head1 SYNOPSIS + + use Crypt::SaltedHash; + + my $csh = Crypt::SaltedHash->new(algorithm => 'SHA-1'); + $csh->add('secret'); + + my $salted = $csh->generate; + my $valid = Crypt::SaltedHash->validate($salted, 'secret'); + + +=head1 DESCRIPTION + +The C module provides an object oriented interface to +create salted (or seeded) hashes of clear text data. The original +formalization of this concept comes from RFC-3112 and is extended by the use +of different digital agorithms. + +=head1 ABSTRACT + +=head2 Setting the data + +The process starts with 2 elements of data: + +=over + +=item * + +a clear text string (this could represent a password for instance). + +=item * + +the salt, a random seed of data. This is the value used to augment a hash in order to +ensure that 2 hashes of identical data yield different output. + +=back + +For the purposes of this abstract we will analyze the steps within code that perform the necessary actions +to achieve the endresult hashes. Cryptographers call this hash a digest. We will not however go into an explanation +of a one-way encryption scheme. Readers of this abstract are encouraged to get information on that subject by +their own. + +Theoretically, an implementation of a one-way function as an algorithm takes input, and provides output, that are both +in binary form; realistically though digests are typically encoded and stored in a database or in a flat text or XML file. +Take slappasswd5 for instance, it performs the exact functionality described above. We will use it as a black box compiled +piece of code for our analysis. + +In pseudocode we generate a salted hash as follows: + + Get the source string and salt as separate binary objects + Concatenate the 2 binary values + Hash the concatenation into SaltedPasswordHash + Base64Encode(concat(SaltedPasswordHash, Salt)) + +We take a clear text string and hash this into a binary object representing the hashed value of the clear text string plus the random salt. +Then we have the Salt value, which are typically 4 bytes of purely random binary data represented as hexadecimal notation (Base16 as 8 bytes). + +Using SHA-1 as the hashing algorithm, SaltedPasswordHash is of length 20 (bytes) in raw binary form +(40 bytes if we look at it in hex). Salt is then 4 bytes in raw binary form. The SHA-1 algorithm generates +a 160 bit hash string. Consider that 8 bits = 1 byte. So 160 bits = 20 bytes, which is exactly what the +algorithm gives us. + +The Base64 encoding of the binary result looks like: + + {SSHA}B0O0XSYdsk7g9K229ZEr73Lid7HBD9DX + +Take note here that the final output is a 32-byte string of data. The Base64 encoding process uses bit shifting, masking, and padding as per RFC-3548. + +A couple of examples of salted hashes using on the same exact clear-text string: + + slappasswd -s testing123 + {SSHA}72uhy5xc1AWOLwmNcXALHBSzp8xt4giL + + slappasswd -s testing123 + {SSHA}zmIAVaKMmTngrUi4UlS0dzYwVAbfBTl7 + + slappasswd -s testing123 + {SSHA}Be3F12VVvBf9Sy6MSqpOgAdEj6JCZ+0f + + slappasswd -s testing123 + {SSHA}ncHs4XYmQKJqL+VuyNQzQjwRXfvu6noa + +4 runs of slappasswd against the same clear text string each yielded unique endresult hashes. +The random salt is generated silently and never made visible. + +=head2 Extracting the data + +One of the keys to note is that the salt is dealt with twice in the process. It is used once for the actual application of randomness to the +given clear text string, and then it is stored within the final output as purely Base64 encoded data. In order to perform an authentication +query for instance, we must break apart the concatenation that was created for storage of the data. We accomplish this by splitting +up the binary data we get after Base64 decoding the stored hash. + +In pseudocode we would perform the extraction and verification operations as such: + + Strip the hash identifier from the Digest + Base64Decode(Digest, 20) + Split Digest into 2 byte arrays, one for bytes 0 20(pwhash), one for bytes 21 32 (salt) + Get the target string and salt as separate binary object + Concatenate the 2 binary values + SHA hash the concatenation into targetPasswordHash + Compare targetPasswordHash with pwhash + Return corresponding Boolean value + +Our job is to split the original digest up into 2 distinct byte arrays, one of the left 20 (0 - 20 including the null terminator) bytes and +the other for the rest of the data. The left 0 20 bytes will represent the salted binary value we will use for a byte-by-byte data +match against the new clear text presented for verification. The string presented for verification will have to be salted as well. The rest +of the bytes (21 32) represent the random salt which when decoded will show the exact hex characters that make up the once randomly +generated seed. + +We are now ready to verify some data. Let's start with the 4 hashes presented earlier. We will run them through our code to extract the +random salt and then using that verify the clear text string hashed by slappasswd. First, let's do a verification test with an erroneous +password; this should fail the matching test: + + {SSHA}72uhy5xc1AWOLwmNcXALHBSzp8xt4giL Test123 + Hash extracted (in hex): ef6ba1cb9c5cd4058e2f098d71700b1c14b3a7cc + Salt extracted (in hex): 6de2088b + Hash length is: 20 Salt length is: 4 + Hash presented in hex: 256bc48def0ce04b0af90dfd2808c42588bf9542 + Hashes DON'T match: Test123 + +The match failure test was successful as expected. Now let's use known valid data through the same exact code: + + {SSHA}72uhy5xc1AWOLwmNcXALHBSzp8xt4giL testing123 + Hash extracted (in hex): ef6ba1cb9c5cd4058e2f098d71700b1c14b3a7cc + Salt extracted (in hex): 6de2088b + Hash length is: 20 Salt length is: 4 + Hash presented in hex: ef6ba1cb9c5cd4058e2f098d71700b1c14b3a7cc + Hashes match: testing123 + +The process used for salted passwords should now be clear. We see that salting hashed data does indeed add another layer of security to the +clear text one-way hashing process. But we also see that salted hashes should also be protected just as if the data was in clear text form. +Now that we have seen salted hashes actually work you should also realize that in code it is possible to extract salt values and use them +for various purposes. Obviously the usage can be on either side of the colored hat line, but the data is there. + +=head1 METHODS + +=over 4 + +=item B + +Returns a new Crypt::SaltedHash object. +Possible keys for I<%options> are: + +=over + +=item * + +I: It's also possible to use common string representations of the +algorithm (e.g. "sha256", "SHA-384"). If the argument is missing, SHA-1 will +be used by default. + +=item * + +I: You can specify your on salt. You can either specify it as a sequence +of charactres or as a hex encoded string of the form "HEX{...}". If the argument is missing, +a random seed is provided for you (recommended). + +=item * + +I: By default, the module assumes a salt length of 4 bytes (or 8, if it is encoded in hex). +If you choose a different length, you have to tell the I function how long your seed was. + +=back + +=cut + +sub new { + my ( $class, %options ) = @_; + + $options{algorithm} ||= 'SHA-1'; + $options{salt_len} ||= 4; + $options{salt} ||= &__generate_hex_salt( $options{salt_len} * 2 ); + + $options{algorithm} = uc( $options{algorithm} ); + $options{algorithm} .= '-1' + if $options{algorithm} =~ m!SHA$!; # SHA => SHA-1, HMAC-SHA => HMAC-SHA-1 + + my $digest = Digest->new( $options{algorithm} ); + my $self = { + salt => $options{salt}, + algorithm => $options{algorithm}, + digest => $digest, + scheme => &__make_scheme( $options{algorithm} ), + }; + + return bless $self, $class; +} + +=item B + +Logically joins the arguments into a single string, and uses it to +update the current digest state. For more details see L. + +=cut + +sub add { + my $self = shift; + $self->obj->add(@_); + return $self; +} + +=item B + +Resets the digest. + +=cut + +sub clear { + my $self = shift; + $self->{digest} = Digest->new( $self->{algorithm} ); + return $self; +} + +=item B + +Returns the salt in binary form. + +=cut + +sub salt_bin { + my $self = shift; + + return $self->{salt} =~ m!^HEX\{(.*)\}$!i ? pack( "H*", $1 ) : $self->{salt}; +} + +=item B + +Returns the salt in hexadecimal form ('HEX{...}') + +=cut + +sub salt_hex { + my $self = shift; + + return $self->{salt} =~ m!^HEX\{(.*)\}$!i + ? $self->{salt} + : 'HEX{' . join( '', unpack( 'H*', $self->{salt} ) ) . '}'; +} + +=item B + +Generates the seeded hash. Uses the I-method of L before actually performing +the digest calculation, so adding more cleardata after a call of I to an instance of +I has the same effect as adding the data before the call of I. + +=cut + +sub generate { + my $self = shift; + + my $clone = $self->obj->clone; + my $salt = $self->salt_bin; + + $clone->add($salt); + + my $gen = &MIME::Base64::encode_base64( $clone->digest . $salt, '' ); + my $scheme = $self->{scheme}; + + return "{$scheme}$gen"; +} + +=item B + +Validates a hasheddata previously generated against cleardata. I<$salt_len> defaults to 4 if not set. +Returns 1 if the validation is successful, 0 otherwise. + +=cut + +sub validate { + my ( undef, $hasheddata, $cleardata, $salt_len ) = @_; + + # trim white-spaces + $hasheddata =~ s!^\s+!!; + $hasheddata =~ s!\s+$!!; + + my $scheme = &__get_pass_scheme($hasheddata); + $scheme = uc( $scheme ) if $scheme; + my $algorithm = &__make_algorithm($scheme); + my $hash = &__get_pass_hash($hasheddata) || ''; + my $salt = &__extract_salt( $hash, $salt_len ); + + my $obj = __PACKAGE__->new( + algorithm => $algorithm, + salt => $salt, + salt_len => $salt_len + ); + $obj->add($cleardata); + + my $gen_hasheddata = $obj->generate; + my $gen_hash = &__get_pass_hash($gen_hasheddata); + + return $gen_hash eq $hash; +} + +=item B + +Returns a handle to L object. + +=cut + +sub obj { + return shift->{digest}; +} + +=back + +=head1 FUNCTIONS + +I + +=cut + +sub __make_scheme { + + my $scheme = shift; + + my @parts = split /-/, $scheme; + pop @parts if $parts[-1] eq '1'; # SHA-1 => SHA + + $scheme = join '', @parts; + + return uc("S$scheme"); +} + +sub __make_algorithm { + my ( $algorithm ) = @_; + + $algorithm ||= ''; + local $1; + + if ( $algorithm =~ m!^S(.*)$! ) { + $algorithm = $1; + + # print STDERR "algorithm: $algorithm\n"; + if ( $algorithm =~ m!([a-zA-Z]+)([0-9]+)! ) { + + my $name = uc($1); + my $digits = $2; + + # print STDERR "name: $name\n"; + # print STDERR "digits: $digits\n"; + + $name = "HMAC-$2" if $name =~ m!^HMAC(.*)$!; # HMAC-SHA-1 + $digits = "-$digits" unless $name =~ m!MD$!; # MD2, MD4, MD5 + + $algorithm = "$name$digits"; + } + + } + + return $algorithm; +} + +sub __get_pass_scheme { + local $1; + return unless $_[0] =~ m/{([^}]*)/; + return $1; +} + +sub __get_pass_hash { + local $1; + return unless $_[0] =~ m/}(.*)/; + return $1; +} + +sub __generate_hex_salt { + + my @keychars = ( + "0", "1", "2", "3", "4", "5", "6", "7", + "8", "9", "a", "b", "c", "d", "e", "f" + ); + my $length = shift || 8; + + my $salt = ''; + my $max = scalar @keychars; + for my $i ( 0 .. $length - 1 ) { + my $skip = $i == 0 ? 1 : 0; # don't let the first be 0 + $salt .= $keychars[ $skip + int( rand( $max - $skip ) ) ]; + } + + return "HEX{$salt}"; +} + +sub __extract_salt { + + my ( $hash, $salt_len ) = @_; + + my $binhash = &MIME::Base64::decode_base64($hash); + my $binsalt = substr( $binhash, length($binhash) - ( $salt_len || 4 ) ); + + return $binsalt; +} + +=head1 SEE ALSO + +L, L + +=head1 AUTHOR + +Sascha Kiefer, L + +=head1 ACKNOWLEDGMENTS + +The author is particularly grateful to Andres Andreu for his article: Salted +hashes demystified - A Primer (L) + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2010 Sascha Kiefer + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +1; diff --git a/cpanlib/Crypt/SaltedHash/.packlist b/cpanlib/Crypt/SaltedHash/.packlist new file mode 100644 index 0000000..5f6d001 --- /dev/null +++ b/cpanlib/Crypt/SaltedHash/.packlist @@ -0,0 +1,2 @@ +/home/smarty/CPANLIB/lib/Crypt/SaltedHash.pm +/home/smarty/CPANLIB/man/man3/Crypt::SaltedHash.3pm diff --git a/cpanlib/Crypt/URandom.pm b/cpanlib/Crypt/URandom.pm new file mode 100644 index 0000000..aff67ea --- /dev/null +++ b/cpanlib/Crypt/URandom.pm @@ -0,0 +1,363 @@ +package Crypt::URandom; + +use warnings; +use strict; +use Carp(); +use English qw( -no_match_vars ); +use Exporter(); +*import = \&Exporter::import; +our @EXPORT_OK = qw( + urandom +); +our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK, ); + +our $VERSION = '0.36'; +our @CARP_NOT = ('Crypt::URandom'); + +sub CRYPT_SILENT { return 64; } # hex 40 +sub PROV_RSA_FULL { return 1; } +sub VERIFY_CONTEXT { return 4_026_531_840; } # hex 'F0000000' +sub W2K_MAJOR_VERSION { return 5; } +sub W2K_MINOR_VERSION { return 0; } +sub SINGLE_QUOTE { return q[']; } + +sub PATH { + my $path = '/dev/urandom'; + if ( $OSNAME eq 'freebsd' ) { + $path = '/dev/random'; # FreeBSD's /dev/random is non-blocking + } + return $path; +} + +my $_initialised; +my $_context; +my $_cryptgenrandom; +my $_rtlgenrand; +my $_urandom_handle; + +sub _init { + if ( $OSNAME eq 'MSWin32' ) { + require Win32; + require Win32::API; + require Win32::API::Type; + my ( $major, $minor ) = ( Win32::GetOSVersion() )[ 1, 2 ]; + my $ntorlower = ( $major < W2K_MAJOR_VERSION() ) ? 1 : 0; + my $w2k = + ( $major == W2K_MAJOR_VERSION() and $minor == W2K_MINOR_VERSION() ) + ? 1 + : 0; + + if ($ntorlower) { + Carp::croak( +'No secure alternative for random number generation for Win32 versions older than W2K' + ); + } + elsif ($w2k) { + + my $crypt_acquire_context_a = + Win32::API->new( 'advapi32', 'CryptAcquireContextA', 'PPPNN', + 'I' ); + if ( !defined $crypt_acquire_context_a ) { + Carp::croak( + "Could not import CryptAcquireContext: $EXTENDED_OS_ERROR"); + } + + my $context = chr(0) x Win32::API::Type->sizeof('PULONG'); + my $result = + $crypt_acquire_context_a->Call( $context, 0, 0, PROV_RSA_FULL(), + CRYPT_SILENT() | VERIFY_CONTEXT() ); + my $pack_type = Win32::API::Type::packing('PULONG'); + $context = unpack $pack_type, $context; + if ( !$result ) { + Carp::croak("CryptAcquireContext failed: $EXTENDED_OS_ERROR"); + } + + my $crypt_gen_random = + Win32::API->new( 'advapi32', 'CryptGenRandom', 'NNP', 'I' ); + if ( !defined $crypt_gen_random ) { + Carp::croak( + "Could not import CryptGenRandom: $EXTENDED_OS_ERROR"); + } + $_context = $context; + $_cryptgenrandom = $crypt_gen_random; + } + else { + my $rtlgenrand = + Win32::API->new( 'advapi32', <<'_RTLGENRANDOM_PROTO_'); +INT SystemFunction036( + PVOID RandomBuffer, + ULONG RandomBufferLength +) +_RTLGENRANDOM_PROTO_ + if ( !defined $rtlgenrand ) { + Carp::croak( + "Could not import SystemFunction036: $EXTENDED_OS_ERROR"); + } + $_rtlgenrand = $rtlgenrand; + } + } + else { + require FileHandle; + $_urandom_handle = FileHandle->new( PATH(), Fcntl::O_RDONLY() ) + or Carp::croak( 'Failed to open ' + . SINGLE_QUOTE() + . PATH() + . SINGLE_QUOTE() + . " for reading:$OS_ERROR" ); + binmode $_urandom_handle; + } + return; +} + +sub urandom { + my ($length) = @_; + + my $length_ok; + if ( defined $length ) { + if ( $length =~ /^\d+$/xms ) { + $length_ok = 1; + } + } + if ( !$length_ok ) { + Carp::croak( + 'The length argument must be supplied and must be an integer'); + } + if ( !( ( defined $_initialised ) && ( $_initialised == $PROCESS_ID ) ) ) { + _init(); + $_initialised = $PROCESS_ID; + } + if ( $OSNAME eq 'MSWin32' ) { + my $buffer = chr(0) x $length; + if ($_cryptgenrandom) { + + my $result = $_cryptgenrandom->Call( $_context, $length, $buffer ); + if ( !$result ) { + Carp::croak("CryptGenRandom failed: $EXTENDED_OS_ERROR"); + } + } + elsif ($_rtlgenrand) { + + my $result = $_rtlgenrand->Call( $buffer, $length ); + if ( !$result ) { + Carp::croak("RtlGenRand failed: $EXTENDED_OS_ERROR"); + } + } + return $buffer; + } + else { + my $result = $_urandom_handle->read( my $buffer, $length ); + if ( defined $result ) { + if ( $result == $length ) { + return $buffer; + } + else { + $_urandom_handle = undef; + Carp::croak( "Only read $result bytes from " + . SINGLE_QUOTE() + . PATH() + . SINGLE_QUOTE() ); + } + } + else { + my $error = $OS_ERROR; + $_urandom_handle = undef; + Carp::croak( 'Failed to read from ' + . SINGLE_QUOTE() + . PATH() + . SINGLE_QUOTE() + . ":$error" ); + } + } +} + +1; # Magic true value required at end of module +__END__ + +=head1 NAME + +Crypt::URandom - Provide non blocking randomness + + +=head1 VERSION + +This document describes Crypt::URandom version 0.36 + + +=head1 SYNOPSIS + + use Crypt::URandom(); + + my $random_string_50_bytes_long = Crypt::URandom::urandom(50); + +OR + + use Crypt::URandom qw( urandom ); + + my $random_string_50_bytes_long = urandom(50); + +=head1 DESCRIPTION + +This Module is intended to provide +an interface to the strongest available source of non-blocking +randomness on the current platform. Platforms currently supported are +anything supporting /dev/urandom and versions of Windows greater than +or equal to Windows 2000. + + +=head1 SUBROUTINES/METHODS + +=over + +=item C + +=for stopwords cryptographic + +This function accepts an integer and returns a string of the same size +filled with random data. The first call will initialize the native +cryptographic libraries (if necessary) and load all the required Perl libraries + +=back + +=head1 DIAGNOSTICS + +=over + +=item C + +The module cannot run on versions of Windows earlier than Windows 2000 as there is no +cryptographic functions provided by the operating system. + +=item C + +=for stopwords CryptAcquireContextA advapi32 + +The module was unable to load the CryptAcquireContextA function from the +advapi32 dynamic library. The advapi32 library cannot probably be loaded. + +=item C + +=for stopwords advapi32 + +The module was unable to call the CryptAcquireContextA function from the +advapi32 dynamic library. + +=item C + +=for stopwords advapi32 CryptGenRandom + +The module was unable to load the CryptGenRandom function from the +advapi32 dynamic library. + +=item C + +=for stopwords SystemFunction036 + +The module was unable to load the SystemFunction036 function from the +advapi32 dynamic library. + +=item C + +The get method must be called with an integer argument to describe how many +random bytes are required. + +=item C + +The Windows 2000 CryptGenRandom method call failed to generate the required +amount of randomness + +=item C + +=for stopwords RtlGenRand + +The post Windows 2000 RtlGenRand method call failed to generate the required +amount of randomness + +=item C + +The /dev/urandom device did not return the desired amount of random bytes + +=item C + +The /dev/urandom device returned an error when being read from + +=item C + +The /dev/urandom device returned an error when being opened + +=back + +=head1 CONFIGURATION AND ENVIRONMENT + +Crypt::URandom requires no configuration files or environment variables. + + +=head1 DEPENDENCIES + +=over + +=for stopwords perl + +If the platform is Win32, the Win32::API module will be required. Otherwise +no other modules other than those provided by perl will be required + +=back + +=head1 INCOMPATIBILITIES + +None reported. + + +=head1 BUGS AND LIMITATIONS + +No bugs have been reported. + +Please report any bugs or feature requests to +C, or through the web interface at +L. + + +=head1 AUTHOR + +David Dick C<< >> + +=for stopwords ACKNOWLEDGEMENTS + +=head1 ACKNOWLEDGEMENTS + +=for stopwords CryptoAPI Kanat-Alexander + +The Win32::API code for interacting with Microsoft's CryptoAPI was stolen with extreme +gratitude from Crypt::Random::Source::Strong::Win32 by Max Kanat-Alexander + +=head1 LICENSE AND COPYRIGHT + +Copyright (c) 2011, David Dick C<< >>. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + +=head1 DISCLAIMER OF WARRANTY + +=for stopwords MERCHANTABILITY LICENCE + +BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER +EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE +ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH +YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL +NECESSARY SERVICING, REPAIR, OR CORRECTION. + +IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE +LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, +OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE +THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. diff --git a/cpanlib/Crypt/URandom/.packlist b/cpanlib/Crypt/URandom/.packlist new file mode 100644 index 0000000..5804fa9 --- /dev/null +++ b/cpanlib/Crypt/URandom/.packlist @@ -0,0 +1,2 @@ +/home/smarty/CPANLIB/lib/Crypt/URandom.pm +/home/smarty/CPANLIB/man/man3/Crypt::URandom.3pm diff --git a/cpanlib/Dancer2.pm b/cpanlib/Dancer2.pm new file mode 100644 index 0000000..b2e30ca --- /dev/null +++ b/cpanlib/Dancer2.pm @@ -0,0 +1,375 @@ +package Dancer2; +$Dancer2::VERSION = '0.206000'; +# ABSTRACT: Lightweight yet powerful web application framework + +use strict; +use warnings; +use List::Util 'first'; +use Module::Runtime 'use_module'; +use Import::Into; +use Dancer2::Core; +use Dancer2::Core::App; +use Dancer2::Core::Runner; +use Dancer2::FileUtils; + +our $AUTHORITY = 'SUKRIA'; + +sub VERSION { shift->SUPER::VERSION(@_) || '0.000000_000' } + +our $runner; + +sub runner {$runner} +sub psgi_app { shift->runner->psgi_app(@_) } + +sub import { + my ($class, @args) = @_; + my ($caller, $script) = caller; + + my @final_args; + my $clean_import; + foreach my $arg (@args) { + + # ignore, no longer necessary + # in the future these will warn as deprecated + grep +($arg eq $_), qw<:script :syntax :tests> + and next; + + if ($arg eq ':nopragmas') { + $clean_import++; + next; + } + + if (substr($arg, 0, 1) eq '!') { + push @final_args, $arg, 1; + } + else { + push @final_args, $arg; + } + } + + $clean_import + or $_->import::into($caller) + for qw; + + scalar @final_args % 2 + and die q{parameters must be key/value pairs or '!keyword'}; + + my %final_args = @final_args; + + my $appname = delete $final_args{appname}; + $appname ||= $caller; + + # never instantiated the runner, should do it now + if (not defined $runner) { + $runner = Dancer2::Core::Runner->new(); + } + + # Search through registered apps, creating a new app object + # if we do not find one with the same name. + my $app; + ($app) = first { $_->name eq $appname } @{$runner->apps}; + + if (!$app) { + + # populating with the server's postponed hooks in advance + $app = Dancer2::Core::App->new( + name => $appname, + caller => $script, + environment => $runner->environment, + postponed_hooks => $runner->postponed_hooks->{$appname} || {}, + ); + + # register the app within the runner instance + $runner->register_application($app); + } + + _set_import_method_to_caller($caller); + + # use config dsl class, must extend Dancer2::Core::DSL + my $config_dsl = $app->setting('dsl_class') || 'Dancer2::Core::DSL'; + $final_args{dsl} ||= $config_dsl; + + # load the DSL, defaulting to Dancer2::Core::DSL + my $dsl = use_module($final_args{dsl})->new(app => $app); + $dsl->export_symbols_to($caller, \%final_args); +} + +sub _set_import_method_to_caller { + my ($caller) = @_; + + my $import = sub { + my ($self, %options) = @_; + + my $with = $options{with}; + for my $key (keys %$with) { + $self->dancer_app->setting($key => $with->{$key}); + } + }; + + { + ## no critic + no strict 'refs'; + no warnings 'redefine'; + *{"${caller}::import"} = $import; + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2 - Lightweight yet powerful web application framework + +=head1 VERSION + +version 0.206000 + +=head1 DESCRIPTION + +Dancer2 is the new generation of L, the lightweight web-framework for +Perl. Dancer2 is a complete rewrite based on L. + +Dancer2 can optionally use XS modules for speed, but at its core remains +fatpackable (packable by L) so you could easily deploy Dancer2 +applications on hosts that do not support custom CPAN modules. + +Dancer2 is easy and fun: + + use Dancer2; + get '/' => sub { "Hello World" }; + dance; + +This is the main module for the Dancer2 distribution. It contains logic for +creating a new Dancer2 application. + +You are welcome to join our mailing list. +For subscription information, mail address and archives see +L. + +We are also on IRC: #dancer on irc.perl.org. + +=head2 Documentation Index + +Documentation on Dancer2 is split into several manpages. Below is a +complete outline on where to go for help. + +=over 4 + +=item * Dancer2 Tutorial + +If you are new to the Dancer approach, you should start by reading +our L. + +=item * Dancer2 Manual + +L is the reference for Dancer2. Here you will find +information on the concepts of Dancer2 application development and +a comprehensive reference to the Dancer2 domain specific +language. + +=item * Dancer2 Keywords + +The keywords for Dancer2 can be found under L. + +=item * Dancer2 Deployment + +For configuration examples of different deployment solutions involving +Dancer2 and Plack, refer to L. + +=item * Dancer2 Cookbook + +Specific examples of code for real-life problems and some 'tricks' for +applications in Dancer can be found in L + +=item * Dancer2 Config + +For configuration file details refer to L. It is a +complete list of all configuration options. + +=item * Dancer2 Plugins + +Refer to L for a partial list of available Dancer2 +plugins. Note that although we try to keep this list up to date we +expect plugin authors to tell us about new modules. + +For information on how to author a plugin, see L. + +=item * Dancer2 Migration guide + +L provides the most up-to-date instruction on +how to convert a Dancer (1) based application to Dancer2. + +=back + +=head1 FUNCTIONS + +=head2 my $runner=runner(); + +Returns the current runner. It is of type L. + +=head1 AUTHORS + +=head2 CORE DEVELOPERS + + Alberto Simões + Alexis Sukrieh + Damien Krotkine + David Precious + Franck Cuny + Jason A. Crome + Mickey Nasriachi + Peter Mottram (SysPete) + Russell Jenkins + Sawyer X + Stefan Hornburg (Racke) + Steven Humphrey + Yanick Champoux + +=head2 CORE DEVELOPERS EMERITUS + + David Golden + +=head2 CONTRIBUTORS + + A. Sinan Unur + Abdullah Diab + Ahmad M. Zawawi + Alex Beamish + Alexander Karelas + Alexandr Ciornii + Andrew Beverley + Andrew Grangaard + Andrew Inishev + Andrew Solomon + Andy Jack + Ashvini V + B10m + Bas Bloemsaat + baynes + Ben Hutton + biafra + Blabos de Blebe + Breno G. de Oliveira + cdmalon + Celogeek + Cesare Gargano + Charlie Gonzalez + chenchen000 + Chi Trinh + Christian Walde + Colin Kuskie + cym0n + Dale Gallagher + Daniel Muey + Daniel Perrett + Dave Jacoby + Dave Webb + David (sbts) + David Steinbrunner + David Zurborg + Davs + Dennis Lichtenthäler + Dinis Rebolo + dtcyganov + Erik Smit + Fayland Lam + Gabor Szabo + geistteufel + Gideon D'souza + Glenn Fowler + Graham Knop + Gregor Herrmann + Grzegorz Rożniecki + Hobbestigrou + Hunter McMillen + Ivan Bessarabov + Ivan Kruglov + JaHIY + Jakob Voss + James Aitken + James Raspass + James McCoy + Jason Lewis + Javier Rojas + Jean Stebens + Jens Rehsack + Joel Berger + Jonathan Cast + Jonathan Scott Duff + Joseph Frazer + Julien Fiegehenn (simbabque) + Julio Fraire + Kaitlyn Parkhurst (SYMKAT) + kbeyazli + Keith Broughton + lbeesley + Lennart Hengstmengel + Ludovic Tolhurst-Cleaver + Mario Zieschang + Mark A. Stratman + Marketa Wachtlova + Masaaki Saito + Mateu X Hunter + Matt Phillips + Matt S Trout + Maurice + Menno Blom + Michael Kröll + Michał Wojciechowski + Mohammad S Anwar + mokko + Nick Patch + Nick Tonkin + Nigel Gregoire + Nikita K + Nuno Carvalho + Olaf Alders + Olivier Mengué + Omar M. Othman + pants + Patrick Zimmermann + Pau Amma + Paul Cochrane + Paul Williams + Pedro Bruno + Pedro Melo + Philippe Bricout + Ricardo Signes + Rick Yakubowski + Ruben Amortegui + Sakshee Vijay (sakshee3) + Sam Kington + Samit Badle + Sebastien Deseille (sdeseille) + Shlomi Fish + Slava Goltser + Snigdha + Steve Dondley + Tatsuhiko Miyagawa + Tina Müller + Tom Hukins + Upasana Shukla + Vernon Lyon + Victor Adam + Vince Willems + Vincent Bachelier + Yves Orton + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/.packlist b/cpanlib/Dancer2/.packlist new file mode 100644 index 0000000..4754974 --- /dev/null +++ b/cpanlib/Dancer2/.packlist @@ -0,0 +1,157 @@ +/home/smarty/CPANLIB/bin/dancer2 +/home/smarty/CPANLIB/lib/Dancer2.pm +/home/smarty/CPANLIB/lib/Dancer2/CLI.pm +/home/smarty/CPANLIB/lib/Dancer2/CLI/Command/gen.pm +/home/smarty/CPANLIB/lib/Dancer2/CLI/Command/version.pm +/home/smarty/CPANLIB/lib/Dancer2/Config.pod +/home/smarty/CPANLIB/lib/Dancer2/Cookbook.pod +/home/smarty/CPANLIB/lib/Dancer2/Core.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/App.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Cookie.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/DSL.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Dispatcher.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Error.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Factory.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/HTTP.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Hook.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/MIME.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Request.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Request/Upload.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Response.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Response/Delayed.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Role/ConfigReader.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Role/DSL.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Role/Engine.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Role/Handler.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Role/HasLocation.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Role/Hookable.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Role/Logger.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Role/Serializer.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Role/SessionFactory.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Role/SessionFactory/File.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Role/StandardResponses.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Role/Template.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Route.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Runner.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Session.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Time.pm +/home/smarty/CPANLIB/lib/Dancer2/Core/Types.pm +/home/smarty/CPANLIB/lib/Dancer2/FileUtils.pm +/home/smarty/CPANLIB/lib/Dancer2/Handler/AutoPage.pm +/home/smarty/CPANLIB/lib/Dancer2/Handler/File.pm +/home/smarty/CPANLIB/lib/Dancer2/Logger/Capture.pm +/home/smarty/CPANLIB/lib/Dancer2/Logger/Capture/Trap.pm +/home/smarty/CPANLIB/lib/Dancer2/Logger/Console.pm +/home/smarty/CPANLIB/lib/Dancer2/Logger/Diag.pm +/home/smarty/CPANLIB/lib/Dancer2/Logger/File.pm +/home/smarty/CPANLIB/lib/Dancer2/Logger/Note.pm +/home/smarty/CPANLIB/lib/Dancer2/Logger/Null.pm +/home/smarty/CPANLIB/lib/Dancer2/Manual.pod +/home/smarty/CPANLIB/lib/Dancer2/Manual/Deployment.pod +/home/smarty/CPANLIB/lib/Dancer2/Manual/Migration.pod +/home/smarty/CPANLIB/lib/Dancer2/Manual/Testing.pod +/home/smarty/CPANLIB/lib/Dancer2/Plugin.pm +/home/smarty/CPANLIB/lib/Dancer2/Plugins.pod +/home/smarty/CPANLIB/lib/Dancer2/Policy.pod +/home/smarty/CPANLIB/lib/Dancer2/Serializer/Dumper.pm +/home/smarty/CPANLIB/lib/Dancer2/Serializer/JSON.pm +/home/smarty/CPANLIB/lib/Dancer2/Serializer/Mutable.pm +/home/smarty/CPANLIB/lib/Dancer2/Serializer/YAML.pm +/home/smarty/CPANLIB/lib/Dancer2/Session/Simple.pm +/home/smarty/CPANLIB/lib/Dancer2/Session/YAML.pm +/home/smarty/CPANLIB/lib/Dancer2/Template/Implementation/ForkedTiny.pm +/home/smarty/CPANLIB/lib/Dancer2/Template/Simple.pm +/home/smarty/CPANLIB/lib/Dancer2/Template/TemplateToolkit.pm +/home/smarty/CPANLIB/lib/Dancer2/Template/Tiny.pm +/home/smarty/CPANLIB/lib/Dancer2/Test.pm +/home/smarty/CPANLIB/lib/Dancer2/Tutorial.pod +/home/smarty/CPANLIB/lib/auto/share/dist/Dancer2/skel/.dancer +/home/smarty/CPANLIB/lib/auto/share/dist/Dancer2/skel/MANIFEST.SKIP +/home/smarty/CPANLIB/lib/auto/share/dist/Dancer2/skel/Makefile.PL +/home/smarty/CPANLIB/lib/auto/share/dist/Dancer2/skel/bin/+app.psgi +/home/smarty/CPANLIB/lib/auto/share/dist/Dancer2/skel/config.yml +/home/smarty/CPANLIB/lib/auto/share/dist/Dancer2/skel/cpanfile +/home/smarty/CPANLIB/lib/auto/share/dist/Dancer2/skel/environments/development.yml +/home/smarty/CPANLIB/lib/auto/share/dist/Dancer2/skel/environments/production.yml +/home/smarty/CPANLIB/lib/auto/share/dist/Dancer2/skel/lib/AppFile.pm +/home/smarty/CPANLIB/lib/auto/share/dist/Dancer2/skel/public/+dispatch.cgi +/home/smarty/CPANLIB/lib/auto/share/dist/Dancer2/skel/public/+dispatch.fcgi +/home/smarty/CPANLIB/lib/auto/share/dist/Dancer2/skel/public/404.html +/home/smarty/CPANLIB/lib/auto/share/dist/Dancer2/skel/public/500.html +/home/smarty/CPANLIB/lib/auto/share/dist/Dancer2/skel/public/css/error.css +/home/smarty/CPANLIB/lib/auto/share/dist/Dancer2/skel/public/css/style.css +/home/smarty/CPANLIB/lib/auto/share/dist/Dancer2/skel/public/favicon.ico +/home/smarty/CPANLIB/lib/auto/share/dist/Dancer2/skel/public/images/perldancer-bg.jpg +/home/smarty/CPANLIB/lib/auto/share/dist/Dancer2/skel/public/images/perldancer.jpg +/home/smarty/CPANLIB/lib/auto/share/dist/Dancer2/skel/public/javascripts/jquery.js +/home/smarty/CPANLIB/lib/auto/share/dist/Dancer2/skel/t/001_base.t +/home/smarty/CPANLIB/lib/auto/share/dist/Dancer2/skel/t/002_index_route.t +/home/smarty/CPANLIB/lib/auto/share/dist/Dancer2/skel/views/index.tt +/home/smarty/CPANLIB/lib/auto/share/dist/Dancer2/skel/views/layouts/main.tt +/home/smarty/CPANLIB/man/man1/dancer2.1p +/home/smarty/CPANLIB/man/man3/Dancer2.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::CLI.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::CLI::Command::gen.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::CLI::Command::version.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Config.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Cookbook.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::App.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Cookie.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::DSL.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Dispatcher.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Error.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Factory.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::HTTP.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Hook.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::MIME.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Request.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Request::Upload.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Response.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Response::Delayed.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Role::ConfigReader.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Role::DSL.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Role::Engine.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Role::Handler.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Role::HasLocation.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Role::Hookable.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Role::Logger.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Role::Serializer.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Role::SessionFactory.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Role::SessionFactory::File.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Role::StandardResponses.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Role::Template.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Route.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Runner.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Session.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Time.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Core::Types.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::FileUtils.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Handler::AutoPage.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Handler::File.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Logger::Capture.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Logger::Capture::Trap.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Logger::Console.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Logger::Diag.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Logger::File.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Logger::Note.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Logger::Null.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Manual.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Manual::Deployment.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Manual::Migration.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Manual::Testing.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Plugin.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Plugins.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Policy.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Serializer::Dumper.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Serializer::JSON.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Serializer::Mutable.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Serializer::YAML.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Session::Simple.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Session::YAML.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Template::Implementation::ForkedTiny.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Template::Simple.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Template::TemplateToolkit.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Template::Tiny.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Test.3pm +/home/smarty/CPANLIB/man/man3/Dancer2::Tutorial.3pm diff --git a/cpanlib/Dancer2/CLI.pm b/cpanlib/Dancer2/CLI.pm new file mode 100644 index 0000000..0d26a9a --- /dev/null +++ b/cpanlib/Dancer2/CLI.pm @@ -0,0 +1,35 @@ +package Dancer2::CLI; +# ABSTRACT: Dancer2 cli application +$Dancer2::CLI::VERSION = '0.206000'; +use strict; +use warnings; +use App::Cmd::Setup -app; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::CLI - Dancer2 cli application + +=head1 VERSION + +version 0.206000 + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/CLI/Command/gen.pm b/cpanlib/Dancer2/CLI/Command/gen.pm new file mode 100644 index 0000000..0995067 --- /dev/null +++ b/cpanlib/Dancer2/CLI/Command/gen.pm @@ -0,0 +1,314 @@ +# ABSTRACT: create new Dancer2 application +package Dancer2::CLI::Command::gen; +$Dancer2::CLI::Command::gen::VERSION = '0.206000'; +use strict; +use warnings; + +use App::Cmd::Setup -command; + +use HTTP::Tiny; +use File::Find; +use File::Path 'mkpath'; +use File::Spec::Functions; +use File::Share 'dist_dir'; +use File::Basename qw/dirname basename/; +use Dancer2::Template::Simple; +use Module::Runtime 'require_module'; + +my $SKEL_APP_FILE = 'lib/AppFile.pm'; + +sub description { 'Helper script to create new Dancer2 applications' } + +sub opt_spec { + return ( + [ 'application|a=s', 'application name' ], + [ 'directory|d=s', 'application folder (default: same as application name)' ], + [ 'path|p=s', 'application path (default: current directory)', + { default => '.' } ], + [ 'overwrite|o', 'overwrite existing files' ], + [ 'no-check|x', 'don\'t check latest Dancer2 version (requires internet)' ], + [ 'skel|s=s', 'skeleton directory' ], + ); +} + +sub validate_args { + my ($self, $opt, $args) = @_; + + my $name = $opt->{application} + or $self->usage_error('Application name must be defined'); + + if ( $name =~ /[^\w:]/ || $name =~ /^\d/ || $name =~ /\b:\b|:{3,}/ ) { + $self->usage_error( + "Invalid application name.\n" . + "Application names must not contain single colons, dots, " . + "hyphens or start with a number.\n" + ); + } + + my $path = $opt->{path}; + -d $path or $self->usage_error("directory '$path' does not exist"); + -w $path or $self->usage_error("directory '$path' is not writeable"); + + if ( my $skel_path = $opt->{skel} ) { + -d $skel_path + or $self->usage_error("skeleton directory '$skel_path' not found"); + } +} + +sub execute { + my ($self, $opt, $args) = @_; + $self->_version_check() unless $opt->{'no_check'}; + + my $dist_dir = dist_dir('Dancer2'); + my $skel_dir = $opt->{skel} || catdir($dist_dir, 'skel'); + -d $skel_dir or die "$skel_dir doesn't exist"; + + my $app_name = $opt->{application}; + my $app_file = _get_app_file($app_name); + my $app_path = _get_app_path($opt->{path}, $app_name); + + if( my $dir = $opt->{directory} ) { + $app_path = catdir( $opt->{path}, $dir ); + } + + my $files_to_copy = _build_file_list($skel_dir, $app_path); + foreach my $pair (@$files_to_copy) { + if ($pair->[0] =~ m/$SKEL_APP_FILE$/) { + $pair->[1] = catfile($app_path, $app_file); + last; + } + } + + my $vars = { + appname => $app_name, + appfile => $app_file, + appdir => File::Spec->rel2abs($app_path), + perl_interpreter => _get_perl_interpreter(), + cleanfiles => _get_dashed_name($app_name), + dancer_version => $self->version(), + }; + + _copy_templates($files_to_copy, $vars, $opt->{overwrite}); + _create_manifest($files_to_copy, $app_path); + _add_to_manifest_skip($app_path); + + if ( ! eval { require_module('YAML'); 1; } ) { + print <<'NOYAML'; +***** +WARNING: YAML.pm is not installed. This is not a full dependency, but is highly +recommended; in particular, the scaffolded Dancer app being created will not be +able to read settings from the config file without YAML.pm being installed. + +To resolve this, simply install YAML from CPAN, for instance using one of the +following commands: + + cpan YAML + perl -MCPAN -e 'install YAML' + curl -L http://cpanmin.us | perl - --sudo YAML +***** +NOYAML + } + + print <VERSION; +} + +# skel creation routines +sub _build_file_list { + my ($from, $to) = @_; + $from =~ s{/+$}{}; + my $len = length($from) + 1; + + my @result; + my $wanted = sub { + return unless -f; + my $file = substr($_, $len); + + # ignore .git and git/* + my $is_git = $file =~ m{^\.git(/|$)} + and return; + + push @result, [ $_, catfile($to, $file) ]; + }; + + find({ wanted => $wanted, no_chdir => 1 }, $from); + return \@result; +} + +sub _copy_templates { + my ($files, $vars, $overwrite) = @_; + + foreach my $pair (@$files) { + my ($from, $to) = @{$pair}; + if (-f $to && !$overwrite) { + print "! $to exists, overwrite? [N/y/a]: "; + my $res = ; chomp($res); + $overwrite = 1 if $res eq 'a'; + next unless ($res eq 'y') or ($res eq 'a'); + } + + my $to_dir = dirname($to); + if (! -d $to_dir) { + print "+ $to_dir\n"; + mkpath $to_dir or die "could not mkpath $to_dir: $!"; + } + + my $to_file = basename($to); + my $ex = ($to_file =~ s/^\+//); + $to = catfile($to_dir, $to_file) if $ex; + + print "+ $to\n"; + my $content; + + { + local $/; + open(my $fh, '<', $from) or die "unable to open file `$from' for reading: $!"; + $content = <$fh>; + close $fh; + } + + if ($from !~ m/\.(ico|jpg|png|css|eot|map|swp|ttf|svg|woff|woff2|js)$/) { + $content = _process_template($content, $vars); + } + + open(my $fh, '>', $to) or die "unable to open file `$to' for writing: $!"; + print $fh $content; + close $fh; + + if ($ex) { + chmod(0755, $to) or warn "unable to change permissions for $to: $!"; + } + } +} + +sub _create_manifest { + my ($files, $dir) = @_; + + my $manifest_name = catfile($dir, 'MANIFEST'); + open(my $manifest, '>', $manifest_name) or die $!; + print $manifest "MANIFEST\n"; + + foreach my $file (@{$files}) { + my $filename = substr $file->[1], length($dir) + 1; + my $basename = basename $filename; + my $clean_basename = $basename; + $clean_basename =~ s/^\+//; + $filename =~ s/\Q$basename\E/$clean_basename/; + print {$manifest} "$filename\n"; + } + + close($manifest); +} + +sub _add_to_manifest_skip { + my $dir = shift; + + my $filename = catfile($dir, 'MANIFEST.SKIP'); + open my $fh, '>>', $filename or die $!; + print {$fh} "^$dir-\n"; + close $fh; +} + +sub _process_template { + my ($template, $tokens) = @_; + my $engine = Dancer2::Template::Simple->new; + $engine->{start_tag} = '[d2%'; + $engine->{stop_tag} = '%2d]'; + return $engine->render(\$template, $tokens); +} + +sub _get_app_path { + my ($path, $appname) = @_; + return catdir($path, _get_dashed_name($appname)); +} + +sub _get_app_file { + my $appname = shift; + $appname =~ s{::}{/}g; + return catfile('lib', "$appname.pm"); +} + +sub _get_perl_interpreter { + return -r '/usr/bin/env' ? '#!/usr/bin/env perl' : "#!$^X"; +} + +sub _get_dashed_name { + my $name = shift; + $name =~ s{::}{-}g; + return $name; +} + +# version check routines +sub _version_check { + my $self = shift; + my $version = $self->version(); + return if $version =~ m/_/; + + my $latest_version = 0; + my $resp = _send_http_request('http://search.cpan.org/api/module/Dancer2'); + + if ($resp) { + if ( $resp =~ /"version" (?:\s+)? \: (?:\s+)? "(\d\.\d+)"/x ) { + $latest_version = $1; + } else { + die "Can't understand search.cpan.org's reply.\n"; + } + } + + if ($latest_version > $version) { + print qq| +The latest stable Dancer2 release is $latest_version, you are currently using $version. +Please check http://search.cpan.org/dist/Dancer2/ for updates. + +|; + } +} + +sub _send_http_request { + my $url = shift; + + my $ua = HTTP::Tiny->new( timeout => 5 ); + + my $response = $ua->get($url); + return $response->{'success'} ? $response->{'content'} : undef; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::CLI::Command::gen - create new Dancer2 application + +=head1 VERSION + +version 0.206000 + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/CLI/Command/version.pm b/cpanlib/Dancer2/CLI/Command/version.pm new file mode 100644 index 0000000..c3cd56d --- /dev/null +++ b/cpanlib/Dancer2/CLI/Command/version.pm @@ -0,0 +1,48 @@ +package Dancer2::CLI::Command::version; +# ABSTRACT: display version +$Dancer2::CLI::Command::version::VERSION = '0.206000'; +use strict; +use warnings; +use App::Cmd::Setup -command; +use Module::Runtime 'require_module'; + +sub description { 'Display version of Dancer2' } + +sub command_names { + qw/version --version -v/; +} + +sub execute { + require_module('Dancer2'); + print 'Dancer2 ' . Dancer2->VERSION . "\n"; + return 0; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::CLI::Command::version - display version + +=head1 VERSION + +version 0.206000 + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Cookbook.pod b/cpanlib/Dancer2/Cookbook.pod new file mode 100644 index 0000000..b971837 --- /dev/null +++ b/cpanlib/Dancer2/Cookbook.pod @@ -0,0 +1,994 @@ +package Dancer2::Cookbook; +# ABSTRACT: Example-driven quick-start to the Dancer2 web framework + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Cookbook - Example-driven quick-start to the Dancer2 web framework + +=head1 VERSION + +version 0.206000 + +=head1 DESCRIPTION + +A quick-start guide with examples to get you up and running with the Dancer2 +web framework. This document will be twice as useful if you finish reading +the manual (L) first, but that is not required... :-) + +=head1 BEGINNER'S DANCE + +=head2 A simple Dancer2 web app + +Dancer2 has been designed to be easy to work with - it's trivial to write a +simple web app, but still has the power to work with larger projects. To +start with, let's make an incredibly simple "Hello World" example: + + #!/usr/bin/env perl + + use Dancer2; + + get '/hello/:name' => sub { + return "Why, hello there " . route_parameters->get('name'); + }; + + dance; + +Yes - the above is a fully-functioning web app; running that script will +launch a webserver listening on the default port (3000). Now you can make a +request: + + $ curl http://localhost:3000/hello/Bob + Why, hello there Bob + +and it will say hello. The C<:name> part is a named parameter within the +route specification, whose value is made available through C. + +Note that you don't need to use the C and C pragmas; they +are already loaded by Dancer2. + +=head2 Default Route + +In case you want to avoid a I<404 error>, or handle multiple routes in the +same way and you don't feel like configuring all of them, you can set up a +default route handler. + +The default route handler will handle any request that doesn't get served by +any other route. + +All you need to do is set up the following route as the B route: + + any qr{.*} => sub { + status 'not_found'; + template 'special_404', { path => request->path }; + }; + +Then you can set up the template like so: + + You tried to reach [% path %], but it is unavailable at the moment. + + Please try again or contact us at . + +=head2 Using the C feature for automatic route creation + +For simple "static" pages you can simply enable the C config +setting; this means you don't need to declare a route handler for those +pages; if a request is for C, Dancer2 will check for a matching +view (e.g. C) and render it with the default layout, if +found. For full details, see the documentation for the L. + +=head2 Simplifying AJAX queries with the Ajax plugin + +As an AJAX query is just an HTTP query, it's similar to a GET or POST route. +You may ask yourself why you may want to use the C keyword (from the +L plugin) instead of a simple C. + +Let's say you have a path like C in your application. You may +want to be able to serve this page with a layout and HTML content. But you +may also want to be able to call this same url from a javascript query using +AJAX. + +So, instead of having the following code: + + get '/user/:user' => sub { + if ( request->is_ajax ) { + # create xml, set headers to text/xml, blablabla + header( 'Content-Type' => 'text/xml' ); + header( 'Cache-Control' => 'no-store, no-cache, must-revalidate' ); + to_xml({...}) + } else { + template users => {...} + } + }; + +you can have + + ajax '/user/:user' => sub { + to_xml( {...}, RootName => undef ); + } + +and + + get '/user/:user' => sub { + template users => {...} + } + +Because it's an AJAX query, you know you need to return XML content, so +the content type of the response is set for you. + +=head3 Example: Feeding graph data through AJAX + +Let us assume we are building an application that uses a plotting library +to generate a graph and expects to get its data, which is in the form +of word count from an AJAX call. + +For the graph, we need the url I to return a JSON representation +of the word count data. Dancer in fact has a C function that takes +care of the JSON encapsulation. + + get '/data' => sub { + open my $fh, '<', $count_file; + + my %contestant; + while (<$fh>) { + chomp; + my ( $date, $who, $count ) = split '\s*,\s*'; + + my $epoch = DateTime::Format::Flexible->parse_datetime($date)->epoch; + my $time = 1000 * $epoch; + $contestant{$who}{$time} = $count; + } + + my @json; # data structure that is going to be JSONified + + while ( my ( $peep, $data ) = each %contestant ) { + push @json, { + label => $peep, + hoverable => \1, # so that it becomes JavaScript's 'true' + data => [ map { [ $_, $data->{$_} ] } + sort { $a <=> $b } + keys %$data ], + }; + } + + my $beginning = DateTime::Format::Flexible->parse_datetime( "2010-11-01")->epoch; + my $end = DateTime::Format::Flexible->parse_datetime( "2010-12-01")->epoch; + + push @json, { + label => 'de par', + data => [ + [$beginning * 1000, 0], + [ DateTime->now->epoch * 1_000, + 50_000 + * (DateTime->now->epoch - $beginning) + / ($end - $beginning) + ] + ], + + }; + + encode_json( \@json ); + }; + +For more serious AJAX interaction, there's also L +that adds an I route handler to the mix. + +Because it's an AJAX query, you know you need to return XML content, so +the content type of the response is set for you. + +=head2 Using the prefix feature to split your application + +For better maintainability, you may want to separate some of your application +components into different packages. Let's say we have a simple web app with an +admin section and want to maintain this in a different package: + + package myapp; + use Dancer2; + use myapp::admin; + + prefix undef; + + get '/' => sub {...}; + + 1; + + package myapp::admin; + use Dancer2 appname => 'myapp'; + + prefix '/admin'; + + get '/' => sub {...}; + + 1; + +The following routes will be generated for us: + + - get / + - get /admin/ + - head / + - head /admin/ + +By default, a separate application is created for every package that uses +Dancer2. The C tag is used to collect routes and hooks into a +single Dancer2 application. In the above example, C 'myapp'> +adds the routes from C to the routes of the app C. + +When using multiple applications please ensure that your path definitions do +not overlap. For example, if using a default route as described above, once +a request is matched to the default route then no further routes (or +applications) would be reached. + +=head2 Delivering custom error pages + +=head3 At the Core + +In Dancer2, creating new errors is done by creating a new L + + my $oopsie = Dancer2::Core::Error->new( + status => 418, + message => "This is the Holidays. Tea not acceptable. We want eggnog.", + app => $app, + ) + +If not given, the status code defaults to a 500, there is no need for a message if +we feel taciturn, and while the C<$app> (which is a I +object holding all the pieces of information related to the current request) is +needed if we want to take advantage of the templates, we can also do without. + +However, to be seen by the end user, we have to populate the L +object with the error's data. This is done via: + + $oopsie->throw($response); + +Or, if we want to use the response object already present in the C<$app> +(which is usually the case): + + $oopsie->throw; + +This populates the status code of the response, sets its content, and throws a +I in the dispatch process. + +=head3 What it will look like + +The error object has quite a few ways to generate its content. + +First, it can be explicitly given + + my $oopsie = Dancer2::Core::Error->new( + content => '

OMG

', + ); + +If the C<$context> was given, the error will check if there is a +template by the name of the status code (so, say you're using Template +Toolkit, I<418.tt>) and will use it to generate the content, passing it +the error's C<$message>, C<$status> code and C<$title> (which, if not +specified, will be the standard http error definition for the status code). + +If there is no template, the error will then look for a static page (to +continue with our example, I<418.html>) in the I directory. + +And finally, if all of that failed, the error object will fall back on +an internal template. + +=head3 Errors in Routes + +The simplest way to use errors in routes is: + + get '/xmas/gift/:gift' => sub { + die "sorry, we're all out of ponies\n" + if route_parameters->get('gift') eq 'pony'; + }; + +The die will be intercepted by Dancer, converted into an error (status +code 500, message set to the dying words) and passed to the response. + +In the cases where more control is required, C is the way to go: + + get '/glass/eggnog' => sub { + send_error "Sorry, no eggnog here", 418; + }; + +And if total control is needed: + + get '/xmas/wishlist' => sub { + Dancer2::Core::Error->new( + response => response(), + status => 406, + message => "nothing but coal for you, I'm afraid", + template => 'naughty/index', + )->throw unless user_was_nice(); + + ...; + }; + +=head2 Template Toolkit's WRAPPER directive in Dancer2 + +Dancer2 already provides a WRAPPER-like ability, which we call a "layout". +The reason we don't use Template Toolkit's WRAPPER (which also makes us +incompatible with it) is because not all template systems support it. +In fact, most don't. + +However, you might want to use it, and be able to define META variables and +regular L variables. + +These few steps will get you there: + +=over 4 + +=item * Disable the layout in Dancer2 + +You can do this by simply commenting (or removing) the C +configuration in the config file. + +=item * Use the Template Toolkit template engine + +Change the configuration of the template to Template Toolkit: + + # in config.yml + template: "template_toolkit" + +=item * Tell the Template Toolkit engine which wrapper to use + + # in config.yml + # ... + engines: + template: + template_toolkit: + WRAPPER: layouts/main.tt + +=back + +Done! Everything will work fine out of the box, including variables and META +variables. + +However, disabling the internal layout it will also disable the hooks C and C. + +=head2 Customizing Template Toolkit in Dancer2 + +Please see L +for more details. + +=head2 Accessing configuration information from a separate script + +You may want to access your webapp's configuration from outside your +webapp. You could, of course, use the YAML module of your choice and load +your webapps's C, but chances are that this is not convenient. + +Use Dancer2 instead. You can simply use +the values from C and some additional default values: + + # bin/show_app_config.pl + use Dancer2; + printf "template: %s\n", config->{'template'}; # simple + printf "log: %s\n", config->{'log'}; # undef + +Note that C<< config->{log} >> should result in an uninitialized warning +on a default scaffold since the environment isn't loaded and +log is defined in the environment and not in C. Hence C. + +Dancer2 will load your C configuration file along with the +correct environment file located in your C directory. + +The environment is determined by two environment variables in the following +order: + +=over 4 + +=item * DANCER_ENVIRONMENT + +=item * PLACK_ENV + +=back + +If neither of those is set, it will default to loading the development +environment (typically C<$webapp/environment/development.yml>). + +If you wish to load a different environment, you need to override these +variables. + +You can call your script with the environment changed: + + $ PLACK_ENV=production perl bin/show_app_config.pl + +Or you can override them directly in the script (less recommended): + + BEGIN { $ENV{'DANCER_ENVIRONMENT'} = 'production' } + use Dancer2; + + ... + +=head2 Using DBIx::Class + +L, also known as DBIC, is one of the many Perl ORM +(I). It is easy to use DBIC in Dancer2 using the +L. + +=head3 An example + +This example demonstrates a simple Dancer2 application that allows one to search +for authors or books. The application is connected to a database, that contains +authors, and their books. The website will have one single page with a form, +that allows one to query books or authors, and display the results. + +=head4 Creating the application + + $ dancer2 -a bookstore + +To use the Template Toolkit as the template engine, we specify it in the +configuration file: + + # add in bookstore/config.yml + template: template_toolkit + +=head4 Creating the view + +We need a view to display the search form, and below, the results, if any. The +results will be fed by the route to the view as an arrayref of results. Each +result is a I, with a author key containing the name of the author, and +a books key containing an I of strings : the books names. + + # example of a list of results + [ { author => 'author 1', + books => [ 'book 1', 'book 2' ], + }, + { author => 'author 2', + books => [ 'book 3', 'book 4' ], + } + ] + +# bookstore/views/search.tt +

+

+Search query: +
+

+
+ +An example of the view, displaying the search form, and the results, if any: + + <% IF query.length %> +

Search query was : <% query %>.

+ <% IF results.size %> + Results: +
    + <% FOREACH result IN results %> +
  • Author: <% result.author.replace("((?i)$query)", '$1') %> +
      + <% FOREACH book IN result.books %> +
    • <% book.replace("((?i)$query)", '$1') %> + <% END %> +
    + <% END %> + <% ELSE %> + No result + <% END %> + <% END %> + +=head4 Creating a Route + +A simple route, to be added in the I module: + + # add in bookstore/lib/bookstore.pm + get '/search' => sub { + my $query = query_parameters->get('query'); + my @results = (); + + if ( length $query ) { + @results = _perform_search($query); + } + + template search => { + query => $query, + results => \@results, + }; + }; + +=head4 Creating a database + +We create a SQLite file database: + + $ sqlite3 bookstore.db + CREATE TABLE author( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + firstname text default '' not null, + lastname text not null); + + CREATE TABLE book( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + author INTEGER REFERENCES author (id), + title text default '' not null ); + +Now, to populate the database with some data, we use L: + + # populate_database.pl + package My::Bookstore::Schema; + use base qw(DBIx::Class::Schema::Loader); + package main; + my $schema = My::Bookstore::Schema->connect('dbi:SQLite:dbname=bookstore.db'); + $schema->populate('Author', [ + [ 'firstname', 'lastname'], + [ 'Ian M.', 'Banks' ], + [ 'Richard', 'Matheson'], + [ 'Frank', 'Herbert' ], + ]); + my @books_list = ( + [ 'Consider Phlebas', 'Banks' ], + [ 'The Player of Games', 'Banks' ], + [ 'Use of Weapons', 'Banks' ], + [ 'Dune', 'Herbert' ], + [ 'Dune Messiah', 'Herbert' ], + [ 'Children of Dune', 'Herbert' ], + [ 'The Night Stalker', 'Matheson' ], + [ 'The Night Strangler', 'Matheson' ], + ); + # transform author names into ids + $_->[1] = $schema->resultset('Author')->find({ lastname => $_->[1] })->id + foreach (@books_list); + $schema->populate('Book', [ + [ 'title', 'author' ], + @books_list, + ]); + +Then run it in the directory where I sits: + + perl populate_database.db + +=head4 Using Dancer2::Plugin::DBIC + +There are 2 ways of configuring DBIC to understand how the data is organized +in your database: + +=over 4 + +=item * Use auto-detection + +The configuration file needs to be updated to indicate the use of the +Dancer2::Plugin::DBIC plugin, define a new DBIC schema called I and +to indicate that this schema is connected to the SQLite database we created. + + # add in bookstore/config.yml + plugins: + DBIC: + bookstore: + dsn: "dbi:SQLite:dbname=bookstore.db" + +Now, C<_perform_search> can be implemented using L. The +plugin gives you access to an additional keyword called B, which you +give the name of schema you want to retrieve. It returns a C +which can be used to get a resultset and perform searches, as per standard +usage of DBIX::Class. + + # add in bookstore/lib/bookstore.pm + sub _perform_search { + my ($query) = @_; + my $bookstore_schema = schema 'bookstore'; + my @results; + # search in authors + my @authors = $bookstore_schema->resultset('Author')->search({ + -or => [ + firstname => { like => "%$query%" }, + lastname => { like => "%$query%" }, + ] + }); + push @results, map { + { author => join(' ', $_->firstname, $_->lastname), + books => [], + } + } @authors; + my %book_results; + # search in books + my @books = $bookstore_schema->resultset('Book')->search({ + title => { like => "%$query%" }, + }); + foreach my $book (@books) { + my $author_name = join(' ', $book->author->firstname, $book->author->lastname); + push @{$book_results{$author_name}}, $book->title; + } + push @results, map { + { author => $_, + books => $book_results{$_}, + } + } keys %book_results; + return @results; + } + +=item * Use home made schema classes + +The L lets you write the DBIC schema classes +using L. The schema classes should be put in a place that Dancer2 +will find. A good place is in I. + +Once your schema classes are in place, all you need to do is modify I +to specify that you want to use them, instead of the default auto-detection method: + + # change in bookstore/config.yml + plugins: + DBIC: + bookstore: + schema_class: My::Bookstore::Schema + dsn: "dbi:SQLite:dbname=bookstore.db" + +B: +Our bookstore lookup application can now be started using the built-in server: + + # start the web application + plackup bin/app.psgi + +=back + +=head2 Authentication + +Writing a form for authentication is simple: we check the user credentials +on a request and decide whether to continue or redirect them to a form. +The form allows them to submit their username and password and we save that +and create a session for them so when they now try the original request, +we recognize them and allow them in. + +=head3 Basic Application + +The application is fairly simple. We have a route that needs authentication, +we have a route for showing the login page, and we have a route for posting +login information and creating a session. + + package MyApp; + use Dancer2; + + get '/' => sub { + session('user') + or redirect('/login'); + + template index => {}; + }; + + get '/login' => sub { + template login => {}; + }; + + post '/login' => sub { + my $username = query_parameters->get('username'); + my $password = query_parameters->get('password'); + my $redir_url = query_parameters->get('redirect_url') || '/login'; + + $username eq 'john' && $password eq 'correcthorsebatterystaple' + or redirect $redir_url; + + session user => $username; + redirect $redir_url; + }; + +=head3 Tiny Authentication Helper + +L allows you to abstract away not only the +part that checks whether the session exists, but to also generate a +redirect with the right path and return URL. + +We simply have to define what routes needs a login using Auth::Tiny's +C keyword. + + get '/' => needs login => sub { + template index => {}; + }; + +It creates a proper return URL using C and the address from which +the user arrived. + +We can thus decorate all of our private routes to require authentication in +this manner. If a user does not have a session, it will automatically forward +it to I, in which we would render a form for the user to send a login request. + +Auth::Tiny even provides a new parameter, C, which can be used to send +the user back to their original requested path. + +=head3 Password Hashing + +L provides a simple passwords-as-objects interface with +sane defaults for hashed passwords which you can use in your web application. It uses +B as the default but supports anything the L interface does. + +Assuming we have the original user-creation form submitting a username and password: + + package MyApp; + use Dancer2; + use Dancer2::Plugin::Passphrase; + post '/register' => sub { + my $username = query_parameters->get('username'); + my $password = passphrase( + query_parameters->get('password') + )->generate; + + # $password is now a hashed password object + save_user_in_db( $username, $password->rfc2307 ); + + template registered => { success => 1 }; + }; + +We can now add the B method for verifying that username and password: + + post '/login' => sub { + my $username = query_parameters->get('username'); + my $password = query_parameters->get('password'); + my $saved_pass = fetch_password_from_db($username); + + if ( passphrase($password)->matches($saved_pass) ) { + session user => $username; + redirect query_parameters->get('return_url') || '/'; + } + + # let's render instead of redirect... + template login => { error => 'Invalid username or password' }; + }; + +=head2 Writing a REST application + +With Dancer2, it's easy to write REST applications. Dancer2 provides helpers +to serialize and deserialize for the following data formats: + +=over 4 + +=item JSON + +=item YAML + +=item XML + +=item Data::Dumper + +=back + +To activate this feature, you only have to set the C setting to +the format you require, for instance in your config file: + + serializer: JSON + +Or directly in your code: + + set serializer => 'JSON'; + +From now, all hashrefs or arrayrefs returned by a route will be serialized +to the format you chose, and all data received from B or B +requests will be automatically deserialized. + + get '/hello/:name' => sub { + # this structure will be returned to the client as + # {"name":"$name"} + return { name => query_parameters->get('name') }; + }; + +It's possible to let the client choose which serializer to use. For +this, use the C serializer, and an appropriate serializer will be +chosen from the C header. + +It's also possible to return a custom error using the +L keyword. When you don't use a serializer, +the C function will take a string as first parameter (the +message), and an optional HTTP code. When using a serializer, the message +can be a string, an arrayref or a hashref: + + get '/hello/:name' => sub { + if (...) { + send_error("you can't do that"); + # or + send_error({reason => 'access denied', message => "no"}); + } + }; + +The content of the error will be serialized using the appropriate +serializer. + +=head2 Using the serializer + +Serializers essentially do two things: + +=over 4 + +=item * Deserialize incoming requests + +When a user makes a request with serialized input, the serializer +automatically deserializes it into actual input parameters. + +=item * Serialize outgoing responses + +When you return a data structure from a route, it will automatically +serialize it for you before returning it to the user. + +=back + +=head3 Configuring + +In order to configure a serializer, you just need to pick which format +you want for encoding/decoding (e.g. L) +and set it up using the C configuration keyword. + +It is recommended to explicitly add it in the actual code instead of the +configuration file so it doesn't apply automatically to every app that +reads the configuration file (unless that's what you want): + + package MyApp; + use Dancer2; + set serializer => 'JSON'; # Dancer2::Serializer::JSON + + ... + +=head3 Using + +Now that we have a serializer set up, we can just return data structures: + + get '/' => sub { + return { resources => \%resources }; + }; + +When we return this data structure, it will automatically be serialized +into JSON. No other code is necessary. + +We also now receive requests in JSON: + + post '/:entity/:id' => sub { + my $entity = route_parameters->get('entity'); + my $id = route_parameters->get('id'); + + # input which was sent serialized + my $user = body_parameters->get('user'); + + ... + }; + +We can now make a serialized request: + + $ curl -X POST http://ourdomain/person/16 -d '{"user":"sawyer_x"}' + +=head3 App-specific feature + +Serializers are engines. They affect a Dancer Application, which means +that once you've set a serializer, B routes within that package +will be serialized and deserialized. This is how the feature works. + +As suggested above, if you would like to have both, you need to create +another application which will not be serialized. + +A common usage for this is an API providing serialized endpoints (and +receiving serialized requests) and providing rendered pages. + + # MyApp.pm + package MyApp; + use Dancer2; + + # another useful feature: + set auto_page => 1; + + get '/' => sub { template 'index' => {...} }; + + # MyApp/API.pm + package MyApp::API; + use Dancer2; + set serializer => 'JSON'; # or any other serializer + + get '/' => sub { +{ resources => \%resources, ... } }; + + # user-specific routes, for example + prefix '/users' => sub { + get '/view' => sub {...}; + get '/view/:id' => sub {...}; + put '/add' => sub {...}; # automatically deserialized params + }; + + ... + +Then those will be mounted together for a single app: + + # handler: app.pl: + use MyApp; + use MyApp::API; + use Plack::Builder; + + builder { + mount '/' => MyApp->to_app; + mount '/api' => MyApp::API->to_app; + }; + +If you want use redirect from a mounted package to the application's root +URI, L makes this possible: + + package OurWiki; + use Dancer; + use Dancer2::Plugin::RootURIFor; + + get '/:some_path' => sub { + redirect root_uri_for('/'); + } + +=head3 An example: Writing API interfaces + +This example demonstrates an app that makes a request to a weather +API and then displays it dynamically in a web page. + +Other than L for defining routes, we will use L +to make the weather API request, L to decode it from JSON format, +and finally L to provide a fully-qualified path to our +template engine. + + use JSON; + use Dancer2; + use HTTP::Tiny; + use File::Spec; + +=head4 Configuration + +We use the L template system for this app. +Dancer searches for our templates in our views directory, which defaults +to I directory in our current directory. Since we want to put our +template in our current directory, we will configure that. However, +I does not want us to provide a relative path without +configuring it to allow it. This is a security issue. So, we're using +L to create a full path to where we are. + +We also unset the default layout, so Dancer won't try to wrap our template +with another one. This is a feature in Dancer to allow you to wrap your +templates with a layout when your templating system doesn't support it. Since +we're not using a layout here, we don't need it. + + set template => 'template_toolkit'; # set template engine + set layout => undef; # disable layout + set views => File::Spec->rel2abs('.'); # full path to views + +Now, we define our URL: + + my $url = 'http://api.openweathermap.org/data/2.5/weather?id=5110629&units=imperial'; + +=head4 Route + +We will define a main route which, upon a request, will fetch the information +from the weather API, decode it, and then display it to the user. + +Route definition: + + get '/' => sub { + ... + }; + +Editing the stub of route dispatching code, we start by making the request +and decoding it: + + # fetch data + my $res = HTTP::Tiny->new->get($url); + + # decode request + my $data = decode_json $res->{'content'}; + +The data is not just a flat hash. It's a deep structure. In this example, we +will filter it for only the simple keys in the retrieved data: + + my $metrics = { map +( + ref $data->{$_} ? () : ( $_ => $data->{$_} ) + ), keys %{$data} }; + +All that is left now is to render it: + + template index => { metrics => $metrics }; + +=head1 NON-STANDARD STEPS + +=head2 Turning off warnings + +The C pragma is already used when one loads Dancer2. However, if +you I do not want the C pragma (for example, due to an +undesired warning about use of undef values), add a C pragma to +the appropriate block in your module or psgi file. + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core.pm b/cpanlib/Dancer2/Core.pm new file mode 100644 index 0000000..2fc3d42 --- /dev/null +++ b/cpanlib/Dancer2/Core.pm @@ -0,0 +1,51 @@ +package Dancer2::Core; +# ABSTRACT: Core libraries for Dancer2 2.0 +$Dancer2::Core::VERSION = '0.206000'; +use strict; +use warnings; + +sub camelize { + my ($value) = @_; + + my $camelized = ''; + for my $word ( split /_/, $value ) { + $camelized .= ucfirst($word); + } + return $camelized; +} + + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core - Core libraries for Dancer2 2.0 + +=head1 VERSION + +version 0.206000 + +=head1 FUNCTIONS + +=head2 camelize + +Camelize a underscore-separated-string. + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/App.pm b/cpanlib/Dancer2/Core/App.pm new file mode 100644 index 0000000..fb38b43 --- /dev/null +++ b/cpanlib/Dancer2/Core/App.pm @@ -0,0 +1,1883 @@ +# ABSTRACT: encapsulation of Dancer2 packages +package Dancer2::Core::App; +$Dancer2::Core::App::VERSION = '0.206000'; +use Moo; +use Carp qw; +use Scalar::Util 'blessed'; +use Module::Runtime 'is_module_name'; +use Return::MultiLevel (); +use Safe::Isa; +use Sub::Quote; +use File::Spec; +use Module::Runtime 'use_module'; +use List::Util (); +use Ref::Util qw< is_ref is_globref is_scalarref >; + +use Plack::App::File; +use Plack::Middleware::FixMissingBodyInRedirect; +use Plack::Middleware::Head; +use Plack::Middleware::Conditional; +use Plack::Middleware::ConditionalGET; + +use Dancer2::FileUtils 'path'; +use Dancer2::Core; +use Dancer2::Core::Cookie; +use Dancer2::Core::Error; +use Dancer2::Core::Types; +use Dancer2::Core::Route; +use Dancer2::Core::Hook; +use Dancer2::Core::Request; +use Dancer2::Core::Factory; + +use Dancer2::Handler::File; + +our $EVAL_SHIM; $EVAL_SHIM ||= sub { + my $code = shift; + $code->(@_); +}; + + +# we have hooks here +with qw< + Dancer2::Core::Role::Hookable + Dancer2::Core::Role::ConfigReader +>; + +sub supported_engines { [ qw ] } + +sub with_plugins { + my ( $self, @plugins ) = @_; + return map $self->_with_plugin($_), @plugins; + +} + +sub _with_plugin { + my( $self, $plugin ) = @_; + + if ( is_ref($plugin) ) { + # passing the plugin as an already-created object + + # already loaded? + if( my ( $already ) = grep { ref($plugin) eq ref $_; } @{ $self->plugins } ) { + die "trying to load two different objects for plugin ". ref $plugin + if refaddr($plugin) != refaddr $already ; + + } + else { + push @{ $self->plugins }, $plugin; + } + + return $plugin; + } + + # short plugin names get Dancer2::Plugin:: prefix + # plugin names starting with a '+' are full package names + if ( $plugin !~ s/^\+// ) { + $plugin =~ s/^(?!Dancer2::Plugin::)/Dancer2::Plugin::/; + } + + # check if it's already there + if( my ( $already ) = grep { $plugin eq ref $_ } @{ $self->plugins } ) { + return $already; + } + + push @{ $self->plugins }, + $plugin = use_module($plugin)->new( app => $self ); + + return $plugin; +} + +sub with_plugin { + my( $self, $plugin ) = @_; + + croak "expected a single argument" + unless @_ == 2; + + ( $self->with_plugins($plugin) )[0]; +} + +has _factory => ( + is => 'ro', + isa => InstanceOf['Dancer2::Core::Factory'], + lazy => 1, + default => sub { Dancer2::Core::Factory->new }, +); + +has logger_engine => ( + is => 'ro', + isa => ConsumerOf['Dancer2::Core::Role::Logger'], + lazy => 1, + builder => '_build_logger_engine', + writer => 'set_logger_engine', +); + +has session_engine => ( + is => 'ro', + isa => ConsumerOf['Dancer2::Core::Role::SessionFactory'], + lazy => 1, + builder => '_build_session_engine', + writer => 'set_session_engine', +); + +has template_engine => ( + is => 'ro', + isa => ConsumerOf['Dancer2::Core::Role::Template'], + lazy => 1, + builder => '_build_template_engine', + writer => 'set_template_engine', +); + +has serializer_engine => ( + is => 'ro', + isa => ConsumerOf['Dancer2::Core::Role::Serializer'], + lazy => 1, + builder => '_build_serializer_engine', + writer => 'set_serializer_engine', + predicate => 'has_serializer_engine', +); + +has '+local_triggers' => ( + default => sub { + my $self = shift; + my $triggers = { + # general triggers we want to allow, besides engines + views => sub { + my $self = shift; + my $value = shift; + $self->template_engine->views($value); + }, + + layout => sub { + my $self = shift; + my $value = shift; + $self->template_engine->layout($value); + }, + + log => sub { + my ( $self, $value, $config ) = @_; + + # This will allow to set the log level + # using: set log => warning + $self->logger_engine->log_level($value); + }, + }; + + foreach my $engine ( @{ $self->supported_engines } ) { + $triggers->{$engine} = sub { + my $self = shift; + my $value = shift; + my $config = shift; + + is_ref($value) and return $value; + + my $build_method = "_build_${engine}_engine"; + my $setter_method = "set_${engine}_engine"; + my $engine_instance = $self->$build_method( $value, $config ); + + # set the engine with the new value from the builder + $self->$setter_method($engine_instance); + + return $engine_instance; + }; + } + + return $triggers; + }, +); + +sub _build_logger_engine { + my $self = shift; + my $value = shift; + my $config = shift; + + defined $config or $config = $self->config; + defined $value or $value = $config->{logger}; + + is_ref($value) and return $value; + + # XXX This is needed for the tests that create an app without + # a runner. + defined $value or $value = 'console'; + + is_module_name($value) + or croak "Cannot load logger engine '$value': illegal module name"; + + my $engine_options = + $self->_get_config_for_engine( logger => $value, $config ); + + my $logger = $self->_factory->create( + logger => $value, + %{$engine_options}, + location => $self->config_location, + environment => $self->environment, + app_name => $self->name, + postponed_hooks => $self->postponed_hooks + ); + + exists $config->{log} and $logger->log_level($config->{log}); + + return $logger; +} + +sub _build_session_engine { + my $self = shift; + my $value = shift; + my $config = shift; + + defined $config or $config = $self->config; + defined $value or $value = $config->{'session'} || 'simple'; + + is_ref($value) and return $value; + + is_module_name($value) + or croak "Cannot load session engine '$value': illegal module name"; + + my $engine_options = + $self->_get_config_for_engine( session => $value, $config ); + + Scalar::Util::weaken( my $weak_self = $self ); + + # Note that engine options will replace the default session_dir (if provided). + return $self->_factory->create( + session => $value, + session_dir => path( $self->config->{appdir}, 'sessions' ), + %{$engine_options}, + postponed_hooks => $self->postponed_hooks, + + log_cb => sub { $weak_self->logger_engine->log(@_) }, + ); +} + +sub _build_template_engine { + my $self = shift; + my $value = shift; + my $config = shift; + + defined $config or $config = $self->config; + defined $value or $value = $config->{'template'}; + + defined $value or return; + is_ref($value) and return $value; + + is_module_name($value) + or croak "Cannot load template engine '$value': illegal module name"; + + my $engine_options = + $self->_get_config_for_engine( template => $value, $config ); + + my $engine_attrs = { config => $engine_options }; + $engine_attrs->{layout} ||= $config->{layout}; + $engine_attrs->{views} ||= $config->{views} + || path( $self->location, 'views' ); + + Scalar::Util::weaken( my $weak_self = $self ); + + return $self->_factory->create( + template => $value, + %{$engine_attrs}, + postponed_hooks => $self->postponed_hooks, + + log_cb => sub { $weak_self->logger_engine->log(@_) }, + ); +} + +sub _build_serializer_engine { + my $self = shift; + my $value = shift; + my $config = shift; + + defined $config or $config = $self->config; + defined $value or $value = $config->{serializer}; + + defined $value or return; + is_ref($value) and return $value; + + my $engine_options = + $self->_get_config_for_engine( serializer => $value, $config ); + + Scalar::Util::weaken( my $weak_self = $self ); + + return $self->_factory->create( + serializer => $value, + config => $engine_options, + postponed_hooks => $self->postponed_hooks, + + log_cb => sub { $weak_self->logger_engine->log(@_) }, + ); +} + +sub _get_config_for_engine { + my $self = shift; + my $engine = shift; + my $name = shift; + my $config = shift; + + defined $config->{'engines'} && defined $config->{'engines'}{$engine} + or return {}; + + # try both camelized name and regular name + my $engine_config = {}; + foreach my $engine_name ( $name, Dancer2::Core::camelize($name) ) { + if ( defined $config->{'engines'}{$engine}{$engine_name} ) { + $engine_config = $config->{'engines'}{$engine}{$engine_name}; + last; + } + } + + return $engine_config; +} + +has postponed_hooks => ( + is => 'ro', + isa => HashRef, + default => sub { {} }, +); + +# TODO I'd be happier with a HashRef, really +has plugins => ( + is => 'rw', + isa => ArrayRef, + default => sub { [] }, +); + +has route_handlers => ( + is => 'rw', + isa => ArrayRef, + default => sub { [] }, +); + +has name => ( + is => 'ro', + isa => Str, + default => sub { (caller(1))[0] }, +); + +has request => ( + is => 'ro', + isa => InstanceOf['Dancer2::Core::Request'], + writer => '_set_request', + clearer => 'clear_request', + predicate => 'has_request', +); + +sub set_request { + my ($self, $request, $defined_engines) = @_; + # typically this is passed in as an optimization within the + # dispatch loop but may be called elsewhere + $defined_engines ||= $self->defined_engines; + # populate request in app and all engines + $self->_set_request($request); + $_->set_request( $request ) for @{$defined_engines}; +} + +has response => ( + is => 'ro', + isa => InstanceOf['Dancer2::Core::Response'], + lazy => 1, + writer => 'set_response', + clearer => 'clear_response', + builder => '_build_response', + predicate => 'has_response', +); + +has with_return => ( + is => 'ro', + predicate => 1, + writer => 'set_with_return', + clearer => 'clear_with_return', +); + +has session => ( + is => 'ro', + isa => InstanceOf['Dancer2::Core::Session'], + lazy => 1, + builder => '_build_session', + writer => 'set_session', + clearer => 'clear_session', + predicate => '_has_session', +); + +around _build_config => sub { + my ( $orig, $self ) = @_; + my $config = $self->$orig; + + if ( $config && $config->{'engines'} ) { + $self->_validate_engine($_) for keys %{ $config->{'engines'} }; + } + + return $config; +}; + +sub _build_response { + my $self = shift; + return Dancer2::Core::Response->new( + server_tokens => !$self->config->{'no_server_tokens'}, + $self->has_serializer_engine + ? ( serializer => $self->serializer_engine ) + : (), + ); +} + +sub _build_session { + my $self = shift; + my $session; + + # Find the session engine + my $engine = $self->session_engine; + + # find the session cookie if any + if ( !$self->has_destroyed_session ) { + my $session_id; + my $session_cookie = $self->cookie( $engine->cookie_name ); + defined $session_cookie and + $session_id = $session_cookie->value; + + # if we have a session cookie, try to retrieve the session + if ( defined $session_id ) { + eval { + $EVAL_SHIM->(sub { + $session = $engine->retrieve( id => $session_id ); + }); + 1; + } + or do { + my $err = $@ || "Zombie Error"; + if ( $err !~ /Unable to retrieve session/ ) { + croak "Failed to retrieve session: $err" + } else { + # XXX we throw away the error entirely? Why? + } + }; + } + } + + # create the session if none retrieved + return $session ||= $engine->create(); +} + +sub has_session { + my $self = shift; + + my $engine = $self->session_engine; + + return $self->_has_session + || ( $self->cookie( $engine->cookie_name ) + && !$self->has_destroyed_session ); +} + +has destroyed_session => ( + is => 'ro', + isa => InstanceOf ['Dancer2::Core::Session'], + predicate => 1, + writer => 'set_destroyed_session', + clearer => 'clear_destroyed_session', +); + +sub find_plugin { + my ( $self, $name ) = @_; + my $plugin = List::Util::first { ref($_) eq $name } @{ $self->plugins }; + $plugin or return; + return $plugin; +} + +sub destroy_session { + my $self = shift; + + # Find the session engine + my $engine = $self->session_engine; + + # Expire session, set the expired cookie and destroy the session + # Setting the cookie ensures client gets an expired cookie unless + # a new session is created and supercedes it + my $session = $self->session; + $session->expires(-86400); # yesterday + $engine->destroy( id => $session->id ); + + # Invalidate session cookie in request + # and clear session in app and engines + $self->set_destroyed_session($session); + $self->clear_session; + $_->clear_session for @{ $self->defined_engines }; + + return; +} + +sub setup_session { + my $self = shift; + + for my $engine ( @{ $self->defined_engines } ) { + $self->has_session ? + $engine->set_session( $self->session ) : + $engine->clear_session; + } +} + +sub change_session_id { + my $self = shift; + + my $session = $self->session; + + # Find the session engine + my $engine = $self->session_engine; + + if ($engine->can('_change_id')) { + + # session engine can change session ID + $engine->change_id( session => $session ); + } + else { + + # Method order is important in here... + # + # On session build if there is no destroyed session then the session + # builder tries to recreate the session using the existing session + # cookie. We really don't want to do that in this case so it is + # important to create the new session before the + # clear_destroyed_session method is called. + # + # This sucks. + # + # Sawyer suggested: + # + # What if you take the session cookie logic out of that attribute into + # another attribute and clear that attribute? + # That would force the session rebuilt to rebuilt the attribute and + # get a different cookie value, no? + # + # TODO: think about this some more. + + # grab data, destroy session and store data again + my %data = %{$session->data}; + + # destroy existing session + $self->destroy_session; + + # get new session + $session = $self->session; + + # write data from old session into new + # Some engines add session id to data so skip id. + while (my ($key, $value) = each %data ) { + $session->write($key => $value) unless $key eq 'id'; + } + + # clear out destroyed session - no longer relevant + $self->clear_destroyed_session; + } + + return $session->id; +} + +has prefix => ( + is => 'rw', + isa => Maybe [Dancer2Prefix], + predicate => 1, + coerce => sub { + my $prefix = shift; + defined($prefix) and $prefix eq "/" and return; + return $prefix; + }, +); + +# routes registry, stored by method: +has routes => ( + is => 'rw', + isa => HashRef, + default => sub { + { get => [], + head => [], + post => [], + put => [], + del => [], + options => [], + }; + }, +); + +has 'calling_class' => ( + 'is' => 'ro', + 'isa' => Str, + 'default' => sub { + my $class = ( caller(2) )[0] || + ( caller(1) )[0] || + ( caller(0) )[0]; + + return $class; + }, +); + +# add_hook will add the hook to the first "hook candidate" it finds that support +# it. If none, then it will try to add the hook to the current application. +around add_hook => sub { + my $orig = shift; + my $self = shift; + + # saving caller information + my ( $package, $file, $line ) = caller(4); # deep to 4 : user's app code + my $add_hook_caller = [ $package, $file, $line ]; + + my ($hook) = @_; + my $name = $hook->name; + my $hook_aliases = $self->all_hook_aliases; + + # look for an alias + defined $hook_aliases->{$name} and $name = $hook_aliases->{$name}; + $hook->name($name); + + # if that hook belongs to the app, register it now and return + $self->has_hook($name) and return $self->$orig(@_); + + # at this point the hook name must be formatted like: + # '$type.$candidate.$name', eg: 'engine.template.before_render' or + # 'plugin.database.before_dbi_connect' + my ( $hookable_type, $hookable_name, $hook_name ) = split( /\./, $name ); + + ( defined $hookable_name && defined $hook_name ) + or croak "Invalid hook name `$name'"; + + grep /^$hookable_type$/, qw(core engine handler plugin) + or croak "Unknown hook type `$hookable_type'"; + + # register the hooks for existing hookable candidates + foreach my $hookable ( $self->hook_candidates ) { + $hookable->has_hook($name) and $hookable->add_hook(@_); + } + + # we register the hook for upcoming objects; + # that way, each components that can claim the hook will have a chance + # to register it. + + my $postponed_hooks = $self->postponed_hooks; + + # Hmm, so the hook was not claimed, at this point we'll cache it and + # register it when the owner is instantiated + $postponed_hooks->{$hookable_type}{$hookable_name} ||= {}; + $postponed_hooks->{$hookable_type}{$hookable_name}{$name} ||= {}; + $postponed_hooks->{$hookable_type}{$hookable_name}{$name}{hook} = $hook; + $postponed_hooks->{$hookable_type}{$hookable_name}{$name}{caller} = + $add_hook_caller; + +}; + +around execute_hook => sub { + my $orig = shift; + my $self = shift; + + local $Dancer2::Core::Route::REQUEST = $self->request; + local $Dancer2::Core::Route::RESPONSE = $self->response; + + my ( $hook, @args ) = @_; + if ( !$self->has_hook($hook) ) { + foreach my $cand ( $self->hook_candidates ) { + $cand->has_hook($hook) and return $cand->execute_hook(@_); + } + } + + return $self->$orig(@_); +}; + +sub _build_default_config { + my $self = shift; + + my $public = $ENV{DANCER_PUBLIC} || path( $self->location, 'public' ); + return { + content_type => ( $ENV{DANCER_CONTENT_TYPE} || 'text/html' ), + charset => ( $ENV{DANCER_CHARSET} || '' ), + logger => ( $ENV{DANCER_LOGGER} || 'console' ), + views => ( $ENV{DANCER_VIEWS} + || path( $self->config_location, 'views' ) ), + environment => $self->environment, + appdir => $self->location, + public_dir => $public, + template => 'Tiny', + route_handlers => [ + [ + AutoPage => 1 + ], + ], + }; +} + +sub _init_hooks { + my $self = shift; + + # Hook to flush the session at the end of the request, + # this way, we're sure we flush only once per request + # + # Note: we create a weakened copy $self + # before closing over the weakened copy + # to avoid circular memory refs. + Scalar::Util::weaken(my $app = $self); + + $self->add_hook( + Dancer2::Core::Hook->new( + name => 'core.app.after_request', + code => sub { + my $response = $Dancer2::Core::Route::RESPONSE; + + # make sure an engine is defined, if not, nothing to do + my $engine = $app->session_engine; + defined $engine or return; + + # if a session has been instantiated or we already had a + # session, first flush the session so cookie-based sessions can + # update the session ID if needed, then set the session cookie + # in the response + # + # if there is NO session object but the request has a cookie with + # a session key, create a dummy session with the same ID (without + # actually retrieving and flushing immediately) and generate the + # cookie header from the dummy session. Lazy Sessions FTW! + + if ( $app->has_session ) { + my $session; + if ( $app->_has_session ) { # Session object exists + $session = $app->session; + $session->is_dirty and $engine->flush( session => $session ); + } + else { # Cookie header exists. Create a dummy session object + my $cookie = $app->cookie( $engine->cookie_name ); + my $session_id = $cookie->value; + $session = Dancer2::Core::Session->new( id => $session_id ); + } + $engine->set_cookie_header( + response => $response, + session => $session + ); + } + elsif ( $app->has_destroyed_session ) { + my $session = $app->destroyed_session; + $engine->set_cookie_header( + response => $response, + session => $session, + destroyed => 1 + ); + } + }, + ) + ); +} + +sub supported_hooks { + qw/ + core.app.before_request + core.app.after_request + core.app.route_exception + core.app.before_file_render + core.app.after_file_render + core.error.before + core.error.after + core.error.init + /; +} + +sub hook_aliases { + my $self = shift; + $self->{'hook_aliases'} ||= { + before => 'core.app.before_request', + before_request => 'core.app.before_request', + after => 'core.app.after_request', + after_request => 'core.app.after_request', + init_error => 'core.error.init', + before_error => 'core.error.before', + after_error => 'core.error.after', + on_route_exception => 'core.app.route_exception', + + before_file_render => 'core.app.before_file_render', + after_file_render => 'core.app.after_file_render', + before_handler_file_render => 'handler.file.before_render', + after_handler_file_render => 'handler.file.after_render', + + + # compatibility from Dancer1 + before_error_render => 'core.error.before', + after_error_render => 'core.error.after', + before_error_init => 'core.error.init', + + # TODO: call $engine->hook_aliases as needed + # But.. currently there are use cases where hook_aliases + # are needed before the engines are intiialized :( + before_template_render => 'engine.template.before_render', + after_template_render => 'engine.template.after_render', + before_layout_render => 'engine.template.before_layout_render', + after_layout_render => 'engine.template.after_layout_render', + before_serializer => 'engine.serializer.before', + after_serializer => 'engine.serializer.after', + }; +} + +sub defined_engines { + my $self = shift; + return [ + $self->template_engine, + $self->session_engine, + $self->logger_engine, + $self->has_serializer_engine + ? $self->serializer_engine + : (), + ]; +} + +# FIXME not needed anymore, I suppose... +sub api_version {2} + +sub register_plugin { + my $self = shift; + my $plugin = shift; + + $self->log( core => "Registered $plugin"); + + push @{ $self->plugins }, $plugin; +} + +# This method overrides the default one from Role::ConfigReader +sub settings { + my $self = shift; + +{ %{ Dancer2::runner()->config }, %{ $self->config } }; +} + +sub cleanup { + my $self = shift; + $self->clear_request; + $self->clear_response; + $self->clear_session; + $self->clear_destroyed_session; + # Clear engine attributes + for my $engine ( @{ $self->defined_engines } ) { + $engine->clear_session; + $engine->clear_request; + } +} + +sub _validate_engine { + my $self = shift; + my $name = shift; + + grep +( $_ eq $name ), @{ $self->supported_engines } + or croak "Engine '$name' is not supported."; +} + +sub engine { + my $self = shift; + my $name = shift; + + $self->_validate_engine($name); + + my $attr_name = "${name}_engine"; + return $self->$attr_name; +} + +sub template { + my $self = shift; + + my $template = $self->template_engine; + $template->set_settings( $self->config ); + + # A session will not exist if there is no request (global keyword) + # + # A session may exist but the route code may not have instantiated + # the session object (sessions are lazy). If this is the case, do + # that now, so the templates have the session data for rendering. + $self->has_request && $self->has_session && ! $template->has_session + and $self->setup_session; + + # return content + return $template->process( @_ ); +} + +sub hook_candidates { + my $self = shift; + + my @engines = @{ $self->defined_engines }; + + my @route_handlers; + for my $handler ( @{ $self->route_handlers } ) { + my $handler_code = $handler->{handler}; + blessed $handler_code and $handler_code->can('supported_hooks') + and push @route_handlers, $handler_code; + } + + # TODO : get the list of all plugins registered + my @plugins = @{ $self->plugins }; + + ( @route_handlers, @engines, @plugins ); +} + +sub all_hook_aliases { + my $self = shift; + + my $aliases = $self->hook_aliases; + for my $plugin ( grep { $_->can('hook_aliases') } @{ $self->plugins } ) { + $aliases = { %{$aliases}, %{ $plugin->hook_aliases } }; + } + + return $aliases; +} + +sub mime_type { + my $self = shift; + my $runner = Dancer2::runner(); + + exists $self->config->{default_mime_type} + ? $runner->mime_type->default( $self->config->{default_mime_type} ) + : $runner->mime_type->reset_default; + + $runner->mime_type; +} + +sub log { + my $self = shift; + my $level = shift; + + my $logger = $self->logger_engine + or croak "No logger defined"; + + $logger->$level(@_); +} + +sub send_as { + my $self = shift; + my ( $type, $data, $options ) = @_; + $options ||= {}; + + $type or croak "Can not send_as using an undefined type"; + + if ( lc($type) eq 'html' ) { + if ( $type ne 'html' ) { + local $Carp::CarpLevel = 2; + carp "Please use 'html' as the type for 'send_as', not $type"; + } + + $options->{charset} = $self->config->{charset} || 'UTF-8'; + my $content = Encode::encode( $options->{charset}, $data ); + $options->{content_type} ||= 'text/html'; + $self->send_file( \$content, %$options ); # returns from sub + } + + # Try and load the serializer class + my $serializer_class = "Dancer2::Serializer::$type"; + eval { + $EVAL_SHIM->(sub { + require_module( $serializer_class ); + }); + 1; + } or do { + my $err = $@ || "Zombie Error"; + croak "Unable to load serializer class for $type: $err"; + }; + + # load any serializer engine config + my $engine_options = + $self->_get_config_for_engine( serializer => $type, $self->config ) || {}; + my $serializer = $serializer_class->new( config => $engine_options ); + my $content = $serializer->serialize( $data ); + $options->{content_type} ||= $serializer->content_type; + $self->send_file( \$content, %$options ); +} + +sub send_error { + my $self = shift; + my ( $message, $status ) = @_; + + my $err = Dancer2::Core::Error->new( + message => $message, + app => $self, + ( status => $status )x!! $status, + + $self->has_serializer_engine + ? ( serializer => $self->serializer_engine ) + : (), + )->throw; + + # Immediately return to dispatch if with_return coderef exists + $self->has_with_return && $self->with_return->($err); + return $err; +} + +sub send_file { + my $self = shift; + my $thing = shift; + my %options = @_; + + my ($content_type, $charset, $file_path); + + # are we're given a filehandle? (based on what Plack::Middleware::Lint accepts) + my $is_filehandle = Plack::Util::is_real_fh($thing) + || ( is_globref($thing) && *{$thing}{IO} && *{$thing}{IO}->can('getline') ) + || ( Scalar::Util::blessed($thing) && $thing->can('getline') ); + my ($fh) = ($thing)x!! $is_filehandle; + + # if we're given an IO::Scalar object, DTRT (take the scalar ref from it) + if (Scalar::Util::blessed($thing) && $thing->isa('IO::Scalar')) { + $thing = $thing->sref; + } + + # if we're given a SCALAR reference, build a filehandle to it + if ( is_scalarref($thing) ) { + ## no critic qw(InputOutput::RequireCheckedOpen) + open $fh, "<", $thing; + } + + # If we haven't got a filehandle, create one to the requested content + if (! $fh) { + my $path = $thing; + # remove prefix from given path (if not a filehandle) + my $prefix = $self->prefix; + if ( $prefix && $prefix ne '/' ) { + $path =~ s/^\Q$prefix\E//; + } + # static file dir - either system root or public_dir + my $dir = $options{system_path} + ? File::Spec->rootdir + : $ENV{DANCER_PUBLIC} + || $self->config->{public_dir} + || path( $self->location, 'public' ); + + $file_path = Dancer2::Handler::File->merge_paths( $path, $dir ); + my $err_response = sub { + my $status = shift; + $self->response->status($status); + $self->response->header( 'Content-Type', 'text/plain' ); + $self->response->content( Dancer2::Core::HTTP->status_message($status) ); + $self->with_return->( $self->response ); + }; + $err_response->(403) if !defined $file_path; + $err_response->(404) if !-f $file_path; + $err_response->(403) if !-r $file_path; + + # Read file content as bytes + $fh = Dancer2::FileUtils::open_file( "<", $file_path ); + binmode $fh; + $content_type = Dancer2::runner()->mime_type->for_file($file_path) || 'text/plain'; + if ( $content_type =~ m!^text/! ) { + $charset = $self->config->{charset} || "utf-8"; + } + } + + # Now we are sure we can render the file... + $self->execute_hook( 'core.app.before_file_render', $file_path ); + + # response content type and charset + ( exists $options{'content_type'} ) and $content_type = $options{'content_type'}; + ( exists $options{'charset'} ) and $charset = $options{'charset'}; + $content_type .= "; charset=$charset" if $content_type and $charset; + ( defined $content_type ) + and $self->response->header('Content-Type' => $content_type ); + + # content disposition + ( exists $options{filename} ) + and $self->response->header( 'Content-Disposition' => + ($options{content_disposition} || "attachment") . "; filename=\"$options{filename}\"" ); + + # use a delayed response unless server does not support streaming + my $use_streaming = exists $options{streaming} ? $options{streaming} : 1; + my $response; + my $env = $self->request->env; + if ( $env->{'psgi.streaming'} && $use_streaming ) { + my $cb = sub { + my $responder = $Dancer2::Core::Route::RESPONDER; + my $res = $Dancer2::Core::Route::RESPONSE; + return $responder->( + [ $res->status, $res->headers_to_array, $fh ] + ); + }; + + Scalar::Util::weaken( my $weak_self = $self ); + + $response = Dancer2::Core::Response::Delayed->new( + error_cb => sub { $weak_self->logger_engine->log( warning => @_ ) }, + cb => $cb, + request => $Dancer2::Core::Route::REQUEST, + response => $Dancer2::Core::Route::RESPONSE, + ); + } + else { + $response = $self->response; + # direct assignment to hash element, avoids around modifier + # trying to serialise this this content. + $response->{content} = Dancer2::FileUtils::read_glob_content($fh); + $response->is_encoded(1); # bytes are already encoded + } + + $self->execute_hook( 'core.app.after_file_render', $response ); + $self->with_return->( $response ); +} + +sub BUILD { + my $self = shift; + $self->init_route_handlers(); + $self->_init_hooks(); +} + +sub finish { + my $self = shift; + + # normalize some values that require calculations + defined $self->config->{'static_handler'} + or $self->config->{'static_handler'} = -d $self->config->{'public_dir'}; + + $self->register_route_handlers; + $self->compile_hooks; + + @{$self->plugins} + && $self->plugins->[0]->can('_add_postponed_plugin_hooks') + && $self->plugins->[0]->_add_postponed_plugin_hooks( + $self->postponed_hooks + ); + + $self->calling_class->can('prepare_app') + and warn "WARNING: You have a subroutine in your " + . "app called 'prepare_app'. In the future " + . "this will automatically be called by Dancer2."; +} + +sub init_route_handlers { + my $self = shift; + + my $handlers_config = $self->config->{route_handlers}; + for my $handler_data ( @{$handlers_config} ) { + my ($handler_name, $config) = @{$handler_data}; + $config = {} if !is_ref($config); + + my $handler = $self->_factory->create( + Handler => $handler_name, + app => $self, + %$config, + postponed_hooks => $self->postponed_hooks, + ); + + push @{ $self->route_handlers }, { + name => $handler_name, + handler => $handler, + }; + } +} + +sub register_route_handlers { + my $self = shift; + for my $handler ( @{$self->route_handlers} ) { + my $handler_code = $handler->{handler}; + $handler_code->register($self); + } +} + +sub compile_hooks { + my ($self) = @_; + + for my $position ( $self->supported_hooks ) { + my $compiled_hooks = []; + for my $hook ( @{ $self->hooks->{$position} } ) { + Scalar::Util::weaken( my $app = $self ); + my $compiled = sub { + # don't run the filter if halt has been used + $Dancer2::Core::Route::RESPONSE && + $Dancer2::Core::Route::RESPONSE->is_halted + and return; + + eval { $EVAL_SHIM->($hook,@_); 1; } + or do { + my $err = $@ || "Zombie Error"; + $app->cleanup; + $app->log('error', "Exception caught in '$position' filter: $err"); + croak "Exception caught in '$position' filter: $err"; + }; + }; + + push @{$compiled_hooks}, $compiled; + } + $self->replace_hook( $position, $compiled_hooks ); + } +} + +sub lexical_prefix { + my $self = shift; + my $prefix = shift; + my $cb = shift; + + $prefix eq '/' and undef $prefix; + + # save the app prefix + my $app_prefix = $self->prefix; + + # alter the prefix for the callback + my $new_prefix = + ( defined $app_prefix ? $app_prefix : '' ) + . ( defined $prefix ? $prefix : '' ); + + # if the new prefix is empty, it's a meaningless prefix, just ignore it + length $new_prefix and $self->prefix($new_prefix); + + my $err; + my $ok= eval { $EVAL_SHIM->($cb); 1 } + or do { $err = $@ || "Zombie Error"; }; + + # restore app prefix + $self->prefix($app_prefix); + + $ok or croak "Unable to run the callback for prefix '$prefix': $err"; +} + +sub add_route { + my $self = shift; + my %route_attrs = @_; + + my $route = + Dancer2::Core::Route->new( %route_attrs, prefix => $self->prefix ); + + my $method = $route->method; + + push @{ $self->routes->{$method} }, $route; + + return $route; +} + +sub route_exists { + my $self = shift; + my $route = shift; + + my $routes = $self->routes->{ $route->method }; + + foreach my $existing_route (@$routes) { + $existing_route->spec_route eq $route->spec_route + and return 1; + } + + return 0; +} + +sub routes_regexps_for { + my $self = shift; + my $method = shift; + + return [ map $_->regexp, @{ $self->routes->{$method} } ]; +} + +sub cookie { + my $self = shift; + + @_ == 1 and return $self->request->cookies->{ $_[0] }; + + # writer + my ( $name, $value, %options ) = @_; + my $c = + Dancer2::Core::Cookie->new( name => $name, value => $value, %options ); + $self->response->push_header( 'Set-Cookie' => $c->to_header ); +} + +sub redirect { + my $self = shift; + my $destination = shift; + my $status = shift; + + # RFC 2616 requires an absolute URI with a scheme, + # turn the URI into that if it needs it + + # Scheme grammar as defined in RFC 2396 + # scheme = alpha *( alpha | digit | "+" | "-" | "." ) + my $scheme_re = qr{ [a-z][a-z0-9\+\-\.]* }ix; + if ( $destination !~ m{^ $scheme_re : }x ) { + $destination = $self->request->uri_for( $destination, {}, 1 ); + } + + $self->response->redirect( $destination, $status ); + + # Short circuit any remaining before hook / route code + # ('pass' and after hooks are still processed) + $self->has_with_return + and $self->with_return->($self->response); +} + +sub halt { + my $self = shift; + $self->response->halt( @_ ); + + # Short citcuit any remaining hook/route code + $self->has_with_return + and $self->with_return->($self->response); +} + +sub pass { + my $self = shift; + $self->response->pass; + + # Short citcuit any remaining hook/route code + $self->has_with_return + and $self->with_return->($self->response); +} + +sub forward { + my $self = shift; + my $url = shift; + my $params = shift; + my $options = shift; + + my $new_request = $self->make_forward_to( $url, $params, $options ); + + $self->has_with_return + and $self->with_return->($new_request); + + # nothing else will run after this +} + +# Create a new request which is a clone of the current one, apart +# from the path location, which points instead to the new location +sub make_forward_to { + my $self = shift; + my $url = shift; + my $params = shift; + my $options = shift; + + my $overrides = { PATH_INFO => $url }; + exists $options->{method} and + $overrides->{REQUEST_METHOD} = $options->{method}; + + # "clone" the existing request + my $new_request = $self->request->_shallow_clone( $params, $overrides ); + + # If a session object was created during processing of the original request + # i.e. a session object exists but no cookie existed + # add a cookie so the dispatcher can assign the session to the appropriate app + my $engine = $self->session_engine; + $engine && $self->_has_session or return $new_request; + my $name = $engine->cookie_name; + exists $new_request->cookies->{$name} and return $new_request; + $new_request->cookies->{$name} = + Dancer2::Core::Cookie->new( name => $name, value => $self->session->id ); + + return $new_request; +} + +sub app { shift } + +# DISPATCHER +sub to_app { + my $self = shift; + + # build engines + { + for ( qw ) { + my $attr = "${_}_engine"; + $self->$attr; + } + + # the serializer engine does not have a default + # and is the only engine that can actually not have a value + if ( $self->config->{'serializer'} ) { + $self->serializer_engine; + } + } + + $self->finish; + + my $psgi = sub { + my $env = shift; + + # pre-request sanity check + my $method = uc $env->{'REQUEST_METHOD'}; + $Dancer2::Core::Types::supported_http_methods{$method} + or return [ + 405, + [ 'Content-Type' => 'text/plain' ], + [ "Method Not Allowed\n\n$method is not supported." ] + ]; + + my $response; + eval { + $EVAL_SHIM->(sub{ $response = $self->dispatch($env)->to_psgi }); + 1; + } or do { + my $err = $@ || "Zombie Error"; + return [ + 500, + [ 'Content-Type' => 'text/plain' ], + [ "Internal Server Error\n\n$err" ], + ]; + }; + + return $response; + }; + + # Wrap with common middleware + # FixMissingBodyInRedirect + $psgi = Plack::Middleware::FixMissingBodyInRedirect->wrap( $psgi ); + + # Only add static content handler if requires + if ( $self->config->{'static_handler'} ) { + # Use App::File to "serve" the static content + my $static_app = Plack::App::File->new( + root => $self->config->{public_dir}, + content_type => sub { $self->mime_type->for_name(shift) }, + )->to_app; + # Conditionally use the static handler wrapped with ConditionalGET + # when the file exists. Otherwise the request passes into our app. + $psgi = Plack::Middleware::Conditional->wrap( + $psgi, + condition => sub { -f path( $self->config->{public_dir}, shift->{PATH_INFO} ) }, + builder => sub { Plack::Middleware::ConditionalGET->wrap( $static_app ) }, + ); + } + + # Apply Head. After static so a HEAD request on static content DWIM. + $psgi = Plack::Middleware::Head->wrap( $psgi ); + return $psgi; +} + +sub dispatch { + my $self = shift; + my $env = shift; + + my $runner = Dancer2::runner(); + my $request = $runner->{'internal_request'} || + $self->build_request($env); + my $cname = $self->session_engine->cookie_name; + + my $defined_engines = $self->defined_engines; + +DISPATCH: + while (1) { + my $http_method = lc $request->method; + my $path_info = $request->path_info; + + # Add request to app and engines + $self->set_request($request, $defined_engines); + + $self->log( core => "looking for $http_method $path_info" ); + + ROUTE: + foreach my $route ( @{ $self->routes->{$http_method} } ) { + #warn "testing route " . $route->regexp . "\n"; + # TODO store in route cache + + # go to the next route if no match + my $match = $route->match($request) + or next ROUTE; + + $request->_set_route_params($match); + $request->_set_route_parameters($match); + $request->_set_route($route); + + # Add session to app *if* we have a session and the request + # has the appropriate cookie header for _this_ app. + if ( my $sess = $runner->{'internal_sessions'}{$cname} ) { + $self->set_session($sess); + } + + # calling the actual route + my $response = Return::MultiLevel::with_return { + my ($return) = @_; + + # stash the multilevel return coderef in the app + $self->has_with_return + or $self->set_with_return($return); + + return $self->_dispatch_route($route); + }; + + # ensure we clear the with_return handler + $self->clear_with_return; + + # handle forward requests + if ( ref $response eq 'Dancer2::Core::Request' ) { + # this is actually a request, not response + # however, we need to clean up the request & response + $self->clear_request; + $self->clear_response; + + # this is in case we're asked for an old-style dispatching + if ( $runner->{'internal_dispatch'} ) { + # Get the session object from the app before we clean up + # the request context, so we can propagate this to the + # next dispatch cycle (if required). + $self->_has_session + and $runner->{'internal_sessions'}{$cname} = + $self->session; + + $runner->{'internal_forward'} = 1; + $runner->{'internal_request'} = $response; + return $self->response_not_found($request); + } + + $request = $response; + next DISPATCH; + } + + # from here we assume the response is a Dancer2::Core::Response + + # halted response, don't process further + if ( $response->is_halted ) { + $self->cleanup; + delete $runner->{'internal_request'}; + return $response; + } + + # pass the baton if the response says so... + if ( $response->has_passed ) { + ## A previous route might have used splat, failed + ## this needs to be cleaned from the request. + exists $request->{_params}{splat} + and delete $request->{_params}{splat}; + + $response->has_passed(0); # clear for the next round + + # clear the content because if you pass it, + # the next route is in charge of catching it + $response->clear_content; + next ROUTE; + } + + # it's just a regular response + $self->execute_hook( 'core.app.after_request', $response ); + $self->cleanup; + delete $runner->{'internal_request'}; + + return $response; + } + + # we don't actually want to continue the loop + last; + } + + # No response! ensure Core::Dispatcher recognizes this failure + # so it can try the next Core::App + # and set the created request so we don't create it again + # (this is important so we don't ignore the previous body) + if ( $runner->{'internal_dispatch'} ) { + $runner->{'internal_404'} = 1; + $runner->{'internal_request'} = $request; + } + + # Render 404 response, cleanup, and return the response. + my $response = $self->response_not_found($request); + $self->cleanup; + return $response; +} + +sub build_request { + my ( $self, $env ) = @_; + + # If we have an app, send the serialization engine + my $request = Dancer2::Core::Request->new( + env => $env, + is_behind_proxy => $self->settings->{'behind_proxy'} || 0, + + $self->has_serializer_engine + ? ( serializer => $self->serializer_engine ) + : (), + ); + + return $request; +} + +# Call any before hooks then the matched route. +sub _dispatch_route { + my ( $self, $route ) = @_; + + local $@; + eval { + $EVAL_SHIM->(sub { + $self->execute_hook( 'core.app.before_request', $self ); + }); + 1; + } or do { + my $err = $@ || "Zombie Error"; + return $self->response_internal_error($err); + }; + my $response = $self->response; + + if ( $response->is_halted ) { + return $self->_prep_response( $response ); + } + + eval { + $EVAL_SHIM->(sub{ $response = $route->execute($self) }); + 1; + } or do { + my $err = $@ || "Zombie Error"; + return $self->response_internal_error($err); + }; + + return $response; +} + +sub _prep_response { + my ( $self, $response, $content ) = @_; + + # The response object has no back references to the content or app + # Update the default_content_type of the response if any value set in + # config so it can be applied when the response is encoded/returned. + my $config = $self->config; + if ( exists $config->{content_type} + and my $ct = $config->{content_type} ) { + $response->default_content_type($ct); + } + + # if we were passed any content, set it in the response + defined $content && $response->content($content); + return $response; +} + +sub response_internal_error { + my ( $self, $error ) = @_; + + $self->execute_hook( 'core.app.route_exception', $self, $error ); + $self->log( error => "Route exception: $error" ); + + local $Dancer2::Core::Route::REQUEST = $self->request; + local $Dancer2::Core::Route::RESPONSE = $self->response; + + return Dancer2::Core::Error->new( + app => $self, + status => 500, + exception => $error, + )->throw; +} + +sub response_not_found { + my ( $self, $request ) = @_; + + $self->set_request($request); + + local $Dancer2::Core::Route::REQUEST = $self->request; + local $Dancer2::Core::Route::RESPONSE = $self->response; + + my $response = Dancer2::Core::Error->new( + app => $self, + status => 404, + message => $request->path, + )->throw; + + $self->cleanup; + + return $response; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::App - encapsulation of Dancer2 packages + +=head1 VERSION + +version 0.206000 + +=head1 DESCRIPTION + +Everything a package that uses Dancer2 does is encapsulated into a +C instance. This class defines all that can be done in such +objects. + +Mainly, it will contain all the route handlers, the configuration settings and +the hooks that are defined in the calling package. + +Note that with Dancer2, everything that is done within a package is scoped to +that package, thanks to that encapsulation. + +=head1 ATTRIBUTES + +=head2 plugins + +=head2 runner_config + +=head2 default_config + +=head2 with_return + +Used to cache the coderef from L within the dispatcher. + +=head2 destroyed_session + +We cache a destroyed session here; once this is set we must not attempt to +retrieve the session from the cookie in the request. If no new session is +created, this is set (with expiration) as a cookie to force the browser to +expire the cookie. + +=head1 METHODS + +=head2 has_session + +Returns true if session engine has been defined and if either a session +object has been instantiated or if a session cookie was found and not +subsequently invalidated. + +=head2 change_session_id + +Changes the session ID used by the current session. This should be used on +any change of privilege level, for example on login. Returns the new session +ID. + +=head2 destroy_session + +Destroys the current session and ensures any subsequent session is created +from scratch and not from the request session cookie + +=head2 register_plugin + +=head2 with_plugins( @plugin_names ) + +Creates instances of the given plugins and tie them to the app. +The plugin classes are automatically loaded. +Returns the newly created plugins. + +The plugin names are expected to be without the leading C. +I.e., use C to mean C. + +If a given plugin is already tied to the app, the already-existing +instance will be used and returned by C (think of it +as using a role). + + my @plugins = $app->with_plugins( 'Foo', 'Bar' ); + + # now $app uses the plugins Dancer2::Plugin::Foo + # and Dancer2::Plugin::Bar + +=head2 with_plugin( $plugin_name ) + +Just like C, but for a single plugin. + + my $plugin = $app->with_plugin('Foo'); + +=head2 redirect($destination, $status) + +Sets a redirect in the response object. If $destination is not an absolute URI, then it will +be made into an absolute URI, relative to the URI in the request. + +=head2 halt + +Flag the response object as 'halted'. + +If called during request dispatch, immediately returns the response +to the dispatcher and after hooks will not be run. + +=head2 pass + +Flag the response object as 'passed'. + +If called during request dispatch, immediately returns the response +to the dispatcher. + +=head2 forward + +Create a new request which is a clone of the current one, apart +from the path location, which points instead to the new location. +This is used internally to chain requests using the forward keyword. + +This method takes 3 parameters: the url to forward to, followed by an +optional hashref of parameters added to the current request parameters, +followed by a hashref of options regarding the redirect, such as +C to change the request method. + +For example: + + forward '/login', { login_failed => 1 }, { method => 'GET' }); + +=head2 lexical_prefix + +Allow for setting a lexical prefix + + $app->lexical_prefix('/blog', sub { + ... + }); + +All the route defined within the callback will have a prefix appended to the +current one. + +=head2 add_route + +Register a new route handler. + + $app->add_route( + method => 'get', + regexp => '/somewhere', + code => sub { ... }, + options => $conditions, + ); + +=head2 route_exists + +Check if a route already exists. + + my $route = Dancer2::Core::Route->new(...); + if ($app->route_exists($route)) { + ... + } + +=head2 routes_regexps_for + +Sugar for getting the ordered list of all registered route regexps by method. + + my $regexps = $app->routes_regexps_for( 'get' ); + +Returns an ArrayRef with the results. + +=head2 app + +Returns itself. This is simply available as a shim to help transition from +a previous version in which hooks were sent a context object (originally +C) which has since been removed. + + # before + hook before => sub { + my $ctx = shift; + my $app = $ctx->app; + }; + + # after + hook before => sub { + my $app = shift; + }; + +This meant that C<< $app->app >> would fail, so this method has been provided +to make it work. + + # now + hook before => sub { + my $WannaBeCtx = shift; + my $app = $WannaBeContext->app; # works + }; + +=head2 C< $SIG{__DIE__} > Compatibility via C< $Dancer2::Core::App::EVAL_SHIM > + +If an installation wishes to use C< $SIG{__DIE__} > hooks to enhance +their error handling then it may be required to ensure that certain +bookkeeping code is executed within every C that Dancer2 +performs. This can be accomplished by overriding the global variable +C<$Dancer2::Core::App::EVAL_SHIM> with a subroutine which does whatever +logic is required. + +This routine must perform the equivalent of the following subroutine: + + our $EVAL_SHIM = sub { + my $code = shift; + return $code->(@_); + }; + +An example of overriding this sub might be as follows: + + $Dancer2::Core::App::EVAL_SHIM = sub { + my $code = shift; + local $IGNORE_EVAL_COUNTER = $IGNORE_EVAL_COUNTER + 1; + return $code->(@_); + }; + +B that this is a GLOBAL setting, which must be set up before +any form of dispatch or use of Dancer2. + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Cookie.pm b/cpanlib/Dancer2/Core/Cookie.pm new file mode 100644 index 0000000..f3eb753 --- /dev/null +++ b/cpanlib/Dancer2/Core/Cookie.pm @@ -0,0 +1,250 @@ +package Dancer2::Core::Cookie; +# ABSTRACT: A cookie representing class +$Dancer2::Core::Cookie::VERSION = '0.206000'; +use Moo; +use URI::Escape; +use Dancer2::Core::Types; +use Dancer2::Core::Time; +use Carp 'croak'; +use Ref::Util qw< is_arrayref is_hashref >; +use overload '""' => \&_get_value; + +BEGIN { + my $try_xs = + exists($ENV{PERL_HTTP_XSCOOKIES}) ? !!$ENV{PERL_HTTP_XSCOOKIES} : + exists($ENV{PERL_ONLY}) ? !$ENV{PERL_ONLY} : + 1; + + my $use_xs = 0; + $try_xs and eval { + require HTTP::XSCookies; + $use_xs++; + }; + if ( $use_xs ) { + *to_header = \&xs_to_header; + } + else { + *to_header = \&pp_to_header; + } + *_USE_XS = $use_xs ? sub () { !!1 } : sub () { !!0 }; +} + +sub xs_to_header { + my $self = shift; + + # HTTP::XSCookies can't handle multi-value cookies. + return $self->pp_to_header(@_) if @{[ $self->value ]} > 1; + + return HTTP::XSCookies::bake_cookie( + $self->name, + { value => $self->value, + path => $self->path, + domain => $self->domain, + expires => $self->expires, + httponly => !!$self->http_only, # HTTP::XSCookies seems to distinguish between '"0"' and '0' + secure => $self->secure, + samesite => $self->same_site, + } + ); +} + +sub pp_to_header { + my $self = shift; + + my $value = join( '&', map uri_escape($_), $self->value ); + my $no_httponly = defined( $self->http_only ) && $self->http_only == 0; + + my @headers = $self->name . '=' . $value; + push @headers, "Path=" . $self->path if $self->path; + push @headers, "Expires=" . $self->expires if $self->expires; + push @headers, "Domain=" . $self->domain if $self->domain; + push @headers, "SameSite=" . $self->same_site if $self->same_site; + push @headers, "Secure" if $self->secure; + push @headers, 'HttpOnly' unless $no_httponly; + + return join '; ', @headers; +} + +has value => ( + is => 'rw', + isa => ArrayRef, + required => 0, + coerce => sub { + my $value = shift; + my @values = + is_arrayref($value) ? @$value + : is_hashref($value) ? %$value + : ($value); + return [@values]; + }, +); + +around value => sub { + my $orig = shift; + my $self = shift; + my $array = $orig->( $self, @_ ); + return wantarray ? @$array : $array->[0]; +}; + +# this is only for overloading; need a real sub to refer to, as the Moose +# attribute accessor won't be available at that point. +sub _get_value { shift->value } + +has name => ( + is => 'rw', + isa => Str, + required => 1, +); + +has expires => ( + is => 'rw', + isa => Str, + required => 0, + coerce => sub { + Dancer2::Core::Time->new( expression => $_[0] )->gmt_string; + }, +); + +has domain => ( + is => 'rw', + isa => Str, + required => 0, +); + +has path => ( + is => 'rw', + isa => Str, + default => sub {'/'}, + predicate => 1, +); + +has secure => ( + is => 'rw', + isa => Bool, + required => 0, + default => sub {0}, +); + +has http_only => ( + is => 'rw', + isa => Bool, + required => 0, + default => sub {1}, +); + +has same_site => ( + is => 'rw', + isa => Enum[qw[Strict Lax]], + required => 0, +); + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Cookie - A cookie representing class + +=head1 VERSION + +version 0.206000 + +=head1 SYNOPSIS + + use Dancer2::Core::Cookie; + + my $cookie = Dancer2::Core::Cookie->new( + name => $cookie_name, value => $cookie_value + ); + + my $value = $cookie->value; + + print "$cookie"; # objects stringify to their value. + +=head1 DESCRIPTION + +Dancer2::Core::Cookie provides a HTTP cookie object to work with cookies. + +=head1 ATTRIBUTES + +=head2 value + +The cookie's value. + +(Note that cookie objects use overloading to stringify to their value, so if +you say e.g. return "Hi, $cookie", you'll get the cookie's value there.) + +In list context, returns a list of potentially multiple values; in scalar +context, returns just the first value. (So, if you expect a cookie to have +multiple values, use list context.) + +=head2 name + +The cookie's name. + +=head2 expires + +The cookie's expiration date. There are several formats. + +Unix epoch time like 1288817656 to mean "Wed, 03-Nov-2010 20:54:16 GMT" + +It also supports a human readable offset from the current time such as "2 hours". +See the documentation of L for details of all supported +formats. + +=head2 domain + +The cookie's domain. + +=head2 path + +The cookie's path. + +=head2 secure + +If true, it instructs the client to only serve the cookie over secure +connections such as https. + +=head2 http_only + +By default, cookies are created with a property, named C, +that can be used for security, forcing the cookie to be used only by +the server (via HTTP) and not by any JavaScript code. + +If your cookie is meant to be used by some JavaScript code, set this +attribute to 0. + +=head2 same_site + +Whether the cookie ought not to be sent along with cross-site requests, +an enum of either "Strict" or "Lax", default is unset. + +=head1 METHODS + +=head2 my $cookie=Dancer2::Core::Cookie->new(%opts); + +Create a new Dancer2::Core::Cookie object. + +You can set any attribute described in the I section above. + +=head2 my $header=$cookie->to_header(); + +Creates a proper HTTP cookie header from the content. + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/DSL.pm b/cpanlib/Dancer2/Core/DSL.pm new file mode 100644 index 0000000..02ec08c --- /dev/null +++ b/cpanlib/Dancer2/Core/DSL.pm @@ -0,0 +1,551 @@ +# ABSTRACT: Dancer2's Domain Specific Language (DSL) + +package Dancer2::Core::DSL; +$Dancer2::Core::DSL::VERSION = '0.206000'; +use Moo; +use Carp; +use Module::Runtime 'require_module'; +use Ref::Util qw< is_arrayref >; +use Dancer2::Core::Hook; +use Dancer2::FileUtils; +use Dancer2::Core::Response::Delayed; + +with 'Dancer2::Core::Role::DSL'; + +sub hook_aliases { +{} } +sub supported_hooks { () } + +sub _add_postponed_plugin_hooks { + my ( $self, $postponed_hooks) = @_; + + $postponed_hooks = $postponed_hooks->{'plugin'}; + return unless defined $postponed_hooks; + + for my $plugin ( keys %{$postponed_hooks} ) { + for my $name ( keys %{$postponed_hooks->{$plugin} } ) { + my $hook = $postponed_hooks->{$plugin}{$name}{hook}; + my $caller = $postponed_hooks->{$plugin}{$name}{caller}; + + $self->has_hook($name) + or croak "plugin $plugin does not support the hook `$name'. (" + . join( ", ", @{$caller} ) . ")"; + + $self->add_hook($hook); + } + } +} + +sub dsl_keywords { + + # the flag means : 1 = is global, 0 = is not global. global means can be + # called from anywhere. not global means must be called from within a route + # handler + { any => { is_global => 1 }, + app => { is_global => 1 }, + captures => { is_global => 0 }, + config => { is_global => 1 }, + content => { is_global => 0 }, + content_type => { is_global => 0 }, + context => { is_global => 0 }, + cookie => { is_global => 0 }, + cookies => { is_global => 0 }, + dance => { is_global => 1 }, + dancer_app => { is_global => 1 }, + dancer_version => { is_global => 1 }, + dancer_major_version => { is_global => 1 }, + debug => { is_global => 1 }, + decode_json => { is_global => 1 }, + del => { is_global => 1 }, + delayed => { + is_global => 0, prototype => '&@', + }, + dirname => { is_global => 1 }, + done => { is_global => 0 }, + dsl => { is_global => 1 }, + encode_json => { is_global => 1 }, + engine => { is_global => 1 }, + error => { is_global => 1 }, + false => { is_global => 1 }, + flush => { is_global => 0 }, + forward => { is_global => 0 }, + from_dumper => { is_global => 1 }, + from_json => { is_global => 1 }, + from_yaml => { is_global => 1 }, + get => { is_global => 1 }, + halt => { is_global => 0 }, + header => { is_global => 0 }, + headers => { is_global => 0 }, + hook => { is_global => 1 }, + info => { is_global => 1 }, + log => { is_global => 1 }, + mime => { is_global => 1 }, + options => { is_global => 1 }, + param => { is_global => 0 }, + params => { is_global => 0 }, + query_parameters => { is_global => 0 }, + body_parameters => { is_global => 0 }, + route_parameters => { is_global => 0 }, + pass => { is_global => 0 }, + patch => { is_global => 1 }, + path => { is_global => 1 }, + post => { is_global => 1 }, + prefix => { is_global => 1 }, + psgi_app => { is_global => 1 }, + push_header => { is_global => 0 }, + push_response_header => { is_global => 0 }, + put => { is_global => 1 }, + redirect => { is_global => 0 }, + request => { is_global => 0 }, + request_header => { is_global => 0 }, + response => { is_global => 0 }, + response_header => { is_global => 0 }, + response_headers => { is_global => 0 }, + runner => { is_global => 1 }, + send_as => { is_global => 0 }, + send_error => { is_global => 0 }, + send_file => { is_global => 0 }, + session => { is_global => 0 }, + set => { is_global => 1 }, + setting => { is_global => 1 }, + splat => { is_global => 0 }, + start => { is_global => 1 }, + status => { is_global => 0 }, + template => { is_global => 1 }, + to_app => { is_global => 1 }, + to_dumper => { is_global => 1 }, + to_json => { is_global => 1 }, + to_yaml => { is_global => 1 }, + true => { is_global => 1 }, + upload => { is_global => 0 }, + uri_for => { is_global => 0 }, + var => { is_global => 0 }, + vars => { is_global => 0 }, + warning => { is_global => 1 }, + }; +} + +sub dancer_app { shift->app } +sub dancer_version { Dancer2->VERSION } + +sub dancer_major_version { + return ( split /\./, dancer_version )[0]; +} + +sub log { shift->app->log( @_ ) } +sub debug { shift->app->log( debug => @_ ) } +sub info { shift->app->log( info => @_ ) } +sub warning { shift->app->log( warning => @_ ) } +sub error { shift->app->log( error => @_ ) } + +sub true {1} +sub false {0} + +sub dirname { shift and Dancer2::FileUtils::dirname(@_) } +sub path { shift and Dancer2::FileUtils::path(@_) } + +sub config { shift->app->settings } + +sub engine { shift->app->engine(@_) } + +sub setting { shift->app->setting(@_) } + +sub set { shift->setting(@_) } + +sub template { shift->app->template(@_) } + +sub session { + my ( $self, $key, $value ) = @_; + + # shortcut reads if no session exists, so we don't + # instantiate sessions for no reason + if ( @_ == 2 ) { + return unless $self->app->has_session; + } + + my $session = $self->app->session + || croak "No session available, a session engine needs to be set"; + + $self->app->setup_session; + + # return the session object if no key + @_ == 1 and return $session; + + # read if a key is provided + @_ == 2 and return $session->read($key); + + + # write to the session or delete if value is undef + if ( defined $value ) { + $session->write( $key => $value ); + } + else { + $session->delete($key); + } +} + +sub send_as { shift->app->send_as(@_) } + +sub send_error { shift->app->send_error(@_) } + +sub send_file { shift->app->send_file(@_) } + +# +# route handlers & friends +# + +sub hook { + my ( $self, $name, $code ) = @_; + $self->app->add_hook( + Dancer2::Core::Hook->new( name => $name, code => $code ) ); +} + +sub prefix { + my $app = shift->app; + @_ == 1 + ? $app->prefix(@_) + : $app->lexical_prefix(@_); +} + +sub halt { shift->app->halt(@_) } + +sub del { shift->_normalize_route( [qw/delete /], @_ ) } +sub get { shift->_normalize_route( [qw/get head/], @_ ) } +sub options { shift->_normalize_route( [qw/options /], @_ ) } +sub patch { shift->_normalize_route( [qw/patch /], @_ ) } +sub post { shift->_normalize_route( [qw/post /], @_ ) } +sub put { shift->_normalize_route( [qw/put /], @_ ) } + +sub any { + my $self = shift; + + # If they've supplied their own list of methods, + # expand del, otherwise give them the default list. + if ( is_arrayref($_[0]) ) { + s/^del$/delete/ for @{ $_[0] }; + } + else { + unshift @_, [qw/delete get head options patch post put/]; + } + + $self->_normalize_route(@_); +} + +sub _normalize_route { + my $app = shift->app; + my $methods = shift; + my %args; + + # Options are optional, deduce their presence from arg length. + # @_ = ( REGEXP, OPTIONS, CODE ) + # or + # @_ = ( REGEXP, CODE ) + @args{qw/regexp options code/} = @_ == 3 ? @_ : ( $_[0], {}, $_[1] ); + + return map $app->add_route( %args, method => $_ ), @{$methods}; +} + +# +# Server startup +# + +# access to the runner singleton +# will be populated on-the-fly when needed +# this singleton contains anything needed to start the application server +sub runner { Dancer2->runner } + +# start the server +sub start { shift->runner->start } + +sub dance { shift->start(@_) } + +sub psgi_app { + my $self = shift; + + $self->app->to_app; +} + +sub to_app { shift->app->to_app } + +# +# Response alterations +# + +sub status { + $Dancer2::Core::Route::RESPONSE->status( $_[1] ); +} + +sub push_header { + # TODO: deprecate old keyword after we have a period of stability + # carp "DEPRECATED: please use the 'push_response_header' keyword instead of 'push_header'"; + goto &push_response_header; +} + +sub push_response_header { + shift; + $Dancer2::Core::Route::RESPONSE->push_header(@_); +} + +sub header { + # TODO: deprecate keyword after a period of stability + # carp "DEPRECATED: please use the 'response_header' keyword instead of 'header'"; + goto &response_header; +} + +sub response_header { + shift; + $Dancer2::Core::Route::RESPONSE->header(@_); +} + +sub headers { + # TODO: deprecate keyword after a period of stability + # carp "DEPRECATED: please use the 'response_headers' keyword instead of 'headers'"; + goto &response_headers; +} + +sub response_headers { + shift; + $Dancer2::Core::Route::RESPONSE->header(@_); +} + +sub content { + my $dsl = shift; + + # simple synchronous response + my $responder = $Dancer2::Core::Route::RESPONDER + or croak 'Cannot use content keyword outside delayed response'; + + # flush if wasn't flushed before + if ( !$Dancer2::Core::Route::WRITER ) { + $Dancer2::Core::Route::WRITER = $responder->([ + $Dancer2::Core::Route::RESPONSE->status, + $Dancer2::Core::Route::RESPONSE->headers_to_array, + ]); + } + + eval { + $Dancer2::Core::Route::WRITER->write(@_); + 1; + } or do { + my $error = $@ || 'Zombie Error'; + $Dancer2::Core::Route::ERROR_HANDLER + ? $Dancer2::Core::Route::ERROR_HANDLER->($error) + : $dsl->app->logger_engine->log( + warning => "Error in delayed response: $error" + ); + }; +} + +sub content_type { + shift; + $Dancer2::Core::Route::RESPONSE->content_type(@_); +} + +sub delayed { + my ( $dsl, $cb, @args ) = @_; + + @args % 2 == 0 + or croak 'Arguments to delayed() keyword must be key/value pairs'; + + # first time, responder doesn't exist yet + my %opts = @args; + $Dancer2::Core::Route::RESPONDER + or return Dancer2::Core::Response::Delayed->new( + cb => $cb, + request => $Dancer2::Core::Route::REQUEST, + response => $Dancer2::Core::Route::RESPONSE, + + ( error_cb => $opts{'on_error'} )x!! $opts{'on_error'}, + ); + + # we're in an async request process + my $request = $Dancer2::Core::Route::REQUEST; + my $response = $Dancer2::Core::Route::RESPONSE; + my $responder = $Dancer2::Core::Route::RESPONDER; + my $writer = $Dancer2::Core::Route::WRITER; + my $handler = $Dancer2::Core::Route::ERROR_HANDLER; + + return sub { + local $Dancer2::Core::Route::REQUEST = $request; + local $Dancer2::Core::Route::RESPONSE = $response; + local $Dancer2::Core::Route::RESPONDER = $responder; + local $Dancer2::Core::Route::WRITER = $writer; + local $Dancer2::Core::Route::ERROR_HANDLER = $handler; + + $cb->(@_); + }; +} + +sub flush { + my $responder = $Dancer2::Core::Route::RESPONDER + or croak 'flush() called outside streaming response'; + + my $response = $Dancer2::Core::Route::RESPONSE; + $Dancer2::Core::Route::WRITER = $responder->([ + $response->status, $response->headers_to_array, + ]); +} + +sub done { + my $writer = $Dancer2::Core::Route::WRITER + or croak 'done() called outside streaming response'; + + $writer->close; +} + +sub pass { shift->app->pass } + +# +# Route handler helpers +# + +sub context { + carp "DEPRECATED: please use the 'app' keyword instead of 'context'"; + shift->app; +} + +sub request { $Dancer2::Core::Route::REQUEST } + +sub request_header { shift; $Dancer2::Core::Route::REQUEST->headers->header(@_) } + +sub response { $Dancer2::Core::Route::RESPONSE } + +sub upload { shift; $Dancer2::Core::Route::REQUEST->upload(@_); } + +sub captures { $Dancer2::Core::Route::REQUEST->captures } + +sub uri_for { shift; $Dancer2::Core::Route::REQUEST->uri_for(@_); } + +sub splat { $Dancer2::Core::Route::REQUEST->splat } + +sub params { shift; $Dancer2::Core::Route::REQUEST->params(@_); } + +sub param { shift; $Dancer2::Core::Route::REQUEST->param(@_); } + +sub query_parameters { shift; $Dancer2::Core::Route::REQUEST->query_parameters(@_); } +sub body_parameters { shift; $Dancer2::Core::Route::REQUEST->body_parameters(@_); } +sub route_parameters { shift; $Dancer2::Core::Route::REQUEST->route_parameters(@_); } + +sub redirect { shift->app->redirect(@_) } + +sub forward { shift->app->forward(@_) } + +sub vars { $Dancer2::Core::Route::REQUEST->vars } + +sub var { shift; $Dancer2::Core::Route::REQUEST->var(@_); } + +sub cookies { $Dancer2::Core::Route::REQUEST->cookies } +sub cookie { shift->app->cookie(@_) } + +sub mime { + my $self = shift; + if ( $self->app ) { + return $self->app->mime_type; + } + else { + my $runner = $self->runner; + $runner->mime_type->reset_default; + return $runner->mime_type; + } +} + +# +# engines +# + +sub from_json { + shift; # remove first element + require_module('Dancer2::Serializer::JSON'); + Dancer2::Serializer::JSON::from_json(@_); +} + +sub to_json { + shift; # remove first element + require_module('Dancer2::Serializer::JSON'); + Dancer2::Serializer::JSON::to_json(@_); +} + +sub decode_json { + shift; # remove first element + require_module('Dancer2::Serializer::JSON'); + Dancer2::Serializer::JSON::decode_json(@_); +} + +sub encode_json { + shift; # remove first element + require_module('Dancer2::Serializer::JSON'); + Dancer2::Serializer::JSON::encode_json(@_); +} + +sub from_yaml { + shift; # remove first element + require_module('Dancer2::Serializer::YAML'); + Dancer2::Serializer::YAML::from_yaml(@_); +} + +sub to_yaml { + shift; # remove first element + require_module('Dancer2::Serializer::YAML'); + Dancer2::Serializer::YAML::to_yaml(@_); +} + +sub from_dumper { + shift; # remove first element + require_module('Dancer2::Serializer::Dumper'); + Dancer2::Serializer::Dumper::from_dumper(@_); +} + +sub to_dumper { + shift; # remove first element + require_module('Dancer2::Serializer::Dumper'); + Dancer2::Serializer::Dumper::to_dumper(@_); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::DSL - Dancer2's Domain Specific Language (DSL) + +=head1 VERSION + +version 0.206000 + +=head1 FUNCTIONS + +=head2 setting + +Lets you define settings and access them: + setting('foo' => 42); + setting('foo' => 42, 'bar' => 43); + my $foo=setting('foo'); + +If settings were defined returns number of settings. + +=head2 set () + +alias for L: + set('foo' => '42'); + my $port=set('port'); + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Dispatcher.pm b/cpanlib/Dancer2/Core/Dispatcher.pm new file mode 100644 index 0000000..b85c4b3 --- /dev/null +++ b/cpanlib/Dancer2/Core/Dispatcher.pm @@ -0,0 +1,142 @@ +package Dancer2::Core::Dispatcher; +# ABSTRACT: Class for dispatching request to the appropriate route handler +$Dancer2::Core::Dispatcher::VERSION = '0.206000'; +use Moo; + +use Dancer2::Core::Types; +use Dancer2::Core::Request; +use Dancer2::Core::Response; + +has apps => ( + is => 'rw', + isa => ArrayRef, + default => sub { [] }, +); + +has apps_psgi => ( + is => 'ro', + isa => ArrayRef, + lazy => 1, + builder => '_build_apps_psgi', +); + +sub _build_apps_psgi { + my $self = shift; + return [ map +( $_->name, $_->to_app ), @{ $self->apps } ]; +} + +sub dispatch { + my ( $self, $env ) = @_; + my @apps = @{ $self->apps_psgi }; + + DISPATCH: while (1) { + for ( my $i = 0; $i < @apps; $i += 2 ) { + my ( $app_name, $app ) = @apps[ $i, $i + 1 ]; + + my $response = $app->($env); + + # check for an internal request + delete Dancer2->runner->{'internal_forward'} + and next DISPATCH; + + # the app raised a flag saying it couldn't match anything + # which is different than "I matched and it's a 404" + delete Dancer2->runner->{'internal_404'} + or do { + delete Dancer2->runner->{'internal_request'}; + return $response; + }; + } + + # don't run anymore + delete Dancer2->runner->{'internal_request'}; + last; + } # while + + # a 404 on all apps, using the first app + my $default_app = $self->apps->[0]; + my $request = $default_app->build_request($env); + return $default_app->response_not_found($request)->to_psgi; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Dispatcher - Class for dispatching request to the appropriate route handler + +=head1 VERSION + +version 0.206000 + +=head1 SYNOPSIS + + use Dancer2::Core::Dispatcher; + + # Create an instance of dispatcher + my $dispatcher = Dancer2::Core::Dispatcher->new( apps => [$app] ); + + # Dispatch a request + my $resp = $dispatcher->dispatch($env)->to_psgi; + + # Capture internal error of a response (if any) after a dispatch + $dispatcher->response_internal_error($app, $error); + + # Capture response not found for an application the after dispatch + $dispatcher->response_not_found($env); + +=head1 ATTRIBUTES + +=head2 apps + +The apps is an array reference to L. + +=head2 default_content_type + +The default_content_type is a string which represents the context of the +request. This attribute is read-only. + +=head1 METHODS + +=head2 dispatch + +The C method accepts the list of applications, hash reference for +the B attribute of L and optionally the request +object and an env as input arguments. + +C returns a response object of L. + +Any before hook and matched route code is wrapped using L +to allow DSL keywords such as forward and redirect to short-circuit remaining code +without having to throw an exception. L will use L +(an XS module) if it is available. + +=head2 response_internal_error + +The C takes as input the list of applications and +a variable error and returns an object of L. + +=head2 response_not_found + +The C consumes as input the list of applications and an +object of type L and returns an object +L. + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Error.pm b/cpanlib/Dancer2/Core/Error.pm new file mode 100644 index 0000000..1c6fb79 --- /dev/null +++ b/cpanlib/Dancer2/Core/Error.pm @@ -0,0 +1,596 @@ +package Dancer2::Core::Error; +# ABSTRACT: Class representing fatal errors +$Dancer2::Core::Error::VERSION = '0.206000'; +use Moo; +use Carp; +use Dancer2::Core::Types; +use Dancer2::Core::HTTP; +use Data::Dumper; +use Dancer2::FileUtils qw/path open_file/; +use Sub::Quote; +use Module::Runtime 'require_module'; +use Ref::Util qw< is_hashref >; +use Clone qw(clone); + +has app => ( + is => 'ro', + isa => InstanceOf['Dancer2::Core::App'], + predicate => 'has_app', +); + +has show_errors => ( + is => 'ro', + isa => Bool, + default => sub { + my $self = shift; + + $self->has_app + and return $self->app->setting('show_errors'); + }, +); + +has charset => ( + is => 'ro', + isa => Str, + default => sub {'UTF-8'}, +); + +has type => ( + is => 'ro', + isa => Str, + default => sub {'Runtime Error'}, +); + +has title => ( + is => 'ro', + isa => Str, + lazy => 1, + builder => '_build_title', +); + +sub _build_title { + my ($self) = @_; + my $title = 'Error ' . $self->status; + if ( my $msg = Dancer2::Core::HTTP->status_message($self->status) ) { + $title .= ' - ' . $msg; + } + + return $title; +} + +has template => ( + is => 'ro', + lazy => 1, + builder => '_build_error_template', +); + +sub _build_error_template { + my ($self) = @_; + + # look for a template named after the status number. + # E.g.: views/404.tt for a TT template + my $engine = $self->app->template_engine; + return $self->status + if $engine->pathname_exists( $engine->view_pathname( $self->status ) ); + + return; +} + +has static_page => ( + is => 'ro', + lazy => 1, + builder => '_build_static_page', +); + +sub _build_static_page { + my ($self) = @_; + + # TODO there must be a better way to get it + my $public_dir = $ENV{DANCER_PUBLIC} + || ( $self->has_app && $self->app->config->{public_dir} ); + + my $filename = sprintf "%s/%d.html", $public_dir, $self->status; + + open my $fh, '<', $filename or return; + + local $/ = undef; # slurp time + + return <$fh>; +} + +sub default_error_page { + my $self = shift; + + require_module('Template::Tiny'); + + my $uri_base = $self->has_app && $self->app->has_request ? + $self->app->request->uri_base : ''; + + # GH#1001 stack trace if show_errors is true and this is a 'server' error (5xx) + my $show_fullmsg = $self->show_errors && $self->status =~ /^5/; + my $opts = { + title => $self->title, + charset => $self->charset, + content => $show_fullmsg ? $self->full_message : _html_encode($self->message) || 'Wooops, something went wrong', + version => Dancer2->VERSION, + uri_base => $uri_base, + }; + + Template::Tiny->new->process( \<<"END_TEMPLATE", $opts, \my $output ); + + + + + + [% title %] + + + +

    [% title %]

    +
    +[% content %] +
    + + + +END_TEMPLATE + + return $output; +} + +has status => ( + is => 'ro', + default => sub {500}, + isa => Num, +); + +has message => ( + is => 'ro', + isa => Str, + lazy => 1, + default => sub { '' }, +); + +sub full_message { + my ($self) = @_; + my $html_output = "

    " . $self->type . "

    "; + $html_output .= $self->backtrace; + $html_output .= $self->environment; + return $html_output; +} + +has serializer => ( + is => 'ro', + isa => Maybe[ConsumerOf['Dancer2::Core::Role::Serializer']], + builder => '_build_serializer', +); + +sub _build_serializer { + my ($self) = @_; + + $self->has_app && $self->app->has_serializer_engine + and return $self->app->serializer_engine; + + return; +} + +sub BUILD { + my ($self) = @_; + + $self->has_app && + $self->app->execute_hook( 'core.error.init', $self ); +} + +has exception => ( + is => 'ro', + isa => Str, + predicate => 1, + coerce => sub { + # Until we properly support exception objects, we shouldn't barf on + # them because that hides the actual error, if object overloads "", + # which most exception objects do, this will result in a nicer string. + # other references will produce a meaningless error, but that is + # better than a meaningless stacktrace + return "$_[0]" + } +); + +has response => ( + is => 'rw', + lazy => 1, + default => sub { + my $self = shift; + my $serializer = $self->serializer; + # include server tokens in response ? + my $no_server_tokens = $self->has_app + ? $self->app->config->{'no_server_tokens'} + : defined $ENV{DANCER_NO_SERVER_TOKENS} + ? $ENV{DANCER_NO_SERVER_TOKENS} + : 0; + return Dancer2::Core::Response->new( + server_tokens => !$no_server_tokens, + ( serializer => $serializer )x!! $serializer + ); + } +); + +has content_type => ( + is => 'ro', + lazy => 1, + default => sub { + my $self = shift; + $self->serializer + ? $self->serializer->content_type + : 'text/html' + }, +); + +has content => ( + is => 'ro', + lazy => 1, + builder => '_build_content', +); + +sub _build_content { + my $self = shift; + + # return a hashref if a serializer is available + if ( $self->serializer ) { + my $content = { + message => $self->message, + title => $self->title, + status => $self->status, + }; + $content->{exception} = $self->exception + if $self->has_exception; + return $content; + } + + # otherwise we check for a template, for a static file, + # for configured error_template, and, if all else fails, + # the default error page + if ( $self->has_app and $self->template ) { + # Render the template using apps' template engine. + # This may well be what caused the initial error, in which + # case we fall back to static page if any error was thrown. + # Note: this calls before/after render hooks. + my $content = eval { + $self->app->template( + $self->template, + { title => $self->title, + content => $self->message, + exception => $self->exception, + status => $self->status, + } + ); + }; + $@ && $self->app->engine('logger')->log( warning => $@ ); + + # return rendered content unless there was an error. + return $content if defined $content; + } + + # It doesn't make sense to return a static page for a 500 if show_errors is on + if ( !($self->show_errors && $self->status eq '500') ) { + if ( my $content = $self->static_page ) { + return $content; + } + } + + if ($self->has_app && $self->app->config->{error_template}) { + my $content = eval { + $self->app->template( + $self->app->config->{error_template}, + { title => $self->title, + content => $self->message, + exception => $self->exception, + status => $self->status, + } + ); + }; + $@ && $self->app->engine('logger')->log( warning => $@ ); + + # return rendered content unless there was an error. + return $content if defined $content; + } + + return $self->default_error_page; +} + +sub throw { + my $self = shift; + $self->response(shift) if @_; + + $self->response + or croak "error has no response to throw at"; + + $self->has_app && + $self->app->execute_hook( 'core.error.before', $self ); + + my $message = $self->content; + + $self->response->status( $self->status ); + $self->response->content_type( $self->content_type ); + $self->response->content($message); + + $self->has_app && + $self->app->execute_hook('core.error.after', $self->response); + + $self->response->is_halted(1); + return $self->response; +} + +sub backtrace { + my ($self) = @_; + + my $message = $self->message; + if ($self->exception) { + $message .= "\n" if $message; + $message .= $self->exception; + } + $message ||= 'Wooops, something went wrong'; + + my $html = '
    ' . _html_encode($message) . "
    \n"; + + # the default perl warning/error pattern + my ($file, $line) = $message =~ /at (\S+) line (\d+)/; + # the Devel::SimpleTrace pattern + ($file, $line) = $message =~ /at.*\((\S+):(\d+)\)/ unless $file and $line; + + # no file/line found, cannot open a file for context + return $html unless $file and $line; + + # file and line are located, let's read the source Luke! + my $fh = eval { open_file('<', $file) } or return $html; + my @lines = <$fh>; + close $fh; + + $html .= qq|
    $file around line $line
    |; + + # get 5 lines of context + my $start = $line - 5 > 1 ? $line - 5 : 1; + my $stop = $line + 5 < @lines ? $line + 5 : @lines; + + $html .= qq|
    \n|;
    +    for my $l ($start .. $stop) {
    +        chomp $lines[$l - 1];
    +
    +        $html .= $l == $line ? '' : '';
    +        $html .= "\n";
    +    }
    +    $html .= "
    $l" . _html_encode($lines[$l - 1]) . "
    \n"; + + return $html; +} + +sub dumper { + my $obj = shift; + + # Take a copy of the data, so we can mask sensitive-looking stuff: + my $data = clone($obj); + my $censored = _censor( $data ); + + #use Data::Dumper; + my $dd = Data::Dumper->new( [ $data ] ); + my $hash_separator = ' @@!%,+$$#._(-- '; # Very unlikely string to exist already + my $prefix_padding = ' #+#+@%.,$_-!(( '; # Very unlikely string to exist already + $dd->Terse(1)->Quotekeys(0)->Indent(1)->Sortkeys(1)->Pair($hash_separator)->Pad($prefix_padding); + my $content = _html_encode( $dd->Dump ); + $content =~ s/^.+//; # Remove the first line + $content =~ s/\n.+$//; # Remove the last line + $content =~ s/^\Q$prefix_padding\E //gm; # Remove the padding + $content =~ s{^(\s*)(.+)\Q$hash_separator}{$1$2 => }gm; + if ($censored) { + $content + .= "\n\nNote: Values of $censored sensitive-looking keys hidden\n"; + } + return $content; +} + +sub environment { + my ($self) = @_; + + my $stack = $self->get_caller; + my $settings = $self->has_app && $self->app->settings; + my $session = $self->has_app && $self->app->_has_session && $self->app->session->data; + my $env = $self->has_app && $self->app->has_request && $self->app->request->env; + + # Get a sanitised dump of the settings, session and environment + $_ = $_ ? dumper($_) : 'undefined' for $settings, $session, $env; + + return <<"END_HTML"; +
    Stack
    $stack
    +
    Settings
    $settings
    +
    Session
    $session
    +
    Environment
    $env
    +END_HTML +} + +sub get_caller { + my ($self) = @_; + my @stack; + + my $deepness = 0; + while ( my ( $package, $file, $line ) = caller( $deepness++ ) ) { + push @stack, "$package in $file l. $line"; + } + + return join( "\n", reverse(@stack) ); +} + +# private + +# Given a hashref, censor anything that looks sensitive. Returns number of +# items which were "censored". + +sub _censor { + my $hash = shift; + my $visited = shift || {}; + + unless ( $hash && is_hashref($hash) ) { + carp "_censor given incorrect input: $hash"; + return; + } + + my $censored = 0; + for my $key ( keys %$hash ) { + if ( is_hashref( $hash->{$key} ) ) { + if (!$visited->{ $hash->{$key} }) { + # mark the new ref as visited + $visited->{ $hash->{$key} } = 1; + + $censored += _censor( $hash->{$key}, $visited ); + } + } + elsif ( $key =~ /(pass|card?num|pan|secret)/i ) { + $hash->{$key} = "Hidden (looks potentially sensitive)"; + $censored++; + } + } + + return $censored; +} + +# Replaces the entities that are illegal in (X)HTML. +sub _html_encode { + my $value = shift; + + return if !defined $value; + + $value =~ s/&/&/g; + $value =~ s//>/g; + $value =~ s/'/'/g; + $value =~ s/"/"/g; + + return $value; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Error - Class representing fatal errors + +=head1 VERSION + +version 0.206000 + +=head1 SYNOPSIS + + # taken from send_file: + use Dancer2::Core::Error; + + my $error = Dancer2::Core::Error->new( + status => 404, + message => "No such file: `$path'" + ); + + Dancer2::Core::Response->set($error->render); + +=head1 DESCRIPTION + +With Dancer2::Core::Error you can throw reasonable-looking errors to the user +instead of crashing the application and filling up the logs. + +This is usually used in debugging environments, and it's what Dancer2 uses as +well under debugging to catch errors and show them on screen. + +=head1 ATTRIBUTES + +=head2 show_errors + +=head2 charset + +=head2 type + +The error type. + +=head2 title + +The title of the error page. + +This is only an attribute getter, you'll have to set it at C. + +=head2 status + +The status that caused the error. + +This is only an attribute getter, you'll have to set it at C. + +=head2 message + +The message of the error page. + +=head1 METHODS + +=head2 my $error=new Dancer2::Core::Error(status => 404, message => "No such file: `$path'"); + +Create a new Dancer2::Core::Error object. For available arguments see ATTRIBUTES. + +=head2 supported_hooks (); + +=head2 throw($response) + +Populates the content of the response with the error's information. +If I<$response> is not given, acts on the I +attribute's response. + +=head2 backtrace + +Show the surrounding lines of context at the line where the error was thrown. + +This method tries to find out where the error appeared according to the actual +error message (using the C attribute) and tries to parse it (supporting +the regular/default Perl warning or error pattern and the L +output) and then returns an error-highlighted C. + +=head2 environment + +A main function to render environment information: the caller (using +C), the settings and environment (using C) and more. + +=head2 get_caller + +Creates a stack trace of callers. + +=head1 FUNCTIONS + +=head2 _censor + +An private function that tries to censor out content which should be protected. + +C calls this method to censor things like passwords and such. + +=head2 my $string=_html_encode ($string); + +Private function that replaces illegal entities in (X)HTML with their +escaped representations. + +html_encode() doesn't do any UTF black magic. + +=head2 dumper + +This uses L to create nice content output with a few predefined +options. + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Factory.pm b/cpanlib/Dancer2/Core/Factory.pm new file mode 100644 index 0000000..1afc968 --- /dev/null +++ b/cpanlib/Dancer2/Core/Factory.pm @@ -0,0 +1,49 @@ +package Dancer2::Core::Factory; +# ABSTRACT: Instantiate components by type and name +$Dancer2::Core::Factory::VERSION = '0.206000'; +use Moo; +use Dancer2::Core; +use Module::Runtime 'use_module'; +use Carp 'croak'; + +sub create { + my ( $class, $type, $name, %options ) = @_; + + $type = Dancer2::Core::camelize($type); + $name = Dancer2::Core::camelize($name); + my $component_class = "Dancer2::${type}::${name}"; + + eval { use_module($component_class); 1; } + or croak "Unable to load class for $type component $name: $@"; + + return $component_class->new(%options); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Factory - Instantiate components by type and name + +=head1 VERSION + +version 0.206000 + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/HTTP.pm b/cpanlib/Dancer2/Core/HTTP.pm new file mode 100644 index 0000000..aeba494 --- /dev/null +++ b/cpanlib/Dancer2/Core/HTTP.pm @@ -0,0 +1,204 @@ +# ABSTRACT: helper for rendering HTTP status codes for Dancer2 + +package Dancer2::Core::HTTP; +$Dancer2::Core::HTTP::VERSION = '0.206000'; +use strict; +use warnings; + +use List::Util qw/ pairmap pairgrep /; + +my $HTTP_CODES = { + + # informational + 100 => 'Continue', # only on HTTP 1.1 + 101 => 'Switching Protocols', # only on HTTP 1.1 + 102 => 'Processing', # WebDAV; RFC 2518 + + # processed + 200 => 'OK', + 201 => 'Created', + 202 => 'Accepted', + 203 => 'Non-Authoritative Information', # only on HTTP 1.1 + 204 => 'No Content', + 205 => 'Reset Content', + 206 => 'Partial Content', + 207 => 'Multi-Status', # WebDAV; RFC 4918 + 208 => 'Already Reported', # WebDAV; RFC 5842 + # 226 => 'IM Used' # RFC 3229 + + # redirections + 301 => 'Moved Permanently', + 302 => 'Found', + 303 => 'See Other', # only on HTTP 1.1 + 304 => 'Not Modified', + 305 => 'Use Proxy', # only on HTTP 1.1 + 306 => 'Switch Proxy', + 307 => 'Temporary Redirect', # only on HTTP 1.1 + # 308 => 'Permanent Redirect' # approved as experimental RFC + + # problems with request + 400 => 'Bad Request', + 401 => 'Unauthorized', + 402 => 'Payment Required', + 403 => 'Forbidden', + 404 => 'Not Found', + 405 => 'Method Not Allowed', + 406 => 'Not Acceptable', + 407 => 'Proxy Authentication Required', + 408 => 'Request Timeout', + 409 => 'Conflict', + 410 => 'Gone', + 411 => 'Length Required', + 412 => 'Precondition Failed', + 413 => 'Request Entity Too Large', + 414 => 'Request-URI Too Long', + 415 => 'Unsupported Media Type', + 416 => 'Requested Range Not Satisfiable', + 417 => 'Expectation Failed', + 418 => "I'm a teapot", # RFC 2324 + # 419 => 'Authentication Timeout', # not in RFC 2616 + 420 => 'Enhance Your Calm', + 422 => 'Unprocessable Entity', + 423 => 'Locked', + 424 => 'Failed Dependency', # Also used for 'Method Failure' + 425 => 'Unordered Collection', + 426 => 'Upgrade Required', + 428 => 'Precondition Required', + 429 => 'Too Many Requests', + 431 => 'Request Header Fields Too Large', + 444 => 'No Response', + 449 => 'Retry With', + 450 => 'Blocked by Windows Parental Controls', + 451 => 'Unavailable For Legal Reasons', + 494 => 'Request Header Too Large', + 495 => 'Cert Error', + 496 => 'No Cert', + 497 => 'HTTP to HTTPS', + 499 => 'Client Closed Request', + + # problems with server + 500 => 'Internal Server Error', + 501 => 'Not Implemented', + 502 => 'Bad Gateway', + 503 => 'Service Unavailable', + 504 => 'Gateway Timeout', + 505 => 'HTTP Version Not Supported', + 506 => 'Variant Also Negotiates', + 507 => 'Insufficient Storage', + 508 => 'Loop Detected', + 509 => 'Bandwidth Limit Exceeded', + 510 => 'Not Extended', + 511 => 'Network Authentication Required', + 598 => 'Network read timeout error', + 599 => 'Network connect timeout error', +}; + +$HTTP_CODES = { + %$HTTP_CODES, + ( reverse %$HTTP_CODES ), + pairmap { join( '_', split /\W/, lc $a ) => $b } reverse %$HTTP_CODES +}; + +$HTTP_CODES->{error} = $HTTP_CODES->{internal_server_error}; + +sub status { + my ( $class, $status ) = @_; + return if ! defined $status; + return $status if $status =~ /^\d+$/; + if ( exists $HTTP_CODES->{$status} ) { + return $HTTP_CODES->{$status}; + } + return; +} + +sub status_message { + my ( $class, $status ) = @_; + return if ! defined $status; + my $code = $class->status($status); + return if ! defined $code || ! exists $HTTP_CODES->{$code}; + return $HTTP_CODES->{ $code }; +} + +sub status_mapping { + pairgrep { $b =~ /^\d+$/ and $a !~ /_/ } %$HTTP_CODES; +} + +sub code_mapping { + my @result = reverse status_mapping(); + return @result; +} + +sub all_mappings { %$HTTP_CODES } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::HTTP - helper for rendering HTTP status codes for Dancer2 + +=head1 VERSION + +version 0.206000 + +=head1 FUNCTIONS + +=head2 status(status_code) + + Dancer2::Core::HTTP->status(200); # returns 200 + + Dancer2::Core::HTTP->status('Not Found'); # returns 404 + + Dancer2::Core::HTTP->status('bad_request'); # 400 + +Returns a HTTP status code. If given an integer, it will return the value it +received, else it will try to find the appropriate alias and return the correct +status. + +=head2 status_message(status_code) + + Dancer2::Core::HTTP->status_message(200); # returns 'OK' + + Dancer2::Core::HTTP->status_message('error'); # returns 'Internal Server Error' + +Returns the HTTP status message for the given status code. + +=head2 status_mapping() + + my %table = Dancer2::Core::HTTP->status_mapping; + # returns ( 'Ok' => 200, 'Created' => 201, ... ) + +Returns the full table of status -> code mappings. + +=head2 code_mapping() + + my %table = Dancer2::Core::HTTP->code_mapping; + # returns ( 200 => 'Ok', 201 => 'Created', ... ) + +Returns the full table of code -> status mappings. + +=head2 all_mappings() + + my %table = Dancer2::Core::HTTP->all_mappings; + # returns ( 418 => 'I'm a teapot', "I'm a teapot' => 418, 'i_m_a_teapot' => 418 ) + +Returns the code-to-status, status-to-code and underscore-groomed status-to-code mappings +all mashed up in a single table. Mostly for internal uses. + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Hook.pm b/cpanlib/Dancer2/Core/Hook.pm new file mode 100644 index 0000000..ae28fcc --- /dev/null +++ b/cpanlib/Dancer2/Core/Hook.pm @@ -0,0 +1,112 @@ +package Dancer2::Core::Hook; +# ABSTRACT: Manipulate hooks with Dancer2 +$Dancer2::Core::Hook::VERSION = '0.206000'; +use Moo; +use Dancer2::Core::Types; +use Carp; + +has name => ( + is => 'rw', + isa => Str, + required => 1, + coerce => sub { + my ($hook_name) = @_; + + # XXX at the moment, we have a filer position named "before_template". + # this one is renamed "before_template_render", so we need to alias it. + # maybe we need to deprecate 'before_template' to enforce the use + # of 'hook before_template_render => sub {}' ? + $hook_name = 'before_template_render' + if $hook_name eq 'before_template'; + return $hook_name; + }, +); + +has code => ( + is => 'ro', + isa => CodeRef, + required => 1, + coerce => sub { + my ($hook) = @_; + sub { + my $res; + eval { $res = $hook->(@_) }; + croak "Hook error: $@" if $@; + return $res; + }; + }, +); + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Hook - Manipulate hooks with Dancer2 + +=head1 VERSION + +version 0.206000 + +=head1 SYNOPSIS + + # inside a plugin + use Dancer2::Core::Hook; + Dancer2::Core::Hook->register_hooks_name(qw/before_auth after_auth/); + +=head1 METHODS + +=head2 register_hook ($hook_name, [$properties], $code) + + hook 'before', {apps => ['main']}, sub {...}; + + hook 'before' => sub {...}; + +Attaches a hook at some point, with a possible list of properties. + +Currently supported properties: + +=over 4 + +=item apps + + an array reference containing apps name + +=back + +=head2 register_hooks_name + +Add a new hook name, so application developers can insert some code at this point. + + package My::Dancer2::Plugin; + Dancer2::Core::Hook->instance->register_hooks_name(qw/before_auth after_auth/); + +=head2 execute_hook + +Execute a hooks + +=head2 get_hooks_for + +Returns the list of coderef registered for a given position + +=head2 hook_is_registered + +Test if a hook with this name has already been registered. + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/MIME.pm b/cpanlib/Dancer2/Core/MIME.pm new file mode 100644 index 0000000..6e094e4 --- /dev/null +++ b/cpanlib/Dancer2/Core/MIME.pm @@ -0,0 +1,177 @@ +# ABSTRACT: Class to ease manipulation of MIME types + +package Dancer2::Core::MIME; +$Dancer2::Core::MIME::VERSION = '0.206000'; +use Moo; + +use Plack::MIME; +use Dancer2::Core::Types; +use Module::Runtime 'require_module'; + +# Initialise MIME::Types at compile time, to ensure it's done before +# the fork in a preforking webserver like mod_perl or Starman. Not +# doing this leads to all MIME types being returned as "text/plain", +# as MIME::Types fails to load its mappings from the DATA handle. See +# t/04_static_file/003_mime_types_reinit.t and GH#136. +BEGIN { + if ( eval { require_module('MIME::Types'); 1; } ) { + my $mime_types = MIME::Types->new(only_complete => 1); + Plack::MIME->set_fallback( + sub { + $mime_types->mimeTypeOf($_[0]) + } + ); + } +} + +has custom_types => ( + is => 'ro', + isa => HashRef, + default => sub { +{} }, +); + +has default => ( + is => 'rw', + isa => Str, + builder => "reset_default", +); + +sub reset_default { + my ($self) = @_; + $self->default("application/data"); +} + +sub add_type { + my ( $self, $name, $type ) = @_; + $self->custom_types->{$name} = $type; + return; +} + +sub add_alias { + my ( $self, $alias, $orig ) = @_; + my $type = $self->for_name($orig); + $self->add_type( $alias, $type ); + return $type; +} + +sub for_file { + my ( $self, $filename ) = @_; + my ($ext) = $filename =~ /\.([^.]+)$/; + return $self->default unless $ext; + return $self->for_name($ext); +} + +sub name_or_type { + my ( $self, $name ) = @_; + + return $name if $name =~ m{/}; # probably a mime type + return $self->for_name($name); +} + +sub for_name { + my ( $self, $name ) = @_; + + return + $self->custom_types->{ lc $name } + || Plack::MIME->mime_type( lc ".$name" ) + || $self->default; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::MIME - Class to ease manipulation of MIME types + +=head1 VERSION + +version 0.206000 + +=head1 SYNOPSIS + + use Dancer2::Core::MIME; + + my $mime = Dancer2::Core::MIME->new(); + + # get mime type for an alias + my $type = $mime->for_name('css'); + + # set a new mime type + my $type = $mime->add_type( foo => 'text/foo' ); + + # set a mime type alias + my $alias = $mime->add_alias( f => 'foo' ); + + # get mime type for a file (based on extension) + my $file = $mime->for_file( "foo.bar" ); + + # set the $thing into a content $type. + my $type = $mime->name_or_type($thing); + + # get current defined default mime type + my $type = $mime->default; + + # set the default mime type using config.yml + # or using the set keyword + set default_mime_type => 'text/plain'; + +=head1 DESCRIPTION + +Dancer2::Core::MIME is a thin wrapper around L providing helpful +methods for MIME handling. + +=head1 ATTRIBUTES + +=head2 custom_types + +Custom user-defined MIME types that are added the with C. + +=head2 default + +Default MIME type defined by MIME::Types, set to: B. + +=head1 METHODS + +=head2 reset_default + +This method resets C to the default type. + +=head2 add_type + +This method adds the new MIME type. + +=head2 add_alias + +The C sets a MIME type alias. + +=head2 for_name + +The method C gets MIME type for an alias. + +=head2 for_file + +This method gets MIME type for a file based on extension. + +=head2 name_or_type + +This method sets the customized MIME name or default MIME type into a content +type. + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Request.pm b/cpanlib/Dancer2/Core/Request.pm new file mode 100644 index 0000000..94c4b4e --- /dev/null +++ b/cpanlib/Dancer2/Core/Request.pm @@ -0,0 +1,1149 @@ +package Dancer2::Core::Request; +# ABSTRACT: Interface for accessing incoming requests +$Dancer2::Core::Request::VERSION = '0.206000'; +use strict; +use warnings; +use parent 'Plack::Request'; + +use Carp; +use Encode; +use URI; +use URI::Escape; +use Safe::Isa; +use Hash::MultiValue; +use Module::Runtime 'require_module'; +use Ref::Util qw< is_ref is_arrayref is_hashref >; + +use Dancer2::Core::Types; +use Dancer2::Core::Request::Upload; +use Dancer2::Core::Cookie; + +# add an attribute for each HTTP_* variables +# (HOST is managed manually) +my @http_env_keys = (qw/ + accept_charset + accept_encoding + accept_language + connection + keep_alive + x_requested_with +/); + +# apparently you can't eval core functions +sub accept { $_[0]->env->{'HTTP_ACCEPT'} } + +eval << "_EVAL" or die $@ for @http_env_keys; ## no critic +sub $_ { \$_[0]->env->{ 'HTTP_' . ( uc "$_" ) } } +1; +_EVAL + +# check presence of XS module to speedup request +our $XS_URL_DECODE = eval { require_module('URL::Encode::XS'); 1; }; +our $XS_PARSE_QUERY_STRING = eval { require_module('CGI::Deurl::XS'); 1; }; +our $XS_HTTP_COOKIES = eval { require_module('HTTP::XSCookies'); 1; }; + +our $_id = 0; + +# self->new( env => {}, serializer => $s, is_behind_proxy => 0|1 ) +sub new { + my ( $class, @args ) = @_; + + # even sized list + @args % 2 == 0 + or croak 'Must provide even sized list'; + + my %opts = @args; + my $env = $opts{'env'}; + + my $self = $class->SUPER::new($env); + + if ( my $s = $opts{'serializer'} ) { + $s->$_does('Dancer2::Core::Role::Serializer') + or croak 'Serializer provided not a Serializer object'; + + $self->{'serializer'} = $s; + } + + # additionally supported attributes + $self->{'id'} = ++$_id; + $self->{'vars'} = {}; + $self->{'is_behind_proxy'} = !!$opts{'is_behind_proxy'}; + + $opts{'body_params'} + and $self->{'_body_params'} = $opts{'body_params'}; + + # Deserialize/parse body for HMV + $self->data; + $self->_build_uploads(); + + return $self; +} + +# a buffer for per-request variables +sub vars { $_[0]->{'vars'} } + +sub var { + my $self = shift; + @_ == 2 + ? $self->vars->{ $_[0] } = $_[1] + : $self->vars->{ $_[0] }; +} + +# I don't like this. I know send_file uses this and I wonder +# if we can remove it. +# -- Sawyer +sub set_path_info { $_[0]->env->{'PATH_INFO'} = $_[1] } + +# XXX: incompatible with Plack::Request +sub body { $_[0]->raw_body } + +sub id { $_id } + +# Private 'read-only' attributes for request params. See the params() +# method for the public interface. +# +# _body_params, _query_params and _route_params have setter methods that +# decode byte string to characters before setting; If you know you have +# decoded (character) params, such as output from a deserializer, you can +# set these directly in the request object hash to avoid the decode op. +sub _params { $_[0]->{'_params'} ||= $_[0]->_build_params } + +sub _has_params { defined $_[0]->{'_params'} } + +sub _body_params { $_[0]->{'_body_params'} ||= $_[0]->body_parameters->as_hashref_mixed } + +sub _query_params { $_[0]->{'_query_params'} } + +sub _set_query_params { + my ( $self, $params ) = @_; + $self->{_query_params} = _decode( $params ); +} + +sub _route_params { $_[0]->{'_route_params'} ||= {} } + +sub _set_route_params { + my ( $self, $params ) = @_; + $self->{_route_params} = _decode( $params ); + $self->_build_params(); +} + +# XXX: incompatible with Plack::Request +sub uploads { $_[0]->{'uploads'} } + +sub is_behind_proxy { $_[0]->{'is_behind_proxy'} || 0 } + +sub host { + my ($self) = @_; + + if ( $self->is_behind_proxy and exists $self->env->{'HTTP_X_FORWARDED_HOST'} ) { + my @hosts = split /\s*,\s*/, $self->env->{'HTTP_X_FORWARDED_HOST'}, 2; + return $hosts[0]; + } else { + return $self->env->{'HTTP_HOST'}; + } +} + +# aliases, kept for backward compat +sub agent { shift->user_agent } +sub remote_address { shift->address } +sub forwarded_for_address { shift->env->{'HTTP_X_FORWARDED_FOR'} } +sub forwarded_host { shift->env->{'HTTP_X_FORWARDED_HOST'} } + +# there are two options +sub forwarded_protocol { + $_[0]->env->{'HTTP_X_FORWARDED_PROTO'} || + $_[0]->env->{'HTTP_X_FORWARDED_PROTOCOL'} || + $_[0]->env->{'HTTP_FORWARDED_PROTO'} +} + +sub scheme { + my ($self) = @_; + my $scheme = $self->is_behind_proxy + ? $self->forwarded_protocol + : ''; + + return $scheme || $self->env->{'psgi.url_scheme'}; +} + +sub serializer { $_[0]->{'serializer'} } + +sub data { $_[0]->{'data'} ||= $_[0]->deserialize() } + +sub deserialize { + my $self = shift; + + my $serializer = $self->serializer + or return; + + # The latest draft of the RFC does not forbid DELETE to have content, + # rather the behaviour is undefined. Take the most lenient route and + # deserialize any content on delete as well. + return + unless grep { $self->method eq $_ } qw/ PUT POST PATCH DELETE /; + + # try to deserialize + my $body = $self->body; + + $body && length $body > 0 + or return; + + # Catch serializer fails - which is tricky as Role::Serializer + # wraps the deserializaion in an eval and returns undef. + # We want to generate a 500 error on serialization fail (Ref #794) + # to achieve that, override the log callback so we can catch a signal + # that it failed. This is messy (messes with serializer internals), but + # "works". + my $serializer_fail; + my $serializer_log_cb = $serializer->log_cb; + local $serializer->{log_cb} = sub { + $serializer_fail = $_[1]; + $serializer_log_cb->(@_); + }; + my $data = $serializer->deserialize($body); + die $serializer_fail if $serializer_fail; + + # Set _body_params directly rather than using the setter. Deserializiation + # returns characters and skipping the decode op in the setter ensures + # that numerical data "stays" numerical; decoding an SV that is an IV + # converts that to a PVIV. Some serializers are picky (JSON).. + $self->{_body_params} = $data; + + # Set body parameters (decoded HMV) + $self->{'body_parameters'} = + Hash::MultiValue->from_mixed( is_hashref($data) ? %$data : () ); + + return $data; +} + +sub uri { $_[0]->request_uri } + +sub is_head { $_[0]->method eq 'HEAD' } +sub is_post { $_[0]->method eq 'POST' } +sub is_get { $_[0]->method eq 'GET' } +sub is_put { $_[0]->method eq 'PUT' } +sub is_delete { $_[0]->method eq 'DELETE' } +sub is_patch { $_[0]->method eq 'PATCH' } +sub is_options { $_[0]->method eq 'OPTIONS' } + +# public interface compat with CGI.pm objects +sub request_method { $_[0]->method } +sub input_handle { $_[0]->env->{'psgi.input'} } + +sub to_string { + my ($self) = @_; + return "[#" . $self->id . "] " . $self->method . " " . $self->path; +} + +sub base { + my $self = shift; + my $uri = $self->_common_uri; + + return $uri->canonical; +} + +sub _common_uri { + my $self = shift; + + my $path = $self->env->{SCRIPT_NAME}; + my $port = $self->env->{SERVER_PORT}; + my $server = $self->env->{SERVER_NAME}; + my $host = $self->host; + my $scheme = $self->scheme; + + my $uri = URI->new; + $uri->scheme($scheme); + $uri->authority( $host || "$server:$port" ); + $uri->path( $path || '/' ); + + return $uri; +} + +sub uri_base { + my $self = shift; + my $uri = $self->_common_uri; + my $canon = $uri->canonical; + + if ( $uri->path eq '/' ) { + $canon =~ s{/$}{}; + } + + return $canon; +} + +sub dispatch_path { + warn q{request->dispatch_path is deprecated}; + return shift->path; +} + +sub uri_for { + my ( $self, $part, $params, $dont_escape ) = @_; + + $part ||= ''; + my $uri = $self->base; + + # Make sure there's exactly one slash between the base and the new part + my $base = $uri->path; + $base =~ s|/$||; + $part =~ s|^/||; + $uri->path("$base/$part"); + + $uri->query_form($params) if $params; + + return $dont_escape + ? uri_unescape( ${ $uri->canonical } ) + : ${ $uri->canonical }; +} + +sub params { + my ( $self, $source ) = @_; + + return %{ $self->_params } if wantarray && @_ == 1; + return $self->_params if @_ == 1; + + if ( $source eq 'query' ) { + return %{ $self->_query_params || {} } if wantarray; + return $self->_query_params; + } + elsif ( $source eq 'body' ) { + return %{ $self->_body_params || {} } if wantarray; + return $self->_body_params; + } + if ( $source eq 'route' ) { + return %{ $self->_route_params } if wantarray; + return $self->_route_params; + } + else { + croak "Unknown source params \"$source\"."; + } +} + +sub query_parameters { + my $self = shift; + $self->{'query_parameters'} ||= do { + if ($XS_PARSE_QUERY_STRING) { + my $query = _decode(CGI::Deurl::XS::parse_query_string( + $self->env->{'QUERY_STRING'} + )); + + Hash::MultiValue->new( + map {; + my $key = $_; + is_arrayref( $query->{$key} ) + ? ( map +( $key => $_ ), @{ $query->{$key} } ) + : ( $key => $query->{$key} ) + } keys %{$query} + ); + } else { + # defer to Plack::Request + _decode($self->SUPER::query_parameters); + } + }; +} + +# this will be filled once the route is matched +sub route_parameters { $_[0]->{'route_parameters'} ||= Hash::MultiValue->new } + +sub _set_route_parameters { + my ( $self, $params ) = @_; + # remove reserved splat parameter name + # you should access splat parameters using splat() keyword + delete @{$params}{qw}; + $self->{'route_parameters'} = Hash::MultiValue->from_mixed( %{_decode($params)} ); +} + +sub body_parameters { + my $self = shift; + # defer to (the overridden) Plack::Request->body_parameters + $self->{'body_parameters'} ||= _decode($self->SUPER::body_parameters()); +} + +sub parameters { + my ( $self, $type ) = @_; + + # handle a specific case + if ($type) { + my $attr = "${type}_parameters"; + return $self->$attr; + } + + # merge together the *decoded* parameters + $self->{'merged_parameters'} ||= do { + my $query = $self->query_parameters; + my $body = $self->body_parameters; + my $route = $self->route_parameters; # not in Plack::Request + Hash::MultiValue->new( map $_->flatten, $query, $body, $route ); + }; +} + +sub captures { shift->params->{captures} || {} } + +sub splat { @{ shift->params->{splat} || [] } } + +# XXX: incompatible with Plack::Request +sub param { shift->params->{ $_[0] } } + +sub _decode { + my ($h) = @_; + return if not defined $h; + + if ( !is_ref($h) && !utf8::is_utf8($h) ) { + return decode( 'UTF-8', $h ); + } + elsif ( ref($h) eq 'Hash::MultiValue' ) { + return Hash::MultiValue->from_mixed(_decode($h->as_hashref_mixed)); + } + elsif ( is_hashref($h) ) { + return { map {my $t = _decode($_); $t} (%$h) }; + } + elsif ( is_arrayref($h) ) { + return [ map _decode($_), @$h ]; + } + + return $h; +} + +sub is_ajax { + my $self = shift; + + return 0 unless defined $self->headers; + return 0 unless defined $self->header('X-Requested-With'); + return 0 if $self->header('X-Requested-With') ne 'XMLHttpRequest'; + return 1; +} + +# XXX incompatible with Plack::Request +# context-aware accessor for uploads +sub upload { + my ( $self, $name ) = @_; + my $res = $self->{uploads}{$name}; + + return $res unless wantarray; + return () unless defined $res; + return ( is_arrayref($res) ) ? @$res : $res; +} + +sub _build_params { + my ($self) = @_; + + # params may have been populated by before filters + # _before_ we get there, so we have to save it first + my $previous = $self->_has_params ? $self->_params : {}; + + # now parse environment params... + my $get_params = $self->_parse_get_params(); + + # and merge everything + $self->{_params} = { + map +( is_hashref($_) ? %{$_} : () ), + $previous, + $get_params, + $self->_body_params, + $self->_route_params, + }; + +} + +sub _url_decode { + my ( $self, $encoded ) = @_; + return URL::Encode::XS::url_decode($encoded) if $XS_URL_DECODE; + my $clean = $encoded; + $clean =~ tr/\+/ /; + $clean =~ s/%([a-fA-F0-9]{2})/pack "H2", $1/eg; + return $clean; +} + +sub _parse_get_params { + my ($self) = @_; + return $self->_query_params if defined $self->{_query_params}; + + my $query_params = {}; + + my $source = $self->env->{QUERY_STRING}; + return if !defined $source || $source eq ''; + + if ($XS_PARSE_QUERY_STRING) { + $self->_set_query_params( + CGI::Deurl::XS::parse_query_string($source) || {} + ); + return $self->_query_params; + } + + foreach my $token ( split /[&;]/, $source ) { + my ( $key, $val ) = split( /=/, $token ); + next unless defined $key; + $val = ( defined $val ) ? $val : ''; + $key = $self->_url_decode($key); + $val = $self->_url_decode($val); + + # looking for multi-value params + if ( exists $query_params->{$key} ) { + my $prev_val = $query_params->{$key}; + if ( is_arrayref($prev_val) ) { + push @{ $query_params->{$key} }, $val; + } + else { + $query_params->{$key} = [ $prev_val, $val ]; + } + } + + # simple value param (first time we see it) + else { + $query_params->{$key} = $val; + } + } + $self->_set_query_params( $query_params ); + return $self->_query_params; +} + +sub _build_uploads { + my ($self) = @_; + + # parse body and build body params + my $body_params = $self->_body_params; + + my $uploads = $self->SUPER::uploads; + my %uploads; + + for my $name ( keys %$uploads ) { + my @uploads = map Dancer2::Core::Request::Upload->new( + # For back-compatibility, we use a HashRef of headers + headers => {@{$_->{headers}->psgi_flatten_without_sort}}, + tempname => $_->{tempname}, + size => $_->{size}, + filename => _decode( $_->{filename} ), + ), $uploads->get_all($name); + + $uploads{$name} = @uploads > 1 ? \@uploads : $uploads[0]; + + # support access to the filename as a normal param + my @filenames = map $_->{'filename'}, @uploads; + $self->{_body_params}{$name} = + @filenames > 1 ? \@filenames : $filenames[0]; + } + + $self->{uploads} = \%uploads; +} + +# XXX: incompatible with Plack::Request +sub cookies { $_[0]->{'cookies'} ||= $_[0]->_build_cookies } + +sub _build_cookies { + my $self = shift; + my $cookies = {}; + + my $http_cookie = $self->header('Cookie'); + return $cookies unless defined $http_cookie; # nothing to do + + if ( $XS_HTTP_COOKIES ) { + $cookies = HTTP::XSCookies::crush_cookie($http_cookie); + } + else { + # handle via Plack::Request + $cookies = $self->SUPER::cookies(); + } + + # convert to objects + while (my ($name, $value) = each %{$cookies}) { + $cookies->{$name} = Dancer2::Core::Cookie->new( + name => $name, + # HTTP::XSCookies v0.17+ will do the split and return an arrayref + value => (is_arrayref($value) ? $value : [split(/[&;]/, $value)]) + ); + } + return $cookies; +} + +# poor man's clone +sub _shallow_clone { + my ($self, $params, $options) = @_; + + # shallow clone $env; we don't want to alter the existing one + # in $self, then merge any overridden values + my $env = { %{ $self->env }, %{ $options || {} } }; + + # request body fh has been read till end + # delete CONTENT_LENGTH in new request (no need to parse body again) + # and merge existing params + delete $env->{CONTENT_LENGTH}; + + my $new_request = __PACKAGE__->new( + env => $env, + body_params => {}, + ); + + # Clone and merge query params + my $new_params = $self->params; + $new_request->{_query_params} = { %{ $self->{_query_params} || {} } }; + $new_request->{query_parameters} = $self->query_parameters->clone; + for my $key ( keys %{ $params || {} } ) { + my $value = $params->{$key}; + $new_params->{$key} = $value; + $new_request->{_query_params}->{$key} = $value; + $new_request->{query_parameters}->add( $key => $value ); + } + + # Copy params (these are already decoded) + $new_request->{_params} = $new_params; + $new_request->{_body_params} = $self->{_body_params}; + $new_request->{_route_params} = $self->{_route_params}; + $new_request->{body} = $self->body; + $new_request->{headers} = $self->headers; + + # Copy remaining settings + $new_request->{is_behind_proxy} = $self->{is_behind_proxy}; + $new_request->{vars} = $self->{vars}; + + # Clone any existing decoded & cached body params. (GH#1116 GH#1269) + $new_request->{'body_parameters'} = $self->body_parameters->clone; + + # Delete merged HMV parameters, allowing them to be reconstructed on first use. + delete $new_request->{'merged_parameters'}; + + return $new_request; +} + + +sub _set_route { + my ( $self, $route ) = @_; + $self->{'route'} = $route; +} + +sub route { $_[0]->{'route'} } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Request - Interface for accessing incoming requests + +=head1 VERSION + +version 0.206000 + +=head1 SYNOPSIS + +In a route handler, the current request object can be accessed by the +C keyword: + + get '/foo' => sub { + request->params; # request, params parsed as a hash ref + request->body; # returns the request body, unparsed + request->path; # the path requested by the client + # ... + }; + +=head1 DESCRIPTION + +An object representing a Dancer2 request. It aims to provide a proper +interface to anything you might need from a web request. + +=head1 METHODS + +=head2 address + +Return the IP address of the client. + +=head2 base + +Returns an absolute URI for the base of the application. Returns a L +object (which stringifies to the URL, as you'd expect). + +=head2 body_parameters + +Returns a L object representing the POST parameters. + +=head2 body + +Return the raw body of the request, unparsed. + +If you need to access the body of the request, you have to use this accessor and +should not try to read C by hand. C +already did it for you and kept the raw body untouched in there. + +=head2 content + +Returns the undecoded byte string POST body. + +=head2 cookies + +Returns a reference to a hash containing cookies, where the keys are the names of the +cookies and values are L objects. + +=head2 data + +If the application has a serializer and if the request has serialized +content, returns the deserialized structure as a hashref. + +=head2 dispatch_path + +Alias for L. Deprecated. + +=head2 env + +Return the current PSGI environment hash reference. + +=head2 header($name) + +Return the value of the given header, if present. If the header has multiple +values, returns an the list of values if called in list context, the first one +in scalar. + +=head2 headers + +Returns either an L or an L object +representing the headers. + +=head2 id + +The ID of the request. This allows you to trace a specific request in loggers, +per the string created using C. + +The ID of the request is essentially the number of requests run in the current +class. + +=head2 input + +Alias to C method below. + +=head2 input_handle + +Alias to the PSGI input handle (C<< env->{psgi.input}> >>) + +=head2 is_ajax + +Return true if the value of the header C is +C. + +=head2 is_delete + +Return true if the method requested by the client is 'DELETE' + +=head2 is_get + +Return true if the method requested by the client is 'GET' + +=head2 is_head + +Return true if the method requested by the client is 'HEAD' + +=head2 is_post + +Return true if the method requested by the client is 'POST' + +=head2 is_put + +Return true if the method requested by the client is 'PUT' + +=head2 is_options + +Return true if the method requested by the client is 'OPTIONS' + +=head2 logger + +Returns the C code reference, if exists. + +=head2 method + +Return the HTTP method used by the client to access the application. + +While this method returns the method string as provided by the environment, it's +better to use one of the following boolean accessors if you want to inspect the +requested method. + +=head2 new + +The constructor of the class, used internally by Dancer2's core to create request +objects. + +It uses the environment hash table given to build the request object: + + Dancer2::Core::Request->new( env => $env ); + +There are two additional parameters for instantiation: + +=over 4 + +=item * serializer + +A serializer object to work with when reading the request body. + +=item * body_params + +Provide body parameters. + +Used internally when we need to avoid parsing the body again. + +=back + +=head2 param($key) + +Calls the C method below and fetches the key provided. + +=head2 params($source) + +Called in scalar context, returns a hashref of params, either from the specified +source (see below for more info on that) or merging all sources. + +So, you can use, for instance: + + my $foo = params->{foo} + +If called in list context, returns a list of key and value pairs, so you could use: + + my %allparams = params; + +Parameters are merged in the following order: query, body, route - i.e. route +parameters have the highest priority: + + POST /hello/Ruth?name=Quentin + + name=Bobbie + + post '/hello/:name' => sub { + return "Hello, " . route_parameters->get('name') . "!"; # returns Ruth + return "Hello, " . query_parameters->get('name') . "!"; # returns Quentin + return "Hello, " . body_parameters->get('name') . "!"; # returns Bobbie + return "Hello, " . param('name') . "!"; # returns Ruth + }; + +The L, L, and L keywords +provide a L result from the three different parameters. +We recommend using these rather than C, because of the potential for +unintentional behaviour - consider the following request and route handler: + + POST /artist/104/new-song + + name=Careless Dancing + + post '/artist/:id/new-song' => sub { + find_artist(param('id'))->create_song(params); + # oops! we just passed id into create_song, + # but we probably only intended to pass name + find_artist(param('id'))->create_song(body_parameters); + }; + + POST /artist/104/join-band + + id=4 + name=Dancing Misfits + + post '/artist/:id/new-song' => sub { + find_artist(param('id'))->join_band(params); + # oops! we just passed an id of 104 into join_band, + # but we probably should have passed an id of 4 + }; + +=head2 parameters + +Returns a L object with merged GET and POST parameters. + +Parameters are merged in the following order: query, body, route - i.e. route +parameters have the highest priority - see L for how this works, and +associated risks and alternatives. + +=head2 path + +The path requested by the client, normalized. This is effectively +C or a single forward C. + +=head2 path_info + +The raw requested path. This could be empty. Use C instead. + +=head2 port + +Return the port of the server. + +=head2 protocol + +Return the protocol (I or I) used for the request. + +=head2 query_parameters + +Returns a L parameters object. + +=head2 query_string + +Returns the portion of the request defining the query itself - this is +what comes after the C in a URI. + +=head2 raw_body + +Alias to C method. + +=head2 remote_address + +Alias for C
    method. + +=head2 remote_host + +Return the remote host of the client. This only works with web servers configured +to do a reverse DNS lookup on the client's IP address. + +=head2 request_method + +Alias to the C accessor, for backward-compatibility with C interface. + +=head2 request_uri + +Return the raw, undecoded request URI path. + +=head2 route + +Return the L which this request matched. + +=head2 scheme + +Return the scheme of the request + +=head2 script_name + +Return script_name from the environment. + +=head2 secure + +Return true or false, indicating whether the connection is secure - this is +effectively checking if the scheme is I or not. + +=head2 serializer + +Returns the optional serializer object used to deserialize request parameters. + +=head2 session + +Returns the C hash, if exists. + +=head2 session_options + +Returns the C hash, if exists. + +=head2 to_string + +Return a string representing the request object (e.g., C). + +=head2 upload($name) + +Context-aware accessor for uploads. It's a wrapper around an access to the hash +table provided by C. It looks at the calling context and returns a +corresponding value. + +If you have many file uploads under the same name, and call C in +an array context, the accessor will unroll the ARRAY ref for you: + + my @uploads = request->upload('many_uploads'); # OK + +Whereas with a manual access to the hash table, you'll end up with one element +in C<@uploads>, being the arrayref: + + my @uploads = request->uploads->{'many_uploads'}; + # $uploads[0]: ARRAY(0xXXXXX) + +That is why this accessor should be used instead of a manual access to +C. + +=head2 uploads + +Returns a reference to a hash containing uploads. Values can be either a +L object, or an arrayref of +L +objects. + +You should probably use the C accessor instead of manually accessing the +C hash table. + +=head2 uri + +An alias to C. + +=head2 uri_base + +Same thing as C above, except it removes the last trailing slash in the +path if it is the only path. + +This means that if your base is I, C will return +I (notice no trailing slash). This is considered very useful +when using templates to do the following thing: + + + +=head2 uri_for(path, params) + +Constructs a URI from the base and the passed path. If params (hashref) is +supplied, these are added to the query string of the URI. + +Thus, with the following base: + + http://localhost:5000/foo + +You get the following behavior: + + my $uri = request->uri_for('/bar', { baz => 'baz' }); + print $uri; # http://localhost:5000/foo/bar?baz=baz + +C returns a L object (which can stringify to the value). + +=head2 user + +Return remote user if defined. + +=head2 var + +By-name interface to variables stored in this request object. + + my $stored = $request->var('some_variable'); + +returns the value of 'some_variable', while + + $request->var('some_variable' => 'value'); + +will set it. + +=head2 vars + +Access to the internal hash of variables: + + my $value = $request->vars->{'my_key'}; + +You want to use C above. + +=head1 Common HTTP request headers + +Commonly used client-supplied HTTP request headers are available through +specific accessors: + +=over 4 + +=item C + +HTTP header: C. + +=item C + +HTTP header: C. + +=item C + +HTTP header: C. + +=item C + +HTTP header: C. + +=item C + +Alias for C) below. + +=item C + +HTTP header: C. + +=item C + +HTTP header: C. + +=item C + +HTTP header: C. + +=item C + +HTTP header: C. + +=item C + +HTTP header: C. + +=item C + +HTTP header: C. + +=item C + +One of either C, C, or +C. + +=item C + +Checks whether we are behind a proxy using the C +configuration option, and if so returns the first +C, since this is a comma separated list. + +If you have not configured that you are behind a proxy, it returns HTTP +header C. + +=item C + +HTTP header: C. + +=item C + +HTTP header: C. + +=item C + +HTTP header: C. + +=item C + +HTTP header: C. + +=back + +=head1 Fetching only params from a given source + +If a required source isn't specified, a mixed hashref (or list of key value +pairs, in list context) will be returned; this will contain params from all +sources (route, query, body). + +In practical terms, this means that if the param C is passed both on the +querystring and in a POST body, you can only access one of them. + +If you want to see only params from a given source, you can say so by passing +the C<$source> param to C: + + my %querystring_params = params('query'); + my %route_params = params('route'); + my %post_params = params('body'); + +If source equals C, then only params parsed from the route pattern +are returned. + +If source equals C, then only params parsed from the query string are +returned. + +If source equals C, then only params sent in the request body will be +returned. + +If another value is given for C<$source>, then an exception is triggered. + +=head1 EXTRA SPEED + +If L detects the following modules as installed, +it will use them to speed things up: + +=over 4 + +=item * L + +=item * L + +=back + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Request/Upload.pm b/cpanlib/Dancer2/Core/Request/Upload.pm new file mode 100644 index 0000000..1f9a4b1 --- /dev/null +++ b/cpanlib/Dancer2/Core/Request/Upload.pm @@ -0,0 +1,178 @@ +package Dancer2::Core::Request::Upload; +# ABSTRACT: Class representing file upload requests +$Dancer2::Core::Request::Upload::VERSION = '0.206000'; +use Moo; + +use Carp; +use File::Spec; +use Module::Runtime 'require_module'; + +use Dancer2::Core::Types; +use Dancer2::FileUtils qw(open_file); + +has filename => ( + is => 'ro', + isa => Str, +); + +has tempname => ( + is => 'ro', + isa => Str, +); + +has headers => ( + is => 'ro', + isa => HashRef, +); + +has size => ( + is => 'ro', + isa => Num, +); + +sub file_handle { + my ($self) = @_; + return $self->{_fh} if defined $self->{_fh}; + my $fh = open_file( '<', $self->tempname ); + $self->{_fh} = $fh; +} + +sub copy_to { + my ( $self, $target ) = @_; + require_module('File::Copy'); + File::Copy::copy( $self->tempname, $target ); +} + +sub link_to { + my ( $self, $target ) = @_; + CORE::link( $self->tempname, $target ); +} + +sub content { + my ( $self, $layer ) = @_; + return $self->{_content} + if defined $self->{_content}; + + $layer = ':raw' unless $layer; + + my $content = undef; + my $handle = $self->file_handle; + + binmode( $handle, $layer ); + + while ( $handle->read( my $buffer, 8192 ) ) { + $content .= $buffer; + } + + $self->{_content} = $content; +} + +sub basename { + my ($self) = @_; + require_module('File::Basename'); + File::Basename::basename( $self->filename ); +} + +sub type { + my $self = shift; + return $self->headers->{'Content-Type'}; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Request::Upload - Class representing file upload requests + +=head1 VERSION + +version 0.206000 + +=head1 DESCRIPTION + +This class implements a representation of file uploads for Dancer2. +These objects are accessible within route handlers via the request->uploads +keyword. See L for details. + +=head1 ATTRIBUTES + +=head2 filename + +Filename as sent by client. optional. May not be undef. + +=head2 tempname + +The name of the temporary file the data has been saved to. Optional. May not be undef. + +=head2 headers + +A hash ref of the headers associated with this upload. optional. is read-write and a HashRef. + +=head2 size + +The size of the upload, in bytes. Optional. + +=head1 METHODS + +=head2 my $filename=$upload->filename; + +Returns the filename (full path) as sent by the client. + +=head2 my $tempname=$upload->tempname; + +Returns the name of the temporary file the data has been saved to. + +For example, in directory /tmp, and given a random name, with no file extension. + +=head2 my $href=$upload->headers; + +Returns a hashRef of the headers associated with this upload. + +=head2 my $fh=$upload->file_handle; + +Returns a read-only file handle on the temporary file. + +=head2 $upload->copy_to('/path/to/target') + +Copies the temporary file using File::Copy. Returns true for success, +false for failure. + +=head2 $upload->link_to('/path/to/target'); + +Creates a hard link to the temporary file. Returns true for success, +false for failure. + +=head2 my $content=$upload->content; + +Returns a scalar containing the contents of the temporary file. + +=head2 my $basename=$upload->basename; + +Returns basename for "filename". + +=head2 $upload->type + +Returns the Content-Type of this upload. + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Response.pm b/cpanlib/Dancer2/Core/Response.pm new file mode 100644 index 0000000..5b1f71c --- /dev/null +++ b/cpanlib/Dancer2/Core/Response.pm @@ -0,0 +1,406 @@ +# ABSTRACT: Response object for Dancer2 + +package Dancer2::Core::Response; +$Dancer2::Core::Response::VERSION = '0.206000'; +use Moo; + +use Encode; +use Dancer2::Core::Types; + +use Dancer2 (); +use Dancer2::Core::HTTP; + +use HTTP::Headers::Fast; +use Scalar::Util qw(blessed); +use Plack::Util; +use Safe::Isa; +use Sub::Quote (); + +use overload + '@{}' => sub { $_[0]->to_psgi }, + '""' => sub { $_[0] }; + +has headers => ( + is => 'ro', + isa => InstanceOf['HTTP::Headers'], + lazy => 1, + coerce => sub { + my ($value) = @_; + # HTTP::Headers::Fast reports that it isa 'HTTP::Headers', + # but there is no actual inheritance. + $value->$_isa('HTTP::Headers') + ? $value + : HTTP::Headers::Fast->new(@{$value}); + }, + default => sub { + HTTP::Headers::Fast->new(); + }, + handles => [qw
    ], +); + +sub headers_to_array { + my $self = shift; + my $headers = shift || $self->headers; + + my @hdrs; + $headers->scan( sub { + my ( $k, $v ) = @_; + $v =~ s/\015\012[\040|\011]+/chr(32)/ge; # replace LWS with a single SP + $v =~ s/\015|\012//g; # remove CR and LF since the char is invalid here + push @hdrs, $k => $v; + }); + + return \@hdrs; +} + +# boolean to tell if the route passes or not +has has_passed => ( + is => 'rw', + isa => Bool, + default => sub {0}, +); + +sub pass { shift->has_passed(1) } + +has serializer => ( + is => 'ro', + isa => ConsumerOf ['Dancer2::Core::Role::Serializer'], +); + +has is_encoded => ( + is => 'rw', + isa => Bool, + default => sub {0}, +); + +has is_halted => ( + is => 'rw', + isa => Bool, + default => sub {0}, +); + +sub halt { + my ( $self, $content ) = @_; + $self->content( $content ) if @_ > 1; + $self->is_halted(1); +} + +has status => ( + is => 'rw', + isa => Num, + default => sub {200}, + lazy => 1, + coerce => sub { Dancer2::Core::HTTP->status(shift) }, +); + +has content => ( + is => 'rw', + isa => Str, + predicate => 'has_content', + clearer => 'clear_content', +); + +has server_tokens => ( + is => 'ro', + isa => Bool, + default => sub {1}, +); + +around content => sub { + my ( $orig, $self ) = ( shift, shift ); + + # called as getter? + @_ or return $self->$orig; + + # No serializer defined; encode content + $self->serializer + or return $self->$orig( $self->encode_content(@_) ); + + # serialize content + my $serialized = $self->serialize(@_); + $self->is_encoded(1); # All serializers return byte strings + return $self->$orig( defined $serialized ? $serialized : '' ); +}; + +has default_content_type => ( + is => 'rw', + isa => Str, + default => sub {'text/html'}, +); + +sub encode_content { + my ( $self, $content ) = @_; + + return $content if $self->is_encoded; + + # Apply default content type if none set. + my $ct = $self->content_type || + $self->content_type( $self->default_content_type ); + + return $content if $ct !~ /^text/; + + # we don't want to encode an empty string, it will break the output + $content or return $content; + + $self->content_type("$ct; charset=UTF-8") + if $ct !~ /charset/; + + $self->is_encoded(1); + return Encode::encode( 'UTF-8', $content ); +} + +sub new_from_plack { + my ($self, $psgi_res) = @_; + + return Dancer2::Core::Response->new( + status => $psgi_res->status, + headers => $psgi_res->headers, + content => $psgi_res->body, + ); +} + +sub new_from_array { + my ($self, $arrayref) = @_; + + return Dancer2::Core::Response->new( + status => $arrayref->[0], + headers => $arrayref->[1], + content => $arrayref->[2][0], + ); +} + +sub to_psgi { + my ($self) = @_; + + $self->server_tokens + and $self->header( 'Server' => "Perl Dancer2 " . Dancer2->VERSION ); + + my $headers = $self->headers; + my $status = $self->status; + + Plack::Util::status_with_no_entity_body($status) + and return [ $status, $self->headers_to_array($headers), [] ]; + + my $content = $self->content; + # It is possible to have no content and/or no content type set + # e.g. if all routes 'pass'. Set the default value for the content + # (an empty string), allowing serializer hooks to be triggered + # as they may change the content.. + $content = $self->content('') if ! defined $content; + + if ( !$headers->header('Content-Length') && + !$headers->header('Transfer-Encoding') && + defined( my $content_length = length $content ) ) { + $headers->push_header( 'Content-Length' => $content_length ); + } + + # More defaults + $self->content_type or $self->content_type($self->default_content_type); + return [ $status, $self->headers_to_array($headers), [ $content ], ]; +} + +# sugar for accessing the content_type header, with mimetype care +sub content_type { + my $self = shift; + + if ( scalar @_ > 0 ) { + my $runner = Dancer2::runner(); + my $mimetype = $runner->mime_type->name_or_type(shift); + $self->header( 'Content-Type' => $mimetype ); + return $mimetype; + } + else { + return $self->header('Content-Type'); + } +} + +has _forward => ( + is => 'rw', + isa => HashRef, +); + +sub forward { + my ( $self, $uri, $params, $opts ) = @_; + $self->_forward( { to_url => $uri, params => $params, options => $opts } ); +} + +sub is_forwarded { + my $self = shift; + $self->_forward; +} + +sub redirect { + my ( $self, $destination, $status ) = @_; + $self->status( $status || 302 ); + + # we want to stringify the $destination object (URI object) + $self->header( 'Location' => "$destination" ); +} + +sub error { + my $self = shift; + + my $error = Dancer2::Core::Error->new( + response => $self, + @_, + ); + + $error->throw; + return $error; +} + +sub serialize { + my ($self, $content) = @_; + + my $serializer = $self->serializer + or return; + + $content = $serializer->serialize($content) + or return; + + $self->content_type( $serializer->content_type ); + return $content; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Response - Response object for Dancer2 + +=head1 VERSION + +version 0.206000 + +=head1 ATTRIBUTES + +=head2 is_encoded + +Flag to tell if the content has already been encoded. + +=head2 is_halted + +Flag to tell whether or not the response should continue to be processed. + +=head2 status + +The HTTP status for the response. + +=head2 content + +The content for the response, stored as a string. If a reference is passed, the +response will try coerce it to a string via double quote interpolation. + +=head2 default_content_type + +Default mime type to use for the response Content-Type header +if nothing was specified + +=head2 headers + +The attribute that store the headers in a L object. + +That attribute coerces from ArrayRef and defaults to an empty L +instance. + +=head1 METHODS + +=head2 pass + +Set has_passed to true. + +=head2 serializer() + +Returns the optional serializer object used to deserialize request parameters + +=head2 halt + +Shortcut to halt the current response by setting the is_halted flag. + +=head2 encode_content + +Encodes the stored content according to the stored L. If the content_type +is a text format C<^text>, then no encoding will take place. + +Internally, it uses the L flag to make sure that content is not encoded twice. + +If it encodes the content, then it will return the encoded content. In all other +cases it returns C. + +=head2 new_from_plack + +Creates a new response object from a L object. + +=head2 new_from_array + +Creates a new response object from a PSGI arrayref. + +=head2 to_psgi + +Converts the response object to a PSGI array. + +=head2 content_type($type) + +A little sugar for setting or accessing the content_type of the response, via the headers. + +=head2 redirect ($destination, $status) + +Sets a header in this response to give a redirect to $destination, and sets the +status to $status. If $status is omitted, or false, then it defaults to a status of +302. + +=head2 error( @args ) + + $response->error( message => "oops" ); + +Creates a L object with the given I<@args> and I +it against the response object. Returns the error object. + +=head2 serialize( $content ) + + $response->serialize( $content ); + +Serialize and return $content with the response's serializer. +set content-type accordingly. + +=head2 header($name) + +Return the value of the given header, if present. If the header has multiple +values, returns the list of values if called in list context, the first one +if in scalar context. + +=head2 push_header + +Add the header no matter if it already exists or not. + + $self->push_header( 'X-Wing' => '1' ); + +It can also be called with multiple values to add many times the same header +with different values: + + $self->push_header( 'X-Wing' => 1, 2, 3 ); + +=head2 headers_to_array($headers) + +Convert the C<$headers> to a PSGI ArrayRef. + +If no C<$headers> are provided, it will use the current response headers. + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Response/Delayed.pm b/cpanlib/Dancer2/Core/Response/Delayed.pm new file mode 100644 index 0000000..6e11d39 --- /dev/null +++ b/cpanlib/Dancer2/Core/Response/Delayed.pm @@ -0,0 +1,175 @@ +package Dancer2::Core::Response::Delayed; +# ABSTRACT: Delayed responses +$Dancer2::Core::Response::Delayed::VERSION = '0.206000'; +use Moo; +use Dancer2::Core::Types qw; + +has request => ( + is => 'ro', + isa => InstanceOf['Dancer2::Core::Request'], + required => 1, +); + +has response => ( + is => 'ro', + isa => InstanceOf['Dancer2::Core::Response'], + required => 1, + handles => [qw/status headers/], +); + +has cb => ( + is => 'ro', + isa => CodeRef, + required => 1, +); + +has error_cb => ( + is => 'ro', + isa => CodeRef, + predicate => '_has_error_cb', +); + +sub is_halted() {0} +sub has_passed() {0} + +sub to_psgi { + my $self = shift; + + return sub { + my $responder = shift; + + local $Dancer2::Core::Route::REQUEST = $self->request; + local $Dancer2::Core::Route::RESPONSE = $self->response; + local $Dancer2::Core::Route::RESPONDER = $responder; + local $Dancer2::Core::Route::WRITER; + + local $Dancer2::Core::Route::ERROR_HANDLER = + $self->_has_error_cb ? $self->error_cb : undef; + + $self->cb->(); + }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Response::Delayed - Delayed responses + +=head1 VERSION + +version 0.206000 + +=head1 SYNOPSIS + + my $response = Dancer2::Core::Response::Delayed->new( + request => Dancer2::Core::Request->new(...), + response => Dancer2::Core::Response->new(...), + cb => sub {...}, + + # optional error handling + error_cb => sub { + my ($error) = @_; + ... + }, + ); + + # or in an app + get '/' => sub { + # delayed response: + delayed { + # streaming content + content "data"; + content "more data"; + + # close user connection + done; + } on_error => sub { + my ($error) = @_; + warning 'Failed to stream to user: ' . request->remote_address; + }; + }; + +=head1 DESCRIPTION + +This object represents a delayed (asynchronous) response for L. +It can be used via the C keyword. + +It keeps references to a request and a response in order to avoid +keeping a reference to the application. + +=head1 ATTRIBUTES + +=head2 request + +Contains a request the delayed response uses. + +In the context of a web request, this will be the request that existed +when the delayed response has been created. + +=head2 response + +Contains a response the delayed response uses. + +In the context of a web request, this will be the response that existed +when the delayed response has been created. + +=head2 cb + +The code that will be run asynchronously. + +=head2 error_cb + +A callback for handling errors. This callback receives the error as its +first (and currently only) parameter. + +=head1 METHODS + +=head2 is_halted + +A method indicating whether the response has halted. + +This is useless in the context of an asynchronous request so it simply +returns no. + +This method is likely going away. + +=head2 has_passed + +A method indicating whether the response asked to skip the current +response. + +This is useless in the context of an asynchronous request so it simply +returns no. + +This method is likely going away. + +=head2 to_psgi + +Create a PSGI response. The way it works is by returning a proper PSGI +response subroutine which localizes the request and response (in case +the callback wants to edit them without a reference to them), and then +calls the callback. + +Finally, when the callback is done, it asks the response (whether it +was changed or not) to create its own PSGI response (calling C) +and sends that to the callback it receives as a delayed response. + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Role/ConfigReader.pm b/cpanlib/Dancer2/Core/Role/ConfigReader.pm new file mode 100644 index 0000000..bf91a52 --- /dev/null +++ b/cpanlib/Dancer2/Core/Role/ConfigReader.pm @@ -0,0 +1,357 @@ +# ABSTRACT: Config role for Dancer2 core objects +package Dancer2::Core::Role::ConfigReader; +$Dancer2::Core::Role::ConfigReader::VERSION = '0.206000'; +use Moo::Role; + +use File::Spec; +use Config::Any; +use Hash::Merge::Simple; +use Carp 'croak'; +use Module::Runtime 'require_module'; + +use Dancer2::Core::Factory; +use Dancer2::Core; +use Dancer2::Core::Types; +use Dancer2::FileUtils 'path'; + +with 'Dancer2::Core::Role::HasLocation'; + +has default_config => ( + is => 'ro', + isa => HashRef, + lazy => 1, + builder => '_build_default_config', +); + +has config_location => ( + is => 'ro', + isa => ReadableFilePath, + lazy => 1, + default => sub { $ENV{DANCER_CONFDIR} || $_[0]->location }, +); + +# The type for this attribute is Str because we don't require +# an existing directory with configuration files for the +# environments. An application without environments is still +# valid and works. +has environments_location => ( + is => 'ro', + isa => Str, + lazy => 1, + default => sub { + $ENV{DANCER_ENVDIR} + || File::Spec->catdir( $_[0]->config_location, 'environments' ) + || File::Spec->catdir( $_[0]->location, 'environments' ); + }, +); + +has config => ( + is => 'ro', + isa => HashRef, + lazy => 1, + builder => '_build_config', +); + +has environment => ( + is => 'ro', + isa => Str, + lazy => 1, + builder => '_build_environment', +); + +has config_files => ( + is => 'ro', + lazy => 1, + isa => ArrayRef, + builder => '_build_config_files', +); + +has local_triggers => ( + is => 'ro', + isa => HashRef, + default => sub { +{} }, +); + +has global_triggers => ( + is => 'ro', + isa => HashRef, + default => sub { + my $triggers = { + traces => sub { + my ( $self, $traces ) = @_; + # Carp is already a dependency + $Carp::Verbose = $traces ? 1 : 0; + }, + }; + + my $runner_config = defined $Dancer2::runner + ? Dancer2->runner->config + : {}; + + for my $global ( keys %$runner_config ) { + next if exists $triggers->{$global}; + $triggers->{$global} = sub { + my ($self, $value) = @_; + Dancer2->runner->config->{$global} = $value; + } + } + + return $triggers; + }, +); + +sub _build_default_config { +{} } + +sub _build_environment { 'development' } + +sub _build_config_files { + my ($self) = @_; + + my $location = $self->config_location; + # an undef location means no config files for the caller + return [] unless defined $location; + + my $running_env = $self->environment; + my @available_exts = Config::Any->extensions; + my @files; + + my @exts = @available_exts; + if (my $ext = $ENV{DANCER_CONFIG_EXT}) { + if (grep { $ext eq $_ } @available_exts) { + @exts = $ext; + warn "Only looking for configs ending in '$ext'\n" + if $ENV{DANCER_CONFIG_VERBOSE}; + } else { + warn "DANCER_CONFIG_EXT environment variable set to '$ext' which\n" . + "is not recognized by Config::Any. Looking for config file\n" . + "using default list of extensions:\n" . + "\t@available_exts\n"; + } + } + + foreach my $file ( [ $location, "config" ], + [ $self->environments_location, $running_env ] ) + { + foreach my $ext (@exts) { + my $path = path( $file->[0], $file->[1] . ".$ext" ); + next if !-r $path; + + # Look for *_local.ext files + my $local = path( $file->[0], $file->[1] . "_local.$ext" ); + push @files, $path, ( -r $local ? $local : () ); + } + } + + return \@files; +} + +sub _build_config { + my ($self) = @_; + + my $location = $self->config_location; + my $default = $self->default_config; + + my $config = Hash::Merge::Simple->merge( + $default, + map { + warn "Merging config file $_\n" if $ENV{DANCER_CONFIG_VERBOSE}; + $self->load_config_file($_) + } @{ $self->config_files } + ); + + $config = $self->_normalize_config($config); + return $config; +} + +sub _set_config_entries { + my ( $self, @args ) = @_; + my $no = scalar @args; + while (@args) { + $self->_set_config_entry( shift(@args), shift(@args) ); + } + return $no; +} + +sub _set_config_entry { + my ( $self, $name, $value ) = @_; + + $value = $self->_normalize_config_entry( $name, $value ); + $value = $self->_compile_config_entry( $name, $value, $self->config ); + $self->config->{$name} = $value; +} + +sub _normalize_config { + my ( $self, $config ) = @_; + + foreach my $key ( keys %{$config} ) { + my $value = $config->{$key}; + $config->{$key} = $self->_normalize_config_entry( $key, $value ); + } + return $config; +} + +sub _compile_config { + my ( $self, $config ) = @_; + + foreach my $key ( keys %{$config} ) { + my $value = $config->{$key}; + $config->{$key} = + $self->_compile_config_entry( $key, $value, $config ); + } + return $config; +} + +sub settings { shift->config } + +sub setting { + my $self = shift; + my @args = @_; + + return ( scalar @args == 1 ) + ? $self->settings->{ $args[0] } + : $self->_set_config_entries(@args); +} + +sub has_setting { + my ( $self, $name ) = @_; + return exists $self->config->{$name}; +} + +sub load_config_file { + my ( $self, $file ) = @_; + my $config; + + eval { + my @files = ($file); + my $tmpconfig = + Config::Any->load_files( { files => \@files, use_ext => 1 } )->[0]; + ( $file, $config ) = %{$tmpconfig} if defined $tmpconfig; + }; + if ( my $err = $@ || ( !$config ) ) { + croak "Unable to parse the configuration file: $file: $@"; + } + + # TODO handle mergeable entries + return $config; +} + +# private + +my $_normalizers = { + charset => sub { + my ($charset) = @_; + return $charset if !length( $charset || '' ); + + require_module('Encode'); + my $encoding = Encode::find_encoding($charset); + croak + "Charset defined in configuration is wrong : couldn't identify '$charset'" + unless defined $encoding; + my $name = $encoding->name; + + # Perl makes a distinction between the usual perl utf8, and the strict + # utf8 charset. But we don't want to make this distinction + $name = 'utf-8' if $name eq 'utf-8-strict'; + return $name; + }, +}; + +sub _normalize_config_entry { + my ( $self, $name, $value ) = @_; + $value = $_normalizers->{$name}->($value) + if exists $_normalizers->{$name}; + return $value; +} + +sub _compile_config_entry { + my ( $self, $name, $value, $config ) = @_; + + my $trigger = exists $self->local_triggers->{$name} ? + $self->local_triggers->{$name} : + $self->global_triggers->{$name}; + + defined $trigger or return $value; + + return $trigger->( $self, $value, $config ); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Role::ConfigReader - Config role for Dancer2 core objects + +=head1 VERSION + +version 0.206000 + +=head1 DESCRIPTION + +Provides a C attribute that feeds itself by finding and parsing +configuration files. + +Also provides a C method which is supposed to be used by externals to +read/write config entries. + +=head1 ATTRIBUTES + +=head2 location + +Absolute path to the directory where the server started. + +=head2 config_location + +Gets the location from the configuration. Same as C<< $object->location >>. + +=head2 environments_location + +Gets the directory were the environment files are stored. + +=head2 config + +Returns the whole configuration. + +=head2 environments + +Returns the name of the environment. + +=head2 config_files + +List of all the configuration files. + +=head1 METHODS + +=head2 settings + +Alias for config. Equivalent to <<$object->config>>. + +=head2 setting + +Get or set an element from the configuration. + +=head2 has_setting + +Verifies that a key exists in the configuration. + +=head2 load_config_file + +Load the configuration files. + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Role/DSL.pm b/cpanlib/Dancer2/Core/Role/DSL.pm new file mode 100644 index 0000000..555b6d4 --- /dev/null +++ b/cpanlib/Dancer2/Core/Role/DSL.pm @@ -0,0 +1,130 @@ +package Dancer2::Core::Role::DSL; +# ABSTRACT: Role for DSL +$Dancer2::Core::Role::DSL::VERSION = '0.206000'; +use Moo::Role; +use Dancer2::Core::Types; +use Carp 'croak'; +use Scalar::Util qw(); + +with 'Dancer2::Core::Role::Hookable'; + +has app => ( is => 'ro', required => 1 ); + +has keywords => ( + is => 'rw', + isa => HashRef, + lazy => 1, + builder => '_build_dsl_keywords', +); + +sub _build_dsl_keywords { + my ($self) = @_; + $self->can('dsl_keywords') + ? $self->dsl_keywords + : {}; +} + +sub register { + my ( $self, $keyword, $is_global ) = @_; + my $keywords = $self->keywords; + my $pkg = ref($self); + $pkg =~ s/__WITH__.+$//; + + if ( exists $keywords->{$keyword} ) { + my $reg_pkg = $keywords->{$keyword}{'pkg'}; + $reg_pkg =~ s/__WITH__.+$//; + $reg_pkg eq $pkg and return; + + croak "[$pkg] Keyword $keyword already registered by $reg_pkg"; + } + + $keywords->{$keyword} = { is_global => $is_global, pkg => $pkg }; +} + +sub dsl { $_[0] } + +# exports new symbol to caller +sub export_symbols_to { + my ( $self, $caller, $args ) = @_; + my $exports = $self->_construct_export_map($args); + + ## no critic + foreach my $export ( keys %{$exports} ) { + no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict) + my $existing = *{"${caller}::${export}"}{CODE}; + + next if defined $existing; + + *{"${caller}::${export}"} = $exports->{$export}; + } + ## use critic + + return keys %{$exports}; +} + +# private + +sub _compile_keyword { + my ( $self, $keyword, $opts ) = @_; + + my $code = $opts->{is_global} + ? sub { $self->$keyword(@_) } + : sub { + croak "Function '$keyword' must be called from a route handler" + unless defined $Dancer2::Core::Route::REQUEST; + + $self->$keyword(@_) + }; + + return $self->_apply_prototype($code, $opts); +} + +sub _apply_prototype { + my ($self, $code, $opts) = @_; + + # set prototype if one is defined for the keyword. undef => no prototype + my $prototype; + exists $opts->{'prototype'} and $prototype = $opts->{'prototype'}; + return Scalar::Util::set_prototype( \&$code, $prototype ); +} + +sub _construct_export_map { + my ( $self, $args ) = @_; + my $keywords = $self->keywords; + my %map; + foreach my $keyword ( keys %$keywords ) { + # check if the keyword were excluded from importation + $args->{ '!' . $keyword } and next; + $map{$keyword} = $self->_compile_keyword( $keyword, $keywords->{$keyword} ); + } + return \%map; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Role::DSL - Role for DSL + +=head1 VERSION + +version 0.206000 + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Role/Engine.pm b/cpanlib/Dancer2/Core/Role/Engine.pm new file mode 100644 index 0000000..5fbecca --- /dev/null +++ b/cpanlib/Dancer2/Core/Role/Engine.pm @@ -0,0 +1,71 @@ +package Dancer2::Core::Role::Engine; +# ABSTRACT: Role for engines +$Dancer2::Core::Role::Engine::VERSION = '0.206000'; +use Moo::Role; +use Dancer2::Core::Types; + +with 'Dancer2::Core::Role::Hookable'; + +has session => ( + is => 'ro', + isa => InstanceOf['Dancer2::Core::Session'], + writer => 'set_session', + clearer => 'clear_session', + predicate => 'has_session', +); + +has config => ( + is => 'ro', + isa => HashRef, + default => sub { {} }, +); + +has request => ( + is => 'ro', + isa => InstanceOf['Dancer2::Core::Request'], + writer => 'set_request', + clearer => 'clear_request', + predicate => 'has_request', +); + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Role::Engine - Role for engines + +=head1 VERSION + +version 0.206000 + +=head1 DESCRIPTION + +This role is intended to be consumed by all engine roles. It contains all the +shared logic for engines. + +This role consumes the L role. + +=head1 ATTRIBUTES + +=head2 config + +An HashRef that hosts the configuration bits for the engine. + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Role/Handler.pm b/cpanlib/Dancer2/Core/Role/Handler.pm new file mode 100644 index 0000000..a58910e --- /dev/null +++ b/cpanlib/Dancer2/Core/Role/Handler.pm @@ -0,0 +1,52 @@ +package Dancer2::Core::Role::Handler; +# ABSTRACT: Role for Handlers +$Dancer2::Core::Role::Handler::VERSION = '0.206000'; +use Moo::Role; +use Dancer2::Core::Types; + +requires 'register'; + +has app => ( + is => 'ro', + isa => InstanceOf ['Dancer2::Core::App'], + weak_ref => 1, +); + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Role::Handler - Role for Handlers + +=head1 VERSION + +version 0.206000 + +=head1 ATTRIBUTES + +=head2 app + +Contain an object of class L. + +=head1 REQUIREMENTS + +This role requires the method C to be implemented. + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Role/HasLocation.pm b/cpanlib/Dancer2/Core/Role/HasLocation.pm new file mode 100644 index 0000000..68c0e15 --- /dev/null +++ b/cpanlib/Dancer2/Core/Role/HasLocation.pm @@ -0,0 +1,104 @@ +package Dancer2::Core::Role::HasLocation; +# ABSTRACT: Role for application location "guessing" +$Dancer2::Core::Role::HasLocation::VERSION = '0.206000'; +use Moo::Role; +use Dancer2::Core::Types; +use Dancer2::FileUtils; +use File::Spec; +use Sub::Quote 'quote_sub'; + +# the path to the caller script/app +# Note: to remove any ambiguity between the accessor for the +# 'caller' attribute and the core function caller(), explicitly +# specify we want the function 'CORE::caller' as the default for +# the attribute. +has caller => ( + is => 'ro', + isa => Str, + default => quote_sub( q{ + my ( $caller, $script ) = CORE::caller; + $script = File::Spec->abs2rel( $script ) if File::Spec->file_name_is_absolute( $script ); + $script; + } ), +); + +has location => ( + is => 'ro', + builder => '_build_location', +); + +# FIXME: i hate you most of all -- Sawyer X +sub _build_location { + my $self = shift; + my $script = $self->caller; + + # default to the dir that contains the script... + my $location = Dancer2::FileUtils::dirname($script); + + #we try to find bin and lib + my $subdir = $location; + my $subdir_found = 0; + + #maximum of 10 iterations, to prevent infinite loop + for ( 1 .. 10 ) { + + #try to find libdir and bindir to determine the root of dancer app + my $libdir = Dancer2::FileUtils::path( $subdir, 'lib' ); + my $bindir = Dancer2::FileUtils::path( $subdir, 'bin' ); + + #try to find .dancer_app file to determine the root of dancer app + my $dancerdir = Dancer2::FileUtils::path( $subdir, '.dancer' ); + + # if one of them is found, keep that; but skip ./blib since both lib and bin exist + # under it, but views and public do not. + if ( + ( $subdir !~ m![\\/]blib[\\/]?$! && -d $libdir && -d $bindir ) || + ( -f $dancerdir ) + ) { + $subdir_found = 1; + last; + } + + $subdir = Dancer2::FileUtils::path( $subdir, '..' ) || '.'; + last if File::Spec->rel2abs($subdir) eq File::Spec->rootdir; + + } + + my $path = $subdir_found ? $subdir : $location; + + # return if absolute + File::Spec->file_name_is_absolute($path) + and return $path; + + # convert relative to absolute + return File::Spec->rel2abs($path); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Role::HasLocation - Role for application location "guessing" + +=head1 VERSION + +version 0.206000 + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Role/Hookable.pm b/cpanlib/Dancer2/Core/Role/Hookable.pm new file mode 100644 index 0000000..92d6f99 --- /dev/null +++ b/cpanlib/Dancer2/Core/Role/Hookable.pm @@ -0,0 +1,146 @@ +package Dancer2::Core::Role::Hookable; +# ABSTRACT: Role for hookable objects +$Dancer2::Core::Role::Hookable::VERSION = '0.206000'; +use Moo::Role; +use Dancer2::Core; +use Dancer2::Core::Types; +use Carp 'croak'; +use Safe::Isa; + +requires 'supported_hooks', 'hook_aliases'; + +# The hooks registry +has hooks => ( + is => 'ro', + isa => HashRef, + builder => '_build_hooks', + lazy => 1, +); + +sub BUILD { } + +# after a hookable object is built, we go over its postponed hooks and register +# them if any. +after BUILD => sub { + my ( $self, $args ) = @_; + $self->_add_postponed_hooks($args) + if defined $args->{postponed_hooks}; +}; + +sub _add_postponed_hooks { + my ( $self, $args ) = @_; + my $postponed_hooks = $args->{postponed_hooks}; + + # find the internal name of the hooks, from the caller name + my $caller = ref($self); + my ( $dancer, $h_type, $h_name, @rest ) = map lc, split /::/, $caller; + $h_name = $rest[0] if $h_name eq 'role'; + if ( $h_type =~ /(template|logger|serializer|session)/ ) { + $h_name = $h_type; + $h_type = 'engine'; + } + + # keep only the hooks we want + $postponed_hooks = $postponed_hooks->{$h_type}{$h_name}; + return unless defined $postponed_hooks; + + foreach my $name ( keys %{$postponed_hooks} ) { + my $hook = $postponed_hooks->{$name}{hook}; + my $caller = $postponed_hooks->{$name}{caller}; + + $self->has_hook($name) + or croak "$h_name $h_type does not support the hook `$name'. (" + . join( ", ", @{$caller} ) . ")"; + + $self->add_hook($hook); + } +} + +# mst++ for the hint +sub _build_hooks { + my ($self) = @_; + my %hooks = map +( $_ => [] ), $self->supported_hooks; + return \%hooks; +} + +# This binds a coderef to an installed hook if not already +# existing +sub add_hook { + my ( $self, $hook ) = @_; + my $name = $hook->name; + my $code = $hook->code; + + croak "Unsupported hook '$name'" + unless $self->has_hook($name); + + push @{ $self->hooks->{$name} }, $code; +} + +# allows the caller to replace the current list of hooks at the given position +# this is useful if the object where this role is composed wants to compile the +# hooks. +sub replace_hook { + my ( $self, $position, $hooks ) = @_; + + croak "Hook '$position' must be installed first" + unless $self->has_hook($position); + + $self->hooks->{$position} = $hooks; +} + +# Boolean flag to tells if the hook is registered or not +sub has_hook { + my ( $self, $hook_name ) = @_; + return exists $self->hooks->{$hook_name}; +} + +# Execute the hook at the given position +sub execute_hook { + my $self = shift; + my $name = shift; + + $name and !ref $name + or croak "execute_hook needs a hook name"; + + $name = $self->hook_aliases->{$name} + if exists $self->hook_aliases->{$name}; + + croak "Hook '$name' does not exist" + if !$self->has_hook($name); + + $self->$_isa('Dancer2::Core::App') && + $self->log( core => "Entering hook $name" ); + + for my $hook ( @{ $self->hooks->{$name} } ) { + $hook->(@_); + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Role::Hookable - Role for hookable objects + +=head1 VERSION + +version 0.206000 + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Role/Logger.pm b/cpanlib/Dancer2/Core/Role/Logger.pm new file mode 100644 index 0000000..c6379db --- /dev/null +++ b/cpanlib/Dancer2/Core/Role/Logger.pm @@ -0,0 +1,344 @@ +package Dancer2::Core::Role::Logger; +# ABSTRACT: Role for logger engines +$Dancer2::Core::Role::Logger::VERSION = '0.206000'; +use Dancer2::Core::Types; + +use Moo::Role; +use POSIX 'strftime'; +use Data::Dumper; + +with 'Dancer2::Core::Role::Engine'; + +sub hook_aliases { +{} } +sub supported_hooks { + qw( + engine.logger.before + engine.logger.after + ); +} + +sub _build_type {'Logger'} + +# This is the only method to implement by logger engines. +# It receives the following arguments: +# $msg_level, $msg_content, it gets called only if the configuration allows +# a message of the given level to be logged. +requires 'log'; + +has auto_encoding_charset => ( + is => 'ro', + isa => Str, +); + +has app_name => ( + is => 'ro', + isa => Str, + default => sub {'-'}, +); + +has log_format => ( + is => 'rw', + isa => Str, + default => sub {'[%a:%P] %L @%T> %m in %f l. %l'}, +); + +my $_levels = { + + # levels < 0 are for core only + core => -10, + + # levels > 0 are for end-users only + debug => 1, + info => 2, + warn => 3, + warning => 3, + error => 4, +}; + +has log_level => ( + is => 'rw', + isa => Enum[keys %{$_levels}], + default => sub {'debug'}, +); + +sub _should { + my ( $self, $msg_level ) = @_; + my $conf_level = $self->log_level; + return $_levels->{$conf_level} <= $_levels->{$msg_level}; +} + +sub format_message { + my ( $self, $level, $message ) = @_; + chomp $message; + + $message = Encode::encode( $self->auto_encoding_charset, $message ) + if $self->auto_encoding_charset; + + my @stack = caller(8); + my $request = $self->request; + my $config = $self->config; + + my $block_handler = sub { + my ( $block, $type ) = @_; + if ( $type eq 't' ) { + return Encode::decode( + $config->{'charset'} || 'UTF-8', + POSIX::strftime( $block, localtime(time) ) + ); + } + elsif ( $type eq 'h' ) { + return ( $request && $request->header($block) ) || '-'; + } + else { + Carp::carp("{$block}$type not supported"); + return "-"; + } + }; + + my $chars_mapping = { + a => sub { $self->app_name }, + t => sub { + Encode::decode( + $config->{'charset'} || 'UTF-8', + POSIX::strftime( "%d/%b/%Y %H:%M:%S", localtime(time) ) + ); + }, + T => sub { POSIX::strftime( "%Y-%m-%d %H:%M:%S", localtime(time) ) }, + u => sub { + Encode::decode( + $config->{'charset'} || 'UTF-8', + POSIX::strftime( "%d/%b/%Y %H:%M:%S", gmtime(time) ) + ); + }, + U => sub { POSIX::strftime( "%Y-%m-%d %H:%M:%S", gmtime(time) ) }, + P => sub {$$}, + L => sub {$level}, + m => sub {$message}, + f => sub { $stack[1] || '-' }, + l => sub { $stack[2] || '-' }, + h => sub { + ( $request && ( $request->remote_host || $request->address ) ) || '-' + }, + i => sub { ( $request && $request->id ) || '-' }, + }; + + my $char_mapping = sub { + my $char = shift; + + my $cb = $chars_mapping->{$char}; + if ( !$cb ) { + Carp::carp "%$char not supported."; + return "-"; + } + $cb->($char); + }; + + my $fmt = $self->log_format; + + $fmt =~ s/ + (?: + \%\{(.+?)\}([a-z])| + \%([a-zA-Z]) + ) + / $1 ? $block_handler->($1, $2) : $char_mapping->($3) /egx; + + return $fmt . "\n"; +} + +sub _serialize { + my @vars = @_; + + return join q{}, map +( + ref $_ + ? Data::Dumper->new( [$_] )->Terse(1)->Purity(1)->Indent(0) + ->Sortkeys(1)->Dump() + : ( defined($_) ? $_ : 'undef' ) + ), @vars; +} + +around 'log' => sub { + my ($orig, $self, @args) = @_; + + $self->execute_hook( 'engine.logger.before', $self, @args ); + $self->$orig( @args ); + $self->execute_hook( 'engine.logger.after', $self, @args ); +}; + +sub core { + my ( $self, @args ) = @_; + $self->_should('core') and $self->log( 'core', _serialize(@args) ); +} + +sub debug { + my ( $self, @args ) = @_; + $self->_should('debug') and $self->log( 'debug', _serialize(@args) ); +} + +sub info { + my ( $self, @args ) = @_; + $self->_should('info') and $self->log( 'info', _serialize(@args) ); +} + +sub warning { + my ( $self, @args ) = @_; + $self->_should('warning') and $self->log( 'warning', _serialize(@args) ); +} + +sub error { + my ( $self, @args ) = @_; + $self->_should('error') and $self->log( 'error', _serialize(@args) ); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Role::Logger - Role for logger engines + +=head1 VERSION + +version 0.206000 + +=head1 DESCRIPTION + +Any class that consumes this role will be able to implement to write log messages. + +In order to implement this role, the consumer B implement the C +method. This method will receives as argument the C and the C. + +=head1 ATTRIBUTES + +=head2 auto_encoding_charset + +Charset to use when writing a message. + +=head2 app_name + +Name of the application. Can be used in the message. + +=head2 log_format + +This is a format string (or a preset name) to specify the log format. + +The possible values are: + +=over 4 + +=item %h + +host emitting the request + +=item %t + +date (local timezone, formatted like %d/%b/%Y %H:%M:%S) + +=item %T + +date (local timezone, formatted like %Y-%m-%d %H:%M:%S) + +=item %u + +date (UTC timezone, formatted like %d/%b/%Y %H:%M:%S) + +=item %U + +date (UTC timezone, formatted like %Y-%m-%d %H:%M:%S) + +=item %P + +PID + +=item %L + +log level + +=item %D + +timer + +=item %m + +message + +=item %f + +file name that emit the message + +=item %l + +line from the file + +=item %i + +request ID + +=item %{$fmt}t + +timer formatted with a valid time format + +=item %{header}h + +header value + +=back + +=head2 log_level + +Level to use by default. + +=head1 METHODS + +=head2 core + +Log messages as B. + +=head2 debug + +Log messages as B. + +=head2 info + +Log messages as B. + +=head2 warning + +Log messages as B. + +=head2 error + +Log messages as B. + +=head2 format_message + +Provides a common message formatting. + +=head1 CONFIGURATION + +The B configuration variable tells Dancer2 which engine to use. + +You can change it either in your config.yml file: + + # logging to console + logger: "console" + +The log format can also be configured, +please see L for details. + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Role/Serializer.pm b/cpanlib/Dancer2/Core/Role/Serializer.pm new file mode 100644 index 0000000..97017ce --- /dev/null +++ b/cpanlib/Dancer2/Core/Role/Serializer.pm @@ -0,0 +1,175 @@ +package Dancer2::Core::Role::Serializer; +# ABSTRACT: Role for Serializer engines +$Dancer2::Core::Role::Serializer::VERSION = '0.206000'; +use Moo::Role; +use Dancer2::Core::Types; +use Scalar::Util 'blessed'; + +with 'Dancer2::Core::Role::Engine'; + +sub hook_aliases { + { + before_serializer => 'engine.serializer.before', + after_serializer => 'engine.serializer.after', + } +} + +sub supported_hooks { values %{ shift->hook_aliases } } + +sub _build_type {'Serializer'} + +requires 'serialize'; +requires 'deserialize'; + +has log_cb => ( + is => 'ro', + isa => CodeRef, + default => sub { sub {1} }, +); + +has content_type => ( + is => 'ro', + isa => Str, + required => 1, + writer => 'set_content_type' +); + +around serialize => sub { + my ( $orig, $self, $content, $options ) = @_; + + blessed $self && $self->execute_hook( 'engine.serializer.before', $content ); + + $content or return $content; + + my $data; + eval { + $data = $self->$orig( $content, $options ); + blessed $self + and $self->execute_hook( 'engine.serializer.after', $data ); + 1; + } or do { + my $error = $@ || 'Zombie Error'; + blessed $self + and $self->log_cb->( core => "Failed to serialize content: $error" ); + }; + + return $data; +}; + +around deserialize => sub { + my ( $orig, $self, $content, $options ) = @_; + + $content && length $content > 0 + or return $content; + + my $data; + eval { + $data = $self->$orig($content, $options); + 1; + } or do { + my $error = $@ || 'Zombie Error'; + $self->log_cb->( core => "Failed to deserialize content: $error" ); + }; + + return $data; +}; + +# most serializer don't have to overload this one +sub support_content_type { + my ( $self, $ct ) = @_; + return unless $ct; + + my @toks = split /;/, $ct; + $ct = lc( $toks[0] ); + return $ct eq $self->content_type; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Role::Serializer - Role for Serializer engines + +=head1 VERSION + +version 0.206000 + +=head1 DESCRIPTION + +Any class that consumes this role will be able to be used as a +serializer under Dancer2. + +In order to implement this role, the consumer B implement the +methods C and C, and should define +the C attribute value. + +=head1 ATTRIBUTES + +=head2 content_type + +The I of the object after being serialized. For example, +a JSON serializer would have a I content type +defined. + +=head1 METHODS + +=head2 serialize($content, [\%options]) + +The serialize method need to be implemented by the consumer. It +receives the serializer class object and a reference to the object to +be serialized. Should return the object after being serialized, in the +content type defined by the C attribute. + +A third optional argument is a hash reference of options to the +serializer. + +The serialize method must return bytes and therefore has to handle any +encoding. + +=head2 deserialize($content, [\%options]) + +The inverse method of C. Receives the serializer class +object and a string that should be deserialized. The method should +return a reference to the deserialized Perl data structure. + +A third optional argument is a hash reference of options to the +serializer. + +The deserialize method receives encoded bytes and must therefore +handle any decoding required. + +=head1 CONFIGURATION + +The B configuration variable tells Dancer2 which engine to use. + +You can change it either in your config.yml file: + + #Set JSON engine + serializer: "JSON" + + # Prettify JSON output + engines: + serializer: + JSON: + pretty: 1 + +To know which engines are availables please see L + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Role/SessionFactory.pm b/cpanlib/Dancer2/Core/Role/SessionFactory.pm new file mode 100644 index 0000000..dea163f --- /dev/null +++ b/cpanlib/Dancer2/Core/Role/SessionFactory.pm @@ -0,0 +1,503 @@ +package Dancer2::Core::Role::SessionFactory; +# ABSTRACT: Role for session factories +$Dancer2::Core::Role::SessionFactory::VERSION = '0.206000'; +use Moo::Role; +with 'Dancer2::Core::Role::Engine'; + +use Carp 'croak'; +use Dancer2::Core::Session; +use Dancer2::Core::Types; +use Digest::SHA 'sha1'; +use List::Util 'shuffle'; +use MIME::Base64 'encode_base64url'; +use Module::Runtime 'require_module'; +use Ref::Util qw< is_ref is_arrayref is_hashref >; + +sub hook_aliases { +{} } +sub supported_hooks { + qw/ + engine.session.before_retrieve + engine.session.after_retrieve + + engine.session.before_create + engine.session.after_create + + engine.session.before_change_id + engine.session.after_change_id + + engine.session.before_destroy + engine.session.after_destroy + + engine.session.before_flush + engine.session.after_flush + /; +} + +sub _build_type { + 'SessionFactory'; +} # XXX vs 'Session'? Unused, so I can't tell -- xdg + +has log_cb => ( + is => 'ro', + isa => CodeRef, + default => sub { sub {1} }, +); + +has cookie_name => ( + is => 'ro', + isa => Str, + default => sub {'dancer.session'}, +); + +has cookie_domain => ( + is => 'ro', + isa => Str, + predicate => 1, +); + +has cookie_path => ( + is => 'ro', + isa => Str, + default => sub {"/"}, +); + +has cookie_duration => ( + is => 'ro', + isa => Str, + predicate => 1, +); + +has session_duration => ( + is => 'ro', + isa => Num, + predicate => 1, +); + +has is_secure => ( + is => 'rw', + isa => Bool, + default => sub {0}, +); + +has is_http_only => ( + is => 'rw', + isa => Bool, + default => sub {1}, +); + +sub create { + my ($self) = @_; + + my %args = ( id => $self->generate_id, ); + + $args{expires} = $self->cookie_duration + if $self->has_cookie_duration; + + my $session = Dancer2::Core::Session->new(%args); + + $self->execute_hook( 'engine.session.before_create', $session ); + + # XXX why do we _flush now? Seems unnecessary -- xdg, 2013-03-03 + eval { $self->_flush( $session->id, $session->data ) }; + croak "Unable to create a new session: $@" + if $@; + + $self->execute_hook( 'engine.session.after_create', $session ); + return $session; +} + +{ + my $COUNTER = 0; + my $CPRNG_AVAIL = eval { require_module('Math::Random::ISAAC::XS'); 1; } && + eval { require_module('Crypt::URandom'); 1; }; + + # don't initialize until generate_id is called so the ISAAC algorithm + # is seeded after any pre-forking + my $CPRNG; + + # prepend epoch seconds so session ID is roughly monotonic + sub generate_id { + my ($self) = @_; + + if ($CPRNG_AVAIL) { + $CPRNG ||= Math::Random::ISAAC::XS->new( + map { unpack( "N", Crypt::URandom::urandom(4) ) } 1 .. 256 ); + + # include $$ to ensure $CPRNG wasn't forked by accident + return encode_base64url( + pack( + "N6", + time, $$, $CPRNG->irand, + $CPRNG->irand, $CPRNG->irand, $CPRNG->irand + ) + ); + } + else { + my $seed = ( + rand(1_000_000_000) # a random number + . __FILE__ # the absolute path as a secret key + . $COUNTER++ # impossible to have two consecutive dups + . $$ # the process ID as another private constant + . "$self" # the instance's memory address for more entropy + . join( '', shuffle( 'a' .. 'z', 'A' .. 'Z', 0 .. 9 ) ) + + # a shuffled list of 62 chars, another random component + ); + return encode_base64url( pack( "Na*", time, sha1($seed) ) ); + } + + } +} + +sub validate_id { + my ($self, $id) = @_; + return $id =~ m/^[A-Za-z0-9_\-~]+$/; +} + +requires '_retrieve'; + +sub retrieve { + my ( $self, %params ) = @_; + my $id = $params{id}; + + $self->execute_hook( 'engine.session.before_retrieve', $id ); + + my $data; + # validate format of session id before attempt to retrieve + my $rc = eval { + $self->validate_id($id) && ( $data = $self->_retrieve($id) ); + }; + croak "Unable to retrieve session with id '$id'" + if ! $rc; + + my %args = ( id => $id, ); + + $args{data} = $data + if $data and is_hashref($data); + + $args{expires} = $self->cookie_duration + if $self->has_cookie_duration; + + my $session = Dancer2::Core::Session->new(%args); + + $self->execute_hook( 'engine.session.after_retrieve', $session ); + return $session; +} + +# XXX eventually we could perhaps require '_change_id'? + +sub change_id { + my ( $self, %params ) = @_; + my $session = $params{session}; + my $old_id = $session->id; + + $self->execute_hook( 'engine.session.before_change_id', $old_id ); + + my $new_id = $self->generate_id; + $session->id( $new_id ); + + eval { $self->_change_id( $old_id, $new_id ) }; + croak "Unable to change session id for session with id $old_id: $@" + if $@; + + $self->execute_hook( 'engine.session.after_change_id', $new_id ); +} + +requires '_destroy'; + +sub destroy { + my ( $self, %params ) = @_; + my $id = $params{id}; + $self->execute_hook( 'engine.session.before_destroy', $id ); + + eval { $self->_destroy($id) }; + croak "Unable to destroy session with id '$id': $@" + if $@; + + $self->execute_hook( 'engine.session.after_destroy', $id ); + return $id; +} + +requires '_flush'; + +sub flush { + my ( $self, %params ) = @_; + my $session = $params{session}; + $self->execute_hook( 'engine.session.before_flush', $session ); + + eval { $self->_flush( $session->id, $session->data ) }; + croak "Unable to flush session: $@" + if $@; + + $self->execute_hook( 'engine.session.after_flush', $session ); + return $session->id; +} + +sub set_cookie_header { + my ( $self, %params ) = @_; + $params{response}->push_header( + 'Set-Cookie', + $self->cookie( session => $params{session} )->to_header + ); +} + +sub cookie { + my ( $self, %params ) = @_; + my $session = $params{session}; + croak "cookie() requires a valid 'session' parameter" + unless is_ref($session) && $session->isa("Dancer2::Core::Session"); + + my %cookie = ( + value => $session->id, + name => $self->cookie_name, + path => $self->cookie_path, + secure => $self->is_secure, + http_only => $self->is_http_only, + ); + + $cookie{domain} = $self->cookie_domain + if $self->has_cookie_domain; + + if ( my $expires = $session->expires ) { + $cookie{expires} = $expires; + } + + return Dancer2::Core::Cookie->new(%cookie); +} + +requires '_sessions'; + +sub sessions { + my ($self) = @_; + my $sessions = $self->_sessions; + + croak "_sessions() should return an array ref" + unless is_arrayref($sessions); + + return $sessions; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Role::SessionFactory - Role for session factories + +=head1 VERSION + +version 0.206000 + +=head1 DESCRIPTION + +Any class that consumes this role will be able to store, create, retrieve and +destroy session objects. + +The default values for attributes can be overridden in your Dancer2 +configuration. See L. + +=head1 ATTRIBUTES + +=head2 cookie_name + +The name of the cookie to create for storing the session key + +Defaults to C + +=head2 cookie_domain + +The domain of the cookie to create for storing the session key. +Defaults to the empty string and is unused as a result. + +=head2 cookie_path + +The path of the cookie to create for storing the session key. +Defaults to "/". + +=head2 cookie_duration + +Default duration before session cookie expiration. If set, the +L C attribute will be set to the current time +plus this duration (expression parsed by L). + +=head2 session_duration + +Duration in seconds before sessions should expire, regardless of cookie +expiration. If set, then SessionFactories should use this to enforce a limit +on session validity. + +=head2 is_secure + +Boolean flag to tell if the session cookie is secure or not. + +Default is false. + +=head2 is_http_only + +Boolean flag to tell if the session cookie is http only. + +Default is true. + +=head1 INTERFACE + +Following is the interface provided by this role. When specified the required +methods to implement are described. + +=head2 create + +Create a brand new session object and store it. Returns the newly created +session object. + +Triggers an exception if the session is unable to be created. + + my $session = MySessionFactory->create(); + +This method does not need to be implemented in the class. + +=head2 generate_id + +Returns a randomly-generated, guaranteed-unique string. +By default, it is a 32-character, URL-safe, Base64 encoded combination +of a 32 bit timestamp and a 160 bit SHA1 digest of random seed data. +The timestamp ensures that session IDs are generally monotonic. + +The default algorithm is not guaranteed cryptographically secure, but it's +still reasonably strong for general use. + +If you have installed L and L, +the seed data will be generated from a cryptographically-strong +random number generator. + +This method is used internally by create() to set the session ID. + +This method does not need to be implemented in the class unless an +alternative method for session ID generation is desired. + +=head2 validate_id + +Returns true if a session id is of the correct format, or false otherwise. + +By default, this ensures that the session ID is a string of characters +from the Base64 schema for "URL Applications" plus the C<~> character. + +This method does not need to be implemented in the class unless an +alternative set of characters for session IDs is desired. + +=head2 retrieve + +Return the session object corresponding to the session ID given. If none is +found, triggers an exception. + + my $session = MySessionFactory->retrieve(id => $id); + +The method C<_retrieve> must be implemented. It must take C<$id> as a single +argument and must return a hash reference of session data. + +=head2 change_id + +Changes the session ID of the corresponding session. + + MySessionFactory->change_id(session => $session_object); + +The method C<_change_id> must be implemented. It must take C<$old_id> and +C<$new_id> as arguments and change the ID from the old one to the new one +in the underlying session storage. + +=head2 destroy + +Purges the session object that matches the ID given. Returns the ID of the +destroyed session if succeeded, triggers an exception otherwise. + + MySessionFactory->destroy(id => $id); + +The C<_destroy> method must be implemented. It must take C<$id> as a single +argument and destroy the underlying data. + +=head2 flush + +Make sure the session object is stored in the factory's backend. This method is +called to notify the backend about the change in the session object. + +The Dancer application will not call flush unless the session C +attribute is true to avoid unnecessary writes to the database when no +data has been modified. + +An exception is triggered if the session is unable to be updated in the backend. + + MySessionFactory->flush(session => $session); + +The C<_flush> method must be implemented. It must take two arguments: the C<$id> +and a hash reference of session data. + +=head2 set_cookie_header + +Sets the session cookie into the response object + + MySessionFactory->set_cookie_header( + response => $response, + session => $session, + destroyed => undef, + ); + +The C parameter contains a L object. +The C parameter contains a L object. + +The C parameter is optional. If true, it indicates the +session was marked destroyed by the request context. The default +C method doesn't need that information, but it is +included in case a SessionFactory must handle destroyed sessions +differently (such as signalling to middleware). + +=head2 cookie + +Coerce a session object into a L object. + + MySessionFactory->cookie(session => $session); + +=head2 sessions + +Return a list of all session IDs stored in the backend. +Useful to create cleaning scripts, in conjunction with session's creation time. + +The C<_sessions> method must be implemented. It must return an array reference +of session IDs (or an empty array reference). + +=head1 CONFIGURATION + +If there are configuration values specific to your session factory in your config.yml or +environment, those will be passed to the constructor of the session factory automatically. +In order to accept and store them, you need to define accessors for them. + + engines: + session: + Example: + database_connection: "some_data" + +In your session factory: + + package Dancer2::Session::Example; + use Moo; + with "Dancer2::Core::Role::SessionFactory"; + + has database_connection => ( is => "ro" ); + +You need to do this for every configuration key. The ones that do not have accessors +defined will just go to the void. + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Role/SessionFactory/File.pm b/cpanlib/Dancer2/Core/Role/SessionFactory/File.pm new file mode 100644 index 0000000..d5456bf --- /dev/null +++ b/cpanlib/Dancer2/Core/Role/SessionFactory/File.pm @@ -0,0 +1,189 @@ +package Dancer2::Core::Role::SessionFactory::File; +# ABSTRACT: Role for file-based session factories +$Dancer2::Core::Role::SessionFactory::File::VERSION = '0.206000'; +use Moo::Role; +with 'Dancer2::Core::Role::SessionFactory'; + +use Carp 'croak'; +use Dancer2::Core::Types; +use Dancer2::FileUtils qw(path set_file_mode escape_filename); +use Fcntl ':flock'; +use File::Copy (); + +#--------------------------------------------------------------------------# +# Required by classes consuming this role +#--------------------------------------------------------------------------# + +requires '_suffix'; # '.yml', '.json', etc. +requires '_thaw_from_handle'; # given handle, return session 'data' field +requires '_freeze_to_handle'; # given handle and data, serialize it + + +#--------------------------------------------------------------------------# +# Attributes and methods +#--------------------------------------------------------------------------# + +has session_dir => ( + is => 'ro', + isa => Str, + default => sub { path( '.', 'sessions' ) }, +); + +sub BUILD { + my $self = shift; + + if ( !-d $self->session_dir ) { + mkdir $self->session_dir + or croak "Unable to create session dir : " + . $self->session_dir . ' : ' + . $!; + } +} + +sub _sessions { + my ($self) = @_; + my $sessions = []; + + opendir( my $dh, $self->session_dir ) + or croak "Unable to open directory " . $self->session_dir . " : $!"; + + my $suffix = $self->_suffix; + + while ( my $file = readdir($dh) ) { + next if $file eq '.' || $file eq '..'; + if ( $file =~ /(\w+)\Q$suffix\E/ ) { + push @{$sessions}, $1; + } + } + closedir($dh); + + return $sessions; +} + +sub _retrieve { + my ( $self, $id ) = @_; + my $session_file = path( $self->session_dir, escape_filename($id) . $self->_suffix ); + + croak "Invalid session ID: $id" unless -f $session_file; + + open my $fh, '+<', $session_file or die "Can't open '$session_file': $!\n"; + flock $fh, LOCK_SH or die "Can't lock file '$session_file': $!\n"; + my $data = $self->_thaw_from_handle($fh); + close $fh or die "Can't close '$session_file': $!\n"; + + return $data; +} + +sub _change_id { + my ($self, $old_id, $new_id) = @_; + + my $old_path = + path($self->session_dir, escape_filename($old_id) . $self->_suffix); + + return if !-f $old_path; + + my $new_path = + path($self->session_dir, escape_filename($new_id) . $self->_suffix); + + File::Copy::move($old_path, $new_path); +} + +sub _destroy { + my ( $self, $id ) = @_; + my $session_file = path( $self->session_dir, escape_filename($id) . $self->_suffix ); + return if !-f $session_file; + + unlink $session_file; +} + +sub _flush { + my ( $self, $id, $data ) = @_; + my $session_file = path( $self->session_dir, escape_filename($id) . $self->_suffix ); + + open my $fh, '>', $session_file or die "Can't open '$session_file': $!\n"; + flock $fh, LOCK_EX or die "Can't lock file '$session_file': $!\n"; + seek $fh, 0, 0 or die "Can't seek in file '$session_file': $!\n"; + truncate $fh, 0 or die "Can't truncate file '$session_file': $!\n"; + set_file_mode($fh); + $self->_freeze_to_handle( $fh, $data ); + close $fh or die "Can't close '$session_file': $!\n"; + + return $data; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Role::SessionFactory::File - Role for file-based session factories + +=head1 VERSION + +version 0.206000 + +=head1 DESCRIPTION + +This is a specialized SessionFactory role for storing session +data in files. + +This role manages the files. Classes consuming it only need to handle +serialization and deserialization. + +Classes consuming this must satisfy three requirements: C<_suffix>, +C<_freeze_to_handle> and C<_thaw_from_handle>. + + package Dancer2::SessionFactory::XYX + + use Moo; + + has _suffix => ( + is => 'ro', + isa => 'Str', + default => sub { '.xyz' }, + ); + + with 'Dancer2::Core::Role::SessionFactory::File'; + + sub _freeze_to_handle { + my ($self, $fh, $data) = @_; + + # ... do whatever to get data into $fh + + return; + } + + sub _thaw_from_handle { + my ($self, $fh) = @_; + my $data; + + # ... do whatever to get data from $fh + + return $data; + } + + 1; + +=head1 ATTRIBUTES + +=head2 session_dir + +Where to store the session files. Defaults to "./sessions". + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Role/StandardResponses.pm b/cpanlib/Dancer2/Core/Role/StandardResponses.pm new file mode 100644 index 0000000..2ec4b71 --- /dev/null +++ b/cpanlib/Dancer2/Core/Role/StandardResponses.pm @@ -0,0 +1,70 @@ +package Dancer2::Core::Role::StandardResponses; +# ABSTRACT: Role to provide commonly used responses +$Dancer2::Core::Role::StandardResponses::VERSION = '0.206000'; +use Moo::Role; +use Dancer2::Core::HTTP; + +sub response { + my ( $self, $app, $code, $message ) = @_; + $app->response->status($code); + $app->response->header( 'Content-Type', 'text/plain' ); + return $message; +} + +sub standard_response { + my ( $self, $app, $status_code ) = @_; + + return $self->response( + $app, + $status_code, + Dancer2::Core::HTTP->status_message($status_code), + ); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Role::StandardResponses - Role to provide commonly used responses + +=head1 VERSION + +version 0.206000 + +=head1 METHODS + +=head2 response + +Generic method that produces a custom response given with a code and a message: + + $self->response( $app, 404, 'Not Found' ); + +This could be used to create your own, which is separate from the standard one: + + $self->response( $app, 404, 'File missing in action' ); + +=head2 standard_response + +Produces a standard response using the code. + + # first example can be more easily written as + $self->standard_response( $app, 404 ); + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Role/Template.pm b/cpanlib/Dancer2/Core/Role/Template.pm new file mode 100644 index 0000000..167cb42 --- /dev/null +++ b/cpanlib/Dancer2/Core/Role/Template.pm @@ -0,0 +1,364 @@ +# ABSTRACT: Role for template engines + +package Dancer2::Core::Role::Template; +$Dancer2::Core::Role::Template::VERSION = '0.206000'; +use Dancer2::Core::Types; +use Dancer2::FileUtils 'path'; +use Carp 'croak'; +use Ref::Util qw< is_ref >; + +use Moo::Role; +with 'Dancer2::Core::Role::Engine'; + +sub hook_aliases { + { + before_template_render => 'engine.template.before_render', + after_template_render => 'engine.template.after_render', + before_layout_render => 'engine.template.before_layout_render', + after_layout_render => 'engine.template.after_layout_render', + } +} + +sub supported_hooks { values %{ shift->hook_aliases } } + +sub _build_type {'Template'} + +requires 'render'; + +has log_cb => ( + is => 'ro', + isa => CodeRef, + default => sub { sub {1} }, +); + +has name => ( + is => 'ro', + lazy => 1, + builder => 1, +); + +sub _build_name { + ( my $name = ref shift ) =~ s/^Dancer2::Template:://; + $name; +} + +has charset => ( + is => 'ro', + isa => Str, + default => sub {'UTF-8'}, +); + +has default_tmpl_ext => ( + is => 'ro', + isa => Str, + default => sub { shift->config->{extension} || 'tt' }, +); + +has views => ( + is => 'rw', + isa => Maybe [Str], +); + +has layout => ( + is => 'rw', + isa => Maybe [Str], +); + +has engine => ( + is => 'ro', + isa => Object, + lazy => 1, + builder => 1, +); + +has settings => ( + is => 'ro', + isa => HashRef, + lazy => 1, + default => sub { +{} }, + writer => 'set_settings', +); + +has layout_dir => ( + is => 'ro', + isa => Str, + default => sub {'layouts'}, +); + +sub _template_name { + my ( $self, $view ) = @_; + my $def_tmpl_ext = $self->default_tmpl_ext(); + $view .= ".$def_tmpl_ext" if $view !~ /\.\Q$def_tmpl_ext\E$/; + return $view; +} + +sub view_pathname { + my ( $self, $view ) = @_; + + $view = $self->_template_name($view); + return path( $self->views, $view ); +} + +sub layout_pathname { + my ( $self, $layout ) = @_; + + return path( + $self->views, + $self->layout_dir, + $self->_template_name($layout), + ); +} + +sub pathname_exists { + my ( $self, $pathname ) = @_; + return -f $pathname; +} + +sub render_layout { + my ( $self, $layout, $tokens, $content ) = @_; + + $layout = $self->layout_pathname($layout); + + # FIXME: not sure if I can "just call render" + $self->render( $layout, { %$tokens, content => $content } ); +} + +sub apply_renderer { + my ( $self, $view, $tokens ) = @_; + $view = $self->view_pathname($view) if !is_ref($view); + $tokens = $self->_prepare_tokens_options( $tokens ); + + $self->execute_hook( 'engine.template.before_render', $tokens ); + + my $content = $self->render( $view, $tokens ); + $self->execute_hook( 'engine.template.after_render', \$content ); + + # make sure to avoid ( undef ) in list context return + defined $content and return $content; + return; +} + +sub apply_layout { + my ( $self, $content, $tokens, $options ) = @_; + + $tokens = $self->_prepare_tokens_options( $tokens ); + + # If 'layout' was given in the options hashref, use it if it's a true value, + # or don't use a layout if it was false (0, or undef); if layout wasn't + # given in the options hashref, go with whatever the current layout setting + # is. + my $layout = + exists $options->{layout} + ? ( $options->{layout} ? $options->{layout} : undef ) + : ( $self->layout || $self->config->{layout} ); + + # that should only be $self->config, but the layout ain't there ??? + + defined $content or return; + defined $layout or return $content; + + $self->execute_hook( + 'engine.template.before_layout_render', + $tokens, \$content + ); + + my $full_content = $self->render_layout( $layout, $tokens, $content ); + + $self->execute_hook( 'engine.template.after_layout_render', + \$full_content ); + + # make sure to avoid ( undef ) in list context return + defined $full_content and return $full_content; + return; +} + +sub _prepare_tokens_options { + my ( $self, $tokens ) = @_; + + # these are the default tokens provided for template processing + $tokens ||= {}; + $tokens->{perl_version} = $^V; + $tokens->{dancer_version} = Dancer2->VERSION; + $tokens->{settings} = $self->settings; + + # no request when template is called as a global keyword + if ( $self->has_request ) { + $tokens->{request} = $self->request; + $tokens->{params} = $self->request->params; + $tokens->{vars} = $self->request->vars; + + # a session can not exist if there is no request + $tokens->{session} = $self->session->data + if $self->has_session; + } + + return $tokens; +} + +sub process { + my ( $self, $view, $tokens, $options ) = @_; + my ( $content, $full_content ); + + # it's important that $tokens is not undef, so that things added to it via + # a before_template in apply_renderer survive to the apply_layout. GH#354 + $tokens ||= {}; + $options ||= {}; + + ## FIXME - Look into PR 654 so we fix the problem here as well! + + $content = + $view + ? $self->apply_renderer( $view, $tokens ) + : delete $options->{content}; + + defined $content + and $full_content = $self->apply_layout( $content, $tokens, $options ); + + defined $full_content + and return $full_content; + + croak "Template did not produce any content"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Role::Template - Role for template engines + +=head1 VERSION + +version 0.206000 + +=head1 DESCRIPTION + +Any class that consumes this role will be able to be used as a template engine +under Dancer2. + +In order to implement this role, the consumer B implement the method C. This method will receive three arguments: + +=over 4 + +=item $self + +=item $template + +=item $tokens + +=back + +Any template receives the following tokens, by default: + +=over 4 + +=item * C + +Current version of perl, effectively C<$^V>. + +=item * C + +Current version of Dancer2, effectively C<< Dancer2->VERSION >>. + +=item * C + +A hash of the application configuration. + +=item * C + +The current request object. + +=item * C + +A hash reference of all the parameters. + +Currently the equivalent of C<< $request->params >>. + +=item * C + +The list of request variables, which is what you would get if you +called the C keyword. + +=item * C + +The current session data, if a session exists. + +=back + +=head1 ATTRIBUTES + +=head2 name + +The name of the template engine (e.g.: Simple). + +=head2 charset + +The charset. The default value is B. + +=head2 default_tmpl_ext + +The default file extension. If not provided, B is used. + +=head2 views + +Path to the directory containing the views. + +=head2 layout + +Path to the directory containing the layouts. + +=head2 layout_dir + +Relative path to the layout directory. + +Default: B. + +=head2 engine + +Contains the engine. + +=head1 METHODS + +=head2 view_pathname($view) + +Returns the full path to the requested view. + +=head2 layout_pathname($layout) + +Returns the full path to the requested layout. + +=head2 pathname_exists($pathname) + +Returns true if the requested pathname exists. Can be used for either views +or layouts: + + $self->pathname_exists( $self->view_pathname( 'some_view' ) ); + $self->pathname_exists( $self->layout_pathname( 'some_layout' ) ); + +=head2 render_layout($layout, \%tokens, \$content) + +Render the layout with the applied tokens + +=head2 apply_renderer($view, \%tokens) + +=head2 apply_layout($content, \%tokens, \%options) + +=head2 process($view, \%tokens, \%options) + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Route.pm b/cpanlib/Dancer2/Core/Route.pm new file mode 100644 index 0000000..59ad98a --- /dev/null +++ b/cpanlib/Dancer2/Core/Route.pm @@ -0,0 +1,325 @@ +package Dancer2::Core::Route; +# ABSTRACT: Dancer2's route handler +$Dancer2::Core::Route::VERSION = '0.206000'; +use Moo; +use Dancer2::Core::Types; +use Carp 'croak'; +use List::Util 'first'; +use Scalar::Util 'blessed'; +use Ref::Util qw< is_regexpref >; + +our ( $REQUEST, $RESPONSE, $RESPONDER, $WRITER, $ERROR_HANDLER ); + +has method => ( + is => 'ro', + isa => Dancer2Method, + required => 1, +); + +has code => ( + is => 'ro', + required => 1, + isa => CodeRef, +); + +has regexp => ( + is => 'ro', + required => 1, +); + +has spec_route => ( is => 'ro' ); + +has prefix => ( + is => 'ro', + isa => Maybe [Dancer2Prefix], + predicate => 1, +); + +has options => ( + is => 'ro', + isa => HashRef, + trigger => \&_check_options, + predicate => 1, +); + +sub _check_options { + my ( $self, $options ) = @_; + return 1 unless defined $options; + + my @supported_options = ( + qw/content_type agent user_agent content_length + path_info/ + ); + for my $opt ( keys %{$options} ) { + croak "Not a valid option for route matching: `$opt'" + if not( grep {/^$opt$/} @supported_options ); + } + return 1; +} + +# private attributes + +has _should_capture => ( + is => 'ro', + isa => Bool, +); + +has _match_data => ( + is => 'rw', + isa => HashRef, +); + +has _params => ( + is => 'ro', + isa => ArrayRef, + default => sub { [] }, +); + +sub match { + my ( $self, $request ) = @_; + + if ( $self->has_options ) { + return unless $self->validate_options($request); + } + + my @values = $request->path =~ $self->regexp; + + return unless @values; + + # if some named captures are found, return captures + # no warnings is for perl < 5.10 + # - Note no @values implies no named captures + if (my %captures = + do { no warnings; %+ } + ) + { + return $self->_match_data( { captures => \%captures } ); + } + + # regex comments are how we know if we captured a token, + # splat or a megasplat + my @token_or_splat = $self->regexp =~ /\(\?#(token|(?:mega)?splat)\)/g; + if (@token_or_splat) { + # our named tokens + my @tokens = @{ $self->_params }; + + my %params; + my @splat; + for ( my $i = 0; $i < @values; $i++ ) { + # Is this value from a token? + if ( $token_or_splat[$i] eq 'token' ) { + $params{ shift @tokens } = $values[$i]; + next; + } + + # megasplat values are split on '/' + if ($token_or_splat[$i] eq 'megasplat') { + $values[$i] = [ + defined $values[$i] ? split( m{/} , $values[$i], -1 ) : () + ]; + } + push @splat, $values[$i]; + } + return $self->_match_data( { + %params, + (splat => \@splat)x!! @splat, + }); + } + + if ( $self->_should_capture ) { + return $self->_match_data( { splat => \@values } ); + } + + return $self->_match_data( {} ); +} + +sub execute { + my ( $self, $app, @args ) = @_; + local $REQUEST = $app->request; + local $RESPONSE = $app->response; + + my $content = $self->code->( $app, @args ); + + # users may set content in the response. If the response has + # content, and the returned value from the route code is not + # an object (well, reference) we ignore the returned value + # and use the existing content in the response instead. + $RESPONSE->has_content && !ref $content + and return $app->_prep_response( $RESPONSE ); + + my $type = blessed($content) + or return $app->_prep_response( $RESPONSE, $content ); + + # Plack::Response: proper ArrayRef-style response + $type eq 'Plack::Response' + and $RESPONSE = Dancer2::Core::Response->new_from_plack($RESPONSE); + + # CodeRef: raw PSGI response + # do we want to allow it and forward it back? + # do we want to upgrade it to an asynchronous response? + $type eq 'CODE' + and die "We do not support returning code references from routes.\n"; + + # Dancer2::Core::Response, Dancer2::Core::Response::Delayed: + # proper responses + $type eq 'Dancer2::Core::Response' + and return $RESPONSE; + + $type eq 'Dancer2::Core::Response::Delayed' + and return $content; + + # we can't handle arrayref or hashref + # because those might be serialized back + die "Unrecognized response type from route: $type.\n"; +} + +# private subs + +sub BUILDARGS { + my ( $class, %args ) = @_; + + my $prefix = $args{prefix}; + my $regexp = $args{regexp}; + + # init prefix + if ( $prefix ) { + $args{regexp} = + is_regexpref($regexp) ? qr{^\Q${prefix}\E${regexp}$} : + $prefix . $regexp; + } + elsif ( !is_regexpref($regexp) ) { + # No prefix, so ensure regexp begins with a '/' + index( $regexp, '/', 0 ) == 0 or $args{regexp} = "/$regexp"; + } + + # init regexp + $regexp = $args{regexp}; # updated value + $args{spec_route} = $regexp; + + if ( is_regexpref($regexp)) { + $args{_should_capture} = 1; + } + else { + @args{qw/ regexp _params _should_capture/} = + @{ _build_regexp_from_string($regexp) }; + } + + return \%args; +} + +sub _build_regexp_from_string { + my ($string) = @_; + + my $capture = 0; + my @params; + + # look for route with tokens [aka params] (/hello/:foo) + if ( $string =~ /:/ ) { + @params = $string =~ /:([^\/\.\?]+)/g; + if (@params) { + first { $_ eq 'splat' } @params + and warn q{Named placeholder 'splat' is deprecated}; + + first { $_ eq 'captures' } @params + and warn q{Named placeholder 'captures' is deprecated}; + + $string =~ s!(:[^\/\.\?]+)!(?#token)([^/]+)!g; + $capture = 1; + } + } + + # parse megasplat + # we use {0,} instead of '*' not to fall in the splat rule + # same logic for [^\n] instead of '.' + $capture = 1 if $string =~ s!\Q**\E!(?#megasplat)([^\n]+)!g; + + # parse wildcards + $capture = 1 if $string =~ s!\*!(?#splat)([^/]+)!g; + + # escape dots + $string =~ s/\./\\\./g if $string =~ /\./; + + # escape slashes + $string =~ s/\//\\\//g; + + return [ "^$string\$", \@params, $capture ]; +} + +sub validate_options { + my ( $self, $request ) = @_; + + for my $option ( keys %{ $self->options } ) { + return 0 + if ( + ( not $request->$option ) + || ( $request->$option !~ $self->options->{ $option } ) + ) + } + return 1; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Route - Dancer2's route handler + +=head1 VERSION + +version 0.206000 + +=head1 ATTRIBUTES + +=head2 method + +The HTTP method of the route (lowercase). Required. + +=head2 code + +The code reference to execute when the route is ran. Required. + +=head2 regexp + +The regular expression that defines the path of the route. +Required. Coerce from Dancer2's route I. + +=head2 prefix + +The prefix to prepend to the C. Optional. + +=head2 options + +A HashRef of conditions on which the matching will depend. Optional. + +=head1 METHODS + +=head2 match + +Try to match the route with a given L object. +Returns the hash of matching data if success (captures and values of the route +against the path of the request) or C if not. + + my $match = $route->match( $request ); + +=head2 execute + +Runs the coderef of the route. + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Runner.pm b/cpanlib/Dancer2/Core/Runner.pm new file mode 100644 index 0000000..9a6b5ff --- /dev/null +++ b/cpanlib/Dancer2/Core/Runner.pm @@ -0,0 +1,277 @@ +package Dancer2::Core::Runner; +# ABSTRACT: Top-layer class to start a dancer app +$Dancer2::Core::Runner::VERSION = '0.206000'; +use Moo; +use Carp 'croak'; +use Module::Runtime 'require_module'; +use Dancer2::Core::MIME; +use Dancer2::Core::Types; +use Dancer2::Core::Dispatcher; +use Plack::Builder qw(); +use Ref::Util qw< is_ref is_regexpref >; + +# Hashref of configurable items for the runner. +# Defaults come from ENV vars. Updated via global triggers +# from app configs. +has config => ( + is => 'ro', + isa => HashRef, + lazy => 1, + builder => '_build_config', +); + +# FIXME: i hate this +has mime_type => ( + is => 'ro', + isa => InstanceOf ['Dancer2::Core::MIME'], + default => sub { Dancer2::Core::MIME->new(); }, +); + +has server => ( + is => 'ro', + isa => InstanceOf['HTTP::Server::PSGI'], + lazy => 1, + builder => '_build_server', + handles => ['run'], +); + +has apps => ( + is => 'ro', + isa => ArrayRef, + default => sub { [] }, +); + +has postponed_hooks => ( + is => 'ro', + isa => HashRef, + default => sub { +{} }, +); + +has environment => ( + is => 'ro', + isa => Str, + required => 1, + default => sub { + $ENV{DANCER_ENVIRONMENT} || $ENV{PLACK_ENV} || 'development' + }, +); + +has host => ( + is => 'ro', + lazy => 1, + default => sub { $_[0]->config->{'host'} }, +); + +has port => ( + is => 'ro', + lazy => 1, + default => sub { $_[0]->config->{'port'} }, +); + +has timeout => ( + is => 'ro', + lazy => 1, + default => sub { $_[0]->config->{'timeout'} }, +); + +sub _build_server { + my $self = shift; + + require_module('HTTP::Server::PSGI'); + HTTP::Server::PSGI->new( + host => $self->host, + port => $self->port, + timeout => $self->timeout, + server_software => "Perl Dancer2 " . Dancer2->VERSION, + ); +} + +sub _build_config { + my $self = shift; + + $ENV{PLACK_ENV} + and $ENV{DANCER_APPHANDLER} = 'PSGI'; + + return { + behind_proxy => 0, + apphandler => ( $ENV{DANCER_APPHANDLER} || 'Standalone' ), + traces => ( $ENV{DANCER_TRACES} || 0 ), + host => ( $ENV{DANCER_SERVER} || '0.0.0.0' ), + port => ( $ENV{DANCER_PORT} || '3000' ), + no_server_tokens => ( defined $ENV{DANCER_NO_SERVER_TOKENS} ? + $ENV{DANCER_NO_SERVER_TOKENS} : + 0 ), + startup_info => ( defined $ENV{DANCER_STARTUP_INFO} ? + $ENV{DANCER_STARTUP_INFO} : + 1 ), + }; +} + +sub BUILD { + my $self = shift; + + # Enable traces if set by ENV var. + if (my $traces = $self->config->{traces} ) { + require_module('Carp'); + $Carp::Verbose = $traces ? 1 : 0; + }; + + # set the global runner object if one doesn't exist yet + # this can happen if you create one without going through Dancer2 + # which doesn't trigger the import that creates it + defined $Dancer2::runner + or $Dancer2::runner = $self; +} + +sub register_application { + my $self = shift; + my $app = shift; + + push @{ $self->apps }, $app; + + # add postponed hooks to our psgi app + $self->add_postponed_hooks( $app->name, $app->postponed_hooks ); +} + +sub add_postponed_hooks { + my $self = shift; + my $name = shift; + my $hooks = shift; + + # merge postponed hooks + @{ $self->{'postponed_hooks'}{$name} }{ keys %{$hooks} } = values %{$hooks}; +} + +# decide what to start +# do we just return a PSGI app +# or do we actually start a development standalone server? +sub start { + my $self = shift; + my $app = $self->psgi_app; + + # we decide whether we return a PSGI coderef + # or spin a local development PSGI server + $self->config->{'apphandler'} eq 'PSGI' + and return $app; + + # FIXME: this should not include the server tokens + # since those are already added to the server itself + $self->start_server($app); +} + +sub start_server { + my $self = shift; + my $app = shift; + + # does not return + $self->print_banner; + $self->server->run($app); +} + +sub psgi_app { + my ($self, $apps) = @_; + + if ( $apps && @{$apps} ) { + my @found_apps = (); + + foreach my $app_req ( @{$apps} ) { + if ( is_regexpref($app_req) ) { + # find it in the apps registry + push @found_apps, + grep +( $_->name =~ $app_req ), @{ $self->apps }; + } elsif ( ref $app_req eq 'Dancer2::Core::App' ) { + # use it directly + push @found_apps, $app_req; + } elsif ( !is_ref($app_req) ) { + # find it in the apps registry + push @found_apps, + grep +( $_->name eq $app_req ), @{ $self->apps }; + } else { + croak "Invalid input to psgi_app: $app_req"; + } + } + + $apps = \@found_apps; + } else { + # dispatch over all apps by default + $apps = $self->apps; + } + + my $dispatcher = Dancer2::Core::Dispatcher->new( apps => $apps ); + + # initialize psgi_apps + # (calls ->finish on the apps and create their PSGI apps) + # the dispatcher caches that in the attribute + # so ->finish isn't actually called again if you run this method + $dispatcher->apps_psgi; + + return sub { + my $env = shift; + + # mark it as an old-style dispatching + $self->{'internal_dispatch'} = 1; + + my $response = $dispatcher->dispatch($env); + + # unmark it + delete $self->{'internal_dispatch'}; + + # cleanup + delete $self->{'internal_sessions'}; + + return $response; + }; +} + +sub print_banner { + my $self = shift; + my $pid = $$; + + # we only print the info if we need to + $self->config->{'startup_info'} or return; + + # bare minimum + print STDERR ">> Dancer2 v" . Dancer2->VERSION . " server $pid listening " + . 'on http://' + . $self->host . ':' + . $self->port . "\n"; + + # all loaded plugins + foreach my $module ( grep { $_ =~ m{^Dancer2/Plugin/} } keys %INC ) { + $module =~ s{/}{::}g; # change / to :: + $module =~ s{\.pm$}{}; # remove .pm at the end + my $version = $module->VERSION; + + defined $version or $version = 'no version number defined'; + print STDERR ">> $module ($version)\n"; + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Runner - Top-layer class to start a dancer app + +=head1 VERSION + +version 0.206000 + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Session.pm b/cpanlib/Dancer2/Core/Session.pm new file mode 100644 index 0000000..25213ca --- /dev/null +++ b/cpanlib/Dancer2/Core/Session.pm @@ -0,0 +1,153 @@ +package Dancer2::Core::Session; +# ABSTRACT: class to represent any session object +$Dancer2::Core::Session::VERSION = '0.206000'; +use Moo; +use Dancer2::Core::Types; +use Dancer2::Core::Time; + +has id => ( + # for some specific plugins this should be rw. + # refer to https://github.com/PerlDancer/Dancer2/issues/460 + is => 'rw', + isa => Str, + required => 1, +); + +has data => ( + is => 'ro', + lazy => 1, + default => sub { {} }, +); + +has expires => ( + is => 'rw', + isa => Str, + coerce => sub { + my $value = shift; + $value += time if $value =~ /^[\-\+]?\d+$/; + Dancer2::Core::Time->new( expression => $value )->epoch; + }, +); + +has is_dirty => ( + is => 'rw', + isa => Bool, + default => sub {0}, +); + + +sub read { + my ( $self, $key ) = @_; + return $self->data->{$key}; +} + + +sub write { + my ( $self, $key, $value ) = @_; + $self->is_dirty(1); + $self->data->{$key} = $value; +} + +sub delete { + my ( $self, $key, $value ) = @_; + $self->is_dirty(1); + delete $self->data->{$key}; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Session - class to represent any session object + +=head1 VERSION + +version 0.206000 + +=head1 DESCRIPTION + +A session object encapsulates anything related to a specific session: its ID, +its data, and its expiration. + +It is completely agnostic of how it will be stored, this is the role of +a factory that consumes L to know about that. + +Generally, session objects should not be created directly. The correct way to +get a new session object is to call the C method on a session engine +that implements the SessionFactory role. This is done automatically by the +app object if a session engine is defined. + +=head1 ATTRIBUTES + +=head2 id + +The identifier of the session object. Required. By default, +L sets this to a randomly-generated, +guaranteed-unique string. + +This attribute can be modified if your Session implementation requires this. + +=head2 data + +Contains the data of the session (Hash). + +=head2 expires + +Number of seconds for the expiry of the session cookie. Don't add the current +timestamp to it, will be done automatically. + +Default is no expiry (session cookie will leave for the whole browser's +session). + +For a lifetime of one hour: + + expires => 3600 + +=head2 is_dirty + +Boolean value for whether data in the session has been modified. + +=head1 METHODS + +=head2 read + +Reader on the session data + + my $value = $session->read('something'); + +Returns C if the key does not exist in the session. + +=head2 write + +Writer on the session data + + $session->write('something', $value); + +Sets C to true. Returns C<$value>. + +=head2 delete + +Deletes a key from session data + + $session->delete('something'); + +Sets C to true. Returns the value deleted from the session. + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Time.pm b/cpanlib/Dancer2/Core/Time.pm new file mode 100644 index 0000000..b945ca2 --- /dev/null +++ b/cpanlib/Dancer2/Core/Time.pm @@ -0,0 +1,201 @@ +package Dancer2::Core::Time; +# ABSTRACT: class to handle common helpers for time manipulations +$Dancer2::Core::Time::VERSION = '0.206000'; +use Moo; + +has seconds => ( + is => 'ro', + lazy => 1, + builder => '_build_seconds', +); + +sub _build_seconds { + my ($self) = @_; + my $seconds = $self->expression; + + return $seconds + if $seconds =~ /^\d+$/; + + return $self->_parse_duration($seconds) +} + +has epoch => ( + is => 'ro', + lazy => 1, + builder => '_build_epoch', +); + +sub _build_epoch { + my ($self) = @_; + return $self->seconds if $self->seconds !~ /^[\-\+]?\d+$/; + $self->seconds + time; +} + +has gmt_string => ( + is => 'ro', + builder => '_build_gmt_string', + lazy => 1, +); + +sub _build_gmt_string { + my ($self) = @_; + my $epoch = $self->epoch; + return $epoch if $epoch !~ /^\d+$/; + + my ( $sec, $min, $hour, $mday, $mon, $year, $wday ) = gmtime($epoch); + my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); + my @days = qw(Sun Mon Tue Wed Thu Fri Sat); + + return sprintf "%s, %02d-%s-%d %02d:%02d:%02d GMT", + $days[$wday], + $mday, + $months[$mon], + ( $year + 1900 ), + $hour, $min, $sec; +} + +has expression => ( + is => 'ro', + required => 1, +); + +sub BUILDARGS { + my ($class, %args) = @_; + + $args{epoch} = $args{expression} + if $args{expression} =~ /^\d+$/; + + return \%args; +} + +# private + +# This map is taken from Cache and Cache::Cache +# map of expiration formats to their respective time in seconds +#<<< no perl tidy +my %Units = ( map(($_, 1), qw(s second seconds sec secs)), + map(($_, 60), qw(m minute minutes min mins)), + map(($_, 60*60), qw(h hr hour hours)), + map(($_, 60*60*24), qw(d day days)), + map(($_, 60*60*24*7), qw(w week weeks)), + map(($_, 60*60*24*30), qw(M month months)), + map(($_, 60*60*24*365), qw(y year years)) ); +#>>> + +# This code is taken from Time::Duration::Parse, except if it isn't +# understood it just passes it through and it adds the current time. +sub _parse_duration { + my ( $self, $timespec ) = @_; + my $orig_timespec = $timespec; + + # Treat a plain number as a number of seconds (and parse it later) + if ( $timespec =~ /^\s*([-+]?\d+(?:[.,]\d+)?)\s*$/ ) { + $timespec = "$1s"; + } + + # Convert hh:mm(:ss)? to something we understand + $timespec =~ s/\b(\d+):(\d\d):(\d\d)\b/$1h $2m $3s/g; + $timespec =~ s/\b(\d+):(\d\d)\b/$1h $2m/g; + + my $duration = 0; + while ( $timespec + =~ s/^\s*([-+]?\d+(?:[.,]\d+)?)\s*([a-zA-Z]+)(?:\s*(?:,|and)\s*)*//i ) + { + my ( $amount, $unit ) = ( $1, $2 ); + $unit = lc($unit) unless length($unit) == 1; + + if ( my $value = $Units{$unit} ) { + $amount =~ s/,/./; + $duration += $amount * $value; + } + else { + return $orig_timespec; + } + } + + if ( $timespec =~ /\S/ ) { + return $orig_timespec; + } + + return sprintf "%.0f", $duration; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Time - class to handle common helpers for time manipulations + +=head1 VERSION + +version 0.206000 + +=head1 SYNOPSIS + + my $time = Dancer2::Core::Time->new( expression => "1h" ); + $time->seconds; # return 3600 + +=head1 DESCRIPTION + +For consistency, whenever something needs to work with time, it +needs to be expressed in seconds, with a timestamp. Although it's very +convenient for the machine and calculations, it's not very handy for a +human-being, for instance in a configuration file. + +This class provides everything needed to translate any human-understandable +expression into a number of seconds. + +=head1 ATTRIBUTES + +=head2 seconds + +Number of seconds represented by the object. Defaults to 0. + +=head2 epoch + +The current epoch to handle. Defaults to seconds + time. + +=head2 gmt_string + +Convert the current value in epoch as a GMT string. + +=head2 expression + +Required. A human readable expression representing the number of seconds to provide. + +The format supported is a number followed by an expression. It currently +understands: + + s second seconds sec secs + m minute minutes min mins + h hr hour hours + d day days + w week weeks + M month months + y year years + +Months and years are currently fixed at 30 and 365 days. This may change. +Anything else is used verbatim as the expression of a number of seconds. + +Example: + + 2 hours, 3 days, 3d, 1 week, 3600, etc... + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Core/Types.pm b/cpanlib/Dancer2/Core/Types.pm new file mode 100644 index 0000000..fae6811 --- /dev/null +++ b/cpanlib/Dancer2/Core/Types.pm @@ -0,0 +1,149 @@ +package Dancer2::Core::Types; +# ABSTRACT: Type::Tiny types for Dancer2 core. +$Dancer2::Core::Types::VERSION = '0.206000'; +use strict; +use warnings; +use Type::Library -base; +use Type::Utils -all; +use Sub::Quote 'quote_sub'; + +BEGIN { extends "Types::Standard" }; + +our %supported_http_methods = map +( $_ => 1 ), qw< + GET HEAD POST PUT DELETE OPTIONS PATCH +>; + +my $single_part = qr/ + [A-Za-z] # must start with letter + (?: [A-Za-z0-9_]+ )? # can continue with letters, numbers or underscore +/x; + +my $namespace = qr/ + ^ + $single_part # first part + (?: (?: \:\: $single_part )+ )? # optional part starting with double colon + $ +/x; + +declare 'ReadableFilePath', constraint => quote_sub q{ -e $_ && -r $_ }; + +declare 'WritableFilePath', constraint => quote_sub q{ -e $_ && -w $_ }; + +declare 'Dancer2Prefix', as 'Str', where { + # a prefix must start with the char '/' + # index is much faster than =~ /^\// + index($_, '/') == 0 +}; + +declare 'Dancer2AppName', as 'Str', where { + # TODO need a real check of valid app names + $_ =~ $namespace; +}, message { + sprintf("%s is not a Dancer2AppName", + ($_ && length($_)) ? $_ : 'Empty string') +}; + +declare 'Dancer2Method', as Enum [map +(lc), keys %supported_http_methods]; + +declare 'Dancer2HTTPMethod', as Enum [keys %supported_http_methods]; + +# generate abbreviated class types for core dancer objects +for my $type ( + qw/ + App + Context + Cookie + DSL + Dispatcher + Error + Hook + MIME + Request + Response + Role + Route + Runner + Server + Session + Types + / + ) +{ + declare $type, + as InstanceOf[ 'Dancer2::Core::' . $type ]; +} + +# Export everything by default. +our @EXPORT = __PACKAGE__->type_names; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Core::Types - Type::Tiny types for Dancer2 core. + +=head1 VERSION + +version 0.206000 + +=head1 DESCRIPTION + +L definitions for Moo attributes. These are defined as subroutines. + +=head1 MOO TYPES + +=head2 ReadableFilePath($value) + +A readable file path. + +=head2 WritableFilePath($value) + +A writable file path. + +=head2 Dancer2Prefix($value) + +A proper Dancer2 prefix, which is basically a prefix that starts with a I +character. + +=head2 Dancer2AppName($value) + +A proper Dancer2 application name. + +Currently this only checks for I<\w+>. + +=head2 Dancer2Method($value) + +An acceptable method supported by Dancer2. + +Currently this includes: I, I, I, I, I and +I. + +=head2 Dancer2HTTPMethod($value) + +An acceptable HTTP method supported by Dancer2. + +Current this includes: I, I, I, I, I +and I. + +=head1 SEE ALSO + +L for more available types + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/FileUtils.pm b/cpanlib/Dancer2/FileUtils.pm new file mode 100644 index 0000000..d37bca0 --- /dev/null +++ b/cpanlib/Dancer2/FileUtils.pm @@ -0,0 +1,243 @@ +package Dancer2::FileUtils; +# ABSTRACT: File utility helpers +$Dancer2::FileUtils::VERSION = '0.206000'; +use strict; +use warnings; + +use File::Basename (); +use File::Spec; +use Carp; + +use Exporter 'import'; +our @EXPORT_OK = qw( + dirname open_file path read_file_content read_glob_content + path_or_empty set_file_mode normalize_path escape_filename +); + + +sub path { + my @parts = @_; + my $path = File::Spec->catfile(@parts); + + return normalize_path($path); +} + +sub path_or_empty { + my @parts = @_; + my $path = path(@parts); + + # return empty if it doesn't exist + return -e $path ? $path : ''; +} + +sub dirname { File::Basename::dirname(@_) } + +sub set_file_mode { + my $fh = shift; + my $charset = 'utf-8'; + binmode $fh, ":encoding($charset)"; + return $fh; +} + +sub open_file { + my ( $mode, $filename ) = @_; + + open my $fh, $mode, $filename + or croak "Can't open '$filename' using mode '$mode': $!"; + + return set_file_mode($fh); +} + +sub read_file_content { + my $file = shift or return; + my $fh = open_file( '<', $file ); + + return wantarray + ? read_glob_content($fh) + : scalar read_glob_content($fh); +} + +sub read_glob_content { + my $fh = shift; + + my @content = <$fh>; + close $fh; + + return wantarray ? @content : join '', @content; +} + +sub normalize_path { + + # this is a revised version of what is described in + # http://www.linuxjournal.com/content/normalizing-path-names-bash + # by Mitch Frazier + my $path = shift or return; + my $seqregex = qr{ + [^/]* # anything without a slash + /\.\.(/|\z) # that is accompanied by two dots as such + }x; + + $path =~ s{/\./}{/}g; + while ( $path =~ s{$seqregex}{} ) {} + + #see https://rt.cpan.org/Public/Bug/Display.html?id=80077 + $path =~ s{^//}{/}; + return $path; +} + +sub escape_filename { + my $filename = shift or return; + + # based on escaping used in CHI::Driver. Our use-case is one-way, + # so we allow utf8 chars to be escaped, but NEVER do the inverse + # operation. + $filename =~ s/([^A-Za-z0-9_\=\-\~])/sprintf("+%02x", ord($1))/ge; + return $filename; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::FileUtils - File utility helpers + +=head1 VERSION + +version 0.206000 + +=head1 SYNOPSIS + + use Dancer2::FileUtils qw/dirname path path_or_empty/; + + # for 'path/to/file' + my $dir = dirname($path); # returns 'path/to' + my $path = path($path); # returns '/abs/path/to/file' + my $path = path_or_empty($path); # returns '' if file doesn't exist + + + use Dancer2::FileUtils qw/path read_file_content/; + + my $content = read_file_content( path( 'folder', 'folder', 'file' ) ); + my @content = read_file_content( path( 'folder', 'folder', 'file' ) ); + + + use Dancer2::FileUtils qw/read_glob_content set_file_mode/; + + open my $fh, '<', $file or die "$!\n"; + set_file_mode($fh); + my @content = read_glob_content($fh); + my $content = read_glob_content($fh); + + + use Dancer2::FileUtils qw/open_file/; + + my $fh = open_file('<', $file) or die $message; + + + use Dancer2::FileUtils 'set_file_mode'; + + set_file_mode($fh); + +=head1 DESCRIPTION + +Dancer2::FileUtils includes a few file related utilities that Dancer2 +uses internally. Developers may use it instead of writing their own +file reading subroutines or using additional modules. + +=head1 FUNCTIONS + +=head2 my $path = path( 'folder', 'folder', 'filename'); + +Provides comfortable path resolution, internally using L. 'path' +does not verify paths, it just normalizes the path. + +=head2 my $path = path_or_empty('folder, 'folder','filename'); + +Like path, but returns '' if path doesn't exist. + +=head2 dirname + + use Dancer2::FileUtils 'dirname'; + + my $dir = dirname($path); + +Exposes L's I, to allow fetching a directory name from +a path. On most OS, returns all but last level of file path. See +L for details. + +=head2 set_file_mode($fh); + + use Dancer2::FileUtils 'set_file_mode'; + + set_file_mode($fh); + +Applies charset setting from Dancer2's configuration. Defaults to utf-8 if no +charset setting. + +=head2 my $fh = open_file('<', $file) or die $message; + + use Dancer2::FileUtils 'open_file'; + my $fh = open_file('<', $file) or die $message; + +Calls open and returns a filehandle. Takes in account the 'charset' setting +from Dancer2's configuration to open the file in the proper encoding (or +defaults to utf-8 if setting not present). + +=head2 my $content = read_file_content($file); + + use Dancer2::FileUtils 'read_file_content'; + + my @content = read_file_content($file); + my $content = read_file_content($file); + +Returns either the content of a file (whose filename is the input), or I +if the file could not be opened. + +In array context it returns each line (as defined by $/) as a separate element; +in scalar context returns the entire contents of the file. + +=head2 my $content = read_glob_content($fh); + + use Dancer2::FileUtils 'read_glob_content'; + + open my $fh, '<', $file or die "$!\n"; + binmode $fh, ':encoding(utf-8)'; + my @content = read_glob_content($fh); + my $content = read_glob_content($fh); + +Similar to I, only it accepts a file handle. It is +assumed that the appropriate PerlIO layers are applied to the file handle. +Returns the content and B. + +=head2 my $norm_path=normalize_path ($path); + +=head2 my $escaped_filename = escape_filename( $filename ); + +Escapes characters in a filename that may alter a path when concatenated. + + use Dancer2::FileUtils 'escape_filename'; + + my $safe = escape_filename( "a/../b.txt" ); # a+2f+2e+2e+2fb+2etxt + +=head1 EXPORT + +Nothing by default. You can provide a list of subroutines to import. + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Handler/AutoPage.pm b/cpanlib/Dancer2/Handler/AutoPage.pm new file mode 100644 index 0000000..981e891 --- /dev/null +++ b/cpanlib/Dancer2/Handler/AutoPage.pm @@ -0,0 +1,127 @@ +package Dancer2::Handler::AutoPage; +# ABSTRACT: Class for handling the AutoPage feature +$Dancer2::Handler::AutoPage::VERSION = '0.206000'; +use Moo; +use Carp 'croak'; +use Dancer2::Core::Types; + +with qw< + Dancer2::Core::Role::Handler + Dancer2::Core::Role::StandardResponses +>; + +sub register { + my ( $self, $app ) = @_; + + return unless $app->config->{auto_page}; + + $app->add_route( + method => $_, + regexp => $self->regexp, + code => $self->code, + ) for $self->methods; +} + +sub code { + sub { + my $app = shift; + my $prefix = shift; + + my $template = $app->template_engine; + if ( !defined $template ) { + $app->response->has_passed(1); + return; + } + + my $page = $app->request->path; + my $layout_dir = $template->layout_dir; + if ( $page =~ m{^/\Q$layout_dir\E/} ) { + $app->response->has_passed(1); + return; + } + + # remove leading '/', ensuring paths relative to the view + $page =~ s{^/}{}; + my $view_path = $template->view_pathname($page); + + if ( ! $template->pathname_exists( $view_path ) ) { + $app->response->has_passed(1); + return; + } + + my $ct = $template->process( $page ); + return ( $app->request->method eq 'GET' ) ? $ct : ''; + }; +} + +sub regexp {'/**'} + +sub methods {qw(head get)} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Handler::AutoPage - Class for handling the AutoPage feature + +=head1 VERSION + +version 0.206000 + +=head1 DESCRIPTION + +The AutoPage feature is a Handler (turned off by default) that is +responsible for serving pages that match an existing template. If a +view exists with a name that matches the requested path, Dancer2 +processes the request using the Autopage handler. + +To turn it add to your config file: + + auto_page: 1 + +This allows you to easily serve simple pages without having to write a +route definition for them. + +If there's no view with the name request, the route passes, allowing +other matching routes to be dispatched. + +=head1 METHODS + +=head2 register + +Creates the routes. + +=head2 code + +A code reference that processes the route request. + +=head2 methods + +The methods that should be served for autopages. + +Default: B, B. + +=head2 regexp + +The regexp (path) we want to match. + +Default: B. + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Handler/File.pm b/cpanlib/Dancer2/Handler/File.pm new file mode 100644 index 0000000..d1fd652 --- /dev/null +++ b/cpanlib/Dancer2/Handler/File.pm @@ -0,0 +1,179 @@ +package Dancer2::Handler::File; +# ABSTRACT: class for handling file content rendering +$Dancer2::Handler::File::VERSION = '0.206000'; +use Carp 'croak'; +use Moo; +use HTTP::Date; +use Dancer2::FileUtils 'path', 'open_file', 'read_glob_content'; +use Dancer2::Core::MIME; +use Dancer2::Core::Types; +use File::Spec; + +with qw< + Dancer2::Core::Role::Handler + Dancer2::Core::Role::StandardResponses + Dancer2::Core::Role::Hookable +>; + +sub hook_aliases { + { + before_file_render => 'handler.file.before_render', + after_file_render => 'handler.file.after_render', + } +} + +sub supported_hooks { values %{ shift->hook_aliases } } + +has mime => ( + is => 'ro', + isa => InstanceOf ['Dancer2::Core::MIME'], + default => sub { Dancer2::Core::MIME->new }, +); + +has encoding => ( + is => 'ro', + default => sub {'utf-8'}, +); + +has public_dir => ( + is => 'ro', + lazy => 1, + builder => '_build_public_dir', +); + +has regexp => ( + is => 'ro', + default => sub {'/**'}, +); + +sub _build_public_dir { + my $self = shift; + return $self->app->config->{public_dir} + || $ENV{DANCER_PUBLIC} + || path( $self->app->location, 'public' ); +} + +sub register { + my ( $self, $app ) = @_; + + # don't register the handler if no valid public dir + return if !-d $self->public_dir; + + $app->add_route( + method => $_, + regexp => $self->regexp, + code => $self->code( $app->prefix ), + ) for $self->methods; +} + +sub methods { ( 'head', 'get' ) } + +sub code { + my ( $self, $prefix ) = @_; + + sub { + my $app = shift; + my $prefix = shift; + my $path = $app->request->path_info; + + if ( $path =~ /\0/ ) { + return $self->standard_response( $app, 400 ); + } + + if ( $prefix && $prefix ne '/' ) { + $path =~ s/^\Q$prefix\E//; + } + + my $file_path = $self->merge_paths( $path, $self->public_dir ); + return $self->standard_response( $app, 403 ) if !defined $file_path; + + if ( !-f $file_path ) { + $app->response->has_passed(1); + return; + } + + if ( !-r $file_path ) { + return $self->standard_response( $app, 403 ); + } + + # Now we are sure we can render the file... + $self->execute_hook( 'handler.file.before_render', $file_path ); + + # Read file content as bytes + my $fh = open_file( "<", $file_path ); + binmode $fh; + my $content = read_glob_content($fh); + + # Assume m/^text/ mime types are correctly encoded + my $content_type = $self->mime->for_file($file_path) || 'text/plain'; + if ( $content_type =~ m!^text/! ) { + $content_type .= "; charset=" . ( $self->encoding || "utf-8" ); + } + + my @stat = stat $file_path; + + $app->response->header('Content-Type') + or $app->response->header( 'Content-Type', $content_type ); + + $app->response->header('Content-Length') + or $app->response->header( 'Content-Length', $stat[7] ); + + $app->response->header('Last-Modified') + or $app->response->header( + 'Last-Modified', + HTTP::Date::time2str( $stat[9] ) + ); + + $app->response->content($content); + $app->response->is_encoded(1); # bytes are already encoded + $self->execute_hook( 'handler.file.after_render', $app->response ); + return ( $app->request->method eq 'GET' ) ? $content : ''; + }; +} + +sub merge_paths { + my ( undef, $path, $public_dir ) = @_; + + my ( $volume, $dirs, $file ) = File::Spec->splitpath( $path ); + my @tokens = File::Spec->splitdir( "$dirs$file" ); + my $updir = File::Spec->updir; + return if grep $_ eq $updir, @tokens; + + my ( $pub_vol, $pub_dirs, $pub_file ) = File::Spec->splitpath( $public_dir ); + my @pub_tokens = File::Spec->splitdir( "$pub_dirs$pub_file" ); + return if length $volume and length $pub_vol and $volume ne $pub_vol; + + my @final_vol = ( length $pub_vol ? $pub_vol : length $volume ? $volume : () ); + my @file_path = ( @final_vol, @pub_tokens, @tokens ); + my $file_path = path( @file_path ); + return $file_path; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Handler::File - class for handling file content rendering + +=head1 VERSION + +version 0.206000 + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Logger/Capture.pm b/cpanlib/Dancer2/Logger/Capture.pm new file mode 100644 index 0000000..61414de --- /dev/null +++ b/cpanlib/Dancer2/Logger/Capture.pm @@ -0,0 +1,141 @@ +package Dancer2::Logger::Capture; +# ABSTRACT: Capture dancer logs +$Dancer2::Logger::Capture::VERSION = '0.206000'; +use Moo; +use Dancer2::Logger::Capture::Trap; + +with 'Dancer2::Core::Role::Logger'; + +has trapper => ( + is => 'ro', + lazy => 1, + builder => '_build_trapper', +); + +sub _build_trapper { Dancer2::Logger::Capture::Trap->new } + +sub log { + my ( $self, $level, $message ) = @_; + + $self->trapper->store( + $level, $message, $self->format_message( $level => $message ) + ); + + return; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Logger::Capture - Capture dancer logs + +=head1 VERSION + +version 0.206000 + +=head1 SYNOPSIS + +The basics: + + set logger => "capture"; + + my $trap = dancer_app->logger_engine->trapper; + my $logs = $trap->read; + +A worked-out real-world example: + + use Test::More tests => 2; + use Dancer2; + + set logger => 'capture'; + + warning "Danger! Warning!"; + debug "I like pie."; + + my $trap = dancer_app->logger_engine->trapper; + + is_deeply $trap->read, [ + { level => "warning", message => "Danger! Warning!" }, + { level => "debug", message => "I like pie.", } + ]; + + # each call to read cleans the trap + is_deeply $trap->read, []; + +=head1 DESCRIPTION + +This is a logger class for L which captures all logs to an object. + +It's primary purpose is for testing. Here is an example of a test: + + use strict; + use warnings; + use Test::More; + use Plack::Test; + use HTTP::Request::Common; + use Ref::Util qw; + + { + package App; + use Dancer2; + + set log => 'debug'; + set logger => 'capture'; + + get '/' => sub { + log(debug => 'this is my debug message'); + log(core => 'this should not be logged'); + log(info => 'this is my info message'); + }; + } + + my $app = Dancer2->psgi_app; + ok( is_coderef($app), 'Got app' ); + + test_psgi $app, sub { + my $cb = shift; + + my $res = $cb->( GET '/' ); + + my $trap = App->dancer_app->logger_engine->trapper; + + is_deeply $trap->read, [ + { level => 'debug', message => 'this is my debug message' }, + { level => 'info', message => 'this is my info message' }, + ]; + + is_deeply $trap->read, []; + }; + + done_testing; + +=head1 METHODS + +=head2 trapper + +Returns the L object used to capture +and read logs. + +=head1 SEE ALSO + +L, L + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Logger/Capture/Trap.pm b/cpanlib/Dancer2/Logger/Capture/Trap.pm new file mode 100644 index 0000000..eb34edc --- /dev/null +++ b/cpanlib/Dancer2/Logger/Capture/Trap.pm @@ -0,0 +1,94 @@ +package Dancer2::Logger::Capture::Trap; +# ABSTRACT: a place to store captured Dancer2 logs +$Dancer2::Logger::Capture::Trap::VERSION = '0.206000'; +use Moo; +use Dancer2::Core::Types; + +has storage => ( + is => 'rw', + isa => ArrayRef, + default => sub { [] }, +); + +sub store { + my ( $self, $level, $message, $fmt_string ) = @_; + push @{ $self->storage }, { + level => $level, + message => $message, + formatted => $fmt_string, + }; +} + +sub read { + my $self = shift; + + my $logs = $self->storage; + $self->storage( [] ); + return $logs; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Logger::Capture::Trap - a place to store captured Dancer2 logs + +=head1 VERSION + +version 0.206000 + +=head1 SYNOPSIS + + my $trap = Dancer2::Logger::Capture::Trap->new; + $trap->store( $level, $message ); + my $logs = $trap->read; + +=head1 DESCRIPTION + +This is a place to store and retrieve capture Dancer2 logs used by +L. + +=head2 Methods + +=head3 new + +=head3 store + + $trap->store($level, $message); + +Stores a log $message and its $level. + +=head3 read + + my $logs = $trap->read; + +Returns the logs stored as an array ref and clears the storage. + +For example... + + [{ level => "warning", message => "Danger! Warning! Dancer2!" }, + { level => "error", message => "You fail forever" } + ]; + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Logger/Console.pm b/cpanlib/Dancer2/Logger/Console.pm new file mode 100644 index 0000000..9557360 --- /dev/null +++ b/cpanlib/Dancer2/Logger/Console.pm @@ -0,0 +1,62 @@ +package Dancer2::Logger::Console; +# ABSTRACT: Console logger +$Dancer2::Logger::Console::VERSION = '0.206000'; +use Moo; + +with 'Dancer2::Core::Role::Logger'; + +sub log { + my ( $self, $level, $message ) = @_; + print STDERR $self->format_message( $level => $message ); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Logger::Console - Console logger + +=head1 VERSION + +version 0.206000 + +=head1 DESCRIPTION + +This is a logging engine that allows you to print debug messages on the +standard error output. + +=head1 METHODS + +=head2 log + +Writes the log message to the console. + +=head1 CONFIGURATION + +The setting C should be set to C in order to use this logging +engine in a Dancer2 application. + +There is no additional setting available with this engine. + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Logger/Diag.pm b/cpanlib/Dancer2/Logger/Diag.pm new file mode 100644 index 0000000..a698bde --- /dev/null +++ b/cpanlib/Dancer2/Logger/Diag.pm @@ -0,0 +1,55 @@ +package Dancer2::Logger::Diag; +# ABSTRACT: Test::More diag() logging engine for Dancer2 +$Dancer2::Logger::Diag::VERSION = '0.206000'; +use Moo; +use Test::More; + +with 'Dancer2::Core::Role::Logger'; + +sub log { + my ( $self, $level, $message ) = @_; + + Test::More::diag( $self->format_message( $level => $message ) ); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Logger::Diag - Test::More diag() logging engine for Dancer2 + +=head1 VERSION + +version 0.206000 + +=head1 DESCRIPTION + +This logging engine uses L's diag() to output as TAP comments. + +This is very useful in case you're writing a test and want to have logging +messages as part of your TAP. + +=head1 METHODS + +=head2 log + +Use Test::More's diag() to output the log message. + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Logger/File.pm b/cpanlib/Dancer2/Logger/File.pm new file mode 100644 index 0000000..ca423d4 --- /dev/null +++ b/cpanlib/Dancer2/Logger/File.pm @@ -0,0 +1,173 @@ +package Dancer2::Logger::File; +# ABSTRACT: file-based logging engine for Dancer2 +$Dancer2::Logger::File::VERSION = '0.206000'; +use Carp 'carp'; +use Moo; +use Dancer2::Core::Types; + +with 'Dancer2::Core::Role::Logger'; + +use File::Spec; +use Fcntl qw(:flock SEEK_END); +use Dancer2::FileUtils qw(open_file); +use IO::File; + +has environment => ( + is => 'ro', + required => 1, +); + +has location => ( + is => 'ro', + required => 1, +); + +has log_dir => ( + is => 'rw', + isa => sub { + my $dir = shift; + + if ( !-d $dir && !mkdir $dir ) { + die "log directory \"$dir\" does not exist and unable to create it."; + } + if ( !-w $dir ) { + die "log directory \"$dir\" is not writable." + } + }, + lazy => 1, + builder => '_build_log_dir', +); + +has file_name => ( + is => 'ro', + isa => Str, + builder => '_build_file_name', + lazy => 1 +); + +has log_file => ( + is => 'ro', + isa => Str, + lazy => 1, + builder => '_build_log_file', +); + +has fh => ( + is => 'ro', + lazy => 1, + builder => '_build_fh', +); + +sub _build_log_dir { File::Spec->catdir( $_[0]->location, 'logs' ) } + +sub _build_file_name {$_[0]->environment . ".log"} + +sub _build_log_file { + my $self = shift; + return File::Spec->catfile( $self->log_dir, $self->file_name ); +} + +sub _build_fh { + my $self = shift; + my $logfile = $self->log_file; + + my $fh; + unless ( $fh = open_file( '>>', $logfile ) ) { + carp "unable to create or append to $logfile"; + return; + } + + $fh->autoflush; + + return $fh; +} + +sub log { + my ( $self, $level, $message ) = @_; + my $fh = $self->fh; + + return unless ( ref $fh && $fh->opened ); + + flock( $fh, LOCK_EX ) + or carp "locking logfile $self->{logfile} failed: $!"; + seek( $fh, 0, SEEK_END ); + $fh->print( $self->format_message( $level => $message ) ) + or carp "writing to logfile $self->{logfile} failed"; + flock( $fh, LOCK_UN ) + or carp "unlocking logfile $self->{logfile} failed: $!"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Logger::File - file-based logging engine for Dancer2 + +=head1 VERSION + +version 0.206000 + +=head1 DESCRIPTION + +This is a logging engine that allows you to save your logs to files on disk. + +Logs are not automatically rotated. Use a log rotation tool like +C in C mode. + +=head1 METHODS + +=head2 log($level, $message) + +Writes the log message to the file. + +=head1 CONFIGURATION + +The setting C should be set to C in order to use this logging +engine in a Dancer2 application. + +The follow attributes are supported: + +=over 4 + +=item * C + +Directory path to hold log files. + +Defaults to F in the application directory + +=item * C + +The name of the log file. + +Defaults to the environment name with a F<.log> suffix + +=back + +Here is an example configuration that use this logger and stores logs in F: + + logger: "File" + + engines: + logger: + File: + log_dir: "/var/log/myapp" + file_name: "myapp.log" + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Logger/Note.pm b/cpanlib/Dancer2/Logger/Note.pm new file mode 100644 index 0000000..31d469a --- /dev/null +++ b/cpanlib/Dancer2/Logger/Note.pm @@ -0,0 +1,58 @@ +package Dancer2::Logger::Note; +# ABSTRACT: Test::More note() logging engine for Dancer2 +$Dancer2::Logger::Note::VERSION = '0.206000'; +use Moo; +use Test::More; + +with 'Dancer2::Core::Role::Logger'; + +sub log { + my ( $self, $level, $message ) = @_; + + Test::More::note( $self->format_message( $level => $message ) ); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Logger::Note - Test::More note() logging engine for Dancer2 + +=head1 VERSION + +version 0.206000 + +=head1 DESCRIPTION + +This logging engine uses L's note() to output as TAP comments. + +This is very useful in case you're writing a test and want to have logging +messages as part of your TAP. + +"Like C, except the message will not be seen when the test is run in a +harness. It will only be visible in the verbose TAP stream." -- Test::More. + +=head1 METHODS + +=head2 log + +Use Test::More's note() to output the log message. + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Logger/Null.pm b/cpanlib/Dancer2/Logger/Null.pm new file mode 100644 index 0000000..4e6390a --- /dev/null +++ b/cpanlib/Dancer2/Logger/Null.pm @@ -0,0 +1,47 @@ +package Dancer2::Logger::Null; +# ABSTRACT: Blackhole-like silent logging engine for Dancer2 +$Dancer2::Logger::Null::VERSION = '0.206000'; +use Moo; +with 'Dancer2::Core::Role::Logger'; + +sub log {1} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Logger::Null - Blackhole-like silent logging engine for Dancer2 + +=head1 VERSION + +version 0.206000 + +=head1 DESCRIPTION + +This logger acts as a blackhole (or /dev/null, if you will) that discards all +the log messages instead of displaying them anywhere. + +=head1 METHODS + +=head2 log + +Discards the message. + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Manual/Deployment.pod b/cpanlib/Dancer2/Manual/Deployment.pod new file mode 100644 index 0000000..bd22857 --- /dev/null +++ b/cpanlib/Dancer2/Manual/Deployment.pod @@ -0,0 +1,728 @@ +# PODNAME: Dancer2::Manual::Deployment +# ABSTRACT: common ways to put your Dancer app into use + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Manual::Deployment - common ways to put your Dancer app into use + +=head1 VERSION + +version 0.206000 + +=head1 DESCRIPTION + +Dancer has been designed to be flexible, and this flexibility extends to your +choices when deploying your Dancer app. + +=head2 Running stand-alone + +To start your application, just run plackup: + + $ plackup bin/app.psgi + HTTP::Server::PSGI: Accepting connections at http://0:5000/ + +Point your browser at it, and away you go! + +This option can be useful for small personal web apps or internal apps, but if +you want to make your app available to the world, it probably won't suit you. + +=head3 Auto Reloading the Application + +While developing your application, it is often handy to have the server +automatically reload your application when changes are made. There are +two recommended ways of handling this with Dancer: using C< plackup -r > +and L. Both have their advantages and disadvantages +(which will be explained below). + +Regardless of the method you use, it is B< not > recommended that you +automatically reload your applications in a production environment, for +reasons of performance, deployment best practices, etc. + +For Dancer 1 programmers that used the C< auto_reload > option, please use +one of these alternatives instead: + +=head4 Auto reloading with C< plackup -r > + +Plack's built-in reloader will reload your application anytime a file in +your application's directory (usually, F< /bin >) changes. You will likely +want to monitor your F< lib/ > directory too, using the C< -R > option: + + $ plackup -r -R lib bin/app.psgi + +There is a performance hit associated with this, as Plack will spin off +a separate process that monitors files in the application and other +specified directories. If the timestamp of any files in a watched +directory changes, the application is recompiled and reloaded. + +See the L docs for more information on the C< -r > and C< -R > +options. + +=head4 Auto reloading with plackup and Shotgun + +There may be circumstances where Plack's built-in reloader won't work for +you, be it for the way it looks for changes, or because there are many +directories you need to monitor, or you want to reload the application any +time one of the modules in Perl's F< lib/ > path changes. +L makes this easy by recompiling the application +on every request. + +To use Shotgun, specify it using the loader argument to C< plackup (-L) >: + + $ plackup -L Shotgun bin/app.psgi + +The Shotgun, while effective, can quickly cause you performance issues, even +during the development phase of your application. As the number of plugins +you use in your application grows, as the number of static resources (images, +etc.) grows, the more requests your server process needs to handle. Since +each request recompiles the application, even simple page refreshes can get +unbearably slow over time. Use with caution. + +You can bypass Shotgun's auto-reloading of specific modules with the +C< -M > switch: + + $ plackup -L Shotgun -M -M bin/app.psgi + +On Windows, Shotgun loader is known to cause huge memory leaks in a +fork-emulation layer. If you are aware of this and still want to run the +loader, please use the following command: + + > set PLACK_SHOTGUN_MEMORY_LEAK=1 && plackup -L Shotgun bin\app.psgi + HTTP::Server::PSGI: Accepting connections at http://0:5000/ + +B if you are using Dancer 2's asynchronous capabilities, using +Shotgun will kill Twiggy. If you need async processing, consider an +alternative to Shotgun. + +=head2 Running under Apache + +You can run your Dancer app from Apache using the following examples: + +=head3 As a CGI script + +In its simplest form, your Dancer app can be run as a simple CGI script +out-of-the-box. You will need to enable the Apache mod_cgi or mod_cgid modules +(C or C on Debian-based systems) and mod_rewrite +(C). The Perl module L is required. + +The following is an example apache configuration. Depending on your Apache +configuration layout, this should be placed in C or +C. The configuration options can also be placed in +C<.htaccess> files if you prefer. + + + ServerName www.example.com + + # /srv/www.example.com is the root of your + # dancer application + DocumentRoot /srv/www.example.com/public + + ServerAdmin you@example.com + + + AllowOverride None + Options +ExecCGI -MultiViews +SymLinksIfOwnerMatch + AddHandler cgi-script .cgi + # Apache 2.2 + Order allow,deny + Allow from all + # Apache 2.4 + Require all granted + + + RewriteEngine On + RewriteCond %{REQUEST_FILENAME} !-f + RewriteRule ^(.*)$ /dispatch.cgi$1 [QSA,L] + + ErrorLog /var/log/apache2/www.example.com-error.log + CustomLog /var/log/apache2/www.example.com-access_log common + + +Now you can access your dancer application URLs as if you were using the +embedded web server. + + http://www.example.com/ + +This option is a no-brainer, easy to setup and low maintenance, but serves +requests slower than all other options, as each time a request is made to your +server, Apache will start your application. This might be suitable for a small, +occasionally-used sites, as the application is not using resources when it is +not being accessed. For anything more, you probably want to use FastCGI instead +(see next section). + +To list all currently loaded modules, type C +(C on Debian/Ubuntu). + +=head3 As a FastCGI script + +This has all the easy-to-setup and low-maintenance advantages of CGI, but is +much faster for each request, as it keeps a copy of the application running all +the time. + +You will still need to enable C, but will need to use a FastCGI +module instead of a CGI module. There are 3 available: +L, +L and +L. +For this example, we will use mod_fastcgi (C in Debian). + +The CGI configuration above now changes as follows (differences highlighted +with XXX): + + + ServerName www.example.com + + # /srv/www.example.com is the root of your + # dancer application + DocumentRoot /srv/www.example.com/public + + ServerAdmin you@example.com + + # XXX Start a FastCGI server to run in the background + FastCgiServer /srv/www.example.com/public/dispatch.fcgi + + + AllowOverride None + Options +ExecCGI -MultiViews +SymLinksIfOwnerMatch + # XXX Use FastCGI handler instead of CGI + AddHandler fastcgi-script .fcgi + # Apache 2.2 + Order allow,deny + Allow from all + # Apache 2.4 + Require all granted + + + RewriteEngine On + RewriteCond %{REQUEST_FILENAME} !-f + # Run FastCGI dispatcher instead of CGI dispatcher + RewriteRule ^(.*)$ /dispatch.fcgi$1 [QSA,L] + + ErrorLog /var/log/apache2/www.example.com-error.log + CustomLog /var/log/apache2/www.example.com-access_log common + + +This is the easiest way to get a production server up and running, as there is +no need to worry about daemonizing your application. Apache manages all that +for you. + +=head4 Reloading your application + +You can use C or C to reload your +application. The latter will be more friendly to your users in a production +environment. If your application loads relatively quickly, then it should go +unnoticed. + +=head4 Configuration + +See L for FastCGI +configuration options. An example configuration: + + FastCgiServer /srv/www.example.com/public/dispatch.fcgi -processes 5 -initial-env DANCER_ENVIRONMENT="production" + +=head3 With Plack + +You can run your app from Apache using PSGI (Plack), with a config like the +following: + + + ServerName www.myapp.example.com + ServerAlias myapp.example.com + DocumentRoot /websites/myapp.example.com + + + AllowOverride None + Order allow,deny + Allow from all + + + + SetHandler perl-script + PerlResponseHandler Plack::Handler::Apache2 + PerlSetVar psgi_app /websites/myapp.example.com/app.psgi + + + ErrorLog /websites/myapp.example.com/logs/error_log + CustomLog /websites/myapp.example.com/logs/access_log common + + +To set the environment you want to use for your application (production or +development), you can set it this way: + + + ... + SetEnv DANCER_ENVIRONMENT "production" + ... + + +=head3 Running multiple applications under the same virtualhost + +If you want to deploy multiple applications under the same C +(using one application per directory, for example) you can use the following +example Apache configuration. + +This example uses the FastCGI dispatcher that comes with Dancer, but you should +be able to adapt this to use any other way of deployment described in this +guide. The only purpose of this example is to show how to deploy multiple +applications under the same base directory/virtualhost. + + + ServerName localhost + DocumentRoot "/path/to/rootdir" + RewriteEngine On + RewriteCond %{REQUEST_FILENAME} !-f + + + AllowOverride None + Options +ExecCGI -MultiViews +SymLinksIfOwnerMatch + Order allow,deny + Allow from all + AddHandler fastcgi-script .fcgi + + + RewriteRule /App1(.*)$ /App1/public/dispatch.fcgi$1 [QSA,L] + RewriteRule /App2(.*)$ /App2/public/dispatch.fcgi$1 [QSA,L] + ... + RewriteRule /AppN(.*)$ /AppN/public/dispatch.fcgi$1 [QSA,L] + + +Of course, if your Apache configuration allows that, you can put the +RewriteRules in a .htaccess file directly within the application's directory, +which lets you add a new application without changing the Apache configuration. + +=head2 Running on PSGI-based Perl webservers + +A number of Perl web servers supporting PSGI are available on cpan: + +=over 4 + +=item L + +C is a high performance web server, with support for preforking, +signals, multiple interfaces, graceful restarts and dynamic worker pool +configuration. + +=item L + +C is an C web server, it's light and fast. + +=item L + +C is a C based web server. + +=back + +Similar to running standalone, use plackup to start your application +(see L and specific servers above for all available options): + + $ plackup bin/app.psgi + $ plackup -E deployment -s Starman --workers=10 -p 5001 -a bin/app.psgi + +As you can see, the scaffolded Perl script for your app can be used as a PSGI +startup file. + +=head3 Enabling content compression + +Content compression (gzip, deflate) can be easily enabled via a Plack +middleware (see L): L. +It's a middleware to encode the response body in gzip or deflate, based on +the C HTTP request header. + +Enable it as you would enable any Plack middleware. First you need to +install L, then in the handler (usually +F) edit it to use L, as described above: + + use Dancer2; + use MyWebApp; + use Plack::Builder; + + builder { + enable 'Deflater'; + dance; + }; + +To test if content compression works, trace the HTTP request and response +before and after enabling this middleware. Among other things, you should +notice that the response is gzip or deflate encoded, and contains a header +C set to C or C. + +=head3 Creating a service + +You can turn your app into proper service running in background using one of +the following examples: + +=head4 Using Ubic + +L is an extensible perlish service manager. You can use it to start +and stop any services, automatically start them on reboots or daemon +failures, and implement custom status checks. + +A basic PSGI service description (usually in C): + + use parent qw(Ubic::Service::Plack); + + # if your application is not installed in @INC path: + sub start { + my $self = shift; + $ENV{PERL5LIB} = '/path/to/your/application/lib'; + $self->SUPER::start(@_); + } + + __PACKAGE__->new( + server => 'Starman', + app => '/path/to/your/application/app.psgi', + port => 5000, + user => 'www-data', + ); + +Run C to start the service. + +=head4 Using daemontools + +daemontools is a collection of tools for managing UNIX services. You can use +it to easily start/restart/stop services. + +A basic script to start an application: (in C) + + #!/bin/sh + + # if your application is not installed in @INC path: + export PERL5LIB='/path/to/your/application/lib' + + exec 2>&1 \ + /usr/local/bin/plackup -s Starman -a /path/to/your/application/app.psgi -p 5000 + +=head2 Running stand-alone behind a proxy / load balancer + +Another option would be to run your app stand-alone as described above, but then +use a proxy or load balancer to accept incoming requests (on the standard port +80, say) and feed them to your Dancer app. + +This could be achieved using various software; examples would include: + +=head3 Using Apache's mod_proxy + +You could set up a C for your web app, and proxy all requests through +to it: + + + ProxyPass / http://localhost:3000/ + ProxyPassReverse / http://localhost:3000/ + + +Or, if you want your webapp to share an existing VirtualHost, you could have +it under a specified dir: + + ProxyPass /mywebapp/ http://localhost:3000/ + ProxyPassReverse /mywebapp/ http://localhost:3000/ + +It is important for you to note that the Apache2 modules C and +C must be enabled: + + $ a2enmod proxy + $ a2enmod proxy_http + +It is also important to set permissions for proxying for security purposes, +below is an example. + + + Order allow,deny + Allow from all + + +=head3 Using perlbal + +C is a single-threaded event-based server written in Perl supporting +HTTP load balancing, web serving, and a mix of the two, available from +L + +It processes hundreds of millions of requests a day just for LiveJournal, Vox +and TypePad and dozens of other "Web 2.0" applications. + +It can also provide a management interface to let you see various information on +requests handled etc. + +It could easily be used to handle requests for your Dancer apps, too. + +It can be easily installed from CPAN: + + perl -MCPAN -e 'install Perlbal' + +Once installed, you'll need to write a configuration file. See the examples +provided with perlbal, but you'll probably want something like: + + CREATE POOL my_dancers + POOL my_dancers ADD 10.0.0.10:3030 + POOL my_dancers ADD 10.0.0.11:3030 + POOL my_dancers ADD 10.0.0.12:3030 + POOL my_dancers ADD 10.0.0.13:3030 + + CREATE SERVICE my_webapp + SET listen = 0.0.0.0:80 + SET role = reverse_proxy + SET pool = my_dancers + SET persist_client = on + SET persist_backend = on + SET verify_backend = on + ENABLE my_webapp + +=head3 Using balance + +C is a simple load-balancer from Inlab Software, available from +L. + +It could be used simply to hand requests to a standalone Dancer app. You could +even run several instances of your Dancer app, on the same machine or on several +machines, and use a machine running C to distribute the requests between +them, for some serious heavy traffic handling! + +To listen on port 80, and send requests to a Dancer app on port 3000: + + balance http localhost:3000 + +To listen on a specified IP only on port 80, and distribute requests between +multiple Dancer apps on multiple other machines: + + balance -b 10.0.0.1 80 10.0.0.2:3000 10.0.0.3:3000 10.0.0.4:3000 + +=head3 Using Lighttpd + +You can use Lighttp's C: + + $HTTP["url"] =~ "/application" { + proxy.server = ( + "/" => ( + "application" => ( "host" => "127.0.0.1", "port" => 3000 ) + ) + ) + } + +This configuration will proxy all request to the B path to the +path B on localhost:3000. + +=head3 Using Nginx + +with Nginx: + + upstream backendurl { + server unix:THE_PATH_OF_YOUR_PLACKUP_SOCKET_HERE.sock; + } + + server { + listen 80; + server_name YOUR_HOST_HERE; + + access_log /var/log/YOUR_ACCESS_LOG_HERE.log; + error_log /var/log/YOUR_ERROR_LOG_HERE.log info; + + root YOUR_ROOT_PROJECT/public; + location / { + try_files $uri @proxy; + access_log off; + expires max; + } + + location @proxy { + proxy_set_header Host $http_host; + proxy_set_header X-Forwarded-Host $host; + proxy_set_header X-Real-IP $remote_addr; + proxy_set_header X-Forwarded-For $proxy_add_x_forwarded_for; + proxy_pass http://backendurl; + } + + } + +You will need plackup to start a worker listening on a socket : + + cd YOUR_PROJECT_PATH + sudo -u www plackup -E production -s Starman --workers=2 -l THE_PATH_OF_YOUR_PLACKUP_SOCKET_HERE.sock -a bin/app.pl + +A good way to start this is to use C and place this line with +all environments variables in the "run" file. + +=head3 Using HAProxy + +C is a reliable high-performance TCP/HTTP load balancer written in C available from +L. + +Suppose we want to run an application at C and would to use two +backends listen on hosts C and C. + +Here is HAProxy configuration file (haproxy.conf): + + global + nbproc 1 + maxconn 4096 + user nobody + group nobody + # haproxy logs will be collected by syslog + # syslog: unix socket path or tcp pair (ipaddress:port) + log /var/run/log local0 + daemon + # enable compression (haproxy v1.5-dev13 and above required) + tune.comp.maxlevel 5 + + defaults + log global + option httpclose + option httplog + option dontlognull + option forwardfor + option abortonclose + mode http + balance roundrobin + retries 3 + timeout connect 5s + timeout server 30s + timeout client 30s + timeout http-keep-alive 200m + # enable compression (haproxy v1.5-dev13 and above required) + compression algo gzip + compression type text/html application/javascript text/css application/x-javascript text/javascript + + # application frontend (available at http://app.example.com) + frontend app.example.com + bind :80 + # modify request headers + reqadd X-Forwarded-Proto:\ http + reqadd X-Forwarded-Port:\ 80 + # modify response headers + rspdel ^Server:.* + rspdel ^X-Powered-By:.* + rspadd Server:\ Dethklok\ (Unix/0.2.3) + rate-limit sessions 1024 + acl is-haproxy-stats path_beg /stats + # uncomment if you'd like to get haproxy usage statistics + # use_backend haproxy if is-haproxy-stats + default_backend dynamic + + # haproxy statistics (available at http://app.example.com/stats) + backend haproxy + stats uri /stats + stats refresh 180s + stats realm app.example.com\ haproxy\ statistics + # change credentials + stats auth admin1:password1 + stats auth admin2:password2 + stats hide-version + stats show-legends + + # application backends + backend dynamic + # change path_info to check and value of the Host header sent to application server + option httpchk HEAD / HTTP/1.1\r\nHost:\ app.example.com + server app1 app-be1.example.com:3000 check inter 30s + server app2 app-be2.example.com:3000 check inter 30s + +We will need to start the workers on each backend of our application. This can be done by starman utility: + + # on app-be1.example.com + $ starman --workers=2 --listen :3000 /path/to/app.pl + # on app-be2.example.com + $ starman --workers=2 --listen :3000 /path/to/app.pl + +Then start the haproxy itself: + + # check the configuration.. + $ sudo haproxy -c -f haproxy.conf + # now really start it.. + $ sudo haproxy -f haproxy.conf + +=head2 Running on lighttpd + +=head3 Running on lighttpd (CGI) + +To run as a CGI app on lighttpd, just create a soft link to the C +script (created when you run C) inside your system's C +folder. Make sure C is enabled. + + ln -s /path/to/MyApp/public/dispatch.cgi /usr/lib/cgi-bin/mycoolapp.cgi + +=head3 Running on lighttpd (FastCGI) + +Make sure C is enabled. You also must have L installed. + +This example configuration uses TCP/IP: + + $HTTP["url"] == "^/app" { + fastcgi.server += ( + "/app" => ( + "" => ( + "host" => "127.0.0.1", + "port" => "5000", + "check-local" => "disable", + ) + ) + ) + } + +Launch your application: + + plackup -s FCGI --port 5000 bin/app.psgi + +This example configuration uses a socket: + + $HTTP["url"] =~ "^/app" { + fastcgi.server += ( + "/app" => ( + "" => ( + "socket" => "/tmp/fcgi.sock", + "check-local" => "disable", + ) + ) + ) + } + +Launch your application: + + plackup -s FCGI --listen /tmp/fcgi.sock bin/app.psgi + +=head2 Performance Improvements + +The following modules can be used to speed up an app in Dancer2: + +=over 4 + +=item * L + +=item * L + +=item * L + +=item * L + +=item * L + +=item * L + +=back + +They would need to be installed separately. This is because L does +not incorporate any C code, but it can get C-code compiled as a module. +Thus, these modules can be used for speed improvement provided: + +=over 4 + +=item * You have access to a C interpreter + +=item * You don't need to fatpack your application + +=back + +=head1 AUTHOR + +Dancer Core Developers + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2018 by Alexis Sukrieh. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/cpanlib/Dancer2/Manual/Migration.pod b/cpanlib/Dancer2/Manual/Migration.pod new file mode 100644 index 0000000..4f23740 --- /dev/null +++ b/cpanlib/Dancer2/Manual/Migration.pod @@ -0,0 +1,606 @@ +package Dancer2::Manual::Migration; +# ABSTRACT: Migrating from Dancer to Dancer2 + +use strict; +use warnings; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dancer2::Manual::Migration - Migrating from Dancer to Dancer2 + +=head1 VERSION + +version 0.206000 + +=head1 Migration from Dancer 1 to Dancer2 + +This document covers some changes that users will need to be aware of +while upgrading from L (version 1) to L. + +=head2 Launcher script + +The default launcher script F in L looked like this: + + #!/usr/bin/env perl + use Dancer; + use MyApp; + dance; + +In L it is available as F and looks like this: + + #!/usr/bin/env perl + + use strict; + use warnings; + use FindBin; + use lib "$FindBin::Bin/../lib"; + + use MyApp; + MyApp->to_app; + +So you need to remove the C part, replace the C command +by C<< MyApp->to_app; >> (where MyApp is the name of your application), and +add the following lines: + + use strict; + use warnings; + use FindBin; + use lib "$FindBin::Bin/../lib"; + +There is a L article +L<< covering the C keyword|http://advent.perldancer.org/2014/9 >> +and its usage. + +=head2 Configuration + +You specify a different location to the directory used for serving static (public) +content by setting the C option. In that case, you have to set +C option also. + +=head2 Apps + +1. In L, each module is a B with its own +namespace and variables. You can set the application name in each of your +L application modules. Different modules can be tied into the same +app by setting the application name to the same value. + +For example, to set the appname directive explicitly: + +C: + + package MyApp; + use Dancer2; + use MyApp::Admin + + hook before => sub { + var db => 'Users'; + }; + + get '/' => sub {...}; + + 1; + +C: + + package MyApp::Admin; + use Dancer2 appname => 'MyApp'; + + # use a lexical prefix so we don't override it globally + prefix '/admin' => sub { + get '/' => sub {...}; + }; + + 1; + +Without the appname directive, C would not have access +to variable C. In fact, when accessing C, the before hook would +not be executed. + +See L +for details. + +2. To speed up an app in Dancer2, install the recommended modules listed in the +L section. + +=head2 Request + +The request object (L) is now deferring much of +its code to L to be consistent with the known interface +to L requests. + +Currently the following attributes pass directly to L: + +C
    , C, C, C, C, C, +C, C, C, C, +C, C, and C. + +If previous attributes returned I for no value beforehand, they +will return whatever L defines now, which just might be +an empty list. + +For example: + + my %data = ( + referer => request->referer, + user_agent => request->user_agent, + ); + +should be replaced by: + + my %data = ( + referer => request->referer || '', + user_agent => request->user_agent || '', + ); + +=head2 Plugins: plugin_setting + +C returns the configuration of the plugin. It can only be +called in C or C. + +=head2 Routes + +L requires all routes defined via a string to begin with a leading +slash C. + +For example: + + get '0' => sub { + return "not gonna fly"; + }; + +would return an error. The correct way to write this would be to use +C + +=head2 Route parameters + +The C keyword which provides merged parameters used to allow body +parameters to override route parameters. Now route parameters take +precedence over query parameters and body parameters. + +We have introduced C to retrieve parameter values from +the route matching. Please refer to L for more +information. + +=head2 Tests + +Dancer2 recommends the use of L. + +For example: + + use strict; + use warnings; + use Test::More tests => 2; + use Plack::Test; + use HTTP::Request::Common; + + { + package App::Test; # or whatever you want to call it + get '/' => sub { template 'index' }; + } + + my $test = Plack::Test->create( App::Test->to_app ); + my $res = $test->request( GET '/' ); + + ok( $res->is_success, '[GET /] Successful' ); + like( $res->content, qr{Test2}, 'Correct title' ); + +Other modules that could be used for testing are: + +=over 4 + +=item * L + +=item * L + +=back + +=head3 Logs + +The C in the Logger role (L) +is now C. + +C can no longer be used, as with L. Instead, +L could be used for testing, to capture all +logs to an object. + +For example: + + use strict; + use warnings; + use Test::More import => ['!pass']; + use Plack::Test; + use HTTP::Request::Common; + use Ref::Util qw; + + { + package App; + use Dancer2; + + set log => 'debug'; + set logger => 'capture'; + + get '/' => sub { + debug 'this is my debug message'; + return 1; + }; + } + + my $app = Dancer2->psgi_app; + ok( is_coderef($app), 'Got app' ); + + test_psgi $app, sub { + my $cb = shift; + + my $res = $cb->( GET '/' ); + is $res->code, 200; + + my $trap = App->dancer_app->logger_engine->trapper; + + is_deeply $trap->read, [ + { level => 'debug', message => 'this is my debug message' } + ]; + }; + +=head2 Exports: Tags + +The following tags are not needed in L: + + use Dancer2 qw(:syntax); + use Dancer2 qw(:tests); + use Dancer2 qw(:script); + +The C command should be used instead. It provides a development +server and reads the configuration options in your command line utilities. + +=head2 Engines + +=over 4 + +=item * Engines receive a logging callback + +Engines now receive a logging callback named C. Engines can use it +to log anything in run-time, without having to worry about what logging +engine is used. + +This is provided as a callback because the logger might be changed in +run-time and we want engines to be able to always reach the current one +without having a reference back to the core application object. + +The logger engine doesn't have the attribute since it is the logger itself. + +=item * Engines handle encoding consistently + +All engines are now expected to handle encoding on their own. User code +is expected to be in internal Perl representation. + +Therefore, all serializers, for example, should deserialize to the Perl +representation. Templates, in turn, encode to UTF-8 if requested by the +user, or by default. + +One side-effect of this is that C will call L's C +function with decoded input. + +=back + +=head3 Templating engine changes + +Whereas in Dancer1, the following were equivalent for Template::Toolkit: + + template 'foo/bar' + template '/foo/bar' + +In Dancer2, when using L, the version with +the leading slash will try to locate C relative to your filesystem +root, not relative to your Dancer application directory. + +The L engine is unchanged in this respect. + +Whereas in Dancer1, template engines have the methods: + + $template_engine->view('foo.tt') + $template_engine->view_exists('foo.tt') + +In Dancer2, you should instead write: + + $template_engine->view_pathname('foo.tt') + $template_engine->pathname_exists($full_path) + +You may not need these unless you are writing a templating engine. + +=head3 Serializers + +You no longer need to implement the C method. It is simply +unnecessary. + +=head3 Sessions + +Now the L session engine is turned on +by default, unless you specify a different one. + +=head2 Configuration + +=head3 C + +You cannot set the public directory with C now. Instead you +will need to call C: + + # before + setting( 'public_dir', 'new_path/' ); + + # after + config->{'public_dir'} = 'new_path'; + +=head3 warnings + +The C configuration option, along with the environment variable +C, have been removed and have no effect whatsoever. + +They were added when someone requested to be able to load Dancer without +the L pragma, which it adds, just like L, L, and +other modules provide. + +If you want this to happen now (which you probably shouldn't be doing), +you can always control it lexically: + + use Dancer2; + no warnings; + +You can also use Dancer2 within a narrower scope: + + { use Dancer2 } + use strict; + # warnings are not turned on + +However, having L turned it is very recommended. + +=head3 server_tokens + +The configuration C has been introduced in the reverse (but +more sensible, and Plack-compatible) form as C. + +C changed to C. + +=head3 engines + +If you want to use Template::Toolkit instead of the built-in simple templating +engine you used to enable the following line in the config.yml file. + + template: "template_toolkit" + +That was enough to get started. The start_tag and end_tag it used were the same as in +the simple template <% and %> respectively. + +If you wanted to further customize the Template::Toolkit you could also enable or add +the following: + + engines: + template_toolkit: + encoding: 'utf8' + start_tag: '[%' + end_tag: '%]' + +In Dancer 2 you can also enable Template::Toolkit with the same configuration option: + + template: "template_toolkit" + +But the default start_tag and end_tag are now [% and %], so if you used the default in Dancer 1 +now you will have to explicitly change the start_tag and end_tag values. +The configuration also got an extral level of depth. Under the C key there is a C