├── .gitignore ├── .shipit ├── Changes ├── EARLY_NOTES ├── MANIFEST ├── MANIFEST.SKIP ├── MIT-LICENSE ├── Makefile.PL ├── README ├── bin └── squatting ├── doc ├── squatting-intro.xul ├── squatting-propaganda-for-catalyst.txt ├── squatting-propaganda-for-perlmonks.html └── squatting-tpf-grant-proposal.txt ├── edit ├── eg ├── Chat.pm ├── CouchWiki.pm ├── Counter.pm ├── Example.pm ├── Example │ ├── Controllers.pm │ └── Views.pm ├── Guess.pm ├── HTTPAuth.pm ├── MicroWiki.pm ├── PODServer.pm ├── README ├── UTF_8.pm ├── UniCodePoints.pm ├── chat-ajax-push.js ├── jquery.js └── microwiki.psgi ├── lib ├── Squatting.pm ├── Squatting │ ├── Controller.pm │ ├── H.pm │ ├── Mapper.pm │ ├── On │ │ ├── CGI.pm │ │ ├── Catalyst.pm │ │ ├── Continuity.pm │ │ ├── MP13.pm │ │ ├── MP20.pm │ │ └── Squatting.pm │ ├── View.pm │ └── With │ │ ├── AccessTrace.pm │ │ ├── Coro │ │ └── Debug.pm │ │ ├── Log.pm │ │ ├── MockRequest.pm │ │ └── Mount.pm └── squatting.pl ├── t ├── 00_basic.t ├── 01_controller.t ├── 02_view.t └── 20_squatting_with_log.t └── xt ├── 01_podspell.t ├── 02_perlcritic.t ├── 03_pod.t ├── 04_kwalitee.t └── perlcriticrc /.gitignore: -------------------------------------------------------------------------------- 1 | Makefile 2 | *.~ 3 | *.bak 4 | *.sw? 5 | blib 6 | pm_to_blib 7 | -------------------------------------------------------------------------------- /.shipit: -------------------------------------------------------------------------------- 1 | # auto-generated shipit config file. 2 | steps = FindVersion, ChangeVersion, CheckChangeLog, DistTest, Commit, Tag, MakeDist 3 | 4 | # svn.tagpattern = MyProj-%v 5 | # svn.tagpattern = http://code.example.com/svn/tags/MyProj-%v 6 | 7 | # CheckChangeLog.files = ChangeLog, MyProj.CHANGES 8 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Beyond (unreleased) 2 | * add proper support for file uploads wherever possible. #lack-of-maturity 3 | # I think adding an upload method to the controllers would work. 4 | * do a better job of simulating requests in squatting -C 5 | * BUG: POST -> perlbal -> thttpd -> Squatting::On::CGI == FAIL 6 | Strangely enough, GET is fine. 7 | Take perlbal out of the setup and everything is fine. 8 | * implement Squatting::On::Jifty 9 | * implement Squatting::On::Squatting 10 | * move mount method out of the core and into Squatting::With::Mount 11 | * use Rhetoric and Pod::Server as examples of how to document a Squatting app. 12 | * OLD: in Squatting::Controller's POD, teach people how to document controllers. 13 | * OLD: in Squatting::View's POD, teach people how to document views. 14 | * Make bin/squatting use Plack::Runner 15 | * Things that would make Squatting easier to get started with: 16 | - an app generator (using Module::Setup?) 17 | - PSGI support by default 18 | * Replace Shell::Perl with something based on Eval::WithLexicals. 19 | 20 | 0.82 2013-08-11 21 | - Squatting::With::PerHostConfig was removed, because I realized 22 | that it couldn't work the way I wanted it, too. By the time 23 | it modified %CONFIG, it would be too late to affect the response 24 | in a meaningful way. 25 | - Small patch from Duncan Garland to remove warnings issued by perl 5.14 26 | 27 | 0.81 2011-04-27 28 | - Slight improvements to Squatting::With::MockRequest were made 29 | to facilitate doing static exports of Rhetoric sites. 30 | 31 | 0.80 2011-04-27 32 | - [ MAJOR API CHANGE! ] 33 | - You don't say: use base 'Squatting' anymore. 34 | - When creating a Squatting app, 35 | you just say: use Squatting; 36 | - You don't say: use Squatting ':controllers' or 37 | use Squatting ':views' anymore 38 | - use Squatting takes care of what those statements used to do. 39 | - Squatting::H->merge renamed to Squatting::H->extend to 40 | be consistent w/ the way these words are used in contemporary 41 | Javascript libraries. 42 | - Added Squatting::With::PerHostConfig 43 | - hacked bin/squatting so that the console experience is a bit nicer. 44 | App->get and App->post will work a tiny bit more reliably. 45 | 46 | 0.70 2009-08-27 47 | - reimplemented Squatting::With::Log using Squatting::H 48 | - added Squatting::H->bless (breaking all the rules ;) 49 | - changed Squatting::Mapper semantics 50 | - $controller->{queue} has been deprecated in favor of 51 | $controller->{continuity} 52 | - Squatting::Mapper now dispatches on 53 | $sid + $controller + $path 54 | (in that order) 55 | - It used to just be $sid + $controller, 56 | but when people start opening multiple tabs, 57 | that wasn't enough. It was necessary to be 58 | able to distinguish between the different tabs, 59 | and putting something random at the end of a path 60 | was one way to do that, so it's now the default. 61 | - updated L 62 | 63 | 0.60 2009-04-21 64 | - More documentation updates and corrections. 65 | - Fixed URL for Tenjin in Squatting::Cookbook. 66 | - Implemented Squatting::With::Log 67 | - added --module parameter to bin/squatting 68 | - added default in-memory session to Squatting::On::Continuity 69 | - removed bin/vw from distribution, because it will be 70 | distributed with App::VW from now on. 71 | - worked around a weird bug where 72 | Squatting::On::Catalyst + FastCGI 73 | was using the wrong path. 74 | - added support for nested %CONFIG vars in bin/squatting 75 | - resurrected Squatting::H 76 | - implemented Squatting::With::Coro::Debug 77 | - implemented Squatting::On::MP13 78 | - implemented Squatting::On::MP20 79 | 80 | 0.52 81 | - More documentation updates and corrections 82 | - Massive updates to Squatting::Cookbook 83 | 84 | 0.51 85 | - implemented Squatting::On::CGI 86 | - implemented OpenID::Consumer example 87 | 88 | 0.50 89 | - More documentation updates and corrections. 90 | - Moved last if-block in service to Squatting::On::Continuity 91 | - Moved controller log into Squatting::With::AccessTrace 92 | - Allow more HTTP methods when using Squatting::On::Continuity 93 | - Started documenting Continuity's special powers. 94 | 95 | 0.42 96 | - Revised the documentation a bit. 97 | - Made squatting --help have a higher precedence. 98 | 99 | 0.41 100 | - Fixed a few documentation errors. 101 | - Minimized namespace pollution from Squatting::On::* plugins. 102 | - Fixed Squatting <=> Catalyst cookie mapping. 103 | 104 | 0.40 105 | - Removed $Squatting::app and became both mod_perl compatible and embeddable. 106 | - Added unit tests for Squatting::Controller and Squatting::View 107 | - Allow views to have access to outgoing HTTP headers. 108 | - Fixed yet another obscure cookie bug. 109 | - Learned that the attribute handler in Squatting::Q must be invoked 110 | during the INIT phase rather than the earlier CHECK phase, because 111 | the coderef's address during the CHECK phase may not be final. 112 | (Trivia: coderef's that close over variables outside their own 113 | lexical scope get changed sometime after the CHECK phase.) 114 | - Unfortunately, even that's not good enough. 115 | Squatting::Q has been removed, because Attribute::Handlers 116 | can't be made to work for this purpose. (RIP Squatting::Q July 4, 2008) 117 | - Implemented Squatting::On::Catalyst. 118 | - Implemented Squatting::On::Continuity. 119 | - We're using Class::C3::Componentised to load extensions like 120 | those found in Squatting::On::*. 121 | - Added sample application, Chat. 122 | - Added sample application, UniCodePoints. 123 | 124 | 0.31 125 | - Fixed a bug in the cookie parsing code. 126 | 127 | 0.30 128 | - In view objects, $self->{template} is the name of the current template. 129 | - $controller->set_cookies renamed to $controller->cookies 130 | - $controller->cookies now handles both incoming and outgoing cookies 131 | - made $controller->headers and $controller->cgi_cookies lvalue subs, too. 132 | - lots of documentation added 133 | 134 | 0.21 135 | - Fixed the URL to Io's web site 136 | 137 | 0.20 138 | - Initial Release 139 | -------------------------------------------------------------------------------- /EARLY_NOTES: -------------------------------------------------------------------------------- 1 | RANDOM NOTES 2 | ============ 3 | 4 | There is an example application in the eg/ directory 5 | called "Example". 6 | 7 | This is how you currently run this squatting application: 8 | 9 | cd eg/ 10 | squatting Example 11 | 12 | (Example.pm needs to be discoverable through @INC.) 13 | 14 | - -*- - 15 | 16 | If you're familiar w/ the Camping API, 17 | the Squatting API will feel similar. 18 | 19 | - -*- - 20 | 21 | Example::Controllers is the package that contains all the controllers. 22 | 23 | - -*- - 24 | 25 | Controllers are objects (not classes) 26 | that are constructed using the C() function. 27 | 28 | - -*- - 29 | 30 | Controllers represent HTTP Resources 31 | that support HTTP Methods 32 | like GET and POST with 33 | the object methods 34 | get and post. 35 | 36 | This was the genius of Camping. 37 | I can't think of a better way to 38 | express RESTful controllers. 39 | 40 | - -*- - 41 | 42 | Example::Views is the package that contains all the views. 43 | 44 | - -*- - 45 | 46 | Views are also objects (not classes) 47 | that are constructed using the V() function. 48 | 49 | - -*- - 50 | 51 | The methods of a view are thought of as templates. 52 | 53 | - -*- - 54 | 55 | The responsibility of a template is to 56 | 1) take a hashref of variables and 57 | 2) return a string. 58 | 59 | You may use any templating system you want, 60 | or even none at all. 61 | 62 | - -*- - 63 | 64 | You may define a layout template called 'layout' 65 | which will be used to wrap the content of any other template. 66 | If you don't want your template to be wrapped, you have 67 | to give it a name with a '_' in front. 68 | 69 | - -*- - 70 | 71 | You may define a generic template called '_' for use when 72 | a specific template can't be found. 73 | 74 | - -*- - 75 | 76 | You may have multiple views. 77 | 78 | - -*- - 79 | 80 | The first view you define is your default view. 81 | 82 | - -*- - 83 | 84 | The optional 2nd parameter to the render() method 85 | lets you specify which view you want to use. For example, 86 | 87 | $self->render('profile', 'json') 88 | 89 | would render the 'profile' template using the 'json' view. 90 | 91 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | .shipit 2 | bin/squatting 3 | Changes 4 | doc/squatting-intro.xul 5 | doc/squatting-propaganda-for-catalyst.txt 6 | doc/squatting-propaganda-for-perlmonks.html 7 | doc/squatting-tpf-grant-proposal.txt 8 | EARLY_NOTES 9 | edit 10 | eg/chat-ajax-push.js 11 | eg/Chat.pm 12 | eg/CouchWiki.pm 13 | eg/Counter.pm 14 | eg/Example.pm 15 | eg/Example/Controllers.pm 16 | eg/Example/Views.pm 17 | eg/Guess.pm 18 | eg/HTTPAuth.pm 19 | eg/jquery.js 20 | eg/MicroWiki.pm 21 | eg/microwiki.psgi 22 | eg/PODServer.pm 23 | eg/README 24 | eg/UniCodePoints.pm 25 | eg/UTF_8.pm 26 | lib/squatting.pl 27 | lib/Squatting.pm 28 | lib/Squatting/Controller.pm 29 | lib/Squatting/H.pm 30 | lib/Squatting/Mapper.pm 31 | lib/Squatting/On/Catalyst.pm 32 | lib/Squatting/On/CGI.pm 33 | lib/Squatting/On/Continuity.pm 34 | lib/Squatting/On/MP13.pm 35 | lib/Squatting/On/MP20.pm 36 | lib/Squatting/On/Squatting.pm 37 | lib/Squatting/View.pm 38 | lib/Squatting/With/AccessTrace.pm 39 | lib/Squatting/With/Coro/Debug.pm 40 | lib/Squatting/With/Log.pm 41 | lib/Squatting/With/MockRequest.pm 42 | lib/Squatting/With/Mount.pm 43 | Makefile.PL 44 | MANIFEST This list of files 45 | MANIFEST.SKIP 46 | MIT-LICENSE 47 | README 48 | t/00_basic.t 49 | t/01_controller.t 50 | t/02_view.t 51 | t/20_squatting_with_log.t 52 | xt/01_podspell.t 53 | xt/02_perlcritic.t 54 | xt/03_pod.t 55 | xt/04_kwalitee.t 56 | xt/perlcriticrc 57 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | ^\.git 2 | ^MANIFEST\.bak$ 3 | ^Makefile$ 4 | \..*\.swp$ 5 | pm_to_blib 6 | ~$ 7 | \bblib\b 8 | \b\.xvpics\b 9 | -------------------------------------------------------------------------------- /MIT-LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2008 John BEPPU . 2 | 3 | Permission is hereby granted, free of charge, to any person 4 | obtaining a copy of this software and associated documentation 5 | files (the "Software"), to deal in the Software without 6 | restriction, including without limitation the rights to use, 7 | copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the 9 | Software is furnished to do so, subject to the following 10 | conditions: 11 | 12 | The above copyright notice and this permission notice shall be 13 | included in all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 16 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 17 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 18 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 19 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 20 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use ExtUtils::MakeMaker; 2 | 3 | WriteMakefile1( 4 | META_MERGE => { 5 | resources => { 6 | repository => 'http://github.com/beppu/squatting', 7 | }, 8 | }, 9 | #BUILD_REQUIRES => { 10 | #}, 11 | 12 | NAME => 'Squatting', 13 | AUTHOR => 'John BEPPU ', 14 | LICENSE => 'mit', 15 | VERSION_FROM => 'lib/Squatting.pm', 16 | ABSTRACT_FROM => 'lib/Squatting.pm', 17 | EXE_FILES => [ 'bin/squatting' ], 18 | PREREQ_PM => { 19 | 'Class::C3::Componentised' => 0, 20 | 'HTTP::Daemon' => 0, 21 | 'Continuity' => 0.991, 22 | 'Data::Dump' => 0, 23 | 'JSON::XS' => 0, 24 | 'Shell::Perl' => 0, 25 | 'IO::All' => 0, 26 | 'Test::More' => 0, 27 | 'HTTP::Response' => 0, 28 | 'Clone' => 0, 29 | }, 30 | MIN_PERL_VERSION => 5.006001, 31 | depend => { distmeta => 'metamunge' } 32 | ); 33 | 34 | sub MY::libscan { 35 | my $self = shift; 36 | $_ = shift; 37 | # $self appears to be a blessed hashref that contains 38 | # all the attributes/value pairs passed to WriteMakeFile() 39 | # plus some other MakeMaker-related info. 40 | return 0 if /\.sw.$/ || /~$/; 41 | return $_; 42 | } 43 | 44 | sub MY::postamble {q{ 45 | metamunge : 46 | $(NOECHO) $(ECHO) 'no_index:' >> $(DISTVNAME)/META.yml 47 | $(NOECHO) $(ECHO) ' directory:' >> $(DISTVNAME)/META.yml 48 | $(NOECHO) $(ECHO) ' - eg' >> $(DISTVNAME)/META.yml 49 | $(NOECHO) $(ECHO) ' - t' >> $(DISTVNAME)/META.yml 50 | 51 | nd : 52 | $(MKPATH) doc 53 | $(MKPATH) /tmp/squatting-doc 54 | nd -r -i lib -o HTML doc -p /tmp/sqautting-doc 55 | }} 56 | 57 | sub WriteMakefile1 { #Written by Alexandr Ciornii, version 0.21. Added by eumm-upgrade. 58 | my %params=@_; 59 | my $eumm_version=$ExtUtils::MakeMaker::VERSION; 60 | $eumm_version=eval $eumm_version; 61 | die "EXTRA_META is deprecated" if exists $params{EXTRA_META}; 62 | die "License not specified" if not exists $params{LICENSE}; 63 | if ($params{BUILD_REQUIRES} and $eumm_version < 6.5503) { 64 | #EUMM 6.5502 has problems with BUILD_REQUIRES 65 | $params{PREREQ_PM}={ %{$params{PREREQ_PM} || {}} , %{$params{BUILD_REQUIRES}} }; 66 | delete $params{BUILD_REQUIRES}; 67 | } 68 | delete $params{CONFIGURE_REQUIRES} if $eumm_version < 6.52; 69 | delete $params{MIN_PERL_VERSION} if $eumm_version < 6.48; 70 | delete $params{META_MERGE} if $eumm_version < 6.46; 71 | delete $params{META_ADD} if $eumm_version < 6.46; 72 | delete $params{LICENSE} if $eumm_version < 6.31; 73 | delete $params{AUTHOR} if $] < 5.005; 74 | delete $params{ABSTRACT_FROM} if $] < 5.005; 75 | delete $params{BINARY_LOCATION} if $] < 5.005; 76 | 77 | WriteMakefile(%params); 78 | } 79 | 80 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | 2 | 3 | -+m 4 | .%- .. 5 | [ Squatting ] . m*#-+ 6 | A Camping-inspired Web Microframework for Perl m+*##+m. 7 | ...- m#*#%-.. 8 | --.. +mm###-+-. 9 | ..- m..*#####*m++ 10 | .--+.-m#m+.%+-m###+ 11 | .-m..###+...% m#m-##% . 12 | +%+.. -++.+ m--#-+ 13 | .. --..%*-%- --+#.m 14 | - - -.--+# .. +#m+ 15 | ..#-+%. +.#.. 16 | . . . .%#-... .-+.- 17 | . -.+m+-. .. .-.++#.*-... . . 18 | ..- .+. ..+..+---+%---.--.--#m#+.. + 19 | .-. m .. -.m++m####%###-##%.++*%++ m . 20 | . +. m-- *##*#+###..-m+m.++.#-####-%-m. .. 21 | -m#--%###-m+- --+%m..--. - .-*%####% ..-. -. 22 | -...-*##%m+.+-+.++-m#+-. .. . +.+%%-#m..m#%m+..-. 23 | -..*#**m.-.+..-.m+-##+.- +m-+*%- %-- %##- 24 | ...++*++.. . . +m##*-. -.%m+ + -.-++%+- 25 | . ++###.%.-- . . *m+##%%. .-%-#- . ...#... 26 | ..%*+m . + m+####%.. .-+%#+- .-#-- 27 | -.#mm.. --.- +%#-m#%% ...%+##%+ .+..\- 28 | .+mm%+ .. ..m-m.+%%+m**+.. --.##%m--. + #-. 29 | .--%%. . m .#++ %-- +mm-. ...m##m-.+ -+*-- 30 | +-#+- . .##+.. +..m .m-#%#%-- -.##-. 31 | .%.**+. ...m#%..- .. ...# m . +-%#.%+ . %#%..+ 32 | -+##%.+.. #-. -. .m+..m -#%mm .--**++ 33 | .-%.*m+-...mm+ . .+ +- -m-+. ..*#.. . 34 | .-+*m#%m**++-+ .. -##.%%.- - ..##+-. 35 | - +-*%##%+mm--+ . .#m-m- - -+.m.##-+. 36 | .. m*##*#*%-m+- - . . .m.+.m .. m%+.*-% - 37 | ...+##m%####m-+m- -. .. ..- ++.. . +.. +%-###m-%. 38 | ..%#-%#++%####.+.m-+. . +m#+#+%.. . -#*###m.-- 39 | . %-mm ++-mm+**##%mm. - .+mm#+*.+--.#/##-+-+m . 40 | ..+.# - +-. m%m#m#*+.-..+##*###%m#%#% .--- - . . 41 | .-m#m. . . ..m+...#%m--+-*#+######.%+.. .+ 42 | ..m-#%. . ..- .+-- - .---.-**-+--... 43 | .+.#m#m- .. . . - -..- ..* 44 | . +-##-+. . -- . .. 45 | .+##m%+ 46 | .%.--- 47 | .. . 48 | ... 49 | 50 | http://en.wikipedia.org/wiki/Squatting 51 | https://github.com/beppu/squatting 52 | 53 | 54 | The API (should fit comfortably in your head with plenty of room to spare). 55 | --------------------------------------------------------------------------- 56 | 57 | ## [0] BEGINNING AN APP 58 | 59 | package App; 60 | use Squatting; # <-- This use statement is where the magic happens. 61 | # 62 | # %App::CONFIG 63 | # &App::D 64 | # &App::Controllers::R 65 | # @App::Controllers::C 66 | # %App::Controllers::C 67 | # &App::Controllers::C 68 | # &App::Views::R 69 | # @App::Views::V 70 | # %App::Views::V 71 | # 72 | # @App::ISA = qw(Squatting); 73 | # # ...and Squatting->isa('Class::C3::Componentised') 74 | 75 | ## [1] CUSTOMIZING AN APP 76 | 77 | our %CONFIG = ( 78 | # App configuration goes in a hash. 79 | ); 80 | 81 | # Code that needs to run when the app starts goes in init(). 82 | sub init { 83 | my ($class) = @_; 84 | $class->next::method(); 85 | } 86 | 87 | # Code that needs to run on every request goes in service(). 88 | sub service { 89 | my ($class, $controller, @args) = @_; 90 | 91 | # before controller 92 | 93 | my $content = $class->next::method($controller, @args); 94 | 95 | # after controller 96 | 97 | return $content; 98 | } 99 | 100 | 1; 101 | 102 | ## [2] DEFINE CONTROLLERS 103 | 104 | package App::Controllers; 105 | our @C = ( 106 | 107 | C( 108 | 'Home' => [ '/' ], 109 | get => sub { 110 | } 111 | ), 112 | 113 | C( 114 | 'Post' => [ '/(\d+)/(\d+)/(\w+)' ], 115 | get => sub { 116 | my ($self, $year, $month, $slug) = @_; 117 | }, 118 | post => sub { 119 | my ($self, $year, $month, $slug) = @_; 120 | } 121 | ) 122 | 123 | C( 124 | 'Comment' => [ '/comment' ], 125 | post => sub { 126 | } 127 | ) 128 | 129 | ); 130 | 131 | 1; 132 | 133 | ## [3] DEFINE VIEWS 134 | 135 | package App::Views; 136 | our @V = ( 137 | V( 138 | 'Default', 139 | 140 | layout => sub { 141 | my ($self, $v, $content) = @_; 142 | # This optional method allows you to wrap the content 143 | # that your template methods return. 144 | return "HEADER $content FOOTER"; 145 | }, 146 | 147 | _partial => sub { 148 | my ($self, $v) = @_; 149 | # If you want a view to not be wrapped by the layout, 150 | # its name should begin with "_". 151 | return "exactly what you want"; 152 | }, 153 | 154 | wrapped => sub { 155 | my ($self, $v) = @_; 156 | # This template's name does not begin with "_" so it 157 | # WILL be wrapped by the layout. 158 | return "wrapped content"; 159 | } 160 | 161 | _ => sub { 162 | my ($self, $v) = @_; 163 | # If a named template method is not found, this method 164 | # will be run. Think of it as AUTOLOAD for views. 165 | return "something"; 166 | }, 167 | 168 | ), 169 | ); 170 | 171 | 1; 172 | 173 | 174 | SUMMARY OF THE SQUATTING API 175 | ---------------------------- 176 | 177 | %App::CONFIG Where your app configuration is expected to be 178 | 179 | &App::init Code that runs on applicationn initialization 180 | 181 | &App::service Code that runs on every HTTP request 182 | 183 | App::Controllers Package where controllers are expected to be 184 | 185 | @App::Controllers::C Array where controllers are expected to be 186 | 187 | &App::Controllers::C Helper function for creating Squatting::Controller 188 | objects 189 | 190 | &App::Controllers::R Helper function for generating URL paths; 191 | Think "R" for "route". 192 | 193 | App::Views Package where views are expected to be 194 | 195 | @App::Views::V Array where views are expected to be 196 | 197 | &App::Views::V Helper function for creating Squatting::View objects 198 | 199 | &App::Views::R Helper function for generating URL paths; 200 | It's the exact same function as &App::Controllers::R. 201 | &App::Controllers::R == &App::Views::R 202 | 203 | 204 | You should be able to memorize this quite easily, and I hope you 205 | never have to use a search engine to figure out how any of this works. 206 | The entire API should fit comfortably inside your mind with plenty of 207 | room to spare. 208 | 209 | 210 | For more information: 211 | `perldoc Squatting` 212 | `perldoc Squatting::Controller` 213 | `perldoc Squatting::View` 214 | 215 | 216 | For practical examples, see: 217 | Rhetoric (a simple blogging system) 218 | Pod::Server (a POD browser) 219 | Stardust (a COMET server) 220 | 221 | -------------------------------------------------------------------------------- /bin/squatting: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | no strict 'refs'; 5 | use warnings; 6 | use lib 'lib'; 7 | 8 | require Squatting; 9 | use Squatting::H; 10 | use Getopt::Long; 11 | use Data::Dump 'pp'; 12 | 13 | # defaults 14 | $_{port} = 4234; 15 | $_{debug} = 1; 16 | $_{module} = [ 'With::Log', 'With::AccessTrace' ]; 17 | 18 | # command line options 19 | Getopt::Long::Configure('no_ignore_case'); 20 | GetOptions( 21 | \%_, 22 | 'port|p=i', 23 | 'log|l=s', 24 | 'console|C', 25 | 'debug=i', 26 | 'version|v', 27 | 'config|c=s%', 28 | 'show-config|s', 29 | 'module|m=s@', 30 | 'logo', 31 | 'help|h', 32 | ); 33 | 34 | sub help { 35 | print "Squatting $Squatting::VERSION - launch a Squatting web application 36 | 37 | Usage: squatting [OPTIONS]... App 38 | 39 | Options: 40 | -p, --port NUM Port for web server (defaults to $_{port}) 41 | -c, --config ATTR=VALUE Set an app's %CONFIG variables 42 | -s, --show-config Display an app's %CONFIG and exit 43 | -m, --module MODULE Load a Squatting plugin into the app 44 | -l, --log FILE Log file # TODO 45 | -C, --console Run in console mode with Shell::Perl 46 | --debug NUM Continuity debug_level (defaults to $_{debug}) 47 | 48 | -v, --version Display Squatting version 49 | --logo Display the International Squatting Symbol 50 | --help Display this help message 51 | 52 | "; 53 | } 54 | 55 | if ($_{version}) { 56 | print "Version $Squatting::VERSION\n"; 57 | exit 0; 58 | } elsif ($_{help}) { 59 | help; 60 | exit 0; 61 | } elsif ($_{log}) { 62 | $_{config}{'with.log.path'} = $_{log}; 63 | } elsif ($_{logo}) { 64 | print ; 65 | exit 0; 66 | } else { 67 | 68 | } 69 | 70 | # warn pp($_{config}), "\n"; 71 | # warn pp(\%_), "\n"; 72 | 73 | my $app = shift; 74 | if ($app) { 75 | $app =~ s/\.pmc?$//; 76 | my $path = $app; 77 | $path =~ s{::}{/}g; 78 | $path .= ".pm"; 79 | require "$path"; 80 | my $C = \%{$app."::CONFIG"}; 81 | for (keys %{$_{config}}) { 82 | if (/\[/ || /\{/) { 83 | my $key = $_; 84 | # XXX - If you can think of a better way, let me know. 85 | eval '$C->'.$key.' = $_{config}'."{'$key'}"; 86 | } else { 87 | $C->{$_} = $_{config}{$_} 88 | } 89 | } 90 | if ($_{'show-config'}) { 91 | print pp($C), "\n"; 92 | exit 0; 93 | } 94 | if ($_{console}) { 95 | eval { require Shell::Perl }; 96 | if ($@) { 97 | print "Please install Shell::Perl if you'd like to use the Squatting console.\n"; 98 | exit 1; 99 | } 100 | $app->load_components(@{$_{module}}); 101 | $app->init; 102 | # XXX - This is broken. I have to think this over. 103 | sub Squatting::Controller::mock_init { 104 | my $self = shift; 105 | $self->{cr} = {}; # TODO - provide a mock Continuity::Request 106 | $self->{env} = { REQUEST_PATH => &{"$app"."::Controllers::R"}($self->name, @_) }; 107 | $self->{cookies} = {}; 108 | $self->{input} = {}; 109 | $self->{headers} = {}; 110 | $self->{v} = {}; 111 | $self->{status} = 200; 112 | $self; 113 | }; 114 | foreach my $method ( qw(get post put delete) ) { 115 | *{$app."::$method" } = sub { 116 | my $cc = ${$app."::Controllers::C"}{$_[1]}->clone->mock_init(@_[2..$#_]); 117 | $cc->env->{REQUEST_METHOD} = $method; 118 | if (ref($_[-1]) eq 'HASH') { 119 | $cc->input = pop @_; 120 | } 121 | my $content = $app->service($cc, @_[2..$#_]); 122 | ($cc, $content); 123 | }; 124 | } 125 | $0 = $app; 126 | my $pirl = Shell::Perl->new; 127 | $pirl->set_package($app."::Controllers"); 128 | $pirl->run; 129 | } else { 130 | my @components = ( "On::Continuity", @{$_{module}} ); 131 | $app->load_components(@components); 132 | $app->init; 133 | $app->continue( 134 | port => $_{port}, 135 | log => $_{log}, 136 | debug_level => $_{debug}, 137 | ); 138 | } 139 | } else { 140 | help; 141 | } 142 | 143 | exit 0; 144 | 145 | =head1 NAME 146 | 147 | squatting -- Squatting server start-up script 148 | 149 | =head1 SYNOPSIS 150 | 151 | Usage: 152 | 153 | squatting [OPTION]... APPLICATION 154 | 155 | Starting an App in web server mode on port 4234: 156 | 157 | squatting -p 4234 App 158 | 159 | Start an App in interactive console mode: 160 | 161 | squatting -C App 162 | Welcome to the Perl shell. Type ':help' for more information 163 | 164 | App @> \@App::Controllers::C 165 | App @> \%App::Controllers::C 166 | App @> \@App::Views::V 167 | App @> \%App::Views::V 168 | App @> App->get('Home') 169 | App @> App->post('Comment', { name => 'beppu', body => 'Why?' }) 170 | 171 | =head1 DESCRIPTION 172 | 173 | Start a Squatting application. 174 | 175 | =head1 OPTIONS 176 | 177 | =over 2 178 | 179 | =item -p, --port NUM 180 | 181 | Port for web server (defaults to 4234) 182 | 183 | =item -c, --config ATTR=VALUE 184 | 185 | The standard way to configure a Squatting application is to manipulate its 186 | C<%CONFIG> hash. The --config option lets you set values in this hash, and you 187 | may use --config multiple times in a single command line. 188 | 189 | B: 190 | 191 | squatting App --config doc_root=/www/app.com --config hostname=app.com 192 | 193 | =item -s, --show-config 194 | 195 | Display an App's %CONFIG hash and exit. 196 | 197 | =item -m, --module MODULE 198 | 199 | This option can be used to load additional Squatting plugins into the app, and 200 | you may use this option multiple times in a single command line. Note that 201 | L and L are loaded by 202 | default. 203 | 204 | B: Loading Squatting::With::UTF8 and Squatting::With::Coro::Debug 205 | 206 | squatting App -m With::UTF8 -m With::Coro::Debug 207 | 208 | =item -l, --log FILE 209 | 210 | Send log output to a log file. 211 | 212 | =item -C, --console 213 | 214 | Run in console mode with Shell::Perl. 215 | 216 | =item --debug NUM 217 | 218 | Set Continuity's debug level. 0 is the least verbose setting, and higher 219 | numbers get progressively more verbose. 220 | 221 | =item -v, --version 222 | 223 | Show version 224 | 225 | =item --logo 226 | 227 | Display the B. 228 | 229 | =item -h, --help 230 | 231 | Show the help message 232 | 233 | =back 234 | 235 | =cut 236 | 237 | 238 | __DATA__ 239 | 240 | -+m 241 | .%- .. 242 | . m*#-+ 243 | m+*##+m. 244 | ...- m#*#%-.. 245 | --.. +mm###-+-. 246 | ..- m..*#####*m++ 247 | .--+.-m#m+.%+-m###+ 248 | .-m..###+...% m#m-##% . 249 | +%+.. -++.+ m--#-+ 250 | .. --..%*-%- --+#.m 251 | - - -.--+# .. +#m+ 252 | ..#-+%. +.#.. 253 | . . . .%#-... .-+.- 254 | . -.+m+-. .. .-.++#.*-... . . 255 | ..- .+. ..+..+---+%---.--.--#m#+.. + 256 | .-. m .. -.m++m####%###-##%.++*%++ m . 257 | . +. m-- *##*#+###..-m+m.++.#-####-%-m. .. 258 | -m#--%###-m+- --+%m..--. - .-*%####% ..-. -. 259 | -...-*##%m+.+-+.++-m#+-. .. . +.+%%-#m..m#%m+..-. 260 | -..*#**m.-.+..-.m+-##+.- +m-+*%- %-- %##- 261 | ...++*++.. . . +m##*-. -.%m+ + -.-++%+- 262 | . ++###.%.-- . . *m+##%%. .-%-#- . ...#... 263 | ..%*+m . + m+####%.. .-+%#+- .-#-- 264 | -.#mm.. --.- +%#-m#%% ...%+##%+ .+..\- 265 | .+mm%+ .. ..m-m.+%%+m**+.. --.##%m--. + #-. 266 | .--%%. . m .#++ %-- +mm-. ...m##m-.+ -+*-- 267 | +-#+- . .##+.. +..m .m-#%#%-- -.##-. 268 | .%.**+. ...m#%..- .. ...# m . +-%#.%+ . %#%..+ 269 | -+##%.+.. #-. -. .m+..m -#%mm .--**++ 270 | .-%.*m+-...mm+ . .+ +- -m-+. ..*#.. . 271 | .-+*m#%m**++-+ .. -##.%%.- - ..##+-. 272 | - +-*%##%+mm--+ . .#m-m- - -+.m.##-+. 273 | .. m*##*#*%-m+- - . . .m.+.m .. m%+.*-% - 274 | ...+##m%####m-+m- -. .. ..- ++.. . +.. +%-###m-%. 275 | ..%#-%#++%####.+.m-+. . +m#+#+%.. . -#*###m.-- 276 | . %-mm ++-mm+**##%mm. - .+mm#+*.+--.#/##-+-+m . 277 | ..+.# - +-. m%m#m#*+.-..+##*###%m#%#% .--- - . . 278 | .-m#m. . . ..m+...#%m--+-*#+######.%+.. .+ 279 | ..m-#%. . ..- .+-- - .---.-**-+--... 280 | .+.#m#m- .. . . - -..- ..* 281 | . +-##-+. . -- . .. 282 | .+##m%+ 283 | .%.--- 284 | .. . 285 | ... 286 | 287 | http://en.wikipedia.org/wiki/Squatting 288 | http://github.com/beppu/squatting/tree/master 289 | 290 | -------------------------------------------------------------------------------- /doc/squatting-propaganda-for-catalyst.txt: -------------------------------------------------------------------------------- 1 | Squatting::On::Catalyst 2 | 3 | Squatting is a web microframework for Perl that's based on Camping from the 4 | Ruby world. During the transition from Ruby to Perl, Squatting gained some 5 | mutant powers which is why I'm writing to you today. 6 | 7 | One of Squatting's mutant powers is its ability to embed itself into other 8 | frameworks (like Catalyst). You can take whole Squatting apps, and embed them 9 | into your existing web application with just a few lines of glue code. Allow 10 | me to demonstrate. 11 | 12 | 13 | STEP 1: Install Pod::Server from CPAN. 14 | 15 | $ sudo cpan Pod::Server 16 | 17 | 18 | 19 | STEP 2: Run Pod::Server so you can see what it looks like. 20 | 21 | $ squatting Pod::Server -p 8088 22 | 23 | or 24 | 25 | $ pod_server 26 | 27 | Then, visit http://localhost:8088/ and pay attention to the URLs as you 28 | click around. (This will be interesting when you see how the URLs of 29 | the whole site will be "relocated" later on in the demonstration.) 30 | 31 | 32 | 33 | STEP 3: Create a Catalyst application. 34 | 35 | $ catalyst.pl Propaganda 36 | 37 | 38 | 39 | STEP 4: Embed Pod::Server into the Catalyst application. 40 | 41 | $ cd Propaganda 42 | $ $EDITOR lib/Propaganda/Controller/Root.pm 43 | 44 | Then, add the following lines of code to an appropriate place in the 45 | controller. 46 | 47 | use Pod::Server ’On::Catalyst’; 48 | Pod::Server->init; 49 | Pod::Server->relocate(’/pod’); 50 | $Pod::Simple::HTML::Perldoc_URL_Prefix = ’/pod/’; 51 | sub pod : Local { Pod::Server->catalyze($_[1]) } 52 | 53 | 54 | 55 | STEP 5: Start up the Catalyst application. 56 | 57 | $ script/propaganda_server.pl 58 | 59 | Finally, visit http://localhost:3000/pod/ . If everything worked, you should 60 | see that Pod::Server has just been embedded into a Catalyst application. 61 | 62 | 63 | 64 | What Are The Implications of This? 65 | 66 | Right now, anyone who is developing a web app with Catalyst can install 67 | Pod::Server from CPAN and embed it directly into their web app. However, 68 | this is just the beginning. 69 | 70 | Imagine if you could install a blog, a wiki, a forum, or a store just as 71 | easily. 72 | 73 | Imagine adding major functionality to any Perl-based site with ~5 lines of 74 | code. 75 | 76 | Squatting makes modular web applications both possible and probable. 77 | 78 | http://search.cpan.org/dist/Squatting/ 79 | 80 | http://github.com/beppu/squatting/tree/master 81 | 82 | -------------------------------------------------------------------------------- /doc/squatting-propaganda-for-perlmonks.html: -------------------------------------------------------------------------------- 1 |

Squatting::On::Catalyst

2 | 3 |
4 | (This was originally posted to the 5 | Catalyst Mailing List. 6 | It's being reposted on PerlMonks for the benefit of the 7 | broader Perl community.) 8 |
9 | 10 |

Squatting is a web microframework for Perl that's based on 11 | Camping from the 12 | Ruby world. During the transition from Ruby to Perl, Squatting gained some 13 | mutant powers which is why I'm writing to you today. 14 |

15 | 16 |

One of Squatting's mutant powers is its ability to embed itself into other 17 | frameworks (like Catalyst). You can take whole Squatting apps, and embed them 18 | into your existing web application with just a few lines of glue code. Allow 19 | me to demonstrate. 20 |

21 | 22 | 23 | 24 | 25 |

STEP 1: Install Pod::Server from CPAN.

26 | 27 | 28 | $ sudo cpan Pod::Server 29 | 30 | 31 | 32 |

STEP 2: Run Pod::Server so you can see what it looks like.

33 | 34 | 35 | $ squatting Pod::Server -p 8088 36 | 37 | 38 | or 39 | 40 | 41 | $ pod_server 42 | 43 | 44 |

Then, visit http://localhost:8088/ 45 | and pay attention to the URLs as you 46 | click around. (This will be interesting when you see how the URLs of 47 | the whole site will be "relocated" later on in the demonstration.) 48 |

49 | 50 | 51 |

STEP 3: Create a Catalyst application.

52 | 53 | 54 | $ catalyst.pl Propaganda 55 | 56 | 57 | 58 |

STEP 4: Embed Pod::Server into the Catalyst application.

59 | 60 | 61 | $ cd Propaganda 62 | $ $EDITOR lib/Propaganda/Controller/Root.pm 63 | 64 | 65 |

Then, add the following lines of code to an appropriate place in the 66 | controller. 67 |

68 | 69 | 70 | use Pod::Server ’On::Catalyst’; 71 | Pod::Server->init; 72 | Pod::Server->relocate(’/pod’); 73 | $Pod::Simple::HTML::Perldoc_URL_Prefix = ’/pod/’; 74 | sub pod : Local { Pod::Server->catalyze($_[1]) } 75 | 76 | 77 | 78 | 79 |

STEP 5: Start up the Catalyst application.

80 | 81 | 82 | $ script/propaganda_server.pl 83 | 84 | 85 |

Finally, visit 86 | http://localhost:3000/pod/. 87 | If everything worked, you should 88 | see that Pod::Server has just been embedded into a Catalyst application. 89 |

90 | 91 | 92 |

What Are The Implications of This?

93 | 94 |

Right now, anyone who is developing a web app with Catalyst can install 95 | Pod::Server from CPAN and embed it directly into their web app. However, 96 | this is just the beginning. 97 |

98 | 99 |

Imagine if you could install a blog, a wiki, a forum, or a store just as 100 | easily. 101 |

102 | 103 |

Imagine adding major functionality to any Perl-based site with ~5 lines of 104 | code. 105 |

106 | 107 |

Squatting makes modular web applications both possible and probable. 108 |

109 | 110 |

http://search.cpan.org/dist/Squatting/

111 | 112 |

http://github.com/beppu/squatting/tree/master

113 | 114 | 115 | -------------------------------------------------------------------------------- /doc/squatting-tpf-grant-proposal.txt: -------------------------------------------------------------------------------- 1 | Name 2 | 3 | John Beppu 4 | 5 | Email 6 | 7 | john.beppu@gmail.com 8 | 9 | Project Title 10 | 11 | Squatting On Everything 12 | 13 | Synopsis 14 | 15 | Squatting is unique among web frameworks, because it has the ability to embed 16 | itself into other frameworks. This ability has been demonstrated with the 17 | Squatting::On::Catalyst module that shows that you can take a whole Squatting 18 | application and embed it directly into a Catalyst application. (To see an 19 | example of this, take a look at the Pod::Server documentation.) 20 | 21 | I'd like to expand Squatting's range by writing adapters for more frameworks 22 | and environments. 23 | 24 | Benefits to the Perl Community 25 | 26 | Imagine that you built a web application, and then imagine you wanted to add 27 | a blog, or a forum, or a picture gallery, or a store to your site. What's a 28 | Perl programmer to do? Web applications haven't historically been conducive 29 | to modular composition. 30 | 31 | However, Squatting can change all this for the better. Not only will 32 | Squatting let you embed whole web applications into your existing site, it'll 33 | even let you replace the layout of the Squatting application so that you can 34 | keep a common look and feel across the entire site. The best part is that 35 | you don't have to throw away all your old work and join the Squatting cult. 36 | You can keep all your old work and make Squatting adapt to you. 37 | 38 | Unfortunately, these hypothetical, embeddable, Squatting applications have 39 | yet to be written, but even before we get to that part, I'd like to make sure 40 | Squatting can be embedded in as many places as possible. 41 | 42 | This will lay the groundwork for a future where adding major functionality 43 | to your web site will be as easy installing a module from CPAN and adding 44 | a few lines of glue code to your existing application. 45 | 46 | Deliverables 47 | 48 | * Squatting::On::MP13 49 | * Squatting::On::MP19 50 | * Squatting::On::MP20 51 | * Squatting::On::HTTP::Engine 52 | * Squatting::On::Mojo 53 | * Squatting::On::Jifty 54 | 55 | Project Details 56 | 57 | This project is fairly straightforward. For each framework, I have to 58 | translate the HTTP request info from their world view into terms Squatting 59 | can understand. Then, after I let Squatting handle a request, I have to take 60 | the output and translate it back into terms that the original framework can 61 | understand. Most of the difficulty in this project comes from having to 62 | learn how the foreign framework handles HTTP requests and responses. 63 | 64 | Project Schedule 65 | 66 | 5 weeks to implement and test the modules mentioned above is my conservative 67 | estimate, and I can begin work immediately. 68 | 69 | Bio 70 | 71 | I am a programmer who has been using Perl for 10 years, now. However, for 72 | the last 2 years, I took a trip into the worlds of Ruby and JavaScript to see 73 | what they had to offer. I have recently returned to Perl, because I decided 74 | that it was time to implement the idea for a language learning site that my 75 | friend and I have been sitting on, and I believed that Perl (the language 76 | created by our favorite linguist/programmer) would be the most appropriate 77 | tool for the job. I wrote Squatting so that I could write the language 78 | learning site with it, but now Squatting seems to have taken on a life of its 79 | own. 80 | 81 | Amount Requested 82 | 83 | $1000.00 84 | 85 | -------------------------------------------------------------------------------- /edit: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | vim=${vim:-vim} 3 | case ${1:-base} in 4 | base) 5 | $vim -p bin/squatting lib/squatting.pl lib/Squatting.pm lib/Squatting/Controller.pm lib/Squatting/View.pm lib/Squatting/H.pm lib/Squatting/Mapper.pm 6 | ;; 7 | on) 8 | $vim -p lib/Squatting/On/*.pm 9 | ;; 10 | with) 11 | $vim -p lib/Squatting/With/AccessTrace.pm lib/Squatting/With/Log.pm 12 | ;; 13 | esac 14 | -------------------------------------------------------------------------------- /eg/Chat.pm: -------------------------------------------------------------------------------- 1 | package Chat; 2 | use Squatting; 3 | 4 | # This is a port of eg/chat-ajax-push.pl from the Continuity distribution. 5 | # We're using the exact same JavaScript, but we've switched the server side 6 | # with a Squatting implementation. Let's see if they can taste the difference. 7 | 8 | package Chat::Controllers; 9 | use selfvars; 10 | 11 | our @messages; 12 | our $got_message; 13 | 14 | our @C = ( 15 | 16 | C( 17 | Home => [ '/' ], 18 | get => sub { 19 | $self->render('home'); 20 | }, 21 | ), 22 | 23 | C( 24 | PushStream => [ '/pushstream/' ], 25 | get => sub { 26 | my $cr = $self->cr; 27 | my $w = Coro::Event->var(var => \$got_message, poll => 'w'); 28 | while (1) { 29 | print STDERR "**** GOT MESSAGE, SENDING ****\n"; 30 | my $log = join("
", @messages); 31 | $cr->print($log); 32 | $cr->next; 33 | print STDERR "**** Waiting for got_message indicator ****\n"; 34 | $w->next; 35 | } 36 | }, 37 | continuity => 1, 38 | ), 39 | 40 | C( 41 | SendMessage => [ '/sendmessage/' ], 42 | post => sub { 43 | my $input = $self->input; 44 | my $msg = $input->{message}; 45 | my $name = $input->{username}; 46 | if ($msg) { 47 | unshift @messages, "$name: $msg"; 48 | pop @messages if $#messages > 15; 49 | } 50 | $got_message = 1; 51 | "Got it!"; 52 | }, 53 | ), 54 | 55 | ); 56 | 57 | package Chat::Views; 58 | use selfvars; 59 | use HTML::AsSubs; 60 | 61 | our @V = ( 62 | V( 63 | 'html', 64 | home => sub { 65 | my ($v) = @args; 66 | html( 67 | head( 68 | title('Chat'), 69 | script({ src => 'jquery.js' }), 70 | script({ src => 'chat-ajax-push.js' }), 71 | ), 72 | body( 73 | form({ id=> 'f', method => 'get', action => R('SendMessage') }, 74 | div( 75 | input({ type => 'text', id => 'username', name => 'username', size => 10 }), 76 | input({ type => 'text', id => 'message', name => 'message', size => 50 }), 77 | input({ type => 'submit', id => 'sendbutton', name => 'sendbutton', value => 'Send', }), 78 | b({ id => 'status' }, "?") 79 | ), 80 | div({ id => 'log' }, '-- no messages yet --') 81 | ) 82 | ) 83 | )->as_HTML; 84 | } 85 | ) 86 | ); 87 | 88 | 1; 89 | -------------------------------------------------------------------------------- /eg/CouchWiki.pm: -------------------------------------------------------------------------------- 1 | package CouchWiki; 2 | use strict; 3 | use warnings; 4 | use Squatting; 5 | use Coro::AnyEvent; 6 | 7 | our %CONFIG = ( 8 | db => 'couchwiki' 9 | ); 10 | 11 | #_____________________________________________________________________________ 12 | package CouchWiki::Models; 13 | use strict; 14 | use warnings; 15 | use AnyEvent::CouchDB; 16 | use Text::Textile; 17 | use Clone 'clone'; 18 | 19 | # $db = db 20 | our $DB; 21 | our $DESIGN_PAGES = { 22 | _id => "_design/pages", 23 | language => "javascript", 24 | views => { 25 | recent => { 26 | map => "function(doc) { if (doc.type == 'Page') emit(doc.created_date, doc); }", 27 | }, 28 | }, 29 | }; 30 | sub db { 31 | $DB || do { 32 | $DB = couchdb($CouchWiki::CONFIG{db}); 33 | eval { $DB->info->recv; }; 34 | if ($@) { 35 | $DB->create->recv; 36 | $DB->save_doc($DESIGN_PAGES)->recv; 37 | } 38 | $DB; 39 | }; 40 | } 41 | 42 | # timestamp - I had no idea this would be 60x faster than: DateTime->now.""; 43 | sub timestamp { 44 | my ($sec,$min,$hour,$mday,$mon,$year) = gmtime; 45 | sprintf( 46 | '%d-%02d-%02dT%02d:%02d:%02d', 47 | $year+1900,$mon+1,$mday, 48 | $hour,$min,$sec 49 | ); 50 | } 51 | 52 | # $doc = page('WikiPageTitle'); 53 | # $doc = page('WikiPageTitle' => 'new text for page'); 54 | our $PAGE = { type => 'Page', raw => 'Edit me.', html => '
Edit me.
' }; 55 | our $TEXTILE = Text::Textile->new(disable_html => 1); 56 | sub page { 57 | my ($title, $text) = @_; 58 | my $db = db; 59 | my $doc; 60 | eval { $doc = $db->open_doc($title)->recv; }; 61 | if (!$doc) { 62 | $doc = clone($PAGE); 63 | $doc->{_id} = $title; 64 | } 65 | if ($text) { 66 | $doc->{raw} = $text; 67 | $doc->{html} = $TEXTILE->process($text); 68 | $doc->{created_date} = timestamp; 69 | $db->save_doc($doc)->recv; 70 | } 71 | return $doc; 72 | } 73 | 74 | # $pages = recent_changes(); 75 | sub recent_changes { 76 | my $db = db; 77 | my $results = $db->view('pages/recent', { descending => "true" })->recv; 78 | my @pages = map { $_->{value} } @{$results->{rows}}; 79 | return \@pages; 80 | } 81 | 82 | #_____________________________________________________________________________ 83 | package CouchWiki::Controllers; 84 | use strict; 85 | use warnings; 86 | use AnyEvent::CouchDB; 87 | 88 | *page = \&CouchWiki::Models::page; 89 | *recent_changes = \&CouchWiki::Models::recent_changes; 90 | 91 | our @C = ( 92 | 93 | C( 94 | Page => [ '/', '/(\w+)', '/(\w+).(edit)' ], 95 | get => sub { 96 | my ($self, $title, $edit) = @_; 97 | $title ||= 'Home'; 98 | $self->v->{page} = page($title); 99 | $self->v->{title} = $title; 100 | if ($edit) { 101 | $self->render('edit'); 102 | } else { 103 | $self->render('page'); 104 | } 105 | }, 106 | post => sub { 107 | my ($self, $title) = @_; 108 | page($title => $self->input->{text}); 109 | $self->redirect( R('Page', $title) ); 110 | } 111 | ), 112 | 113 | C( 114 | RecentChanges => [ '/@recent_changes' ], 115 | get => sub { 116 | my ($self) = @_; 117 | $self->v->{title} = "Recent Changes"; 118 | $self->v->{pages} = recent_changes(); 119 | $self->v->{no_edit} = 1; 120 | $self->render('recent_changes'); 121 | } 122 | ), 123 | 124 | ); 125 | 126 | #_____________________________________________________________________________ 127 | package CouchWiki::Views; 128 | use strict; 129 | use warnings; 130 | use HTML::AsSubs; 131 | 132 | sub span { HTML::AsSubs::_elem('span', @_) } 133 | sub thead { HTML::AsSubs::_elem('thead', @_) } 134 | sub tbody { HTML::AsSubs::_elem('tbody', @_) } 135 | sub x { map { HTML::Element->new('~literal', text => $_) } @_ } 136 | 137 | our @V = ( 138 | V('html', 139 | 140 | layout => sub { 141 | my ($self, $v, $content) = @_; 142 | html( 143 | head( 144 | title($v->{title}) 145 | ), 146 | body( 147 | div({ id => 'couchwiki' }, 148 | x($self->_menu($v)), 149 | x($content), 150 | ) 151 | ), 152 | )->as_HTML; 153 | }, 154 | 155 | _menu => sub { 156 | my ($self, $v) = @_; 157 | div( 158 | a({ href => R('RecentChanges') }, 'Recent Changes'), 159 | span(' | '), 160 | a({ href => R('Page', 'Home') }, 'Home'), 161 | do { 162 | unless ($v->{no_edit}) { 163 | ( 164 | span(' | '), 165 | a({ href => R('Page', $v->{title}, 'edit') }, 'Edit This Page'), 166 | ); 167 | } else { 168 | () 169 | } 170 | }, 171 | )->as_HTML; 172 | }, 173 | 174 | page => sub { 175 | my ($self, $v) = @_; 176 | div( 177 | div(x($v->{page}->{html})) 178 | )->as_HTML; 179 | }, 180 | 181 | edit => sub { 182 | my ($self, $v) = @_; 183 | div( 184 | form( 185 | { 186 | method => 'post', 187 | action => R('Page', $v->{page}->{_id}), 188 | }, 189 | textarea( 190 | { 191 | name => 'text', 192 | cols => '80', 193 | rows => '24', 194 | }, 195 | $v->{page}->{raw} 196 | ), 197 | div(input({ type => 'submit' })), 198 | ), 199 | )->as_HTML; 200 | }, 201 | 202 | recent_changes => sub { 203 | my ($self, $v) = @_; 204 | div( 205 | ul( 206 | map { 207 | li( 208 | a({ href => R('Page', $_->{_id}) }, $_->{_id}) 209 | ) 210 | } @{$v->{pages}} 211 | ) 212 | )->as_HTML; 213 | }, 214 | 215 | ) 216 | ); 217 | 218 | 1; 219 | -------------------------------------------------------------------------------- /eg/Counter.pm: -------------------------------------------------------------------------------- 1 | package Counter; 2 | use Squatting; 3 | 4 | package Counter::Controllers; 5 | use strict; 6 | use Tie::IxHash::FixedSize; 7 | use UUID::Random; 8 | use Data::Dump 'pp'; 9 | 10 | our @C = ( 11 | C( 12 | Home => [ '/' ], 13 | get => sub { 14 | my ($self) = @_; 15 | $self->redirect(R('Count')); 16 | }, 17 | ), 18 | 19 | C( 20 | Count => [ '/@count' ], 21 | get => sub { 22 | my ($self) = @_; 23 | my $cr = $self->cr; 24 | my $log = $self->log; 25 | 26 | my %p = ( 27 | i => 1 28 | ); 29 | my %callbacks; 30 | tie my %history, 'Tie::IxHash::FixedSize', {size => 10}; 31 | 32 | my $get_new_ci = sub { 33 | my $ci = -1; 34 | return sub { 35 | $ci++ if ($ci <= ($cr->param('ci') || $ci)); 36 | return $ci; 37 | } 38 | }->(); 39 | $history{$get_new_ci->()} = {%p}; 40 | sub gen_link { 41 | my ($text, $code) = @_; 42 | my $uuid = UUID::Random::generate; 43 | $callbacks{$uuid} = $code; 44 | return qq|$text|; 45 | } 46 | sub process_links { 47 | my $cr = shift; 48 | my $cb = $cr->param('cb'); 49 | my $ci = ($cr->param('ci') || 0); 50 | $log->debug($ci); 51 | if(defined $cb) { 52 | if (exists $callbacks{$cb} 53 | && ref($callbacks{$cb}) eq "CODE") { 54 | $callbacks{$cb}->($cr); 55 | delete $callbacks{$cb}; 56 | $history{$ci} = {%p}; 57 | } elsif (exists $history{$ci}) { 58 | %p = %{$history{$ci}}; 59 | } 60 | } 61 | } 62 | 63 | while (1) { 64 | process_links($cr); 65 | $cr->print(gen_link('next' => sub { 66 | $p{i}++; 67 | })); 68 | $cr->print("
"); 69 | $cr->print(gen_link('prev' => sub { $p{i}-- })); 70 | $cr->print("
"); 71 | $cr->print($p{i}); 72 | $cr->print("
"); 73 | $cr->next; 74 | } 75 | }, 76 | continuity => 1, 77 | ) 78 | ); 79 | 80 | 1; 81 | -------------------------------------------------------------------------------- /eg/Example.pm: -------------------------------------------------------------------------------- 1 | package Example; 2 | use Squatting; 3 | use Example::Controllers; 4 | use Example::Views; 5 | 6 | use PODServer; 7 | $Pod::Simple::HTML::Perldoc_URL_Prefix = '/pod/'; 8 | Example->mount('PODServer', '/pod'); 9 | 10 | 1; 11 | -------------------------------------------------------------------------------- /eg/Example/Controllers.pm: -------------------------------------------------------------------------------- 1 | package Example::Controllers; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Data::Dump qw(dump); 7 | 8 | sub add { my $sum = 0; $sum += $_ for(@_); $sum } 9 | 10 | our @C = ( 11 | 12 | C( 13 | Home => [ '/' ], 14 | get => sub { 15 | my ($self) = @_; 16 | my $v = $self->v; 17 | my $input = $self->input; 18 | $v->{life} = 'good'; 19 | $v->{bavl} = 'realized'; 20 | $v->{input} = $input; 21 | if (%$input) { 22 | $v->{sum} = add(values %$input); 23 | } 24 | $self->log->debug('home sweet home'); 25 | $self->render('home') 26 | } 27 | ), 28 | 29 | C( 30 | Profile => [ '/~(\w+)\.?(\w+)?' ], 31 | get => sub { 32 | my ($self, $name, $format) = @_; 33 | $format ||= 'html'; 34 | $self->log->info("format is $format"); 35 | my $v = $self->v; 36 | $v->{name} = $name; 37 | $v->{controller} = $self->name; 38 | $v->{description} = "$name is hoping for the best."; 39 | $v->{_secret_from_json} = 40 | 'The JSON view will purposely omit this data, '. 41 | 'because the $V{json}->profile template was written to '. 42 | 'ignore the key, _secret_from_json.'; 43 | $self->render('profile', $format) 44 | # This will use the _specific_ json template called 'profile' 45 | # if ($format eq 'json'). 46 | } 47 | ), 48 | 49 | # This controller shows you how $self->cookies handles 50 | # both incoming AND outgoing cookies. 51 | # - incoming cookies are stored in the $self->cookies hashref as strings 52 | # - outgoing cookies are stored in the $self->cookies hashref as hashrefs 53 | # that can be fed to CGI::Cookie 54 | C( 55 | Cookie => [ '/cookies' ], 56 | get => sub { 57 | my ($self) = @_; 58 | $self->v->{cookies} = [ 59 | map { 60 | { 61 | name => $_, 62 | value => $self->cookies->{$_}, 63 | } 64 | } sort keys %{$self->cookies} 65 | ]; 66 | $self->render('cookies'); 67 | }, 68 | post => sub { 69 | my ($self) = @_; 70 | my $input = $self->input; 71 | my $name = $input->{name}; 72 | my $value = $input->{value}; 73 | $self->cookies->{$name} = { -value => $value }; 74 | $self->redirect(R('Cookie')); 75 | }, 76 | ), 77 | 78 | C( 79 | Count => [ '/@count' ], 80 | # Requests to the Count controller run in a separate coroutine. 81 | # - The (continuity => 1) tells Squatting::Mapper to take notice 82 | # of this controller and put requests to this controller in 83 | # a different "session queue". In Continuity-speak, being in 84 | # a different "session queue" means you get your own coroutine. 85 | continuity => 1, 86 | 87 | get => sub { 88 | my ($self) = @_; 89 | my $cr = $self->cr; 90 | my $i = 1; 91 | # Infinite loops are allowed in Continuity controllers. 92 | while (1) { 93 | # - Typically, you won't ever return control back to Squatting. 94 | # - You're in Continuity land, now. 95 | $cr->print($i++); 96 | # $cr->next blocks until the next request comes in. 97 | $cr->next; 98 | } 99 | }, 100 | ), 101 | 102 | C( 103 | RubyGems => [ '/rubygems' ], 104 | get => sub { 105 | my ($self) = @_; 106 | $self->redirect('http://localhost:8808/'); 107 | } 108 | ), 109 | 110 | C( 111 | Env => [ '/env', '/env.json' ], 112 | get => sub { 113 | my ($self) = @_; 114 | my $v = $self->v = $self->env; 115 | my $format = ($v->{REQUEST_PATH} eq '/env') 116 | ? 'html' 117 | : 'json'; 118 | $self->render('env', $format); 119 | # This will use the generic json template called '_' 120 | # if ($format eq 'json'). 121 | # The generic template, '_', is used 122 | # when no other template can be found. 123 | } 124 | ), 125 | 126 | ); 127 | 128 | 129 | 1; 130 | -------------------------------------------------------------------------------- /eg/Example/Views.pm: -------------------------------------------------------------------------------- 1 | package Example::Views; 2 | 3 | use strict; 4 | use warnings; 5 | # Long before Markaby or HAML, there was CGI.pm. 6 | use CGI ':standard'; # CGI.pm => DSLs since before they were cool. ;-) 7 | use JSON::XS; 8 | use Data::Dump 'dump'; 9 | 10 | our %V; 11 | our @V = ( 12 | 13 | V( 14 | 'html', 15 | layout => sub { 16 | my ($self, $v, @body) = @_; 17 | join "", start_html('Example'), 18 | div({-id => 'header'}, 19 | h1('Example'), 20 | ul({-id => 'menu'}, 21 | li(a({-href => '/'}, "home")), 22 | li(a({-href => '/?foo=1&bar=2&baz=5'}, "home + cgi")), 23 | li(a({-href => '/@count'}, "count"), span('[RESTless] [Reload the page to watch the counter increment]')), 24 | li(a({-href => '/~beppu'}, "profile")), 25 | li(a({-href => '/~beppu.json'}, "profile.json")), 26 | li(a({-href => '/env'}, "env")), 27 | li(a({-href => '/env.json'}, "env.json")), 28 | li(a({-href => '/cookies'}, "cookies")), 29 | li(a({-href => '/rubygems'}, "redirect to ruby's gem_server on port 8808")), 30 | li(a({-href => '/pod/'}, "PODServer has been mounted on /pod")), 31 | li(a({-href => '/droids-you-are-looking-for'}, "404")), 32 | ), 33 | ), 34 | div({-id => 'content'}, @body), 35 | end_html; 36 | }, 37 | home => sub { 38 | my ($self, $v) = @_; 39 | h2("Home"), 40 | h3('$v -- Template Variables'), 41 | pre(encode_json($v)), 42 | h3('\%input -- CGI Variables'), 43 | pre(encode_json($v->{input})), 44 | p('This is an example Squatting application.') 45 | }, 46 | profile => sub { 47 | my ($self, $v) = @_; 48 | h2("Profile of $v->{name}"), 49 | p($v->{description}), 50 | h2("Special Hack"), 51 | p({-id => 'secret'}, $v->{_secret_from_json}); 52 | }, 53 | env => sub { 54 | my ($self, $v) = @_; 55 | h2("env"), 56 | pre(dump($v)); 57 | }, 58 | cookies => sub { 59 | my ($self, $v) = @_; 60 | h2("Cookies"), 61 | dl( 62 | map { 63 | dt($_->{name}), 64 | dd($_->{value}) 65 | } @{$v->{cookies}} 66 | ), 67 | start_form(-method => 'POST', -action => R('Cookie'), -enctype => &CGI::URL_ENCODED), 68 | dl( 69 | dt('Cookie Name'), 70 | dd(textfield(-name => 'name')), 71 | dt('Cookie Value'), 72 | dd(textfield(-name => 'value')), 73 | ), 74 | submit(), 75 | end_form(), 76 | }, 77 | ), 78 | 79 | V( 80 | 'json', 81 | profile => sub { 82 | my ($self, $v) = @_; 83 | delete $v->{_secret_from_json}; 84 | encode_json($v); 85 | }, 86 | _ => sub { 87 | my ($self, $v) = @_; 88 | encode_json($v); 89 | } 90 | ) 91 | 92 | ); 93 | 94 | 1; 95 | -------------------------------------------------------------------------------- /eg/Guess.pm: -------------------------------------------------------------------------------- 1 | package Guess; 2 | use Squatting; 3 | 4 | package Guess::Controllers; 5 | 6 | our @C = ( 7 | C( 8 | Home => [ '/' ], 9 | get => sub { 10 | my ($self) = @_; 11 | $self->redirect(R('Guess')); 12 | }, 13 | ), 14 | 15 | C( 16 | Guess => [ '/guess' ], 17 | get => sub { 18 | my ($self) = @_; 19 | 20 | my $cr = $self->cr; 21 | 22 | my $rand100 = sub { int(rand(100)) }; 23 | my $to_guess = $rand100->(); 24 | my $tries = 0; 25 | 26 | while(1) { 27 | my $n = $cr->param('n'); 28 | $cr->print(qq| 29 | 30 | 31 | 32 | 33 | |); 34 | $cr->print(qq| 35 | Guess a number from 0 to 100
36 | |. sub { 37 | if ($n) { 38 | return "The guess is invalid." if $n !~ /\d+/; 39 | return ($n<$to_guess) 40 | ? "The answer is higher." 41 | : ($n>$to_guess) 42 | ? "The answer is lower." 43 | : "You guessed it in $tries tries"; 44 | } 45 | }->() . qq| 46 |
47 | |. (($n!=$to_guess) 48 | ? (qq| 49 | 50 | 51 | |) 52 | : sub { 53 | $tries = 0; 54 | $to_guess = $rand100->(); 55 | return "start again" 56 | }->() 57 | ) . qq| 58 | 59 |
60 | |); 61 | $cr->print(qq| 62 | 63 | 64 | |); 65 | $cr->next; 66 | 67 | $tries++; 68 | } # while 69 | }, 70 | continuity => 1, 71 | ), 72 | 73 | ); 74 | 75 | 1; 76 | -------------------------------------------------------------------------------- /eg/HTTPAuth.pm: -------------------------------------------------------------------------------- 1 | package HTTPAuth; 2 | use Squatting; 3 | 4 | our %CONFIG = ( 5 | login => 'bob', 6 | password => 'freeman', 7 | ); 8 | 9 | sub service { 10 | my ($app, $c, @args) = @_; 11 | $c->headers->{'Content-Type'} = 'text/html; charset=utf-8'; 12 | $app->next::method($c, @args); 13 | } 14 | 15 | package HTTPAuth::Controllers; 16 | use strict; 17 | use warnings; 18 | use MIME::Base64; 19 | 20 | sub authorized { 21 | my $self = shift; 22 | return undef unless defined $self->env->{HTTP_AUTHORIZATION}; 23 | my $auth = $self->env->{HTTP_AUTHORIZATION}; 24 | $auth =~ s/Basic\s*//; 25 | my $login_pass = encode_base64("$CONFIG{login}:$CONFIG{password}", ''); 26 | if ($auth eq $login_pass) { 27 | return 1; 28 | } else { 29 | return 0; 30 | } 31 | } 32 | 33 | our @C = ( 34 | C( 35 | Home => [ '/' ], 36 | get => sub { 37 | my ($self) = @_; 38 | $self->render('home'); 39 | } 40 | ), 41 | C( 42 | Secret => [ '/secret' ], 43 | get => sub { 44 | my ($self) = @_; 45 | if (authorized($self)) { 46 | $self->render('secret'); 47 | } else { 48 | $self->status = 401; 49 | $self->headers->{'WWW-Authenticate'} = 'Basic realm="Secret"'; 50 | $self->render('unauthorized'); 51 | } 52 | } 53 | ), 54 | C( 55 | Himitsu => [ '/himitsu' ], 56 | get => sub { 57 | my ($self) = @_; 58 | if (authorized($self)) { 59 | $self->render('himitsu'); 60 | } else { 61 | $self->status = 401; 62 | $self->headers->{'WWW-Authenticate'} = 'Basic realm="Secret"'; 63 | $self->render('unauthorized'); 64 | } 65 | } 66 | ) 67 | ); 68 | 69 | package HTTPAuth::Views; 70 | use strict; 71 | use warnings; 72 | use HTML::AsSubs; 73 | 74 | sub span { HTML::AsSubs::_elem('span', @_) } 75 | sub x { map { HTML::Element->new('~literal', text => $_) } @_ } 76 | 77 | our @V = ( 78 | V( 79 | 'html', 80 | layout => sub { 81 | my ($self, $v, $content) = @_; 82 | html( 83 | head( 84 | title('HTTP Auth Demo') 85 | ), 86 | body( 87 | x($content) 88 | ) 89 | )->as_HTML; 90 | }, 91 | home => sub { 92 | my ($self, $v) = @_; 93 | div( 94 | h1("Which one would you like?"), 95 | ul( 96 | li(a({ href => R('Secret') }, 'Secret' )), 97 | li(a({ href => R('Himitsu') }, x('ひみつ') )), 98 | ), 99 | )->as_HTML; 100 | }, 101 | secret => sub { 102 | my ($self, $v) = @_; 103 | div( 104 | a({ href => R('Home') }, 'Return'), 105 | p("George W. Bush is the grandson of Aleister Crowley."), 106 | )->as_HTML; 107 | }, 108 | himitsu => sub { 109 | my ($self, $v) = @_; 110 | div( 111 | a({ href => R('Home') }, x('戻る')), 112 | p(x("自由になるため、仕事をやめた。")) 113 | )->as_HTML; 114 | }, 115 | unauthorized => sub { 116 | div( 117 | h1('Psst!'), 118 | small(qq[The login is "$CONFIG{login}" and the password is "$CONFIG{password}".]), 119 | )->as_HTML; 120 | }, 121 | ) 122 | ); 123 | 124 | 1; 125 | -------------------------------------------------------------------------------- /eg/MicroWiki.pm: -------------------------------------------------------------------------------- 1 | package MicroWiki; use Squatting; package MicroWiki::Controllers; 2 | use IO::All; @C = C( Page => ['/', '/(\w+)', 3 | '/(\w+).(edit)' ], get => sub { $_[1] ||= 'Home'; -f $_[1] || 'Edit' > 4 | io($_[1]); $x < io($_[1]); $_[0]->v->{page} = $_[1]; $_[0]->v->{text} = $x; 5 | $_[0]->render($_[2] && 'edit' || 'page') }, post => sub { $_[0]->input->{text} 6 | > io($_[1]); $_[0]->redirect(R('Page', $_[1])) }); package MicroWiki::Views; 7 | use Text::Textile 'textile'; our @V = (V(html, page => 8 | sub { 'edit'.textile($_[1]-> 9 | {text})},edit=>sub{sprintf('
'. 11 | '
',R('Page', $_[1]->{page}) ,$_[1]->{text})})); 1 12 | -------------------------------------------------------------------------------- /eg/PODServer.pm: -------------------------------------------------------------------------------- 1 | package PODServer; 2 | use Squatting; 3 | 4 | package PODServer::Controllers; 5 | use File::Basename; 6 | use File::Find; 7 | use Config; 8 | 9 | # skip files we've already seen 10 | my %already_seen; 11 | 12 | # figure out where all(?) our pod is located 13 | # (loosely based on zsh's _perl_basepods and _perl_modules) 14 | our %perl_basepods = map { 15 | my ($file, $path, $suffix) = fileparse($_, ".pod"); 16 | $already_seen{$_} = 1; 17 | ($file => $_); 18 | } glob "$Config{installprivlib}/pod/*.pod"; 19 | 20 | our %perl_modules; 21 | our @perl_modules; 22 | sub scan { 23 | for (@INC) { 24 | next if $_ eq "."; 25 | my $inc = $_; 26 | my $pm_or_pod = sub { 27 | my $m = $File::Find::name; 28 | next if -d $m; 29 | next unless /\.(pm|pod)$/; 30 | next if $already_seen{$m}; 31 | $already_seen{$m} = 1; 32 | $m =~ s/$inc//; 33 | $m =~ s/\.\w*$//; 34 | $m =~ s{^/}{}; 35 | $perl_modules{$m} = $File::Find::name; 36 | }; 37 | find({ wanted => $pm_or_pod, follow_fast => 1 }, $_); 38 | } 39 | my %h = map { $_ => 1 } ( keys %perl_modules, keys %perl_basepods ); 40 | @perl_modules = sort keys %h; 41 | } 42 | scan; 43 | %already_seen = (); 44 | 45 | # *.pod takes precedence over *.pm 46 | sub pod_for { 47 | for ($_[0]) { 48 | return $_ if /\.pod$/; 49 | my $pod = $_; 50 | $pod =~ s/\.pm$/\.pod/; 51 | if (-e $pod) { 52 | return $pod; 53 | } 54 | return $_; 55 | } 56 | } 57 | 58 | our @C = ( 59 | 60 | C( 61 | Home => [ '/' ], 62 | get => sub { 63 | my ($self) = @_; 64 | $self->v->{title} = 'POD Server'; 65 | if ($self->input->{base}) { 66 | $self->v->{base} = 'pod'; 67 | } 68 | $self->render('home'); 69 | } 70 | ), 71 | 72 | C( 73 | Frames => [ '/@frames' ], 74 | get => sub { 75 | my ($self) = @_; 76 | $self->v->{title} = 'POD Server'; 77 | $self->render('_frames'); 78 | } 79 | ), 80 | 81 | # The job of this controller is to take $module 82 | # and find the file that contains the POD for it. 83 | # Then it asks the view to turn the POD into HTML. 84 | C( 85 | Pod => [ '/(.*)' ], 86 | get => sub { 87 | my ($self, $module) = @_; 88 | my $v = $self->v; 89 | my $pm = $module; $pm =~ s{/}{::}g; 90 | $v->{path} = [ split('/', $module) ]; 91 | $v->{module} = $module; 92 | if (exists $perl_modules{$module}) { 93 | $v->{pod_file} = pod_for $perl_modules{$module}; 94 | $v->{title} = "POD Server - $pm"; 95 | $self->render('pod'); 96 | } elsif (exists $perl_basepods{$module}) { 97 | $v->{pod_file} = pod_for $perl_basepods{$module}; 98 | $v->{title} = "POD Server - $pm"; 99 | $self->render('pod'); 100 | } else { 101 | $v->{title} = "POD Server - $v->{module}"; 102 | $self->render('pod_not_found'); 103 | } 104 | } 105 | ) 106 | ); 107 | 108 | package PODServer::Views; 109 | use Data::Dump 'pp'; 110 | use HTML::AsSubs; 111 | use Pod::Simple; 112 | use Pod::Simple::HTML; 113 | $Pod::Simple::HTML::Perldoc_URL_Prefix = '/'; 114 | 115 | # the ~literal pseudo-element -- don't entity escape this content 116 | sub x { 117 | HTML::Element->new('~literal', text => $_[0]) 118 | } 119 | 120 | our $JS; 121 | our $HOME; 122 | 123 | our @V = ( 124 | V( 125 | 'html', 126 | 127 | layout => sub { 128 | my ($self, $v, @content) = @_; 129 | html( 130 | head( 131 | title($v->{title}), 132 | style(x($self->_css)), 133 | ( 134 | $v->{base} 135 | ? base({ target => $v->{base} }) 136 | : () 137 | ), 138 | ), 139 | body( 140 | div({ id => 'menu' }, 141 | a({ href => R('Home')}, "Home"), ($self->_breadcrumbs($v)) 142 | ), 143 | div({ id => 'pod' }, @content), 144 | ), 145 | )->as_HTML; 146 | }, 147 | 148 | _breadcrumbs => sub { 149 | my ($self, $v) = @_; 150 | my @breadcrumb; 151 | my @path; 152 | for (@{$v->{path}}) { 153 | push @path, $_; 154 | push @breadcrumb, a({ href => R('Pod', join('/', @path)) }, " > $_ "); 155 | } 156 | @breadcrumb; 157 | }, 158 | 159 | _css => sub { 160 | qq| 161 | body { 162 | background: #112; 163 | color: wheat; 164 | font-family: 'Trebuchet MS', sans-serif; 165 | font-size: 10pt; 166 | } 167 | h1, h2, h3, h4 { 168 | margin-left: -1em; 169 | } 170 | pre { 171 | font-size: 9pt; 172 | background: #000; 173 | color: #ccd; 174 | } 175 | code { 176 | font-size: 9pt; 177 | font-weight: bold; 178 | color: #fff; 179 | } 180 | a { 181 | color: #fc4; 182 | text-decoration: none; 183 | } 184 | a:hover { 185 | color: #fe8; 186 | } 187 | div#menu { 188 | position: fixed; 189 | top: 0; 190 | left: 0; 191 | width: 100%; 192 | background: #000; 193 | color: #fff; 194 | opacity: 0.75; 195 | } 196 | ul#list { 197 | margin-left: -6em; 198 | list-style: none; 199 | } 200 | div#pod { 201 | width: 580px; 202 | margin: 2em 4em 2em 4em; 203 | } 204 | div#pod pre { 205 | padding: 0.5em; 206 | border: 1px solid #444; 207 | -moz-border-radius-bottomleft: 7px; 208 | -moz-border-radius-bottomright: 7px; 209 | -moz-border-radius-topleft: 7px; 210 | -moz-border-radius-topright: 7px; 211 | } 212 | div#pod h1 { 213 | font-size: 24pt; 214 | border-bottom: 2px solid #fe2; 215 | } 216 | div#pod p { 217 | line-height: 1.4em; 218 | } 219 | |; 220 | }, 221 | 222 | home => sub { 223 | $HOME ||= div( 224 | a({ href => R(Home), target => '_top' }, "no frames"), 225 | em(" | "), 226 | a({ href => R(Frames), target => '_top' }, "frames"), 227 | ul({ id => 'list' }, 228 | map { 229 | my $pm = $_; 230 | $pm =~ s{/}{::}g; 231 | li( 232 | a({ href => R('Pod', $_) }, $pm ) 233 | ) 234 | } (sort @perl_modules) 235 | ) 236 | ); 237 | }, 238 | 239 | _frames => sub { 240 | my ($self, $v) = @_; 241 | html( 242 | head( 243 | title($v->{title}) 244 | ), 245 | frameset({ cols => '*,340' }, 246 | frame({ name => 'pod', src => R('Pod', 'Squatting') }), 247 | frame({ name => 'list', src => R('Home', { base => 'pod' }) }), 248 | ), 249 | )->as_HTML; 250 | }, 251 | 252 | pod => sub { 253 | my ($self, $v) = @_; 254 | my $out; 255 | my $pod = Pod::Simple::HTML->new; 256 | $pod->index(1); 257 | $pod->output_string($out); 258 | $pod->parse_file($v->{pod_file}); 259 | $out =~ s{%3A%3A}{/}g; 260 | $out =~ s/^.*//s; 261 | $out =~ s/.*$//s; 262 | x($out), $self->_possibilities($v); 263 | }, 264 | 265 | pod_not_found => sub { 266 | my ($self, $v) = @_; 267 | div( 268 | p("POD for $v->{module} not found."), 269 | $self->_possibilities($v) 270 | ) 271 | }, 272 | 273 | _possibilities => sub { 274 | my ($self, $v) = @_; 275 | my @possibilities = grep { /^$v->{module}/ } @perl_modules; 276 | my $colon = sub { my $x = shift; $x =~ s{/}{::}g; $x }; 277 | hr, 278 | ul( 279 | map { 280 | li( 281 | a({ href => R('Pod', $_) }, $colon->($_)) 282 | ) 283 | } @possibilities 284 | ); 285 | } 286 | 287 | ) 288 | ); 289 | 290 | 1; 291 | -------------------------------------------------------------------------------- /eg/README: -------------------------------------------------------------------------------- 1 | ______________________________________________________________________________ 2 | squatting Example -p 4235 3 | 4 | http://localhost:4235/ 5 | 6 | This is the first example app I made. 7 | I tried to show a little bit of everything here. 8 | For sillyness points, I used CGI.pm's HTML generating functions 9 | as my templating system. 10 | 11 | ______________________________________________________________________________ 12 | squatting PODServer -p 4236 13 | 14 | http://localhost:4236/ 15 | 16 | requires: 17 | Pod::Simple 18 | HTML::AsSubs 19 | 20 | This will let you browse (almost) all the POD that's 21 | installed on your system. I wrote this before I was aware of 22 | Pod::Webserver which basically does the same thing. 23 | However, I may still make a separate dist out of this 24 | and put it on CPAN, because its output is pretty, and 25 | it has some nice little usability features. 26 | 27 | UPDATE: Pod::Server has been uploaded to CPAN. 28 | 29 | ______________________________________________________________________________ 30 | squatting UniCodePoints -p 4237 --config count=1024 31 | 32 | http://localhost:4237/ 33 | 34 | requires: 35 | HTML::AsSubs 36 | 37 | This is a simple utility for displaying unicode code points. 38 | You can configure the default number of codepoints to display per page 39 | by passing in --config count=XXX where XXX is a positive integer. 40 | 41 | ______________________________________________________________________________ 42 | squatting Chat -p 4238 43 | 44 | http://localhost:4238/ 45 | 46 | requires 47 | selfvars 48 | HTML::AsSubs 49 | Coro::Event 50 | 51 | This is a port of chat-ajax-push.pl from the Continuity examples. 52 | Open this app up in 2 or more different browsers and try chatting. 53 | 54 | ______________________________________________________________________________ 55 | squatting OpenID::Consumer -p 4239 56 | 57 | http://localhost:4239/ 58 | 59 | requires 60 | HTML::AsSubs 61 | Net::OpenID::Consumer 62 | LWPx::ParanoidAgent 63 | Cache::File 64 | 65 | This example currently shows the bare minimum you need to implement 66 | an OpenID login. It'll be improved as time goes on. 67 | 68 | ______________________________________________________________________________ 69 | squatting MicroWiki -p 4240 70 | 71 | http://localhost:4240/ 72 | 73 | requires 74 | Text::Textile 75 | IO::All 76 | 77 | metaperl from perlmonks.org wondered if a wiki could be implemented with 78 | Squatting in 20 lines or less. MicroWiki was my 17 line response. It has 79 | since been reduced to 11 lines. 80 | 81 | http://perlmonks.org/?node_id=704372 82 | 83 | If you find this unreadable, run it through perltidy. 84 | 85 | perltidy < MicroWiki.pm 86 | 87 | There's also a microwiki.psgi file that lets you run this wiki by typing: 88 | 89 | plackup microwiki.psgi 90 | 91 | ______________________________________________________________________________ 92 | squatting CouchWiki -p 4241 93 | 94 | http://localhost:4241/ 95 | 96 | requires 97 | Clone 98 | HTML::AsSubs 99 | Text::Textile 100 | AnyEvent::CouchDB 101 | 102 | I received an email from someone who wanted an example of how to use 103 | AnyEvent in combination with Squatting and Continuity, so I ended up 104 | creating CouchWiki. 105 | 106 | * It started out as an unobfuscated MicroWiki. 107 | * Then I switched to CouchDB for storage (instead of the filesystem). 108 | 109 | After you've created a few pages through the browser, try doing this 110 | in the shell: 111 | 112 | $ squatting CouchWiki -C 113 | > recent_changes 114 | > page('Home') 115 | 116 | ______________________________________________________________________________ 117 | squatting HTTPAuth -p 4242 118 | 119 | http://localhost:4242/ 120 | 121 | requires 122 | MIME::Base64 123 | HTML::AsSubs 124 | 125 | This example shows you how to implement HTTP Basic Auth in Squatting. 126 | http://en.wikipedia.org/wiki/Basic_access_authentication 127 | 128 | -------------------------------------------------------------------------------- /eg/UTF_8.pm: -------------------------------------------------------------------------------- 1 | package UTF_8; 2 | use Squatting; 3 | 4 | # == How to Run This App == 5 | # 6 | # squatting UTF_8 7 | # squatting UTF_8 -c view=raw 8 | # squatting UTF_8 -c view=as_subs 9 | # squatting UTF_8 -c view=crash 10 | # 11 | 12 | our %CONFIG = ( 13 | view => 'raw' # or 'as_subs' or 'crash' 14 | ); 15 | 16 | sub service { 17 | my ($app, $c, @args) = @_; 18 | $c->view = $CONFIG{view}; 19 | $app->next::method($c, @args); 20 | } 21 | 22 | package UTF_8::Controllers; 23 | use strict; 24 | use warnings; 25 | 26 | our @C = ( 27 | C( 28 | Home => [ '/' ], 29 | get => sub { 30 | my ($self) = @_; 31 | $self->render('home'); 32 | } 33 | ), 34 | ); 35 | 36 | 37 | package UTF_8::Views; 38 | use strict; 39 | use warnings; 40 | use Encode; 41 | use HTML::AsSubs; 42 | 43 | sub utf8 { 44 | join('', map { encode('utf8', $_) } @_); 45 | } 46 | 47 | sub x { map { HTML::Element->new('~literal', text => $_) } @_ } 48 | 49 | our @V = ( 50 | V( 51 | 'raw', 52 | layout => sub { 53 | my ($self, $v, $content) = @_; 54 | qq| 55 | 56 | 57 | 58 | 59 | UTF-8 Hacking 60 | 69 | 70 | $content 71 | 72 | |; 73 | }, 74 | home => sub { 75 | utf8("

\x{5225}\x{5e9c} \x{8061}

"); 76 | }, 77 | ), 78 | 79 | V( 80 | 'as_subs', 81 | layout => sub { 82 | my ($self, $v, $content) = @_; 83 | html( 84 | head( 85 | title('UTF-8 Hacking'), 86 | ), 87 | body( 88 | x($content) 89 | ) 90 | )->as_HTML; 91 | }, 92 | home => sub { 93 | my ($self, $v) = @_; 94 | h1("\x{5225}\x{5e9c} \x{8061}")->as_HTML; 95 | }, 96 | ), 97 | 98 | V( 99 | 'crash', 100 | home => sub { 101 | "\x{5225}\x{5e9c} \x{8061}" 102 | } 103 | ), 104 | 105 | ); 106 | 107 | 1; 108 | -------------------------------------------------------------------------------- /eg/UniCodePoints.pm: -------------------------------------------------------------------------------- 1 | package UniCodePoints; 2 | 3 | #warn 'export PERL_UNICODE=SD # before running this app' 4 | # unless $ENV{PERL_UNICODE} =~ /S/ && $ENV{PERL_UNICODE} =~ /D/; 5 | 6 | use Squatting; 7 | use strict; 8 | use warnings; 9 | 10 | # squatting UniCodePoints --show-config 11 | # squatting UniCodePoints --config count=256 -c bg='#112' -c fg='#ccc' 12 | our %CONFIG = ( 13 | count => 1024, 14 | bg => '#ffffff', 15 | fg => '#000000', 16 | a => '#44a', 17 | ah => '#ccf', 18 | ); 19 | 20 | package UniCodePoints::Controllers; 21 | our @C = ( 22 | C( 23 | Home => [ '/' ], 24 | get => sub { 25 | my ($self) = @_; 26 | my $input = $self->input; 27 | my $v = $self->v; 28 | my $start = $input->{start}; 29 | $start ||= 0; 30 | my $count = $input->{count} || $CONFIG{count}; 31 | $v->{chars} = [ map { chr($_) } ($start .. ($start + $count - 1)) ]; 32 | $v->{prev} = { count => $count, start => (($start - $count) < 0) ? 0 : $start - $count }; 33 | $v->{next} = { count => $count, start => $start + $count }; 34 | $self->render('home'); 35 | } 36 | ) 37 | ); 38 | 39 | package UniCodePoints::Views; 40 | use HTML::AsSubs; 41 | 42 | sub x { 43 | map { HTML::Element->new('~literal', text => $_) } @_; 44 | } 45 | 46 | my $C = \%UniCodePoints::CONFIG; 47 | our @V = ( 48 | V( 49 | 'html', 50 | 51 | layout => sub { 52 | my ($self, $v, @content) = @_; 53 | html( 54 | head( 55 | title("unicode codepoints"), 56 | style($self->_css), 57 | ), 58 | body( 59 | x(@content), 60 | ), 61 | )->as_HTML; 62 | }, 63 | 64 | _css => sub {qq| 65 | body { 66 | font-size: 10pt; 67 | background: $C->{bg}; 68 | color: $C->{fg}; 69 | } 70 | a { 71 | color: $C->{a}; 72 | text-decoration: none; 73 | } 74 | a:hover { 75 | color: $C->{ah}; 76 | } 77 | td { 78 | padding: 8px; 79 | width: 88px; 80 | font-family: monospace; 81 | } 82 | tr td:last-child { 83 | font-family: sans-serif; 84 | } 85 | |}, 86 | 87 | home => sub { 88 | my ($self, $v) = @_; 89 | div( 90 | x($self->_pager($v)), 91 | table( 92 | map { 93 | my $o = ord($_); 94 | &tr( 95 | td(sprintf('0x%04X', $o)), 96 | td(sprintf('&#x%04X;', $o)), 97 | td($_), 98 | ) 99 | } @{$v->{chars}} 100 | ), 101 | x($self->_pager($v)), 102 | )->as_HTML; 103 | }, 104 | 105 | _pager => sub { 106 | my ($self, $v) = @_; 107 | div( 108 | a({ href => R('Home', $v->{prev}) }, " R('Home', $v->{next}) }, "next>"), 111 | )->as_HTML; 112 | }, 113 | 114 | ), 115 | ); 116 | -------------------------------------------------------------------------------- /eg/chat-ajax-push.js: -------------------------------------------------------------------------------- 1 | 2 | // Using the magic of jquery, this is really easy. See jquery.com for details! 3 | 4 | // This is the long-pull (aka "Comet"). We start this request, and then if it 5 | // times out we start again. The server holds the connection open until there 6 | // is an update in the message queue. 7 | function poll_server() { 8 | $('#log').load( 9 | '/pushstream/', // URL to load 10 | function(){poll_server();} // What to do upon success (recurse!) 11 | ); 12 | } 13 | 14 | // We also send messages using AJAX 15 | function send_message() { 16 | var username = $('#username').val(); 17 | var message = $('#message').val(); 18 | $('#status').load('/sendmessage/', { 19 | username: username, 20 | message: message 21 | },function(){ 22 | $('#message').val(''); 23 | $('#message').focus(); 24 | }); 25 | return false; 26 | } 27 | 28 | // This stuff gets executed once the document is loaded 29 | $(function(){ 30 | // Start up the long-pull cycle 31 | poll_server(); 32 | // Unobtrusively make submitting a message use send_message() 33 | $('#f').submit(send_message); 34 | }); 35 | 36 | -------------------------------------------------------------------------------- /eg/microwiki.psgi: -------------------------------------------------------------------------------- 1 | use MicroWiki 'On::PSGI'; 2 | MicroWiki->init; 3 | 4 | my $app = sub { 5 | my $env = shift; 6 | MicroWiki->psgi($env); 7 | }; 8 | -------------------------------------------------------------------------------- /lib/Squatting.pm: -------------------------------------------------------------------------------- 1 | package Squatting; 2 | 3 | use strict; 4 | no strict 'refs'; 5 | use warnings; 6 | no warnings 'redefine'; 7 | use base 'Class::C3::Componentised'; 8 | 9 | use List::Util qw(first); 10 | use URI::Escape; 11 | use Carp; 12 | use Data::Dump 'pp'; 13 | 14 | our $VERSION = '0.82'; 15 | 16 | require Squatting::Controller; 17 | require Squatting::View; 18 | 19 | # XXX - deprecated | use App ':controllers' 20 | # XXX - deprecated | use App ':views' 21 | # use App @PLUGINS 22 | # 23 | # No longer have to : use base 'Squatting'; 24 | # Simply saying : use Squatting; 25 | # will muck with the calling packages @ISA. 26 | sub import { 27 | my $m = shift; 28 | my $p = (caller)[0]; 29 | 30 | if ($m ne 'Squatting') { 31 | return $m->load_components(grep /::/, @_); 32 | } 33 | 34 | push @{$p.'::ISA'}, 'Squatting'; 35 | 36 | # $url = R('Controller', @args, { cgi => vars }) # Generate URLs with the routing function 37 | *{$p."::Controllers::R"} = *{$p."::Views::R"} = *{$p."::R"} = sub { 38 | my ($controller, @args) = @_; 39 | my $input; 40 | if (@args && ref($args[-1]) eq 'HASH') { 41 | $input = pop(@args); 42 | } 43 | my $c = ${$p."::Controllers::C"}{$controller}; 44 | croak "$controller controller not found in '\%$p\::Controllers::C" unless $c; 45 | my $arity = @args; 46 | my $path = first { my @m = /\(.*?\)/g; $arity == @m } @{$c->urls}; 47 | croak "couldn't find a matching URL path" unless $path; 48 | while ($path =~ /\(.*?\)/) { 49 | $path =~ s{\(.*?\)}{uri_escape(+shift(@args), "^A-Za-z0-9\-_.!~*’()/")}e; 50 | } 51 | if ($input) { 52 | $path .= "?". join('&' => 53 | map { 54 | my $k = $_; 55 | ref($input->{$_}) eq 'ARRAY' 56 | ? map { "$k=".uri_escape($_) } @{$input->{$_}} 57 | : "$_=".uri_escape($input->{$_}) 58 | } keys %$input); 59 | } 60 | $path; 61 | }; 62 | 63 | # ($controller, \@regex_captures) = D($path) # Return controller and captures for a path 64 | *{$p."::D"} = sub { 65 | my $url = uri_unescape($_[0]); 66 | my $C = \@{$p.'::Controllers::C'}; 67 | my ($c, @regex_captures); 68 | for $c (@$C) { 69 | for (@{$c->urls}) { 70 | if (@regex_captures = ($url =~ qr{^$_$})) { 71 | pop @regex_captures if ($#+ == 0); 72 | return ($c, \@regex_captures); 73 | } 74 | } 75 | } 76 | ($Squatting::Controller::r404, []); 77 | }; 78 | 79 | *{$p."::Controllers::C"} = sub { 80 | Squatting::Controller->new(@_, app => $p) 81 | }; 82 | *{$p."::Views::V"} = sub { 83 | Squatting::View->new(@_) 84 | }; 85 | 86 | } 87 | 88 | # Squatting plugins may be anywhere in Squatting::*::* but by convention 89 | # (and for fun) you should use poetic diction in your package names. 90 | # 91 | # Squatting::On::Continuity 92 | # Squatting::On::Catalyst 93 | # Squatting::On::CGI 94 | # Squatting::On::Jifty 95 | # 96 | # (ALL YOUR FRAMEWORK ARE BELONG TO US) 97 | # 98 | # Squatting::With::Impunity (What could we do w/ this name?) 99 | # Squatting::With::Log4Perl (which is how we could add logging support) 100 | # 101 | # (etc) 102 | sub component_base_class { __PACKAGE__ } 103 | 104 | # 1 105 | # App->mount($AnotherApp, $prefix) # Map another app on to a URL $prefix. 106 | sub mount { 107 | my ($app, $other, $prefix) = @_; 108 | push @{$app."::O"}, $other; 109 | push @{$app."::Controllers::C"}, map { 110 | my $urls = $_->urls; 111 | $_->urls = [ map { $prefix.$_ } @$urls ]; 112 | $_; 113 | } @{$other."::Controllers::C"} 114 | } 115 | 116 | # 2 117 | # App->relocate($prefix) # Map main app to a URL $prefix 118 | sub relocate { 119 | my ($app, $prefix) = @_; 120 | for (@{$app."::Controllers::C"}) { 121 | my $urls = $_->urls; 122 | $_->urls = [ map { $prefix.$_ } @$urls ]; 123 | } 124 | ${$app."::CONFIG"}{relocated} = $prefix; 125 | } 126 | 127 | # 3 128 | # App->init # Initialize $app 129 | sub init { 130 | $_->init for (@{$_[0]."::O"}); 131 | %{$_[0]."::Controllers::C"} = map { $_->name => $_ } @{$_[0]."::Controllers::C"}; 132 | %{$_[0]."::Views::V"} = map { $_->name => $_ } @{$_[0]."::Views::V"}; 133 | } 134 | 135 | # App->service($controller, @args) # Handle an HTTP request 136 | sub service { 137 | my ($app, $c, @args) = grep { defined } @_; 138 | my $method = lc $c->env->{REQUEST_METHOD}; 139 | my $content; 140 | 141 | eval { $content = $c->$method(@args) }; 142 | die $@ if (ref($@) =~ /^HTTP::Exception/); # Pass HTTP::Exceptions on up 143 | warn "EXCEPTION: $@" if ($@); 144 | 145 | my $cookies = $c->cookies; 146 | $c->headers->{'Set-Cookie'} = join("; ", 147 | map { CGI::Cookie->new( -name => $_, %{$cookies->{$_}} ) } 148 | grep { ref $cookies->{$_} eq 'HASH' } 149 | keys %$cookies) if (%$cookies); 150 | 151 | $content; 152 | } 153 | 154 | 1; 155 | 156 | =head1 NAME 157 | 158 | Squatting - A Camping-inspired Web Microframework for Perl 159 | 160 | =head1 SYNOPSIS 161 | 162 | Running an App: 163 | 164 | $ squatting App 165 | Please contact me at: http://localhost:4234/ 166 | 167 | Check out our ASCII art logo: 168 | 169 | $ squatting --logo 170 | 171 | What a basic App looks like: 172 | 173 | # STEP 1 => Use Squatting for your App 174 | { 175 | package App; # <-- I hope it's obvious that this name can whatever you want. 176 | use Squatting; 177 | our %CONFIG; # <-- standard app config goes here 178 | } 179 | 180 | # STEP 2 => Define the App's Controllers 181 | { 182 | package App::Controllers; 183 | 184 | # Setup a list of controller objects in @C using the C() function. 185 | our @C = ( 186 | C( 187 | Home => [ '/' ], 188 | get => sub { 189 | my ($self) = @_; 190 | my $v = $self->v; 191 | $v->{title} = 'A Simple Squatting Application'; 192 | $v->{message} = 'Hello, World!'; 193 | $self->render('home'); 194 | }, 195 | post => sub { } 196 | ), 197 | ); 198 | } 199 | 200 | # STEP 3 => Define the App's Views 201 | { 202 | package App::Views; 203 | 204 | # Setup a list of view objects in @V using the V() function. 205 | our @V = ( 206 | V( 207 | 'html', 208 | layout => sub { 209 | my ($self, $v, $content) = @_; 210 | "$v->{title}". 211 | "$content"; 212 | }, 213 | home => sub { 214 | my ($self, $v) = @_; 215 | "

$v->{message}

" 216 | }, 217 | ), 218 | ); 219 | } 220 | 221 | # Models? 222 | # - The whole world is your model. ;-) 223 | # - I have no interest in defining policy here. 224 | # - Use whatever works for you. 225 | 226 | =head1 DESCRIPTION 227 | 228 | Squatting is a web microframework based on Camping. 229 | It originally used L as its foundation, 230 | but it has since been generalized such that it can 231 | squat on top of any Perl-based web framework (in theory). 232 | 233 | =head2 What does this mean? 234 | 235 | =over 4 236 | 237 | =item B 238 | 239 | _why did a really good job designing Camping's API so that you could get the 240 | B done with the B amount of code possible. I loved Camping's API 241 | so much that I ported it to Perl. 242 | 243 | =item B 244 | 245 | The core of Squatting (which includes Squatting, Squatting::Controller, and 246 | Squatting::View) can be squished into less than 4K of obfuscated perl. Also, 247 | the number of Perl module dependencies has been kept down to a minimum. 248 | 249 | =item B 250 | 251 | Controllers are objects (not classes) that are made to look like HTTP 252 | resources. Thus, they respond to methods like get(), post(), put(), and 253 | delete(). 254 | 255 | =item B 256 | 257 | Stateful continuation-based code can be surprisingly useful (especially for 258 | COMET), so we try to make RESTless controllers easy to express as well. (B<*>) 259 | 260 | =item B 261 | 262 | Views are also objects (not classes) whose methods represent templates to be 263 | rendered. An app can also have more than one view. Changing a Squatting app's 264 | look and feel can be as simple as swapping out one view object for another. 265 | 266 | =item B 267 | 268 | You can take multiple Squatting apps and compose them into a single app. For 269 | example, suppose you built a site and decided that you'd like to add a forum. 270 | You could take a hypothetical forum app written in Squatting and just mount 271 | it at an arbitrary path like /forum. 272 | 273 | =item B 274 | 275 | Already using another framework? No problem. You should be able to embed 276 | Squatting apps into apps written in anything from CGI on up to Catalyst. 277 | B 278 | 279 | =item B 280 | 281 | You may use any templating system you want, and you may use any ORM you 282 | want. We only have a few rules on how the controller code and the view code 283 | should be organized, but beyond that, you are free as you want to be. 284 | 285 | =back 286 | 287 | B<*> RESTless controllers currently only work when you're L. 288 | 289 | =head1 API 290 | 291 | =head2 Use as a Base Class for Squatting Applications 292 | 293 | package App; 294 | use Squatting; 295 | our %CONFIG = (); 296 | 1; 297 | 298 | Just Cing Squatting makes a lot of magic happen. In the example above: 299 | 300 | =over 4 301 | 302 | =item App becomes a subclass of Squatting. 303 | 304 | =item App::Controllers is given this app's R() and C() functions. 305 | 306 | =item App::Views is given this app's R() and V() functions. 307 | 308 | =back 309 | 310 | =head3 App->service($controller, @args) 311 | 312 | Every time an HTTP request comes in, this method is called with a controller 313 | object and a list of arguments. The controller will then be invoked with the 314 | HTTP method that was requested (like GET or POST), and it will return the 315 | content of the response as a string. 316 | 317 | B: If you want to do anything before, after, or around an HTTP request, 318 | this is the method you should override in your subclass. 319 | 320 | =head3 App->init 321 | 322 | This method takes no parameters and initializes some internal variables. 323 | 324 | B: You can override this method if you want to do more things when 325 | the App is initialized. 326 | 327 | =head3 App->mount($AnotherApp => $prefix) 328 | 329 | XXX - The C has been moved out of the core and into 330 | L. Furthermore, Squatting::With::Mount has 331 | been implemented using L. 332 | 333 | This method will mount another Squatting app at the specified prefix. 334 | 335 | App->mount('My::Blog' => '/my/ridiculous/rantings'); 336 | App->mount('Forum' => '/forum'); 337 | App->mount('ChatterBox' => '/chat'); 338 | 339 | B: You can only mount an app once. Don't try to mount it again 340 | at some other prefix, because it won't work. This is a consequence 341 | of storing so much information in package variables and a strong argument 342 | for going all objects all the time. 343 | 344 | =head3 App->relocate($prefix) 345 | 346 | This method will relocate a Squatting app to the specified prefix. It's useful 347 | for embedding a Squatting app into apps written in other frameworks. 348 | 349 | This also has a side-effect of setting C<$CONFIG{relocated}> to C<$prefix>. 350 | 351 | =head2 Use as a Helper for Controllers 352 | 353 | In this package, you will define a list of L objects in C<@C>. 354 | 355 | package App::Controllers; 356 | use Squatting ':controllers'; 357 | our @C = ( 358 | C(...), 359 | C(...), 360 | C(...), 361 | ); 362 | 363 | =head3 C($name => \@urls, %methods) 364 | 365 | This is a shortcut for: 366 | 367 | Squatting::Controller->new( 368 | $name => \@urls, 369 | app => $App, 370 | %methods 371 | ); 372 | 373 | =head3 R($name, @args, [ \%params ]) 374 | 375 | R() is a URL generation function that takes a controller name and a list of 376 | arguments. You may also pass in a hashref representing CGI variables as the 377 | very last parameter to this function. 378 | 379 | B: Given the following controllers, R() would respond like this. 380 | 381 | # Example Controllers 382 | C(Home => [ '/' ]); 383 | C(Profile => [ '/~(\w+)', '/~(\w+)\.(\w+)' ]); 384 | 385 | # Generated URLs 386 | R('Home') # "/" 387 | R('Home', { foo => 1, bar => 2}) # "/?foo=1&bar=2" 388 | R('Profile', 'larry') # "/~larry" 389 | R('Profile', 'larry', 'json') # "/~larry.json" 390 | 391 | As you can see, C<@args> represents the regexp captures, and C<\%params> 392 | represents the CGI query parameters. 393 | 394 | =head2 Use as a Helper for Views 395 | 396 | In this package, you will define a list of L objects in C<@V>. 397 | 398 | package App::Views; 399 | use Squatting ':views'; 400 | our @V = ( 401 | V( 402 | 'html', 403 | home => sub { "

Home

" }, 404 | ), 405 | ); 406 | 407 | =head3 V($name, %methods) 408 | 409 | This is a shortcut for: 410 | 411 | Squatting::View->new($name, %methods); 412 | 413 | =head3 R($name, @args, [ \%params ]) 414 | 415 | This is the same R() function that the controllers get access to. 416 | Please use it to generate URLs so that your apps may be composable 417 | and embeddable. 418 | 419 | =head1 SEE ALSO 420 | 421 | =over 4 422 | 423 | =item B: 424 | 425 | L, L, 426 | L, L, 427 | L, L, L, 428 | L, L, 429 | L, L, 430 | L 431 | 432 | L, 433 | L, 434 | L 435 | 436 | =item B: 437 | 438 | L 439 | 440 | =item B: 441 | 442 | L - a nice way to browse through the POD for your locally 443 | installed perl modules. 444 | 445 | L - a simple COMET server. (DEPRECATED. Use Web::Hippie or Plack::Middleware::SocketIO instead.) 446 | 447 | L - a simple CPAN-friendly blogging system for Perl. 448 | 449 | =back 450 | 451 | =head2 Google Group: squatting-framework 452 | 453 | A Google Group has been setup so that people can discuss Squatting. 454 | If you have questions about the framework, this is the place to ask. 455 | 456 | L 457 | 458 | =head2 Squatting Source Code 459 | 460 | The source code is short and it has some useful comments in it, so this might 461 | be all you need to get going. There are also some examples in the F 462 | directory. 463 | 464 | L 465 | 466 | =head2 Bavl Source Code 467 | 468 | We're going to throw Squatting (and Continuity) into the metaphorical deep end 469 | by using it to implement the L. It's a site that 470 | will help people learn foreign languages by letting you hear the phrases you're 471 | interested in learning as actually spoken by fluent speakers. If you're 472 | looking for an example of how to use Squatting for an ambitious project, look 473 | at the Bavl code. 474 | 475 | L 476 | 477 | =head2 Continuity and Coro 478 | 479 | When you want to start dabbling with RESTless controllers, it would serve you 480 | well to understand how Continuity, Coro and Event work. To learn more, I 481 | recommend reading the POD for the following Perl modules: 482 | 483 | L, 484 | L, 485 | L. 486 | 487 | Combining coroutines with an event loop is a surprisingly powerful technique. 488 | 489 | =head2 Camping 490 | 491 | Squatting is descended from Camping, so studying the Camping API 492 | will indirectly teach you much of the Squatting API. 493 | 494 | L 495 | 496 | =head2 Prototype-based OO 497 | 498 | There were a lot of obscure Ruby idioms in Camping that were damn near 499 | impossible to directly translate into Perl. I got around this by resorting to 500 | techniques that are reminiscent of prototype-based OO. (That's why controllers 501 | and views are objects instead of classes.) 502 | 503 | =head3 Prototypes == Grand Unified Theory of Objects 504 | 505 | I've been coding a lot of JavaScript these days, and it has definitely 506 | influenced my programming style. I've come to love the simplicity of 507 | prototype-based OO, and I think it's a damned shame that they're introducing 508 | concepts like 'class' in the next version of JavaScript. It's like they missed 509 | the point of prototype-based OO. 510 | 511 | If you're going to add anything to JavaScript, make the prototype side of it 512 | stronger. Look to languages like Io, and make it easier to clone objects and 513 | manipulate an object's prototype chain. The beauty of prototypes is that you 514 | can combine it with slot-based objects to unify the functionality of objects, 515 | classes, and namespaces into a surprisingly simple and coherent system. Look 516 | at Io if you don't believe me. 517 | 518 | L 519 | 520 | =head1 AUTHOR 521 | 522 | John BEPPU Ebeppu@cpan.orgE 523 | 524 | Scott WALTERS (aka scrottie) gets credit for the name of this module. 525 | 526 | =head1 COPYRIGHT 527 | 528 | Copyright (c) 2008-9 John BEPPU Ebeppu@cpan.orgE. 529 | 530 | =head2 The "MIT" License 531 | 532 | Permission is hereby granted, free of charge, to any person 533 | obtaining a copy of this software and associated documentation 534 | files (the "Software"), to deal in the Software without 535 | restriction, including without limitation the rights to use, 536 | copy, modify, merge, publish, distribute, sublicense, and/or sell 537 | copies of the Software, and to permit persons to whom the 538 | Software is furnished to do so, subject to the following 539 | conditions: 540 | 541 | The above copyright notice and this permission notice shall be 542 | included in all copies or substantial portions of the Software. 543 | 544 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 545 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 546 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 547 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 548 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 549 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 550 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 551 | OTHER DEALINGS IN THE SOFTWARE. 552 | 553 | =cut 554 | 555 | # Local Variables: *** 556 | # mode: cperl *** 557 | # indent-tabs-mode: nil *** 558 | # cperl-close-paren-offset: -2 *** 559 | # cperl-continued-statement-offset: 2 *** 560 | # cperl-indent-level: 2 *** 561 | # cperl-indent-parens-as-block: t *** 562 | # cperl-tab-always-indent: nil *** 563 | # End: *** 564 | # vim:tabstop=8 softtabstop=2 shiftwidth=2 shiftround expandtab 565 | -------------------------------------------------------------------------------- /lib/Squatting/Controller.pm: -------------------------------------------------------------------------------- 1 | package Squatting::Controller; 2 | 3 | use strict; 4 | no strict 'refs'; 5 | use warnings; 6 | no warnings 'redefine'; 7 | 8 | # constructor 9 | sub new { 10 | bless { name => $_[1], urls => $_[2], @_[3..$#_] } => $_[0]; 11 | } 12 | 13 | # (shallow) copy constructor 14 | sub clone { 15 | bless { %{$_[0]}, @_[1..$#_] } => ref($_[0]); 16 | } 17 | 18 | # name - name of controller 19 | # urls - arrayref of URL patterns that this controller responds to 20 | # cr - Continuity::Request object 21 | # env - incoming request headers and misc info like %ENV in the CGI days 22 | # input - incoming CGI variables 23 | # cookies - incoming *AND* outgoing cookies 24 | # state - your session data 25 | # v - outgoing vars 26 | # status - outgoing HTTP Response status 27 | # headers - outgoing HTTP headers 28 | # view - name of default view 29 | # log - logging object 30 | # app - name of our app 31 | for my $m (qw/name urls cr env input cookies state v status headers log view app/) { 32 | *{$m} = sub : lvalue { $_[0]->{$m} } 33 | } 34 | 35 | # HTTP methods 36 | for my $m (qw/get post head put delete options trace connect/) { 37 | *{$m} = sub { $_[0]->{$m}->(@_) } 38 | } 39 | 40 | # For (sufficient) compatibility w/ the ubiquitous API that CGI.pm introduced 41 | sub param { 42 | my ($self, $k, @v) = @_; 43 | if (defined $k) { 44 | if (@v) { 45 | $self->input->{$k} = ((@v > 1) ? \@v : $v[0]); 46 | } else { 47 | $self->input->{$k}; 48 | } 49 | } else { 50 | keys %{$self->input}; 51 | } 52 | } 53 | 54 | # $content = $self->render($template, $view) 55 | sub render { 56 | my ($self, $template, $vn) = @_; 57 | my $view; 58 | $vn ||= $self->view; 59 | my $app = $self->app; 60 | if (defined($vn)) { 61 | $view = ${$app."::Views::V"}{$vn}; # hash 62 | } else { # vs 63 | $view = ${$app."::Views::V"}[0]; # array -- Perl provides a lot of 'namespaces' so why not use them? 64 | } 65 | $view->headers = $self->headers; 66 | $view->$template($self->v); 67 | } 68 | 69 | # $self->redirect($url, $status_code) 70 | sub redirect { 71 | my ($self, $l, $s) = @_; 72 | $self->headers->{Location} = $l || '/'; 73 | $self->status = $s || 302; 74 | } 75 | 76 | # default 404 controller 77 | my $not_found = sub { $_[0]->status = 404; $_[0]->env->{REQUEST_PATH}." not found." }; 78 | our $r404 = Squatting::Controller->new( 79 | R404 => [], 80 | get => $not_found, 81 | post => $not_found, 82 | app => 'Squatting' 83 | ); 84 | 85 | 1; 86 | 87 | =head1 NAME 88 | 89 | Squatting::Controller - default controller class for Squatting 90 | 91 | =head1 SYNOPSIS 92 | 93 | package App::Controllers; 94 | use Squatting ':controllers'; 95 | our @C = ( 96 | C( 97 | Thread => [ '/forum/(\d+)/thread/(\d+)-(\w+)' ], 98 | get => sub { 99 | my ($self, $forum_id, $thread_id, $slug) = @_; 100 | # 101 | # get thread from database... 102 | # 103 | $self->render('thread'); 104 | }, 105 | post => sub { 106 | my ($self, $forum_id, $thread_id, $slug) = @_; 107 | # 108 | # add post to thread 109 | # 110 | $self->redirect(R('Thread', $forum_id, $thread_id, $slug)); 111 | } 112 | ) 113 | ); 114 | 115 | =head1 DESCRIPTION 116 | 117 | Squatting::Controller is the default controller class for Squatting 118 | applications. Its job is to take HTTP requests and construct an appropriate 119 | response by setting up output headers and returning content. 120 | 121 | =head1 API 122 | 123 | =head2 Object Construction 124 | 125 | =head3 Squatting::Controller->new($name => \@urls, %methods) 126 | 127 | The constructor takes a name, an arrayref or URL patterns, and a hash of 128 | method definitions. There is a helper function called C() that makes this 129 | slightly less verbose. 130 | 131 | =head3 $self->clone([ %opts ]) 132 | 133 | This will create a shallow copy of the controller. You may optionally pass in 134 | a hash of options that will be merged into the new clone. 135 | 136 | =head2 HTTP Request Handlers 137 | 138 | =head3 $self->get(@args) 139 | 140 | =head3 $self->post(@args) 141 | 142 | =head3 $self->put(@args) 143 | 144 | =head3 $self->delete(@args) 145 | 146 | =head3 $self->head(@args) 147 | 148 | =head3 $self->options(@args) 149 | 150 | =head3 $self->trace(@args) 151 | 152 | =head3 $self->connect(@args) 153 | 154 | These methods are called when their respective HTTP requests are sent to the 155 | controller. @args is the list of regex captures from the URL pattern in 156 | $self->urls that matched $self->env->{REQUEST_PATH}. 157 | 158 | =head2 Attribute Accessors 159 | 160 | The following methods are lvalue subroutines that contain information 161 | relevant to the current controller and current request/response cycle. 162 | 163 | =head3 $self->name 164 | 165 | This returns the name of the controller. 166 | 167 | =head3 $self->urls 168 | 169 | This returns the arrayref of URL patterns that the controller responds to. 170 | 171 | =head3 $self->cr 172 | 173 | This returns the L object for the current session. 174 | 175 | =head3 $self->env 176 | 177 | This returns a hashref populated with a CGI-like environment. This is where 178 | you'll find the incoming HTTP headers. 179 | 180 | =head3 $self->input 181 | 182 | This returns a hashref containing the incoming CGI parameters. 183 | 184 | B: Interpreting the query ?x=5&y=true&z=2&z=1&z=3 . 185 | 186 | $self->input->{x} is 5 187 | $self->input->{y} is "true" 188 | $self->input->{z} is [2, 1, 3] 189 | 190 | =head3 @keys = $self->param 191 | 192 | =head3 $value = $self->param($key) 193 | 194 | =head3 $self->param($key, $value) 195 | 196 | This is an accessor for C<$self-Einput> that provides an API that's a 197 | subset of the L module's C function. It exists, because there 198 | are many perl modules that can make use of an object that follows this API. It 199 | is not complete, but it should be good enough for L 200 | and many other modules. 201 | 202 | =head3 $self->cookies 203 | 204 | This returns a hashref that holds both the incoming and outgoing cookies. 205 | 206 | Incoming cookies are just simple scalar values, whereas outgoing cookies are 207 | hashrefs that can be passed to L to construct a cookie string. 208 | 209 | B: Setting a cookie named 'foo' 210 | 211 | $self->cookies->{foo} = { -Value => 'bar', -Expires => '+1d' }; 212 | 213 | B: Getting the value of a cookie named 'baz' 214 | 215 | my $baz = $self->cookies->{baz}; 216 | 217 | =head3 $self->state 218 | 219 | If you've setup sessions, this method will return the current session 220 | data as a hashref. 221 | 222 | =head3 $self->v 223 | 224 | This returns a hashref that represents the outgoing variables for this 225 | request. This hashref will be passed to a view's templates when render() 226 | is called. 227 | 228 | =head3 $self->status 229 | 230 | This returns an integer representing the outgoing HTTP status code. 231 | See L for more details. 232 | 233 | $self->status = 404; # Resource Not Found 234 | 235 | =head3 $self->headers 236 | 237 | This returns a hashref representing the outgoing HTTP headers. 238 | 239 | B: Setting the outgoing Content-Type to text/plain 240 | 241 | $self->headers->{'Content-Type'} = 'text/plain'; 242 | 243 | =head3 $self->log 244 | 245 | This returns a logging object if one has been set up for your app. If it 246 | exists, you should be able to call methods like C, C, 247 | C, C, and C against it, and the output of this would 248 | typically end up in an error log. 249 | 250 | =head3 $self->view 251 | 252 | This returns the name of the default view for the current request. If 253 | it's undefined, the first view in @App::Views::V will be considered the 254 | default. 255 | 256 | =head3 $self->app 257 | 258 | This returns the name of the app that this controller belongs to. 259 | 260 | =head2 Output 261 | 262 | =head3 $self->render($template, [ $view ]) 263 | 264 | This method will return a string generated by the specified template and view. 265 | If a view is not specified, the first view object in @App::Views::V will be 266 | used. 267 | 268 | =head3 $self->redirect($path, [ $status ]) 269 | 270 | This method is a shortcut for setting $self->status to 302 and 271 | $self->headers->{Location} to the specified URL. You may optionally pass in a 272 | different status code as the second parameter. 273 | 274 | =head1 SEE ALSO 275 | 276 | L, 277 | L 278 | 279 | =cut 280 | 281 | # Local Variables: *** 282 | # mode: cperl *** 283 | # indent-tabs-mode: nil *** 284 | # cperl-close-paren-offset: -2 *** 285 | # cperl-continued-statement-offset: 2 *** 286 | # cperl-indent-level: 2 *** 287 | # cperl-indent-parens-as-block: t *** 288 | # cperl-tab-always-indent: nil *** 289 | # End: *** 290 | # vim:tabstop=8 softtabstop=2 shiftwidth=2 shiftround expandtab 291 | -------------------------------------------------------------------------------- /lib/Squatting/H.pm: -------------------------------------------------------------------------------- 1 | package Squatting::H; 2 | use strict; 3 | use warnings; 4 | use Clone; 5 | 6 | our $AUTOLOAD; 7 | 8 | # Squatting::H->new(\%attributes) -- constructor 9 | sub new { 10 | my ($class, $opts) = @_; 11 | $opts ||= {}; 12 | CORE::bless { %$opts } => $class; 13 | } 14 | 15 | # Squatting::H->bless(\%attributes) -- like new() but directly bless $opts instead of making a shallow copy. 16 | sub bless { 17 | my ($class, $opts) = @_; 18 | $opts ||= {}; 19 | CORE::bless $opts => $class; 20 | } 21 | 22 | # $object->extend(\%attributes) -- extend keys and values of another hashref into $self 23 | sub extend { 24 | my ($self, $extend) = @_; 25 | for (keys %$extend) { 26 | $self->{$_} = $extend->{$_}; 27 | } 28 | $self; 29 | } 30 | 31 | # $object->clone(\%attributes) -- copy constructor 32 | sub clone { 33 | my ($self, $extend) = @_; 34 | my $clone = Clone::clone($self); 35 | $clone->extend($extend) if ($extend); 36 | $clone; 37 | } 38 | 39 | # $object->slots -- keys of underlying hashref of $object 40 | sub slots { 41 | keys %{$_[0]} 42 | } 43 | 44 | # $object->can($method) -- does the $object support this $method? 45 | sub can { 46 | UNIVERSAL::can($_[0], $_[1]) || $_[0]->{$_[1]}; 47 | } 48 | 49 | # $self->$method -- treat key values as methods 50 | sub AUTOLOAD { 51 | my ($self, @args) = @_; 52 | my $attr = $AUTOLOAD; 53 | $attr =~ s/.*://; 54 | if (ref($self->{$attr}) eq 'CODE') { 55 | $self->{$attr}->($self, @args) 56 | } else { 57 | if (@args) { 58 | $self->{$attr} = $args[0]; 59 | } else { 60 | $self->{$attr}; 61 | } 62 | } 63 | } 64 | 65 | sub DESTROY { } 66 | 67 | 1; 68 | 69 | __END__ 70 | 71 | =head1 NAME 72 | 73 | Squatting::H - a slot-based object that's vaguely reminiscent of Camping::H 74 | 75 | =head1 SYNOPSIS 76 | 77 | Behold, a glorified hashref that you can treat like an object: 78 | 79 | my $cat = Squatting::H->new({ 80 | name => 'kurochan', 81 | meow => sub { "me" . "o" x length($_[0]->name) . "w" } 82 | }); 83 | my $kitty = $cat->clone({ name => 'max' }); 84 | 85 | $cat->name; # "kurochan" 86 | $kitty->name; # "max" 87 | $cat->meow; # "meoooooooow" 88 | $kitty->meow; # "meooow" 89 | $cat->age(3); # 3 90 | $kitty->age(2); # 2 91 | $kitty->slots; # qw(name meow age) 92 | 93 | =head1 DESCRIPTION 94 | 95 | This module implements a simple slot-based object system. Objects in this 96 | system are blessed hashrefs whose keys (aka slots) can be accessed by calling 97 | methods with the same name as the key. You can also assign coderefs to a slot 98 | which will let you define custom methods for an object. 99 | 100 | This object system does not implement inheritance, but you can create 101 | derivatives of an object using the C method which creates a deep copy 102 | of your object. 103 | 104 | =head1 API 105 | 106 | =head2 Object Construction 107 | 108 | =head3 $object = Squatting::H->new(\%attributes) 109 | 110 | This method is used to construct a new object. A hashref of attributes may be 111 | passed to this method to initialize the object. A shallow copy of 112 | C<\%attributes> will then be created and blessed before being returned. 113 | 114 | =head3 $object = Squatting::H->bless(\%attributes) 115 | 116 | This is like new(), but it doesn't bother making a shallow copy of C<\%attributes>. 117 | 118 | =head3 $object = $object->extend(\%attributes) 119 | 120 | This method will add new attributes to an object. If the attributes already 121 | existed, the new values will replace the old values. 122 | 123 | =head3 $clone = $object->clone(\%attributes) 124 | 125 | This method will create a deep clone of the object. You may also pass in 126 | a hashref of attributes that the cloned object should have. 127 | 128 | =head2 General 129 | 130 | =head3 $object->can($method) 131 | 132 | UNIVERSAL::can has been overridden to be aware of the conventions used by 133 | Squatting::H objects. If a slot has been defined for the method that's passed 134 | in, this method will return true. 135 | 136 | =head3 @slot_names = $object->slots; 137 | 138 | This method gives you a list of all the slots that have been defined 139 | for this object. It's essentially the same as saying: 140 | 141 | keys %$object 142 | 143 | =head3 $value = $object->$slot 144 | 145 | =head3 $value = $object->$slot($value) 146 | 147 | This method lets you get and set the value of a slot. 148 | 149 | $object->foo(5); 150 | $object->foo; # 5 151 | 152 | If you pass in a coderef, it'll be treated as a method for your object. 153 | 154 | $object->double(sub { 155 | my ($self, $x) = @_; 156 | $x * 2; 157 | }); 158 | $object->double(16) # 32 159 | 160 | 161 | =head1 SEE ALSO 162 | 163 | L 164 | 165 | =cut 166 | 167 | # Local Variables: *** 168 | # mode: cperl *** 169 | # indent-tabs-mode: f *** 170 | # cperl-close-paren-offset: -2 *** 171 | # cperl-continued-statement-offset: 2 *** 172 | # cperl-indent-level: 2 *** 173 | # cperl-indent-parens-as-block: t *** 174 | # cperl-tab-always-indent: f *** 175 | # End: *** 176 | # vim:tabstop=8 softtabstop=2 shiftwidth=2 shiftround expandtab 177 | -------------------------------------------------------------------------------- /lib/Squatting/Mapper.pm: -------------------------------------------------------------------------------- 1 | package Squatting::Mapper; 2 | 3 | use strict; 4 | use warnings; 5 | use base 'Continuity::Mapper'; 6 | 7 | sub get_session_id_from_hit { 8 | my ($self, $request) = @_; 9 | my $app = $self->{app}; 10 | my $session_id = $self->SUPER::get_session_id_from_hit($request); 11 | my $path = $request->uri->path; 12 | my ($controller, $params); 13 | { 14 | no strict 'refs'; 15 | ($controller, $params) = &{$app."::D"}($path); 16 | } 17 | my $method = lc $request->method; 18 | my $queue = $controller->{queue}->{$method}; 19 | if (defined($queue)) { 20 | warn '$controller->{queue} has been deprecated in favor of $controller->{continuity}'."\n"; 21 | warn " perldoc Squatting::On::Continuity\n for more details.\n"; 22 | $session_id .= ".$app.$queue"; 23 | $self->Continuity::debug(2, " Session: got queue '$session_id'"); 24 | } 25 | my $continuity = $controller->{continuity}; 26 | my $controller_name = $controller->name; 27 | if (defined($continuity)) { 28 | $session_id .= ".$app.$controller_name.$path"; 29 | } 30 | $session_id; 31 | } 32 | 33 | 1; 34 | 35 | =head1 NAME 36 | 37 | Squatting::Mapper - map requests to session queues 38 | 39 | =head1 DESCRIPTION 40 | 41 | The purpose of this module is to be on the lookout for requests that should get 42 | special treatment by L. This is usually done by giving your 43 | controller a C attribute and setting it to a true value: 44 | 45 | C( 46 | Events => [ '/@events/(\d+)' ], 47 | 48 | get => sub { 49 | my ($self, $rand) = @_; 50 | my $cr = $self->cr; 51 | while (1) { # <--- COMET event loops typically loop forever 52 | # broadcasting relevant events 53 | # to long-polling HTTP requests 54 | # as they come in... 55 | $cr->next; 56 | } 57 | }, 58 | 59 | continuity => 1, # <--- causes Squatting::Mapper to notice 60 | ) 61 | 62 | When it sees that C is true, the request will be given a 63 | session id based on: $cookie_session + $app_name + $controller_name + $path. 64 | Normally, it's just $cookie_session, but when you get these extra pieces 65 | added to your session id, that tells Continuity that you want to have a 66 | separate coroutine for this request. 67 | 68 | The primary intended use for handling requests in a separate coroutine is to 69 | facilitate COMET event loops. When a user visits a COMET-enabled site, there 70 | will be some JavaScript that starts a long-polling HTTP request. On the 71 | server-side, the long-polling handler will typically have an infinite loop in 72 | it, so it needs to sit off in its own coroutine so that it doesn't affect the 73 | coroutine that is handling the normal, RESTful requests. 74 | 75 | If the user decides to open multiple-tabs to the same COMET-enabled site, 76 | each of those tabs needs to be differentiated on the server-side as well. 77 | That's when it becomes useful to stick something random in the path. 78 | Notice in the example that the path regex is '/@events/(\d+)'. 79 | 80 | It would be the job of the JavaScript to append a random string of digits to 81 | the end of an '/@events/(\d+)' URL before starting the long-poll request. 82 | That'll let Squatting::Mapper give each tab its own coroutine as well. 83 | 84 | =head1 SEE ALSO 85 | 86 | L, L 87 | 88 | =cut 89 | 90 | # Local Variables: *** 91 | # mode: cperl *** 92 | # indent-tabs-mode: nil *** 93 | # cperl-close-paren-offset: -2 *** 94 | # cperl-continued-statement-offset: 2 *** 95 | # cperl-indent-level: 2 *** 96 | # cperl-indent-parens-as-block: t *** 97 | # cperl-tab-always-indent: nil *** 98 | # End: *** 99 | # vim:tabstop=8 softtabstop=2 shiftwidth=2 shiftround expandtab 100 | -------------------------------------------------------------------------------- /lib/Squatting/On/CGI.pm: -------------------------------------------------------------------------------- 1 | package Squatting::On::CGI; 2 | 3 | use strict; 4 | no strict 'refs'; 5 | use warnings; 6 | use CGI; 7 | use CGI::Cookie; 8 | use HTTP::Response; 9 | 10 | # p for private 11 | my %p; 12 | $p{init_cc} = sub { 13 | my ($c, $q) = @_; 14 | my $cc = $c->clone; 15 | $cc->env = { %ENV }; 16 | $cc->cookies = $p{c}->($ENV{HTTP_COOKIE}); 17 | $cc->input = $p{i}->($q); 18 | $cc->headers = { 'Content-Type' => 'text/html' }; 19 | $cc->v = { }; 20 | $cc->status = 200; 21 | $cc; 22 | }; 23 | 24 | # \%input = i($q) # Extract CGI parameters from a CGI object 25 | $p{i} = sub { 26 | my $q = $_[0]; 27 | my %i = $q->Vars; 28 | +{ map { 29 | if ($i{$_} =~ /\0/) { 30 | $_ => [ split("\0", $i{$_}) ]; 31 | } else { 32 | $_ => $i{$_}; 33 | } 34 | } keys %i } 35 | }; 36 | 37 | # \%cookies = c($cookie_header) # Parse Cookie header(s). 38 | $p{c} = sub { 39 | +{ map { ref($_) ? $_->value : $_ } CGI::Cookie->parse($_[0]) }; 40 | }; 41 | 42 | sub cgi { 43 | my ($app, $q) = @_; 44 | $ENV{PATH_INFO} ||= '/'; 45 | $ENV{REQUEST_PATH} ||= do { 46 | my $script_name = $ENV{SCRIPT_NAME}; 47 | $script_name =~ s{/$}{}; 48 | $script_name . $ENV{PATH_INFO}; 49 | }; 50 | $ENV{REQUEST_URI} ||= do { 51 | ($ENV{QUERY_STRING}) 52 | ? "$ENV{REQUEST_PATH}?$ENV{QUERY_STRING}" 53 | : $ENV{REQUEST_PATH}; 54 | }; 55 | eval { 56 | my ($c, $args) = &{$app."::D"}($ENV{REQUEST_PATH}); 57 | my $cc = $p{init_cc}->($c, $q); 58 | my $content = $app->service($cc, @$args); 59 | my $response = HTTP::Response->new( 60 | $cc->status, 61 | undef, 62 | [ %{ $cc->{headers} } ], 63 | $content 64 | ); 65 | print "Status: " . $response->as_string; 66 | }; 67 | if ($@) { 68 | print $q->header(-status => 500); 69 | print "
$@
"; 70 | } 71 | } 72 | 73 | 1; 74 | 75 | =head1 NAME 76 | 77 | Squatting::On::CGI - if all else fails, you can still deploy on CGI 78 | 79 | =head1 SYNOPSIS 80 | 81 | Create an app.cgi to drive the Squatting app in a CGI environment. 82 | 83 | use App 'On::CGI'; 84 | my $q = CGI->new; 85 | App->init; 86 | App->relocate('/cgi-bin/app.cgi'); 87 | App->cgi($q); 88 | 89 | =head1 DESCRIPTION 90 | 91 | The purpose of this module is to allow Squatting apps to be used in a CGI 92 | environment. This is done by adding a C method to the Squatting app that 93 | knows how to "translate" between CGI and Squatting. To use this module, pass 94 | the string C<'On::CGI'> to the C statement that loads your Squatting 95 | app. 96 | 97 | =head1 API 98 | 99 | =head2 CGI -- The Lowest Common Demoninator 100 | 101 | =head3 App->cgi($q) 102 | 103 | Give the C method a CGI object, and it will send the apps output to 104 | STDOUT. 105 | 106 | =head1 SEE ALSO 107 | 108 | L 109 | 110 | =cut 111 | 112 | # Local Variables: *** 113 | # mode: cperl *** 114 | # indent-tabs-mode: nil *** 115 | # cperl-close-paren-offset: -2 *** 116 | # cperl-continued-statement-offset: 2 *** 117 | # cperl-indent-level: 2 *** 118 | # cperl-indent-parens-as-block: t *** 119 | # cperl-tab-always-indent: nil *** 120 | # End: *** 121 | # vim:tabstop=8 softtabstop=2 shiftwidth=2 shiftround expandtab 122 | -------------------------------------------------------------------------------- /lib/Squatting/On/Catalyst.pm: -------------------------------------------------------------------------------- 1 | package Squatting::On::Catalyst; 2 | 3 | use strict; 4 | no strict 'refs'; 5 | use warnings; 6 | 7 | # In order to embed a Squatting app into an app written in another framework, 8 | # we need to be able to do the following things. 9 | # 10 | # get incoming CGI parameters 11 | # get incoming HTTP request headers 12 | # get incoming `-cookies 13 | # get incoming HTTP method 14 | # set outgoing HTTP status 15 | # set outgoing HTTP response headers 16 | # set outgoing content 17 | 18 | my %p; 19 | 20 | $p{e} = sub { 21 | my $cat = shift; 22 | my $req = $cat->req; 23 | my $uri = $req->uri; 24 | my %env; 25 | $env{QUERY_STRING} = $uri->query || ''; 26 | $env{REQUEST_PATH} = '/' . $req->path; 27 | $env{REQUEST_URI} = "$env{REQUEST_PATH}?$env{QUERY_STRING}"; 28 | $env{REQUEST_METHOD} = $req->method; 29 | my $h = $req->headers; 30 | $h->scan(sub{ 31 | my ($header, $value) = @_; 32 | my $key = uc $header; 33 | $key =~ s/-/_/g; 34 | $key = "HTTP_$key"; 35 | $env{$key} = $value; 36 | }); 37 | \%env; 38 | }; 39 | 40 | $p{c} = sub { 41 | my $cat = shift; 42 | my $c = $cat->req->cookies; 43 | my %k; 44 | $k{$_} = $$c{$_}->value for (keys %$c); 45 | \%k; 46 | }; 47 | 48 | # init_cc($controller, $catalyst) -- initialize a controller clone 49 | $p{init_cc} = sub { 50 | my ($c, $cat) = @_; 51 | my $cc = $c->clone; 52 | $cc->env = $p{e}->($cat); 53 | $cc->cookies = $p{c}->($cat); 54 | $cc->input = $cat->req->parameters; 55 | $cc->headers = { 'Content-Type' => 'text/html' }; 56 | $cc->v = $cat->stash; 57 | $cc->state = $cat->session if ($cat->can('session')); 58 | $cc->log = $cat->log if ($cat->can('log')); 59 | $cc->status = 200; 60 | $cc; 61 | }; 62 | 63 | sub catalyze { 64 | my ($app, $cat) = @_; 65 | my ($c, $p) = &{ $app . "::D" }('/'.$cat->request->path); 66 | my $cc = $p{init_cc}->($c, $cat); 67 | my $content = $app->service($cc, @$p); 68 | my $h = $cat->response->headers; 69 | my $ch = $cc->headers; 70 | for (keys %$ch) { 71 | $h->header($_ => $ch->{$_}); 72 | } 73 | $cat->response->status($cc->status); 74 | $cat->response->body($content); 75 | } 76 | 77 | 1; 78 | 79 | =head1 NAME 80 | 81 | Squatting::On::Catalyst - embed a Squatting app into a Catalyst app 82 | 83 | =head1 SYNOPSIS 84 | 85 | Add these 4 lines to your Catalyst app's Root Controller to embed a Squatting 86 | App. 87 | 88 | use App 'On::Catalyst' 89 | App->init; 90 | App->relocate('/somewhere') 91 | sub somewhere : Local { App->catalyze($_[1]) } 92 | 93 | =head1 DESCRIPTION 94 | 95 | The purpose of this module is to allow Squatting apps to be embedded inside 96 | Catalyst apps. This is done by adding a C method to the Squatting 97 | app that knows how to "translate" between Catalyst and Squatting. To use this 98 | module, pass the string C<'On::Catalyst'> to the C statement that loads 99 | your Squatting app. 100 | 101 | =head1 API 102 | 103 | =head2 All Your Framework Are Belong To Us 104 | 105 | =head3 App->catalyze($c) 106 | 107 | This method takes a Catalyst object, and uses the information it contains to 108 | let the Squatting app handle one HTTP request. First, it translates the 109 | Catalyst::Request object into terms Squatting can understand. Then it lets 110 | the Squatting app handle the request. Finally, it takes the Squatting app's 111 | output and populates the Catalyst::Response object. When this method is done, 112 | the Catalyst object should have everything it needs to send back a complete 113 | HTTP response. 114 | 115 | B: If you want to communicate something from the Catalyst app to the 116 | Squatting app, you can put data in $c->stash or $c->session before calling 117 | catalyze(). From inside a Squatting controller, these can be accessed via 118 | $self->v and $self->state. Squatting controllers also get access to 119 | Catalyst's logging object via $self->log. 120 | 121 | In summary: 122 | 123 | Catalyst Squatting 124 | -------- --------- 125 | $c->stash $self->v 126 | $c->session $self->state 127 | $c->log $self->log 128 | 129 | =head1 SEE ALSO 130 | 131 | L, L, L 132 | 133 | =cut 134 | 135 | # Local Variables: *** 136 | # mode: cperl *** 137 | # indent-tabs-mode: nil *** 138 | # cperl-close-paren-offset: -2 *** 139 | # cperl-continued-statement-offset: 2 *** 140 | # cperl-indent-level: 2 *** 141 | # cperl-indent-parens-as-block: t *** 142 | # cperl-tab-always-indent: nil *** 143 | # End: *** 144 | # vim:tabstop=8 softtabstop=2 shiftwidth=2 shiftround expandtab 145 | -------------------------------------------------------------------------------- /lib/Squatting/On/Continuity.pm: -------------------------------------------------------------------------------- 1 | package Squatting::On::Continuity; 2 | 3 | use strict; 4 | no strict 'refs'; 5 | use warnings; 6 | use Continuity; 7 | use Squatting::Mapper; 8 | use CGI::Cookie; 9 | 10 | # p for private # this is my way of minimizing namespace pollution 11 | my %p; 12 | 13 | # session container 14 | our %state; 15 | 16 | # \%env = e($http_request) 17 | $p{e} = sub { 18 | my $r = shift; 19 | my %env; 20 | my $uri = $r->uri; 21 | $env{QUERY_STRING} = $uri->query || ''; 22 | $env{REQUEST_PATH} = $uri->path; 23 | $env{REQUEST_URI} = $uri->path_query; 24 | $env{REQUEST_METHOD} = $r->method; 25 | $r->scan(sub{ 26 | my ($header, $value) = @_; 27 | my $key = uc $header; 28 | $key =~ s/-/_/g; 29 | $key = "HTTP_$key"; 30 | $env{$key} = $value; 31 | }); 32 | \%env; 33 | }; 34 | 35 | # \%input = i($query_string) # Extract CGI parameters from QUERY_STRING 36 | $p{i} = sub { 37 | my $q = CGI->new($_[0]); 38 | my %i = $q->Vars; 39 | +{ map { 40 | if ($i{$_} =~ /\0/) { 41 | $_ => [ split("\0", $i{$_}) ]; 42 | } else { 43 | $_ => $i{$_}; 44 | } 45 | } keys %i } 46 | }; 47 | 48 | # \%cookies = c($cookie_header) # Parse Cookie header(s). 49 | $p{c} = sub { 50 | +{ map { ref($_) ? $_->value : $_ } CGI::Cookie->parse($_[0]) }; 51 | }; 52 | 53 | # init_cc($controller, $continuity_request) # initialize a controller clone 54 | $p{init_cc} = sub { 55 | my ($c, $cr) = @_; 56 | my $cc = $c->clone; 57 | $cc->cr = $cr; 58 | $cc->env = $p{e}->($cr->http_request); 59 | $cc->cookies = $p{c}->($cc->env->{HTTP_COOKIE}); 60 | $cc->input = $p{i}->(join('&', grep { defined } ($cc->env->{QUERY_STRING}, $cr->request->content))); 61 | $cc->headers = { 'Content-Type' => 'text/html' }; 62 | $cc->v = {}; 63 | $cc->status = 200; 64 | # setup session if one hasn't already been setup 65 | my $sid = $cr->{session_id}; 66 | if (defined $sid) { 67 | $cc->state = $state{$sid} ||= {}; 68 | } 69 | $cc; 70 | }; 71 | 72 | # App->service($controller, @args) # handle one http request 73 | sub service { 74 | my ($app, $c, @args) = @_; 75 | # call original service() 76 | my $content = $app->next::method($c, @args); 77 | # afterward, do some Continuity-specific cookie munging 78 | if (my $cr_cookies = $c->cr->cookies) { 79 | $cr_cookies =~ s/^Set-Cookie: //; 80 | $c->headers->{'Set-Cookie'} = join("; ", 81 | grep { not /^\s*$/ } ($c->headers->{'Set-Cookie'}, $cr_cookies)); 82 | } 83 | $content; 84 | } 85 | 86 | # App->continue(%opts) # Start Continuity's main loop. 87 | sub continue { 88 | my $app = shift; 89 | 90 | # Putting a RESTful face on Continuity since 2008. 91 | Continuity->new( 92 | port => 4234, 93 | allowed_methods => [ qw(GET POST HEAD PUT DELETE) ], 94 | mapper => Squatting::Mapper->new( 95 | app => $app, 96 | callback => sub { 97 | my $cr = shift; 98 | my ($c, $p) = &{$app."::D"}($cr->uri->path); 99 | my $cc = $p{init_cc}->($c, $cr); 100 | my $content = $app->service($cc, @$p); 101 | my $response = HTTP::Response->new( 102 | $cc->status, 103 | undef, 104 | [%{$cc->{headers}}], 105 | $content 106 | ); 107 | $cr->conn->send_response($response); 108 | $cr->end_request; 109 | }, 110 | @_ 111 | ), 112 | @_ 113 | )->loop; 114 | } 115 | 116 | $SIG{PIPE} = sub { Coro::terminate(0) }; 117 | 118 | 1; 119 | 120 | =head1 NAME 121 | 122 | Squatting::On::Continuity - use Continuity as the server for your Squatting app 123 | 124 | =head1 SYNOPSIS 125 | 126 | Running a Squatting application on top of Continuity: 127 | 128 | use App 'On::Continuity'; 129 | App->init; 130 | App->continue(port => 2012); 131 | 132 | =head1 DESCRIPTION 133 | 134 | The purpose of this module is to add a C method to your app that will 135 | start a Continuity-based web server when invoked. To use this module, pass the 136 | string C<'On::Continuity'> to the C statement that loads your Squatting 137 | app. 138 | 139 | =head1 API 140 | 141 | =head2 Continuity meets MVC (or just VC, actually) 142 | 143 | =head3 App->continue(%options) 144 | 145 | This method starts a Continuity-based web server. The %options are passed 146 | straight through to Continuity, and they let you specify things like what port 147 | to run the server on. 148 | 149 | =head1 EXPLANATION 150 | 151 | =head2 The Special Powers of Continuity 152 | 153 | L has 2 highly unusual (but useful) capabilities. 154 | 155 | =over 4 156 | 157 | =item 1. It can hold many simultaneous HTTP connections open. 158 | 159 | =item 2. It can "pause" execution until the next request comes in. 160 | 161 | =back 162 | 163 | The easiest way to explain this is by example. 164 | 165 | =head2 Becoming RESTless 166 | 167 | Consider this controller which has an infinite loop in it. 168 | 169 | C( 170 | Count => [ '/@count' ], 171 | get => sub { 172 | my ($self) = @_; 173 | my $cr = $self->cr; 174 | my $i = 1; 175 | while (1) { 176 | $cr->print($i++); 177 | $cr->next; 178 | } 179 | }, 180 | continuity => 1, 181 | ) 182 | 183 | Here, the code is dropping down to the Continuity level. The C<$cr> variable 184 | contains a L object, and with that in hand, we can try 185 | something as audacious as an infinite loop. However, this while loop does not 186 | spin out of control and eat up all your CPU. The C<$cr-Enext> statement 187 | will pause execution of the current coroutine, and it will wait until the 188 | next HTTP request to come in. Thus, you can hit reload multiple times and 189 | watch C<$i> increment each time. 190 | 191 | However, not just any HTTP request will wake this coroutine up. To make 192 | C<$cr-Enext> stop blocking, a request with the following properties will 193 | have to come in. 194 | 195 | =over 4 196 | 197 | =item It has to have the same session_id. 198 | 199 | =item It has to be for the same controller. 200 | 201 | =item It has to be a GET request. 202 | 203 | =back 204 | 205 | The key is this line: 206 | 207 | queue => { get => 'name_of_queue' } 208 | 209 | When you're squatting on Continuity, you're allowed to define your controllers 210 | with a C attribute. It should contain a hashref where the keys are HTTP 211 | methods (in lower case) and the values are unique strings that will be used 212 | internally by Continuity to differentiate one queue of requests from another. 213 | 214 | Every method mentioned in C will be given its own coroutine to run in. 215 | 216 | =head2 Pausing for Other Events 217 | 218 | TO BE CONTINUED... 219 | 220 | For a sneak peak, take a look at the Chat application in the F directory. 221 | 222 | =head1 SEE ALSO 223 | 224 | L, L, L, L 225 | 226 | =cut 227 | 228 | # Local Variables: *** 229 | # mode: cperl *** 230 | # indent-tabs-mode: nil *** 231 | # cperl-close-paren-offset: -2 *** 232 | # cperl-continued-statement-offset: 2 *** 233 | # cperl-indent-level: 2 *** 234 | # cperl-indent-parens-as-block: t *** 235 | # cperl-tab-always-indent: nil *** 236 | # End: *** 237 | # vim:tabstop=8 softtabstop=2 shiftwidth=2 shiftround expandtab 238 | -------------------------------------------------------------------------------- /lib/Squatting/On/MP13.pm: -------------------------------------------------------------------------------- 1 | package Squatting::On::MP13; 2 | 3 | use strict; 4 | use warnings; 5 | use Apache; 6 | use Apache::Log; 7 | use CGI::Cookie; 8 | use Apache::Constants ':common'; 9 | use Squatting::H; 10 | 11 | # adapt Apache::Log's interface to Squatting::Log's interface 12 | our $log = Squatting::H->new({ 13 | _log => undef, 14 | debug => sub { 15 | my ($self, @messages) = @_; 16 | $self->_log->debug(@messages); 17 | }, 18 | info => sub { 19 | my ($self, @messages) = @_; 20 | $self->_log->info(@messages); 21 | }, 22 | warn => sub { 23 | my ($self, @messages) = @_; 24 | $self->_log->warn(@messages); 25 | }, 26 | error => sub { 27 | my ($self, @messages) = @_; 28 | $self->_log->error(@messages); 29 | }, 30 | fatal => sub { 31 | my ($self, @messages) = @_; 32 | $self->_log->emerg(@messages); 33 | }, 34 | }); 35 | 36 | # p for private 37 | my %p; 38 | $p{init_cc} = sub { 39 | my ($c, $r) = @_; 40 | my $cc = $c->clone; 41 | $cc->env = { %ENV }; 42 | $cc->cookies = $p{c}->($ENV{HTTP_COOKIE}); 43 | $cc->input = { $r->args }; 44 | $cc->headers = { 'Content-Type' => 'text/html' }; 45 | $cc->v = { }; 46 | $cc->status = 200; 47 | $cc->log = $log; 48 | $log->_log($r->log); 49 | $cc; 50 | }; 51 | 52 | # \%cookies = $p{c}->($cookie_header) # Parse Cookie header(s). 53 | $p{c} = sub { 54 | +{ map { ref($_) ? $_->value : $_ } CGI::Cookie->parse($_[0]) }; 55 | }; 56 | 57 | sub mp13($$) { 58 | no strict 'refs'; 59 | my ($app, $r) = @_; 60 | my ($c, $p) = &{ $app . "::D" }($r->uri); 61 | my $cc = $p{init_cc}->($c, $r); 62 | my $content = $app->service($cc, @$p); 63 | while (my($header, $value) = each(%{$cc->headers})) { 64 | $r->header_out($header, $value); 65 | } 66 | $r->status($cc->status); 67 | $r->print($content); 68 | OK; 69 | } 70 | 71 | sub init { 72 | no strict 'refs'; 73 | no warnings 'redefine'; 74 | my ($app) = @_; 75 | *{ $app . "::handler" } = sub { 76 | my ($r) = @_; 77 | $app->mp13($r); 78 | }; 79 | $app->next::method; 80 | } 81 | 82 | 1; 83 | 84 | __END__ 85 | 86 | =head1 NAME 87 | 88 | Squatting::On::MP13 - a handler for Apache 1.3's mod_perl 89 | 90 | =head1 SYNOPSIS 91 | 92 | First, load the App + Squatting::On::MP13: 93 | 94 | 95 | use App 'On::MP13'; 96 | App->init; 97 | 98 | 99 | Then, setup a handler in your Apache config: 100 | 101 | 102 | SetHandler perl-script 103 | PerlHandler App 104 | 105 | 106 | Alternatively, if your mod_perl has L 107 | support, you can say: 108 | 109 | 110 | SetHandler perl-script 111 | PerlHandler App->mp13 112 | 113 | 114 | VirtualHost configuration using L as an example: 115 | 116 | 117 | ServerName podserver.mydomain.org 118 | DocumentRoot /www/podserver.mydomain.org 119 | ErrorLog logs/podserver.mydomain.org-error_log 120 | CustomLog logs/podserver.mydomain.org-access_log common 121 | 122 | use Pod::Server 'On::MP13'; 123 | Pod::Server->init; 124 | 125 | 126 | SetHandler perl-script 127 | PerlHandler Pod::Server 128 | 129 | 130 | 131 | =head1 DESCRIPTION 132 | 133 | The purpose of this module is to add an C method to your app that can be 134 | used as a mod_perl method handler. It also adds a conventional mod_perl handler 135 | so that Squatting apps can be deployed on mod_perl installations that don't 136 | have method handler support built in. To use this module, pass the string 137 | C<'On::MP13'> to the C statement that loads your Squatting app. Also, 138 | make sure you've configured your Apache to use Cmp13> as the handler. 139 | 140 | =head1 API 141 | 142 | =head2 They should have stopped at Apache 1.3.37. 143 | 144 | =head3 App->mp13($r) 145 | 146 | This method takes an L request object, and translates the request into 147 | terms that Squatting understands. Then, after your app has handled the request, 148 | it will send out an HTTP response via mod_perl. 149 | 150 | =head3 App::handler($r) 151 | 152 | Unfortunately, it is common for mod_perl to not have method handler support 153 | compiled in, so a more conventional mod_perl handler is also provided. This 154 | just calls Cmp13($r)>. 155 | 156 | (Note that this sub is added directly to the App that loaded 157 | Squatting::On::MP13. It's C and NOT Chandler>.) 158 | 159 | =head1 SEE ALSO 160 | 161 | L 162 | 163 | L, L, L 164 | 165 | =cut 166 | 167 | # Local Variables: *** 168 | # mode: cperl *** 169 | # indent-tabs-mode: nil *** 170 | # cperl-close-paren-offset: -2 *** 171 | # cperl-continued-statement-offset: 2 *** 172 | # cperl-indent-level: 2 *** 173 | # cperl-indent-parens-as-block: t *** 174 | # cperl-tab-always-indent: nil *** 175 | # End: *** 176 | # vim:tabstop=8 softtabstop=2 shiftwidth=2 shiftround expandtab 177 | -------------------------------------------------------------------------------- /lib/Squatting/On/MP20.pm: -------------------------------------------------------------------------------- 1 | package Squatting::On::MP20; 2 | 3 | use strict; 4 | use warnings; 5 | use Apache2::RequestRec; 6 | use Apache2::RequestIO; 7 | use Apache2::Const -compile => qw(OK); 8 | use CGI::Cookie; 9 | use Squatting::H; 10 | 11 | # adapt Apache::Log's interface to Squatting::Log's interface 12 | our $log = Squatting::H->new({ 13 | _log => undef, 14 | debug => sub { 15 | my ($self, @messages) = @_; 16 | $self->_log->debug(@messages); 17 | }, 18 | info => sub { 19 | my ($self, @messages) = @_; 20 | $self->_log->info(@messages); 21 | }, 22 | warn => sub { 23 | my ($self, @messages) = @_; 24 | $self->_log->warn(@messages); 25 | }, 26 | error => sub { 27 | my ($self, @messages) = @_; 28 | $self->_log->error(@messages); 29 | }, 30 | fatal => sub { 31 | my ($self, @messages) = @_; 32 | $self->_log->emerg(@messages); 33 | }, 34 | }); 35 | 36 | # p for private 37 | my %p; 38 | $p{init_cc} = sub { 39 | my ($c, $r) = @_; 40 | my $cc = $c->clone; 41 | $cc->env = $p{e}->($r->headers_in); 42 | $cc->cookies = $p{c}->($ENV{HTTP_COOKIE}); 43 | $cc->input = $p{i}->($r->args); 44 | $cc->headers = { 'Content-Type' => 'text/html' }; 45 | $cc->v = { }; 46 | $cc->status = 200; 47 | $cc->log = $log; 48 | $log->_log($r->log); 49 | $cc; 50 | }; 51 | 52 | # \%input = $p{i}->($query_string) # Extract CGI parameters from QUERY_STRING 53 | $p{i} = sub { 54 | my $q = CGI->new($_[0]); 55 | my %i = $q->Vars; 56 | +{ map { 57 | if ($i{$_} =~ /\0/) { 58 | $_ => [ split("\0", $i{$_}) ]; 59 | } else { 60 | $_ => $i{$_}; 61 | } 62 | } keys %i } 63 | }; 64 | 65 | # \%cookies = $p{c}->($cookie_header) # Parse Cookie header(s). 66 | $p{c} = sub { 67 | +{ map { ref($_) ? $_->value : $_ } CGI::Cookie->parse($_[0]) }; 68 | }; 69 | 70 | # \%env = $p{e}->($r->headers_in) # Extract incoming HTTP headers from $r->headers_in 71 | $p{e} = sub { 72 | my ($hd) = @_; 73 | my %env = %ENV; 74 | while (my ($k, $v) = each(%$hd)) { 75 | my $key = uc $k; $key =~ s/-/_/g; 76 | $env{$key} = $v; 77 | } 78 | \%env; 79 | }; 80 | 81 | sub mp20 { 82 | no strict 'refs'; 83 | my ($app, $r) = @_; 84 | my ($c, $p) = &{ $app . "::D" }($r->uri); 85 | my $cc = $p{init_cc}->($c, $r); 86 | my $content = $app->service($cc, @$p); 87 | my $headers = ($cc->status >= 200 && $cc->status < 300) 88 | ? $r->headers_out 89 | : $r->err_headers_out; 90 | while (my($h, $v) = each(%{$cc->headers})) { 91 | if ($h =~ /Content-Type/i) { 92 | $r->content_type($v); # XXX - Why did I even have to do this????!!@$ 93 | } else { 94 | $headers->{$h} = $v; 95 | } 96 | } 97 | $r->status($cc->status); 98 | $r->set_content_length(length($content)); 99 | $r->print($content); 100 | Apache2::Const::OK; 101 | } 102 | 103 | 1; 104 | 105 | =head1 NAME 106 | 107 | Squatting::On::MP20 - mod_perl 2.0 support for Squatting 108 | 109 | =head1 SYNOPSIS 110 | 111 | Load 112 | 113 | 114 | use App 'On::MP20'; 115 | App->init 116 | 117 | 118 | Setup handler 119 | 120 | 121 | SetHandler perl-script 122 | PerlHandler App->mp20 123 | 124 | 125 | VirtualHost Configuration Example 126 | 127 | ... 128 | 129 | =head1 DESCRIPTION 130 | 131 | =head1 API 132 | 133 | =head2 Something Clever 134 | 135 | =head3 App->mp20 136 | 137 | =head1 SEE ALSO 138 | 139 | =cut 140 | 141 | # Local Variables: *** 142 | # mode: cperl *** 143 | # indent-tabs-mode: nil *** 144 | # cperl-close-paren-offset: -2 *** 145 | # cperl-continued-statement-offset: 2 *** 146 | # cperl-indent-level: 2 *** 147 | # cperl-indent-parens-as-block: t *** 148 | # cperl-tab-always-indent: nil *** 149 | # End: *** 150 | # vim:tabstop=8 softtabstop=2 shiftwidth=2 shiftround expandtab 151 | -------------------------------------------------------------------------------- /lib/Squatting/On/Squatting.pm: -------------------------------------------------------------------------------- 1 | package Squatting::On::Squatting; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | # Placeholder for Squatting::mount() 7 | 8 | 1; 9 | -------------------------------------------------------------------------------- /lib/Squatting/View.pm: -------------------------------------------------------------------------------- 1 | package Squatting::View; 2 | 3 | use strict; 4 | use warnings; 5 | no warnings 'redefine'; 6 | 7 | our $AUTOLOAD; 8 | 9 | # constructor 10 | sub new { 11 | my $class = shift; 12 | my $name = shift; 13 | bless { name => $name, @_ } => $class; 14 | } 15 | 16 | # name of view 17 | sub name : lvalue { 18 | $_[0]->{name}; 19 | } 20 | 21 | # name of view 22 | sub headers : lvalue { 23 | $_[0]->{headers}; 24 | } 25 | 26 | # $content = $view->_render($template, $vars) # render $template 27 | # $content = $view->_render($template, $vars, '_') # render generic template 28 | sub _render { 29 | my ($self, $template, $vars, $alt) = @_; 30 | $self->{template} = $template; 31 | if (exists $self->{layout} && ($template !~ /^_/)) { 32 | $template = $alt if defined $alt; 33 | $self->{layout}($self, $vars, $self->{$template}($self, $vars)); 34 | } else { 35 | $template = $alt if defined $alt; 36 | $self->{$template}($self, $vars); 37 | } 38 | } 39 | 40 | # forward to _render() 41 | sub AUTOLOAD { 42 | my ($self, $vars) = @_; 43 | my $template = $AUTOLOAD; 44 | $template =~ s/.*://; 45 | if (exists $self->{$template} && ref($self->{$template}) eq 'CODE') { 46 | $self->_render($template, $vars); 47 | } elsif (exists $self->{_}) { 48 | $self->_render($template, $vars, '_'); 49 | } else { 50 | die("$template cannot be rendered."); 51 | } 52 | } 53 | 54 | sub DESTROY { } 55 | 56 | 1; 57 | 58 | =head1 NAME 59 | 60 | Squatting::View - default view class for Squatting 61 | 62 | =head1 SYNOPSIS 63 | 64 | package App::Views; 65 | use Squatting ':views'; 66 | our @V = ( 67 | V( 68 | 'example', 69 | layout => sub { 70 | my ($self, $v, $content) = @_; 71 | "(header $content footer)"; 72 | }, 73 | home => sub { 74 | my ($self, $v) = @_; 75 | "Hello, $v->{name}"; 76 | }, 77 | _ => sub { 78 | my ($self, $v) = @_; 79 | "You tried to render $self->{template} which was not defined."; 80 | }, 81 | arbitrary_data => [ { is => 'ok' }, 2 ], 82 | ) 83 | ); 84 | 85 | =head1 DESCRIPTION 86 | 87 | In Squatting, views are objects that contain many templates. Templates are 88 | represented by coderefs that will be treated as methods of a view object. The 89 | job of a template is to take a hashref of variables and return a string. 90 | 91 | Typically, the hashref of variables will be the same as what's in 92 | C<$controller-Ev>. This is important to note, because if you want a session 93 | variable in C<$controller-Estate> to affect the template, you have to put 94 | it in C<$controller-Ev>. 95 | 96 | =head1 API 97 | 98 | =head2 General Methods 99 | 100 | =head3 $view = Squatting::View->new($name, %methods) 101 | 102 | The constructor takes a name and a hash of attributes and coderefs. 103 | Note that the name must be unique within the package the view is defined. 104 | 105 | =head3 $view->name 106 | 107 | This returns the name of the view. 108 | 109 | =head3 $view->headers 110 | 111 | This returns a hashref of the outgoing HTTP headers. 112 | 113 | =head2 Template Methods 114 | 115 | =head3 $content = $view->$template($v) 116 | 117 | Any coderef that was given to the constructor may be called by name. Templates 118 | should be passed in a hashref (C<$v>) with variables for it to use to generate 119 | the final output. 120 | 121 | =head3 $content = $view->layout($v, $content) 122 | 123 | If you define a template named "layout", it'll be used to wrap the 124 | content of all templates whose name do not begin with "_". You can 125 | use this feature to provide standard headers and footers for your 126 | pages. 127 | 128 | =head3 $content = $view->_($v) 129 | 130 | If you define a template named "_", this will act as a catch-all 131 | that can be asked to render anything that wasn't explicitly defined. 132 | It's like our version of C. 133 | 134 | B: You can find out what they tried to render by inspecting 135 | C<$self-E{template}>. 136 | 137 | This feature is useful when you're using a file-based templating system like 138 | Tenjin or Template Toolkit, and you don't want to write a template sub for 139 | every single template. Instead, you can make C<$self-E{template}> 140 | correspond to a file on disk. 141 | 142 | =head3 $view->{$template} = \&coderef 143 | 144 | You are allowed to directly replace the template coderefs with your own. 145 | The most common reason you'd do this would be to replace an app's default 146 | layout with your own. 147 | 148 | $view->{layout} = sub { 149 | my ($self, $v, $content) = @_; 150 | # ... 151 | }; 152 | 153 | =head1 SEE ALSO 154 | 155 | L, 156 | L 157 | 158 | =cut 159 | 160 | # Local Variables: *** 161 | # mode: cperl *** 162 | # indent-tabs-mode: nil *** 163 | # cperl-close-paren-offset: -2 *** 164 | # cperl-continued-statement-offset: 2 *** 165 | # cperl-indent-level: 2 *** 166 | # cperl-indent-parens-as-block: t *** 167 | # cperl-tab-always-indent: nil *** 168 | # End: *** 169 | # vim:tabstop=8 softtabstop=2 shiftwidth=2 shiftround expandtab 170 | -------------------------------------------------------------------------------- /lib/Squatting/With/AccessTrace.pm: -------------------------------------------------------------------------------- 1 | package Squatting::With::AccessTrace; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Data::Dump 'pp'; 7 | our $I = 1; 8 | 9 | sub service { 10 | my ($self, $c, @args) = grep { defined } @_; 11 | my $body = $self->next::method($c, @args); 12 | my $meth = lc $c->env->{REQUEST_METHOD}; 13 | my $app = $c->app; 14 | my $s = $c->status; 15 | my $ppi = (%{ $c->input }) 16 | ? ', ' . pp($c->input) 17 | : ''; 18 | my $referer = (defined $c->env->{HTTP_REFERER}) ? "# ".$c->env->{HTTP_REFERER} : " "; 19 | warn sprintf('%5d ', $I++), 20 | "[$s] $app->$meth(@{[ join(', '=>map { \"'$_'\" } $c->name, @args) ]}$ppi) $referer\n"; 21 | $body; 22 | } 23 | 24 | 1; 25 | 26 | =head1 NAME 27 | 28 | Squatting::With::AccessTrace - provide a simple access log on STDERR 29 | 30 | =head1 SYNOPSIS 31 | 32 | use App 'With::AccessTrace', 'On::Continuity'; 33 | 34 | =head1 DESCRIPTION 35 | 36 | Using this plugin will print an executable line of code that represents the 37 | HTTP request that just came in. This print out conveniently condenses what 38 | app, HTTP method, controller, arguments, and CGI params were involved in the 39 | request. It looks like this: 40 | 41 | 1 [200] Example->get('Home') 42 | 2 [200] Example->get('Home', { bar => 2, baz => 5, foo => 1 }) 43 | 3 [200] Example->get('Profile', 'beppu') 44 | 4 [200] Example->get('Home') 45 | 5 [302] Example->get('RubyGems') 46 | 6 [404] Squatting->get('R404') 47 | 48 | You also get the number of requests the current process has served and the 49 | HTTP status of the response in the first and second columns, respectively. 50 | 51 | The code that generates this was originally in C<&Squatting::service>, but I 52 | wanted to make it optional, so I moved it into a separate module. 53 | 54 | =cut 55 | 56 | # Local Variables: *** 57 | # mode: cperl *** 58 | # indent-tabs-mode: nil *** 59 | # cperl-close-paren-offset: -2 *** 60 | # cperl-continued-statement-offset: 2 *** 61 | # cperl-indent-level: 2 *** 62 | # cperl-indent-parens-as-block: t *** 63 | # cperl-tab-always-indent: nil *** 64 | # End: *** 65 | # vim:tabstop=8 softtabstop=2 shiftwidth=2 shiftround expandtab 66 | -------------------------------------------------------------------------------- /lib/Squatting/With/Coro/Debug.pm: -------------------------------------------------------------------------------- 1 | package Squatting::With::Coro::Debug; 2 | 3 | use strict; 4 | use warnings; 5 | use Coro::Debug; 6 | 7 | sub init { 8 | my $app = shift; 9 | my $config = \%{$app.'::CONFIG'}; 10 | my $path = $config->{'with.coro.debug.unix_domain_socket'} 11 | || '/tmp/squatting.with.coro.debug'; 12 | our $debug = Coro::Debug->new_unix_server($path); 13 | $app->next::method; 14 | } 15 | 16 | 1; 17 | 18 | __END__ 19 | 20 | =head1 NAME 21 | 22 | Squatting::With::Coro::Debug - inspect running Squatting apps with Coro::Debug 23 | 24 | =head1 SYNOPSIS 25 | 26 | From the command line: 27 | 28 | squatting --module With::Coro::Debug App 29 | 30 | From a script: 31 | 32 | use App qw(On::Continuity With::Coro::Debug); 33 | App->init; 34 | App->continue(); 35 | 36 | Connect to Coro::Debug in another terminal 37 | 38 | socat readline unix:/tmp/squatting.with.coro.debug 39 | 40 | A Coro::Debug session looks like this: 41 | 42 | > ps 43 | PID SC RSS USES Description Where 44 | 142161516 RC 245k 23 [main::] [Event.pm:164] 45 | 142188912 -- 1404 4 [coro manager] [Coro.pm:358] 46 | 142189128 N- 84 0 [unblock_sub scheduler] - 47 | 142455240 N- 84 0 [Event idle process] - 48 | 146549540 -- 7340 14 [HttpDaemon.pm:426] 49 | 146549792 -- 2088 5 [Continuity.pm:436] 50 | 146552468 UC 3344 6 [Coro::Debug session] [Coro.pm:257] 51 | 52 | =head1 DESCRIPTION 53 | 54 | Using this module in conjunction with a Squatting app that's running on top of 55 | Continuity will provide you with a L server that you can connect 56 | to using tools like C. This will let you inspect the state of your 57 | Squatting app while its running. 58 | 59 | =head1 CONFIG 60 | 61 | =over 4 62 | 63 | =item with.coro.debug.unix_domain_socket 64 | 65 | This should be a string that represents the path of the Unix domain socket 66 | that Coro::Debug will use. If this option is not set, the default value 67 | is F. 68 | 69 | B 70 | 71 | $CONFIG{'with.coro.debug.unix_domain_socket'} = '/tmp/coro-debug-socket'; 72 | 73 | =back 74 | 75 | =head1 SEE ALSO 76 | 77 | =head2 Perl Modules 78 | 79 | L, 80 | L, 81 | L, 82 | L 83 | 84 | =head2 socat 85 | 86 | L 87 | 88 | =cut 89 | 90 | # Local Variables: *** 91 | # mode: cperl *** 92 | # indent-tabs-mode: nil *** 93 | # cperl-close-paren-offset: -2 *** 94 | # cperl-continued-statement-offset: 2 *** 95 | # cperl-indent-level: 2 *** 96 | # cperl-indent-parens-as-block: t *** 97 | # cperl-tab-always-indent: nil *** 98 | # End: *** 99 | # vim:tabstop=8 softtabstop=2 shiftwidth=2 shiftround expandtab 100 | -------------------------------------------------------------------------------- /lib/Squatting/With/Log.pm: -------------------------------------------------------------------------------- 1 | package Squatting::With::Log; 2 | 3 | use strict; 4 | no strict 'refs'; 5 | use warnings; 6 | use Squatting::H; 7 | use IO::All; 8 | use Clone 'clone'; 9 | 10 | sub timestamp { 11 | my ($sec, $min, $hour, $mday, $mon, $year) = localtime; 12 | sprintf( 13 | '%d-%02d-%02dT%02d:%02d:%02d', 14 | $year + 1900, $mon + 1, $mday, 15 | $hour, $min, $sec 16 | ); 17 | } 18 | 19 | our $Log = Squatting::H->new({ 20 | _path => '=', 21 | _levels => {}, 22 | enable => sub { 23 | my $self = shift; 24 | $self->{_levels}->{$_} = 1 for (@_); 25 | keys %{$self->{_levels}}; 26 | }, 27 | disable => sub { 28 | my $self = shift; 29 | delete($self->{_levels}->{$_}) for (@_); 30 | keys %{$self->{_levels}}; 31 | }, 32 | }); 33 | $Log->{levels} = sub { 34 | keys %{$_[0]->{_levels}}; 35 | }; 36 | for my $level (qw(debug info warn error fatal)) { 37 | $Log->{$level} = sub { 38 | my ($self, @messages) = @_; 39 | my $is_level = "is_$level"; 40 | return unless $self->$is_level; 41 | for (@messages) { 42 | sprintf('%-5s %s ! %s'."\n", $level, timestamp, $_) >> io($self->{_path}); 43 | } 44 | }; 45 | $Log->{"is_$level"} = sub { 46 | $_[0]->{_levels}->{$level}; 47 | }; 48 | } 49 | 50 | # every app gets its own log object in %log 51 | our %log; 52 | my $log_object = sub { 53 | my ($app) = @_; 54 | my $config = \%{$app.'::CONFIG'}; 55 | $log{$app} ||= do { 56 | my $path = $config->{'with.log.path'} || '='; # (default STDERR) 57 | my $level = $config->{'with.log.levels'} || 'debug,info,warn,error,fatal'; 58 | my $levels = +{ map { $_ => 1 } split(/\s*,\s*/, $level) }; 59 | $Log->clone({ path => $path, levels => $levels }); 60 | }; 61 | }; 62 | 63 | sub service { 64 | my ($app, $c, @args) = @_; 65 | $c->log ||= $log_object->($app); 66 | $app->next::method($c, @args); 67 | } 68 | 69 | 1; 70 | 71 | =head1 NAME 72 | 73 | Squatting::With::Log - a simple error log for Squatting apps 74 | 75 | =head1 SYNOPSIS 76 | 77 | Adding simple logging to your Squatting app: 78 | 79 | use App 'With::Log', 'On::CGI'; 80 | 81 | This will let log from within your controllers: 82 | 83 | C( 84 | Day => [ '/(\d+)/(\d+)/(\d+)' ], 85 | get => sub { 86 | my ($self, $year, $month, $day) = @_; 87 | my $log = $self->log; 88 | $log->debug(" year: $year"); 89 | $log->info ("month: $month"); 90 | $log->warn (" day: $day"); 91 | # you also get $log->error and $log->fatal 92 | $self->render('day'); 93 | } 94 | ) 95 | 96 | =head1 DESCRIPTION 97 | 98 | Squatting::With::Log provides a simple logging object that can be used from 99 | within your controllers to send messages to either a log file or STDERR for 100 | informational purposes. Typically, these messages would be useful during 101 | development and debugging but would be disabled for production use. 102 | 103 | To use this module, pass the string C<'With::Log'> to the C statement that 104 | loads your Squatting app. 105 | 106 | =head1 CONFIGURATION 107 | 108 | Squatting apps may set the following values in their C<%CONFIG> hash to control 109 | the behavior of this module. 110 | 111 | =over 4 112 | 113 | =item with.log.path 114 | 115 | This should be a string that specifies the full path to where you want the 116 | logs to be sent. 117 | 118 | B: 119 | 120 | $CONFIG{'with.log.path'} = "/tmp/error_log"; 121 | 122 | =item with.log.levels 123 | 124 | This should be a comma-separated string that lists all the log levels you 125 | want to enable. 126 | 127 | B: Only output messages with a log level of C or C. 128 | 129 | $CONFIG{'with.log.levels'} = "error,fatal"; 130 | 131 | =back 132 | 133 | =head1 API 134 | 135 | =head2 Object Construction 136 | 137 | =head3 $log = Squatting::Log->new(\%config) 138 | 139 | =head2 Configuration 140 | 141 | =head3 $log->enable(@levels) 142 | 143 | This method enables the list of log levels you send it. 144 | 145 | =head3 $log->disable(@levels) 146 | 147 | This method disables the list of log levels you send it. 148 | 149 | =head2 Introspection 150 | 151 | =head3 $log->is_debug 152 | 153 | =head3 $log->is_info 154 | 155 | =head3 $log->is_warn 156 | 157 | =head3 $log->is_error 158 | 159 | =head3 $log->is_fatal 160 | 161 | These methods return true if their respective log levels are enabled. 162 | 163 | =head2 Logging 164 | 165 | =head3 $log->debug(@messages) 166 | 167 | =head3 $log->info(@messages) 168 | 169 | =head3 $log->warn(@messages) 170 | 171 | =head3 $log->error(@messages) 172 | 173 | =head3 $log->fatal(@messages) 174 | 175 | These methods output the list of log messages you send it using the 176 | specified log level. 177 | 178 | =head1 SEE ALSO 179 | 180 | L - The Squatting::Log API is the same as the Catalyst::Log API. 181 | 182 | =cut 183 | 184 | # Local Variables: *** 185 | # mode: cperl *** 186 | # indent-tabs-mode: nil *** 187 | # cperl-close-paren-offset: -2 *** 188 | # cperl-continued-statement-offset: 2 *** 189 | # cperl-indent-level: 2 *** 190 | # cperl-indent-parens-as-block: t *** 191 | # cperl-tab-always-indent: nil *** 192 | # End: *** 193 | # vim:tabstop=8 softtabstop=2 shiftwidth=2 shiftround expandtab 194 | -------------------------------------------------------------------------------- /lib/Squatting/With/MockRequest.pm: -------------------------------------------------------------------------------- 1 | package Squatting::With::MockRequest; 2 | use common::sense; 3 | 4 | # TODO - hook these in to the init 5 | our %cookies; 6 | our %state = (mock_request => 1); 7 | 8 | sub mock_controller_init { 9 | my ($app, $cc, @args) = @_; 10 | $cc->{cr} = {}; # TODO - provide a mock Continuity::Request 11 | $cc->{env} = { REQUEST_PATH => &{"$app"."::Controllers::R"}($cc->name, @args) }; 12 | $cc->{cookies} = \%cookies; 13 | $cc->{input} = {}; 14 | $cc->{headers} = {}; 15 | $cc->{v} = {}; 16 | $cc->{state} = \%state; 17 | $cc->{status} = 200; 18 | $cc; 19 | }; 20 | 21 | foreach my $method ( qw(get post put delete head) ) { 22 | *{$method} = sub { 23 | my ($app, $controller, @args) = @_; 24 | my $cc = ${$app."::Controllers::C"}{$controller}->clone; 25 | $app->mock_controller_init($cc, @args); 26 | $cc->env->{REQUEST_METHOD} = $method; 27 | if (ref($_[-1]) eq 'HASH') { 28 | $cc->input = pop @args; 29 | } 30 | my $content = $app->service($cc, @args); 31 | ($cc, $content); 32 | }; 33 | } 34 | 35 | 1; 36 | 37 | __END__ 38 | 39 | =head1 NAME 40 | 41 | Squatting::With::MockRequest - Mock HTTP helper methods mostly for the REPL 42 | 43 | =head1 SYNOPSIS 44 | 45 | use App 'With::MockRequest'; 46 | 47 | App->get( 48 | 49 | =head1 DESCRIPTION 50 | 51 | =cut 52 | 53 | # Local Variables: *** 54 | # mode: cperl *** 55 | # indent-tabs-mode: nil *** 56 | # cperl-close-paren-offset: -2 *** 57 | # cperl-continued-statement-offset: 2 *** 58 | # cperl-indent-level: 2 *** 59 | # cperl-indent-parens-as-block: t *** 60 | # cperl-tab-always-indent: nil *** 61 | # End: *** 62 | # vim:tabstop=2 softtabstop=2 shiftwidth=2 shiftround expandtab 63 | -------------------------------------------------------------------------------- /lib/Squatting/With/Mount.pm: -------------------------------------------------------------------------------- 1 | package Squatting::With::Mount; 2 | use strict; 3 | use warnings; 4 | 5 | sub mount { 6 | my ($class, $path, $app, @plugins) = @_; 7 | # load the app 8 | # make the app use the 'On::Squatting' plugin 9 | # load other plugins if @plugins 10 | # create a controller object 11 | # plug the app into this controller 12 | # push the controller into @C 13 | } 14 | 15 | 1; 16 | 17 | __END__ 18 | 19 | =head1 NAME 20 | 21 | Squatting::With::Mount - mount Squatting apps at arbitrary paths 22 | 23 | =head1 SYNOPSIS 24 | 25 | use App 'With::Mount'; 26 | App->mount('/forum' => 'Ground'); 27 | App->init; 28 | 29 | =head1 DESCRIPTION 30 | 31 | This adds a C method to your Squatting application that lets 32 | you mount other Squatting applications at arbitrary paths within your 33 | application. 34 | 35 | L used to provide a C method by default, but I 36 | discovered after the fact that the implementation was flawed. To do 37 | it correctly would require that I write a lot more code, so I decided 38 | to move the mount method out of the core and into a plugin called 39 | L. 40 | 41 | =cut 42 | 43 | # Local Variables: *** 44 | # mode: cperl *** 45 | # indent-tabs-mode: nil *** 46 | # cperl-close-paren-offset: -2 *** 47 | # cperl-continued-statement-offset: 2 *** 48 | # cperl-indent-level: 2 *** 49 | # cperl-indent-parens-as-block: t *** 50 | # cperl-tab-always-indent: nil *** 51 | # End: *** 52 | # vim:tabstop=8 softtabstop=2 shiftwidth=2 shiftround expandtab 53 | -------------------------------------------------------------------------------- /lib/squatting.pl: -------------------------------------------------------------------------------- 1 | package Squatting::Controller; 2 | sub new{bless{name=>$_[1],urls=>$_[2],@_[3..$#_]}=>$_[0]} 3 | sub clone{bless{%{$_[0]},@_[1..$#_]}=>ref($_[0])} 4 | for my$m qw(name urls cr env input cookies state v status headers log view app){ 5 | *{$m}=sub:lvalue{$_[0]->{$m}}} 6 | for my$m qw(get post head put delete options trace connect){ 7 | *{$m}=sub{$_[0]->{$m}->(@_)}}sub param{my($self,$k,@v)=@_; 8 | if(defined $k){if(@v){$self->input->{$k}=((@v>1)?\@v:$v[0]); 9 | }else{$self->input->{$k}} 10 | }else{keys%{$self->input}}} 11 | sub render{my($self,$template,$vn)=@_;my$view;$vn||=$self->view; 12 | my$app=$self->app;if(defined($vn)){$view=${$app."::Views::V"}{$vn}; 13 | }else{$view=${$app."::Views::V"}[0]} 14 | $view->headers=$self->headers;$view->$template($self->v)} 15 | sub redirect{my($self,$l,$s)=@_;$self->headers->{Location}=$l||'/'; 16 | $self->status=$s||302}my$not_found=sub{$_[0]->status=404; 17 | $_[0]->env->{REQUEST_PATH}." not found."}; 18 | our$r404=Squatting::Controller->new(R404=>[], 19 | get=>$not_found,post=>$not_found,app=>'Squatting'); 20 | package Squatting; 21 | use base"Class::C3::Componentised";use List::Util"first";use URI::Escape; 22 | use Carp;our$VERSION='0.60';sub import{my$m=shift;my$p=(caller)[0];my$app=$p; 23 | $app=~s/::Controllers$//;$app=~s/::Views$//;if(UNIVERSAL::isa($app,'Squatting') 24 | ){*{$p."::R"}=sub{my($controller,@args)=@_;my$input;if(@args && ref($args[-1]) 25 | eq'HASH'){$input=pop(@args)}my$c=${$app."::Controllers::C"}{$controller}; 26 | croak"$controller controller not found"unless$c;my$arity=@args; 27 | my$path=first{my@m=/\(.*?\)/g;$arity==@m}@{$c->urls}; 28 | croak"couldn't find a matching URL path" unless $path; 29 | while($path=~/\(.*?\)/){ 30 | $path=~s{\(.*?\)}{uri_escape(+shift(@args),"^A-Za-z0-9\-_.!~*’()/")}e} 31 | if($input){$path.="?".join('&'=>map{my$k=$_;ref($input->{$_})eq'ARRAY' 32 | ?map{"$k=".uri_escape($_)}@{$input->{$_}}:"$_=".uri_escape($input->{$_}) 33 | }keys %$input)}$path}; 34 | *{$app."::D"}=sub{my$url=uri_unescape($_[0]); 35 | my$C=\@{$app.'::Controllers::C'};my($c,@regex_captures);for$c(@$C){ 36 | for(@{$c->urls}){if(@regex_captures=($url=~qr{^$_$})){ 37 | pop @regex_captures if($#+==0);return($c,\@regex_captures)}}} 38 | ($Squatting::Controller::r404,[])}unless exists ${$app."::"}{D}} 39 | my@c;for(@_){if($_ eq':controllers'){*{$p."::C"}=sub{ 40 | Squatting::Controller->new(@_,app=>$app)}; 41 | }elsif($_ eq':views'){*{$p."::V"}=sub{Squatting::View->new(@_)}; 42 | }elsif(/::/){push @c,$_}}$m->load_components(@c)if@c} 43 | sub component_base_class{__PACKAGE__}sub mount{my($app,$other,$prefix)=@_; 44 | push @{$app."::O"},$other;push @{$app."::Controllers::C"},map{ 45 | my$urls=$_->urls;$_->urls=[map{$prefix.$_}@$urls];$_; 46 | }@{$other."::Controllers::C"}} 47 | sub relocate{my($app,$prefix)=@_;for(@{$app."::Controllers::C"}){ 48 | my$urls=$_->urls;$_->urls=[map{$prefix.$_}@$urls]}} 49 | sub init{$_->init for(@{$_[0]."::O"});%{$_[0]."::Controllers::C"}= 50 | map{$_->name=>$_}@{$_[0]."::Controllers::C"}; 51 | %{$_[0]."::Views::V"}=map{$_->name=>$_}@{$_[0]."::Views::V"}} 52 | sub service{my($app,$c,@args)=grep{defined}@_;my$method=lc 53 | $c->env->{REQUEST_METHOD};my$content;eval{$content=$c->$method(@args)}; 54 | warn"EXCEPTION: $@"if($@);my$cookies=$c->cookies;$c->headers->{'Set-Cookie'}= 55 | join("; ",map{CGI::Cookie->new(-name=>$_,%{$cookies->{$_}})} 56 | grep{ref$cookies->{$_}eq'HASH'}keys %$cookies)if(%$cookies);$content} 57 | package Squatting::View;sub new{ 58 | my$class=shift;my$name=shift;bless{name=>$name,@_}=>$class} 59 | sub name:lvalue{$_[0]->{name}};sub headers:lvalue{$_[0]->{headers}} 60 | sub _render{my($self,$template,$vars,$alt)=@_;$self->{template}=$template; 61 | if(exists$self->{layout}&&($template!~/^_/)){$template=$alt if defined$alt; 62 | $self->{layout}($self,$vars,$self->{$template}($self,$vars)); 63 | }else{$template=$alt if defined $alt;$self->{$template}($self,$vars)}} 64 | sub AUTOLOAD{my($self,$vars)=@_;my$template=$AUTOLOAD; 65 | $template=~s/.*://;if(exists$self->{$template}&&ref($self->{$template})eq 66 | 'CODE'){$self->_render($template,$vars)}elsif(exists$self->{_}){ 67 | $self->_render($template,$vars,'_')}else{die( 68 | "$template cannot be rendered.")}};sub DESTROY{};1; 69 | -------------------------------------------------------------------------------- /t/00_basic.t: -------------------------------------------------------------------------------- 1 | use Test::More qw(no_plan); 2 | 3 | BEGIN { use_ok('Squatting') } 4 | -------------------------------------------------------------------------------- /t/01_controller.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | use strict; 3 | use warnings; 4 | 5 | { 6 | package Foo; 7 | use Squatting; 8 | 9 | package Foo::Controllers; 10 | our @C = ( 11 | C( 12 | 'Home' => ['/'], 13 | get => sub { 14 | "home"; 15 | } 16 | ) 17 | ); 18 | } 19 | 20 | sub c { 21 | $Foo::Controllers::C[0] 22 | } 23 | 24 | our @tests = ( 25 | 26 | sub { 27 | my $c = c; 28 | isa_ok($c, 'Squatting::Controller'); 29 | return $c; 30 | }, 31 | 32 | sub { 33 | my $c = c; 34 | can_ok($c, qw(name urls cr env input cookies state v status headers view app)); 35 | }, 36 | 37 | sub { 38 | my $c = c; 39 | $c->{headers} = { }; 40 | $c->redirect('/foo'); 41 | ok($c->headers->{Location} eq '/foo' && $c->status == 302, '$c->redirect should set the Location header to /foo and the status to 302.') 42 | }, 43 | 44 | sub { 45 | my $c = c; 46 | ok($c->get eq "home", '$c->get should return the content for a GET request.'); 47 | } 48 | 49 | ); 50 | 51 | plan tests => scalar(@tests); 52 | 53 | for my $test (@tests) { $test->() } 54 | -------------------------------------------------------------------------------- /t/02_view.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | use strict; 3 | use warnings; 4 | 5 | { 6 | package Foo; 7 | use Squatting; 8 | 9 | package Foo::Views; 10 | use Data::Dump 'pp'; 11 | our @V = ( 12 | V( 13 | 'html', 14 | layout => sub { 15 | my ($self, $v, @content) = @_; 16 | "( @content )"; 17 | }, 18 | home => sub { 19 | my ($self, $v) = @_; 20 | "$v->{title}"; 21 | }, 22 | _menu => sub { 23 | my ($self, $v) = @_; 24 | "1 2 3 4 5"; 25 | }, 26 | _ => sub { 27 | my ($self, $v) = @_; 28 | "$self->{template}"; 29 | } 30 | ) 31 | ); 32 | } 33 | 34 | sub v { 35 | $Foo::Views::V[0] 36 | } 37 | 38 | our @tests = ( 39 | 40 | sub { 41 | my $v = v; 42 | isa_ok($v, 'Squatting::View'); 43 | return $v; 44 | }, 45 | 46 | sub { 47 | my $v = v; 48 | can_ok($v, qw(name headers _render)); 49 | }, 50 | 51 | sub { 52 | my $v = v; 53 | my $body = $v->home({ title => 'home' }); 54 | ok($body eq "( home )", '$v->home({ title => "home" }) should be wrapped by the layout.'); 55 | }, 56 | 57 | sub { 58 | my $v = v; 59 | my $body = $v->_menu({}); 60 | ok($body eq "1 2 3 4 5", '$v->_menu({}) should NOT be wrapped by the layout.'); 61 | }, 62 | 63 | sub { 64 | my $v = v; 65 | my $body = $v->missing({}); 66 | ok($body eq "( missing )", '$v->missing({}) should 1) invoke the _ template, 2) set $self->{template}, and 3) be wrapped by layout.'); 67 | }, 68 | 69 | sub { 70 | my $v = v; 71 | my $body = $v->_missing({}); 72 | ok($body eq "_missing", '$v->_missing({}) should 1) invoke the _ template, 2) set $self->{template}, and 3) NOT be wrapped by layout.'); 73 | }, 74 | 75 | ); 76 | 77 | plan tests => scalar(@tests); 78 | 79 | for my $test (@tests) { $test->() } 80 | -------------------------------------------------------------------------------- /t/20_squatting_with_log.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Squatting::With::Log; 5 | 6 | my $Log = $Squatting::With::Log::Log; 7 | 8 | our @tests = ( 9 | 10 | sub { 11 | can_ok($Log, qw(_path enable disable levels debug info warn error fatal is_debug is_info is_warn is_error is_fatal)); 12 | }, 13 | 14 | sub { 15 | my $log = $Log->clone(); 16 | ok($log->_path eq '=', "The log should output to STDERR by default."); 17 | }, 18 | 19 | sub { 20 | my $log = $Log->clone(); 21 | ok((not $log->is_debug), "The debug level should be OFF by default."); 22 | }, 23 | 24 | sub { 25 | my $log = $Log->clone(); 26 | $log->enable('debug'); 27 | ok($log->is_debug, "The enable method should turn a level on."); 28 | }, 29 | 30 | ); 31 | 32 | plan tests => scalar(@tests); 33 | 34 | for my $test (@tests) { $test->() } 35 | -------------------------------------------------------------------------------- /xt/01_podspell.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | eval q{ use Test::Spelling }; 3 | plan skip_all => "Test::Spelling is not installed." if $@; 4 | add_stopwords(map { split /[\s\:\-]/ } ); 5 | $ENV{LANG} = 'C'; 6 | all_pod_files_spelling_ok('lib'); 7 | __DATA__ 8 | Default Name 9 | default {at} example.com 10 | squatting 11 | -------------------------------------------------------------------------------- /xt/02_perlcritic.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More; 3 | eval { 4 | require Test::Perl::Critic; 5 | Test::Perl::Critic->import( -profile => 'xt/perlcriticrc'); 6 | }; 7 | plan skip_all => "Test::Perl::Critic is not installed." if $@; 8 | all_critic_ok('lib'); 9 | -------------------------------------------------------------------------------- /xt/03_pod.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | eval "use Test::Pod 1.00"; 3 | plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; 4 | all_pod_files_ok(); 5 | -------------------------------------------------------------------------------- /xt/04_kwalitee.t: -------------------------------------------------------------------------------- 1 | BEGIN { # limited to release test 2 | unless ($ENV{RELEASE_TESTING}) { # or $ENV{AUTHOR_TESTING} for author test 3 | require Test::More; 4 | Test::More::plan(skip_all => 'these tests are for release candidate testing'); 5 | } 6 | } 7 | 8 | use Test::More; 9 | eval { require Test::Kwalitee::Extra; Test::Kwalitee::Extra->import(qw( )); }; 10 | plan( skip_all => "Test::Kwalitee::Extra not installed: $@; skipping") if $@; 11 | -------------------------------------------------------------------------------- /xt/perlcriticrc: -------------------------------------------------------------------------------- 1 | [TestingAndDebugging::ProhibitNoStrict] 2 | allow=refs 3 | --------------------------------------------------------------------------------