diff options
134 files changed, 15397 insertions, 489 deletions
diff --git a/.gitignore b/.gitignore index cce185f08..dfba54be6 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,10 @@ /cities_bin /private_locale ._* +.DS_Store +local-lib5 +META.yml +Makefile +blib/ +inc/ .sass-cache - diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 000000000..154cf9052 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,44 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use inc::Module::Install; +use Module::Install::Catalyst; + +name 'FixMyStreet-App'; +all_from 'perllib/FixMyStreet/App.pm'; + +requires 'Catalyst::Action::RenderView'; +requires 'Catalyst::Authentication::Store::DBIx::Class'; +requires 'Catalyst::Model::Adaptor'; +requires 'Catalyst::Plugin::Authentication'; +requires 'Catalyst::Plugin::ConfigLoader'; +requires 'Catalyst::Plugin::Session::Store::DBIC'; +requires 'Catalyst::Plugin::Static::Simple'; +requires 'Catalyst::Runtime' => '5.80031'; +requires 'Catalyst::View::TT'; +requires 'Config::General'; +requires 'DBD::Pg' => '2.9.2'; +requires 'DBIx::Class::Schema::Loader'; +requires 'Email::Send'; +requires 'Email::Simple'; +requires 'Email::Valid'; +requires 'HTML::Entities'; +requires 'IO::String'; +requires 'Moose'; +requires 'namespace::autoclean'; +requires 'Net::Domain::TLD'; +requires 'Path::Class'; +requires 'Readonly'; +requires 'Sort::Key'; + +test_requires 'Test::More' => '0.88'; +test_requires 'Test::WWW::Mechanize::Catalyst'; +test_requires 'Sub::Override'; + +catalyst; + +install_script glob('script/*.pl'); +auto_install; +WriteAll; diff --git a/TODO.txt b/TODO.txt new file mode 100644 index 000000000..8d90a4b64 --- /dev/null +++ b/TODO.txt @@ -0,0 +1,31 @@ + +Add users to system: + * script to migrate database + * best phone for users from problems + +Auth: + * add 'remember me' option on login. + * limit session to this browser session on create account + * redirect back to page they came from on login + +Problem creation: + ? what should the new flow be for not-logged-in (probably unchanged). + * after becoming confirmed require user to manually send off 'pending' reports + +Users: + * create a message to the user if they have reports which have not been + confirmed. + +Email: + * currently don't send email via EvEl or do any of the smarts it does - should + we switch to using it (Email::Send::EvEl...)? + +Framework: + * use Plack to handle all the redirects and also run cgi scripts - get apache + out of the picture (what about tile proxy...). Does this makes sense? + + + +Future ideas: + * dashboard for council to put on big screen +
\ No newline at end of file diff --git a/conf/httpd.conf b/conf/httpd.conf index d9d564f79..0a8323e69 100644 --- a/conf/httpd.conf +++ b/conf/httpd.conf @@ -33,16 +33,15 @@ # </VirtualHost> # # -# Copyright (c) 2006 UK Citizens Online Democracy. All rights reserved. Email: -# francis@mysociety.org; WWW: http://www.mysociety.org -# -# $Id: httpd.conf,v 1.40 2009-10-21 15:22:36 louise Exp $ +# Copyright (c) 2011 UK Citizens Online Democracy. All rights reserved. +# Email: team@mysociety.org +# WWW: http://www.mysociety.org DirectoryIndex index.cgi RewriteEngine on -#RewriteLog /var/log/apache2/rewrite.log -#RewriteLogLevel 3 +# RewriteLog /var/log/apache2/rewrite.log +# RewriteLogLevel 3 # End slashes goodbye RewriteRule ^/admin/ - [L] @@ -50,56 +49,79 @@ RewriteCond %{DOCUMENT_ROOT}%{REQUEST_URI} !-d RewriteRule ^(.+)/$ $1 [R=permanent] # Confirmation tokens -RewriteRule ^/[Aa]/([0-9A-Za-z]{16,18}).*$ /alert.cgi?token=$1 [QSA] -RewriteRule ^/[Cc]/([0-9A-Za-z]{16,18}).*$ /confirm.cgi?type=update;token=$1 [QSA] -RewriteRule ^/[Pp]/([0-9A-Za-z]{16,18}).*$ /confirm.cgi?type=problem;token=$1 [QSA] -RewriteRule ^/[Qq]/([0-9A-Za-z]{16,18}).*$ /questionnaire.cgi?token=$1 [QSA] -RewriteRule ^/[Ff]/([0-9A-Za-z]{16,18}).*$ /flickr.cgi?token=$1 -RewriteRule ^/[Ll]/([0-9A-Za-z]{16,18}).*$ /index.cgi?partial_token=$1 -RewriteRule ^/[Tt]/([0-9A-Za-z]{16,18}).*$ /tms-signup.cgi?token=$1 +RewriteRule ^/[Aa]/([0-9A-Za-z]{16,18}).*$ /alert.cgi?token=$1 [QSA,L] +RewriteRule ^/[Cc]/([0-9A-Za-z]{16,18}).*$ /confirm.cgi?type=update;token=$1 [QSA,L] +RewriteRule ^/[Qq]/([0-9A-Za-z]{16,18}).*$ /questionnaire.cgi?token=$1 [QSA,L] +RewriteRule ^/[Ff]/([0-9A-Za-z]{16,18}).*$ /flickr.cgi?token=$1 [L] +RewriteRule ^/[Tt]/([0-9A-Za-z]{16,18}).*$ /tms-signup.cgi?token=$1 [L] # RSS feeds for updates on a problem -RewriteRule ^/rss/([0-9]+)$ /rss.cgi?type=new_updates;id=$1 [QSA] +RewriteRule ^/rss/([0-9]+)$ /rss.cgi?type=new_updates;id=$1 [QSA,L] # RSS feeds for new local problems -RewriteRule ^/rss/([0-9]+)[,/]([0-9]+)$ /rss.cgi?type=local_problems;x=$1;y=$2 [QSA] -RewriteRule ^/rss/n/([0-9]+)[,/]([0-9]+)$ /rss.cgi?type=local_problems;e=$1;n=$2 [QSA] -RewriteRule ^/rss/l/([0-9.-]+)[,/]([0-9.-]+)$ /rss.cgi?type=local_problems;lat=$1;lon=$2 [QSA] -RewriteRule ^/rss/([0-9]+)[,/]([0-9]+)/([0-9]+)$ /rss.cgi?type=local_problems;x=$1;y=$2;d=$3 [QSA] -RewriteRule ^/rss/n/([0-9]+)[,/]([0-9]+)/([0-9]+)$ /rss.cgi?type=local_problems;e=$1;n=$2;d=$3 [QSA] -RewriteRule ^/rss/l/([0-9.-]+)[,/]([0-9.-]+)/([0-9]+)$ /rss.cgi?type=local_problems;lat=$1;lon=$2;d=$3 [QSA] -RewriteRule ^/rss/pc/(.*)/([0-9]+)$ /rss.cgi?type=local_problems;pc=$1;d=$2 [QSA] -RewriteRule ^/rss/pc/(.*)$ /rss.cgi?type=local_problems;pc=$1 [QSA] -RewriteRule ^/rss/problems$ /rss.cgi?type=new_problems [QSA] +RewriteRule ^/rss/([0-9]+)[,/]([0-9]+)$ /rss.cgi?type=local_problems;x=$1;y=$2 [QSA,L] +RewriteRule ^/rss/n/([0-9]+)[,/]([0-9]+)$ /rss.cgi?type=local_problems;e=$1;n=$2 [QSA,L] +RewriteRule ^/rss/l/([0-9.-]+)[,/]([0-9.-]+)$ /rss.cgi?type=local_problems;lat=$1;lon=$2 [QSA,L] +RewriteRule ^/rss/([0-9]+)[,/]([0-9]+)/([0-9]+)$ /rss.cgi?type=local_problems;x=$1;y=$2;d=$3 [QSA,L] +RewriteRule ^/rss/n/([0-9]+)[,/]([0-9]+)/([0-9]+)$ /rss.cgi?type=local_problems;e=$1;n=$2;d=$3 [QSA,L] +RewriteRule ^/rss/l/([0-9.-]+)[,/]([0-9.-]+)/([0-9]+)$ /rss.cgi?type=local_problems;lat=$1;lon=$2;d=$3 [QSA,L] +RewriteRule ^/rss/pc/(.*)/([0-9]+)$ /rss.cgi?type=local_problems;pc=$1;d=$2 [QSA,L] +RewriteRule ^/rss/pc/(.*)$ /rss.cgi?type=local_problems;pc=$1 [QSA,L] +RewriteRule ^/rss/problems$ /rss.cgi?type=new_problems [QSA,L] # RSS feeds for voting areas -RewriteRule ^/rss/council/([0-9]+)$ /rss/reports/$1 [R=permanent] -RewriteRule ^/report$ /reports [R=permanent] -RewriteRule ^/reports/([^/]+)/all$ /reports.cgi?council=$1;all=1 [QSA] -RewriteRule ^/reports/([^/]+)/([^/]+)$ /reports.cgi?council=$1;ward=$2 [QSA] -RewriteRule ^/rss/(reports|area)/([^/]+)/([^/]+)$ /reports.cgi?rss=$1;council=$2;ward=$3 [QSA] -RewriteRule ^/reports/([^/]+)$ /reports.cgi?council=$1 [QSA] -RewriteRule ^/rss/area/([0-9]+)$ /rss.cgi?type=area_problems;id=$1 [QSA] -RewriteRule ^/rss/(reports|area)/([^/]+)$ /reports.cgi?rss=$1;council=$2 [QSA] +RewriteRule ^/rss/council/([0-9]+)$ /rss/reports/$1 [R=permanent,L] +RewriteRule ^/report$ /reports [R=permanent,L] +RewriteRule ^/reports/([^/]+)/all$ /reports.cgi?council=$1;all=1 [QSA,L] +RewriteRule ^/reports/([^/]+)/([^/]+)$ /reports.cgi?council=$1;ward=$2 [QSA,L] +RewriteRule ^/rss/(reports|area)/([^/]+)/([^/]+)$ /reports.cgi?rss=$1;council=$2;ward=$3 [QSA,L] +RewriteRule ^/reports/([^/]+)$ /reports.cgi?council=$1 [QSA,L] +RewriteRule ^/rss/area/([0-9]+)$ /rss.cgi?type=area_problems;id=$1 [QSA,L] +RewriteRule ^/rss/(reports|area)/([^/]+)$ /reports.cgi?rss=$1;council=$2 [QSA,L] # Fix incorrect RSS urls caused by my stupidity -RewriteRule ^/{/rss/(.*)}$ /rss/$1 [R=permanent] -RewriteRule ^/reports/{/rss/(.*)}$ /rss/$1 [R=permanent] +RewriteRule ^/{/rss/(.*)}$ /rss/$1 [R=permanent,L] +RewriteRule ^/reports/{/rss/(.*)}$ /rss/$1 [R=permanent,L] -RewriteRule ^/report/([0-9]+)$ /index.cgi?id=$1 [QSA] -RewriteRule ^/report/([0-9]+) /report/$1 [R] -RewriteRule ^/alerts/?$ /alert [R=permanent] +RewriteRule ^/report/([0-9]+)$ /index.cgi?id=$1 [QSA,L] +RewriteRule ^/report/([0-9]+) /report/$1 [R,L] +RewriteRule ^/alerts/?$ /alert [R=permanent,L] # JSON API for summaries of reports -RewriteRule ^/json/problems/new$ /json.cgi?type=new_problems [QSA] -RewriteRule ^/json/problems/fixed$ /json.cgi?type=fixed_problems [QSA] +RewriteRule ^/json/problems/new$ /json.cgi?type=new_problems [QSA,L] +RewriteRule ^/json/problems/fixed$ /json.cgi?type=fixed_problems [QSA,L] -ProxyPass /tilma/ http://tilma.mysociety.org/ +ProxyPass /tilma/ http://tilma.mysociety.org/ ProxyPassReverse /tilma/ http://tilma.mysociety.org/ -# CGI files can be referred without CGI -RewriteCond %{DOCUMENT_ROOT}%{REQUEST_URI}.cgi -f -RewriteRule /(.+) /$1.cgi - # S. Cambs RewriteRule ^/images/southcambridgeshiredistrictcouncil/icons/internet/print.gif$ http://www.scambs.gov.uk/images/southcambridgeshiredistrictcouncil/icons/internet/print.gif [R=permanent] + +# serve static files directly +RewriteCond %{DOCUMENT_ROOT}%{REQUEST_URI} -f +RewriteRule /(.+) /$1 [L] + +# Explicitly capture all cgi files so that we can remove them one by one +RewriteRule ^/ajax(.*) /ajax.cgi$1 [L] +RewriteRule ^/alert(.*) /alert.cgi$1 [L] +RewriteRule ^/confirm(.*) /confirm.cgi$1 [L] +RewriteRule ^/contact(.*) /contact.cgi$1 [L] +RewriteRule ^/flickr(.*) /flickr.cgi$1 [L] +RewriteRule ^/fun(.*) /fun.cgi$1 [L] +RewriteRule ^/$ /index.cgi [L] +RewriteRule ^/index(.*) /index.cgi$1 [L] +RewriteRule ^/json(.*) /json.cgi$1 [L] +RewriteRule ^/photo(.*) /photo.cgi$1 [L] +RewriteRule ^/questionnaire(.*) /questionnaire.cgi$1 [L] +RewriteRule ^/reports(.*) /reports.cgi$1 [L] +RewriteRule ^/rss(.*) /rss.cgi$1 [L] +RewriteRule ^/test(.*) /test.cgi$1 [L] +RewriteRule ^/tms-signup(.*) /tms-signup.cgi$1 [L] +RewriteRule ^/upload(.*) /upload.cgi$1 [L] + +# trap anything that reaches us here and send it to the Catalyst app - this is +# so that we can gradually move functionality into the app without having to +# touch the existing code. +RewriteRule ^(.*)$ /fixmystreet_app_cgi.cgi$1 [L] + + diff --git a/conf/packages b/conf/packages index b8324300d..7828cc699 100644 --- a/conf/packages +++ b/conf/packages @@ -28,4 +28,7 @@ libmath-bigint-gmp-perl libtext-template-perl gettext libtest-exception-perl +libipc-run3-perl +libyaml-perl +liblist-moreutils-perl libhaml-ruby diff --git a/db/rerun_dbic_loader.pl b/db/rerun_dbic_loader.pl new file mode 100755 index 000000000..13316ad09 --- /dev/null +++ b/db/rerun_dbic_loader.pl @@ -0,0 +1,46 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +# This script inspects the current state of the database and then ammends the +# FixMyStreet::DB::Result::* files to suit. After running the changes should be +# inspected before the code is commited. + +use FixMyStreet; +use DBIx::Class::Schema::Loader qw/ make_schema_at /; + +# create a exclude statement that filters out the table that we are not +# interested in +my @tables_to_ignore = ( + 'admin_log', # + 'alert', # + 'alert_sent', # + 'alert_type', # + 'comment', # + 'contacts_history', # + 'debugdate', # + 'flickr_imported', # + 'partial_user', # + 'questionnaire', # + 'secret', # + 'textmystreet', # +); +my $exclude = '^(?:' . join( '|', @tables_to_ignore ) . ')$'; + +make_schema_at( + 'FixMyStreet::DB', + { + debug => 0, # switch on to be chatty + dump_directory => './lib', # edit files in place + exclude => qr{$exclude}, # ignore some tables + generate_pod => 0, # no need for pod + overwrite_modifications => 1, # don't worry that the md5 is wrong + + # add in some extra components + components => ['FilterColumn'], + + }, + FixMyStreet->dbic_connect_info(), +); + diff --git a/db/schema_0001-add_sessions_and_users_and_dbic_fields.sql b/db/schema_0001-add_sessions_and_users_and_dbic_fields.sql new file mode 100644 index 000000000..315cf2fda --- /dev/null +++ b/db/schema_0001-add_sessions_and_users_and_dbic_fields.sql @@ -0,0 +1,37 @@ +-- These are changes needed to the schema to support moving over to DBIx::Class + +begin; + +-- table for sessions - needed by Catalyst::Plugin::Session::Store::DBIC +CREATE TABLE sessions ( + id CHAR(72) PRIMARY KEY, + session_data TEXT, + expires INTEGER +); + +-- users table +create table users ( + id serial not null primary key, + email text not null unique, + name text, + phone text, + password text not null default '' +); + +-- add PK to contacts table +ALTER TABLE contacts + ADD COLUMN id SERIAL PRIMARY KEY; + +AlTER TABLE contacts_history + ADD COLUMN contact_id integer; + +update contacts_history + set contact_id = ( + select id + from contacts + where contacts_history.category = contacts.category + and contacts_history.area_id = contacts.area_id + ); + +-- rollback; +commit; diff --git a/db/schema_0002-create_users_from_problems_and_link.sql b/db/schema_0002-create_users_from_problems_and_link.sql new file mode 100644 index 000000000..bfb502a96 --- /dev/null +++ b/db/schema_0002-create_users_from_problems_and_link.sql @@ -0,0 +1,53 @@ +-- link the problems to the users, creating the users as required. Removes the +-- email field from the problems. +-- +-- Uses the most recently used non-anonymmous name as the name for the user. + +begin; + +-- create users from the problems +INSERT INTO users (email) + SELECT distinct( lower( email ) ) FROM problem; + +-- add a user id to the problems +ALTER TABLE problem + ADD COLUMN user_id INT REFERENCES users(id); + +-- populate the user_ids +update problem + set user_id = ( + select id + from users + where users.email = lower( problem.email ) + ); + +-- create the index now that the entries have been made +create index problem_user_id_idx on problem ( user_id ); + +-- add names from the problems +UPDATE users + SET name = ( + select name from problem + where user_id = users.id + order by created desc + limit 1 + ), + phone = ( + select phone from problem + where user_id = users.id + order by created desc + limit 1 + ); + + +-- make the problems user id not null etc +ALTER TABLE problem + ALTER COLUMN user_id SET NOT NULL; + +-- drop emails from the problems +ALTER TABLE problem + DROP COLUMN email; +ALTER TABLE problem + DROP COLUMN phone; + +commit; @@ -0,0 +1 @@ +perllib
\ No newline at end of file diff --git a/notes/INSTALL b/notes/INSTALL index fcb1f5579..2a1dba635 100644 --- a/notes/INSTALL +++ b/notes/INSTALL @@ -39,7 +39,7 @@ sudo apt-get install `cat conf/packages` # also install these that are available by default on mySoc boxes: sudo apt-get install \ - libregexp-common-perl php5-cli perl-doc libtest-exception-perl + libregexp-common-perl php5-cli perl-doc libtest-exception-perl locales-all # SETTING UP APACHE diff --git a/notes/INSTALL-catalyst.txt b/notes/INSTALL-catalyst.txt new file mode 100644 index 000000000..c3dfd0256 --- /dev/null +++ b/notes/INSTALL-catalyst.txt @@ -0,0 +1,107 @@ +These are notes on how to get the Catalyst version of FMS up and running during the change from Apache/CGI based code to pure Catalyst based code. + +########## location ############ + +Pretty much everything that follows assumes that you run the commands from the root of the fixmystreet project. + + +########## setup environment ########### + +There is a little script that is used to setup the correct environment needed for FMS to run (perl library paths, cpan install locations, bin paths etc). It can either be evaled in a bash shell to set environment variables: + + eval `./setenv.pl` + +or used as a runner to start scripts (eg in cron): + + setenv.pl some_script + + +########## build CPAN dependecies ########### + +There are many CPAN dependencies that should be dealt with using module-manage.pl which takes care of fetching specific versions of packages from CPAN and building them. To install all the CPAN packages needed: + + eval `./setenv.pl` + module-manage.pl setup + +Look in the perl-external directory for details. Notably the following are important: + +urls.txt - url to the specific packages to fetch +modules.txt - list of all modules that need to be built +minicpan/ - local subset of cpan - used as source for all packages +local-lib - where the cpan modules get built to +lib - some initial modules needed for bootstrap +bin - scripts to make it all work + +Read the perl-external/bin/module-manage.pl code to see how it all works. It is basically a wrapper around cpanm (which builds the packages) and dpan (which helps maintain the fake cpan subset). + +If you need to add a module do it using: + + module-manage.pl add Module::To::Add + +and it will update all the relevant bits. + +If a module won't build (Test::WWW::Mechanize and HTTP::Server::Simple fail tests for me but the failures are not pertinent) then the module-manage script will bail out. Look in ~/.cpanm/build_log to see what went wrong. You can force an install if the test failures are not important by running cpanm directly: + + cpanm \ + --mirror /absolute/path/to/perl-external/minicpan \ + --mirror-only \ + --force \ + Test::WWW::Mechanize + +Hopefully once it is all built we can put something like this into the exec in vhosts.pl to make sure that the setup is current: + + setenv.pl module-manage.pl setup + + +Note: Others are starting to work on this and it might be a good idea to switch +to their output: +http://blogs.perl.org/users/sebastian_willert/2011/03/how-i-distribute-my-projects.html + + +############ running the code (dev server) ############ + +Start the catalyst dev server using: + + CATALYST_DEBUG=1 ./script/fixmystreet_app_server.pl -r + +CATALYST_DEBUG turns on the very verbose debug output which is helpful to see what the code is actually doing. The '-r' flag watches for files to change and then restarts the dev server. + + +############ running the code (under Apache) ############# + +The Catalyst App (FixMyStreet::App) is the last thing that gets tried by apache if none of the redirects in httpd.conf get triggered. This means that the existing code can run unchanged and the bits we want to have Catalyst process just get removed from the redirects. + +Currently the httpd.conf runs the FixMyStreet::App as a cgi (rather than fastcgi) which means that the startup hit happens everytime. In production this should probably be fastcgi, or we could go all hip and use the psgi interface. Whatevah! + + +################ databases ###################### + +The database modifications needed are in the scripts 'db/schema_00*' which should be applied in order. + +After further changes to the schema the script 'db/rerun_dbic_loader.pl' should be run to inspect the database and update the model files in perllib/FixMyStreet/DB/Result. Also note that several tables are ignored in that script but just deleting them from the ignore list will cause code to be generated for them. + +The DBIx::Class code is pulled into the FixMyStreet::App using FixMyStreet::App::Model::DB which is just a thin wrapper. The separation is there so that the models can be easily used outside of Catalyst (eg in the utility scripts). + +The DBIx::Class code uses a separate DBI connection than the mySociety::DBHandler code. This is due to different assumptions about the transaction commit policy. + + +########## What's where in the code? ############## + +FixMyStreet::App is a fairly standard Catalyst app, there aren't any really big surprises. + +Note that the FixMyStree.pm file is used though to abstract some config related things. Note the FixMyStreet->test_mode(1) which will do things like send all emails to a memory queue for the test scripts. test_mode should only be used in test scripts, and so is different from setting STAGING to true. + + +############## testing ################## + +There are several tests in the t directory - organized into subdirs. Note that there is a module FixMyStreet::TestMech that abstracts some things like logging in as a user and grabbing all the form error messages. This makes testing much slicker and less fiddly. + +Run all the tests using: + + prove -lr t + +or a specific test in verbose mode using: + + prove -lv t/app/controller/report_new.t + +For all the lovely options do 'prove --help'. Note I've made no attempt to make the tests be able to run in parallel, the database fiddling would not be worth it.
\ No newline at end of file diff --git a/notes/catalyst-master-merge-todos.txt b/notes/catalyst-master-merge-todos.txt new file mode 100644 index 000000000..ead633331 --- /dev/null +++ b/notes/catalyst-master-merge-todos.txt @@ -0,0 +1,7 @@ +convert templates for new micro sites (or switch old code to use new headers and footers) + +should we ditch flickr import? (does not seem to be getting huge usage and those using it would probably report using another method: http://www.flickr.com/search/?w=all&q=fixmystreet&m=tags) + +add 'remember me on this computer' to auth login. What should default session lifetime be? Waiting for answer on http://lists.scsys.co.uk/pipermail/catalyst/2011-April/date.html + +merge in from master diff --git a/perl-external/.gitignore b/perl-external/.gitignore new file mode 100644 index 000000000..8db64e38e --- /dev/null +++ b/perl-external/.gitignore @@ -0,0 +1 @@ +local-lib diff --git a/perl-external/bin/cpanm b/perl-external/bin/cpanm new file mode 100755 index 000000000..1c552fac2 --- /dev/null +++ b/perl-external/bin/cpanm @@ -0,0 +1,6671 @@ +#!/usr/bin/env perl +# +# You want to install cpanminus? Run the following command and it will +# install itself for you. You might want to run it as a root with sudo +# if you want to install to places like /usr/local/bin. +# +# % curl -L http://cpanmin.us | perl - --self-upgrade +# +# If you don't have curl but wget, replace `curl -L` with `wget -O -`. +# +# For more details about this program, visit http://search.cpan.org/dist/App-cpanminus +# +# DO NOT EDIT -- this is an auto generated file +# This chunk of stuff was generated by App::FatPacker. To find the original +# file's code, look for the end of this BEGIN block or the string 'FATPACK' +BEGIN { +my %fatpacked; + +$fatpacked{"App/cpanminus.pm"} = <<'APP_CPANMINUS'; + package App::cpanminus; + our $VERSION = "1.3001"; + + =head1 NAME + + App::cpanminus - get, unpack, build and install modules from CPAN + + =head1 SYNOPSIS + + cpanm Module + + Run C<cpanm -h> for more options. + + =head1 DESCRIPTION + + cpanminus is a script to get, unpack, build and install modules from + CPAN and does nothing else. + + It's dependency free (can bootstrap itself), requires zero + configuration, and stands alone. When running, it requires only 10MB + of RAM. + + =head1 INSTALLATION + + There are several ways to install cpanminus to your system. + + =head2 Package management system + + There are Debian packages, RPMs, FreeBSD ports, and packages for other + operation systems available. If you want to use the package management system, + search for cpanminus and use the appropriate command to install. This makes it + easy to install C<cpanm> to your system without thinking about where to + install, and later upgrade. + + =head2 Installing to system perl + + You can also use the latest cpanminus to install cpanminus itself: + + curl -L http://cpanmin.us | perl - --sudo App::cpanminus + + This will install C<cpanm> to your bin directory like + C</usr/local/bin> (unless you configured C<INSTALL_BASE> with + L<local::lib>), so you probably need the C<--sudo> option. + + =head2 Installing to local perl (perlbrew) + + If you have perl in your home directory, which is the case if you use + tools like L<perlbrew>, you don't need the C<--sudo> option, since + you're most likely to have a write permission to the perl's library + path. You can just do: + + curl -L http://cpanmin.us | perl - App::cpanminus + + to install the C<cpanm> executable to the perl's bin path, like + C<~/perl5/perlbrew/bin/cpanm>. + + =head2 Downloaing the standalone executable + + You can also copy the standalone executable to whatever location you'd like. + + cd ~/bin + curl -LO http://xrl.us/cpanm + chmod +x cpanm + # edit shebang if you don't have /usr/bin/env + + This just works, but be sure to grab the new version manually when you + upgrade because C<--self-upgrade> might not work for this. + + =head1 DEPENDENCIES + + perl 5.8 or later. + + =over 4 + + =item * + + 'tar' executable (bsdtar or GNU tar version 1.22 are rcommended) or Archive::Tar to unpack files. + + =item * + + C compiler, if you want to build XS modules. + + =item * + + make + + =item * + + Module::Build (core in 5.10) + + =back + + =head1 QUESTIONS + + =head2 Another CPAN installer? + + OK, the first motivation was this: the CPAN shell runs out of memory (or swaps + heavily and gets really slow) on Slicehost/linode's most affordable plan with + only 256MB RAM. Should I pay more to install perl modules from CPAN? I don't + think so. + + =head2 But why a new client? + + First of all, let me be clear that CPAN and CPANPLUS are great tools + I've used for I<literally> years (you know how many modules I have on + CPAN, right?). I really respect their efforts of maintaining the most + important tools in the CPAN toolchain ecosystem. + + However, for less experienced users (mostly from outside the Perl community), + or even really experienced Perl developers who know how to shoot themselves in + their feet, setting up the CPAN toolchain often feels like yak shaving, + especially when all they want to do is just install some modules and start + writing code. + + =head2 Zero-conf? How does this module get/parse/update the CPAN index? + + It queries the CPAN Meta DB site running on Google AppEngine at + L<http://cpanmetadb.appspot.com/>. The site is updated every hour to reflect + the latest changes from fast syncing mirrors. The script then also falls back + to scrape the site L<http://search.cpan.org/>. + + Fetched files are unpacked in C<~/.cpanm> and automatically cleaned up + periodically. You can configure the location of this with the + C<PERL_CPANM_HOME> environment variable. + + =head2 Where does this install modules to? Do I need root access? + + It installs to wherever ExtUtils::MakeMaker and Module::Build are + configured to (via C<PERL_MM_OPT> and C<PERL_MB_OPT>). So if you're + using local::lib, then it installs to your local perl5 + directory. Otherwise it installs to the site_perl directory that + belongs to your perl. + + cpanminus at a boot time checks whether you have configured + local::lib, or have the permission to install modules to the site_perl + directory. If neither, it automatically sets up local::lib compatible + installation path in a C<perl5> directory under your home + directory. To avoid this, run the script as the root user, with + C<--sudo> option or with C<--local-lib> option. + + =head2 cpanminus can't install the module XYZ. Is it a bug? + + It is more likely a problem with the distribution itself. cpanminus + doesn't support or is known to have issues with distributions like as + follows: + + =over 4 + + =item * + + Tests that require input from STDIN. + + =item * + + Tests that might fail when C<AUTOMATED_TESTING> is enabled. + + =item * + + Modules that have invalid numeric values as VERSION (such as C<1.1a>) + + =back + + These failures can be reported back to the author of the module so + that they can fix it accordingly, rather than me. + + =head2 Does cpanm support the feature XYZ of L<CPAN> and L<CPANPLUS>? + + Most likely not. Here are the things that cpanm doesn't do by + itself. And it's a feature - you got that from the name I<minus>, + right? + + If you need these features, use L<CPAN>, L<CPANPLUS> or the standalone + tools that are mentioned. + + =over 4 + + =item * + + Bundle:: module dependencies + + =item * + + CPAN testers reporting + + =item * + + Building RPM packages from CPAN modules + + =item * + + Listing the outdated modules that needs upgrading. See L<cpan-outdated> + + =item * + + Uninstalling modules. See L<pm-uninstall>. + + =item * + + Showing the changes of the modules you're about to upgrade. See L<cpan-listchanges> + + =item * + + Patching CPAN modules with distroprefs. + + =back + + See L<cpanm> or C<cpanm -h> to see what cpanminus I<can> do :) + + =head1 COPYRIGHT + + Copyright 2010- Tatsuhiko Miyagawa + + The standalone executable contains the following modules embedded. + + =over 4 + + =item L<CPAN::DistnameInfo> Copyright 2003 Graham Barr + + =item L<Parse::CPAN::Meta> Copyright 2006-2009 Adam Kennedy + + =item L<local::lib> Copyright 2007-2009 Matt S Trout + + =item L<HTTP::Tiny> Copyright 2011 Christian Hansen + + =item L<Module::Metadata> Copyright 2001-2006 Ken Williams. 2010 Matt S Trout + + =item L<version> Copyright 2004-2010 John Peacock + + =back + + =head1 LICENSE + + Same as Perl. + + =head1 CREDITS + + =head2 CONTRIBUTORS + + Patches and code improvements were contributed by: + + Goro Fuji, Kazuhiro Osawa, Tokuhiro Matsuno, Kenichi Ishigaki, Ian + Wells, Pedro Melo, Masayoshi Sekimura, Matt S Trout, squeeky, horus + and Ingy dot Net. + + =head2 ACKNOWLEDGEMENTS + + Bug reports, suggestions and feedbacks were sent by, or general + acknowledgement goes to: + + Jesse Vincent, David Golden, Andreas Koenig, Jos Boumans, Chris + Williams, Adam Kennedy, Audrey Tang, J. Shirley, Chris Prather, Jesse + Luehrs, Marcus Ramberg, Shawn M Moore, chocolateboy, Chirs Nehren, + Jonathan Rockway, Leon Brocard, Simon Elliott, Ricardo Signes, AEvar + Arnfjord Bjarmason, Eric Wilhelm, Florian Ragwitz and xaicron. + + =head1 COMMUNITY + + =over 4 + + =item L<http://github.com/miyagawa/cpanminus> - source code repository, issue tracker + + =item L<irc://irc.perl.org/#toolchain> - discussions about Perl toolchain. I'm there. + + =back + + =head1 NO WARRANTY + + This software is provided "as-is," without any express or implied + warranty. In no event shall the author be held liable for any damages + arising from the use of the software. + + =head1 SEE ALSO + + L<CPAN> L<CPANPLUS> L<pip> + + =cut + + 1; +APP_CPANMINUS + +$fatpacked{"App/cpanminus/script.pm"} = <<'APP_CPANMINUS_SCRIPT'; + package App::cpanminus::script; + use strict; + use Config; + use Cwd (); + use File::Basename (); + use File::Path (); + use File::Spec (); + use File::Copy (); + use Getopt::Long (); + use Parse::CPAN::Meta; + + use constant WIN32 => $^O eq 'MSWin32'; + use constant SUNOS => $^O eq 'solaris'; + + our $VERSION = "1.3001"; + + my $quote = WIN32 ? q/"/ : q/'/; + + sub new { + my $class = shift; + + bless { + home => "$ENV{HOME}/.cpanm", + cmd => 'install', + seen => {}, + notest => undef, + installdeps => undef, + force => undef, + sudo => undef, + make => undef, + verbose => undef, + quiet => undef, + interactive => undef, + log => undef, + mirrors => [], + mirror_only => undef, + perl => $^X, + argv => [], + local_lib => undef, + self_contained => undef, + prompt_timeout => 0, + prompt => undef, + configure_timeout => 60, + try_lwp => 1, + try_wget => 1, + try_curl => 1, + uninstall_shadows => ($] < 5.012), + skip_installed => 1, + auto_cleanup => 7, # days + @_, + }, $class; + } + + sub env { + my($self, $key) = @_; + $ENV{"PERL_CPANM_" . $key}; + } + + sub parse_options { + my $self = shift; + + local @ARGV = @{$self->{argv}}; + push @ARGV, split /\s+/, $self->env('OPT'); + push @ARGV, @_; + + if ($0 ne '-' && !-t STDIN){ # e.g. $ cpanm < author/requires.cpanm + push @ARGV, $self->load_argv_from_fh(\*STDIN); + } + + Getopt::Long::Configure("bundling"); + Getopt::Long::GetOptions( + 'f|force' => sub { $self->{skip_installed} = 0; $self->{force} = 1 }, + 'n|notest!' => \$self->{notest}, + 'S|sudo!' => \$self->{sudo}, + 'v|verbose' => sub { $self->{verbose} = $self->{interactive} = 1 }, + 'q|quiet' => \$self->{quiet}, + 'h|help' => sub { $self->{action} = 'show_help' }, + 'V|version' => sub { $self->{action} = 'show_version' }, + 'perl=s' => \$self->{perl}, + 'l|local-lib=s' => sub { $self->{local_lib} = $self->maybe_abs($_[1]) }, + 'L|local-lib-contained=s' => sub { $self->{local_lib} = $self->maybe_abs($_[1]); $self->{self_contained} = 1 }, + 'mirror=s@' => $self->{mirrors}, + 'mirror-only!' => \$self->{mirror_only}, + 'prompt!' => \$self->{prompt}, + 'installdeps' => \$self->{installdeps}, + 'skip-installed!' => \$self->{skip_installed}, + 'reinstall' => sub { $self->{skip_installed} = 0 }, + 'interactive!' => \$self->{interactive}, + 'i|install' => sub { $self->{cmd} = 'install' }, + 'info' => sub { $self->{cmd} = 'info' }, + 'look' => sub { $self->{cmd} = 'look'; $self->{skip_installed} = 0 }, + 'self-upgrade' => sub { $self->{cmd} = 'install'; $self->{skip_installed} = 1; push @ARGV, 'App::cpanminus' }, + 'uninst-shadows!' => \$self->{uninstall_shadows}, + 'lwp!' => \$self->{try_lwp}, + 'wget!' => \$self->{try_wget}, + 'curl!' => \$self->{try_curl}, + 'auto-cleanup=s' => \$self->{auto_cleanup}, + ); + + $self->{argv} = \@ARGV; + } + + sub check_libs { + my $self = shift; + return if $self->{_checked}++; + + $self->bootstrap_local_lib; + if (@{$self->{bootstrap_deps} || []}) { + local $self->{notest} = 1; # test failure in bootstrap should be tolerated + $self->install_deps(Cwd::cwd, 0, @{$self->{bootstrap_deps}}); + } + } + + sub doit { + my $self = shift; + + $self->setup_home; + $self->init_tools; + + if (my $action = $self->{action}) { + $self->$action() and return 1; + } + + $self->show_help(1) unless @{$self->{argv}}; + + $self->configure_mirrors; + + my @fail; + for my $module (@{$self->{argv}}) { + if ($module =~ s/\.pm$//i) { + my ($volume, $dirs, $file) = File::Spec->splitpath($module); + $module = join '::', grep { $_ } File::Spec->splitdir($dirs), $file; + } + $self->install_module($module, 0) + or push @fail, $module; + } + + if ($self->{base} && $self->{auto_cleanup}) { + $self->cleanup_workdirs; + } + + return !@fail; + } + + sub setup_home { + my $self = shift; + + $self->{home} = $self->env('HOME') if $self->env('HOME'); + + unless (_writable($self->{home})) { + die "Can't write to cpanm home '$self->{home}': You should fix it with chown/chmod first.\n"; + } + + $self->{base} = "$self->{home}/work/" . time . ".$$"; + File::Path::mkpath([ $self->{base} ], 0, 0777); + + my $link = "$self->{home}/latest-build"; + eval { unlink $link; symlink $self->{base}, $link }; + + $self->{log} = File::Spec->catfile($self->{home}, "build.log"); # because we use shell redirect + + { + my $log = $self->{log}; my $base = $self->{base}; + $self->{at_exit} = sub { + my $self = shift; + File::Copy::copy($self->{log}, "$self->{base}/build.log"); + }; + } + + open my $out, ">$self->{log}" or die "$self->{log}: $!"; + print $out "cpanm (App::cpanminus) $VERSION on perl $] built for $Config{archname}\n"; + print $out "Work directory is $self->{base}\n"; + } + + sub fetch_meta { + my($self, $dist) = @_; + + unless ($self->{mirror_only}) { + my $meta_yml = $self->get("http://cpansearch.perl.org/src/$dist->{cpanid}/$dist->{distvname}/META.yml"); + return $self->parse_meta_string($meta_yml); + } + + return undef; + } + + sub package_index_for { + my ($self, $mirror) = @_; + return $self->source_for($mirror) . "/02packages.details.txt"; + } + + sub generate_mirror_index { + my ($self, $mirror) = @_; + my $file = $self->package_index_for($mirror); + my $gz_file = $file . '.gz'; + my $index_mtime = (stat $gz_file)[9]; + + unless (-e $file && (stat $file)[9] >= $index_mtime) { + $self->chat("Uncompressing index file...\n"); + if (eval {require Compress::Zlib}) { + my $gz = Compress::Zlib::gzopen($gz_file, "rb") + or do { $self->diag_fail("$Compress::Zlib::gzerrno opening compressed index"); return}; + open my $fh, '>', $file + or do { $self->diag_fail("$! opening uncompressed index for write"); return }; + my $buffer; + while (my $status = $gz->gzread($buffer)) { + if ($status < 0) { + $self->diag_fail($gz->gzerror . " reading compressed index"); + return; + } + print $fh $buffer; + } + } else { + unless (system("gunzip -c $gz_file > $file")) { + $self->diag_fail("Cannot uncompress -- please install gunzip or Compress::Zlib"); + return; + } + } + utime $index_mtime, $index_mtime, $file; + } + return 1; + } + + sub search_mirror_index { + my ($self, $mirror, $module) = @_; + + open my $fh, '<', $self->package_index_for($mirror) or return; + while (<$fh>) { + if (m!^\Q$module\E\s+([\w\.]+)\s+(.*)!m) { + return $self->cpan_module($module, $2, $1); + } + } + + return; + } + + sub search_module { + my($self, $module) = @_; + + unless ($self->{mirror_only}) { + $self->chat("Searching $module on cpanmetadb ...\n"); + my $uri = "http://cpanmetadb.appspot.com/v1.0/package/$module"; + my $yaml = $self->get($uri); + my $meta = $self->parse_meta_string($yaml); + if ($meta->{distfile}) { + return $self->cpan_module($module, $meta->{distfile}, $meta->{version}); + } + + $self->diag_fail("Finding $module on cpanmetadb failed."); + + $self->chat("Searching $module on search.cpan.org ...\n"); + my $uri = "http://search.cpan.org/perldoc?$module"; + my $html = $self->get($uri); + $html =~ m!<a href="/CPAN/authors/id/(.*?\.(?:tar\.gz|tgz|tar\.bz2|zip))">! + and return $self->cpan_module($module, $1); + + $self->diag_fail("Finding $module on search.cpan.org failed."); + } + + MIRROR: for my $mirror (@{ $self->{mirrors} }) { + $self->chat("Searching $module on mirror $mirror ...\n"); + my $name = '02packages.details.txt.gz'; + my $uri = "$mirror/modules/$name"; + my $gz_file = $self->package_index_for($mirror) . '.gz'; + + unless ($self->{pkgs}{$uri}) { + $self->chat("Downloading index file $uri ...\n"); + $self->mirror($uri, $gz_file); + $self->generate_mirror_index($mirror) or next MIRROR; + $self->{pkgs}{$uri} = "!!retrieved!!"; + } + + my $pkg = $self->search_mirror_index($mirror, $module); + return $pkg if $pkg; + + $self->diag_fail("Finding $module on mirror $mirror failed."); + } + + return; + } + + sub source_for { + my($self, $mirror) = @_; + $mirror =~ s/[^\w\.\-]+/%/g; + + my $dir = "$self->{home}/sources/$mirror"; + File::Path::mkpath([ $dir ], 0, 0777); + + return $dir; + } + + sub load_argv_from_fh { + my($self, $fh) = @_; + + my @argv; + while(defined(my $line = <$fh>)){ + chomp $line; + $line =~ s/#.+$//; # comment + $line =~ s/^\s+//; # trim spaces + $line =~ s/\s+$//; # trim spaces + + push @argv, split ' ', $line if $line; + } + return @argv; + } + + sub show_version { + print "cpanm (App::cpanminus) version $VERSION\n"; + return 1; + } + + sub show_help { + my $self = shift; + + if ($_[0]) { + die <<USAGE; + Usage: cpanm [options] Module [...] + + Try `cpanm --help` or `man cpanm` for more options. + USAGE + } + + print <<HELP; + Usage: cpanm [options] Module [...] + + Options: + -v,--verbose Turns on chatty output + -q,--quiet Turns off all output + --interactive Turns on interactive configure (required for Task:: modules) + -f,--force force install + -n,--notest Do not run unit tests + -S,--sudo sudo to run install commands + --installdeps Only install dependencies + --reinstall Reinstall the distribution even if you already have the latest version installed + --mirror Specify the base URL for the mirror (e.g. http://cpan.cpantesters.org/) + --mirror-only Use the mirror's index file instead of the CPAN Meta DB + --prompt Prompt when configure/build/test fails + -l,--local-lib Specify the install base to install modules + -L,--local-lib-contained Specify the install base to install all non-core modules + --auto-cleanup Number of days that cpanm's work directories expire in. Defaults to 7 + + Commands: + --self-upgrade upgrades itself + --info Displays distribution info on CPAN + --look Opens the distribution with your SHELL + -V,--version Displays software version + + Examples: + + cpanm Test::More # install Test::More + cpanm MIYAGAWA/Plack-0.99_05.tar.gz # full distribution path + cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz # install from URL + cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz # install from a local file + cpanm --interactive Task::Kensho # Configure interactively + cpanm . # install from local directory + cpanm --installdeps . # install all the deps for the current directory + cpanm -L extlib Plack # install Plack and all non-core deps into extlib + cpanm --mirror http://cpan.cpantesters.org/ DBI # use the fast-syncing mirror + + You can also specify the default options in PERL_CPANM_OPT environment variable in the shell rc: + + export PERL_CPANM_OPT="--prompt --reinstall -l ~/perl --mirror http://cpan.cpantesters.org" + + Type `man cpanm` or `perldoc cpanm` for the more detailed explanation of the options. + + HELP + + return 1; + } + + sub _writable { + my $dir = shift; + my @dir = File::Spec->splitdir($dir); + while (@dir) { + $dir = File::Spec->catdir(@dir); + if (-e $dir) { + return -w _; + } + pop @dir; + } + + return; + } + + sub maybe_abs { + my($self, $lib) = @_; + $lib =~ /^[~\/]/ ? $lib : Cwd::abs_path($lib); + } + + sub bootstrap_local_lib { + my $self = shift; + + # If -l is specified, use that. + if ($self->{local_lib}) { + return $self->setup_local_lib($self->{local_lib}); + } + + # root, locally-installed perl or --sudo: don't care about install_base + return if $self->{sudo} or (_writable($Config{installsitelib}) and _writable($Config{installsitebin})); + + # local::lib is configured in the shell -- yay + if ($ENV{PERL_MM_OPT} and ($ENV{MODULEBUILDRC} or $ENV{PERL_MB_OPT})) { + $self->bootstrap_local_lib_deps; + return; + } + + $self->setup_local_lib; + + $self->diag(<<DIAG); + ! + ! Can't write to $Config{installsitelib} and $Config{installsitebin}: Installing modules to $ENV{HOME}/perl5 + ! To turn off this warning, you have to do one of the following: + ! - run me as a root or with --sudo option (to install to $Config{installsitelib} and $Config{installsitebin}) + | - run me with --local-lib option e.g. cpanm --local-lib=~/perl5 + ! - Set PERL_CPANM_OPT="--local-lib=~/perl5" environment variable (in your shell rc file) + ! - Configure local::lib in your shell to set PERL_MM_OPT etc. + ! + DIAG + sleep 2; + } + + sub _core_only_inc { + my($self, $base) = @_; + require local::lib; + ( + local::lib->install_base_perl_path($base), + local::lib->install_base_arch_path($base), + @Config{qw(privlibexp archlibexp)}, + ); + } + + sub _dump_inc { + my($self, $inc) = @_; + + my @inc = map { qq('$_') } (@$inc, '.'); # . for inc/Module/Install.pm + + open my $out, ">$self->{base}/DumpedINC.pm" or die $!; + local $" = ","; + print $out "BEGIN { \@INC = (@inc) }\n1;\n"; + } + + sub _import_local_lib { + my($self, @args) = @_; + local $SIG{__WARN__} = sub { }; # catch 'Attempting to write ...' + local::lib->import(@args); + } + + sub setup_local_lib { + my($self, $base) = @_; + + require local::lib; + { + local $0 = 'cpanm'; # so curl/wget | perl works + $base ||= "~/perl5"; + if ($self->{self_contained}) { + my @inc = $self->_core_only_inc($base); + $self->_dump_inc(\@inc); + $self->{search_inc} = [ @inc ]; + } + $self->_import_local_lib($base); + } + + $self->bootstrap_local_lib_deps; + } + + sub bootstrap_local_lib_deps { + my $self = shift; + push @{$self->{bootstrap_deps}}, + 'ExtUtils::MakeMaker' => 6.31, + 'ExtUtils::Install' => 1.46, + 'Module::Build' => 0.36; + } + + sub prompt_bool { + my($self, $mess, $def) = @_; + + my $val = $self->prompt($mess, $def); + return lc $val eq 'y'; + } + + sub prompt { + my($self, $mess, $def) = @_; + + my $isa_tty = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ; + my $dispdef = defined $def ? "[$def] " : " "; + $def = defined $def ? $def : ""; + + if ($self->{quiet} || !$self->{prompt} || (!$isa_tty && eof STDIN)) { + return $def; + } + + local $|=1; + local $\; + my $ans; + eval { + local $SIG{ALRM} = sub { undef $ans; die "alarm\n" }; + print STDOUT "$mess $dispdef"; + alarm $self->{prompt_timeout} if $self->{prompt_timeout}; + $ans = <STDIN>; + alarm 0; + }; + if ( defined $ans ) { + chomp $ans; + } else { # user hit ctrl-D or alarm timeout + print STDOUT "\n"; + } + + return (!defined $ans || $ans eq '') ? $def : $ans; + } + + sub diag_ok { + my($self, $msg) = @_; + chomp $msg; + $msg ||= "OK"; + if ($self->{in_progress}) { + $self->_diag("$msg\n"); + $self->{in_progress} = 0; + } + $self->log("-> $msg\n"); + } + + sub diag_fail { + my($self, $msg) = @_; + chomp $msg; + if ($self->{in_progress}) { + $self->_diag("FAIL\n"); + $self->{in_progress} = 0; + } + + if ($msg) { + $self->_diag("! $msg\n"); + $self->log("-> FAIL $msg\n"); + } + } + + sub diag_progress { + my($self, $msg) = @_; + chomp $msg; + $self->{in_progress} = 1; + $self->_diag("$msg ... "); + $self->log("$msg\n"); + } + + sub _diag { + my $self = shift; + print STDERR @_ if $self->{verbose} or !$self->{quiet}; + } + + sub diag { + my($self, $msg) = @_; + $self->_diag($msg); + $self->log($msg); + } + + sub chat { + my $self = shift; + print STDERR @_ if $self->{verbose}; + $self->log(@_); + } + + sub log { + my $self = shift; + open my $out, ">>$self->{log}"; + print $out @_; + } + + sub run { + my($self, $cmd) = @_; + + if (WIN32 && ref $cmd eq 'ARRAY') { + $cmd = join q{ }, map { $self->shell_quote($_) } @$cmd; + } + + if (ref $cmd eq 'ARRAY') { + my $pid = fork; + if ($pid) { + waitpid $pid, 0; + return !$?; + } else { + $self->run_exec($cmd); + } + } else { + unless ($self->{verbose}) { + $cmd .= " >> " . $self->shell_quote($self->{log}) . " 2>&1"; + } + !system $cmd; + } + } + + sub run_exec { + my($self, $cmd) = @_; + + if (ref $cmd eq 'ARRAY') { + unless ($self->{verbose}) { + open my $logfh, ">>", $self->{log}; + open STDERR, '>&', $logfh; + open STDOUT, '>&', $logfh; + close $logfh; + } + exec @$cmd; + } else { + unless ($self->{verbose}) { + $cmd .= " >> " . $self->shell_quote($self->{log}) . " 2>&1"; + } + exec $cmd; + } + } + + sub run_timeout { + my($self, $cmd, $timeout) = @_; + return $self->run($cmd) if WIN32 || $self->{verbose} || !$timeout; + + my $pid = fork; + if ($pid) { + eval { + local $SIG{ALRM} = sub { die "alarm\n" }; + alarm $timeout; + waitpid $pid, 0; + alarm 0; + }; + if ($@ && $@ eq "alarm\n") { + $self->diag_fail("Timed out (> ${timeout}s). Use --verbose to retry."); + local $SIG{TERM} = 'IGNORE'; + kill TERM => 0; + waitpid $pid, 0; + return; + } + return !$?; + } elsif ($pid == 0) { + $self->run_exec($cmd); + } else { + $self->chat("! fork failed: falling back to system()\n"); + $self->run($cmd); + } + } + + sub configure { + my($self, $cmd) = @_; + + # trick AutoInstall + local $ENV{PERL5_CPAN_IS_RUNNING} = local $ENV{PERL5_CPANPLUS_IS_RUNNING} = $$; + + # e.g. skip CPAN configuration on local::lib + local $ENV{PERL5_CPANM_IS_RUNNING} = $$; + + my $use_default = !$self->{interactive}; + local $ENV{PERL_MM_USE_DEFAULT} = $use_default; + + local $self->{verbose} = $self->{verbose} || $self->{interactive}; + $self->run_timeout($cmd, $self->{configure_timeout}); + } + + sub build { + my($self, $cmd, $distname) = @_; + + return 1 if $self->run_timeout($cmd, $self->{build_timeout}); + while (1) { + my $ans = lc $self->prompt("Building $distname failed.\nYou can s)kip, r)etry or l)ook ?", "s"); + return if $ans eq 's'; + return $self->build($cmd, $distname) if $ans eq 'r'; + $self->look if $ans eq 'l'; + } + } + + sub test { + my($self, $cmd, $distname) = @_; + return 1 if $self->{notest}; + + # http://www.nntp.perl.org/group/perl.perl5.porters/2009/10/msg152656.html + local $ENV{AUTOMATED_TESTING} = 1 + unless $self->env('NO_AUTOMATED_TESTING'); + + return 1 if $self->run_timeout($cmd, $self->{test_timeout}); + if ($self->{force}) { + $self->diag_fail("Testing $distname failed but installing it anyway."); + return 1; + } else { + $self->diag_fail; + while (1) { + my $ans = lc $self->prompt("Testing $distname failed.\nYou can s)kip, r)etry, f)orce install or l)ook ?", "s"); + return if $ans eq 's'; + return $self->test($cmd, $distname) if $ans eq 'r'; + return 1 if $ans eq 'f'; + $self->look if $ans eq 'l'; + } + } + } + + sub install { + my($self, $cmd, $uninst_opts) = @_; + + if ($self->{sudo}) { + unshift @$cmd, "sudo"; + } + + if ($self->{uninstall_shadows} && !$ENV{PERL_MM_OPT}) { + push @$cmd, @$uninst_opts; + } + + $self->run($cmd); + } + + sub look { + my $self = shift; + + my $shell = $ENV{SHELL}; + $shell ||= $ENV{COMSPEC} if WIN32; + if ($shell) { + my $cwd = Cwd::cwd; + $self->diag("Entering $cwd with $shell\n"); + system $shell; + } else { + $self->diag_fail("You don't seem to have a SHELL :/"); + } + } + + sub chdir { + my $self = shift; + chdir(File::Spec->canonpath($_[0])) or die "$_[0]: $!"; + } + + sub configure_mirrors { + my $self = shift; + unless (@{$self->{mirrors}}) { + $self->{mirrors} = [ 'http://search.cpan.org/CPAN' ]; + } + for (@{$self->{mirrors}}) { + s!^/!file:///!; + s!/$!!; + } + } + + sub self_upgrade { + my $self = shift; + $self->{argv} = [ 'App::cpanminus' ]; + return; # continue + } + + sub install_module { + my($self, $module, $depth) = @_; + + if ($self->{seen}{$module}++) { + $self->chat("Already tried $module. Skipping.\n"); + return 1; + } + + my $dist = $self->resolve_name($module); + unless ($dist) { + $self->diag_fail("Couldn't find module or a distribution $module"); + return; + } + + if ($dist->{distvname} && $self->{seen}{$dist->{distvname}}++) { + $self->chat("Already tried $dist->{distvname}. Skipping.\n"); + return 1; + } + + if ($dist->{source} eq 'cpan') { + $dist->{meta} = $self->fetch_meta($dist); + } + + if ($self->{cmd} eq 'info') { + print $dist->{cpanid}, "/", $dist->{filename}, "\n"; + return 1; + } + + $self->check_libs; + + if ($dist->{module}) { + my($ok, $local) = $self->check_module($dist->{module}, $dist->{module_version} || 0); + if ($self->{skip_installed} && $ok) { + $self->diag("$dist->{module} is up to date. ($local)\n"); + return 1; + } + } + + if ($dist->{dist} eq 'perl'){ + $self->diag("skipping $dist->{pathname}\n"); + return 1; + } + + $self->diag("--> Working on $module\n"); + + $dist->{dir} ||= $self->fetch_module($dist); + + unless ($dist->{dir}) { + $self->diag_fail("Failed to fetch distribution $dist->{distvname}"); + return; + } + + $self->chat("Entering $dist->{dir}\n"); + $self->chdir($self->{base}); + $self->chdir($dist->{dir}); + + if ($self->{cmd} eq 'look') { + $self->look; + return 1; + } + + return $self->build_stuff($module, $dist, $depth); + } + + sub fetch_module { + my($self, $dist) = @_; + + $self->chdir($self->{base}); + + for my $uri (@{$dist->{uris}}) { + $self->diag_progress("Fetching $uri"); + + # Ugh, $dist->{filename} can contain sub directory + my $filename = $dist->{filename} || $uri; + my $name = File::Basename::basename($filename); + + my $cancelled; + my $fetch = sub { + my $file; + eval { + local $SIG{INT} = sub { $cancelled = 1; die "SIGINT\n" }; + $self->mirror($uri, $name); + $file = $name if -e $name; + }; + $self->chat("$@") if $@ && $@ ne "SIGINT\n"; + return $file; + }; + + my($try, $file); + while ($try++ < 3) { + $file = $fetch->(); + last if $cancelled or $file; + $self->diag_fail("Download $uri failed. Retrying ... "); + } + + if ($cancelled) { + $self->diag_fail("Download cancelled."); + return; + } + + unless ($file) { + $self->diag_fail("Failed to download $uri"); + next; + } + + $self->diag_ok; + + my $dir = $self->unpack($file); + next unless $dir; # unpack failed + + return $dist, $dir; + } + } + + sub unpack { + my($self, $file) = @_; + $self->chat("Unpacking $file\n"); + my $dir = $file =~ /\.zip/i ? $self->unzip($file) : $self->untar($file); + unless ($dir) { + $self->diag_fail("Failed to unpack $file: no directory"); + } + return $dir; + } + + sub resolve_name { + my($self, $module) = @_; + + # URL + if ($module =~ /^(ftp|https?|file):/) { + if ($module =~ m!authors/id/!) { + return $self->cpan_dist($module, $module); + } else { + return { uris => [ $module ] }; + } + } + + # Directory + if ($module =~ m!^[\./]! && -d $module) { + return { + source => 'local', + dir => Cwd::abs_path($module), + }; + } + + # File + if (-f $module) { + return { + source => 'local', + uris => [ "file://" . Cwd::abs_path($module) ], + }; + } + + # cpan URI + if ($module =~ s!^cpan:///distfile/!!) { + return $self->cpan_dist($module); + } + + # PAUSEID/foo + if ($module =~ m!([A-Z]{3,})/!) { + return $self->cpan_dist($module); + } + + # Module name + return $self->search_module($module); + } + + sub cpan_module { + my($self, $module, $dist, $version) = @_; + + my $dist = $self->cpan_dist($dist); + $dist->{module} = $module; + $dist->{module_version} = $version if $version && $version ne 'undef'; + + return $dist; + } + + sub cpan_dist { + my($self, $dist, $url) = @_; + + $dist =~ s!^([A-Z]{3})!substr($1,0,1)."/".substr($1,0,2)."/".$1!e; + + require CPAN::DistnameInfo; + my $d = CPAN::DistnameInfo->new($dist); + + if ($url) { + $url = [ $url ] unless ref $url eq 'ARRAY'; + } else { + my $id = $d->cpanid; + my $fn = substr($id, 0, 1) . "/" . substr($id, 0, 2) . "/" . $id . "/" . $d->filename; + + my @mirrors = @{$self->{mirrors}}; + my @urls = map "$_/authors/id/$fn", @mirrors; + + $url = \@urls, + } + + return { + $d->properties, + source => 'cpan', + uris => $url, + }; + } + + sub check_module { + my($self, $mod, $want_ver) = @_; + + require Module::Metadata; + my $meta = Module::Metadata->new_from_module($mod, inc => $self->{search_inc}) + or return 0, undef; + + my $version = $meta->version; + + # When -L is in use, the version loaded from 'perl' library path + # might be newer than the version that is shipped with the current perl + if ($self->{self_contained} && $self->loaded_from_perl_lib($meta)) { + require Module::CoreList; + $version = $Module::CoreList::version{$]}{$mod}; + } + + $self->{local_versions}{$mod} = $version; + + if ($self->is_deprecated($meta)){ + return 0, $version; + } elsif (!$want_ver or $version >= version->new($want_ver)) { + return 1, $version; + } else { + return 0, $version; + } + } + + sub is_deprecated { + my($self, $meta) = @_; + + my $deprecated = eval { + require Module::CoreList; + Module::CoreList::is_deprecated($meta->{module}); + }; + + return unless $deprecated; + return $self->loaded_from_perl_lib($meta); + } + + sub loaded_from_perl_lib { + my($self, $meta) = @_; + + require Config; + for my $dir (qw(archlibexp privlibexp)) { + my $confdir = $Config{$dir}; + if ($confdir eq substr($meta->filename, 0, length($confdir))) { + return 1; + } + } + + return; + } + + sub should_install { + my($self, $mod, $ver) = @_; + + $self->chat("Checking if you have $mod $ver ... "); + my($ok, $local) = $self->check_module($mod, $ver); + + if ($ok) { $self->chat("Yes ($local)\n") } + elsif ($local) { $self->chat("No ($local < $ver)\n") } + else { $self->chat("No\n") } + + return $mod unless $ok; + return; + } + + sub install_deps { + my($self, $dir, $depth, @deps) = @_; + + my(@install, %seen); + while (my($mod, $ver) = splice @deps, 0, 2) { + next if $seen{$mod} or $mod eq 'perl' or $mod eq 'Config'; + if ($self->should_install($mod, $ver)) { + push @install, $mod; + $seen{$mod} = 1; + } + } + + if (@install) { + $self->diag("==> Found dependencies: " . join(", ", @install) . "\n"); + } + + my @fail; + for my $mod (@install) { + $self->install_module($mod, $depth + 1) + or push @fail, $mod; + } + + $self->chdir($self->{base}); + $self->chdir($dir) if $dir; + + return @fail; + } + + sub install_deps_bailout { + my($self, $target, $dir, $depth, @deps) = @_; + + my @fail = $self->install_deps($dir, $depth, @deps); + if (@fail) { + unless ($self->prompt_bool("Installing the following dependencies failed:\n==> " . + join(", ", @fail) . "\nDo you want to continue building $target anyway?", "n")) { + $self->diag_fail("Bailing out the installation for $target. Retry with --prompt or --force."); + return; + } + } + + return 1; + } + + sub _patch_module_build_config_deps { + my($self, $config_deps) = @_; + + # Crazy hack to auto-add Module::Build dependencies into + # configure_requires if Module::Build is there, since there's a + # possibility where Module::Build is in 'perl' library path while + # the dependencies are in 'site' and can't be loaded when -L + # (--local-lib-contained) is in effect. + + my %config_deps = (@{$config_deps}); + if ($config_deps{"Module::Build"}) { + push @{$config_deps}, ( + 'Perl::OSType' => 1, + 'Module::Metadata' => 1.000002, + 'version' => 0.87, + ); + } + } + + sub build_stuff { + my($self, $stuff, $dist, $depth) = @_; + + my @config_deps; + if (!%{$dist->{meta} || {}} && -e 'META.yml') { + $self->chat("Checking configure dependencies from META.yml\n"); + $dist->{meta} = $self->parse_meta('META.yml'); + } + + push @config_deps, %{$dist->{meta}{configure_requires} || {}}; + + my $target = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $dist->{dir}; + + $self->_patch_module_build_config_deps(\@config_deps) + if $self->{self_contained}; + + $self->install_deps_bailout($target, $dist->{dir}, $depth, @config_deps) + or return; + + $self->diag_progress("Configuring $target"); + + my $configure_state = $self->configure_this($dist); + + $self->diag_ok($configure_state->{configured_ok} ? "OK" : "N/A"); + + my @deps = $self->find_prereqs($dist->{meta}); + + my $distname = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $stuff; + + $self->install_deps_bailout($distname, $dist->{dir}, $depth, @deps) + or return; + + if ($self->{installdeps} && $depth == 0) { + $self->diag("<== Installed dependencies for $stuff. Finishing.\n"); + return 1; + } + + my $installed; + if ($configure_state->{use_module_build} && -e 'Build' && -f _) { + $self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname); + $self->build([ $self->{perl}, "./Build" ], $distname) && + $self->test([ $self->{perl}, "./Build", "test" ], $distname) && + $self->install([ $self->{perl}, "./Build", "install" ], [ "--uninst", 1 ]) && + $installed++; + } elsif ($self->{make} && -e 'Makefile') { + $self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname); + $self->build([ $self->{make} ], $distname) && + $self->test([ $self->{make}, "test" ], $distname) && + $self->install([ $self->{make}, "install" ], [ "UNINST=1" ]) && + $installed++; + } else { + my $why; + my $configure_failed = $configure_state->{configured} && !$configure_state->{configured_ok}; + if ($configure_failed) { $why = "Configure failed for $distname." } + elsif ($self->{make}) { $why = "The distribution doesn't have a proper Makefile.PL/Build.PL" } + else { $why = "Can't configure the distribution. You probably need to have 'make'." } + + $self->diag_fail("$why See $self->{log} for details."); + return; + } + + if ($installed) { + my $local = $self->{local_versions}{$dist->{module} || ''}; + my $version = $dist->{module_version} || $dist->{meta}{version} || $dist->{version}; + my $reinstall = $local && ($local eq $version); + + my $how = $reinstall ? "reinstalled $distname" + : $local ? "installed $distname (upgraded from $local)" + : "installed $distname" ; + my $msg = "Successfully $how"; + $self->diag_ok; + $self->diag("$msg\n"); + return 1; + } else { + my $msg = "Building $distname failed"; + $self->diag_fail("Installing $stuff failed. See $self->{log} for details."); + return; + } + } + + sub configure_this { + my($self, $dist) = @_; + + my @switches; + @switches = ("-I$self->{base}", "-MDumpedINC") if $self->{self_contained}; + local $ENV{PERL5LIB} = '' if $self->{self_contained}; + + my $state = {}; + + my $try_eumm = sub { + if (-e 'Makefile.PL') { + $self->chat("Running Makefile.PL\n"); + local $ENV{X_MYMETA} = 'YAML'; + + # NOTE: according to Devel::CheckLib, most XS modules exit + # with 0 even if header files are missing, to avoid receiving + # tons of FAIL reports in such cases. So exit code can't be + # trusted if it went well. + if ($self->configure([ $self->{perl}, @switches, "Makefile.PL" ])) { + $state->{configured_ok} = -e 'Makefile'; + } + $state->{configured}++; + } + }; + + my $try_mb = sub { + if (-e 'Build.PL') { + $self->chat("Running Build.PL\n"); + if ($self->configure([ $self->{perl}, @switches, "Build.PL" ])) { + $state->{configured_ok} = -e 'Build' && -f _; + } + $state->{use_module_build}++; + $state->{configured}++; + } + }; + + # Module::Build deps should use MakeMaker because that causes circular deps and fail + # Otherwise we should prefer Build.PL + my %should_use_mm = map { $_ => 1 } qw( version ExtUtils-ParseXS ExtUtils-Install ExtUtils-Manifest ); + + my @try; + if ($dist->{dist} && $should_use_mm{$dist->{dist}}) { + @try = ($try_eumm, $try_mb); + } else { + @try = ($try_mb, $try_eumm); + } + + for my $try (@try) { + $try->(); + last if $state->{configured_ok}; + } + + unless ($state->{configured_ok}) { + while (1) { + my $ans = lc $self->prompt("Configuring $dist->{dist} failed.\nYou can s)kip, r)etry or l)ook ?", "s"); + last if $ans eq 's'; + return $self->configure_this($dist) if $ans eq 'r'; + $self->look if $ans eq 'l'; + } + } + + return $state; + } + + sub safe_eval { + my($self, $code) = @_; + eval $code; + } + + sub find_prereqs { + my($self, $meta) = @_; + + my @deps; + if (-e 'MYMETA.yml') { + $self->chat("Checking dependencies from MYMETA.yml ...\n"); + my $mymeta = $self->parse_meta('MYMETA.yml'); + @deps = $self->extract_requires($mymeta); + $meta->{$_} = $mymeta->{$_} for keys %$mymeta; # merge + } elsif (-e '_build/prereqs') { + $self->chat("Checking dependencies from _build/prereqs ...\n"); + my $mymeta = do { open my $in, "_build/prereqs"; $self->safe_eval(join "", <$in>) }; + @deps = $self->extract_requires($mymeta); + } + + if (-e 'Makefile') { + $self->chat("Finding PREREQ from Makefile ...\n"); + open my $mf, "Makefile"; + while (<$mf>) { + if (/^\#\s+PREREQ_PM => {\s*(.*?)\s*}/) { + my @all; + my @pairs = split ', ', $1; + for (@pairs) { + my ($pkg, $v) = split '=>', $_; + push @all, [ $pkg, $v ]; + } + my $list = join ", ", map { "'$_->[0]' => $_->[1]" } @all; + my $prereq = $self->safe_eval("no strict; +{ $list }"); + push @deps, %$prereq if $prereq; + last; + } + } + } + + # No need to remove, but this gets in the way of signature testing :/ + unlink 'MYMETA.yml'; + + return @deps; + } + + sub extract_requires { + my($self, $meta) = @_; + + my @deps; + push @deps, %{$meta->{requires}} if $meta->{requires}; + push @deps, %{$meta->{build_requires}} if $meta->{build_requires}; + + return @deps; + } + + sub cleanup_workdirs { + my $self = shift; + + my $expire = time - 24 * 60 * 60 * $self->{auto_cleanup}; + my @targets; + + opendir my $dh, "$self->{home}/work"; + while (my $e = readdir $dh) { + next if $e !~ /^(\d+)\.\d+$/; # {UNIX time}.{PID} + my $time = $1; + if ($time < $expire) { + push @targets, "$self->{home}/work/$e"; + } + } + + if (@targets) { + $self->chat("Expiring ", scalar(@targets), " work directories.\n"); + File::Path::rmtree(\@targets, 0, 0); # safe = 0, since blib usually doesn't have write bits + } + } + + sub DESTROY { + my $self = shift; + $self->{at_exit}->($self) if $self->{at_exit}; + } + + # Utils + + sub shell_quote { + my($self, $stuff) = @_; + $quote . $stuff . $quote; + } + + sub which { + my($self, $name) = @_; + my $exe_ext = $Config{_exe}; + for my $dir (File::Spec->path) { + my $fullpath = File::Spec->catfile($dir, $name); + if (-x $fullpath || -x ($fullpath .= $exe_ext)) { + if ($fullpath =~ /\s/ && $fullpath !~ /^$quote/) { + $fullpath = $self->shell_quote($fullpath); + } + return $fullpath; + } + } + return; + } + + sub get { $_[0]->{_backends}{get}->(@_) }; + sub mirror { $_[0]->{_backends}{mirror}->(@_) }; + sub untar { $_[0]->{_backends}{untar}->(@_) }; + sub unzip { $_[0]->{_backends}{unzip}->(@_) }; + + sub file_get { + my($self, $uri) = @_; + open my $fh, "<$uri" or return; + join '', <$fh>; + } + + sub file_mirror { + my($self, $uri, $path) = @_; + File::Copy::copy($uri, $path); + } + + sub init_tools { + my $self = shift; + + return if $self->{initialized}++; + + if ($self->{make} = $self->which($Config{make})) { + $self->chat("You have make $self->{make}\n"); + } + + # use --no-lwp if they have a broken LWP, to upgrade LWP + if ($self->{try_lwp} && eval { require LWP::UserAgent; LWP::UserAgent->VERSION(5.802) }) { + $self->chat("You have LWP $LWP::VERSION\n"); + my $ua = sub { + LWP::UserAgent->new( + parse_head => 0, + env_proxy => 1, + agent => "cpanminus/$VERSION", + timeout => 30, + @_, + ); + }; + $self->{_backends}{get} = sub { + my $self = shift; + my $res = $ua->()->request(HTTP::Request->new(GET => $_[0])); + return unless $res->is_success; + return $res->decoded_content; + }; + $self->{_backends}{mirror} = sub { + my $self = shift; + my $res = $ua->()->mirror(@_); + $res->code; + }; + } elsif ($self->{try_wget} and my $wget = $self->which('wget')) { + $self->chat("You have $wget\n"); + $self->{_backends}{get} = sub { + my($self, $uri) = @_; + return $self->file_get($uri) if $uri =~ s!^file:/+!/!; + my $q = $self->{verbose} ? '' : '-q'; + open my $fh, "$wget $uri $q -O - |" or die "wget $uri: $!"; + local $/; + <$fh>; + }; + $self->{_backends}{mirror} = sub { + my($self, $uri, $path) = @_; + return $self->file_mirror($uri, $path) if $uri =~ s!^file:/+!/!; + my $q = $self->{verbose} ? '' : '-q'; + system "$wget --retry-connrefused $uri $q -O $path"; + }; + } elsif ($self->{try_curl} and my $curl = $self->which('curl')) { + $self->chat("You have $curl\n"); + $self->{_backends}{get} = sub { + my($self, $uri) = @_; + return $self->file_get($uri) if $uri =~ s!^file:/+!/!; + my $q = $self->{verbose} ? '' : '-s'; + open my $fh, "$curl -L $q $uri |" or die "curl $uri: $!"; + local $/; + <$fh>; + }; + $self->{_backends}{mirror} = sub { + my($self, $uri, $path) = @_; + return $self->file_mirror($uri, $path) if $uri =~ s!^file:/+!/!; + my $q = $self->{verbose} ? '' : '-s'; + system "$curl -L $uri $q -# -o $path"; + }; + } else { + require HTTP::Tiny; + $self->chat("Falling back to HTTP::Tiny $HTTP::Tiny::VERSION\n"); + + $self->{_backends}{get} = sub { + my $self = shift; + my $res = HTTP::Tiny->new->get($_[0]); + return unless $res->{success}; + return $res->{content}; + }; + $self->{_backends}{mirror} = sub { + my $self = shift; + my $res = HTTP::Tiny->new->mirror(@_); + return $res->{status}; + }; + } + + my $tar = $self->which('tar'); + my $tar_ver; + my $maybe_bad_tar = sub { WIN32 || SUNOS || (($tar_ver = `$tar --version 2>/dev/null`) =~ /GNU.*1\.13/i) }; + + if ($tar && !$maybe_bad_tar->()) { + chomp $tar_ver; + $self->chat("You have $tar: $tar_ver\n"); + $self->{_backends}{untar} = sub { + my($self, $tarfile) = @_; + + my $xf = "xf" . ($self->{verbose} ? 'v' : ''); + my $ar = $tarfile =~ /bz2$/ ? 'j' : 'z'; + + my($root, @others) = `$tar tf$ar $tarfile` + or return undef; + + chomp $root; + $root =~ s{^(.+?)/.*$}{$1}; + + system "$tar $xf$ar $tarfile"; + return $root if -d $root; + + $self->diag_fail("Bad archive: $tarfile"); + return undef; + } + } elsif ( $tar + and my $gzip = $self->which('gzip') + and my $bzip2 = $self->which('bzip2')) { + $self->chat("You have $tar, $gzip and $bzip2\n"); + $self->{_backends}{untar} = sub { + my($self, $tarfile) = @_; + + my $x = "x" . ($self->{verbose} ? 'v' : '') . "f -"; + my $ar = $tarfile =~ /bz2$/ ? $bzip2 : $gzip; + + my($root, @others) = `$ar -dc $tarfile | $tar tf -` + or return undef; + + chomp $root; + $root =~ s{^(.+?)/.*$}{$1}; + + system "$ar -dc $tarfile | $tar $x"; + return $root if -d $root; + + $self->diag_fail("Bad archive: $tarfile"); + return undef; + } + } elsif (eval { require Archive::Tar }) { # uses too much memory! + $self->chat("Falling back to Archive::Tar $Archive::Tar::VERSION\n"); + $self->{_backends}{untar} = sub { + my $self = shift; + my $t = Archive::Tar->new($_[0]); + my $root = ($t->list_files)[0]; + $root =~ s{^(.+?)/.*$}{$1}; + $t->extract; + return -d $root ? $root : undef; + }; + } else { + $self->{_backends}{untar} = sub { + die "Failed to extract $_[1] - You need to have tar or Archive::Tar installed.\n"; + }; + } + + if (my $unzip = $self->which('unzip')) { + $self->chat("You have $unzip\n"); + $self->{_backends}{unzip} = sub { + my($self, $zipfile) = @_; + + my $opt = $self->{verbose} ? '' : '-q'; + my(undef, $root, @others) = `$unzip -t $zipfile` + or return undef; + + chomp $root; + $root =~ s{^\s+testing:\s+(.+?)/\s+OK$}{$1}; + + system "$unzip $opt $zipfile"; + return $root if -d $root; + + $self->diag_fail("Bad archive: [$root] $zipfile"); + return undef; + } + } else { + $self->{_backends}{unzip} = sub { + eval { require Archive::Zip } + or die "Failed to extract $_[1] - You need to have unzip or Archive::Zip installed.\n"; + my($self, $file) = @_; + my $zip = Archive::Zip->new(); + my $status; + $status = $zip->read($file); + $self->diag_fail("Read of file[$file] failed") + if $status != Archive::Zip::AZ_OK(); + my @members = $zip->members(); + my $root; + for my $member ( @members ) { + my $af = $member->fileName(); + next if ($af =~ m!^(/|\.\./)!); + $root = $af unless $root; + $status = $member->extractToFileNamed( $af ); + $self->diag_fail("Extracting of file[$af] from zipfile[$file failed") + if $status != Archive::Zip::AZ_OK(); + } + return -d $root ? $root : undef; + }; + } + } + + sub parse_meta { + my($self, $file) = @_; + return eval { (Parse::CPAN::Meta::LoadFile($file))[0] } || {}; + } + + sub parse_meta_string { + my($self, $yaml) = @_; + return eval { (Parse::CPAN::Meta::Load($yaml))[0] } || {}; + } + + 1; +APP_CPANMINUS_SCRIPT + +$fatpacked{"CPAN/DistnameInfo.pm"} = <<'CPAN_DISTNAMEINFO'; + + package CPAN::DistnameInfo; + + $VERSION = "0.11"; + use strict; + + sub distname_info { + my $file = shift or return; + + my ($dist, $version) = $file =~ /^ + ((?:[-+.]*(?:[A-Za-z0-9]+|(?<=\D)_|_(?=\D))* + (?: + [A-Za-z](?=[^A-Za-z]|$) + | + \d(?=-) + )(?<![._-][vV]) + )+)(.*) + $/xs or return ($file,undef,undef); + + if ($dist =~ /-undef\z/ and ! length $version) { + $dist =~ s/-undef\z//; + } + + # Remove potential -withoutworldwriteables suffix + $version =~ s/-withoutworldwriteables$//; + + if ($version =~ /^(-[Vv].*)-(\d.*)/) { + + # Catch names like Unicode-Collate-Standard-V3_1_1-0.1 + # where the V3_1_1 is part of the distname + $dist .= $1; + $version = $2; + } + + # Normalize the Dist.pm-1.23 convention which CGI.pm and + # a few others use. + $dist =~ s{\.pm$}{}; + + $version = $1 + if !length $version and $dist =~ s/-(\d+\w)$//; + + $version = $1 . $version + if $version =~ /^\d+$/ and $dist =~ s/-(\w+)$//; + + if ($version =~ /\d\.\d/) { + $version =~ s/^[-_.]+//; + } + else { + $version =~ s/^[-_]+//; + } + + my $dev; + if (length $version) { + if ($file =~ /^perl-?\d+\.(\d+)(?:\D(\d+))?(-(?:TRIAL|RC)\d+)?$/) { + $dev = 1 if (($1 > 6 and $1 & 1) or ($2 and $2 >= 50)) or $3; + } + elsif ($version =~ /\d\D\d+_\d/ or $version =~ /-TRIAL/) { + $dev = 1; + } + } + else { + $version = undef; + } + + ($dist, $version, $dev); + } + + sub new { + my $class = shift; + my $distfile = shift; + + $distfile =~ s,//+,/,g; + + my %info = ( pathname => $distfile ); + + ($info{filename} = $distfile) =~ s,^(((.*?/)?authors/)?id/)?([A-Z])/(\4[A-Z])/(\5[-A-Z0-9]*)/,, + and $info{cpanid} = $6; + + if ($distfile =~ m,([^/]+)\.(tar\.(?:g?z|bz2)|zip|tgz)$,i) { # support more ? + $info{distvname} = $1; + $info{extension} = $2; + } + + @info{qw(dist version beta)} = distname_info($info{distvname}); + $info{maturity} = delete $info{beta} ? 'developer' : 'released'; + + return bless \%info, $class; + } + + sub dist { shift->{dist} } + sub version { shift->{version} } + sub maturity { shift->{maturity} } + sub filename { shift->{filename} } + sub cpanid { shift->{cpanid} } + sub distvname { shift->{distvname} } + sub extension { shift->{extension} } + sub pathname { shift->{pathname} } + + sub properties { %{ $_[0] } } + + 1; + + __END__ + + =head1 NAME + + CPAN::DistnameInfo - Extract distribution name and version from a distribution filename + + =head1 SYNOPSIS + + my $pathname = "authors/id/G/GB/GBARR/CPAN-DistnameInfo-0.02.tar.gz"; + + my $d = CPAN::DistnameInfo->new($pathname); + + my $dist = $d->dist; # "CPAN-DistnameInfo" + my $version = $d->version; # "0.02" + my $maturity = $d->maturity; # "released" + my $filename = $d->filename; # "CPAN-DistnameInfo-0.02.tar.gz" + my $cpanid = $d->cpanid; # "GBARR" + my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02" + my $extension = $d->extension; # "tar.gz" + my $pathname = $d->pathname; # "authors/id/G/GB/GBARR/..." + + my %prop = $d->properties; + + =head1 DESCRIPTION + + Many online services that are centered around CPAN attempt to + associate multiple uploads by extracting a distribution name from + the filename of the upload. For most distributions this is easy as + they have used ExtUtils::MakeMaker or Module::Build to create the + distribution, which results in a uniform name. But sadly not all + uploads are created in this way. + + C<CPAN::DistnameInfo> uses heuristics that have been learnt by + L<http://search.cpan.org/> to extract the distribution name and + version from filenames and also report if the version is to be + treated as a developer release + + The constructor takes a single pathname, returning an object with the following methods + + =over + + =item cpanid + + If the path given looked like a CPAN authors directory path, then this will be the + the CPAN id of the author. + + =item dist + + The name of the distribution + + =item distvname + + The file name with any suffix and leading directory names removed + + =item filename + + If the path given looked like a CPAN authors directory path, then this will be the + path to the file relative to the detected CPAN author directory. Otherwise it is the path + that was passed in. + + =item maturity + + The maturity of the distribution. This will be either C<released> or C<developer> + + =item extension + + The extension of the distribution, often used to denote the archive type (e.g. 'tar.gz') + + =item pathname + + The pathname that was passed to the constructor when creating the object. + + =item properties + + This will return a list of key-value pairs, suitable for assigning to a hash, + for the known properties. + + =item version + + The extracted version + + =back + + =head1 AUTHOR + + Graham Barr <gbarr@pobox.com> + + =head1 COPYRIGHT + + Copyright (c) 2003 Graham Barr. All rights reserved. This program is + free software; you can redistribute it and/or modify it under the same + terms as Perl itself. + + =cut + +CPAN_DISTNAMEINFO + +$fatpacked{"HTTP/Tiny.pm"} = <<'HTTP_TINY'; + # vim: ts=4 sts=4 sw=4 et: + # + # This file is part of HTTP-Tiny + # + # This software is copyright (c) 2011 by Christian Hansen. + # + # This is free software; you can redistribute it and/or modify it under + # the same terms as the Perl 5 programming language system itself. + # + package HTTP::Tiny; + BEGIN { + $HTTP::Tiny::VERSION = '0.009'; + } + use strict; + use warnings; + # ABSTRACT: A small, simple, correct HTTP/1.1 client + + use Carp (); + + + my @attributes; + BEGIN { + @attributes = qw(agent default_headers max_redirect max_size proxy timeout); + no strict 'refs'; + for my $accessor ( @attributes ) { + *{$accessor} = sub { + @_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor}; + }; + } + } + + sub new { + my($class, %args) = @_; + (my $agent = $class) =~ s{::}{-}g; + my $self = { + agent => $agent . "/" . ($class->VERSION || 0), + max_redirect => 5, + timeout => 60, + }; + for my $key ( @attributes ) { + $self->{$key} = $args{$key} if exists $args{$key} + } + return bless $self, $class; + } + + + sub get { + my ($self, $url, $args) = @_; + @_ == 2 || (@_ == 3 && ref $args eq 'HASH') + or Carp::croak(q/Usage: $http->get(URL, [HASHREF])/); + return $self->request('GET', $url, $args || {}); + } + + + sub mirror { + my ($self, $url, $file, $args) = @_; + @_ == 3 || (@_ == 4 && ref $args eq 'HASH') + or Carp::croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/); + if ( -e $file and my $mtime = (stat($file))[9] ) { + $args->{headers}{'if-modified-since'} ||= $self->_http_date($mtime); + } + my $tempfile = $file . int(rand(2**31)); + open my $fh, ">", $tempfile + or Carp::croak(qq/Error: Could not open temporary file $tempfile for downloading: $!/); + $args->{data_callback} = sub { print {$fh} $_[0] }; + my $response = $self->request('GET', $url, $args); + close $fh + or Carp::croak(qq/Error: Could not close temporary file $tempfile: $!/); + if ( $response->{success} ) { + rename $tempfile, $file + or Carp::croak "Error replacing $file with $tempfile: $!\n"; + my $lm = $response->{headers}{'last-modified'}; + if ( $lm and my $mtime = $self->_parse_http_date($lm) ) { + utime $mtime, $mtime, $file; + } + } + $response->{success} ||= $response->{status} eq '304'; + unlink $tempfile; + return $response; + } + + + my %idempotent = map { $_ => 1 } qw/GET HEAD PUT DELETE OPTIONS TRACE/; + + sub request { + my ($self, $method, $url, $args) = @_; + @_ == 3 || (@_ == 4 && ref $args eq 'HASH') + or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/); + $args ||= {}; # we keep some state in this during _request + + # RFC 2616 Section 8.1.4 mandates a single retry on broken socket + my $response; + for ( 0 .. 1 ) { + $response = eval { $self->_request($method, $url, $args) }; + last unless $@ && $idempotent{$method} + && $@ =~ m{^(?:Socket closed|Unexpected end)}; + } + + if (my $e = "$@") { + $response = { + success => q{}, + status => 599, + reason => 'Internal Exception', + content => $e, + headers => { + 'content-type' => 'text/plain', + 'content-length' => length $e, + } + }; + } + return $response; + } + + my %DefaultPort = ( + http => 80, + https => 443, + ); + + sub _request { + my ($self, $method, $url, $args) = @_; + + my ($scheme, $host, $port, $path_query) = $self->_split_url($url); + + my $request = { + method => $method, + scheme => $scheme, + host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"), + uri => $path_query, + headers => {}, + }; + + my $handle = HTTP::Tiny::Handle->new(timeout => $self->{timeout}); + + if ($self->{proxy}) { + $request->{uri} = "$scheme://$request->{host_port}$path_query"; + croak(qq/HTTPS via proxy is not supported/) + if $request->{scheme} eq 'https'; + $handle->connect(($self->_split_url($self->{proxy}))[0..2]); + } + else { + $handle->connect($scheme, $host, $port); + } + + $self->_prepare_headers_and_cb($request, $args); + $handle->write_request($request); + + my $response; + do { $response = $handle->read_response_header } + until (substr($response->{status},0,1) ne '1'); + + if ( my @redir_args = $self->_maybe_redirect($request, $response, $args) ) { + $handle->close; + return $self->_request(@redir_args, $args); + } + + if ($method eq 'HEAD' || $response->{status} =~ /^[23]04/) { + # response has no message body + } + else { + my $data_cb = $self->_prepare_data_cb($response, $args); + $handle->read_body($data_cb, $response); + } + + $handle->close; + $response->{success} = substr($response->{status},0,1) eq '2'; + return $response; + } + + sub _prepare_headers_and_cb { + my ($self, $request, $args) = @_; + + for ($self->{default_headers}, $args->{headers}) { + next unless defined; + while (my ($k, $v) = each %$_) { + $request->{headers}{lc $k} = $v; + } + } + $request->{headers}{'host'} = $request->{host_port}; + $request->{headers}{'connection'} = "close"; + $request->{headers}{'user-agent'} ||= $self->{agent}; + + if (defined $args->{content}) { + $request->{headers}{'content-type'} ||= "application/octet-stream"; + if (ref $args->{content} eq 'CODE') { + $request->{headers}{'transfer-encoding'} = 'chunked' + unless $request->{headers}{'content-length'} + || $request->{headers}{'transfer-encoding'}; + $request->{cb} = $args->{content}; + } + else { + my $content = $args->{content}; + if ( $] ge '5.008' ) { + utf8::downgrade($content, 1) + or Carp::croak(q/Wide character in request message body/); + } + $request->{headers}{'content-length'} = length $content + unless $request->{headers}{'content-length'} + || $request->{headers}{'transfer-encoding'}; + $request->{cb} = sub { substr $content, 0, length $content, '' }; + } + $request->{trailer_cb} = $args->{trailer_callback} + if ref $args->{trailer_callback} eq 'CODE'; + } + return; + } + + sub _prepare_data_cb { + my ($self, $response, $args) = @_; + my $data_cb = $args->{data_callback}; + $response->{content} = ''; + + if (!$data_cb || $response->{status} !~ /^2/) { + if (defined $self->{max_size}) { + $data_cb = sub { + $_[1]->{content} .= $_[0]; + die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/) + if length $_[1]->{content} > $self->{max_size}; + }; + } + else { + $data_cb = sub { $_[1]->{content} .= $_[0] }; + } + } + return $data_cb; + } + + sub _maybe_redirect { + my ($self, $request, $response, $args) = @_; + my $headers = $response->{headers}; + my ($status, $method) = ($response->{status}, $request->{method}); + if (($status eq '303' or ($status =~ /^30[127]/ && $method =~ /^GET|HEAD$/)) + and $headers->{location} + and ++$args->{redirects} <= $self->{max_redirect} + ) { + my $location = ($headers->{location} =~ /^\//) + ? "$request->{scheme}://$request->{host_port}$headers->{location}" + : $headers->{location} ; + return (($status eq '303' ? 'GET' : $method), $location); + } + return; + } + + sub _split_url { + my $url = pop; + + # URI regex adapted from the URI module + my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)> + or Carp::croak(qq/Cannot parse URL: '$url'/); + + $scheme = lc $scheme; + $path_query = "/$path_query" unless $path_query =~ m<\A/>; + + my $host = (length($authority)) ? lc $authority : 'localhost'; + $host =~ s/\A[^@]*@//; # userinfo + my $port = do { + $host =~ s/:([0-9]*)\z// && length $1 + ? $1 + : ($scheme eq 'http' ? 80 : $scheme eq 'https' ? 443 : undef); + }; + + return ($scheme, $host, $port, $path_query); + } + + # Date conversions adapted from HTTP::Date + my $DoW = "Sun|Mon|Tue|Wed|Thu|Fri|Sat"; + my $MoY = "Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec"; + sub _http_date { + my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($_[1]); + return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT", + substr($DoW,$wday*4,3), + $mday, substr($MoY,$mon*4,3), $year+1900, + $hour, $min, $sec + ); + } + + sub _parse_http_date { + my ($self, $str) = @_; + require Time::Local; + my @tl_parts; + if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) { + @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3); + } + elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) { + @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3); + } + elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) { + @tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6); + } + return eval { + my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1; + $t < 0 ? undef : $t; + }; + } + + package + HTTP::Tiny::Handle; # hide from PAUSE/indexers + use strict; + use warnings; + + use Carp qw[croak]; + use Errno qw[EINTR EPIPE]; + use IO::Socket qw[SOCK_STREAM]; + + sub BUFSIZE () { 32768 } + + my $Printable = sub { + local $_ = shift; + s/\r/\\r/g; + s/\n/\\n/g; + s/\t/\\t/g; + s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge; + $_; + }; + + my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/; + + sub new { + my ($class, %args) = @_; + return bless { + rbuf => '', + timeout => 60, + max_line_size => 16384, + max_header_lines => 64, + %args + }, $class; + } + + my $ssl_verify_args = { + check_cn => "when_only", + wildcards_in_alt => "anywhere", + wildcards_in_cn => "anywhere" + }; + + sub connect { + @_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/); + my ($self, $scheme, $host, $port) = @_; + + if ( $scheme eq 'https' ) { + eval "require IO::Socket::SSL" + unless exists $INC{'IO/Socket/SSL.pm'}; + croak(qq/IO::Socket::SSL must be installed for https support\n/) + unless $INC{'IO/Socket/SSL.pm'}; + } + elsif ( $scheme ne 'http' ) { + croak(qq/Unsupported URL scheme '$scheme'/); + } + + $self->{fh} = 'IO::Socket::INET'->new( + PeerHost => $host, + PeerPort => $port, + Proto => 'tcp', + Type => SOCK_STREAM, + Timeout => $self->{timeout} + ) or croak(qq/Could not connect to '$host:$port': $@/); + + binmode($self->{fh}) + or croak(qq/Could not binmode() socket: '$!'/); + + if ( $scheme eq 'https') { + IO::Socket::SSL->start_SSL($self->{fh}); + ref($self->{fh}) eq 'IO::Socket::SSL' + or die(qq/SSL connection failed for $host\n/); + $self->{fh}->verify_hostname( $host, $ssl_verify_args ) + or die(qq/SSL certificate not valid for $host\n/); + } + + $self->{host} = $host; + $self->{port} = $port; + + return $self; + } + + sub close { + @_ == 1 || croak(q/Usage: $handle->close()/); + my ($self) = @_; + CORE::close($self->{fh}) + or croak(qq/Could not close socket: '$!'/); + } + + sub write { + @_ == 2 || croak(q/Usage: $handle->write(buf)/); + my ($self, $buf) = @_; + + if ( $] ge '5.008' ) { + utf8::downgrade($buf, 1) + or croak(q/Wide character in write()/); + } + + my $len = length $buf; + my $off = 0; + + local $SIG{PIPE} = 'IGNORE'; + + while () { + $self->can_write + or croak(q/Timed out while waiting for socket to become ready for writing/); + my $r = syswrite($self->{fh}, $buf, $len, $off); + if (defined $r) { + $len -= $r; + $off += $r; + last unless $len > 0; + } + elsif ($! == EPIPE) { + croak(qq/Socket closed by remote server: $!/); + } + elsif ($! != EINTR) { + croak(qq/Could not write to socket: '$!'/); + } + } + return $off; + } + + sub read { + @_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len [, allow_partial])/); + my ($self, $len, $allow_partial) = @_; + + my $buf = ''; + my $got = length $self->{rbuf}; + + if ($got) { + my $take = ($got < $len) ? $got : $len; + $buf = substr($self->{rbuf}, 0, $take, ''); + $len -= $take; + } + + while ($len > 0) { + $self->can_read + or croak(q/Timed out while waiting for socket to become ready for reading/); + my $r = sysread($self->{fh}, $buf, $len, length $buf); + if (defined $r) { + last unless $r; + $len -= $r; + } + elsif ($! != EINTR) { + croak(qq/Could not read from socket: '$!'/); + } + } + if ($len && !$allow_partial) { + croak(q/Unexpected end of stream/); + } + return $buf; + } + + sub readline { + @_ == 1 || croak(q/Usage: $handle->readline()/); + my ($self) = @_; + + while () { + if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) { + return $1; + } + if (length $self->{rbuf} >= $self->{max_line_size}) { + croak(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}/); + } + $self->can_read + or croak(q/Timed out while waiting for socket to become ready for reading/); + my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf}); + if (defined $r) { + last unless $r; + } + elsif ($! != EINTR) { + croak(qq/Could not read from socket: '$!'/); + } + } + croak(q/Unexpected end of stream while looking for line/); + } + + sub read_header_lines { + @_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/); + my ($self, $headers) = @_; + $headers ||= {}; + my $lines = 0; + my $val; + + while () { + my $line = $self->readline; + + if (++$lines >= $self->{max_header_lines}) { + croak(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}/); + } + elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) { + my ($field_name) = lc $1; + if (exists $headers->{$field_name}) { + for ($headers->{$field_name}) { + $_ = [$_] unless ref $_ eq "ARRAY"; + push @$_, $2; + $val = \$_->[-1]; + } + } + else { + $val = \($headers->{$field_name} = $2); + } + } + elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) { + $val + or croak(q/Unexpected header continuation line/); + next unless length $1; + $$val .= ' ' if length $$val; + $$val .= $1; + } + elsif ($line =~ /\A \x0D?\x0A \z/x) { + last; + } + else { + croak(q/Malformed header line: / . $Printable->($line)); + } + } + return $headers; + } + + sub write_request { + @_ == 2 || croak(q/Usage: $handle->write_request(request)/); + my($self, $request) = @_; + $self->write_request_header(@{$request}{qw/method uri headers/}); + $self->write_body($request) if $request->{cb}; + return; + } + + my %HeaderCase = ( + 'content-md5' => 'Content-MD5', + 'etag' => 'ETag', + 'te' => 'TE', + 'www-authenticate' => 'WWW-Authenticate', + 'x-xss-protection' => 'X-XSS-Protection', + ); + + sub write_header_lines { + (@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/); + my($self, $headers) = @_; + + my $buf = ''; + while (my ($k, $v) = each %$headers) { + my $field_name = lc $k; + if (exists $HeaderCase{$field_name}) { + $field_name = $HeaderCase{$field_name}; + } + else { + $field_name =~ /\A $Token+ \z/xo + or croak(q/Invalid HTTP header field name: / . $Printable->($field_name)); + $field_name =~ s/\b(\w)/\u$1/g; + $HeaderCase{lc $field_name} = $field_name; + } + for (ref $v eq 'ARRAY' ? @$v : $v) { + /[^\x0D\x0A]/ + or croak(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_)); + $buf .= "$field_name: $_\x0D\x0A"; + } + } + $buf .= "\x0D\x0A"; + return $self->write($buf); + } + + sub read_body { + @_ == 3 || croak(q/Usage: $handle->read_body(callback, response)/); + my ($self, $cb, $response) = @_; + my $te = $response->{headers}{'transfer-encoding'} || ''; + if ( grep { /chunked/i } ( ref $te eq 'ARRAY' ? @$te : $te ) ) { + $self->read_chunked_body($cb, $response); + } + else { + $self->read_content_body($cb, $response); + } + return; + } + + sub write_body { + @_ == 2 || croak(q/Usage: $handle->write_body(request)/); + my ($self, $request) = @_; + if ($request->{headers}{'content-length'}) { + return $self->write_content_body($request); + } + else { + return $self->write_chunked_body($request); + } + } + + sub read_content_body { + @_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/); + my ($self, $cb, $response, $content_length) = @_; + $content_length ||= $response->{headers}{'content-length'}; + + if ( $content_length ) { + my $len = $content_length; + while ($len > 0) { + my $read = ($len > BUFSIZE) ? BUFSIZE : $len; + $cb->($self->read($read, 0), $response); + $len -= $read; + } + } + else { + my $chunk; + $cb->($chunk, $response) while length( $chunk = $self->read(BUFSIZE, 1) ); + } + + return; + } + + sub write_content_body { + @_ == 2 || croak(q/Usage: $handle->write_content_body(request)/); + my ($self, $request) = @_; + + my ($len, $content_length) = (0, $request->{headers}{'content-length'}); + while () { + my $data = $request->{cb}->(); + + defined $data && length $data + or last; + + if ( $] ge '5.008' ) { + utf8::downgrade($data, 1) + or croak(q/Wide character in write_content()/); + } + + $len += $self->write($data); + } + + $len == $content_length + or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/); + + return $len; + } + + sub read_chunked_body { + @_ == 3 || croak(q/Usage: $handle->read_chunked_body(callback, $response)/); + my ($self, $cb, $response) = @_; + + while () { + my $head = $self->readline; + + $head =~ /\A ([A-Fa-f0-9]+)/x + or croak(q/Malformed chunk head: / . $Printable->($head)); + + my $len = hex($1) + or last; + + $self->read_content_body($cb, $response, $len); + + $self->read(2) eq "\x0D\x0A" + or croak(q/Malformed chunk: missing CRLF after chunk data/); + } + $self->read_header_lines($response->{headers}); + return; + } + + sub write_chunked_body { + @_ == 2 || croak(q/Usage: $handle->write_chunked_body(request)/); + my ($self, $request) = @_; + + my $len = 0; + while () { + my $data = $request->{cb}->(); + + defined $data && length $data + or last; + + if ( $] ge '5.008' ) { + utf8::downgrade($data, 1) + or croak(q/Wide character in write_chunked_body()/); + } + + $len += length $data; + + my $chunk = sprintf '%X', length $data; + $chunk .= "\x0D\x0A"; + $chunk .= $data; + $chunk .= "\x0D\x0A"; + + $self->write($chunk); + } + $self->write("0\x0D\x0A"); + $self->write_header_lines($request->{trailer_cb}->()) + if ref $request->{trailer_cb} eq 'CODE'; + return $len; + } + + sub read_response_header { + @_ == 1 || croak(q/Usage: $handle->read_response_header()/); + my ($self) = @_; + + my $line = $self->readline; + + $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x + or croak(q/Malformed Status-Line: / . $Printable->($line)); + + my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4); + + croak (qq/Unsupported HTTP protocol: $protocol/) + unless $version =~ /0*1\.0*[01]/; + + return { + status => $status, + reason => $reason, + headers => $self->read_header_lines, + protocol => $protocol, + }; + } + + sub write_request_header { + @_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/); + my ($self, $method, $request_uri, $headers) = @_; + + return $self->write("$method $request_uri HTTP/1.1\x0D\x0A") + + $self->write_header_lines($headers); + } + + sub _do_timeout { + my ($self, $type, $timeout) = @_; + $timeout = $self->{timeout} + unless defined $timeout && $timeout >= 0; + + my $fd = fileno $self->{fh}; + defined $fd && $fd >= 0 + or croak(q/select(2): 'Bad file descriptor'/); + + my $initial = time; + my $pending = $timeout; + my $nfound; + + vec(my $fdset = '', $fd, 1) = 1; + + while () { + $nfound = ($type eq 'read') + ? select($fdset, undef, undef, $pending) + : select(undef, $fdset, undef, $pending) ; + if ($nfound == -1) { + $! == EINTR + or croak(qq/select(2): '$!'/); + redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0; + $nfound = 0; + } + last; + } + $! = 0; + return $nfound; + } + + sub can_read { + @_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/); + my $self = shift; + return $self->_do_timeout('read', @_) + } + + sub can_write { + @_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/); + my $self = shift; + return $self->_do_timeout('write', @_) + } + + 1; + + + + __END__ + =pod + + =head1 NAME + + HTTP::Tiny - A small, simple, correct HTTP/1.1 client + + =head1 VERSION + + version 0.009 + + =head1 SYNOPSIS + + use HTTP::Tiny; + + my $response = HTTP::Tiny->new->get('http://example.com/'); + + die "Failed!\n" unless $response->{success}; + + print "$response->{status} $response->{reason}\n"; + + while (my ($k, $v) = each %{$response->{headers}}) { + for (ref $v eq 'ARRAY' ? @$v : $v) { + print "$k: $_\n"; + } + } + + print $response->{content} if length $response->{content}; + + =head1 DESCRIPTION + + This is a very simple HTTP/1.1 client, designed primarily for doing simple GET + requests without the overhead of a large framework like L<LWP::UserAgent>. + + It is more correct and more complete than L<HTTP::Lite>. It supports + proxies (currently only non-authenticating ones) and redirection. It + also correctly resumes after EINTR. + + =head1 METHODS + + =head2 new + + $http = HTTP::Tiny->new( %attributes ); + + This constructor returns a new HTTP::Tiny object. Valid attributes include: + + =over 4 + + =item * + + agent + + A user-agent string (defaults to 'HTTP::Tiny/$VERSION') + + =item * + + default_headers + + A hashref of default headers to apply to requests + + =item * + + max_redirect + + Maximum number of redirects allowed (defaults to 5) + + =item * + + max_size + + Maximum response size (only when not using a data callback). If defined, + responses larger than this will die with an error message + + =item * + + proxy + + URL of a proxy server to use. + + =item * + + timeout + + Request timeout in seconds (default is 60) + + =back + + =head2 get + + $response = $http->get($url); + $response = $http->get($url, \%options); + + Executes a C<GET> request for the given URL. The URL must have unsafe + characters escaped and international domain names encoded. Internally, it just + calls C<request()> with 'GET' as the method. See C<request()> for valid + options and a description of the response. + + =head2 mirror + + $response = $http->mirror($url, $file, \%options) + if ( $response->{success} ) { + print "$file is up to date\n"; + } + + Executes a C<GET> request for the URL and saves the response body to the file + name provided. The URL must have unsafe characters escaped and international + domain names encoded. If the file already exists, the request will includes an + C<If-Modified-Since> header with the modification timestamp of the file. You + may specificy a different C<If-Modified-Since> header yourself in the C<< + $options->{headers} >> hash. + + The C<success> field of the response will be true if the status code is 2XX + or 304 (unmodified). + + If the file was modified and the server response includes a properly + formatted C<Last-Modified> header, the file modification time will + be updated accordingly. + + =head2 request + + $response = $http->request($method, $url); + $response = $http->request($method, $url, \%options); + + Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST', + 'PUT', etc.) on the given URL. The URL must have unsafe characters escaped and + international domain names encoded. A hashref of options may be appended to + modify the request. + + Valid options are: + + =over 4 + + =item * + + headers + + A hashref containing headers to include with the request. If the value for + a header is an array reference, the header will be output multiple times with + each value in the array. These headers over-write any default headers. + + =item * + + content + + A scalar to include as the body of the request OR a code reference + that will be called iteratively to produce the body of the response + + =item * + + trailer_callback + + A code reference that will be called if it exists to provide a hashref + of trailing headers (only used with chunked transfer-encoding) + + =item * + + data_callback + + A code reference that will be called for each chunks of the response + body received. + + =back + + If the C<content> option is a code reference, it will be called iteratively + to provide the content body of the request. It should return the empty + string or undef when the iterator is exhausted. + + If the C<data_callback> option is provided, it will be called iteratively until + the entire response body is received. The first argument will be a string + containing a chunk of the response body, the second argument will be the + in-progress response hash reference, as described below. (This allows + customizing the action of the callback based on the C<status> or C<headers> + received prior to the content body.) + + The C<request> method returns a hashref containing the response. The hashref + will have the following keys: + + =over 4 + + =item * + + success + + Boolean indicating whether the operation returned a 2XX status code + + =item * + + status + + The HTTP status code of the response + + =item * + + reason + + The response phrase returned by the server + + =item * + + content + + The body of the response. If the response does not have any content + or if a data callback is provided to consume the response body, + this will be the empty string + + =item * + + headers + + A hashref of header fields. All header field names will be normalized + to be lower case. If a header is repeated, the value will be an arrayref; + it will otherwise be a scalar string containing the value + + =back + + On an exception during the execution of the request, the C<status> field will + contain 599, and the C<content> field will contain the text of the exception. + + =for Pod::Coverage agent + default_headers + max_redirect + max_size + proxy + timeout + + =head1 LIMITATIONS + + HTTP::Tiny is I<conditionally compliant> with the + L<HTTP/1.1 specification|http://www.w3.org/Protocols/rfc2616/rfc2616.html>. + It attempts to meet all "MUST" requirements of the specification, but does not + implement all "SHOULD" requirements. + + Some particular limitations of note include: + + =over + + =item * + + HTTP::Tiny focuses on correct transport. Users are responsible for ensuring + that user-defined headers and content are compliant with the HTTP/1.1 + specification. + + =item * + + Users must ensure that URLs are properly escaped for unsafe characters and that + international domain names are properly encoded to ASCII. See L<URI::Escape>, + L<URI::_punycode> and L<Net::IDN::Encode>. + + =item * + + Redirection is very strict against the specification. Redirection is only + automatic for response codes 301, 302 and 307 if the request method is 'GET' or + 'HEAD'. Response code 303 is always converted into a 'GET' redirection, as + mandated by the specification. There is no automatic support for status 305 + ("Use proxy") redirections. + + =item * + + Persistant connections are not supported. The C<Connection> header will + always be set to C<close>. + + =item * + + Direct C<https> connections are supported only if L<IO::Socket::SSL> is + installed. There is no support for C<https> connections via proxy. + + =item * + + Cookies are not directly supported. Users that set a C<Cookie> header + should also set C<max_redirect> to zero to ensure cookies are not + inappropriately re-transmitted. + + =item * + + Proxy environment variables are not supported. + + =item * + + There is no provision for delaying a request body using an C<Expect> header. + Unexpected C<1XX> responses are silently ignored as per the specification. + + =item * + + Only 'chunked' C<Transfer-Encoding> is supported. + + =item * + + There is no support for a Request-URI of '*' for the 'OPTIONS' request. + + =back + + =head1 SEE ALSO + + =over 4 + + =item * + + L<LWP::UserAgent> + + =back + + =head1 AUTHORS + + =over 4 + + =item * + + Christian Hansen <chansen@cpan.org> + + =item * + + David Golden <dagolden@cpan.org> + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2011 by Christian Hansen. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut + +HTTP_TINY + +$fatpacked{"Module/Metadata.pm"} = <<'MODULE_METADATA'; + # -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*- + # vim:ts=8:sw=2:et:sta:sts=2 + package Module::Metadata; + + # Adapted from Perl-licensed code originally distributed with + # Module-Build by Ken Williams + + # This module provides routines to gather information about + # perl modules (assuming this may be expanded in the distant + # parrot future to look at other types of modules). + + use strict; + use vars qw($VERSION); + $VERSION = '1.000003'; + $VERSION = eval $VERSION; + + use File::Spec; + use IO::File; + use version 0.87; + BEGIN { + if ($INC{'Log/Contextual.pm'}) { + Log::Contextual->import('log_info'); + } else { + *log_info = sub (&) { warn $_[0]->() }; + } + } + use File::Find qw(find); + + my $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal + + my $PKG_REGEXP = qr{ # match a package declaration + ^[\s\{;]* # intro chars on a line + package # the word 'package' + \s+ # whitespace + ([\w:]+) # a package name + \s* # optional whitespace + ($V_NUM_REGEXP)? # optional version number + \s* # optional whitesapce + ; # semicolon line terminator + }x; + + my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name + ([\$*]) # sigil - $ or * + ( + ( # optional leading package name + (?:::|\')? # possibly starting like just :: (Ì la $::VERSION) + (?:\w+(?:::|\'))* # Foo::Bar:: ... + )? + VERSION + )\b + }x; + + my $VERS_REGEXP = qr{ # match a VERSION definition + (?: + \(\s*$VARNAME_REGEXP\s*\) # with parens + | + $VARNAME_REGEXP # without parens + ) + \s* + =[^=~] # = but not ==, nor =~ + }x; + + + sub new_from_file { + my $class = shift; + my $filename = File::Spec->rel2abs( shift ); + + return undef unless defined( $filename ) && -f $filename; + return $class->_init(undef, $filename, @_); + } + + sub new_from_module { + my $class = shift; + my $module = shift; + my %props = @_; + + $props{inc} ||= \@INC; + my $filename = $class->find_module_by_name( $module, $props{inc} ); + return undef unless defined( $filename ) && -f $filename; + return $class->_init($module, $filename, %props); + } + + { + + my $compare_versions = sub { + my ($v1, $op, $v2) = @_; + $v1 = version->new($v1) + unless UNIVERSAL::isa($v1,'version'); + + my $eval_str = "\$v1 $op \$v2"; + my $result = eval $eval_str; + log_info { "error comparing versions: '$eval_str' $@" } if $@; + + return $result; + }; + + my $normalize_version = sub { + my ($version) = @_; + if ( $version =~ /[=<>!,]/ ) { # logic, not just version + # take as is without modification + } + elsif ( ref $version eq 'version' ) { # version objects + $version = $version->is_qv ? $version->normal : $version->stringify; + } + elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots + # normalize string tuples without "v": "1.2.3" -> "v1.2.3" + $version = "v$version"; + } + else { + # leave alone + } + return $version; + }; + + # separate out some of the conflict resolution logic + + my $resolve_module_versions = sub { + my $packages = shift; + + my( $file, $version ); + my $err = ''; + foreach my $p ( @$packages ) { + if ( defined( $p->{version} ) ) { + if ( defined( $version ) ) { + if ( $compare_versions->( $version, '!=', $p->{version} ) ) { + $err .= " $p->{file} ($p->{version})\n"; + } else { + # same version declared multiple times, ignore + } + } else { + $file = $p->{file}; + $version = $p->{version}; + } + } + $file ||= $p->{file} if defined( $p->{file} ); + } + + if ( $err ) { + $err = " $file ($version)\n" . $err; + } + + my %result = ( + file => $file, + version => $version, + err => $err + ); + + return \%result; + }; + + sub package_versions_from_directory { + my ( $class, $dir, $files ) = @_; + + my @files; + + if ( $files ) { + @files = @$files; + } else { + find( { + wanted => sub { + push @files, $_ if -f $_ && /\.pm$/; + }, + no_chdir => 1, + }, $dir ); + } + + # First, we enumerate all packages & versions, + # separating into primary & alternative candidates + my( %prime, %alt ); + foreach my $file (@files) { + my $mapped_filename = File::Spec->abs2rel( $file, $dir ); + my @path = split( /\//, $mapped_filename ); + (my $prime_package = join( '::', @path )) =~ s/\.pm$//; + + my $pm_info = $class->new_from_file( $file ); + + foreach my $package ( $pm_info->packages_inside ) { + next if $package eq 'main'; # main can appear numerous times, ignore + next if $package eq 'DB'; # special debugging package, ignore + next if grep /^_/, split( /::/, $package ); # private package, ignore + + my $version = $pm_info->version( $package ); + + if ( $package eq $prime_package ) { + if ( exists( $prime{$package} ) ) { + # M::B::ModuleInfo will handle this conflict + die "Unexpected conflict in '$package'; multiple versions found.\n"; + } else { + $prime{$package}{file} = $mapped_filename; + $prime{$package}{version} = $version if defined( $version ); + } + } else { + push( @{$alt{$package}}, { + file => $mapped_filename, + version => $version, + } ); + } + } + } + + # Then we iterate over all the packages found above, identifying conflicts + # and selecting the "best" candidate for recording the file & version + # for each package. + foreach my $package ( keys( %alt ) ) { + my $result = $resolve_module_versions->( $alt{$package} ); + + if ( exists( $prime{$package} ) ) { # primary package selected + + if ( $result->{err} ) { + # Use the selected primary package, but there are conflicting + # errors among multiple alternative packages that need to be + # reported + log_info { + "Found conflicting versions for package '$package'\n" . + " $prime{$package}{file} ($prime{$package}{version})\n" . + $result->{err} + }; + + } elsif ( defined( $result->{version} ) ) { + # There is a primary package selected, and exactly one + # alternative package + + if ( exists( $prime{$package}{version} ) && + defined( $prime{$package}{version} ) ) { + # Unless the version of the primary package agrees with the + # version of the alternative package, report a conflict + if ( $compare_versions->( + $prime{$package}{version}, '!=', $result->{version} + ) + ) { + + log_info { + "Found conflicting versions for package '$package'\n" . + " $prime{$package}{file} ($prime{$package}{version})\n" . + " $result->{file} ($result->{version})\n" + }; + } + + } else { + # The prime package selected has no version so, we choose to + # use any alternative package that does have a version + $prime{$package}{file} = $result->{file}; + $prime{$package}{version} = $result->{version}; + } + + } else { + # no alt package found with a version, but we have a prime + # package so we use it whether it has a version or not + } + + } else { # No primary package was selected, use the best alternative + + if ( $result->{err} ) { + log_info { + "Found conflicting versions for package '$package'\n" . + $result->{err} + }; + } + + # Despite possible conflicting versions, we choose to record + # something rather than nothing + $prime{$package}{file} = $result->{file}; + $prime{$package}{version} = $result->{version} + if defined( $result->{version} ); + } + } + + # Normalize versions. Can't use exists() here because of bug in YAML::Node. + # XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18 + for (grep defined $_->{version}, values %prime) { + $_->{version} = $normalize_version->( $_->{version} ); + } + + return \%prime; + } + } + + + sub _init { + my $class = shift; + my $module = shift; + my $filename = shift; + my %props = @_; + + my( %valid_props, @valid_props ); + @valid_props = qw( collect_pod inc ); + @valid_props{@valid_props} = delete( @props{@valid_props} ); + warn "Unknown properties: @{[keys %props]}\n" if scalar( %props ); + + my %data = ( + module => $module, + filename => $filename, + version => undef, + packages => [], + versions => {}, + pod => {}, + pod_headings => [], + collect_pod => 0, + + %valid_props, + ); + + my $self = bless(\%data, $class); + + $self->_parse_file(); + + unless($self->{module} and length($self->{module})) { + my ($v, $d, $f) = File::Spec->splitpath($self->{filename}); + if($f =~ /\.pm$/) { + $f =~ s/\..+$//; + my @candidates = grep /$f$/, @{$self->{packages}}; + $self->{module} = shift(@candidates); # punt + } + else { + if(grep /main/, @{$self->{packages}}) { + $self->{module} = 'main'; + } + else { + $self->{module} = $self->{packages}[0] || ''; + } + } + } + + $self->{version} = $self->{versions}{$self->{module}} + if defined( $self->{module} ); + + return $self; + } + + # class method + sub _do_find_module { + my $class = shift; + my $module = shift || die 'find_module_by_name() requires a package name'; + my $dirs = shift || \@INC; + + my $file = File::Spec->catfile(split( /::/, $module)); + foreach my $dir ( @$dirs ) { + my $testfile = File::Spec->catfile($dir, $file); + return [ File::Spec->rel2abs( $testfile ), $dir ] + if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp + return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ] + if -e "$testfile.pm"; + } + return; + } + + # class method + sub find_module_by_name { + my $found = shift()->_do_find_module(@_) or return; + return $found->[0]; + } + + # class method + sub find_module_dir_by_name { + my $found = shift()->_do_find_module(@_) or return; + return $found->[1]; + } + + + # given a line of perl code, attempt to parse it if it looks like a + # $VERSION assignment, returning sigil, full name, & package name + sub _parse_version_expression { + my $self = shift; + my $line = shift; + + my( $sig, $var, $pkg ); + if ( $line =~ $VERS_REGEXP ) { + ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 ); + if ( $pkg ) { + $pkg = ($pkg eq '::') ? 'main' : $pkg; + $pkg =~ s/::$//; + } + } + + return ( $sig, $var, $pkg ); + } + + sub _parse_file { + my $self = shift; + + my $filename = $self->{filename}; + my $fh = IO::File->new( $filename ) + or die( "Can't open '$filename': $!" ); + + $self->_parse_fh($fh); + } + + sub _parse_fh { + my ($self, $fh) = @_; + + my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 ); + my( @pkgs, %vers, %pod, @pod ); + my $pkg = 'main'; + my $pod_sect = ''; + my $pod_data = ''; + + while (defined( my $line = <$fh> )) { + my $line_num = $.; + + chomp( $line ); + next if $line =~ /^\s*#/; + + $in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod; + + # Would be nice if we could also check $in_string or something too + last if !$in_pod && $line =~ /^__(?:DATA|END)__$/; + + if ( $in_pod || $line =~ /^=cut/ ) { + + if ( $line =~ /^=head\d\s+(.+)\s*$/ ) { + push( @pod, $1 ); + if ( $self->{collect_pod} && length( $pod_data ) ) { + $pod{$pod_sect} = $pod_data; + $pod_data = ''; + } + $pod_sect = $1; + + + } elsif ( $self->{collect_pod} ) { + $pod_data .= "$line\n"; + + } + + } else { + + $pod_sect = ''; + $pod_data = ''; + + # parse $line to see if it's a $VERSION declaration + my( $vers_sig, $vers_fullname, $vers_pkg ) = + $self->_parse_version_expression( $line ); + + if ( $line =~ $PKG_REGEXP ) { + $pkg = $1; + push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs ); + $vers{$pkg} = (defined $2 ? $2 : undef) unless exists( $vers{$pkg} ); + $need_vers = defined $2 ? 0 : 1; + + # VERSION defined with full package spec, i.e. $Module::VERSION + } elsif ( $vers_fullname && $vers_pkg ) { + push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs ); + $need_vers = 0 if $vers_pkg eq $pkg; + + unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) { + $vers{$vers_pkg} = + $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line ); + } else { + # Warn unless the user is using the "$VERSION = eval + # $VERSION" idiom (though there are probably other idioms + # that we should watch out for...) + warn <<"EOM" unless $line =~ /=\s*eval/; + Package '$vers_pkg' already declared with version '$vers{$vers_pkg}', + ignoring subsequent declaration on line $line_num. + EOM + } + + # first non-comment line in undeclared package main is VERSION + } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) { + $need_vers = 0; + my $v = + $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line ); + $vers{$pkg} = $v; + push( @pkgs, 'main' ); + + # first non-comment line in undeclared package defines package main + } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) { + $need_vers = 1; + $vers{main} = ''; + push( @pkgs, 'main' ); + + # only keep if this is the first $VERSION seen + } elsif ( $vers_fullname && $need_vers ) { + $need_vers = 0; + my $v = + $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line ); + + + unless ( defined $vers{$pkg} && length $vers{$pkg} ) { + $vers{$pkg} = $v; + } else { + warn <<"EOM"; + Package '$pkg' already declared with version '$vers{$pkg}' + ignoring new version '$v' on line $line_num. + EOM + } + + } + + } + + } + + if ( $self->{collect_pod} && length($pod_data) ) { + $pod{$pod_sect} = $pod_data; + } + + $self->{versions} = \%vers; + $self->{packages} = \@pkgs; + $self->{pod} = \%pod; + $self->{pod_headings} = \@pod; + } + + { + my $pn = 0; + sub _evaluate_version_line { + my $self = shift; + my( $sigil, $var, $line ) = @_; + + # Some of this code came from the ExtUtils:: hierarchy. + + # We compile into $vsub because 'use version' would cause + # compiletime/runtime issues with local() + my $vsub; + $pn++; # everybody gets their own package + my $eval = qq{BEGIN { q# Hide from _packages_inside() + #; package Module::Metadata::_version::p$pn; + use version; + no strict; + + local $sigil$var; + \$$var=undef; + \$vsub = sub { + $line; + \$$var + }; + }}; + + local $^W; + # Try to get the $VERSION + eval $eval; + # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't + # installed, so we need to hunt in ./lib for it + if ( $@ =~ /Can't locate/ && -d 'lib' ) { + local @INC = ('lib',@INC); + eval $eval; + } + warn "Error evaling version line '$eval' in $self->{filename}: $@\n" + if $@; + (ref($vsub) eq 'CODE') or + die "failed to build version sub for $self->{filename}"; + my $result = eval { $vsub->() }; + die "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n" + if $@; + + # Upgrade it into a version object + my $version = eval { _dwim_version($result) }; + + die "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n" + unless defined $version; # "0" is OK! + + return $version; + } + } + + # Try to DWIM when things fail the lax version test in obvious ways + { + my @version_prep = ( + # Best case, it just works + sub { return shift }, + + # If we still don't have a version, try stripping any + # trailing junk that is prohibited by lax rules + sub { + my $v = shift; + $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b + return $v; + }, + + # Activestate apparently creates custom versions like '1.23_45_01', which + # cause version.pm to think it's an invalid alpha. So check for that + # and strip them + sub { + my $v = shift; + my $num_dots = () = $v =~ m{(\.)}g; + my $num_unders = () = $v =~ m{(_)}g; + my $leading_v = substr($v,0,1) eq 'v'; + if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) { + $v =~ s{_}{}g; + $num_unders = () = $v =~ m{(_)}g; + } + return $v; + }, + + # Worst case, try numifying it like we would have before version objects + sub { + my $v = shift; + no warnings 'numeric'; + return 0 + $v; + }, + + ); + + sub _dwim_version { + my ($result) = shift; + + return $result if ref($result) eq 'version'; + + my ($version, $error); + for my $f (@version_prep) { + $result = $f->($result); + $version = eval { version->new($result) }; + $error ||= $@ if $@; # capture first failure + last if defined $version; + } + + die $error unless defined $version; + + return $version; + } + } + + ############################################################ + + # accessors + sub name { $_[0]->{module} } + + sub filename { $_[0]->{filename} } + sub packages_inside { @{$_[0]->{packages}} } + sub pod_inside { @{$_[0]->{pod_headings}} } + sub contains_pod { $#{$_[0]->{pod_headings}} } + + sub version { + my $self = shift; + my $mod = shift || $self->{module}; + my $vers; + if ( defined( $mod ) && length( $mod ) && + exists( $self->{versions}{$mod} ) ) { + return $self->{versions}{$mod}; + } else { + return undef; + } + } + + sub pod { + my $self = shift; + my $sect = shift; + if ( defined( $sect ) && length( $sect ) && + exists( $self->{pod}{$sect} ) ) { + return $self->{pod}{$sect}; + } else { + return undef; + } + } + + 1; + + =head1 NAME + + Module::Metadata - Gather package and POD information from perl module files + + =head1 DESCRIPTION + + =over 4 + + =item new_from_file($filename, collect_pod => 1) + + Construct a C<ModuleInfo> object given the path to a file. Takes an optional + argument C<collect_pod> which is a boolean that determines whether + POD data is collected and stored for reference. POD data is not + collected by default. POD headings are always collected. + + =item new_from_module($module, collect_pod => 1, inc => \@dirs) + + Construct a C<ModuleInfo> object given a module or package name. In addition + to accepting the C<collect_pod> argument as described above, this + method accepts a C<inc> argument which is a reference to an array of + of directories to search for the module. If none are given, the + default is @INC. + + =item name() + + Returns the name of the package represented by this module. If there + are more than one packages, it makes a best guess based on the + filename. If it's a script (i.e. not a *.pm) the package name is + 'main'. + + =item version($package) + + Returns the version as defined by the $VERSION variable for the + package as returned by the C<name> method if no arguments are + given. If given the name of a package it will attempt to return the + version of that package if it is specified in the file. + + =item filename() + + Returns the absolute path to the file. + + =item packages_inside() + + Returns a list of packages. + + =item pod_inside() + + Returns a list of POD sections. + + =item contains_pod() + + Returns true if there is any POD in the file. + + =item pod($section) + + Returns the POD data in the given section. + + =item find_module_by_name($module, \@dirs) + + Returns the path to a module given the module or package name. A list + of directories can be passed in as an optional parameter, otherwise + @INC is searched. + + Can be called as either an object or a class method. + + =item find_module_dir_by_name($module, \@dirs) + + Returns the entry in C<@dirs> (or C<@INC> by default) that contains + the module C<$module>. A list of directories can be passed in as an + optional parameter, otherwise @INC is searched. + + Can be called as either an object or a class method. + + =item package_versions_from_directory($dir, \@files?) + + Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks + for those files in C<$dir> - and reads each file for packages and versions, + returning a hashref of the form: + + { + 'Package::Name' => { + version => '0.123', + file => 'Package/Name.pm' + }, + 'OtherPackage::Name' => ... + } + + =item log_info (internal) + + Used internally to perform logging; imported from Log::Contextual if + Log::Contextual has already been loaded, otherwise simply calls warn. + + =back + + =head1 AUTHOR + + Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org> + + Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with + assistance from David Golden (xdg) <dagolden@cpan.org> + + =head1 COPYRIGHT + + Copyright (c) 2001-2011 Ken Williams. All rights reserved. + + This library is free software; you can redistribute it and/or + modify it under the same terms as Perl itself. + + =cut + +MODULE_METADATA + +$fatpacked{"Parse/CPAN/Meta.pm"} = <<'PARSE_CPAN_META'; + package Parse::CPAN::Meta;
+
+ use strict;
+ use Carp 'croak';
+
+ # UTF Support?
+ sub HAVE_UTF8 () { $] >= 5.007003 }
+ BEGIN {
+ if ( HAVE_UTF8 ) {
+ # The string eval helps hide this from Test::MinimumVersion
+ eval "require utf8;";
+ die "Failed to load UTF-8 support" if $@;
+ }
+
+ # Class structure
+ require 5.004;
+ require Exporter;
+ $Parse::CPAN::Meta::VERSION = '1.40';
+ @Parse::CPAN::Meta::ISA = qw{ Exporter };
+ @Parse::CPAN::Meta::EXPORT_OK = qw{ Load LoadFile };
+ }
+
+ # Prototypes
+ sub LoadFile ($);
+ sub Load ($);
+ sub _scalar ($$$);
+ sub _array ($$$);
+ sub _hash ($$$);
+
+ # Printable characters for escapes
+ my %UNESCAPES = (
+ z => "\x00", a => "\x07", t => "\x09",
+ n => "\x0a", v => "\x0b", f => "\x0c",
+ r => "\x0d", e => "\x1b", '\\' => '\\',
+ );
+
+
+
+
+
+ #####################################################################
+ # Implementation
+
+ # Create an object from a file
+ sub LoadFile ($) {
+ # Check the file
+ my $file = shift;
+ croak('You did not specify a file name') unless $file;
+ croak( "File '$file' does not exist" ) unless -e $file;
+ croak( "'$file' is a directory, not a file" ) unless -f _;
+ croak( "Insufficient permissions to read '$file'" ) unless -r _;
+
+ # Slurp in the file
+ local $/ = undef;
+ local *CFG;
+ unless ( open( CFG, $file ) ) {
+ croak("Failed to open file '$file': $!");
+ }
+ my $yaml = <CFG>;
+ unless ( close(CFG) ) {
+ croak("Failed to close file '$file': $!");
+ }
+
+ # Hand off to the actual parser
+ Load( $yaml );
+ }
+
+ # Parse a document from a string.
+ # Doing checks on $_[0] prevents us having to do a string copy.
+ sub Load ($) {
+ my $string = $_[0];
+ unless ( defined $string ) {
+ croak("Did not provide a string to load");
+ }
+
+ # Byte order marks
+ if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) {
+ croak("Stream has a non UTF-8 Unicode Byte Order Mark");
+ } else {
+ # Strip UTF-8 bom if found, we'll just ignore it
+ $string =~ s/^\357\273\277//;
+ }
+
+ # Try to decode as utf8
+ utf8::decode($string) if HAVE_UTF8;
+
+ # Check for some special cases
+ return () unless length $string;
+ unless ( $string =~ /[\012\015]+\z/ ) {
+ croak("Stream does not end with newline character");
+ }
+
+ # Split the file into lines
+ my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
+ split /(?:\015{1,2}\012|\015|\012)/, $string;
+
+ # Strip the initial YAML header
+ @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
+
+ # A nibbling parser
+ my @documents = ();
+ while ( @lines ) {
+ # Do we have a document header?
+ if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
+ # Handle scalar documents
+ shift @lines;
+ if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
+ push @documents, _scalar( "$1", [ undef ], \@lines );
+ next;
+ }
+ }
+
+ if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
+ # A naked document
+ push @documents, undef;
+ while ( @lines and $lines[0] !~ /^---/ ) {
+ shift @lines;
+ }
+
+ } elsif ( $lines[0] =~ /^\s*\-/ ) {
+ # An array at the root
+ my $document = [ ];
+ push @documents, $document;
+ _array( $document, [ 0 ], \@lines );
+
+ } elsif ( $lines[0] =~ /^(\s*)\S/ ) {
+ # A hash at the root
+ my $document = { };
+ push @documents, $document;
+ _hash( $document, [ length($1) ], \@lines );
+
+ } else {
+ croak("Parse::CPAN::Meta failed to classify line '$lines[0]'");
+ }
+ }
+
+ if ( wantarray ) {
+ return @documents;
+ } else {
+ return $documents[-1];
+ }
+ }
+
+ # Deparse a scalar string to the actual scalar
+ sub _scalar ($$$) {
+ my ($string, $indent, $lines) = @_;
+
+ # Trim trailing whitespace
+ $string =~ s/\s*\z//;
+
+ # Explitic null/undef
+ return undef if $string eq '~';
+
+ # Quotes
+ if ( $string =~ /^\'(.*?)\'\z/ ) {
+ return '' unless defined $1;
+ $string = $1;
+ $string =~ s/\'\'/\'/g;
+ return $string;
+ }
+ if ( $string =~ /^\"((?:\\.|[^\"])*)\"\z/ ) {
+ # Reusing the variable is a little ugly,
+ # but avoids a new variable and a string copy.
+ $string = $1;
+ $string =~ s/\\"/"/g;
+ $string =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex;
+ return $string;
+ }
+
+ # Special cases
+ if ( $string =~ /^[\'\"!&]/ ) {
+ croak("Parse::CPAN::Meta does not support a feature in line '$lines->[0]'");
+ }
+ return {} if $string eq '{}';
+ return [] if $string eq '[]';
+
+ # Regular unquoted string
+ return $string unless $string =~ /^[>|]/;
+
+ # Error
+ croak("Parse::CPAN::Meta failed to find multi-line scalar content") unless @$lines;
+
+ # Check the indent depth
+ $lines->[0] =~ /^(\s*)/;
+ $indent->[-1] = length("$1");
+ if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
+ croak("Parse::CPAN::Meta found bad indenting in line '$lines->[0]'");
+ }
+
+ # Pull the lines
+ my @multiline = ();
+ while ( @$lines ) {
+ $lines->[0] =~ /^(\s*)/;
+ last unless length($1) >= $indent->[-1];
+ push @multiline, substr(shift(@$lines), length($1));
+ }
+
+ my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
+ my $t = (substr($string, 1, 1) eq '-') ? '' : "\n";
+ return join( $j, @multiline ) . $t;
+ }
+
+ # Parse an array
+ sub _array ($$$) {
+ my ($array, $indent, $lines) = @_;
+
+ while ( @$lines ) {
+ # Check for a new document
+ if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
+ while ( @$lines and $lines->[0] !~ /^---/ ) {
+ shift @$lines;
+ }
+ return 1;
+ }
+
+ # Check the indent level
+ $lines->[0] =~ /^(\s*)/;
+ if ( length($1) < $indent->[-1] ) {
+ return 1;
+ } elsif ( length($1) > $indent->[-1] ) {
+ croak("Parse::CPAN::Meta found bad indenting in line '$lines->[0]'");
+ }
+
+ if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
+ # Inline nested hash
+ my $indent2 = length("$1");
+ $lines->[0] =~ s/-/ /;
+ push @$array, { };
+ _hash( $array->[-1], [ @$indent, $indent2 ], $lines );
+
+ } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
+ # Array entry with a value
+ shift @$lines;
+ push @$array, _scalar( "$2", [ @$indent, undef ], $lines );
+
+ } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
+ shift @$lines;
+ unless ( @$lines ) {
+ push @$array, undef;
+ return 1;
+ }
+ if ( $lines->[0] =~ /^(\s*)\-/ ) {
+ my $indent2 = length("$1");
+ if ( $indent->[-1] == $indent2 ) {
+ # Null array entry
+ push @$array, undef;
+ } else {
+ # Naked indenter
+ push @$array, [ ];
+ _array( $array->[-1], [ @$indent, $indent2 ], $lines );
+ }
+
+ } elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
+ push @$array, { };
+ _hash( $array->[-1], [ @$indent, length("$1") ], $lines );
+
+ } else {
+ croak("Parse::CPAN::Meta failed to classify line '$lines->[0]'");
+ }
+
+ } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
+ # This is probably a structure like the following...
+ # ---
+ # foo:
+ # - list
+ # bar: value
+ #
+ # ... so lets return and let the hash parser handle it
+ return 1;
+
+ } else {
+ croak("Parse::CPAN::Meta failed to classify line '$lines->[0]'");
+ }
+ }
+
+ return 1;
+ }
+
+ # Parse an array
+ sub _hash ($$$) {
+ my ($hash, $indent, $lines) = @_;
+
+ while ( @$lines ) {
+ # Check for a new document
+ if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
+ while ( @$lines and $lines->[0] !~ /^---/ ) {
+ shift @$lines;
+ }
+ return 1;
+ }
+
+ # Check the indent level
+ $lines->[0] =~ /^(\s*)/;
+ if ( length($1) < $indent->[-1] ) {
+ return 1;
+ } elsif ( length($1) > $indent->[-1] ) {
+ croak("Parse::CPAN::Meta found bad indenting in line '$lines->[0]'");
+ }
+
+ # Get the key
+ unless ( $lines->[0] =~ s/^\s*([^\'\" ][^\n]*?)\s*:(\s+|$)// ) {
+ if ( $lines->[0] =~ /^\s*[?\'\"]/ ) {
+ croak("Parse::CPAN::Meta does not support a feature in line '$lines->[0]'");
+ }
+ croak("Parse::CPAN::Meta failed to classify line '$lines->[0]'");
+ }
+ my $key = $1;
+
+ # Do we have a value?
+ if ( length $lines->[0] ) {
+ # Yes
+ $hash->{$key} = _scalar( shift(@$lines), [ @$indent, undef ], $lines );
+ } else {
+ # An indent
+ shift @$lines;
+ unless ( @$lines ) {
+ $hash->{$key} = undef;
+ return 1;
+ }
+ if ( $lines->[0] =~ /^(\s*)-/ ) {
+ $hash->{$key} = [];
+ _array( $hash->{$key}, [ @$indent, length($1) ], $lines );
+ } elsif ( $lines->[0] =~ /^(\s*)./ ) {
+ my $indent2 = length("$1");
+ if ( $indent->[-1] >= $indent2 ) {
+ # Null hash entry
+ $hash->{$key} = undef;
+ } else {
+ $hash->{$key} = {};
+ _hash( $hash->{$key}, [ @$indent, length($1) ], $lines );
+ }
+ }
+ }
+ }
+
+ return 1;
+ }
+
+ 1;
+
+ __END__
+
+ =pod
+
+ =head1 NAME
+
+ Parse::CPAN::Meta - Parse META.yml and other similar CPAN metadata files
+
+ =head1 SYNOPSIS
+
+ #############################################
+ # In your file
+
+ ---
+ rootproperty: blah
+ section:
+ one: two
+ three: four
+ Foo: Bar
+ empty: ~
+
+
+
+ #############################################
+ # In your program
+
+ use Parse::CPAN::Meta;
+
+ # Create a YAML file
+ my @yaml = Parse::CPAN::Meta::LoadFile( 'Meta.yml' );
+
+ # Reading properties
+ my $root = $yaml[0]->{rootproperty};
+ my $one = $yaml[0]->{section}->{one};
+ my $Foo = $yaml[0]->{section}->{Foo};
+
+ =head1 DESCRIPTION
+
+ B<Parse::CPAN::Meta> is a parser for F<META.yml> files, based on the
+ parser half of L<YAML::Tiny>.
+
+ It supports a basic subset of the full YAML specification, enough to
+ implement parsing of typical F<META.yml> files, and other similarly simple
+ YAML files.
+
+ If you need something with more power, move up to a full YAML parser such
+ as L<YAML>, L<YAML::Syck> or L<YAML::LibYAML>.
+
+ B<Parse::CPAN::Meta> provides a very simply API of only two functions,
+ based on the YAML functions of the same name. Wherever possible,
+ identical calling semantics are used.
+
+ All error reporting is done with exceptions (die'ing).
+
+ =head1 FUNCTIONS
+
+ For maintenance clarity, no functions are exported.
+
+ =head2 Load
+
+ my @yaml = Load( $string );
+
+ Parses a string containing a valid YAML stream into a list of Perl data
+ structures.
+
+ =head2 LoadFile
+
+ my @yaml = LoadFile( 'META.yml' );
+
+ Reads the YAML stream from a file instead of a string.
+
+ =head1 SUPPORT
+
+ Bugs should be reported via the CPAN bug tracker at
+
+ L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Parse-CPAN-Meta>
+
+ =head1 AUTHOR
+
+ Adam Kennedy E<lt>adamk@cpan.orgE<gt>
+
+ =head1 SEE ALSO
+
+ L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>,
+ L<http://use.perl.org/~Alias/journal/29427>, L<http://ali.as/>
+
+ =head1 COPYRIGHT
+
+ Copyright 2006 - 2009 Adam Kennedy.
+
+ This program is free software; you can redistribute
+ it and/or modify it under the same terms as Perl itself.
+
+ The full text of the license can be found in the
+ LICENSE file included with this module.
+
+ =cut
+PARSE_CPAN_META + +$fatpacked{"lib/core/only.pm"} = <<'LIB_CORE_ONLY'; + package lib::core::only; + + use strict; + use warnings FATAL => 'all'; + use Config; + + sub import { + @INC = @Config{qw(privlibexp archlibexp)}; + return + } + + =head1 NAME + + lib::core::only - Remove all non-core paths from @INC to avoid site/vendor dirs + + =head1 SYNOPSIS + + use lib::core::only; # now @INC contains only the two core directories + + To get only the core directories plus the ones for the local::lib in scope: + + $ perl -Mlib::core::only -Mlocal::lib=~/perl5 myscript.pl + + To attempt to do a self-contained build (but note this will not reliably + propagate into subprocesses, see the CAVEATS below): + + $ PERL5OPT='-Mlib::core::only -Mlocal::lib=~/perl5' cpan + + =head1 DESCRIPTION + + lib::core::only is simply a shortcut to say "please reduce my @INC to only + the core lib and archlib (architecture-specific lib) directories of this perl". + + You might want to do this to ensure a local::lib contains only the code you + need, or to test an L<App::FatPacker|App::FatPacker> tree, or to avoid known + bad vendor packages. + + You might want to use this to try and install a self-contained tree of perl + modules. Be warned that that probably won't work (see L</CAVEATS>). + + This module was extracted from L<local::lib|local::lib>'s --self-contained + feature, and contains the only part that ever worked. I apologise to anybody + who thought anything else did. + + =head1 CAVEATS + + This does B<not> propagate properly across perl invocations like local::lib's + stuff does. It can't. It's only a module import, so it B<only affects the + specific perl VM instance in which you load and import() it>. + + If you want to cascade it across invocations, you can set the PERL5OPT + environment variable to '-Mlib::core::only' and it'll sort of work. But be + aware that taint mode ignores this, so some modules' build and test code + probably will as well. + + You also need to be aware that perl's command line options are not processed + in order - -I options take effect before -M options, so + + perl -Mlib::core::only -Ilib + + is unlike to do what you want - it's exactly equivalent to: + + perl -Mlib::core::only + + If you want to combine a core-only @INC with additional paths, you need to + add the additional paths using -M options and the L<lib|lib> module: + + perl -Mlib::core::only -Mlib=lib + + # or if you're trying to test compiled code: + + perl -Mlib::core::only -Mblib + + For more information on the impossibility of sanely propagating this across + module builds without help from the build program, see + L<http://www.shadowcat.co.uk/blog/matt-s-trout/tainted-love> - and for ways + to achieve the old --self-contained feature's results, look at + L<App::FatPacker|App::FatPacker>'s tree function, and at + L<App::cpanminus|cpanm>'s --local-lib-contained feature. + + =head1 AUTHOR + + Matt S. Trout <mst@shadowcat.co.uk> + + =head1 LICENSE + + This library is free software under the same terms as perl itself. + + =head1 COPYRIGHT + + (c) 2010 the lib::core::only L</AUTHOR> as specified above. + + =cut + + 1; +LIB_CORE_ONLY + +$fatpacked{"local/lib.pm"} = <<'LOCAL_LIB'; + use strict; + use warnings; + + package local::lib; + + use 5.008001; # probably works with earlier versions but I'm not supporting them + # (patches would, of course, be welcome) + + use File::Spec (); + use File::Path (); + use Carp (); + use Config; + + our $VERSION = '1.008001'; # 1.8.1 + + our @KNOWN_FLAGS = qw(--self-contained); + + sub import { + my ($class, @args) = @_; + + # Remember what PERL5LIB was when we started + my $perl5lib = $ENV{PERL5LIB} || ''; + + my %arg_store; + for my $arg (@args) { + # check for lethal dash first to stop processing before causing problems + if ($arg =~ /−/) { + die <<'DEATH'; + WHOA THERE! It looks like you've got some fancy dashes in your commandline! + These are *not* the traditional -- dashes that software recognizes. You + probably got these by copy-pasting from the perldoc for this module as + rendered by a UTF8-capable formatter. This most typically happens on an OS X + terminal, but can happen elsewhere too. Please try again after replacing the + dashes with normal minus signs. + DEATH + } + elsif(grep { $arg eq $_ } @KNOWN_FLAGS) { + (my $flag = $arg) =~ s/--//; + $arg_store{$flag} = 1; + } + elsif($arg =~ /^--/) { + die "Unknown import argument: $arg"; + } + else { + # assume that what's left is a path + $arg_store{path} = $arg; + } + } + + if($arg_store{'self-contained'}) { + die "FATAL: The local::lib --self-contained flag has never worked reliably and the original author, Mark Stosberg, was unable or unwilling to maintain it. As such, this flag has been removed from the local::lib codebase in order to prevent misunderstandings and potentially broken builds. The local::lib authors recommend that you look at the lib::core::only module shipped with this distribution in order to create a more robust environment that is equivalent to what --self-contained provided (although quite possibly not what you originally thought it provided due to the poor quality of the documentation, for which we apologise).\n"; + } + + $arg_store{path} = $class->resolve_path($arg_store{path}); + $class->setup_local_lib_for($arg_store{path}); + + for (@INC) { # Untaint @INC + next if ref; # Skip entry if it is an ARRAY, CODE, blessed, etc. + m/(.*)/ and $_ = $1; + } + } + + sub pipeline; + + sub pipeline { + my @methods = @_; + my $last = pop(@methods); + if (@methods) { + \sub { + my ($obj, @args) = @_; + $obj->${pipeline @methods}( + $obj->$last(@args) + ); + }; + } else { + \sub { + shift->$last(@_); + }; + } + } + + =begin testing + + #:: test pipeline + + package local::lib; + + { package Foo; sub foo { -$_[1] } sub bar { $_[1]+2 } sub baz { $_[1]+3 } } + my $foo = bless({}, 'Foo'); + Test::More::ok($foo->${pipeline qw(foo bar baz)}(10) == -15); + + =end testing + + =cut + + sub _uniq { + my %seen; + grep { ! $seen{$_}++ } @_; + } + + sub resolve_path { + my ($class, $path) = @_; + $class->${pipeline qw( + resolve_relative_path + resolve_home_path + resolve_empty_path + )}($path); + } + + sub resolve_empty_path { + my ($class, $path) = @_; + if (defined $path) { + $path; + } else { + '~/perl5'; + } + } + + =begin testing + + #:: test classmethod setup + + my $c = 'local::lib'; + + =end testing + + =begin testing + + #:: test classmethod + + is($c->resolve_empty_path, '~/perl5'); + is($c->resolve_empty_path('foo'), 'foo'); + + =end testing + + =cut + + sub resolve_home_path { + my ($class, $path) = @_; + return $path unless ($path =~ /^~/); + my ($user) = ($path =~ /^~([^\/]+)/); # can assume ^~ so undef for 'us' + my $tried_file_homedir; + my $homedir = do { + if (eval { require File::HomeDir } && $File::HomeDir::VERSION >= 0.65) { + $tried_file_homedir = 1; + if (defined $user) { + File::HomeDir->users_home($user); + } else { + File::HomeDir->my_home; + } + } else { + if (defined $user) { + (getpwnam $user)[7]; + } else { + if (defined $ENV{HOME}) { + $ENV{HOME}; + } else { + (getpwuid $<)[7]; + } + } + } + }; + unless (defined $homedir) { + Carp::croak( + "Couldn't resolve homedir for " + .(defined $user ? $user : 'current user') + .($tried_file_homedir ? '' : ' - consider installing File::HomeDir') + ); + } + $path =~ s/^~[^\/]*/$homedir/; + $path; + } + + sub resolve_relative_path { + my ($class, $path) = @_; + $path = File::Spec->rel2abs($path); + } + + =begin testing + + #:: test classmethod + + local *File::Spec::rel2abs = sub { shift; 'FOO'.shift; }; + is($c->resolve_relative_path('bar'),'FOObar'); + + =end testing + + =cut + + sub setup_local_lib_for { + my ($class, $path) = @_; + $path = $class->ensure_dir_structure_for($path); + if ($0 eq '-') { + $class->print_environment_vars_for($path); + exit 0; + } else { + $class->setup_env_hash_for($path); + @INC = _uniq(split($Config{path_sep}, $ENV{PERL5LIB}), @INC); + } + } + + sub install_base_bin_path { + my ($class, $path) = @_; + File::Spec->catdir($path, 'bin'); + } + + sub install_base_perl_path { + my ($class, $path) = @_; + File::Spec->catdir($path, 'lib', 'perl5'); + } + + sub install_base_arch_path { + my ($class, $path) = @_; + File::Spec->catdir($class->install_base_perl_path($path), $Config{archname}); + } + + sub ensure_dir_structure_for { + my ($class, $path) = @_; + unless (-d $path) { + warn "Attempting to create directory ${path}\n"; + } + File::Path::mkpath($path); + # Need to have the path exist to make a short name for it, so + # converting to a short name here. + $path = Win32::GetShortPathName($path) if $^O eq 'MSWin32'; + + return $path; + } + + sub INTERPOLATE_ENV () { 1 } + sub LITERAL_ENV () { 0 } + + sub guess_shelltype { + my $shellbin = 'sh'; + if(defined $ENV{'SHELL'}) { + my @shell_bin_path_parts = File::Spec->splitpath($ENV{'SHELL'}); + $shellbin = $shell_bin_path_parts[-1]; + } + my $shelltype = do { + local $_ = $shellbin; + if(/csh/) { + 'csh' + } else { + 'bourne' + } + }; + + # Both Win32 and Cygwin have $ENV{COMSPEC} set. + if (defined $ENV{'COMSPEC'} && $^O ne 'cygwin') { + my @shell_bin_path_parts = File::Spec->splitpath($ENV{'COMSPEC'}); + $shellbin = $shell_bin_path_parts[-1]; + $shelltype = do { + local $_ = $shellbin; + if(/command\.com/) { + 'win32' + } elsif(/cmd\.exe/) { + 'win32' + } elsif(/4nt\.exe/) { + 'win32' + } else { + $shelltype + } + }; + } + return $shelltype; + } + + sub print_environment_vars_for { + my ($class, $path) = @_; + print $class->environment_vars_string_for($path); + } + + sub environment_vars_string_for { + my ($class, $path) = @_; + my @envs = $class->build_environment_vars_for($path, LITERAL_ENV); + my $out = ''; + + # rather basic csh detection, goes on the assumption that something won't + # call itself csh unless it really is. also, default to bourne in the + # pathological situation where a user doesn't have $ENV{SHELL} defined. + # note also that shells with funny names, like zoid, are assumed to be + # bourne. + + my $shelltype = $class->guess_shelltype; + + while (@envs) { + my ($name, $value) = (shift(@envs), shift(@envs)); + $value =~ s/(\\")/\\$1/g; + $out .= $class->${\"build_${shelltype}_env_declaration"}($name, $value); + } + return $out; + } + + # simple routines that take two arguments: an %ENV key and a value. return + # strings that are suitable for passing directly to the relevant shell to set + # said key to said value. + sub build_bourne_env_declaration { + my $class = shift; + my($name, $value) = @_; + return qq{export ${name}="${value}"\n}; + } + + sub build_csh_env_declaration { + my $class = shift; + my($name, $value) = @_; + return qq{setenv ${name} "${value}"\n}; + } + + sub build_win32_env_declaration { + my $class = shift; + my($name, $value) = @_; + return qq{set ${name}=${value}\n}; + } + + sub setup_env_hash_for { + my ($class, $path) = @_; + my %envs = $class->build_environment_vars_for($path, INTERPOLATE_ENV); + @ENV{keys %envs} = values %envs; + } + + sub build_environment_vars_for { + my ($class, $path, $interpolate) = @_; + return ( + PERL_LOCAL_LIB_ROOT => $path, + PERL_MB_OPT => "--install_base ${path}", + PERL_MM_OPT => "INSTALL_BASE=${path}", + PERL5LIB => join($Config{path_sep}, + $class->install_base_arch_path($path), + $class->install_base_perl_path($path), + (($ENV{PERL5LIB}||()) ? + ($interpolate == INTERPOLATE_ENV + ? ($ENV{PERL5LIB}) + : (($^O ne 'MSWin32') ? '$PERL5LIB' : '%PERL5LIB%' )) + : ()) + ), + PATH => join($Config{path_sep}, + $class->install_base_bin_path($path), + ($interpolate == INTERPOLATE_ENV + ? ($ENV{PATH}||()) + : (($^O ne 'MSWin32') ? '$PATH' : '%PATH%' )) + ), + ) + } + + =begin testing + + #:: test classmethod + + File::Path::rmtree('t/var/splat'); + + $c->ensure_dir_structure_for('t/var/splat'); + + ok(-d 't/var/splat'); + + =end testing + + =encoding utf8 + + =head1 NAME + + local::lib - create and use a local lib/ for perl modules with PERL5LIB + + =head1 SYNOPSIS + + In code - + + use local::lib; # sets up a local lib at ~/perl5 + + use local::lib '~/foo'; # same, but ~/foo + + # Or... + use FindBin; + use local::lib "$FindBin::Bin/../support"; # app-local support library + + From the shell - + + # Install LWP and its missing dependencies to the '~/perl5' directory + perl -MCPAN -Mlocal::lib -e 'CPAN::install(LWP)' + + # Just print out useful shell commands + $ perl -Mlocal::lib + export PERL_MB_OPT='--install_base /home/username/perl5' + export PERL_MM_OPT='INSTALL_BASE=/home/username/perl5' + export PERL5LIB='/home/username/perl5/lib/perl5/i386-linux:/home/username/perl5/lib/perl5' + export PATH="/home/username/perl5/bin:$PATH" + + =head2 The bootstrapping technique + + A typical way to install local::lib is using what is known as the + "bootstrapping" technique. You would do this if your system administrator + hasn't already installed local::lib. In this case, you'll need to install + local::lib in your home directory. + + If you do have administrative privileges, you will still want to set up your + environment variables, as discussed in step 4. Without this, you would still + install the modules into the system CPAN installation and also your Perl scripts + will not use the lib/ path you bootstrapped with local::lib. + + By default local::lib installs itself and the CPAN modules into ~/perl5. + + Windows users must also see L</Differences when using this module under Win32>. + + 1. Download and unpack the local::lib tarball from CPAN (search for "Download" + on the CPAN page about local::lib). Do this as an ordinary user, not as root + or administrator. Unpack the file in your home directory or in any other + convenient location. + + 2. Run this: + + perl Makefile.PL --bootstrap + + If the system asks you whether it should automatically configure as much + as possible, you would typically answer yes. + + In order to install local::lib into a directory other than the default, you need + to specify the name of the directory when you call bootstrap, as follows: + + perl Makefile.PL --bootstrap=~/foo + + 3. Run this: (local::lib assumes you have make installed on your system) + + make test && make install + + 4. Now we need to setup the appropriate environment variables, so that Perl + starts using our newly generated lib/ directory. If you are using bash or + any other Bourne shells, you can add this to your shell startup script this + way: + + echo 'eval $(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)' >>~/.bashrc + + If you are using C shell, you can do this as follows: + + /bin/csh + echo $SHELL + /bin/csh + perl -I$HOME/perl5/lib/perl5 -Mlocal::lib >> ~/.cshrc + + If you passed to bootstrap a directory other than default, you also need to give that as + import parameter to the call of the local::lib module like this way: + + echo 'eval $(perl -I$HOME/foo/lib/perl5 -Mlocal::lib=$HOME/foo)' >>~/.bashrc + + After writing your shell configuration file, be sure to re-read it to get the + changed settings into your current shell's environment. Bourne shells use + C<. ~/.bashrc> for this, whereas C shells use C<source ~/.cshrc>. + + If you're on a slower machine, or are operating under draconian disk space + limitations, you can disable the automatic generation of manpages from POD when + installing modules by using the C<--no-manpages> argument when bootstrapping: + + perl Makefile.PL --bootstrap --no-manpages + + To avoid doing several bootstrap for several Perl module environments on the + same account, for example if you use it for several different deployed + applications independently, you can use one bootstrapped local::lib + installation to install modules in different directories directly this way: + + cd ~/mydir1 + perl -Mlocal::lib=./ + eval $(perl -Mlocal::lib=./) ### To set the environment for this shell alone + printenv ### You will see that ~/mydir1 is in the PERL5LIB + perl -MCPAN -e install ... ### whatever modules you want + cd ../mydir2 + ... REPEAT ... + + For multiple environments for multiple apps you may need to include a modified + version of the C<< use FindBin >> instructions in the "In code" sample above. + If you did something like the above, you have a set of Perl modules at C<< + ~/mydir1/lib >>. If you have a script at C<< ~/mydir1/scripts/myscript.pl >>, + you need to tell it where to find the modules you installed for it at C<< + ~/mydir1/lib >>. + + In C<< ~/mydir1/scripts/myscript.pl >>: + + use strict; + use warnings; + use local::lib "$FindBin::Bin/.."; ### points to ~/mydir1 and local::lib finds lib + use lib "$FindBin::Bin/../lib"; ### points to ~/mydir1/lib + + Put this before any BEGIN { ... } blocks that require the modules you installed. + + =head2 Differences when using this module under Win32 + + To set up the proper environment variables for your current session of + C<CMD.exe>, you can use this: + + C:\>perl -Mlocal::lib + set PERL_MB_OPT=--install_base C:\DOCUME~1\ADMINI~1\perl5 + set PERL_MM_OPT=INSTALL_BASE=C:\DOCUME~1\ADMINI~1\perl5 + set PERL5LIB=C:\DOCUME~1\ADMINI~1\perl5\lib\perl5;C:\DOCUME~1\ADMINI~1\perl5\lib\perl5\MSWin32-x86-multi-thread + set PATH=C:\DOCUME~1\ADMINI~1\perl5\bin;%PATH% + + ### To set the environment for this shell alone + C:\>perl -Mlocal::lib > %TEMP%\tmp.bat && %TEMP%\tmp.bat && del %TEMP%\temp.bat + ### instead of $(perl -Mlocal::lib=./) + + If you want the environment entries to persist, you'll need to add then to the + Control Panel's System applet yourself or use L<App::local::lib::Win32Helper>. + + The "~" is translated to the user's profile directory (the directory named for + the user under "Documents and Settings" (Windows XP or earlier) or "Users" + (Windows Vista or later)) unless $ENV{HOME} exists. After that, the home + directory is translated to a short name (which means the directory must exist) + and the subdirectories are created. + + =head1 RATIONALE + + The version of a Perl package on your machine is not always the version you + need. Obviously, the best thing to do would be to update to the version you + need. However, you might be in a situation where you're prevented from doing + this. Perhaps you don't have system administrator privileges; or perhaps you + are using a package management system such as Debian, and nobody has yet gotten + around to packaging up the version you need. + + local::lib solves this problem by allowing you to create your own directory of + Perl packages downloaded from CPAN (in a multi-user system, this would typically + be within your own home directory). The existing system Perl installation is + not affected; you simply invoke Perl with special options so that Perl uses the + packages in your own local package directory rather than the system packages. + local::lib arranges things so that your locally installed version of the Perl + packages takes precedence over the system installation. + + If you are using a package management system (such as Debian), you don't need to + worry about Debian and CPAN stepping on each other's toes. Your local version + of the packages will be written to an entirely separate directory from those + installed by Debian. + + =head1 DESCRIPTION + + This module provides a quick, convenient way of bootstrapping a user-local Perl + module library located within the user's home directory. It also constructs and + prints out for the user the list of environment variables using the syntax + appropriate for the user's current shell (as specified by the C<SHELL> + environment variable), suitable for directly adding to one's shell + configuration file. + + More generally, local::lib allows for the bootstrapping and usage of a + directory containing Perl modules outside of Perl's C<@INC>. This makes it + easier to ship an application with an app-specific copy of a Perl module, or + collection of modules. Useful in cases like when an upstream maintainer hasn't + applied a patch to a module of theirs that you need for your application. + + On import, local::lib sets the following environment variables to appropriate + values: + + =over 4 + + =item PERL_MB_OPT + + =item PERL_MM_OPT + + =item PERL5LIB + + =item PATH + + PATH is appended to, rather than clobbered. + + =back + + These values are then available for reference by any code after import. + + =head1 CREATING A SELF-CONTAINED SET OF MODULES + + See L<lib::core::only> for one way to do this - but note that + there are a number of caveats, and the best approach is always to perform a + build against a clean perl (i.e. site and vendor as close to empty as possible). + + =head1 METHODS + + =head2 ensure_dir_structure_for + + =over 4 + + =item Arguments: $path + + =item Return value: None + + =back + + Attempts to create the given path, and all required parent directories. Throws + an exception on failure. + + =head2 print_environment_vars_for + + =over 4 + + =item Arguments: $path + + =item Return value: None + + =back + + Prints to standard output the variables listed above, properly set to use the + given path as the base directory. + + =head2 build_environment_vars_for + + =over 4 + + =item Arguments: $path, $interpolate + + =item Return value: \%environment_vars + + =back + + Returns a hash with the variables listed above, properly set to use the + given path as the base directory. + + =head2 setup_env_hash_for + + =over 4 + + =item Arguments: $path + + =item Return value: None + + =back + + Constructs the C<%ENV> keys for the given path, by calling + L</build_environment_vars_for>. + + =head2 install_base_perl_path + + =over 4 + + =item Arguments: $path + + =item Return value: $install_base_perl_path + + =back + + Returns a path describing where to install the Perl modules for this local + library installation. Appends the directories C<lib> and C<perl5> to the given + path. + + =head2 install_base_arch_path + + =over 4 + + =item Arguments: $path + + =item Return value: $install_base_arch_path + + =back + + Returns a path describing where to install the architecture-specific Perl + modules for this local library installation. Based on the + L</install_base_perl_path> method's return value, and appends the value of + C<$Config{archname}>. + + =head2 install_base_bin_path + + =over 4 + + =item Arguments: $path + + =item Return value: $install_base_bin_path + + =back + + Returns a path describing where to install the executable programs for this + local library installation. Based on the L</install_base_perl_path> method's + return value, and appends the directory C<bin>. + + =head2 resolve_empty_path + + =over 4 + + =item Arguments: $path + + =item Return value: $base_path + + =back + + Builds and returns the base path into which to set up the local module + installation. Defaults to C<~/perl5>. + + =head2 resolve_home_path + + =over 4 + + =item Arguments: $path + + =item Return value: $home_path + + =back + + Attempts to find the user's home directory. If installed, uses C<File::HomeDir> + for this purpose. If no definite answer is available, throws an exception. + + =head2 resolve_relative_path + + =over 4 + + =item Arguments: $path + + =item Return value: $absolute_path + + =back + + Translates the given path into an absolute path. + + =head2 resolve_path + + =over 4 + + =item Arguments: $path + + =item Return value: $absolute_path + + =back + + Calls the following in a pipeline, passing the result from the previous to the + next, in an attempt to find where to configure the environment for a local + library installation: L</resolve_empty_path>, L</resolve_home_path>, + L</resolve_relative_path>. Passes the given path argument to + L</resolve_empty_path> which then returns a result that is passed to + L</resolve_home_path>, which then has its result passed to + L</resolve_relative_path>. The result of this final call is returned from + L</resolve_path>. + + =head1 A WARNING ABOUT UNINST=1 + + Be careful about using local::lib in combination with "make install UNINST=1". + The idea of this feature is that will uninstall an old version of a module + before installing a new one. However it lacks a safety check that the old + version and the new version will go in the same directory. Used in combination + with local::lib, you can potentially delete a globally accessible version of a + module while installing the new version in a local place. Only combine "make + install UNINST=1" and local::lib if you understand these possible consequences. + + =head1 LIMITATIONS + + The perl toolchain is unable to handle directory names with spaces in it, + so you cant put your local::lib bootstrap into a directory with spaces. What + you can do is moving your local::lib to a directory with spaces B<after> you + installed all modules inside your local::lib bootstrap. But be aware that you + cant update or install CPAN modules after the move. + + Rather basic shell detection. Right now anything with csh in its name is + assumed to be a C shell or something compatible, and everything else is assumed + to be Bourne, except on Win32 systems. If the C<SHELL> environment variable is + not set, a Bourne-compatible shell is assumed. + + Bootstrap is a hack and will use CPAN.pm for ExtUtils::MakeMaker even if you + have CPANPLUS installed. + + Kills any existing PERL5LIB, PERL_MM_OPT or PERL_MB_OPT. + + Should probably auto-fixup CPAN config if not already done. + + Patches very much welcome for any of the above. + + On Win32 systems, does not have a way to write the created environment variables + to the registry, so that they can persist through a reboot. + + =head1 TROUBLESHOOTING + + If you've configured local::lib to install CPAN modules somewhere in to your + home directory, and at some point later you try to install a module with C<cpan + -i Foo::Bar>, but it fails with an error like: C<Warning: You do not have + permissions to install into /usr/lib64/perl5/site_perl/5.8.8/x86_64-linux at + /usr/lib64/perl5/5.8.8/Foo/Bar.pm> and buried within the install log is an + error saying C<'INSTALL_BASE' is not a known MakeMaker parameter name>, then + you've somehow lost your updated ExtUtils::MakeMaker module. + + To remedy this situation, rerun the bootstrapping procedure documented above. + + Then, run C<rm -r ~/.cpan/build/Foo-Bar*> + + Finally, re-run C<cpan -i Foo::Bar> and it should install without problems. + + =head1 ENVIRONMENT + + =over 4 + + =item SHELL + + =item COMSPEC + + local::lib looks at the user's C<SHELL> environment variable when printing out + commands to add to the shell configuration file. + + On Win32 systems, C<COMSPEC> is also examined. + + =back + + =head1 SUPPORT + + IRC: + + Join #local-lib on irc.perl.org. + + =head1 AUTHOR + + Matt S Trout <mst@shadowcat.co.uk> http://www.shadowcat.co.uk/ + + auto_install fixes kindly sponsored by http://www.takkle.com/ + + =head1 CONTRIBUTORS + + Patches to correctly output commands for csh style shells, as well as some + documentation additions, contributed by Christopher Nehren <apeiron@cpan.org>. + + Doc patches for a custom local::lib directory, more cleanups in the english + documentation and a L<german documentation|POD2::DE::local::lib> contributed by Torsten Raudssus + <torsten@raudssus.de>. + + Hans Dieter Pearcey <hdp@cpan.org> sent in some additional tests for ensuring + things will install properly, submitted a fix for the bug causing problems with + writing Makefiles during bootstrapping, contributed an example program, and + submitted yet another fix to ensure that local::lib can install and bootstrap + properly. Many, many thanks! + + pattern of Freenode IRC contributed the beginnings of the Troubleshooting + section. Many thanks! + + Patch to add Win32 support contributed by Curtis Jewell <csjewell@cpan.org>. + + Warnings for missing PATH/PERL5LIB (as when not running interactively) silenced + by a patch from Marco Emilio Poleggi. + + Mark Stosberg <mark@summersault.com> provided the code for the now deleted + '--self-contained' option. + + Documentation patches to make win32 usage clearer by + David Mertens <dcmertens.perl@gmail.com> (run4flat). + + Brazilian L<portuguese translation|POD2::PT_BR::local::lib> and minor doc patches contributed by Breno + G. de Oliveira <garu@cpan.org>. + + =head1 COPYRIGHT + + Copyright (c) 2007 - 2010 the local::lib L</AUTHOR> and L</CONTRIBUTORS> as + listed above. + + =head1 LICENSE + + This library is free software and may be distributed under the same terms + as perl itself. + + =cut + + 1; +LOCAL_LIB + +$fatpacked{"version.pm"} = <<'VERSION'; + #!perl -w + package version; + + use 5.005_04; + use strict; + + use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv); + + $VERSION = 0.88; + + $CLASS = 'version'; + + #--------------------------------------------------------------------------# + # Version regexp components + #--------------------------------------------------------------------------# + + # Fraction part of a decimal version number. This is a common part of + # both strict and lax decimal versions + + my $FRACTION_PART = qr/\.[0-9]+/; + + # First part of either decimal or dotted-decimal strict version number. + # Unsigned integer with no leading zeroes (except for zero itself) to + # avoid confusion with octal. + + my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/; + + # First part of either decimal or dotted-decimal lax version number. + # Unsigned integer, but allowing leading zeros. Always interpreted + # as decimal. However, some forms of the resulting syntax give odd + # results if used as ordinary Perl expressions, due to how perl treats + # octals. E.g. + # version->new("010" ) == 10 + # version->new( 010 ) == 8 + # version->new( 010.2) == 82 # "8" . "2" + + my $LAX_INTEGER_PART = qr/[0-9]+/; + + # Second and subsequent part of a strict dotted-decimal version number. + # Leading zeroes are permitted, and the number is always decimal. + # Limited to three digits to avoid overflow when converting to decimal + # form and also avoid problematic style with excessive leading zeroes. + + my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/; + + # Second and subsequent part of a lax dotted-decimal version number. + # Leading zeroes are permitted, and the number is always decimal. No + # limit on the numerical value or number of digits, so there is the + # possibility of overflow when converting to decimal form. + + my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/; + + # Alpha suffix part of lax version number syntax. Acts like a + # dotted-decimal part. + + my $LAX_ALPHA_PART = qr/_[0-9]+/; + + #--------------------------------------------------------------------------# + # Strict version regexp definitions + #--------------------------------------------------------------------------# + + # Strict decimal version number. + + my $STRICT_DECIMAL_VERSION = + qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x; + + # Strict dotted-decimal version number. Must have both leading "v" and + # at least three parts, to avoid confusion with decimal syntax. + + my $STRICT_DOTTED_DECIMAL_VERSION = + qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x; + + # Complete strict version number syntax -- should generally be used + # anchored: qr/ \A $STRICT \z /x + + $STRICT = + qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x; + + #--------------------------------------------------------------------------# + # Lax version regexp definitions + #--------------------------------------------------------------------------# + + # Lax decimal version number. Just like the strict one except for + # allowing an alpha suffix or allowing a leading or trailing + # decimal-point + + my $LAX_DECIMAL_VERSION = + qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )? + | + $FRACTION_PART $LAX_ALPHA_PART? + /x; + + # Lax dotted-decimal version number. Distinguished by having either + # leading "v" or at least three non-alpha parts. Alpha part is only + # permitted if there are at least two non-alpha parts. Strangely + # enough, without the leading "v", Perl takes .1.2 to mean v0.1.2, + # so when there is no "v", the leading part is optional + + my $LAX_DOTTED_DECIMAL_VERSION = + qr/ + v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )? + | + $LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART? + /x; + + # Complete lax version number syntax -- should generally be used + # anchored: qr/ \A $LAX \z /x + # + # The string 'undef' is a special case to make for easier handling + # of return values from ExtUtils::MM->parse_version + + $LAX = + qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x; + + #--------------------------------------------------------------------------# + + eval "use version::vxs $VERSION"; + if ( $@ ) { # don't have the XS version installed + eval "use version::vpp $VERSION"; # don't tempt fate + die "$@" if ( $@ ); + push @ISA, "version::vpp"; + local $^W; + *version::qv = \&version::vpp::qv; + *version::declare = \&version::vpp::declare; + *version::_VERSION = \&version::vpp::_VERSION; + if ($] >= 5.009000 && $] < 5.011004) { + no strict 'refs'; + *version::stringify = \&version::vpp::stringify; + *{'version::(""'} = \&version::vpp::stringify; + *version::new = \&version::vpp::new; + *version::parse = \&version::vpp::parse; + } + } + else { # use XS module + push @ISA, "version::vxs"; + local $^W; + *version::declare = \&version::vxs::declare; + *version::qv = \&version::vxs::qv; + *version::_VERSION = \&version::vxs::_VERSION; + *version::vcmp = \&version::vxs::VCMP; + if ($] >= 5.009000 && $] < 5.011004) { + no strict 'refs'; + *version::stringify = \&version::vxs::stringify; + *{'version::(""'} = \&version::vxs::stringify; + *version::new = \&version::vxs::new; + *version::parse = \&version::vxs::parse; + } + + } + + # Preloaded methods go here. + sub import { + no strict 'refs'; + my ($class) = shift; + + # Set up any derived class + unless ($class eq 'version') { + local $^W; + *{$class.'::declare'} = \&version::declare; + *{$class.'::qv'} = \&version::qv; + } + + my %args; + if (@_) { # any remaining terms are arguments + map { $args{$_} = 1 } @_ + } + else { # no parameters at all on use line + %args = + ( + qv => 1, + 'UNIVERSAL::VERSION' => 1, + ); + } + + my $callpkg = caller(); + + if (exists($args{declare})) { + *{$callpkg.'::declare'} = + sub {return $class->declare(shift) } + unless defined(&{$callpkg.'::declare'}); + } + + if (exists($args{qv})) { + *{$callpkg.'::qv'} = + sub {return $class->qv(shift) } + unless defined(&{$callpkg.'::qv'}); + } + + if (exists($args{'UNIVERSAL::VERSION'})) { + local $^W; + *UNIVERSAL::VERSION + = \&version::_VERSION; + } + + if (exists($args{'VERSION'})) { + *{$callpkg.'::VERSION'} = \&version::_VERSION; + } + + if (exists($args{'is_strict'})) { + *{$callpkg.'::is_strict'} = \&version::is_strict + unless defined(&{$callpkg.'::is_strict'}); + } + + if (exists($args{'is_lax'})) { + *{$callpkg.'::is_lax'} = \&version::is_lax + unless defined(&{$callpkg.'::is_lax'}); + } + } + + sub is_strict { defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x } + sub is_lax { defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x } + + 1; +VERSION + +$fatpacked{"version/vpp.pm"} = <<'VERSION_VPP'; + package charstar; + # a little helper class to emulate C char* semantics in Perl + # so that prescan_version can use the same code as in C + + use overload ( + '""' => \&thischar, + '0+' => \&thischar, + '++' => \&increment, + '--' => \&decrement, + '+' => \&plus, + '-' => \&minus, + '*' => \&multiply, + 'cmp' => \&cmp, + '<=>' => \&spaceship, + 'bool' => \&thischar, + '=' => \&clone, + ); + + sub new { + my ($self, $string) = @_; + my $class = ref($self) || $self; + + my $obj = { + string => [split(//,$string)], + current => 0, + }; + return bless $obj, $class; + } + + sub thischar { + my ($self) = @_; + my $last = $#{$self->{string}}; + my $curr = $self->{current}; + if ($curr >= 0 && $curr <= $last) { + return $self->{string}->[$curr]; + } + else { + return ''; + } + } + + sub increment { + my ($self) = @_; + $self->{current}++; + } + + sub decrement { + my ($self) = @_; + $self->{current}--; + } + + sub plus { + my ($self, $offset) = @_; + my $rself = $self->clone; + $rself->{current} += $offset; + return $rself; + } + + sub minus { + my ($self, $offset) = @_; + my $rself = $self->clone; + $rself->{current} -= $offset; + return $rself; + } + + sub multiply { + my ($left, $right, $swapped) = @_; + my $char = $left->thischar(); + return $char * $right; + } + + sub spaceship { + my ($left, $right, $swapped) = @_; + unless (ref($right)) { # not an object already + $right = $left->new($right); + } + return $left->{current} <=> $right->{current}; + } + + sub cmp { + my ($left, $right, $swapped) = @_; + unless (ref($right)) { # not an object already + if (length($right) == 1) { # comparing single character only + return $left->thischar cmp $right; + } + $right = $left->new($right); + } + return $left->currstr cmp $right->currstr; + } + + sub bool { + my ($self) = @_; + my $char = $self->thischar; + return ($char ne ''); + } + + sub clone { + my ($left, $right, $swapped) = @_; + $right = { + string => [@{$left->{string}}], + current => $left->{current}, + }; + return bless $right, ref($left); + } + + sub currstr { + my ($self, $s) = @_; + my $curr = $self->{current}; + my $last = $#{$self->{string}}; + if (defined($s) && $s->{current} < $last) { + $last = $s->{current}; + } + + my $string = join('', @{$self->{string}}[$curr..$last]); + return $string; + } + + package version::vpp; + use strict; + + use POSIX qw/locale_h/; + use locale; + use vars qw ($VERSION @ISA @REGEXS); + $VERSION = 0.88; + + use overload ( + '""' => \&stringify, + '0+' => \&numify, + 'cmp' => \&vcmp, + '<=>' => \&vcmp, + 'bool' => \&vbool, + 'nomethod' => \&vnoop, + ); + + eval "use warnings"; + if ($@) { + eval ' + package warnings; + sub enabled {return $^W;} + 1; + '; + } + + my $VERSION_MAX = 0x7FFFFFFF; + + # implement prescan_version as closely to the C version as possible + use constant TRUE => 1; + use constant FALSE => 0; + + sub isDIGIT { + my ($char) = shift->thischar(); + return ($char =~ /\d/); + } + + sub isALPHA { + my ($char) = shift->thischar(); + return ($char =~ /[a-zA-Z]/); + } + + sub isSPACE { + my ($char) = shift->thischar(); + return ($char =~ /\s/); + } + + sub BADVERSION { + my ($s, $errstr, $error) = @_; + if ($errstr) { + $$errstr = $error; + } + return $s; + } + + sub prescan_version { + my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_; + my $qv = defined $sqv ? $$sqv : FALSE; + my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0; + my $width = defined $swidth ? $$swidth : 3; + my $alpha = defined $salpha ? $$salpha : FALSE; + + my $d = $s; + + if ($qv && isDIGIT($d)) { + goto dotted_decimal_version; + } + + if ($d eq 'v') { # explicit v-string + $d++; + if (isDIGIT($d)) { + $qv = TRUE; + } + else { # degenerate v-string + # requires v1.2.3 + return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); + } + + dotted_decimal_version: + if ($strict && $d eq '0' && isDIGIT($d+1)) { + # no leading zeros allowed + return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)"); + } + + while (isDIGIT($d)) { # integer part + $d++; + } + + if ($d eq '.') + { + $saw_decimal++; + $d++; # decimal point + } + else + { + if ($strict) { + # require v1.2.3 + return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); + } + else { + goto version_prescan_finish; + } + } + + { + my $i = 0; + my $j = 0; + while (isDIGIT($d)) { # just keep reading + $i++; + while (isDIGIT($d)) { + $d++; $j++; + # maximum 3 digits between decimal + if ($strict && $j > 3) { + return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)"); + } + } + if ($d eq '_') { + if ($strict) { + return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); + } + if ( $alpha ) { + return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)"); + } + $d++; + $alpha = TRUE; + } + elsif ($d eq '.') { + if ($alpha) { + return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)"); + } + $saw_decimal++; + $d++; + } + elsif (!isDIGIT($d)) { + last; + } + $j = 0; + } + + if ($strict && $i < 2) { + # requires v1.2.3 + return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); + } + } + } # end if dotted-decimal + else + { # decimal versions + # special $strict case for leading '.' or '0' + if ($strict) { + if ($d eq '.') { + return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)"); + } + if ($d eq '0' && isDIGIT($d+1)) { + return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)"); + } + } + + # consume all of the integer part + while (isDIGIT($d)) { + $d++; + } + + # look for a fractional part + if ($d eq '.') { + # we found it, so consume it + $saw_decimal++; + $d++; + } + elsif (!$d || $d eq ';' || isSPACE($d) || $d eq '}') { + if ( $d == $s ) { + # found nothing + return BADVERSION($s,$errstr,"Invalid version format (version required)"); + } + # found just an integer + goto version_prescan_finish; + } + elsif ( $d == $s ) { + # didn't find either integer or period + return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); + } + elsif ($d eq '_') { + # underscore can't come after integer part + if ($strict) { + return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); + } + elsif (isDIGIT($d+1)) { + return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)"); + } + else { + return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)"); + } + } + elsif ($d) { + # anything else after integer part is just invalid data + return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); + } + + # scan the fractional part after the decimal point + if ($d && !isDIGIT($d) && ($strict || ! ($d eq ';' || isSPACE($d) || $d eq '}') )) { + # $strict or lax-but-not-the-end + return BADVERSION($s,$errstr,"Invalid version format (fractional part required)"); + } + + while (isDIGIT($d)) { + $d++; + if ($d eq '.' && isDIGIT($d-1)) { + if ($alpha) { + return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)"); + } + if ($strict) { + return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')"); + } + $d = $s; # start all over again + $qv = TRUE; + goto dotted_decimal_version; + } + if ($d eq '_') { + if ($strict) { + return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); + } + if ( $alpha ) { + return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)"); + } + if ( ! isDIGIT($d+1) ) { + return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)"); + } + $d++; + $alpha = TRUE; + } + } + } + + version_prescan_finish: + while (isSPACE($d)) { + $d++; + } + + if ($d && !isDIGIT($d) && (! ($d eq ';' || $d eq '}') )) { + # trailing non-numeric data + return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); + } + + if (defined $sqv) { + $$sqv = $qv; + } + if (defined $swidth) { + $$swidth = $width; + } + if (defined $ssaw_decimal) { + $$ssaw_decimal = $saw_decimal; + } + if (defined $salpha) { + $$salpha = $alpha; + } + return $d; + } + + sub scan_version { + my ($s, $rv, $qv) = @_; + my $start; + my $pos; + my $last; + my $errstr; + my $saw_decimal = 0; + my $width = 3; + my $alpha = FALSE; + my $vinf = FALSE; + my @av; + + $s = new charstar $s; + + while (isSPACE($s)) { # leading whitespace is OK + $s++; + } + + $last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal, + \$width, \$alpha); + + if ($errstr) { + # 'undef' is a special case and not an error + if ( $s ne 'undef') { + use Carp; + Carp::croak($errstr); + } + } + + $start = $s; + if ($s eq 'v') { + $s++; + } + $pos = $s; + + if ( $qv ) { + $$rv->{qv} = $qv; + } + if ( $alpha ) { + $$rv->{alpha} = $alpha; + } + if ( !$qv && $width < 3 ) { + $$rv->{width} = $width; + } + + while (isDIGIT($pos)) { + $pos++; + } + if (!isALPHA($pos)) { + my $rev; + + for (;;) { + $rev = 0; + { + # this is atoi() that delimits on underscores + my $end = $pos; + my $mult = 1; + my $orev; + + # the following if() will only be true after the decimal + # point of a version originally created with a bare + # floating point number, i.e. not quoted in any way + # + if ( !$qv && $s > $start && $saw_decimal == 1 ) { + $mult *= 100; + while ( $s < $end ) { + $orev = $rev; + $rev += $s * $mult; + $mult /= 10; + if ( (abs($orev) > abs($rev)) + || (abs($rev) > $VERSION_MAX )) { + warn("Integer overflow in version %d", + $VERSION_MAX); + $s = $end - 1; + $rev = $VERSION_MAX; + $vinf = 1; + } + $s++; + if ( $s eq '_' ) { + $s++; + } + } + } + else { + while (--$end >= $s) { + $orev = $rev; + $rev += $end * $mult; + $mult *= 10; + if ( (abs($orev) > abs($rev)) + || (abs($rev) > $VERSION_MAX )) { + warn("Integer overflow in version"); + $end = $s - 1; + $rev = $VERSION_MAX; + $vinf = 1; + } + } + } + } + + # Append revision + push @av, $rev; + if ( $vinf ) { + $s = $last; + last; + } + elsif ( $pos eq '.' ) { + $s = ++$pos; + } + elsif ( $pos eq '_' && isDIGIT($pos+1) ) { + $s = ++$pos; + } + elsif ( $pos eq ',' && isDIGIT($pos+1) ) { + $s = ++$pos; + } + elsif ( isDIGIT($pos) ) { + $s = $pos; + } + else { + $s = $pos; + last; + } + if ( $qv ) { + while ( isDIGIT($pos) ) { + $pos++; + } + } + else { + my $digits = 0; + while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) { + if ( $pos ne '_' ) { + $digits++; + } + $pos++; + } + } + } + } + if ( $qv ) { # quoted versions always get at least three terms + my $len = $#av; + # This for loop appears to trigger a compiler bug on OS X, as it + # loops infinitely. Yes, len is negative. No, it makes no sense. + # Compiler in question is: + # gcc version 3.3 20030304 (Apple Computer, Inc. build 1640) + # for ( len = 2 - len; len > 0; len-- ) + # av_push(MUTABLE_AV(sv), newSViv(0)); + # + $len = 2 - $len; + while ($len-- > 0) { + push @av, 0; + } + } + + # need to save off the current version string for later + if ( $vinf ) { + $$rv->{original} = "v.Inf"; + $$rv->{vinf} = 1; + } + elsif ( $s > $start ) { + $$rv->{original} = $start->currstr($s); + if ( $qv && $saw_decimal == 1 && $start ne 'v' ) { + # need to insert a v to be consistent + $$rv->{original} = 'v' . $$rv->{original}; + } + } + else { + $$rv->{original} = '0'; + push(@av, 0); + } + + # And finally, store the AV in the hash + $$rv->{version} = \@av; + + # fix RT#19517 - special case 'undef' as string + if ($s eq 'undef') { + $s += 5; + } + + return $s; + } + + sub new + { + my ($class, $value) = @_; + my $self = bless ({}, ref ($class) || $class); + my $qv = FALSE; + + if ( ref($value) && eval('$value->isa("version")') ) { + # Can copy the elements directly + $self->{version} = [ @{$value->{version} } ]; + $self->{qv} = 1 if $value->{qv}; + $self->{alpha} = 1 if $value->{alpha}; + $self->{original} = ''.$value->{original}; + return $self; + } + + my $currlocale = setlocale(LC_ALL); + + # if the current locale uses commas for decimal points, we + # just replace commas with decimal places, rather than changing + # locales + if ( localeconv()->{decimal_point} eq ',' ) { + $value =~ tr/,/./; + } + + if ( not defined $value or $value =~ /^undef$/ ) { + # RT #19517 - special case for undef comparison + # or someone forgot to pass a value + push @{$self->{version}}, 0; + $self->{original} = "0"; + return ($self); + } + + if ( $#_ == 2 ) { # must be CVS-style + $value = $_[2]; + $qv = TRUE; + } + + $value = _un_vstring($value); + + # exponential notation + if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) { + $value = sprintf("%.9f",$value); + $value =~ s/(0+)$//; # trim trailing zeros + } + + my $s = scan_version($value, \$self, $qv); + + if ($s) { # must be something left over + warn("Version string '%s' contains invalid data; " + ."ignoring: '%s'", $value, $s); + } + + return ($self); + } + + *parse = \&new; + + sub numify + { + my ($self) = @_; + unless (_verify($self)) { + require Carp; + Carp::croak("Invalid version object"); + } + my $width = $self->{width} || 3; + my $alpha = $self->{alpha} || ""; + my $len = $#{$self->{version}}; + my $digit = $self->{version}[0]; + my $string = sprintf("%d.", $digit ); + + for ( my $i = 1 ; $i < $len ; $i++ ) { + $digit = $self->{version}[$i]; + if ( $width < 3 ) { + my $denom = 10**(3-$width); + my $quot = int($digit/$denom); + my $rem = $digit - ($quot * $denom); + $string .= sprintf("%0".$width."d_%d", $quot, $rem); + } + else { + $string .= sprintf("%03d", $digit); + } + } + + if ( $len > 0 ) { + $digit = $self->{version}[$len]; + if ( $alpha && $width == 3 ) { + $string .= "_"; + } + $string .= sprintf("%0".$width."d", $digit); + } + else # $len = 0 + { + $string .= sprintf("000"); + } + + return $string; + } + + sub normal + { + my ($self) = @_; + unless (_verify($self)) { + require Carp; + Carp::croak("Invalid version object"); + } + my $alpha = $self->{alpha} || ""; + my $len = $#{$self->{version}}; + my $digit = $self->{version}[0]; + my $string = sprintf("v%d", $digit ); + + for ( my $i = 1 ; $i < $len ; $i++ ) { + $digit = $self->{version}[$i]; + $string .= sprintf(".%d", $digit); + } + + if ( $len > 0 ) { + $digit = $self->{version}[$len]; + if ( $alpha ) { + $string .= sprintf("_%0d", $digit); + } + else { + $string .= sprintf(".%0d", $digit); + } + } + + if ( $len <= 2 ) { + for ( $len = 2 - $len; $len != 0; $len-- ) { + $string .= sprintf(".%0d", 0); + } + } + + return $string; + } + + sub stringify + { + my ($self) = @_; + unless (_verify($self)) { + require Carp; + Carp::croak("Invalid version object"); + } + return exists $self->{original} + ? $self->{original} + : exists $self->{qv} + ? $self->normal + : $self->numify; + } + + sub vcmp + { + require UNIVERSAL; + my ($left,$right,$swap) = @_; + my $class = ref($left); + unless ( UNIVERSAL::isa($right, $class) ) { + $right = $class->new($right); + } + + if ( $swap ) { + ($left, $right) = ($right, $left); + } + unless (_verify($left)) { + require Carp; + Carp::croak("Invalid version object"); + } + unless (_verify($right)) { + require Carp; + Carp::croak("Invalid version object"); + } + my $l = $#{$left->{version}}; + my $r = $#{$right->{version}}; + my $m = $l < $r ? $l : $r; + my $lalpha = $left->is_alpha; + my $ralpha = $right->is_alpha; + my $retval = 0; + my $i = 0; + while ( $i <= $m && $retval == 0 ) { + $retval = $left->{version}[$i] <=> $right->{version}[$i]; + $i++; + } + + # tiebreaker for alpha with identical terms + if ( $retval == 0 + && $l == $r + && $left->{version}[$m] == $right->{version}[$m] + && ( $lalpha || $ralpha ) ) { + + if ( $lalpha && !$ralpha ) { + $retval = -1; + } + elsif ( $ralpha && !$lalpha) { + $retval = +1; + } + } + + # possible match except for trailing 0's + if ( $retval == 0 && $l != $r ) { + if ( $l < $r ) { + while ( $i <= $r && $retval == 0 ) { + if ( $right->{version}[$i] != 0 ) { + $retval = -1; # not a match after all + } + $i++; + } + } + else { + while ( $i <= $l && $retval == 0 ) { + if ( $left->{version}[$i] != 0 ) { + $retval = +1; # not a match after all + } + $i++; + } + } + } + + return $retval; + } + + sub vbool { + my ($self) = @_; + return vcmp($self,$self->new("0"),1); + } + + sub vnoop { + require Carp; + Carp::croak("operation not supported with version object"); + } + + sub is_alpha { + my ($self) = @_; + return (exists $self->{alpha}); + } + + sub qv { + my $value = shift; + my $class = 'version'; + if (@_) { + $class = ref($value) || $value; + $value = shift; + } + + $value = _un_vstring($value); + $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/; + my $version = $class->new($value); + return $version; + } + + *declare = \&qv; + + sub is_qv { + my ($self) = @_; + return (exists $self->{qv}); + } + + + sub _verify { + my ($self) = @_; + if ( ref($self) + && eval { exists $self->{version} } + && ref($self->{version}) eq 'ARRAY' + ) { + return 1; + } + else { + return 0; + } + } + + sub _is_non_alphanumeric { + my $s = shift; + $s = new charstar $s; + while ($s) { + return 0 if isSPACE($s); # early out + return 1 unless (isALPHA($s) || isDIGIT($s) || $s =~ /[.-]/); + $s++; + } + return 0; + } + + sub _un_vstring { + my $value = shift; + # may be a v-string + if ( length($value) >= 3 && $value !~ /[._]/ + && _is_non_alphanumeric($value)) { + my $tvalue; + if ( $] ge 5.008_001 ) { + $tvalue = _find_magic_vstring($value); + $value = $tvalue if length $tvalue; + } + elsif ( $] ge 5.006_000 ) { + $tvalue = sprintf("v%vd",$value); + if ( $tvalue =~ /^v\d+(\.\d+){2,}$/ ) { + # must be a v-string + $value = $tvalue; + } + } + } + return $value; + } + + sub _find_magic_vstring { + my $value = shift; + my $tvalue = ''; + require B; + my $sv = B::svref_2object(\$value); + my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef; + while ( $magic ) { + if ( $magic->TYPE eq 'V' ) { + $tvalue = $magic->PTR; + $tvalue =~ s/^v?(.+)$/v$1/; + last; + } + else { + $magic = $magic->MOREMAGIC; + } + } + return $tvalue; + } + + sub _VERSION { + my ($obj, $req) = @_; + my $class = ref($obj) || $obj; + + no strict 'refs'; + if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) { + # file but no package + require Carp; + Carp::croak( "$class defines neither package nor VERSION" + ."--version check failed"); + } + + my $version = eval "\$$class\::VERSION"; + if ( defined $version ) { + local $^W if $] <= 5.008; + $version = version::vpp->new($version); + } + + if ( defined $req ) { + unless ( defined $version ) { + require Carp; + my $msg = $] < 5.006 + ? "$class version $req required--this is only version " + : "$class does not define \$$class\::VERSION" + ."--version check failed"; + + if ( $ENV{VERSION_DEBUG} ) { + Carp::confess($msg); + } + else { + Carp::croak($msg); + } + } + + $req = version::vpp->new($req); + + if ( $req > $version ) { + require Carp; + if ( $req->is_qv ) { + Carp::croak( + sprintf ("%s version %s required--". + "this is only version %s", $class, + $req->normal, $version->normal) + ); + } + else { + Carp::croak( + sprintf ("%s version %s required--". + "this is only version %s", $class, + $req->stringify, $version->stringify) + ); + } + } + } + + return defined $version ? $version->stringify : undef; + } + + 1; #this line is important and will help the module return a true value +VERSION_VPP + +s/^ //mg for values %fatpacked; + +unshift @INC, sub { + if (my $fat = $fatpacked{$_[1]}) { + open my $fh, '<', \$fat + or die "FatPacker error loading $_[1] (could be a perl installation issue?)"; + return $fh; + } + return +}; + +} # END OF FATPACK CODE + +use strict; +use App::cpanminus::script; + +unless (caller) { + my $app = App::cpanminus::script->new; + $app->parse_options(@ARGV); + $app->doit or exit(1); +} + +__END__ + +=head1 NAME + +cpanm - get, unpack build and install modules from CPAN + +=head1 SYNOPSIS + + cpanm Test::More # install Test::More + cpanm MIYAGAWA/Plack-0.99_05.tar.gz # full distribution path + cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz # install from URL + cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz # install from a local file + cpanm --interactive Task::Kensho # Configure interactively + cpanm . # install from local directory + cpanm --installdeps . # install all the deps for the current directory + cpanm -L extlib Plack # install Plack and all non-core deps into extlib + cpanm --mirror http://cpan.cpantesters.org/ DBI # use the fast-syncing mirror + +=head1 COMMANDS + +=over 4 + +=item -i, --install + +Installs the modules. This is a default behavior and this is just a +compatibility option to make it work like L<cpan> or L<cpanp>. + +=item --self-upgrade + +Upgrades itself. It's just an alias for: + + cpanm App::cpanminus + +=item --info + +Displays the distribution information in +C<AUTHOR/Dist-Name-ver.tar.gz> format in the standard out. + +=item --installdeps + +Installs the dependencies of the target distribution but won't build +itself. Handy if you want to try the application from a version +controlled repository such as git. + + cpanm --installdeps . + +=item --look + +Download and unpack the distribution and then open the directory with +your shell. Handy to poke around the source code or do the manual +testing. + +=item -h, --help + +Displays the help message. + +=item -V, --version + +Displays the version number. + +=back + +=head1 OPTIONS + +You can specify the default options in C<PERL_CPANM_OPT> environment variable. + +=over 4 + +=item -f, --force + +Force install modules even when testing failed. + +=item -n, --notest + +Skip the testing of modules. Use this only when you just want to save +time for installing hundreds of distributions to the same perl and +architecture you've already tested to make sure it builds fine. + +Defaults to false, and you can say C<--no-notest> to override when it +is set in the default options in C<PERL_CPANM_OPT>. + +=item -S, --sudo + +Switch to the root user with C<sudo> when installing modules. Use this +if you want to install modules to the system perl include path. + +Defaults to false, and you can say C<--no-sudo> to override when it is +set in the default options in C<PERL_CPANM_OPT>. + +=item -v, --verbose + +Makes the output verbose. It also enables the interactive +configuration. (See --interactive) + +=item -q, --quiet + +Makes the output even more quiet than the default. It doesn't print +anything to the STDERR. + +=item -l, --local-lib + +Sets the L<local::lib> compatible path to install modules to. You +don't need to set this if you already configure the shell environment +variables using L<local::lib>, but this can be used to override that +as well. + +=item -L, --local-lib-contained + +Same with C<--local-lib> but when examining the dependencies, it +assumes no non-core modules are installed on the system. It's handy if +you want to bundle application dependencies in one directory so you +can distribute to other machines. + +For instance, + + cpanm -L extlib Plack + +would install Plack and all of its non-core dependencies into the +directory C<extlib>, which can be loaded from your application with: + + use local::lib '/path/to/extlib'; + +=item --mirror + +Specifies the base URL for the CPAN mirror to use, such as +C<http://cpan.cpantesters.org/> (you can omit the trailing slash). You +can specify multiple mirror URLs by repeating the command line option. + +Defaults to C<http://search.cpan.org/CPAN> which is a geo location +aware redirector. + +=item --mirror-only + +Download the mirror's 02packages.details.txt.gz index file instead of +querying the CPAN Meta DB. + +Select this option if you are using a local mirror of CPAN, such as +minicpan when you're offline, or your own CPAN index (a.k.a darkpan). + +B<Tip:> It might be useful if you name these mirror options with your +shell aliases, like: + + alias minicpanm='cpanm --mirror ~/minicpan --mirror-only' + alias darkpan='cpanm --mirror http://mycompany.example.com/DPAN --mirror-only' + +=item --prompt + +Prompts when a test fails so that you can skip, force install, retry +or look in the shell to see what's going wrong. It also prompts when +one of the dependency failed if you want to proceed the installation. + +Defaults to false, and you can say C<--no-prompt> to override if it's +set in the default options in C<PERL_CPANM_OPT>. + +=item --reinstall + +cpanm, when given a module name in the command line (i.e. C<cpanm +Plack>), checks the locally installed version first and skips if it is +already installed. This option makes it skip the check, so: + + cpanm --reinstall Plack + +would reinstall L<Plack> even if your locally installed version is +latest, or even newer (which would happen if you install a developer +release from version control repositories). + +Defaults to false. + +=item --interactive + +Makes the configuration (such as C<Makefile.PL> and C<Build.PL>) +interactive, so you can answer questions in the distribution that +requires custom configuration or Task:: distributions. + +Defaults to false, and you can say C<--no-interactive> to override +when it's set in the default options in C<PERL_CPANM_OPT>. + +=item --uninst-shadows + +Uninstalls the shadow files of the distribution that you're +installing. This eliminates the confusion if you're trying to install +core (dual-life) modules from CPAN against perl 5.10 or older, or +modules that used to be XS-based but switched to pure perl at some +version. + +If you run cpanm as root and use C<INSTALL_BASE> or equivalent to +specify custom installation path, you SHOULD disable this option so +you won't accidentally uninstall dual-life modules from the core +include path. + +Defaults to true if your perl version is smaller than 5.12, and you +can disable that with C<--no-uninst-shadows>. + +B<NOTE>: Since version 1.3000 this flag is turned off by default for +perl newer than 5.12, since with 5.12 @INC contains site_perl directory +I<before> the perl core library path, and uninstalling shadows is not +necessary anymore and does more harm by deleting files from the core +library path. + +=item --auto-cleanup + +Specifies the number of days in whcih cpanm's work directories +expire. Defaults to 7, which means old work directories will be +cleaned up in one week. + +You can set the value to C<0> to make cpan never cleanup those +directories. + +=item --lwp + +Uses L<LWP> module to download stuff over HTTP. Defaults to true, and +you can say C<--no-lwp> to disable using LWP, when you want to upgrade +LWP from CPAN on some broken perl systems. + +=item --wget + +Uses GNU Wget (if available) to download stuff. Defaults to true, and +you can say C<--no-wget> to disable using Wget (versions of Wget older +than 1.9 don't support the C<--retry-connrefused> option used by cpanm). + +=item --curl + +Uses cURL (if available) to download stuff. Defaults to true, and +you can say C<--no-curl> to disable using cURL. + +Normally with C<--lwp>, C<--wget> and C<--curl> options set to true +(which is the default) cpanm tries L<LWP>, Wget, cURL and L<HTTP::Tiny> +(in that order) and uses the first one available. + +=back + +=head1 SEE ALSO + +L<App::cpanminus> + +=head1 COPYRIGHT + +Copyright 2010 Tatsuhiko Miyagawa. + +=head1 AUTHOR + +Tatsuhiko Miyagawa + +=cut diff --git a/perl-external/bin/module-manage.pl b/perl-external/bin/module-manage.pl new file mode 100755 index 000000000..f0defb75c --- /dev/null +++ b/perl-external/bin/module-manage.pl @@ -0,0 +1,159 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use IPC::Run3; +use LWP::Simple; +use File::Slurp; +use Path::Class; +use List::MoreUtils 'uniq'; + +my $root_dir = file(__FILE__)->dir->parent->absolute->stringify; +my $module_list = "$root_dir/modules.txt"; +my $url_list = "$root_dir/urls.txt"; +my $minicpan = "$root_dir/minicpan"; + +my %actions = ( + add => \&add, + build_all => \&build_all, + fetch_all => \&fetch_all, + force_install => \&force_install, + index_minicpan => \&index_minicpan, + init => \&init, + setup => \&setup, + sort_files => \&sort_files, + zap => \&zap, +); + +# work out what to run +my ( $action, @args ) = @ARGV; +$actions{$action} + ? $actions{$action}->(@args) + : die "Usage: $0 action [args ...]\n"; + +exit; + +############################################################################ + +sub init { + add('App::cpanminus'); + add('MyCPAN::App::DPAN'); +} + +sub setup { + fetch_all(); + build('App::cpanminus'); + build('MyCPAN::App::DPAN'); + build_all(); +} + +sub add { + my $module = shift || die "Usage: $0 add Dist::To::Add"; + + # try to install the distribution using cpanm + my $out = ''; + my $cmd = "cpanm --reinstall $module"; + + # print " running '$cmd'\n"; + run3( $cmd, undef, \$out, \$out ) + || die "Error running '$cmd'"; + + my @fetched_urls = + map { s{.*(http://\S+).*}{$1}; $_ } + grep { m{^Fetching http://search.cpan.org} } + split /\n/, $out; + + write_file( $module_list, { append => 1 }, "$module\n" ); + write_file( $url_list, { append => 1 }, map { "$_\n" } @fetched_urls ); + sort_files(); + + fetch_all(); + index_minicpan(); + + if ( $out =~ m{FAIL} ) { + die "\n\n\n" + . "ERROR: Something did not build correctly" + . " - please see ~/.cpanm/build_log for details" + . "\n\n\n"; + } +} + +sub index_minicpan { + + # go to the minicpan dir and run dpan there + if ( `which dpan` =~ m/\S/ ) { + chdir $minicpan; + system "dpan -f ../dpan_config"; + } + else { + warn "Skipping indexing - could not find dpan"; + } +} + +sub build_all { + my @modules = sort uniq map { s{\s+$}{}; $_; } read_file($module_list); + build($_) for @modules; +} + +sub build { + my $module = shift # + || die "Usage: $0 build Module::To::Build\n"; + + print " --- installing $module ---\n"; + + my $out = ''; + my $cmd = "cpanm --mirror $minicpan --mirror-only $module"; + + # print " running '$cmd'\n"; + + run3( $cmd, undef, \$out, \$out ) + || die "Error running '$cmd'"; + + my @lines = + grep { m{\S} } + split /\n+/, $out; + my $last_line = $lines[-1]; + + die "Error building '$module':\n\n$last_line\n\n$out\n\n" + unless $last_line =~ m{Successfully installed } + || $last_line =~ m{is up to date} + || $last_line =~ m{\d+ distributions? installed}; +} + +sub fetch_all { + my @urls = sort uniq map { s{\s+$}{}; $_; } read_file($url_list); + fetch($_) for @urls; +} + +sub fetch { + my $url = shift; + my ($filename) = $url =~ m{/(authors/.+)$}; + + my $destination = file("$minicpan/$filename"); + $destination->dir->mkpath; + + return if -e $destination; + + print " Fetching $url\n"; + print " -> $destination\n"; + + is_success( getstore( $url, "$destination" ) ) + || die "Error saving $url to $destination"; +} + +sub zap { + + # delete all the bits that are generated + my $local_lib_root = $ENV{PERL_LOCAL_LIB_ROOT} || die; + dir($local_lib_root)->rmtree(1); + dir($minicpan)->subdir('authors')->rmtree(1); +} + +sub sort_files { + foreach my $file ( $url_list, $module_list ) { + my @entries = read_file($file); + @entries = uniq sort @entries; + write_file( $file, @entries ); + } +}
\ No newline at end of file diff --git a/perl-external/dpan_config b/perl-external/dpan_config new file mode 100644 index 000000000..cd0d0b203 --- /dev/null +++ b/perl-external/dpan_config @@ -0,0 +1,2 @@ +extra_reports_dir extra_reports +skip_dists_regexes common-sense
\ No newline at end of file diff --git a/perl-external/dpan_l4p_config b/perl-external/dpan_l4p_config new file mode 100644 index 000000000..dace9b77f --- /dev/null +++ b/perl-external/dpan_l4p_config @@ -0,0 +1,5 @@ +log4perl.rootLogger = DEBUG, Screen + +log4perl.appender.Screen = Log::Log4perl::Appender::Screen +log4perl.appender.Screen.stderr = 0 +log4perl.appender.Screen.layout = Log::Log4perl::Layout::SimpleLayout diff --git a/perl-external/lib/perl5/local/lib.pm b/perl-external/lib/perl5/local/lib.pm new file mode 100644 index 000000000..65e5365a6 --- /dev/null +++ b/perl-external/lib/perl5/local/lib.pm @@ -0,0 +1,844 @@ +use strict; +use warnings; + +package local::lib; + +use 5.008001; # probably works with earlier versions but I'm not supporting them + # (patches would, of course, be welcome) + +use File::Spec (); +use File::Path (); +use Carp (); +use Config; + +our $VERSION = '1.008001'; # 1.8.1 + +our @KNOWN_FLAGS = qw(--self-contained); + +sub import { + my ($class, @args) = @_; + + # Remember what PERL5LIB was when we started + my $perl5lib = $ENV{PERL5LIB} || ''; + + my %arg_store; + for my $arg (@args) { + # check for lethal dash first to stop processing before causing problems + if ($arg =~ /−/) { + die <<'DEATH'; +WHOA THERE! It looks like you've got some fancy dashes in your commandline! +These are *not* the traditional -- dashes that software recognizes. You +probably got these by copy-pasting from the perldoc for this module as +rendered by a UTF8-capable formatter. This most typically happens on an OS X +terminal, but can happen elsewhere too. Please try again after replacing the +dashes with normal minus signs. +DEATH + } + elsif(grep { $arg eq $_ } @KNOWN_FLAGS) { + (my $flag = $arg) =~ s/--//; + $arg_store{$flag} = 1; + } + elsif($arg =~ /^--/) { + die "Unknown import argument: $arg"; + } + else { + # assume that what's left is a path + $arg_store{path} = $arg; + } + } + + if($arg_store{'self-contained'}) { + die "FATAL: The local::lib --self-contained flag has never worked reliably and the original author, Mark Stosberg, was unable or unwilling to maintain it. As such, this flag has been removed from the local::lib codebase in order to prevent misunderstandings and potentially broken builds. The local::lib authors recommend that you look at the lib::core::only module shipped with this distribution in order to create a more robust environment that is equivalent to what --self-contained provided (although quite possibly not what you originally thought it provided due to the poor quality of the documentation, for which we apologise).\n"; + } + + $arg_store{path} = $class->resolve_path($arg_store{path}); + $class->setup_local_lib_for($arg_store{path}); + + for (@INC) { # Untaint @INC + next if ref; # Skip entry if it is an ARRAY, CODE, blessed, etc. + m/(.*)/ and $_ = $1; + } +} + +sub pipeline; + +sub pipeline { + my @methods = @_; + my $last = pop(@methods); + if (@methods) { + \sub { + my ($obj, @args) = @_; + $obj->${pipeline @methods}( + $obj->$last(@args) + ); + }; + } else { + \sub { + shift->$last(@_); + }; + } +} + +=begin testing + +#:: test pipeline + +package local::lib; + +{ package Foo; sub foo { -$_[1] } sub bar { $_[1]+2 } sub baz { $_[1]+3 } } +my $foo = bless({}, 'Foo'); +Test::More::ok($foo->${pipeline qw(foo bar baz)}(10) == -15); + +=end testing + +=cut + +sub _uniq { + my %seen; + grep { ! $seen{$_}++ } @_; +} + +sub resolve_path { + my ($class, $path) = @_; + $class->${pipeline qw( + resolve_relative_path + resolve_home_path + resolve_empty_path + )}($path); +} + +sub resolve_empty_path { + my ($class, $path) = @_; + if (defined $path) { + $path; + } else { + '~/perl5'; + } +} + +=begin testing + +#:: test classmethod setup + +my $c = 'local::lib'; + +=end testing + +=begin testing + +#:: test classmethod + +is($c->resolve_empty_path, '~/perl5'); +is($c->resolve_empty_path('foo'), 'foo'); + +=end testing + +=cut + +sub resolve_home_path { + my ($class, $path) = @_; + return $path unless ($path =~ /^~/); + my ($user) = ($path =~ /^~([^\/]+)/); # can assume ^~ so undef for 'us' + my $tried_file_homedir; + my $homedir = do { + if (eval { require File::HomeDir } && $File::HomeDir::VERSION >= 0.65) { + $tried_file_homedir = 1; + if (defined $user) { + File::HomeDir->users_home($user); + } else { + File::HomeDir->my_home; + } + } else { + if (defined $user) { + (getpwnam $user)[7]; + } else { + if (defined $ENV{HOME}) { + $ENV{HOME}; + } else { + (getpwuid $<)[7]; + } + } + } + }; + unless (defined $homedir) { + Carp::croak( + "Couldn't resolve homedir for " + .(defined $user ? $user : 'current user') + .($tried_file_homedir ? '' : ' - consider installing File::HomeDir') + ); + } + $path =~ s/^~[^\/]*/$homedir/; + $path; +} + +sub resolve_relative_path { + my ($class, $path) = @_; + $path = File::Spec->rel2abs($path); +} + +=begin testing + +#:: test classmethod + +local *File::Spec::rel2abs = sub { shift; 'FOO'.shift; }; +is($c->resolve_relative_path('bar'),'FOObar'); + +=end testing + +=cut + +sub setup_local_lib_for { + my ($class, $path) = @_; + $path = $class->ensure_dir_structure_for($path); + if ($0 eq '-') { + $class->print_environment_vars_for($path); + exit 0; + } else { + $class->setup_env_hash_for($path); + @INC = _uniq(split($Config{path_sep}, $ENV{PERL5LIB}), @INC); + } +} + +sub install_base_bin_path { + my ($class, $path) = @_; + File::Spec->catdir($path, 'bin'); +} + +sub install_base_perl_path { + my ($class, $path) = @_; + File::Spec->catdir($path, 'lib', 'perl5'); +} + +sub install_base_arch_path { + my ($class, $path) = @_; + File::Spec->catdir($class->install_base_perl_path($path), $Config{archname}); +} + +sub ensure_dir_structure_for { + my ($class, $path) = @_; + unless (-d $path) { + warn "Attempting to create directory ${path}\n"; + } + File::Path::mkpath($path); + # Need to have the path exist to make a short name for it, so + # converting to a short name here. + $path = Win32::GetShortPathName($path) if $^O eq 'MSWin32'; + + return $path; +} + +sub INTERPOLATE_ENV () { 1 } +sub LITERAL_ENV () { 0 } + +sub guess_shelltype { + my $shellbin = 'sh'; + if(defined $ENV{'SHELL'}) { + my @shell_bin_path_parts = File::Spec->splitpath($ENV{'SHELL'}); + $shellbin = $shell_bin_path_parts[-1]; + } + my $shelltype = do { + local $_ = $shellbin; + if(/csh/) { + 'csh' + } else { + 'bourne' + } + }; + + # Both Win32 and Cygwin have $ENV{COMSPEC} set. + if (defined $ENV{'COMSPEC'} && $^O ne 'cygwin') { + my @shell_bin_path_parts = File::Spec->splitpath($ENV{'COMSPEC'}); + $shellbin = $shell_bin_path_parts[-1]; + $shelltype = do { + local $_ = $shellbin; + if(/command\.com/) { + 'win32' + } elsif(/cmd\.exe/) { + 'win32' + } elsif(/4nt\.exe/) { + 'win32' + } else { + $shelltype + } + }; + } + return $shelltype; +} + +sub print_environment_vars_for { + my ($class, $path) = @_; + print $class->environment_vars_string_for($path); +} + +sub environment_vars_string_for { + my ($class, $path) = @_; + my @envs = $class->build_environment_vars_for($path, LITERAL_ENV); + my $out = ''; + + # rather basic csh detection, goes on the assumption that something won't + # call itself csh unless it really is. also, default to bourne in the + # pathological situation where a user doesn't have $ENV{SHELL} defined. + # note also that shells with funny names, like zoid, are assumed to be + # bourne. + + my $shelltype = $class->guess_shelltype; + + while (@envs) { + my ($name, $value) = (shift(@envs), shift(@envs)); + $value =~ s/(\\")/\\$1/g; + $out .= $class->${\"build_${shelltype}_env_declaration"}($name, $value); + } + return $out; +} + +# simple routines that take two arguments: an %ENV key and a value. return +# strings that are suitable for passing directly to the relevant shell to set +# said key to said value. +sub build_bourne_env_declaration { + my $class = shift; + my($name, $value) = @_; + return qq{export ${name}="${value}"\n}; +} + +sub build_csh_env_declaration { + my $class = shift; + my($name, $value) = @_; + return qq{setenv ${name} "${value}"\n}; +} + +sub build_win32_env_declaration { + my $class = shift; + my($name, $value) = @_; + return qq{set ${name}=${value}\n}; +} + +sub setup_env_hash_for { + my ($class, $path) = @_; + my %envs = $class->build_environment_vars_for($path, INTERPOLATE_ENV); + @ENV{keys %envs} = values %envs; +} + +sub build_environment_vars_for { + my ($class, $path, $interpolate) = @_; + return ( + PERL_LOCAL_LIB_ROOT => $path, + PERL_MB_OPT => "--install_base ${path}", + PERL_MM_OPT => "INSTALL_BASE=${path}", + PERL5LIB => join($Config{path_sep}, + $class->install_base_arch_path($path), + $class->install_base_perl_path($path), + (($ENV{PERL5LIB}||()) ? + ($interpolate == INTERPOLATE_ENV + ? ($ENV{PERL5LIB}) + : (($^O ne 'MSWin32') ? '$PERL5LIB' : '%PERL5LIB%' )) + : ()) + ), + PATH => join($Config{path_sep}, + $class->install_base_bin_path($path), + ($interpolate == INTERPOLATE_ENV + ? ($ENV{PATH}||()) + : (($^O ne 'MSWin32') ? '$PATH' : '%PATH%' )) + ), + ) +} + +=begin testing + +#:: test classmethod + +File::Path::rmtree('t/var/splat'); + +$c->ensure_dir_structure_for('t/var/splat'); + +ok(-d 't/var/splat'); + +=end testing + +=encoding utf8 + +=head1 NAME + +local::lib - create and use a local lib/ for perl modules with PERL5LIB + +=head1 SYNOPSIS + +In code - + + use local::lib; # sets up a local lib at ~/perl5 + + use local::lib '~/foo'; # same, but ~/foo + + # Or... + use FindBin; + use local::lib "$FindBin::Bin/../support"; # app-local support library + +From the shell - + + # Install LWP and its missing dependencies to the '~/perl5' directory + perl -MCPAN -Mlocal::lib -e 'CPAN::install(LWP)' + + # Just print out useful shell commands + $ perl -Mlocal::lib + export PERL_MB_OPT='--install_base /home/username/perl5' + export PERL_MM_OPT='INSTALL_BASE=/home/username/perl5' + export PERL5LIB='/home/username/perl5/lib/perl5/i386-linux:/home/username/perl5/lib/perl5' + export PATH="/home/username/perl5/bin:$PATH" + +=head2 The bootstrapping technique + +A typical way to install local::lib is using what is known as the +"bootstrapping" technique. You would do this if your system administrator +hasn't already installed local::lib. In this case, you'll need to install +local::lib in your home directory. + +If you do have administrative privileges, you will still want to set up your +environment variables, as discussed in step 4. Without this, you would still +install the modules into the system CPAN installation and also your Perl scripts +will not use the lib/ path you bootstrapped with local::lib. + +By default local::lib installs itself and the CPAN modules into ~/perl5. + +Windows users must also see L</Differences when using this module under Win32>. + +1. Download and unpack the local::lib tarball from CPAN (search for "Download" +on the CPAN page about local::lib). Do this as an ordinary user, not as root +or administrator. Unpack the file in your home directory or in any other +convenient location. + +2. Run this: + + perl Makefile.PL --bootstrap + +If the system asks you whether it should automatically configure as much +as possible, you would typically answer yes. + +In order to install local::lib into a directory other than the default, you need +to specify the name of the directory when you call bootstrap, as follows: + + perl Makefile.PL --bootstrap=~/foo + +3. Run this: (local::lib assumes you have make installed on your system) + + make test && make install + +4. Now we need to setup the appropriate environment variables, so that Perl +starts using our newly generated lib/ directory. If you are using bash or +any other Bourne shells, you can add this to your shell startup script this +way: + + echo 'eval $(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)' >>~/.bashrc + +If you are using C shell, you can do this as follows: + + /bin/csh + echo $SHELL + /bin/csh + perl -I$HOME/perl5/lib/perl5 -Mlocal::lib >> ~/.cshrc + +If you passed to bootstrap a directory other than default, you also need to give that as +import parameter to the call of the local::lib module like this way: + + echo 'eval $(perl -I$HOME/foo/lib/perl5 -Mlocal::lib=$HOME/foo)' >>~/.bashrc + +After writing your shell configuration file, be sure to re-read it to get the +changed settings into your current shell's environment. Bourne shells use +C<. ~/.bashrc> for this, whereas C shells use C<source ~/.cshrc>. + +If you're on a slower machine, or are operating under draconian disk space +limitations, you can disable the automatic generation of manpages from POD when +installing modules by using the C<--no-manpages> argument when bootstrapping: + + perl Makefile.PL --bootstrap --no-manpages + +To avoid doing several bootstrap for several Perl module environments on the +same account, for example if you use it for several different deployed +applications independently, you can use one bootstrapped local::lib +installation to install modules in different directories directly this way: + + cd ~/mydir1 + perl -Mlocal::lib=./ + eval $(perl -Mlocal::lib=./) ### To set the environment for this shell alone + printenv ### You will see that ~/mydir1 is in the PERL5LIB + perl -MCPAN -e install ... ### whatever modules you want + cd ../mydir2 + ... REPEAT ... + +For multiple environments for multiple apps you may need to include a modified +version of the C<< use FindBin >> instructions in the "In code" sample above. +If you did something like the above, you have a set of Perl modules at C<< +~/mydir1/lib >>. If you have a script at C<< ~/mydir1/scripts/myscript.pl >>, +you need to tell it where to find the modules you installed for it at C<< +~/mydir1/lib >>. + +In C<< ~/mydir1/scripts/myscript.pl >>: + + use strict; + use warnings; + use local::lib "$FindBin::Bin/.."; ### points to ~/mydir1 and local::lib finds lib + use lib "$FindBin::Bin/../lib"; ### points to ~/mydir1/lib + +Put this before any BEGIN { ... } blocks that require the modules you installed. + +=head2 Differences when using this module under Win32 + +To set up the proper environment variables for your current session of +C<CMD.exe>, you can use this: + + C:\>perl -Mlocal::lib + set PERL_MB_OPT=--install_base C:\DOCUME~1\ADMINI~1\perl5 + set PERL_MM_OPT=INSTALL_BASE=C:\DOCUME~1\ADMINI~1\perl5 + set PERL5LIB=C:\DOCUME~1\ADMINI~1\perl5\lib\perl5;C:\DOCUME~1\ADMINI~1\perl5\lib\perl5\MSWin32-x86-multi-thread + set PATH=C:\DOCUME~1\ADMINI~1\perl5\bin;%PATH% + + ### To set the environment for this shell alone + C:\>perl -Mlocal::lib > %TEMP%\tmp.bat && %TEMP%\tmp.bat && del %TEMP%\temp.bat + ### instead of $(perl -Mlocal::lib=./) + +If you want the environment entries to persist, you'll need to add then to the +Control Panel's System applet yourself or use L<App::local::lib::Win32Helper>. + +The "~" is translated to the user's profile directory (the directory named for +the user under "Documents and Settings" (Windows XP or earlier) or "Users" +(Windows Vista or later)) unless $ENV{HOME} exists. After that, the home +directory is translated to a short name (which means the directory must exist) +and the subdirectories are created. + +=head1 RATIONALE + +The version of a Perl package on your machine is not always the version you +need. Obviously, the best thing to do would be to update to the version you +need. However, you might be in a situation where you're prevented from doing +this. Perhaps you don't have system administrator privileges; or perhaps you +are using a package management system such as Debian, and nobody has yet gotten +around to packaging up the version you need. + +local::lib solves this problem by allowing you to create your own directory of +Perl packages downloaded from CPAN (in a multi-user system, this would typically +be within your own home directory). The existing system Perl installation is +not affected; you simply invoke Perl with special options so that Perl uses the +packages in your own local package directory rather than the system packages. +local::lib arranges things so that your locally installed version of the Perl +packages takes precedence over the system installation. + +If you are using a package management system (such as Debian), you don't need to +worry about Debian and CPAN stepping on each other's toes. Your local version +of the packages will be written to an entirely separate directory from those +installed by Debian. + +=head1 DESCRIPTION + +This module provides a quick, convenient way of bootstrapping a user-local Perl +module library located within the user's home directory. It also constructs and +prints out for the user the list of environment variables using the syntax +appropriate for the user's current shell (as specified by the C<SHELL> +environment variable), suitable for directly adding to one's shell +configuration file. + +More generally, local::lib allows for the bootstrapping and usage of a +directory containing Perl modules outside of Perl's C<@INC>. This makes it +easier to ship an application with an app-specific copy of a Perl module, or +collection of modules. Useful in cases like when an upstream maintainer hasn't +applied a patch to a module of theirs that you need for your application. + +On import, local::lib sets the following environment variables to appropriate +values: + +=over 4 + +=item PERL_MB_OPT + +=item PERL_MM_OPT + +=item PERL5LIB + +=item PATH + +PATH is appended to, rather than clobbered. + +=back + +These values are then available for reference by any code after import. + +=head1 CREATING A SELF-CONTAINED SET OF MODULES + +See L<lib::core::only> for one way to do this - but note that +there are a number of caveats, and the best approach is always to perform a +build against a clean perl (i.e. site and vendor as close to empty as possible). + +=head1 METHODS + +=head2 ensure_dir_structure_for + +=over 4 + +=item Arguments: $path + +=item Return value: None + +=back + +Attempts to create the given path, and all required parent directories. Throws +an exception on failure. + +=head2 print_environment_vars_for + +=over 4 + +=item Arguments: $path + +=item Return value: None + +=back + +Prints to standard output the variables listed above, properly set to use the +given path as the base directory. + +=head2 build_environment_vars_for + +=over 4 + +=item Arguments: $path, $interpolate + +=item Return value: \%environment_vars + +=back + +Returns a hash with the variables listed above, properly set to use the +given path as the base directory. + +=head2 setup_env_hash_for + +=over 4 + +=item Arguments: $path + +=item Return value: None + +=back + +Constructs the C<%ENV> keys for the given path, by calling +L</build_environment_vars_for>. + +=head2 install_base_perl_path + +=over 4 + +=item Arguments: $path + +=item Return value: $install_base_perl_path + +=back + +Returns a path describing where to install the Perl modules for this local +library installation. Appends the directories C<lib> and C<perl5> to the given +path. + +=head2 install_base_arch_path + +=over 4 + +=item Arguments: $path + +=item Return value: $install_base_arch_path + +=back + +Returns a path describing where to install the architecture-specific Perl +modules for this local library installation. Based on the +L</install_base_perl_path> method's return value, and appends the value of +C<$Config{archname}>. + +=head2 install_base_bin_path + +=over 4 + +=item Arguments: $path + +=item Return value: $install_base_bin_path + +=back + +Returns a path describing where to install the executable programs for this +local library installation. Based on the L</install_base_perl_path> method's +return value, and appends the directory C<bin>. + +=head2 resolve_empty_path + +=over 4 + +=item Arguments: $path + +=item Return value: $base_path + +=back + +Builds and returns the base path into which to set up the local module +installation. Defaults to C<~/perl5>. + +=head2 resolve_home_path + +=over 4 + +=item Arguments: $path + +=item Return value: $home_path + +=back + +Attempts to find the user's home directory. If installed, uses C<File::HomeDir> +for this purpose. If no definite answer is available, throws an exception. + +=head2 resolve_relative_path + +=over 4 + +=item Arguments: $path + +=item Return value: $absolute_path + +=back + +Translates the given path into an absolute path. + +=head2 resolve_path + +=over 4 + +=item Arguments: $path + +=item Return value: $absolute_path + +=back + +Calls the following in a pipeline, passing the result from the previous to the +next, in an attempt to find where to configure the environment for a local +library installation: L</resolve_empty_path>, L</resolve_home_path>, +L</resolve_relative_path>. Passes the given path argument to +L</resolve_empty_path> which then returns a result that is passed to +L</resolve_home_path>, which then has its result passed to +L</resolve_relative_path>. The result of this final call is returned from +L</resolve_path>. + +=head1 A WARNING ABOUT UNINST=1 + +Be careful about using local::lib in combination with "make install UNINST=1". +The idea of this feature is that will uninstall an old version of a module +before installing a new one. However it lacks a safety check that the old +version and the new version will go in the same directory. Used in combination +with local::lib, you can potentially delete a globally accessible version of a +module while installing the new version in a local place. Only combine "make +install UNINST=1" and local::lib if you understand these possible consequences. + +=head1 LIMITATIONS + +The perl toolchain is unable to handle directory names with spaces in it, +so you cant put your local::lib bootstrap into a directory with spaces. What +you can do is moving your local::lib to a directory with spaces B<after> you +installed all modules inside your local::lib bootstrap. But be aware that you +cant update or install CPAN modules after the move. + +Rather basic shell detection. Right now anything with csh in its name is +assumed to be a C shell or something compatible, and everything else is assumed +to be Bourne, except on Win32 systems. If the C<SHELL> environment variable is +not set, a Bourne-compatible shell is assumed. + +Bootstrap is a hack and will use CPAN.pm for ExtUtils::MakeMaker even if you +have CPANPLUS installed. + +Kills any existing PERL5LIB, PERL_MM_OPT or PERL_MB_OPT. + +Should probably auto-fixup CPAN config if not already done. + +Patches very much welcome for any of the above. + +On Win32 systems, does not have a way to write the created environment variables +to the registry, so that they can persist through a reboot. + +=head1 TROUBLESHOOTING + +If you've configured local::lib to install CPAN modules somewhere in to your +home directory, and at some point later you try to install a module with C<cpan +-i Foo::Bar>, but it fails with an error like: C<Warning: You do not have +permissions to install into /usr/lib64/perl5/site_perl/5.8.8/x86_64-linux at +/usr/lib64/perl5/5.8.8/Foo/Bar.pm> and buried within the install log is an +error saying C<'INSTALL_BASE' is not a known MakeMaker parameter name>, then +you've somehow lost your updated ExtUtils::MakeMaker module. + +To remedy this situation, rerun the bootstrapping procedure documented above. + +Then, run C<rm -r ~/.cpan/build/Foo-Bar*> + +Finally, re-run C<cpan -i Foo::Bar> and it should install without problems. + +=head1 ENVIRONMENT + +=over 4 + +=item SHELL + +=item COMSPEC + +local::lib looks at the user's C<SHELL> environment variable when printing out +commands to add to the shell configuration file. + +On Win32 systems, C<COMSPEC> is also examined. + +=back + +=head1 SUPPORT + +IRC: + + Join #local-lib on irc.perl.org. + +=head1 AUTHOR + +Matt S Trout <mst@shadowcat.co.uk> http://www.shadowcat.co.uk/ + +auto_install fixes kindly sponsored by http://www.takkle.com/ + +=head1 CONTRIBUTORS + +Patches to correctly output commands for csh style shells, as well as some +documentation additions, contributed by Christopher Nehren <apeiron@cpan.org>. + +Doc patches for a custom local::lib directory, more cleanups in the english +documentation and a L<german documentation|POD2::DE::local::lib> contributed by Torsten Raudssus +<torsten@raudssus.de>. + +Hans Dieter Pearcey <hdp@cpan.org> sent in some additional tests for ensuring +things will install properly, submitted a fix for the bug causing problems with +writing Makefiles during bootstrapping, contributed an example program, and +submitted yet another fix to ensure that local::lib can install and bootstrap +properly. Many, many thanks! + +pattern of Freenode IRC contributed the beginnings of the Troubleshooting +section. Many thanks! + +Patch to add Win32 support contributed by Curtis Jewell <csjewell@cpan.org>. + +Warnings for missing PATH/PERL5LIB (as when not running interactively) silenced +by a patch from Marco Emilio Poleggi. + +Mark Stosberg <mark@summersault.com> provided the code for the now deleted +'--self-contained' option. + +Documentation patches to make win32 usage clearer by +David Mertens <dcmertens.perl@gmail.com> (run4flat). + +Brazilian L<portuguese translation|POD2::PT_BR::local::lib> and minor doc patches contributed by Breno +G. de Oliveira <garu@cpan.org>. + +=head1 COPYRIGHT + +Copyright (c) 2007 - 2010 the local::lib L</AUTHOR> and L</CONTRIBUTORS> as +listed above. + +=head1 LICENSE + +This library is free software and may be distributed under the same terms +as perl itself. + +=cut + +1; diff --git a/perl-external/minicpan/.gitignore b/perl-external/minicpan/.gitignore new file mode 100644 index 000000000..de1f15c6c --- /dev/null +++ b/perl-external/minicpan/.gitignore @@ -0,0 +1,3 @@ +authors +indexer_reports + diff --git a/perl-external/minicpan/extra_reports/JSON-PP-2.27105.txt b/perl-external/minicpan/extra_reports/JSON-PP-2.27105.txt new file mode 100644 index 000000000..00a013461 --- /dev/null +++ b/perl-external/minicpan/extra_reports/JSON-PP-2.27105.txt @@ -0,0 +1,3 @@ +# Primary package [TAB] version [TAB] dist file [newline] +JSON::PP 2.27105 /home/evdb/fixmystreet/perl-external/minicpan/authors/id/M/MA/MAKAMAKA/JSON-PP-2.27105.tar.gz +JSON::PP::Boolean 2.27105 /home/evdb/fixmystreet/perl-external/minicpan/authors/id/M/MA/MAKAMAKA/JSON-PP-2.27105.tar.gz diff --git a/perl-external/minicpan/extra_reports/common-sense-3.4.txt b/perl-external/minicpan/extra_reports/common-sense-3.4.txt new file mode 100644 index 000000000..6d39e3a0f --- /dev/null +++ b/perl-external/minicpan/extra_reports/common-sense-3.4.txt @@ -0,0 +1,2 @@ +# Primary package [TAB] version [TAB] dist file [newline] +common::sense 3.4 authors/id/M/ML/MLEHMANN/common-sense-3.4.tar.gz
\ No newline at end of file diff --git a/perl-external/minicpan/modules/02packages.details.txt.gz b/perl-external/minicpan/modules/02packages.details.txt.gz Binary files differnew file mode 100644 index 000000000..fcc29a213 --- /dev/null +++ b/perl-external/minicpan/modules/02packages.details.txt.gz diff --git a/perl-external/minicpan/modules/03modlist.data.gz b/perl-external/minicpan/modules/03modlist.data.gz Binary files differnew file mode 100644 index 000000000..9c8cc712e --- /dev/null +++ b/perl-external/minicpan/modules/03modlist.data.gz diff --git a/perl-external/modules.txt b/perl-external/modules.txt new file mode 100644 index 000000000..4e9158aff --- /dev/null +++ b/perl-external/modules.txt @@ -0,0 +1,41 @@ +App::cpanminus +Bundle::DBD::Pg +Catalyst +Catalyst::Action::RenderView +Catalyst::Authentication::Store::DBIx::Class +Catalyst::Devel +Catalyst::Model::Adaptor +Catalyst::Plugin::Authentication +Catalyst::Plugin::ConfigLoader +Catalyst::Plugin::Session::Store::DBIC +Catalyst::Plugin::Static::Simple +Catalyst::Plugin::Unicode +Catalyst::Runtime +Catalyst::View::TT +Class::Unload +Config::General +DBIx::Class +DBIx::Class::FilterColumn +DBIx::Class::Schema::Loader +DBIx::Class::Storage::DBI +Email::Send +Email::Simple +Email::Valid +File::Path +HTML::Entities +HTTP::Server::Simple +HTTP::Server::Simple::CGI +IO::String +Moose +MyCPAN::App::DPAN +Net::Domain::TLD +Path::Class +Readonly +Sort::Key +Sub::Override +Term::Size::Any +Test::More +Test::WWW::Mechanize +Test::WWW::Mechanize::Catalyst +Web::Scraper +namespace::autoclean diff --git a/perl-external/urls.txt b/perl-external/urls.txt new file mode 100644 index 000000000..2c58e64eb --- /dev/null +++ b/perl-external/urls.txt @@ -0,0 +1,220 @@ +http://search.cpan.org/CPAN/authors/id/A/AB/ABRAXXA/Catalyst-View-TT-0.36.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AB/ABRAXXA/DBIx-Class-0.08127.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AB/ABW/AppConfig-1.66.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AB/ABW/Template-Toolkit-2.22.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AC/ACALPINI/Lingua-Stem-It-0.02.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AC/ACOBURN/Lingua-EN-Tagger-0.16.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AD/ADAMK/Class-Inspector-1.25.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AD/ADAMK/DBD-SQLite-1.31.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AD/ADAMK/File-Remove-1.48.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AD/ADAMK/File-ShareDir-1.03.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AD/ADAMK/Module-Install-1.00.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AD/ADAMK/Object-Signature-1.05.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AD/ADAMK/PPI-1.215.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AD/ADAMK/Params-Util-1.03.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AD/ADAMK/Task-Weaken-1.04.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AD/ADAMK/Test-NoWarnings-1.02.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AD/ADAMK/Test-Object-0.07.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AD/ADAMK/Test-SubCalls-1.09.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AD/ADAMK/YAML-Tiny-1.48.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AD/ADIE/Test-Exception-0.31.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AL/ALEXP/Net-Domain-TLD-1.68.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AL/ALGDR/Lingua-Stem-Ru-0.01.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AN/ANDK/CPAN-Checksums-2.07.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AN/ANDYA/CGI-Simple-1.113.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AN/ANDYA/Test-Harness-3.23.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AR/ARJAY/Compress-Bzip2-2.09.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AS/ASKSH/Snowball-Norwegian-1.2.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AS/ASKSH/Snowball-Swedish-1.2.tar.gz +http://search.cpan.org/CPAN/authors/id/A/AU/AUDREYT/Test-use-ok-0.02.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BD/BDFOY/CPAN-PackageDetails-0.25.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BD/BDFOY/ConfigReader-Simple-1.28.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BD/BDFOY/Distribution-Guess-BuildSystem-0.12.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BD/BDFOY/File-Find-Closures-1.09.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BD/BDFOY/Module-Extract-Namespaces-0.14.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BD/BDFOY/Module-Extract-Use-0.17.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BD/BDFOY/Module-Extract-VERSION-0.13.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BD/BDFOY/MyCPAN-App-DPAN-1.28.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BD/BDFOY/MyCPAN-Indexer-1.28.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BD/BDFOY/Test-Output-0.16.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BI/BINGOS/Archive-Tar-1.76.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BI/BINGOS/Module-CoreList-2.45.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BO/BOBTFISH/Catalyst-Action-RenderView-0.16.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BO/BOBTFISH/Catalyst-Authentication-Store-DBIx-Class-0.1401.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BO/BOBTFISH/Catalyst-Devel-1.31.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BO/BOBTFISH/Catalyst-Model-Adaptor-0.10.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BO/BOBTFISH/Catalyst-Plugin-Authentication-0.10017.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BO/BOBTFISH/Catalyst-Plugin-Session-0.31.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BO/BOBTFISH/Catalyst-Plugin-Session-Store-Delegate-0.06.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BO/BOBTFISH/Catalyst-Plugin-Unicode-0.93.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BO/BOBTFISH/Catalyst-Runtime-5.80032.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BO/BOBTFISH/CatalystX-Component-Traits-0.16.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BO/BOBTFISH/MooseX-Getopt-0.35.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BO/BOBTFISH/Test-WWW-Mechanize-Catalyst-0.53.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BO/BOBTFISH/namespace-autoclean-0.12.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BP/BPOWERS/Memoize-ExpireLRU-0.55.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BR/BRICAS/Catalyst-Plugin-ConfigLoader-0.30.tar.gz +http://search.cpan.org/CPAN/authors/id/B/BR/BRICAS/Config-Any-0.20.tar.gz +http://search.cpan.org/CPAN/authors/id/C/CH/CHOCOLATE/Scope-Guard-0.20.tar.gz +http://search.cpan.org/CPAN/authors/id/C/CH/CHORNY/Hook-LexWrap-0.24.tar.gz +http://search.cpan.org/CPAN/authors/id/C/CH/CHORNY/Test-Warn-0.23.tar.gz +http://search.cpan.org/CPAN/authors/id/C/CH/CHORNY/Tie-IxHash-1.22.tar.gz +http://search.cpan.org/CPAN/authors/id/C/CI/CINE/Lingua-Stem-Snowball-Da-1.01.tar.gz +http://search.cpan.org/CPAN/authors/id/C/CO/COGENT/Tree-DAG_Node-1.06.tar.gz +http://search.cpan.org/CPAN/authors/id/C/CR/CRENZ/Module-Find-0.10.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DA/DAGOLDEN/CPAN-Meta-2.110580.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DA/DAGOLDEN/CPAN-Meta-YAML-0.003.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DA/DAGOLDEN/ExtUtils-CBuilder-0.280202.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DA/DAGOLDEN/ExtUtils-ParseXS-2.2206.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DA/DAGOLDEN/Module-Build-0.3800.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DA/DAGOLDEN/Module-Metadata-1.000004.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DA/DAGOLDEN/Parse-CPAN-Meta-1.4401.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DA/DAGOLDEN/Perl-OSType-1.002.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DC/DCANTRELL/Data-Compare-1.22.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DC/DCONWAY/Lingua-EN-Inflect-1.893.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DL/DLAND/File-Path-2.08.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DL/DLUX/Parallel-ForkManager-0.7.9.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DM/DMUEY/File-Copy-Recursive-0.38.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DM/DMUEY/Hash-Merge-0.12.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DO/DOY/Dist-CheckConflicts-0.02.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DO/DOY/Package-Stash-0.26.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DO/DOY/Package-Stash-XS-0.22.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DO/DOY/Try-Tiny-0.09.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DR/DROLSKY/File-ChangeNotify-0.19.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DR/DROLSKY/File-Slurp-9999.13.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DR/DROLSKY/Moose-1.24.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DR/DROLSKY/MooseX-Params-Validate-0.16.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DR/DROLSKY/MooseX-SemiAffordanceAccessor-0.09.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DR/DROLSKY/MooseX-Types-0.25.tar.gz +http://search.cpan.org/CPAN/authors/id/D/DR/DROLSKY/Package-DeprecationManager-0.10.tar.gz +http://search.cpan.org/CPAN/authors/id/F/FD/FDALY/Test-Tester-0.107.tar.gz +http://search.cpan.org/CPAN/authors/id/F/FE/FERREIRA/Devel-Hide-0.0008.tar.gz +http://search.cpan.org/CPAN/authors/id/F/FE/FERREIRA/Exporter-5.63.tar.gz +http://search.cpan.org/CPAN/authors/id/F/FE/FERREIRA/Term-Size-Any-0.001.tar.gz +http://search.cpan.org/CPAN/authors/id/F/FE/FERREIRA/Term-Size-Perl-0.029.tar.gz +http://search.cpan.org/CPAN/authors/id/F/FL/FLORA/B-Hooks-EndOfScope-0.09.tar.gz +http://search.cpan.org/CPAN/authors/id/F/FL/FLORA/Catalyst-Plugin-Session-Store-DBIC-0.11.tar.gz +http://search.cpan.org/CPAN/authors/id/F/FL/FLORA/Class-C3-0.23.tar.gz +http://search.cpan.org/CPAN/authors/id/F/FL/FLORA/Class-C3-Adopt-NEXT-0.13.tar.gz +http://search.cpan.org/CPAN/authors/id/F/FL/FLORA/Class-MOP-1.12.tar.gz +http://search.cpan.org/CPAN/authors/id/F/FL/FLORA/Data-Visitor-0.27.tar.gz +http://search.cpan.org/CPAN/authors/id/F/FL/FLORA/Devel-GlobalDestruction-0.03.tar.gz +http://search.cpan.org/CPAN/authors/id/F/FL/FLORA/HTTP-Request-AsCGI-1.2.tar.gz +http://search.cpan.org/CPAN/authors/id/F/FL/FLORA/MRO-Compat-0.11.tar.gz +http://search.cpan.org/CPAN/authors/id/F/FL/FLORA/MooseX-Emulate-Class-Accessor-Fast-0.00903.tar.gz +http://search.cpan.org/CPAN/authors/id/F/FL/FLORA/MooseX-MethodAttributes-0.24.tar.gz +http://search.cpan.org/CPAN/authors/id/F/FL/FLORA/MooseX-Role-WithOverloading-0.09.tar.gz +http://search.cpan.org/CPAN/authors/id/F/FL/FLORA/Sub-Name-0.05.tar.gz +http://search.cpan.org/CPAN/authors/id/F/FL/FLORA/namespace-clean-0.20.tar.gz +http://search.cpan.org/CPAN/authors/id/F/FR/FREW/Data-Dumper-Concise-2.020.tar.gz +http://search.cpan.org/CPAN/authors/id/F/FR/FREW/SQL-Abstract-1.72.tar.gz +http://search.cpan.org/CPAN/authors/id/G/GA/GAAS/Data-Dump-1.19.tar.gz +http://search.cpan.org/CPAN/authors/id/G/GA/GAAS/Digest-HMAC-1.02.tar.gz +http://search.cpan.org/CPAN/authors/id/G/GA/GAAS/Encode-Locale-1.01.tar.gz +http://search.cpan.org/CPAN/authors/id/G/GA/GAAS/File-Listing-6.00.tar.gz +http://search.cpan.org/CPAN/authors/id/G/GA/GAAS/HTML-Parser-3.68.tar.gz +http://search.cpan.org/CPAN/authors/id/G/GA/GAAS/HTTP-Cookies-6.00.tar.gz +http://search.cpan.org/CPAN/authors/id/G/GA/GAAS/HTTP-Daemon-6.00.tar.gz +http://search.cpan.org/CPAN/authors/id/G/GA/GAAS/HTTP-Date-6.00.tar.gz +http://search.cpan.org/CPAN/authors/id/G/GA/GAAS/HTTP-Message-6.01.tar.gz +http://search.cpan.org/CPAN/authors/id/G/GA/GAAS/HTTP-Negotiate-6.00.tar.gz +http://search.cpan.org/CPAN/authors/id/G/GA/GAAS/IO-String-1.08.tar.gz +http://search.cpan.org/CPAN/authors/id/G/GA/GAAS/LWP-MediaTypes-6.01.tar.gz +http://search.cpan.org/CPAN/authors/id/G/GA/GAAS/Net-HTTP-6.00.tar.gz +http://search.cpan.org/CPAN/authors/id/G/GA/GAAS/URI-1.58.tar.gz +http://search.cpan.org/CPAN/authors/id/G/GA/GAAS/WWW-RobotRules-6.00.tar.gz +http://search.cpan.org/CPAN/authors/id/G/GA/GAAS/libwww-perl-6.01.tar.gz +http://search.cpan.org/CPAN/authors/id/G/GB/GBARR/CPAN-DistnameInfo-0.12.tar.gz +http://search.cpan.org/CPAN/authors/id/G/GB/GBARR/Scalar-List-Utils-1.23.tar.gz +http://search.cpan.org/CPAN/authors/id/G/GE/GETTY/HTTP-Body-1.11.tar.gz +http://search.cpan.org/CPAN/authors/id/G/GR/GRODITI/MooseX-Types-Common-0.001002.tar.gz +http://search.cpan.org/CPAN/authors/id/I/IL/ILMARI/Class-Unload-0.07.tar.gz +http://search.cpan.org/CPAN/authors/id/I/IN/INGY/Test-Base-0.59.tar.gz +http://search.cpan.org/CPAN/authors/id/J/JE/JESSE/HTTP-Server-Simple-0.43.tar.gz +http://search.cpan.org/CPAN/authors/id/J/JP/JPEACOCK/version-0.88.tar.gz +http://search.cpan.org/CPAN/authors/id/J/JR/JROCKWAY/Context-Preserve-0.01.tar.gz +http://search.cpan.org/CPAN/authors/id/K/KW/KWILLIAMS/Path-Class-0.23.tar.gz +http://search.cpan.org/CPAN/authors/id/K/KW/KWILLIAMS/Probe-Perl-0.01.tar.gz +http://search.cpan.org/CPAN/authors/id/L/LB/LBROCARD/Data-Page-2.02.tar.gz +http://search.cpan.org/CPAN/authors/id/M/MA/MAKAMAKA/JSON-2.51.tar.gz +http://search.cpan.org/CPAN/authors/id/M/MA/MAKAMAKA/JSON-PP-2.27105.tar.gz +http://search.cpan.org/CPAN/authors/id/M/MA/MANU/Net-IP-1.25.tar.gz +http://search.cpan.org/CPAN/authors/id/M/MA/MARKOV/MIME-Types-1.31.tar.gz +http://search.cpan.org/CPAN/authors/id/M/MH/MHX/Devel-PPPort-3.19.tar.gz +http://search.cpan.org/CPAN/authors/id/M/MI/MIROD/HTML-TreeBuilder-XPath-0.12.tar.gz +http://search.cpan.org/CPAN/authors/id/M/MI/MIROD/XML-XPathEngine-0.12.tar.gz +http://search.cpan.org/CPAN/authors/id/M/MI/MIYAGAWA/App-cpanminus-1.4004.tar.gz +http://search.cpan.org/CPAN/authors/id/M/MI/MIYAGAWA/HTML-Selector-XPath-0.07.tar.gz +http://search.cpan.org/CPAN/authors/id/M/MI/MIYAGAWA/Web-Scraper-0.34.tar.gz +http://search.cpan.org/CPAN/authors/id/M/ML/MLEHMANN/JSON-XS-2.3.tar.gz +http://search.cpan.org/CPAN/authors/id/M/ML/MLEHMANN/common-sense-3.4.tar.gz +http://search.cpan.org/CPAN/authors/id/M/MR/MRAMBERG/Text-SimpleTable-2.03.tar.gz +http://search.cpan.org/CPAN/authors/id/M/MS/MSCHILLI/Log-Log4perl-1.32.tar.gz +http://search.cpan.org/CPAN/authors/id/M/MS/MSCHWERN/Carp-Assert-0.20.tar.gz +http://search.cpan.org/CPAN/authors/id/M/MS/MSCHWERN/ExtUtils-MakeMaker-6.56.tar.gz +http://search.cpan.org/CPAN/authors/id/M/MS/MSCHWERN/Test-Simple-0.98.tar.gz +http://search.cpan.org/CPAN/authors/id/M/MS/MSCHWERN/UNIVERSAL-require-0.13.tar.gz +http://search.cpan.org/CPAN/authors/id/M/MS/MSTROUT/Catalyst-Plugin-Session-State-Cookie-0.17.tar.gz +http://search.cpan.org/CPAN/authors/id/M/MS/MSTROUT/Catalyst-Plugin-Static-Simple-0.29.tar.gz +http://search.cpan.org/CPAN/authors/id/N/NU/NUFFIN/Tie-ToObject-0.03.tar.gz +http://search.cpan.org/CPAN/authors/id/O/OL/OLAF/Net-DNS-0.66.tar.gz +http://search.cpan.org/CPAN/authors/id/O/OV/OVID/Sub-Override-0.08.tar.gz +http://search.cpan.org/CPAN/authors/id/O/OV/OVID/aliased-0.30.tar.gz +http://search.cpan.org/CPAN/authors/id/P/PE/PETDANCE/Carp-Assert-More-1.12.tar.gz +http://search.cpan.org/CPAN/authors/id/P/PE/PETDANCE/Template-Timer-1.00.tar.gz +http://search.cpan.org/CPAN/authors/id/P/PE/PETDANCE/Test-WWW-Mechanize-1.30.tar.gz +http://search.cpan.org/CPAN/authors/id/P/PE/PETDANCE/WWW-Mechanize-1.66.tar.gz +http://search.cpan.org/CPAN/authors/id/P/PM/PMQS/Compress-Raw-Bzip2-2.033.tar.gz +http://search.cpan.org/CPAN/authors/id/P/PM/PMQS/Compress-Raw-Zlib-2.033.tar.gz +http://search.cpan.org/CPAN/authors/id/P/PM/PMQS/IO-Compress-2.033.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RC/RCLAMP/Class-Accessor-Chained-0.01.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RC/RCLAMP/Devel-Caller-2.05.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RC/RCLAMP/File-Find-Rule-0.32.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RC/RCLAMP/Number-Compare-0.01.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RC/RCLAMP/Text-Glob-0.09.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RD/RDF/Clone-0.31.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RG/RGARCIA/Sub-Identify-0.04.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RG/RGARCIA/Test-LongString-0.15.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RI/RIBASUSHI/Class-C3-Componentised-1.0008.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RJ/RJBS/Data-OptList-0.106.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RJ/RJBS/Email-Date-Format-1.002.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RJ/RJBS/Email-Send-2.198.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RJ/RJBS/Email-Simple-2.100.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RJ/RJBS/Email-Valid-0.184.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RJ/RJBS/Getopt-Long-Descriptive-0.089.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RJ/RJBS/String-RewritePrefix-0.006.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RJ/RJBS/Sub-Exporter-0.982.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RJ/RJBS/Sub-Install-0.925.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RJ/RJBS/Test-Deep-0.108.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RJ/RJBS/Test-Fatal-0.003.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RJ/RJBS/Version-Requirements-0.101020.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RK/RKITOVER/Catalyst-Model-DBIC-Schema-0.48.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RK/RKITOVER/Class-Accessor-Grouped-0.10002.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RK/RKITOVER/DBIx-Class-Schema-Loader-0.07010.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RK/RKITOVER/Lingua-EN-Inflect-Phrase-0.04.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RK/RKITOVER/MooseX-Traits-Pluggable-0.10.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RO/ROBIN/PadWalker-1.92.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RO/ROODE/Readonly-1.03.tar.gz +http://search.cpan.org/CPAN/authors/id/R/RS/RSCHUPP/Module-ScanDeps-1.00.tar.gz +http://search.cpan.org/CPAN/authors/id/S/SA/SALVA/Sort-Key-1.28.tar.gz +http://search.cpan.org/CPAN/authors/id/S/SA/SARTAK/Class-Load-0.06.tar.gz +http://search.cpan.org/CPAN/authors/id/S/SD/SDP/Lingua-Stem-Fr-0.02.tar.gz +http://search.cpan.org/CPAN/authors/id/S/SI/SIMON/Lingua-EN-Inflect-Number-1.1.tar.gz +http://search.cpan.org/CPAN/authors/id/S/SI/SIMONW/Module-Pluggable-3.9.tar.gz +http://search.cpan.org/CPAN/authors/id/S/SM/SMUELLER/Class-XSAccessor-1.11.tar.gz +http://search.cpan.org/CPAN/authors/id/S/SM/SMUELLER/PAR-Dist-0.47.tar.gz +http://search.cpan.org/CPAN/authors/id/S/SM/SMUELLER/PathTools-3.33.tar.gz +http://search.cpan.org/CPAN/authors/id/S/SN/SNOWHARE/Lingua-Stem-0.84.tar.gz +http://search.cpan.org/CPAN/authors/id/S/ST/STBEY/Carp-Clan-6.04.tar.gz +http://search.cpan.org/CPAN/authors/id/S/ST/STEVAN/Tree-Simple-1.18.tar.gz +http://search.cpan.org/CPAN/authors/id/S/ST/STEVAN/Tree-Simple-VisitorFactory-0.10.tar.gz +http://search.cpan.org/CPAN/authors/id/T/TI/TIMB/DBI-1.616.tar.gz +http://search.cpan.org/CPAN/authors/id/T/TJ/TJENNESS/File-Temp-0.22.tar.gz +http://search.cpan.org/CPAN/authors/id/T/TL/TLINDEN/Config-General-2.50.tar.gz +http://search.cpan.org/CPAN/authors/id/T/TM/TMTM/Class-Data-Inheritable-0.08.tar.gz +http://search.cpan.org/CPAN/authors/id/T/TO/TOKUHIROM/Test-Requires-0.06.tar.gz +http://search.cpan.org/CPAN/authors/id/T/TU/TURNSTEP/DBD-Pg-2.17.2.tar.gz +http://search.cpan.org/CPAN/authors/id/U/UL/ULPFR/Text-German-0.06.tar.gz +http://search.cpan.org/CPAN/authors/id/V/VP/VPIT/Variable-Magic-0.46.tar.gz +http://search.cpan.org/CPAN/authors/id/X/XE/XERN/Lingua-PT-Stemmer-0.01.tar.gz +http://search.cpan.org/CPAN/authors/id/Y/YV/YVES/ExtUtils-Install-1.54.tar.gz diff --git a/perllib/Carp/Always.pm b/perllib/Carp/Always.pm deleted file mode 100644 index 68bcaee52..000000000 --- a/perllib/Carp/Always.pm +++ /dev/null @@ -1,162 +0,0 @@ - -package Carp::Always; - -use 5.006; -use strict; -use warnings; - -our $VERSION = '0.09'; - -use Carp qw(verbose); # makes carp() cluck and croak() confess - -sub _warn { - if ($_[-1] =~ /\n$/s) { - my $arg = pop @_; - $arg =~ s/ at .*? line .*?\n$//s; - push @_, $arg; - } - warn &Carp::longmess; -} - -sub _die { - if ($_[-1] =~ /\n$/s) { - my $arg = pop @_; - $arg =~ s/ at .*? line .*?\n$//s; - push @_, $arg; - } - die &Carp::longmess; -} - -my %OLD_SIG; - -BEGIN { - @OLD_SIG{qw(__DIE__ __WARN__)} = @SIG{qw(__DIE__ __WARN__)}; - $SIG{__DIE__} = \&_die; - $SIG{__WARN__} = \&_warn; -} - -END { - @SIG{qw(__DIE__ __WARN__)} = @OLD_SIG{qw(__DIE__ __WARN__)}; -} - -1; -__END__ - -=head1 NAME - -Carp::Always - Warns and dies noisily with stack backtraces - -=head1 SYNOPSIS - - use Carp::Always; - -makes every C<warn()> and C<die()> complains loudly in the calling package -and elsewhere. More often used on the command line: - - perl -MCarp::Always script.pl - -=head1 DESCRIPTION - -This module is meant as a debugging aid. It can be -used to make a script complain loudly with stack backtraces -when warn()ing or die()ing. - -Here are how stack backtraces produced by this module -looks: - - # it works for explicit die's and warn's - $ perl -MCarp::Always -e 'sub f { die "arghh" }; sub g { f }; g' - arghh at -e line 1 - main::f() called at -e line 1 - main::g() called at -e line 1 - - # it works for interpreter-thrown failures - $ perl -MCarp::Always -w -e 'sub f { $a = shift; @a = @$a };' \ - -e 'sub g { f(undef) }; g' - Use of uninitialized value in array dereference at -e line 1 - main::f('undef') called at -e line 2 - main::g() called at -e line 2 - -In the implementation, the C<Carp> module does -the heavy work, through C<longmess()>. The -actual implementation sets the signal hooks -C<$SIG{__WARN__}> and C<$SIG{__DIE__}> to -emit the stack backtraces. - -Oh, by the way, C<carp> and C<croak> when requiring/using -the C<Carp> module are also made verbose, behaving -like C<cloak> and C<confess>, respectively. - -=head2 EXPORT - -Nothing at all is exported. - -=head1 ACKNOWLEDGMENTS - -This module was born as a reaction to a release -of L<Acme::JavaTrace> by Sébastien Aperghis-Tramoni. -Sébastien also has a newer module called -L<Devel::SimpleTrace> with the same code and fewer flame -comments on docs. The pruning of the uselessly long -docs of this module were prodded by Michael Schwern. - -Schwern and others told me "the module name stinked" - -it was called C<Carp::Indeed>. After thinking long -and not getting nowhere, I went with nuffin's suggestion -and now it is called C<Carp::Always>. -C<Carp::Indeed> which is now deprecate -lives in its own distribution (which won't go anywhere -but will stay there as a redirection to this module). - -=head1 SEE ALSO - -=over 4 - -=item * - -L<Carp> - -=item * - -L<Acme::JavaTrace> and L<Devel::SimpleTrace> - -=back - -Please report bugs via CPAN RT -http://rt.cpan.org/NoAuth/Bugs.html?Dist=Carp-Always. - -=head1 BUGS - -Every (un)deserving module has its own pet bugs. - -=over 4 - -=item * - -This module does not play well with other modules which fusses -around with C<warn>, C<die>, C<$SIG{'__WARN__'}>, -C<$SIG{'__DIE__'}>. - -=item * - -Test scripts are good. I should write more of these. - -=item * - -I don't know if this module name is still a bug as it was -at the time of C<Carp::Indeed>. - -=back - -=head1 AUTHOR - -Adriano Ferreira, E<lt>ferreira@cpan.orgE<gt> - -=head1 COPYRIGHT AND LICENSE - -Copyright (C) 2005-2007 by Adriano R. Ferreira - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/perllib/FixMyStreet.pm b/perllib/FixMyStreet.pm new file mode 100644 index 000000000..d63f708d2 --- /dev/null +++ b/perllib/FixMyStreet.pm @@ -0,0 +1,158 @@ +package FixMyStreet; + +use strict; +use warnings; + +use Path::Class; +my $ROOT_DIR = file(__FILE__)->parent->parent->absolute->resolve; + +use Readonly; + +use mySociety::Config; +use mySociety::DBHandle; + +# load the config file and store the contents in a readonly hash +mySociety::Config::set_file( __PACKAGE__->path_to("conf/general") ); +Readonly::Hash my %CONFIG, %{ mySociety::Config::get_list() }; + +=head1 NAME + +FixMyStreet + +=head1 DESCRIPTION + +FixMyStreet is a webite where you can report issues and have them routed to the +correct authority so that they can be fixed. + +Thus module has utility functions for the FMS project. + +=head1 METHODS + +=head2 test_mode + + FixMyStreet->test_mode( $bool ); + my $in_test_mode_bool = FixMyStreet->test_mode; + +Put the FixMyStreet into test mode - inteded for the unit tests: + + BEGIN { + use FixMyStreet; + FixMyStreet->test_mode(1); + } + +=cut + +my $TEST_MODE = undef; + +sub test_mode { + my $class = shift; + $TEST_MODE = shift if scalar @_; + return $TEST_MODE; +} + +=head2 path_to + + $path = FixMyStreet->path_to( 'conf/general' ); + +Returns an absolute Path::Class object representing the path to the arguments in +the FixMyStreet directory. + +=cut + +sub path_to { + my $class = shift; + return $ROOT_DIR->file(@_); +} + +=head2 config + + my $config_hash_ref = FixMyStreet->config(); + my $config_value = FixMyStreet->config($key); + +Returns a hashref to the config values. This is readonly so any attempt to +change it will fail. + +Or you can pass it a key and it will return the value for that key, or undef if +it can't find it. + +=cut + +sub config { + my $class = shift; + return \%CONFIG unless scalar @_; + + my $key = shift; + return exists $CONFIG{$key} ? $CONFIG{$key} : undef; +} + +=head2 dbic_connect_info + + $connect_info = FixMyStreet->dbic_connect_info(); + +Returns the array that DBIx::Class::Schema needs to connect to the database. +Most of the values are read from the config file and others are hordcoded here. + +=cut + +# for exact details on what this could return refer to: +# +# http://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class/Storage/DBI.pm#connect_info +# +# we use the one that is most similar to DBI's connect. + +# FIXME - should we just use mySociety::DBHandle? will that lead to AutoCommit +# woes (we want it on, it sets it to off)? + +sub dbic_connect_info { + my $class = shift; + my $config = $class->config; + + my $dsn = "dbi:Pg:dbname=" . $config->{BCI_DB_NAME}; + $dsn .= ";host=$config->{BCI_DB_HOST}" + if $config->{BCI_DB_HOST}; + $dsn .= ";port=$config->{BCI_DB_PORT}" + if $config->{BCI_DB_PORT}; + $dsn .= ";sslmode=allow"; + + my $user = $config->{BCI_DB_USER} || undef; + my $password = $config->{BCI_DB_PASS} || undef; + + my $dbi_args = { + AutoCommit => 1, + pg_enable_utf8 => 1, + }; + my $dbic_args = {}; + + return [ $dsn, $user, $password, $dbi_args, $dbic_args ]; +} + +=head2 configure_mysociety_dbhandle + + FixMyStreet->configure_mysociety_dbhandle(); + +Calls configure in mySociety::DBHandle with args from the config. We need to do +this so that old code that uses mySociety::DBHandle finds it properly set up. We +can't (might not) be able to share the handle as DBIx::Class wants it with +AutoCommit on (so that its transaction code can be used in preference to calling +begin and commit manually) and mySociety::* code does not. + +This should be fixed/standardized to avoid having two database handles floating +around. + +=cut + +sub configure_mysociety_dbhandle { + my $class = shift; + my $config = $class->config; + + mySociety::DBHandle::configure( + Name => $config->{BCI_DB_NAME}, + User => $config->{BCI_DB_USER}, + Password => $config->{BCI_DB_PASS}, + Host => $config->{BCI_DB_HOST} || undef, + Port => $config->{BCI_DB_PORT} || undef, + ); + +} + +1; diff --git a/perllib/FixMyStreet/App.pm b/perllib/FixMyStreet/App.pm new file mode 100644 index 000000000..a35ba6c01 --- /dev/null +++ b/perllib/FixMyStreet/App.pm @@ -0,0 +1,223 @@ +package FixMyStreet::App; +use Moose; +use namespace::autoclean; + +use Catalyst::Runtime 5.80; +use FixMyStreet; +use FixMyStreet::Cobrand; +use Memcached; +use Problems; +use mySociety::Email; + +use Catalyst ( + 'Static::Simple', # + 'Unicode', + 'Session', + 'Session::Store::DBIC', + 'Session::State::Cookie', + 'Authentication', +); + +extends 'Catalyst'; + +our $VERSION = '0.01'; + +__PACKAGE__->config( + + # get the config from the core object + %{ FixMyStreet->config() }, + + name => 'FixMyStreet::App', + + # Disable deprecated behavior needed by old applications + disable_component_resolution_regex_fallback => 1, + + # Some generic stuff + default_view => 'Web', + + # Serve anything in web dir that is not a .cgi script + static => { # + include_path => [ FixMyStreet->path_to("web") . "" ], + ignore_extensions => ['cgi'], + }, + + 'Plugin::Session' => { # Catalyst::Plugin::Session::Store::DBIC + dbic_class => 'DB::Session', + expires => 3600 * 24 * 7 * 6, # 6 months + }, + + 'Plugin::Authentication' => { + default_realm => 'default', + default => { + credential => { # Catalyst::Authentication::Credential::Password + class => 'Password', + password_field => 'password', + password_type => 'hashed', + password_hash_type => 'SHA-1', + }, + store => { # Catalyst::Authentication::Store::DBIx::Class + class => 'DBIx::Class', + user_model => 'DB::User', + }, + }, + no_password => { # use post confirm etc + credential => { # Catalyst::Authentication::Credential::Password + class => 'Password', + password_type => 'none', + }, + store => { # Catalyst::Authentication::Store::DBIx::Class + class => 'DBIx::Class', + user_model => 'DB::User', + }, + }, + }, +); + +# Start the application +__PACKAGE__->setup(); + +# set up DB handle for old code +FixMyStreet->configure_mysociety_dbhandle; + +# disable debug logging unless in debaug mode +__PACKAGE__->log->disable('debug') # + unless __PACKAGE__->debug; + +=head1 NAME + +FixMyStreet::App - Catalyst based application + +=head1 SYNOPSIS + + script/fixmystreet_app_server.pl + +=head1 DESCRIPTION + +FixMyStreet.com codebase + +=head1 METHODS + +=head2 cobrand + + $cobrand = $c->cobrand(); + +Returns the cobrand object. If not already determined this request finds it and +caches it to the stash. + +=cut + +sub cobrand { + my $c = shift; + return $c->stash->{cobrand} ||= $c->_get_cobrand(); +} + +sub _get_cobrand { + my $c = shift; + my $host = $c->req->uri->host; + my $cobrand_class = FixMyStreet::Cobrand->get_class_for_host($host); + return $cobrand_class->new( { request => $c->req } ); +} + +=head2 setup_cobrand + + $cobrand = $c->setup_cobrand(); + +Work out which cobrand we should be using. Set the environment correctly - eg +template paths + +=cut + +sub setup_cobrand { + my $c = shift; + my $cobrand = $c->cobrand; + + # append the cobrand templates to the include path + $c->stash->{additional_template_paths} = + [ $cobrand->path_to_web_templates->stringify ] + unless $cobrand->is_default; + + my $host = $c->req->uri->host; + my $lang = + $host =~ /^en\./ ? 'en-gb' + : $host =~ /cy/ ? 'cy' + : undef; + + # set the language and the translation file to use - store it on stash + my $set_lang = $cobrand->set_lang_and_domain( + $lang, # language + 1, # return unicode + FixMyStreet->path_to('locale')->stringify # use locale directory + ); + $c->stash->{lang_code} = $set_lang; + + # debug + $c->log->debug( sprintf "Set lang to '%s' and cobrand to '%s'", + $set_lang, $cobrand->moniker ); + + Problems::set_site_restriction_with_cobrand_object($cobrand); + + Memcached::set_namespace( FixMyStreet->config('BCI_DB_NAME') . ":" ); + + return $cobrand; +} + +=head2 send_email + + $email_sent = $c->send_email( 'email_template.txt', $extra_stash_values ); + +Send an email by filling in the given template with values in the stash. + +You can specify extra values to those already in the stash by passing a hashref +as the second argument. + +The stash (or extra_stash_values) keys 'to', 'from' and 'subject' are used to +set those fields in the email if they are present. + +If a 'from' is not specified then the default from the config is used. + +=cut + +sub send_email { + my $c = shift; + my $template = shift; + my $extra_stash_values = shift || {}; + + # create the vars to pass to the email template + my $vars = { + from => FixMyStreet->config('CONTACT_EMAIL'), + %{ $c->stash }, + %$extra_stash_values, + additional_template_paths => + [ $c->cobrand->path_to_email_templates->stringify ] + }; + + # render the template + my $content = $c->view('Email')->render( $c, $template, $vars ); + + # create an email - will parse headers out of content + my $email = Email::Simple->new($content); + $email->header_set( ucfirst($_), $vars->{$_} ) + for grep { $vars->{$_} } qw( to from subject); + + # pass the email into mySociety::Email to construct the on the wire 7bit + # format - this should probably happen in the transport instead but hohum. + my $email_text = mySociety::Email::construct_email( + { + _unwrapped_body_ => $email->body, # will get line wrapped + $email->header_pairs + } + ); + + # send the email + $c->model('EmailSend')->send($email_text); + + return $email; +} + +=head1 SEE ALSO + +L<FixMyStreet::App::Controller::Root>, L<Catalyst> + +=cut + +1; diff --git a/perllib/FixMyStreet/App/Controller/About.pm b/perllib/FixMyStreet/App/Controller/About.pm new file mode 100644 index 000000000..b444e02bb --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/About.pm @@ -0,0 +1,33 @@ +package FixMyStreet::App::Controller::About; +use Moose; +use namespace::autoclean; + +BEGIN { extends 'Catalyst::Controller'; } + +=head1 NAME + +FixMyStreet::App::Controller::About - Catalyst Controller + +=head1 DESCRIPTION + +Catalyst Controller. + +=head1 METHODS + +=cut + +=head2 about + +Show the 'about us' page. + +=cut + +sub about : Path : Args(0) { + my ( $self, $c ) = @_; + + # don't need to do anything here - should just pass through. +} + +__PACKAGE__->meta->make_immutable; + +1; diff --git a/perllib/FixMyStreet/App/Controller/Auth.pm b/perllib/FixMyStreet/App/Controller/Auth.pm new file mode 100644 index 000000000..16f0b994c --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Auth.pm @@ -0,0 +1,234 @@ +package FixMyStreet::App::Controller::Auth; +use Moose; +use namespace::autoclean; + +BEGIN { extends 'Catalyst::Controller'; } + +use Email::Valid; +use Net::Domain::TLD; +use mySociety::AuthToken; +use Digest::SHA1 qw(sha1_hex); + +=head1 NAME + +FixMyStreet::App::Controller::Auth - Catalyst Controller + +=head1 DESCRIPTION + +Controller for all the authentication related pages - create account, login, +logout. + +=head1 METHODS + +=head2 index + +Present the user with a login / create account page. + +=cut + +sub general : Path : Args(0) { + my ( $self, $c ) = @_; + my $req = $c->req; + + # all done unless we have a form posted to us + return unless $req->method eq 'POST'; + + # decide which action to take + $c->detach('email_login') if $req->param('email_login'); + $c->detach('login'); # default + +} + +=head2 login + +Allow the user to legin with a username and a password. + +=cut + +sub login : Private { + my ( $self, $c ) = @_; + + my $email = $c->req->param('email') || ''; + my $password = $c->req->param('password') || ''; + + # logout just in case + $c->logout(); + + if ( $email + && $password + && $c->authenticate( { email => $email, password => $password } ) ) + { + $c->res->redirect( $c->uri_for('/my') ); + return; + } + + # could not authenticate - show an error + $c->stash->{login_error} = 1; +} + +=head2 email_login + +Email the user the details they need to log in. Don't check for an account - if +there isn't one we can create it when they come back with a token (which +contains the email addresss). + +=cut + +sub email_login : Private { + my ( $self, $c ) = @_; + + # check that the email is valid - otherwise flag an error + my $raw_email = lc( $c->req->param('email') || '' ); + + my $email_checker = Email::Valid->new( + -mxcheck => 1, + -tldcheck => 1, + -fqdn => 1, + ); + + my $good_email = $email_checker->address($raw_email); + if ( !$good_email ) { + $c->stash->{email} = $raw_email; + $c->stash->{email_error} = + $raw_email ? $email_checker->details : 'missing'; + return; + } + + my $token_obj = $c->model('DB::Token') # + ->create( + { + scope => 'email_login', + data => { email => $good_email } + } + ); + + # log the user in, send them an email and redirect to the welcome page + $c->stash->{token} = $token_obj->token; + $c->send_email( 'login.txt', { to => $good_email } ); + $c->res->redirect( $c->uri_for('token') ); +} + +=head2 token + +Handle the 'email_login' tokens. Find the account for the email address +(creating if needed), authenticate the user and delete the token. + +=cut + +sub token : Local { + my ( $self, $c, $url_token ) = @_; + + # check for a token - if none found then return + return unless $url_token; + + # retrieve the token or return + my $token_obj = + $c->model('DB::Token') + ->find( { scope => 'email_login', token => $url_token, } ); + + if ( !$token_obj ) { + $c->stash->{token_not_found} = 1; + return; + } + + # logout in case we are another user + $c->logout(); + + # get the email and scrap the token + my $email = $token_obj->data->{email}; + $token_obj->delete; + + # find or create the user related to the token and delete the token + my $user = $c->model('DB::User')->find_or_create( { email => $email } ); + $c->authenticate( { email => $user->email }, 'no_password' ); + + # send the user to their page + $c->res->redirect( $c->uri_for('/my') ); +} + +=head2 change_password + +Let the user change their password. + +=cut + +sub change_password : Local { + my ( $self, $c ) = @_; + + # FIXME - handle not being logged in more elegantly + unless ( $c->user ) { + $c->res->redirect( $c->uri_for('/auth') ); + $c->detach; + } + + # FIXME - CSRF check here + # FIXME - minimum criteria for passwords (length, contain number, etc) + + # If not a post then no submission + return unless $c->req->method eq 'POST'; + + # get the passwords + my $new = $c->req->param('new_password') // ''; + my $confirm = $c->req->param('confirm') // ''; + + # check for errors + my $password_error = + !$new && !$confirm ? 'missing' + : $new ne $confirm ? 'mismatch' + : ''; + + if ($password_error) { + $c->stash->{password_error} = $password_error; + $c->stash->{new_password} = $new; + $c->stash->{confirm} = $confirm; + return; + } + + # we should have a usable password - save it to the user + $c->user->obj->update( { password => sha1_hex($new) } ); + $c->stash->{password_changed} = 1; + +} + +=head2 logout + +Log the user out. Tell them we've done so. + +=cut + +sub logout : Local { + my ( $self, $c ) = @_; + $c->logout(); +} + +=head2 check_auth + +Utility page - returns a simple message 'OK' and a 200 response if the user is +authenticated and a 'Unauthorized' / 401 reponse if they are not. + +Mainly intended for testing but might also be useful for ajax calls. + +=cut + +sub check_auth : Local { + my ( $self, $c ) = @_; + + # choose the response + my ( $body, $code ) # + = $c->user + ? ( 'OK', 200 ) + : ( 'Unauthorized', 401 ); + + # set the response + $c->res->body($body); + $c->res->code($code); + + # NOTE - really a 401 response should also contain a 'WWW-Authenticate' + # header but we ignore that here. The spec is not keeping up with usage. + + return; +} + +__PACKAGE__->meta->make_immutable; + +1; diff --git a/perllib/FixMyStreet/App/Controller/FAQ.pm b/perllib/FixMyStreet/App/Controller/FAQ.pm new file mode 100644 index 000000000..6b8fb1191 --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/FAQ.pm @@ -0,0 +1,35 @@ +package FixMyStreet::App::Controller::FAQ; +use Moose; +use namespace::autoclean; + +BEGIN { extends 'Catalyst::Controller'; } + +=head1 NAME + +FixMyStreet::App::Controller::FAQ - Catalyst Controller + +=head1 DESCRIPTION + +Show the FAQ page - does some smarts to choose the correct template depending on +language. + +=cut + +sub faq : Path : Args(0) { + my ( $self, $c ) = @_; + + # There should be a faq template for each language in a cobrand or default. + # This is because putting the FAQ translations into the PO files is + # overkill. + + # We rely on the list of languages for the site being restricted so that there + # will be a faq template for that language/cobrand combo. + + my $lang_code = $c->stash->{lang_code}; + my $template = "faq/faq-$lang_code.html"; + $c->stash->{template} = $template; +} + +__PACKAGE__->meta->make_immutable; + +1; diff --git a/perllib/FixMyStreet/App/Controller/My.pm b/perllib/FixMyStreet/App/Controller/My.pm new file mode 100644 index 000000000..1189fe901 --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/My.pm @@ -0,0 +1,36 @@ +package FixMyStreet::App::Controller::My; +use Moose; +use namespace::autoclean; + +BEGIN { extends 'Catalyst::Controller'; } + +=head1 NAME + +FixMyStreet::App::Controller::My - Catalyst Controller + +=head1 DESCRIPTION + +Catalyst Controller. + +=head1 METHODS + +=cut + +=head2 index + +=cut + +sub my : Path : Args(0) { + my ( $self, $c ) = @_; + + # FIXME - handle not being logged in more elegantly + unless ( $c->user ) { + $c->res->redirect( $c->uri_for('/auth') ); + $c->detach; + } + +} + +__PACKAGE__->meta->make_immutable; + +1; diff --git a/perllib/FixMyStreet/App/Controller/Report/New.pm b/perllib/FixMyStreet/App/Controller/Report/New.pm new file mode 100644 index 000000000..c2488424d --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Report/New.pm @@ -0,0 +1,1172 @@ +package FixMyStreet::App::Controller::Report::New; + +use Moose; +use namespace::autoclean; +BEGIN { extends 'Catalyst::Controller'; } + +use FixMyStreet::Geocode; +use Encode; +use Sort::Key qw(keysort); +use List::MoreUtils qw(uniq); +use HTML::Entities; +use mySociety::MaPit; +use Path::Class; +use Utils; +use mySociety::EmailUtil; + +=head1 NAME + +FixMyStreet::App::Controller::Report::New + +=head1 DESCRIPTION + +Create a new report, or complete a partial one . + +=head1 PARAMETERS + +=head2 flow control + +submit_map: true if we reached this page by clicking on the map + +submit_problem: true if a problem has been submitted + +=head2 location (required) + +We require a location - either lat/lng or a tile click. + +longitude, latitude: location of the report - either determined from the +address/postcode or from a map click. + +x, y, tile_xxx.yyy.x, tile_xxx.yyy.y: x and y are the tile locations. The +'tile_xxx.yyy' pair are the click locations on the tile. These can be converted +back into lat/lng by the map code. + +=head2 image related + +Parameters are 'photo' or 'upload_fileid'. The 'photo' is used when a user has selected a file. Once it has been uploaded it is cached on disk so that if there are errors on the form it need not be uploaded again. The cache location is stored in 'upload_fileid'. + +=head2 optional + +pc: location user searched for + +skipped: true if the map was skipped - may mean that the location is not as +accurate as we'd like. Default is false. + +upload_fileid: set if there is an uploaded file (might not be needed if we use the Catalyst upload handlers) + +may_show_name: bool - false if the user wants this report to be anonymous. + +title + +detail + +name + +email + +phone + +partial + +=head2 can be ignored + +all_pins: related to map display - not relevant to creation of a new report + +=cut + +sub report_new : Path : Args(0) { + my ( $self, $c ) = @_; + + # set up the page + $c->forward('setup_page'); + + # create the report - loading a partial if available + $c->forward('initialize_report'); + + # work out the location for this report and do some checks + return + unless $c->forward('determine_location') + && $c->forward('load_councils'); + + # create a problem from the submitted details + $c->stash->{template} = "report/new/fill_in_details.html"; + $c->forward('setup_categories_and_councils'); + $c->forward('generate_map'); + + # deal with the user and report and check both are happy + return + unless $c->forward('process_user') + && $c->forward('process_report') + && $c->forward('process_photo') + && $c->forward('check_form_submitted') + && $c->forward('check_for_errors') + && $c->forward('save_user_and_report') + && $c->forward('redirect_or_confirm_creation'); +} + +=head2 report_import + +Action to accept report creations from iPhones and other mobile apps. URL is +'/import' to be compatible with existing apps. + +=cut + +sub report_import : Path('/import') { + my ( $self, $c ) = @_; + + # If this is not a POST then just print out instructions for using page + return unless $c->req->method eq 'POST'; + + # anything else we return is plain text + $c->res->content_type('text/plain; charset=utf-8'); + + # use strict; + # use Standard; + # use mySociety::AuthToken; + # use mySociety::Config; + # use mySociety::EvEl; + # use mySociety::Locale; + + my %input = + map { $_ => $c->req->param($_) || '' } ( + 'service', 'subject', 'detail', 'name', 'email', 'phone', + 'easting', 'northing', 'lat', 'lon', 'id', 'phone_id', + ); + + my @errors; + + # Get our location + my $latitude = $input{lat} ||= 0; + my $longitude = $input{lon} ||= 0; + if ( + !( $latitude || $longitude ) # have not been given lat or lon + && ( $input{easting} && $input{northing} ) # but do have e and n + ) + { + ( $latitude, $longitude ) = + Utils::convert_en_to_latlon( $input{easting}, $input{northing} ); + } + + # handle the photo upload + $c->forward( 'process_photo_upload', [ { rotate_photo => 1 } ] ); + my $photo = $c->stash->{upload_fileid}; + if ( my $error = $c->stash->{photo_error} ) { + push @errors, $error; + } + + push @errors, 'You must supply a service' unless $input{service}; + push @errors, 'Please enter a subject' unless $input{subject} =~ /\S/; + push @errors, 'Please enter your name' unless $input{name} =~ /\S/; + + if ( $input{email} !~ /\S/ ) { + push @errors, 'Please enter your email'; + } + elsif ( !mySociety::EmailUtil::is_valid_email( $input{email} ) ) { + push @errors, 'Please enter a valid email'; + } + + if ( $latitude && $c->config->{COUNTRY} eq 'GB' ) { + eval { Utils::convert_latlon_to_en( $latitude, $longitude ); }; + push @errors, + "We had a problem with the supplied co-ordinates - outside the UK?" + if $@; + } + + unless ( $photo || ( $latitude || $longitude ) ) { + push @errors, 'Either a location or a photo must be provided.'; + } + + # if we have errors then we should bail out + if (@errors) { + my $body = join '', map { "ERROR:$_\n" } @errors; + $c->res->body($body); + return; + } + +### leaving commented out for now as the values stored here never appear to +### get used and the new user accounts might make them redundant anyway. + # + # # Store for possible future use + # if ( $input{id} || $input{phone_id} ) { + # my $id = $input{id} || $input{phone_id}; + # my $already = + # dbh() + # ->selectrow_array( + # 'select id from partial_user where service=? and nsid=?', + # {}, $input{service}, $id ); + # unless ($already) { + # dbh()->do( + # 'insert into partial_user (service, nsid, name, email, phone)' + # . ' values (?, ?, ?, ?, ?)', + # {}, + # $input{service}, + # $id, + # $input{name}, + # $input{email}, + # $input{phone} + # ); + # } + # } + + # find or create the user + my $report_user = $c->model('DB::User')->find_or_create( + { + email => $input{email}, + name => $input{name}, + phone => $input{phone} + } + ); + + # create a new report (don't save it yet) + my $report = $c->model('DB::Problem')->new( + { + user => $report_user, + postcode => '', + latitude => $latitude, + longitude => $longitude, + title => $input{subject}, + detail => $input{detail}, + name => $input{name}, + service => $input{service}, + state => 'partial', + used_map => 1, + anonymous => 0, + category => '', + areas => '', + + } + ); + + # If there was a photo add that too + if ( my $fileid = $c->stash->{upload_fileid} ) { + my $file = file( $c->config->{UPLOAD_CACHE}, "$fileid.jpg" ); + my $blob = $file->slurp; + $file->remove; + $report->photo($blob); + } + + # save the report; + $report->insert(); + + my $token = + $c->model("DB::Token") + ->create( { scope => 'partial', data => $report->id } ); + + $c->stash->{report} = $report; + $c->stash->{token_url} = $c->uri_for( '/L', $token->token ); + + my $sender = mySociety::Config::get('CONTACT_EMAIL'); + $sender =~ s/team/fms-DO-NOT-REPLY/; + + # TODO - used to be sent using EvEl + $c->send_email( + 'partial.txt', + { + to => $report->user->email, + from => $sender + } + ); + + $c->res->body('SUCCESS'); + return 1; +} + +=head2 setup_page + +Setup the page - notably add the map js to the stash + +=cut + +sub setup_page : Private { + my ( $self, $c ) = @_; + + $c->stash->{extra_js_verbatim} = FixMyStreet::Map::header_js(); + + return 1; +} + +=head2 initialize_report + +Create the report and set up some basics in it. If there is a partial report +requested then use that . + +Partial reports are created when people submit to us via mobile apps or by +specially tagging photos on Flickr. They are in the database but are not +completed yet. Users reach us by following a link we email them that contains a +token link. This action looks for the token and if found retrieves the report in it. + +=cut + +sub initialize_report : Private { + my ( $self, $c ) = @_; + + # check to see if there is a partial report that we should use, otherwise + # create a new one. Stick it on the stash. + my $report = undef; + + if ( my $partial = scalar $c->req->param('partial') ) { + + for (1) { # use as pseudo flow control + + # did we find a token + last unless $partial; + + # is it in the database + my $token = + $c->model("DB::Token") + ->find( { scope => 'partial', token => $partial } ) # + || last; + + # can we get an id from it? + my $id = $token->data # + || last; + + # load the related problem + $report = $c->model("DB::Problem") # + ->search( { id => $id, state => 'partial' } ) # + ->first; + + if ($report) { + + # log the problem creation user in to the site + $c->authenticate( { email => $report->user->email }, + 'no_password' ); + + # save the token to delete at the end + $c->stash->{partial_token} = $token if $report; + + } + else { + + # no point keeping it if it is done. + $token->delete; + } + } + } + else { + + # If we didn't find a partial then create a new one + $report = $c->model('DB::Problem')->new( {} ); + + # If we have a user logged in let's prefill some values for them. + if ( $c->user ) { + my $user = $c->user->obj; + $report->user($user); + $report->name( $user->name ); + } + + } + + $c->stash->{report} = $report; + + return 1; +} + +=head2 determine_location + +Work out what the location of the report should be - either by using lat,lng or +a tile click or a user search query C<pc>. Returns false if no location could be +found. + +=cut + +sub determine_location : Private { + my ( $self, $c ) = @_; + + return + unless $c->forward('determine_location_from_tile_click') + || $c->forward('determine_location_from_coords') + || $c->forward('determine_location_from_pc') + || $c->forward('determine_location_from_report'); + + # These should be set now + my $lat = $c->stash->{latitude}; + my $lon = $c->stash->{longitude}; + + # Check this location is okay to be displayed for the cobrand + my ( $success, $error_msg ) = $c->cobrand->council_check( # + { lat => $lat, lon => $lon }, + 'submit_problem' + ); + + # If in UK and we have a lat,lon coocdinate check it is in UK + if ( !$error_msg && $lat && $c->config->{COUNTRY} eq 'GB' ) { + eval { Utils::convert_latlon_to_en( $lat, $lon ); }; + $error_msg = + _( "We had a problem with the supplied co-ordinates - outside the UK?" + ) if $@; + } + + # all good + return 1 if !$error_msg; + + # show error + $c->stash->{pc_error} = $error_msg; + return; +} + +=head2 determine_location_from_tile_click + +Detect that the map tiles have been clicked on by looking for the tile +parameters. + +=cut + +sub determine_location_from_tile_click : Private { + my ( $self, $c ) = @_; + + # example: 'tile_1673.1451.x' + my $param_key_regex = '^tile_(\d+)\.(\d+)\.[xy]$'; + + my @matching_param_keys = + grep { m/$param_key_regex/ } keys %{ $c->req->params }; + + # did we find any matches + return unless scalar(@matching_param_keys) == 2; + + # get the x and y keys + my ( $x_key, $y_key ) = sort @matching_param_keys; + + # Extract the data needed + my ( $pin_tile_x, $pin_tile_y ) = $x_key =~ m{$param_key_regex}; + my $pin_x = $c->req->param($x_key); + my $pin_y = $c->req->param($y_key); + + # return if they are both 0 - this happens when you submit the form by + # hitting enter and not using the button. It also happens if you click + # exactly there on the map but that is less likely than hitting return to + # submit. Lesser of two evils... + return unless $pin_x && $pin_y; + + # convert the click to lat and lng + my ( $latitude, $longitude ) = + FixMyStreet::Map::click_to_wgs84( $pin_tile_x, $pin_x, $pin_tile_y, + $pin_y ); + + # store it on the stash + $c->stash->{latitude} = $latitude; + $c->stash->{longitude} = $longitude; + + # set a flag so that the form is not considered submitted. This will prevent + # errors showing on the fields. + $c->stash->{force_form_not_submitted} = 1; + + # return true as we found a location + return 1; +} + +=head2 determine_location_from_coords + +Use latitude and longitude if provided in parameters. + +=cut + +sub determine_location_from_coords : Private { + my ( $self, $c ) = @_; + + my $latitude = $c->req->param('latitude'); + my $longitude = $c->req->param('longitude'); + + if ( defined $latitude && defined $longitude ) { + $c->stash->{latitude} = $latitude; + $c->stash->{longitude} = $longitude; + return 1; + } + + return; +} + +=head2 determine_location_from_pc + +User has searched for a location - try to find it for them. + +If one match is found returns true and lat/lng is set. + +If several possible matches are found puts an array onto stash so that user can be prompted to pick one and returns false. + +If no matches are found returns false. + +=cut + +sub determine_location_from_pc : Private { + my ( $self, $c ) = @_; + + # check for something to search + my $pc = $c->req->param('pc') || return; + $c->stash->{pc} = $pc; # for template + + my ( $latitude, $longitude, $error ) = + eval { FixMyStreet::Geocode::lookup( $pc, $c->req ) }; + + # Check that nothing blew up + if ($@) { + warn "Error: $@"; + return; + } + + # If we got a lat/lng set to stash and return true + if ( defined $latitude && defined $longitude ) { + $c->stash->{latitude} = $latitude; + $c->stash->{longitude} = $longitude; + return 1; + } + + # $error doubles up to return multiple choices by being an array + if ( ref($error) eq 'ARRAY' ) { + @$error = map { decode_utf8($_) } @$error; + $c->stash->{possible_location_matches} = $error; + return; + } + + # pass errors back to the template + $c->stash->{pc_error} = $error; + return; +} + +=head2 determine_location_from_report + +Use latitude and longitude stored in the report - this is probably result of a +partial report being loaded. + +=cut + +sub determine_location_from_report : Private { + my ( $self, $c ) = @_; + + my $report = $c->stash->{report}; + + if ( defined $report->latitude && defined $report->longitude ) { + $c->stash->{latitude} = $report->latitude; + $c->stash->{longitude} = $report->longitude; + return 1; + } + + return; +} + +=head2 load_councils + +Try to load councils for this location and check that we have at least one. If +there are no councils then return false. + +=cut + +sub load_councils : Private { + my ( $self, $c ) = @_; + my $latitude = $c->stash->{latitude}; + my $longitude = $c->stash->{longitude}; + + # Look up councils and do checks for the point we've got + my @area_types = $c->cobrand->area_types(); + + # TODO: I think we want in_gb_locale around the next line, needs testing + my $all_councils = + mySociety::MaPit::call( 'point', "4326/$longitude,$latitude", + type => \@area_types ); + + # Let cobrand do a check + my ( $success, $error_msg ) = + $c->cobrand->council_check( { all_councils => $all_councils }, + 'submit_problem' ); + if ( !$success ) { + $c->stash->{location_error} = $error_msg; + return; + } + + # If we don't have any councils we can't accept the report + if ( !scalar keys %$all_councils ) { + $c->stash->{location_error} = + _( 'That spot does not appear to be covered by a council. If you' + . ' have tried to report an issue past the shoreline, for' + . ' example, please specify the closest point on land.' ); + return; + } + + # edit hash in-place + _remove_redundant_councils($all_councils); + + # all good if we have some councils left + $c->stash->{all_councils} = $all_councils; + $c->stash->{all_council_names} = + [ map { $_->{name} } values %$all_councils ]; + return 1; +} + +# TODO - should not be here. +# These are country specific tweaks that should be in the cobrands +sub _remove_redundant_councils { + my $all_councils = shift; + + # UK specific tweaks + if ( FixMyStreet->config('COUNTRY') eq 'GB' ) { + + # Ipswich & St Edmundsbury are responsible for everything in their + # areas, not Suffolk + delete $all_councils->{2241} + if $all_councils->{2446} # + || $all_councils->{2443}; + + # Norwich is responsible for everything in its areas, not Norfolk + delete $all_councils->{2233} # + if $all_councils->{2391}; + } + + # Norway specific tweaks + if ( FixMyStreet->config('COUNTRY') eq 'NO' ) { + + # Oslo is both a kommune and a fylke, we only want to show it once + delete $all_councils->{301} # + if $all_councils->{3}; + } + +} + +=head2 setup_categories_and_councils + +Look up categories for this council or councils + +=cut + +sub setup_categories_and_councils : Private { + my ( $self, $c ) = @_; + + my @all_council_ids = keys %{ $c->stash->{all_councils} }; + + my @contacts # + = $c # + ->model('DB::Contact') # + ->not_deleted # + ->search( { area_id => \@all_council_ids } ) # + ->all; + + # variables to populate + my @area_ids_to_list = (); # Areas with categories assigned + my @category_options = (); # categories to show + my $category_label = undef; # what to call them + + # FIXME - implement in cobrand + if ( $c->cobrand->moniker eq 'emptyhomes' ) { + + # add all areas found to the list + foreach (@contacts) { + push @area_ids_to_list, $_->area_id; + } + + # set our own categories + @category_options = ( + _('-- Pick a property type --'), + _('Empty house or bungalow'), + _('Empty flat or maisonette'), + _('Whole block of empty flats'), + _('Empty office or other commercial'), + _('Empty pub or bar'), + _('Empty public building - school, hospital, etc.') + ); + $category_label = _('Property type:'); + } + else { + + @contacts = keysort { $_->category } @contacts; + foreach my $contact (@contacts) { + push @area_ids_to_list, $contact->area_id; + push @category_options, $contact->category + unless $contact->category eq _('Other'); + } + + if (@category_options) { + @category_options = + ( _('-- Pick a category --'), @category_options, _('Other') ); + $category_label = _('Category:'); + } + } + + # put results onto stash for display + $c->stash->{area_ids_to_list} = \@area_ids_to_list; + $c->stash->{category_label} = $category_label; + $c->stash->{category_options} = \@category_options; + + # add some conveniant things to the stash + my $all_councils = $c->stash->{all_councils}; + my %area_ids_to_list_hash = map { $_ => 1 } @area_ids_to_list; + + my @missing_details_councils = + grep { !$area_ids_to_list_hash{$_} } # + keys %$all_councils; + + my @missing_details_council_names = + map { $all_councils->{$_}->{name} } # + @missing_details_councils; + + $c->stash->{missing_details_councils} = @missing_details_councils; + $c->stash->{missing_details_council_names} = @missing_details_council_names; +} + +=head2 check_form_submitted + + $bool = $c->forward('check_form_submitted'); + +Returns true if the form has been submitted, false if not. Determines this based +on the presence of the C<submit_problem> parameter. + +=cut + +sub check_form_submitted : Private { + my ( $self, $c ) = @_; + return if $c->stash->{force_form_not_submitted}; + return $c->req->param('submit_problem') || ''; +} + +=head2 process_user + +Load user from the database or prepare a new one. + +=cut + +sub process_user : Private { + my ( $self, $c ) = @_; + + # FIXME - If user already logged in use them regardless + + # Extract all the params to a hash to make them easier to work with + my %params = # + map { $_ => scalar $c->req->param($_) } # + ( 'email', 'name', 'phone', ); + + # cleanup the email address + my $email = lc $params{email}; + $email =~ s{\s+}{}g; + + my $report = $c->stash->{report}; + my $report_user # + = ( $report ? $report->user : undef ) + || $c->model('DB::User')->find_or_new( { email => $email } ); + + # set the user's name and phone (if given) + $report_user->name( _trim_text( $params{name} ) ); + $report_user->phone( _trim_text( $params{phone} ) ) if $params{phone}; + + $c->stash->{report_user} = $report_user; + + return 1; +} + +=head2 process_report + +Looking at the parameters passed in create a new item and return it. Does not +save anything to the database. If no item can be created (ie no information +provided) returns undef. + +=cut + +# args: allow_multiline => bool - strips out "\n\n" linebreaks +sub _cleanup_text { + my $input = shift || ''; + my $args = shift || {}; + + # lowercase everything if looks like it might be SHOUTING + $input = lc $input if $input !~ /[a-z]/; + + # clean up language and tradmarks + for ($input) { + + # shit -> poo + s{\bdog\s*shit\b}{dog poo}ig; + + # 'portakabin' to '[portable cabin]' (and variations) + s{\b(porta)\s*([ck]abin|loo)\b}{[$1ble $2]}ig; + s{kabin\]}{cabin\]}ig; + } + + # Remove unneeded whitespace + my @lines = grep { m/\S/ } split m/\n\n/, $input; + for (@lines) { + $_ = _trim_text($_); + $_ = ucfirst $_; # start with capital + } + + my $join_char = $args->{allow_multiline} ? "\n\n" : " "; + $input = join $join_char, @lines; + + return $input; +} + +sub _trim_text { + my $input = shift; + for ($input) { + last unless $_; + s{\s+}{ }g; # all whitespace to single space + s{^ }{}; # trim leading + s{ $}{}; # trim trailing + } + return $input; +} + +sub process_report : Private { + my ( $self, $c ) = @_; + + # Extract all the params to a hash to make them easier to work with + my %params = # + map { $_ => scalar $c->req->param($_) } # + ( + 'title', 'detail', 'pc', # + 'name', 'may_show_name', # + 'category', # + 'partial', 'skipped', 'submit_problem' # + ); + + # load the report + my $report = $c->stash->{report}; + + # Enter the location and other bits which are not from the form + $report->postcode( $params{pc} ); + $report->latitude( $c->stash->{latitude} ); + $report->longitude( $c->stash->{longitude} ); + + # Short circuit unless the form has been submitted + return 1 unless $params{submit_problem}; + + # set some simple bool values (note they get inverted) + $report->anonymous( $params{may_show_name} ? 0 : 1 ); + $report->used_map( $params{skipped} ? 0 : 1 ); + + # clean up text before setting + $report->title( _cleanup_text( $params{title} ) ); + $report->detail( + _cleanup_text( $params{detail}, { allow_multiline => 1 } ) ); + + # set these straight from the params + $report->name( _trim_text( $params{name} ) ); + $report->category( _ $params{category} ); + + my $mapit_query = + sprintf( "4326/%s,%s", $report->longitude, $report->latitude ); + my $areas = mySociety::MaPit::call( 'point', $mapit_query ); + $report->areas( ',' . join( ',', sort keys %$areas ) . ',' ); + + # determine the area_types that this cobrand is interested in + my @area_types = $c->cobrand->area_types(); + my %area_types_lookup = map { $_ => 1 } @area_types; + + # get all the councils that are of these types and cover this area + my %councils = + map { $_ => 1 } # + grep { $area_types_lookup{ $areas->{$_}->{type} } } # + keys %$areas; + + # partition the councils onto these two arrays + my @councils_with_category = (); + my @councils_without_category = (); + + # all councils have all categories for emptyhomes + if ( $c->cobrand->moniker eq 'emptyhomes' ) { + @councils_with_category = keys %councils; + } + else { + + my @contacts = $c-> # + model('DB::Contact') # + ->not_deleted # + ->search( + { + area_id => [ keys %councils ], # + category => $report->category + } + )->all; + + # clear category if it is not in db for possible councils + $report->category(undef) unless @contacts; + + my %councils_with_contact_for_category = + map { $_->area_id => 1 } @contacts; + + foreach my $council_key ( keys %councils ) { + $councils_with_contact_for_category{$council_key} + ? push( @councils_with_category, $council_key ) + : push( @councils_without_category, $council_key ); + } + + } + + # construct the council string: + # 'x,x' - x are councils_ids that have this category + # 'x,x|y,y' - x are councils_ids that have this category, y don't + my $council_string = join '|', grep { $_ } # + ( + join( ',', @councils_with_category ), + join( ',', @councils_without_category ) + ); + $report->council($council_string); + + # set defaults that make sense + $report->state('unconfirmed'); + + # save the cobrand and language related information + $report->cobrand( $c->cobrand->moniker ); + $report->cobrand_data( $c->cobrand->extra_problem_data ); + $report->lang( $c->stash->{lang_code} ); + + return 1; +} + +=head2 process_photo + +Handle the photo - either checking and storing it after an upload or retrieving +it from the cache. + +Store any error message onto 'photo_error' in stash. +=cut + +sub process_photo : Private { + my ( $self, $c ) = @_; + + return + $c->forward('process_photo_upload') + || $c->forward('process_photo_cache') + || 1; # always return true +} + +sub process_photo_upload : Private { + my ( $self, $c, $args ) = @_; + + # setup args and set defaults + $args ||= {}; + $args->{rotate_photo} ||= 0; + + # check for upload or return + my $upload = $c->req->upload('photo') + || return; + + # check that the photo is a jpeg + my $ct = $upload->type; + unless ( $ct eq 'image/jpeg' || $ct eq 'image/pjpeg' ) { + $c->stash->{photo_error} = _('Please upload a JPEG image only'); + return; + } + + # convert the photo into a blob (also resize etc) + my $photo_blob = + eval { Page::process_photo( $upload->fh, $args->{rotate_photo} ) }; + if ( my $error = $@ ) { + my $format = _( +"That image doesn't appear to have uploaded correctly (%s), please try again." + ); + $c->stash->{photo_error} = sprintf( $format, $error ); + return; + } + + # we have an image we can use - save it to the cache in case there is an + # error + my $cache_dir = dir( $c->config->{UPLOAD_CACHE} ); + $cache_dir->mkpath; + unless ( -d $cache_dir && -w $cache_dir ) { + warn "Can't find/write to photo cache directory '$cache_dir'"; + return; + } + + # create a random name and store the file there + my $fileid = int rand 1_000_000_000; + my $file = $cache_dir->file("$fileid.jpg"); + $file->openw->print($photo_blob); + + # stick the random number on the stash + $c->stash->{upload_fileid} = $fileid; + + return 1; +} + +=head2 process_photo_cache + +Look for the upload_fileid parameter and check it matches a file on disk. If it +does return true and put fileid on stash, otherwise false. + +=cut + +sub process_photo_cache : Private { + my ( $self, $c ) = @_; + + # get the fileid and make sure it is just a number + my $fileid = $c->req->param('upload_fileid') || ''; + $fileid =~ s{\D+}{}g; + return unless $fileid; + + my $file = file( $c->config->{UPLOAD_CACHE}, "$fileid.jpg" ); + return unless -e $file; + + $c->stash->{upload_fileid} = $fileid; + return 1; +} + +=head2 check_for_errors + +Examine the user and the report for errors. If found put them on stash and +return false. + +=cut + +sub check_for_errors : Private { + my ( $self, $c ) = @_; + + # let the model check for errors + my %field_errors = ( + %{ $c->stash->{report_user}->check_for_errors }, + %{ $c->stash->{report}->check_for_errors }, + ); + + # add the photo error if there is one. + if ( my $photo_error = delete $c->stash->{photo_error} ) { + $field_errors{photo} = $photo_error; + } + + # all good if no errors + return 1 unless scalar keys %field_errors; + + $c->stash->{field_errors} = \%field_errors; + + return; +} + +=head2 save_user_and_report + +Save the user and the report. + +Be smart about the user - only set the name and phone if user did not exist +before or they are currently logged in. Otherwise discard any changes. + +=cut + +sub save_user_and_report : Private { + my ( $self, $c ) = @_; + my $report_user = $c->stash->{report_user}; + my $report = $c->stash->{report}; + + # Save or update the user if appropriate + if ( !$report_user->in_storage ) { + $report_user->insert(); + } + elsif ( $c->user && $report_user->id == $c->user->id ) { + $report_user->update(); + $report->confirm; + } + else { + + # user exists and we are not logged in as them. Throw away changes to + # the name and phone. TODO - propagate changes using tokens. + $report_user->discard_changes(); + } + + # add the user to the report + $report->user($report_user); + + # If there was a photo add that too + if ( my $fileid = $c->stash->{upload_fileid} ) { + my $file = file( $c->config->{UPLOAD_CACHE}, "$fileid.jpg" ); + my $blob = $file->slurp; + $file->remove; + $report->photo($blob); + } + + # Set a default if possible + $report->category( _('Other') ) unless $report->category; + + # save the report; + $report->in_storage ? $report->update : $report->insert(); + + # tidy up + if ( my $token = $c->stash->{partial_token} ) { + $token->delete; + } + + return 1; +} + +=head2 generate_map + +Add the html needed to for the map to the stash. + +=cut + +# FIXME - much of this should not happen here or in maps code but in the +# templates. Perhaps also create a map 'None' to use when map is skipped. + +sub generate_map : Private { + my ( $self, $c ) = @_; + my $latitude = $c->stash->{latitude}; + my $longitude = $c->stash->{longitude}; + + # Forms that allow photos need a different enctype + my $allow_photo_upload = $c->cobrand->allow_photo_upload; + + # Don't do anything if the user skipped the map + if ( $c->req->param('skipped') ) { + + my $enctype = + $allow_photo_upload + ? ' enctype="multipart/form-data"' + : ''; + + my $cobrand_form_elements = + $c->cobrand->form_elements('mapSkippedForm'); + + my $form_action = $c->uri_for(''); + my $pc = encode_entities( $c->stash->{pc} ); + + $c->stash->{map_html} = <<END_MAP_HTML; +<form action="$form_action" method="post" name="mapSkippedForm"$enctype> +<input type="hidden" name="pc" value="pc"> +<input type="hidden" name="skipped" value="1"> +$cobrand_form_elements +<div id="skipped-map"> +END_MAP_HTML + + } + else { + my $map_type = $allow_photo_upload ? 2 : 1; + + $c->stash->{map_html} = FixMyStreet::Map::display_map( + $c->req, + latitude => $latitude, + longitude => $longitude, + type => $map_type, + pins => [ [ $latitude, $longitude, 'purple' ] ], + ); + } + + # get the closing for the map + $c->stash->{map_end} = FixMyStreet::Map::display_map_end(1); + + return 1; +} + +=head2 redirect_or_confirm_creation + +Now that the report has been created either redirect the user to its page if it +has been confirmed or email them a token if it has not been. + +=cut + +sub redirect_or_confirm_creation : Private { + my ( $self, $c ) = @_; + my $report = $c->stash->{report}; + + # If confirmed send the user straigh there. + if ( $report->confirmed ) { + my $report_uri = $c->uri_for( '/report', $report->id ); + $c->res->redirect($report_uri); + $c->detach; + } + + # otherwise create a confirm token and email it to them. + my $token = + $c->model("DB::Token") + ->create( { scope => 'problem', data => $report->id } ); + $c->stash->{token_url} = $c->uri_for( '/P', $token->token ); + $c->send_email( 'problem-confirm.txt', { to => $report->user->email } ); + + # tell user that they've been sent an email + $c->stash->{template} = 'email_sent.html'; + $c->stash->{email_type} = 'problem'; +} + +__PACKAGE__->meta->make_immutable; + +1; diff --git a/perllib/FixMyStreet/App/Controller/Root.pm b/perllib/FixMyStreet/App/Controller/Root.pm new file mode 100644 index 000000000..42ac856c6 --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Root.pm @@ -0,0 +1,80 @@ +package FixMyStreet::App::Controller::Root; +use Moose; +use namespace::autoclean; + +BEGIN { extends 'Catalyst::Controller' } + +__PACKAGE__->config( namespace => '' ); + +=head1 NAME + +FixMyStreet::App::Controller::Root - Root Controller for FixMyStreet::App + +=head1 DESCRIPTION + +[enter your description here] + +=head1 METHODS + +=head2 auto + +Set up general things for this instance + +=cut + +sub auto : Private { + my ( $self, $c ) = @_; + + # decide which cobrand this request should use + $c->setup_cobrand(); + + return 1; +} + +=head2 index + +=cut + +sub index : Path : Args(0) { + my ( $self, $c ) = @_; + $c->res->body('index'); +} + +=head2 default + +Forward to the standard 404 error page + +=cut + +sub default : Path { + my ( $self, $c ) = @_; + $c->detach('/page_not_found'); +} + +=head2 page_not_found + + $c->detach('/page_not_found'); + +Display a 404 page. + +=cut + +sub page_not_found : Private { + my ( $self, $c ) = @_; + + $c->stash->{template} = 'errors/page_not_found.html'; + $c->response->status(404); +} + +=head2 end + +Attempt to render a view, if needed. + +=cut + +sub end : ActionClass('RenderView') { +} + +__PACKAGE__->meta->make_immutable; + +1; diff --git a/perllib/FixMyStreet/App/Controller/Tokens.pm b/perllib/FixMyStreet/App/Controller/Tokens.pm new file mode 100644 index 000000000..1d64d9e18 --- /dev/null +++ b/perllib/FixMyStreet/App/Controller/Tokens.pm @@ -0,0 +1,129 @@ +package FixMyStreet::App::Controller::Tokens; +use Moose; +use namespace::autoclean; + +BEGIN { extends 'Catalyst::Controller'; } + +use FixMyStreet::Alert; + +=head1 NAME + +FixMyStreet::App::Controller::Tokens - Handle auth tokens + +=head1 DESCRIPTION + +Act on the various tokens that can be submitted. + +=head1 METHODS + +=cut + +=head2 confirm_problem + + /P/([0-9A-Za-z]{16,18}).*$ + +Confirm a problem - url appears in emails sent to users after they create the +problem but are not logged in. + +=cut + +sub confirm_problem : Path('/P') { + my ( $self, $c, $token_code ) = @_; + + my $auth_token = + $c->forward( 'load_auth_token', [ $token_code, 'problem' ] ); + + # Load the problem + my $problem_id = $auth_token->data; + my $problem = $c->model('DB::Problem')->find( { id => $problem_id } ) + || $c->detach('token_error'); + $c->stash->{problem} = $problem; + + # check that this email or domain are not the cause of abuse. If so hide it. + if ( $problem->is_from_abuser ) { + $problem->update( + { state => 'hidden', lastupdate => \'ms_current_timestamp()' } ); + $c->stash->{template} = 'tokens/abuse.html'; + return; + } + + # We have a problem - confirm it if needed! + $problem->update( + { + state => 'confirmed', + confirmed => \'ms_current_timestamp()', + lastupdate => \'ms_current_timestamp()', + } + ) if $problem->state eq 'unconfirmed'; + + # Subscribe problem reporter to email updates + my $alert_id = + FixMyStreet::Alert::create( $problem->user->email, 'new_updates', + $problem->cobrand, $problem->cobrand_data, $problem_id ); + FixMyStreet::Alert::confirm($alert_id); + + # log the problem creation user in to the site + $c->authenticate( { email => $problem->user->email }, 'no_password' ); + + return 1; +} + +=head2 redirect_to_partial_problem + + /P/... + +Redirect user to continue filling in a partial problem. + +=cut + +sub redirect_to_partial_problem : Path('/L') { + my ( $self, $c, $token_code ) = @_; + + my $url = $c->uri_for( "/report/new", { partial => $token_code } ); + return $c->res->redirect( $url ); +} + +=head2 load_auth_token + + my $auth_token = + $c->forward( 'load_auth_token', [ $token_code, $token_scope ] ); + + +Load the token if possible. If token is not found, or not valid detach to a nice +error message. + +=cut + +sub load_auth_token : Private { + my ( $self, $c, $token_code, $scope ) = @_; + + # clean the token of bad chars (in case of email client issues) + $token_code ||= ''; + $token_code =~ s{[^a-zA-Z0-9]+}{}g; + + # try to load the token + my $token = $c->model('DB::Token')->find( + { + scope => $scope, + token => $token_code, + } + ) || $c->detach('token_error'); + + return $token; +} + +=head2 token_error + +Display an error page saying that there is something wrong with the token. + +=cut + +sub token_error : Private { + my ( $self, $c ) = @_; + $c->stash->{template} = 'tokens/error.html'; + $c->detach; +} + +__PACKAGE__->meta->make_immutable; + +1; diff --git a/perllib/FixMyStreet/App/Model/DB.pm b/perllib/FixMyStreet/App/Model/DB.pm new file mode 100644 index 000000000..f9e43172f --- /dev/null +++ b/perllib/FixMyStreet/App/Model/DB.pm @@ -0,0 +1,24 @@ +package FixMyStreet::App::Model::DB; +use base 'Catalyst::Model::DBIC::Schema'; + +use strict; +use warnings; + +use FixMyStreet; + +__PACKAGE__->config( + schema_class => 'FixMyStreet::DB', + connect_info => FixMyStreet->dbic_connect_info, +); + +=head1 NAME + +FixMyStreet::App::Model::DB - Catalyst DBIC Schema Model + +=head1 DESCRIPTION + +L<Catalyst::Model::DBIC::Schema> Model using schema L<FixMyStreet::DB> + +=cut + +1; diff --git a/perllib/FixMyStreet/App/Model/EmailSend.pm b/perllib/FixMyStreet/App/Model/EmailSend.pm new file mode 100644 index 000000000..de85857f7 --- /dev/null +++ b/perllib/FixMyStreet/App/Model/EmailSend.pm @@ -0,0 +1,51 @@ +package FixMyStreet::App::Model::EmailSend; +use base 'Catalyst::Model::Adaptor'; + +use strict; +use warnings; + +use FixMyStreet; +use Email::Send; + +=head1 NAME + +FixMyStreet::App::Model::EmailSend + +=head1 DESCRIPTION + +Thin wrapper around Email::Send - configuring it correctly acording to our config. + +If the config value 'SMTP_SMARTHOST' is set then email is routed via SMTP to +that. Otherwise it is sent using a 'sendmail' like binary on the local system. + +And finally if if FixMyStreet->test_mode returns true then emails are not sent +at all but are stored in memory for the test suite to inspect (using +Email::Send::Test). + +=cut + +my $args = undef; + +if ( FixMyStreet->test_mode ) { + + # Email::Send::Test + $args = { mailer => 'Test', }; +} +elsif ( my $smtp_host = FixMyStreet->config('SMTP_SMARTHOST') ) { + + # Email::Send::SMTP + $args = { + mailer => 'SMTP', + mailer_args => { Host => $smtp_host }, + }; +} +else { + + # Email::Send::Sendmail + $args = { mailer => 'Sendmail' }; +} + +__PACKAGE__->config( + class => 'Email::Send', + args => $args, +); diff --git a/perllib/FixMyStreet/App/View/Email.pm b/perllib/FixMyStreet/App/View/Email.pm new file mode 100644 index 000000000..86d5c1d60 --- /dev/null +++ b/perllib/FixMyStreet/App/View/Email.pm @@ -0,0 +1,44 @@ +package FixMyStreet::App::View::Email; +use base 'Catalyst::View::TT'; + +use strict; +use warnings; + +use mySociety::Locale; +use FixMyStreet; + +__PACKAGE__->config( + TEMPLATE_EXTENSION => '.txt', + INCLUDE_PATH => [ # + FixMyStreet->path_to( 'templates', 'email', 'default' ), + ], + ENCODING => 'utf8', + render_die => 1, + expose_methods => ['loc'], +); + +=head1 NAME + +FixMyStreet::App::View::Email - TT View for FixMyStreet::App + +=head1 DESCRIPTION + +TT View for FixMyStreet::App. + +=cut + +=head2 loc + + [% loc('Some text to localize') %] + +Passes the text to the localisation engine for translations. + +=cut + +sub loc { + my ( $self, $c, @args ) = @_; + return _(@args); +} + +1; + diff --git a/perllib/FixMyStreet/App/View/Web.pm b/perllib/FixMyStreet/App/View/Web.pm new file mode 100644 index 000000000..75ca4dd81 --- /dev/null +++ b/perllib/FixMyStreet/App/View/Web.pm @@ -0,0 +1,85 @@ +package FixMyStreet::App::View::Web; +use base 'Catalyst::View::TT'; + +use strict; +use warnings; + +use mySociety::Locale; +use FixMyStreet; + +__PACKAGE__->config( + TEMPLATE_EXTENSION => '.html', + INCLUDE_PATH => [ # + FixMyStreet->path_to( 'templates', 'web', 'default' ), + ], + ENCODING => 'utf8', + render_die => 1, + expose_methods => [ 'loc', 'nget', 'tprintf', ], +); + +=head1 NAME + +FixMyStreet::App::View::Web - TT View for FixMyStreet::App + +=head1 DESCRIPTION + +TT View for FixMyStreet::App. + +=cut + +=head2 loc + + [% loc('Some text to localize') %] + +Passes the text to the localisation engine for translations. + +=cut + +sub loc { + my ( $self, $c, @args ) = @_; + return _(@args); +} + +=head2 nget + + [% nget( 'singular', 'plural', $number ) %] + +Use first or second srting depending on the number. + +=cut + +sub nget { + my ( $self, $c, @args ) = @_; + return mySociety::Locale::nget(@args); +} + +=head2 tprintf + + [% tprintf( 'foo %s bar', 'insert' ) %] + +sprintf (different name to avoid clash) + +=cut + +sub tprintf { + my ( $self, $c, $format, @args ) = @_; + return sprintf $format, @args; +} + +=head2 display_crossell_advert + + [% display_crossell_advert( email, name ) %] + +Displays a crosssell advert if permitted by the cobrand. + +=cut + +sub display_crossell_advert { + my ( $self, $c, $email, $name ) = @_; + + return unless $c->cobrand->allow_crosssell_adverts(); + return CrossSell::display_advert( $c->req, $email, $name ); +} + +1; + diff --git a/perllib/FixMyStreet/Cobrand.pm b/perllib/FixMyStreet/Cobrand.pm new file mode 100644 index 000000000..91155db6e --- /dev/null +++ b/perllib/FixMyStreet/Cobrand.pm @@ -0,0 +1,71 @@ +# Copyright (c) 2009 UK Citizens Online Democracy. All rights reserved. +# Email: evdb@mysociety.org. WWW: http://www.mysociety.org + +package FixMyStreet::Cobrand; + +use strict; +use warnings; + +use FixMyStreet; +use Carp; + +use Module::Pluggable + sub_name => '_cobrands', + search_path => ['FixMyStreet::Cobrand'], + require => 1; + +my @ALL_COBRAND_CLASSES = __PACKAGE__->_cobrands; + +=head2 get_allowed_cobrands + +Return an array reference of allowed cobrand subdomains + +=cut + +sub get_allowed_cobrands { + my $allowed_cobrand_string = FixMyStreet->config('ALLOWED_COBRANDS'); + my @allowed_cobrands = split( /\|/, $allowed_cobrand_string ); + return \@allowed_cobrands; +} + +=head2 available_cobrand_classes + + @available_cobrand_classes = + FixMyStreet::Cobrand->available_cobrand_classes(); + +Return an array of all the classes that were found and that have monikers that +match the values from get_allowed_cobrands. + +=cut + +sub available_cobrand_classes { + my $class = shift; + + my %allowed = map { $_ => 1 } @{ $class->get_allowed_cobrands }; + my @avail = grep { $allowed{ $_->moniker } } @ALL_COBRAND_CLASSES; + + return @avail; +} + +=head2 get_class_for_host + + $cobrand_class = FixMyStreet::Cobrand->get_class_for_host( $host ); + +Given a host determine which cobrand we should be using. + +=cut + +sub get_class_for_host { + my $class = shift; + my $host = shift; + + foreach my $avail ( $class->available_cobrand_classes ) { + my $moniker = $avail->moniker; + return $avail if $host =~ m{$moniker}; + } + + # if none match then use the default + return 'FixMyStreet::Cobrand::Default'; +} + +1; diff --git a/perllib/FixMyStreet/Cobrand/Barnet.pm b/perllib/FixMyStreet/Cobrand/Barnet.pm new file mode 100644 index 000000000..4d20d6522 --- /dev/null +++ b/perllib/FixMyStreet/Cobrand/Barnet.pm @@ -0,0 +1,81 @@ +package FixMyStreet::Cobrand::Barnet; +use base 'FixMyStreet::Cobrand::Default'; + +use strict; +use warnings; + +use Carp; +use URI::Escape; +use mySociety::VotingArea; + +sub site_restriction { + return ( "and council='2489'", 'barnet' ); +} + +sub base_url { + my $base_url = mySociety::Config::get('BASE_URL'); + if ( $base_url !~ /barnet/ ) { + $base_url =~ s{http://(?!www\.)}{http://barnet.}g; + $base_url =~ s{http://www\.}{http://barnet.}g; + } + return $base_url; +} + +sub site_title { + my ($self) = @_; + return 'Barnet Council FixMyStreet'; +} + +sub enter_postcode_text { + my ($self) = @_; + return 'Enter a Barnet postcode, or street name and area:'; +} + +sub council_check { + my ( $self, $params, $context ) = @_; + my $q = $self->request; + + my $councils; + if ( $params->{all_councils} ) { + $councils = $params->{all_councils}; + } + elsif ( defined $params->{lat} ) { + my $parent_types = $mySociety::VotingArea::council_parent_types; + $councils = mySociety::MaPit::call( + 'point', + "4326/$params->{lon},$params->{lat}", + type => $parent_types + ); + } + my $council_match = defined $councils->{2489}; + if ($council_match) { + return 1; + } + my $url = 'http://www.fixmystreet.com/'; + $url .= 'alert' if $context eq 'alert'; + $url .= '?pc=' . URI::Escape::uri_escape( $q->param('pc') ) + if $q->param('pc'); + my $error_msg = "That location is not covered by Barnet. +Please visit <a href=\"$url\">the main FixMyStreet site</a>."; + return ( 0, $error_msg ); +} + +# All reports page only has the one council. +sub all_councils_report { + return 0; +} + +sub disambiguate_location { + my ( $self, $s, $q ) = @_; + $s = "ll=51.612832,-0.218169&spn=0.0563,0.09&$s"; + return $s; +} + +sub recent_photos { + my ( $self, $num, $lat, $lon, $dist ) = @_; + $num = 2 if $num == 3; + return Problems::recent_photos( $num, $lat, $lon, $dist ); +} + +1; + diff --git a/perllib/FixMyStreet/Cobrand/Default.pm b/perllib/FixMyStreet/Cobrand/Default.pm new file mode 100644 index 000000000..9054af81c --- /dev/null +++ b/perllib/FixMyStreet/Cobrand/Default.pm @@ -0,0 +1,551 @@ +package FixMyStreet::Cobrand::Default; + +use strict; +use warnings; +use FixMyStreet; +use URI; + +use Carp; + +=head2 new + + my $cobrand = $class->new; + my $cobrand = $class->new( { request => $c->req } ); + +Create a new cobrand object, optionally setting the web request. + +You probably shouldn't need to do this and should get the cobrand object via a +method in L<FixMyStreet::Cobrand> instead. + +=cut + +sub new { + my $class = shift; + my $self = shift || {}; + return bless $self, $class; +} + +=head2 moniker + + $moniker = $cobrand_class->moniker(); + +Returns a moniker that can be used to identify this cobrand. By default this is +the last part of the class name lowercased - eg 'F::C::SomeCobrand' becomes +'somecobrand'. + +=cut + +sub moniker { + my $class = ref( $_[0] ) || $_[0]; # deal with object or class + my ($last_part) = $class =~ m{::(\w+)$}; + return lc($last_part); +} + +=head2 is_default + + $bool = $cobrand->is_default(); + +Returns true if this is the default cobrand, false otherwise. + +=cut + +sub is_default { + my $self = shift; + return $self->moniker eq 'default'; +} + +=head2 q + + $request = $cobrand->q; + +Often the cobrand needs access to the request so we add it at the start by +passing it to ->new. If the request has not been set and you call this (or a +method that needs it) then it croaks. This is probably because you are trying to +use a request-related method out of a request-context. + +=cut + +sub q { + my $self = shift; + return $self->{request} + || croak "No request has been set" + . " - should you be calling this method outside of a web request?"; +} + +=head2 path_to_web_templates + + $path = $cobrand->path_to_web_templates( ); + +Returns the path to the templates for this cobrand - by default +"templates/web/$moniker" + +=cut + +sub path_to_web_templates { + my $self = shift; + return FixMyStreet->path_to( 'templates/web', $self->moniker ); +} + +=head2 path_to_email_templates + + $path = $cobrand->path_to_email_templates( ); + +Returns the path to the templates for this cobrand - by default +"templates/email/$moniker" + +=cut + +sub path_to_email_templates { + my $self = shift; + return FixMyStreet->path_to( 'templates/email', $self->moniker ); +} + +=head1 site_restriction + +Return a site restriction clause and a site key if the cobrand uses a subset of +the FixMyStreet data. Parameter is any extra data the cobrand needs. Returns an +empty string and site key 0 if the cobrand uses all the data. + +=cut + +sub site_restriction { return ( "", 0 ) } + +=head2 contact_restriction + +Return a contact restriction clause if the cobrand uses a subset of the +FixMyStreet contact data. + +=cut + +sub contact_restriction { + ''; +} + +=head2 base_url_for_emails + +Return the base url to use in links in emails for the cobranded version of the +site, parameter is extra data. + +=cut + +sub base_url_for_emails { + my $self = shift; + return $self->base_url; +} + +=head2 admin_base_url + +Base URL for the admin interface. + +=cut + +sub admin_base_url { 0 } + +=head2 writetothem_url + +URL for writetothem; parameter is COBRAND_DATA. + +=cut + +sub writetothem_url { 0 } + +=head2 base_url + +Return the base url for the cobranded version of the site + +=cut + +sub base_url { mySociety::Config::get('BASE_URL') } + +=head2 base_host + +Return the base host for the cobranded version of the site + +=cut + +sub base_host { + my $self = shift; + my $uri = URI->new( $self->base_url ); + return $uri->host; +} + +=head2 enter_postcode_text + +Return the text that prompts the user to enter their postcode/place name. +Parameter is QUERY + +=cut + +sub enter_postcode_text { '' } + +=head2 set_lang_and_domain + + my $set_lang = $cobrand->set_lang_and_domain( $lang, $unicode, $dir ) + +Set the language and domain of the site based on the cobrand and host. + +=cut + +sub set_lang_and_domain { + my ( $self, $lang, $unicode, $dir ) = @_; + my $set_lang = mySociety::Locale::negotiate_language( + 'en-gb,English,en_GB|nb,Norwegian,nb_NO', $lang ); # XXX Testing + mySociety::Locale::gettext_domain( 'FixMyStreet', $unicode, $dir ); + mySociety::Locale::change(); + return $set_lang; +} + +=head2 alert_list_options + +Return HTML for a list of alert options for the cobrand, given QUERY and +OPTIONS. + +=cut + +sub alert_list_options { 0 } + +=head2 recent_photos + +Return N recent photos. If EASTING, NORTHING and DISTANCE are supplied, the +photos must be attached to problems within DISTANCE of the point defined by +EASTING and NORTHING. + +=cut + +sub recent_photos { + my $self = shift; + return Problems::recent_photos(@_); +} + +=head2 recent + +Return recent problems on the site. + +=cut + +sub recent { + my $self = shift; + return Problems::recent(@_); +} + +=head2 front_stats + +Given a QUERY, return a block of html for showing front stats for the site + +=cut + +sub front_stats { + my $self = shift; + return Problems::front_stats(@_); +} + +=head2 disambiguate_location + +Given a STRING ($_[1]) representing a location and a QUERY, return a string that +includes any disambiguating information available + +=cut + +sub disambiguate_location { "$_[1]&gl=uk" } + +=head2 prettify_epoch + +Parameter is EPOCHTIME + +=cut + +sub prettify_epoch { 0 } + +=head2 form_elements + +Parameters are FORM_NAME, QUERY. Return HTML for any extra needed elements for +FORM_NAME + +=cut + +sub form_elements { '' } + +=head2 cobrand_data_for_generic_update + +Parameter is UPDATE_DATA, a reference to a hash of non-cobranded update data. +Return cobrand extra data for the update + +=cut + +sub cobrand_data_for_generic_update { '' } + +=head2 cobrand_data_for_generic_update + +Parameter is PROBLEM_DATA, a reference to a hash of non-cobranded problem data. +Return cobrand extra data for the problem + +=cut + +sub cobrand_data_for_generic_problem { '' } + +=head2 extra_problem_data + +Parameter is QUERY. Return a string of extra data to be stored with a problem + +=cut + +sub extra_problem_data { '' } + +=head2 extra_update_data + +Parameter is QUERY. Return a string of extra data to be stored with an update + +=cut + +sub extra_update_data { '' } + +=head2 extra_alert_data + +Parameter is QUERY. Return a string of extra data to be stored with an alert + +=cut + +sub extra_alert_data { '' } + +=head2 extra_data + +Given a QUERY, extract any extra data required by the cobrand + +=cut + +sub extra_data { '' } + +=head2 extra_params + +Given a QUERY, return a hash of extra params to be included in any URLs in links +produced on the page returned by that query. + +=cut + +sub extra_params { '' } + +=head2 extra_problem_meta_text + +Returns any extra text to be displayed with a PROBLEM. + +=cut + +sub extra_problem_meta_text { '' } + +=head2 extra_update_meta_text + +Returns any extra text to be displayed with an UPDATE. + +=cut + +sub extra_update_meta_text { '' } + +=head2 url + +Given a URL ($_[1]), QUERY, EXTRA_DATA, return a URL with any extra params +needed appended to it. + +=cut + +sub url { $_[1] } + +=head2 header_params + +Return any params to be added to responses + +=cut + +sub header_params { return {} } + +=head2 root_path_js + +Parameter is QUERY. Return some js to set the root path from which AJAX queries +should be made. + +=cut + +sub root_path_js { 'var root_path = "";' } + +=head2 site_title + +Return the title to be used in page heads. + +=cut + +sub site_title { 'FixMyStreet.com' } + +=head2 on_map_list_limit + +Return the maximum number of items to be given in the list of reports on the map + +=cut + +sub on_map_list_limit { return undef; } + +=head2 allow_photo_upload + +Return a boolean indicating whether the cobrand allows photo uploads + +=cut + +sub allow_photo_upload { return 1; } + +=head2 allow_crosssell_adverts + +Return a boolean indicating whether the cobrand allows the display of crosssell +adverts + +=cut + +sub allow_crosssell_adverts { return 1; } + +=head2 allow_photo_display + +Return a boolean indicating whether the cobrand allows photo display + +=cut + +sub allow_photo_display { return 1; } + +=head2 allow_update_reporting + +Return a boolean indication whether users should see links next to updates +allowing them to report them as offensive. + +=cut + +sub allow_update_reporting { return 0; } + +=head2 geocoded_string_check + +Parameters are LOCATION, QUERY. Return a boolean indicating whether the +string LOCATION passes the cobrands checks. + +=cut + +sub geocoded_string_check { return 1; } + +=head2 council_check + +Paramters are COUNCILS, QUERY, CONTEXT. Return a boolean indicating whether +COUNCILS pass any extra checks. CONTEXT is where we are on the site. + +=cut + +sub council_check { return ( 1, '' ); } + +=head2 feed_xsl + +Return an XSL to be used in rendering feeds + +=cut + +sub feed_xsl { '/xsl.xsl' } + +=head2 all_councils_report + +Return a boolean indicating whether the cobrand displays a report of all +councils + +=cut + +sub all_councils_report { 1 } + +=head2 ask_ever_reported + +Return a boolean indicating whether people should be asked whether this is the +first time they' ve reported a problem + +=cut + +sub ask_ever_reported { 1 } + +=head2 admin_pages + +List of names of pages to display on the admin interface + +=cut + +sub admin_pages { 0 } + +=head2 admin_show_creation_graph + +Show the problem creation graph in the admin interface +=cut + +sub admin_show_creation_graph { 1 } + +=head2 area_types, area_min_generation + +The MaPit types this site handles + +=cut + +sub area_types { return qw(DIS LBO MTD UTA CTY COI); } +sub area_min_generation { 10 } + +=head2 contact_name, contact_email + +Return the contact name or email for the cobranded version of the site (to be +used in emails). + +=cut + +sub contact_name { $_[0]->get_cobrand_conf('CONTACT_NAME') } +sub contact_email { $_[0]->get_cobrand_conf('CONTACT_EMAIL') } + +=head2 get_cobrand_conf COBRAND KEY + +Get the value for KEY from the config file for COBRAND + +=cut + +sub get_cobrand_conf { + my ( $self, $key ) = @_; + my $value = undef; + my $cobrand_moniker = $self->moniker; + + my $cobrand_config_file = + FixMyStreet->path_to("conf/cobrands/$cobrand_moniker/general"); + my $normal_config_file = FixMyStreet->path_to('conf/general'); + + if ( -e $cobrand_config_file ) { + + # FIXME - don't rely on the config file name - should + # change mySociety::Config so that it can return values from a + # particular config file instead + mySociety::Config::set_file("$cobrand_config_file"); + my $config_key = $key . "_" . uc($cobrand_moniker); + $value = mySociety::Config::get( $config_key, undef ); + mySociety::Config::set_file("$normal_config_file"); + } + + # If we didn't find a value use one from normal config + if ( !defined($value) ) { + $value = mySociety::Config::get($key); + } + + return $value; +} + +=item email_host + +Return if we are the virtual host that sends email for this cobrand + +=cut + +sub email_host { + my $self = shift; + my $cobrand_moniker_uc = uc( $self->moniker ); + + my $email_vhost = + mySociety::Config::get("EMAIL_VHOST_$cobrand_moniker_uc") + || mySociety::Config::get("EMAIL_VHOST") + || ''; + + return $email_vhost + && "http://$email_vhost" eq mySociety::Config::get("BASE_URL"); +} + +1; + diff --git a/perllib/FixMyStreet/Cobrand/EmptyHomes.pm b/perllib/FixMyStreet/Cobrand/EmptyHomes.pm new file mode 100644 index 000000000..5ebee0d2b --- /dev/null +++ b/perllib/FixMyStreet/Cobrand/EmptyHomes.pm @@ -0,0 +1,72 @@ +package FixMyStreet::Cobrand::EmptyHomes; +use base 'FixMyStreet::Cobrand::Default'; + +use strict; +use warnings; + +use FixMyStreet; +use mySociety::Locale; +use Carp; + +=item + +Return the base url for this cobranded site + +=cut + +sub base_url { + my $base_url = FixMyStreet->config('BASE_URL'); + if ( $base_url !~ /emptyhomes/ ) { + $base_url =~ s/http:\/\//http:\/\/emptyhomes\./g; + } + return $base_url; +} + +sub admin_base_url { + return 'https://secure.mysociety.org/admin/emptyhomes/'; +} + +sub area_types { + return qw(DIS LBO MTD UTA LGD COI); # No CTY +} + +=item set_lang_and_domain LANG UNICODE + +Set the language and text domain for the site based on the query and host. + +=cut + +sub set_lang_and_domain { + my ( $self, $lang, $unicode, $dir ) = @_; + my $set_lang = mySociety::Locale::negotiate_language( + 'en-gb,English,en_GB|cy,Cymraeg,cy_GB', $lang ); + mySociety::Locale::gettext_domain( 'FixMyStreet-EmptyHomes', $unicode, + $dir ); + mySociety::Locale::change(); + return $set_lang; +} + +=item site_title + +Return the title to be used in page heads + +=cut + +sub site_title { + my ($self) = @_; + return _('Report Empty Homes'); +} + +=item feed_xsl + +Return the XSL file path to be used for feeds' + +=cut + +sub feed_xsl { + my ($self) = @_; + return '/xsl.eha.xsl'; +} + +1; + diff --git a/perllib/FixMyStreet/Cobrand/FiksGataMi.pm b/perllib/FixMyStreet/Cobrand/FiksGataMi.pm new file mode 100644 index 000000000..43565d8ea --- /dev/null +++ b/perllib/FixMyStreet/Cobrand/FiksGataMi.pm @@ -0,0 +1,38 @@ +package FixMyStreet::Cobrand::FiksGataMi; +use base 'FixMyStreet::Cobrand::Default'; + +use strict; +use warnings; + +use Carp; + +sub set_lang_and_domain { + my ( $self, $lang, $unicode, $dir ) = @_; + mySociety::Locale::negotiate_language( + 'en-gb,English,en_GB|nb,Norwegian,nb_NO', 'nb' ); + mySociety::Locale::gettext_domain( 'FixMyStreet', $unicode, $dir ); + mySociety::Locale::change(); +} + +sub enter_postcode_text { + my ( $self, $q ) = @_; + return _('Enter a nearby postcode, or street name and area:'); +} + +# Is also adding language parameter +sub disambiguate_location { + my ( $self, $s, $q ) = @_; + $s = "hl=no&gl=no&$s"; + return $s; +} + +sub area_types { + return ( 'NKO', 'NFY' ); +} + +sub area_min_generation { + return ''; +} + +1; + diff --git a/perllib/FixMyStreet/DB.pm b/perllib/FixMyStreet/DB.pm new file mode 100644 index 000000000..18c8cc2ca --- /dev/null +++ b/perllib/FixMyStreet/DB.pm @@ -0,0 +1,17 @@ +package FixMyStreet::DB; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Schema'; + +__PACKAGE__->load_namespaces; + +# Created by DBIx::Class::Schema::Loader v0.07009 @ 2011-03-01 15:43:43 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:tJZ+CpaAfZVPrctDXTZTuQ + +# You can replace this text with custom code or comments, and it will be preserved on regeneration +1; diff --git a/perllib/FixMyStreet/DB/Result/Abuse.pm b/perllib/FixMyStreet/DB/Result/Abuse.pm new file mode 100644 index 000000000..55b22d433 --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/Abuse.pm @@ -0,0 +1,19 @@ +package FixMyStreet::DB::Result::Abuse; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("FilterColumn"); +__PACKAGE__->table("abuse"); +__PACKAGE__->add_columns( "email", { data_type => "text", is_nullable => 0 } ); + +# Created by DBIx::Class::Schema::Loader v0.07010 @ 2011-03-28 12:14:16 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:fCIpGt51z5iDH9LmHeuRYQ + +# You can replace this text with custom code or comments, and it will be preserved on regeneration +1; diff --git a/perllib/FixMyStreet/DB/Result/Contact.pm b/perllib/FixMyStreet/DB/Result/Contact.pm new file mode 100644 index 000000000..5a993a773 --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/Contact.pm @@ -0,0 +1,45 @@ +package FixMyStreet::DB::Result::Contact; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("FilterColumn"); +__PACKAGE__->table("contacts"); +__PACKAGE__->add_columns( + "area_id", + { data_type => "integer", is_nullable => 0 }, + "category", + { data_type => "text", default_value => "Other", is_nullable => 0 }, + "email", + { data_type => "text", is_nullable => 0 }, + "confirmed", + { data_type => "boolean", is_nullable => 0 }, + "deleted", + { data_type => "boolean", is_nullable => 0 }, + "editor", + { data_type => "text", is_nullable => 0 }, + "whenedited", + { data_type => "timestamp", is_nullable => 0 }, + "note", + { data_type => "text", is_nullable => 0 }, + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "contacts_id_seq", + }, +); +__PACKAGE__->set_primary_key("id"); +__PACKAGE__->add_unique_constraint( "contacts_area_id_category_idx", + [ "area_id", "category" ] ); + +# Created by DBIx::Class::Schema::Loader v0.07010 @ 2011-03-24 17:36:08 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:u6kRlRfgwAiCqmGhj6io5A + +1; diff --git a/perllib/FixMyStreet/DB/Result/Problem.pm b/perllib/FixMyStreet/DB/Result/Problem.pm new file mode 100644 index 000000000..bafad4ec0 --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/Problem.pm @@ -0,0 +1,190 @@ +package FixMyStreet::DB::Result::Problem; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("FilterColumn"); +__PACKAGE__->table("problem"); +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "problem_id_seq", + }, + "postcode", + { data_type => "text", is_nullable => 0 }, + "council", + { data_type => "text", is_nullable => 1 }, + "areas", + { data_type => "text", is_nullable => 0 }, + "category", + { data_type => "text", default_value => "Other", is_nullable => 0 }, + "title", + { data_type => "text", is_nullable => 0 }, + "detail", + { data_type => "text", is_nullable => 0 }, + "photo", + { data_type => "bytea", is_nullable => 1 }, + "used_map", + { data_type => "boolean", is_nullable => 0 }, + "name", + { data_type => "text", is_nullable => 0 }, + "anonymous", + { data_type => "boolean", is_nullable => 0 }, + "created", + { + data_type => "timestamp", + default_value => \"ms_current_timestamp()", + is_nullable => 0, + }, + "confirmed", + { data_type => "timestamp", is_nullable => 1 }, + "state", + { data_type => "text", is_nullable => 0 }, + "lang", + { data_type => "text", default_value => "en-gb", is_nullable => 0 }, + "service", + { data_type => "text", default_value => "", is_nullable => 0 }, + "cobrand", + { data_type => "text", default_value => "", is_nullable => 0 }, + "cobrand_data", + { data_type => "text", default_value => "", is_nullable => 0 }, + "lastupdate", + { + data_type => "timestamp", + default_value => \"ms_current_timestamp()", + is_nullable => 0, + }, + "whensent", + { data_type => "timestamp", is_nullable => 1 }, + "send_questionnaire", + { data_type => "boolean", default_value => \"true", is_nullable => 0 }, + "latitude", + { data_type => "double precision", is_nullable => 0 }, + "longitude", + { data_type => "double precision", is_nullable => 0 }, + "user_id", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, +); +__PACKAGE__->set_primary_key("id"); +__PACKAGE__->belongs_to( + "user", + "FixMyStreet::DB::Result::User", + { id => "user_id" }, + { is_deferrable => 1, on_delete => "CASCADE", on_update => "CASCADE" }, +); + +# Created by DBIx::Class::Schema::Loader v0.07010 @ 2011-03-24 17:36:08 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:+a9n7IKg3yFdgxNIbo3SGg + +=head2 check_for_errors + + $error_hashref = $problem->check_for_errors(); + +Look at all the fields and return a hashref with all errors found, keyed on the +field name. This is intended to be passed back to the form to display the +errors. + +TODO - ideally we'd pass back error codes which would be humanised in the +templates (eg: 'missing','email_not_valid', etc). + +=cut + +sub check_for_errors { + my $self = shift; + + my %errors = (); + + $errors{title} = _('Please enter a subject') + unless $self->title =~ m/\S/; + + $errors{detail} = _('Please enter some details') + unless $self->detail =~ m/\S/; + + $errors{council} = _('No council selected') + unless $self->council + && $self->council =~ m/^(?:-1|[\d,]+(?:\|[\d,]+)?)$/; + + if ( $self->name !~ m/\S/ ) { + $errors{name} = _('Please enter your name'); + } + elsif (length( $self->name ) < 5 + || $self->name !~ m/\s/ + || $self->name =~ m/\ba\s*n+on+((y|o)mo?u?s)?(ly)?\b/i ) + { + $errors{name} = _( +'Please enter your full name, councils need this information - if you do not wish your name to be shown on the site, untick the box' + ); + } + + if ( $self->category + && $self->category eq _('-- Pick a category --') ) + { + $errors{category} = _('Please choose a category'); + $self->category(undef); + } + elsif ($self->category + && $self->category eq _('-- Pick a property type --') ) + { + $errors{category} = _('Please choose a property type'); + $self->category(undef); + } + + return \%errors; +} + +=head2 is_from_abuser + + $bool = $problem->is_from_abuser( ); + +Returns true if the user's email or its domain is listed in the 'abuse' table. + +=cut + +sub is_from_abuser { + my $self = shift; + + # get the domain + my $email = $self->user->email; + my ($domain) = $email =~ m{ @ (.*) \z }x; + + # search for an entry in the abuse table + my $abuse_rs = $self->result_source->schema->resultset('Abuse'); + + return + $abuse_rs->find( { email => $email } ) + || $abuse_rs->find( { email => $domain } ) + || undef; +} + +=head2 confirm + + $bool = $problem->confirm( ); + $problem->update; + + +Set the state to 'confirmed' and put current time into 'confirmed' field. This +is a no-op if the report is already confirmed. + +NOTE - does not update storage - call update or insert to do that. + +=cut + +sub confirm { + my $self = shift; + + return if $self->state eq 'confirmed'; + + $self->state('confirmed'); + $self->confirmed( \'ms_current_timestamp()' ); + return 1; +} + +1; diff --git a/perllib/FixMyStreet/DB/Result/Session.pm b/perllib/FixMyStreet/DB/Result/Session.pm new file mode 100644 index 000000000..a50c3780b --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/Session.pm @@ -0,0 +1,24 @@ +package FixMyStreet::DB::Result::Session; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("FilterColumn"); +__PACKAGE__->table("sessions"); +__PACKAGE__->add_columns( + "id", { data_type => "char", is_nullable => 0, size => 72 }, + "session_data", { data_type => "text", is_nullable => 1 }, + "expires", { data_type => "integer", is_nullable => 1 }, +); +__PACKAGE__->set_primary_key("id"); + +# Created by DBIx::Class::Schema::Loader v0.07010 @ 2011-03-24 17:36:08 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:E6SUYbAPJMQSXTrvn0x3kg + +# You can replace this text with custom code or comments, and it will be preserved on regeneration +1; diff --git a/perllib/FixMyStreet/DB/Result/Token.pm b/perllib/FixMyStreet/DB/Result/Token.pm new file mode 100644 index 000000000..e4ea7262a --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/Token.pm @@ -0,0 +1,86 @@ +package FixMyStreet::DB::Result::Token; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("FilterColumn"); +__PACKAGE__->table("token"); +__PACKAGE__->add_columns( + "scope", + { data_type => "text", is_nullable => 0 }, + "token", + { data_type => "text", is_nullable => 0 }, + "data", + { data_type => "bytea", is_nullable => 0 }, + "created", + { + data_type => "timestamp", + default_value => \"ms_current_timestamp()", + is_nullable => 0, + }, +); +__PACKAGE__->set_primary_key( "scope", "token" ); + +# Created by DBIx::Class::Schema::Loader v0.07010 @ 2011-03-24 17:36:08 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:tClh4Spd63IpCeiGVHfrEQ + +# Trying not to use this +# use mySociety::DBHandle qw(dbh); + +use mySociety::AuthToken; +use IO::String; +use RABX; + +=head1 NAME + +FixMyStreet::DB::Result::Token + +=head2 DESCRIPTION + +Representation of mySociety::AuthToken in the DBIx::Class world. + +Mostly done so that we don't need to use mySociety::DBHandle. + +The 'data' value is automatically inflated and deflated in the same way that the +AuthToken would do it. 'token' is set to a new random value by default and the +'created' timestamp is achieved using the database function +ms_current_timestamp. + +=cut + +__PACKAGE__->filter_column( + data => { + filter_from_storage => sub { + my $self = shift; + my $ser = shift; + return undef unless defined $ser; + my $h = new IO::String($ser); + return RABX::wire_rd($h); + }, + filter_to_storage => sub { + my $self = shift; + my $data = shift; + my $ser = ''; + my $h = new IO::String($ser); + RABX::wire_wr( $data, $h ); + return $ser; + }, + } +); + +sub new { + my ( $class, $attrs ) = @_; + + $attrs->{token} ||= mySociety::AuthToken::random_token(); + $attrs->{created} ||= \'ms_current_timestamp()'; + + my $new = $class->next::method($attrs); + return $new; +} + +1; diff --git a/perllib/FixMyStreet/DB/Result/User.pm b/perllib/FixMyStreet/DB/Result/User.pm new file mode 100644 index 000000000..32361ca48 --- /dev/null +++ b/perllib/FixMyStreet/DB/Result/User.pm @@ -0,0 +1,84 @@ +package FixMyStreet::DB::Result::User; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("FilterColumn"); +__PACKAGE__->table("users"); +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "users_id_seq", + }, + "email", + { data_type => "text", is_nullable => 0 }, + "name", + { data_type => "text", is_nullable => 1 }, + "phone", + { data_type => "text", is_nullable => 1 }, + "password", + { data_type => "text", default_value => "", is_nullable => 0 }, +); +__PACKAGE__->set_primary_key("id"); +__PACKAGE__->add_unique_constraint( "users_email_key", ["email"] ); +__PACKAGE__->has_many( + "problems", + "FixMyStreet::DB::Result::Problem", + { "foreign.user_id" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +# Created by DBIx::Class::Schema::Loader v0.07010 @ 2011-03-24 17:36:08 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:36KVfhjrygEEmpmWm/vZBg + +use mySociety::EmailUtil; + +=head2 check_for_errors + + $error_hashref = $problem->check_for_errors(); + +Look at all the fields and return a hashref with all errors found, keyed on the +field name. This is intended to be passed back to the form to display the +errors. + +TODO - ideally we'd pass back error codes which would be humanised in the +templates (eg: 'missing','email_not_valid', etc). + +=cut + +sub check_for_errors { + my $self = shift; + + my %errors = (); + + if ( $self->name !~ m/\S/ ) { + $errors{name} = _('Please enter your name'); + } + elsif (length( $self->name ) < 5 + || $self->name !~ m/\s/ + || $self->name =~ m/\ba\s*n+on+((y|o)mo?u?s)?(ly)?\b/i ) + { + $errors{name} = _( +'Please enter your full name, councils need this information - if you do not wish your name to be shown on the site, untick the box' + ); + } + + if ( $self->email !~ /\S/ ) { + $errors{email} = _('Please enter your email'); + } + elsif ( !mySociety::EmailUtil::is_valid_email( $self->email ) ) { + $errors{email} = _('Please enter a valid email'); + } + + return \%errors; +} + +1; diff --git a/perllib/FixMyStreet/DB/ResultSet/Contact.pm b/perllib/FixMyStreet/DB/ResultSet/Contact.pm new file mode 100644 index 000000000..52ff498a6 --- /dev/null +++ b/perllib/FixMyStreet/DB/ResultSet/Contact.pm @@ -0,0 +1,20 @@ +package FixMyStreet::DB::ResultSet::Contact; +use base 'DBIx::Class::ResultSet'; + +use strict; +use warnings; + +=head2 not_deleted + + $rs = $rs->not_deleted(); + +Filter down to not deleted contacts - which have C<deleted> set to false; + +=cut + +sub not_deleted { + my $rs = shift; + return $rs->search( { deleted => 0 } ); +} + +1; diff --git a/perllib/FixMyStreet/DB/ResultSet/User.pm b/perllib/FixMyStreet/DB/ResultSet/User.pm new file mode 100644 index 000000000..7e657a936 --- /dev/null +++ b/perllib/FixMyStreet/DB/ResultSet/User.pm @@ -0,0 +1,8 @@ +package FixMyStreet::DB::ResultSet::User; +use base 'DBIx::Class::ResultSet'; + +use strict; +use warnings; + + +1; diff --git a/perllib/FixMyStreet/Map.pm b/perllib/FixMyStreet/Map.pm index 5305b360a..62dab454b 100644 --- a/perllib/FixMyStreet/Map.pm +++ b/perllib/FixMyStreet/Map.pm @@ -77,7 +77,7 @@ sub header { my $cobrand = Page::get_cobrand($q); my $cobrand_form_elements = Cobrand::form_elements( $cobrand, 'mapForm', $q ); - my $form_action = Cobrand::url( $cobrand, '/', $q ); + my $form_action = Cobrand::url( $cobrand, '/report/new', $q ); my $encoding = ''; $encoding = ' enctype="multipart/form-data"' if $type == 2; my $pc = ent($q->param('pc') || ''); diff --git a/perllib/FixMyStreet/TestMech.pm b/perllib/FixMyStreet/TestMech.pm new file mode 100644 index 000000000..04d825da7 --- /dev/null +++ b/perllib/FixMyStreet/TestMech.pm @@ -0,0 +1,283 @@ +package FixMyStreet::TestMech; +use base qw(Test::WWW::Mechanize::Catalyst Test::Builder::Module); + +use strict; +use warnings; + +BEGIN { + use FixMyStreet; + FixMyStreet->test_mode(1); +} + +use Test::WWW::Mechanize::Catalyst 'FixMyStreet::App'; +use Test::More; +use Web::Scraper; +use Carp; +use Email::Send::Test; +use Digest::SHA1 'sha1_hex'; + +=head1 NAME + +FixMyStreet::TestMech - T::WWW::M:C but with FMS specific smarts + +=head1 DESCRIPTION + +This module subclasses L<Test::WWW::Mechanize::Catalyst> and adds some +FixMyStreet specific smarts - such as the ability to scrape the resulting page +for form error messages. + +Note - using this module puts L<FixMyStreet::App> into test mode - so for +example emails will not get sent. + +=head1 METHODS + +=head2 check_not_logged_in, check_logged_in + + $bool = $mech->check_not_logged_in(); + $bool = $mech->check_logged_in(); + +Check that the current mech is not logged or logged in as a user. Produces test output. +Returns true test passed, false otherwise. + +=cut + +sub not_logged_in_ok { + my $mech = shift; + $mech->builder->ok( $mech->get('/auth/check_auth')->code == 401, + "not logged in" ); +} + +sub logged_in_ok { + my $mech = shift; + $mech->builder->ok( $mech->get('/auth/check_auth')->code == 200, + "logged in" ); +} + +=head2 log_in_ok + + $user = $mech->log_in_ok( $email_address ); + +Log in with the email given. If email does not match an account then create one. + +=cut + +sub log_in_ok { + my $mech = shift; + my $email = shift; + + my $user = + FixMyStreet::App->model('DB::User') + ->find_or_create( { email => $email } ); + ok $user, "found/created user for $email"; + + # store the old password and then change it + my $old_password_sha1 = $user->password; + $user->update( { password => sha1_hex('secret') } ); + + # log in + $mech->get_ok('/auth'); + $mech->submit_form_ok( + { with_fields => { email => $email, password => 'secret' } }, + "login using form" ); + $mech->logged_in_ok; + + # restore the password (if there was one) + $user->update( { password => $old_password_sha1 } ) if $old_password_sha1; + + return $user; +} + +=head2 log_out_ok + + $bool = $mech->log_out_ok( ); + +Log out the current user + +=cut + +sub log_out_ok { + my $mech = shift; + $mech->get_ok('/auth/logout'); + $mech->not_logged_in_ok; +} + +sub delete_user { + my $mech = shift; + my $user = shift; + + $mech->log_out_ok; + ok( $_->delete, "delete problem " . $_->title ) # + for $user->problems; + ok $user->delete, "delete test user " . $user->email; + + return 1; +} + +=head2 clear_emails_ok + + $bool = $mech->clear_emails_ok(); + +Clear the email queue. + +=cut + +sub clear_emails_ok { + my $mech = shift; + Email::Send::Test->clear; + $mech->builder->ok( 1, 'cleared email queue' ); + return 1; +} + +=head2 email_count_is + + $bool = $mech->email_count_is( $number ); + +Check that the number of emails in queue is correct. + +=cut + +sub email_count_is { + my $mech = shift; + my $number = shift || 0; + + $mech->builder->is_num( scalar( Email::Send::Test->emails ), + $number, "checking for $number email(s) in the queue" ); +} + +=head2 get_email + + $email = $mech->get_email; + +In scalar context returns first email in queue and fails a test if there are not exactly one emails in the queue. + +In list context returns all the emails (or none). + +=cut + +sub get_email { + my $mech = shift; + my @emails = Email::Send::Test->emails; + + return @emails if wantarray; + + $mech->email_count_is(1) || return undef; + return $emails[0]; +} + +=head2 form_errors + + my $arrayref = $mech->form_errors; + +Find all the form errors on the current page and return them in page order as an +arrayref of TEXTs. If none found return empty arrayref. + +=cut + +sub form_errors { + my $mech = shift; + my $result = scraper { + process 'div.form-error', 'errors[]', 'TEXT'; + } + ->scrape( $mech->response ); + return $result->{errors} || []; +} + +=head2 import_errors + + my $arrayref = $mech->import_errors; + +Takes the text output from the import post result and returns all the errors as +an arrayref. + +=cut + +sub import_errors { + my $mech = shift; + my @errors = # + grep { $_ } # + map { s{^ERROR:\s*(.*)$}{$1}g ? $_ : undef; } # + split m/\n+/, $mech->response->content; + return \@errors; +} + +=head2 pc_alternatives + + my $arrayref = $mech->pc_alternatives; + +Find all the suggestions for near matches for a location. Return text presented to user as arrayref, empty arrayref if none found. + +=cut + +sub pc_alternatives { + my $mech = shift; + my $result = scraper { + process 'ul.pc_alternatives li', 'pc_alternatives[]', 'TEXT'; + } + ->scrape( $mech->response ); + return $result->{pc_alternatives} || []; +} + +=head2 extract_location + + $hashref = $mech->extract_location( ); + +Extracts the location from the current page. Looks for inputs with the names +C<pc>, C<latitude> and C<longitude> and returns their values in a hashref with +those keys. If no values found then the values in hashrof are C<undef>. + +=cut + +sub extract_location { + my $mech = shift; + + my $result = scraper { + process 'input[name="pc"]', pc => '@value'; + process 'input[name="latitude"]', latitude => '@value'; + process 'input[name="longitude"]', longitude => '@value'; + } + ->scrape( $mech->response ); + + return { + pc => undef, + latitude => undef, + longitude => undef, + %$result + }; +} + +=head2 visible_form_values + + $hashref = $mech->visible_form_values( ); + +Return all the visible form values on the page - ie not the hidden ones. + +=cut + +sub visible_form_values { + my $mech = shift; + + my @forms = $mech->forms; + + # insert form filtering here (eg ignore login form) + + croak "Found no forms - can't continue..." + unless @forms; + croak "Found several forms - don't know which to use..." + if @forms > 1; + + my $form = $forms[0]; + + my @visible_fields = + grep { ref($_) ne 'HTML::Form::SubmitInput' } + grep { ref($_) ne 'HTML::Form::ImageInput' } + grep { ref($_) ne 'HTML::Form::TextInput' || $_->type ne 'hidden' } + $form->inputs; + + my @visible_field_names = map { $_->name } @visible_fields; + + my %params = map { $_ => $form->value($_) } @visible_field_names; + + return \%params; +} + +1; diff --git a/perllib/Page.pm b/perllib/Page.pm index 24c52885a..797da363d 100644 --- a/perllib/Page.pm +++ b/perllib/Page.pm @@ -362,7 +362,7 @@ EOF </div></div> <h2 class="v">$params{navigation}</h2> <ul id="navigation"> -<li><a href="/">$params{report}</a></li> +<li><a href="/report/new">$params{report}</a></li> <li><a href="/reports">$params{reports}</a></li> <li><a href="/alert$params{pc}">$params{alerts}</a></li> <li><a href="/faq">$params{help}</a></li> diff --git a/perllib/Problems.pm b/perllib/Problems.pm index 3710c3a95..111583fd5 100644 --- a/perllib/Problems.pm +++ b/perllib/Problems.pm @@ -35,6 +35,16 @@ sub set_site_restriction { } } +# Set the site restrictions using the new cobrand style - no need to special +# case 'fixmystreet' as default cobrand takes care of that. +sub set_site_restriction_with_cobrand_object { + my $cobrand = shift; + + my $cobrand_data = $cobrand->extra_data; + ( $site_restriction, $site_key ) = + $cobrand->site_restriction($cobrand_data); +} + sub current_timestamp { my $current_timestamp = dbh()->selectrow_array('select ms_current_timestamp()'); return "'$current_timestamp'::timestamp"; diff --git a/script/fixmystreet_app_create.pl b/script/fixmystreet_app_create.pl new file mode 100755 index 000000000..c0ec0c898 --- /dev/null +++ b/script/fixmystreet_app_create.pl @@ -0,0 +1,60 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use Catalyst::ScriptRunner; +Catalyst::ScriptRunner->run('FixMyStreet::App', 'Create'); + +1; + +=head1 NAME + +fixmystreet_app_create.pl - Create a new Catalyst Component + +=head1 SYNOPSIS + +fixmystreet_app_create.pl [options] model|view|controller name [helper] [options] + + Options: + --force don't create a .new file where a file to be created exists + --mechanize use Test::WWW::Mechanize::Catalyst for tests if available + --help display this help and exits + + Examples: + fixmystreet_app_create.pl controller My::Controller + fixmystreet_app_create.pl -mechanize controller My::Controller + fixmystreet_app_create.pl view My::View + fixmystreet_app_create.pl view HTML TT + fixmystreet_app_create.pl model My::Model + fixmystreet_app_create.pl model SomeDB DBIC::Schema MyApp::Schema create=dynamic\ + dbi:SQLite:/tmp/my.db + fixmystreet_app_create.pl model AnotherDB DBIC::Schema MyApp::Schema create=static\ + [Loader opts like db_schema, naming] dbi:Pg:dbname=foo root 4321 + [connect_info opts like quote_char, name_sep] + + See also: + perldoc Catalyst::Manual + perldoc Catalyst::Manual::Intro + perldoc Catalyst::Helper::Model::DBIC::Schema + perldoc Catalyst::Model::DBIC::Schema + perldoc Catalyst::View::TT + +=head1 DESCRIPTION + +Create a new Catalyst Component. + +Existing component files are not overwritten. If any of the component files +to be created already exist the file will be written with a '.new' suffix. +This behavior can be suppressed with the C<-force> option. + +=head1 AUTHORS + +Catalyst Contributors, see Catalyst.pm + +=head1 COPYRIGHT + +This library is free software. You can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/script/fixmystreet_app_server.pl b/script/fixmystreet_app_server.pl new file mode 100755 index 000000000..3778cf27d --- /dev/null +++ b/script/fixmystreet_app_server.pl @@ -0,0 +1,60 @@ +#!/usr/bin/env perl + +BEGIN { + $ENV{CATALYST_SCRIPT_GEN} = 40; +} + +use Catalyst::ScriptRunner; +Catalyst::ScriptRunner->run('FixMyStreet::App', 'Server'); + +1; + +=head1 NAME + +fixmystreet_app_server.pl - Catalyst Test Server + +=head1 SYNOPSIS + +fixmystreet_app_server.pl [options] + + -d --debug force debug mode + -f --fork handle each request in a new process + (defaults to false) + -? --help display this help and exits + -h --host host (defaults to all) + -p --port port (defaults to 3000) + -k --keepalive enable keep-alive connections + -r --restart restart when files get modified + (defaults to false) + -rd --restart_delay delay between file checks + (ignored if you have Linux::Inotify2 installed) + -rr --restart_regex regex match files that trigger + a restart when modified + (defaults to '\.yml$|\.yaml$|\.conf|\.pm$') + --restart_directory the directory to search for + modified files, can be set multiple times + (defaults to '[SCRIPT_DIR]/..') + --follow_symlinks follow symlinks in search directories + (defaults to false. this is a no-op on Win32) + --background run the process in the background + --pidfile specify filename for pid file + + See also: + perldoc Catalyst::Manual + perldoc Catalyst::Manual::Intro + +=head1 DESCRIPTION + +Run a Catalyst Testserver for this application. + +=head1 AUTHORS + +Catalyst Contributors, see Catalyst.pm + +=head1 COPYRIGHT + +This library is free software. You can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + diff --git a/script/fixmystreet_app_test.pl b/script/fixmystreet_app_test.pl new file mode 100755 index 000000000..4eefd06a4 --- /dev/null +++ b/script/fixmystreet_app_test.pl @@ -0,0 +1,40 @@ +#!/usr/bin/env perl + +use Catalyst::ScriptRunner; +Catalyst::ScriptRunner->run('FixMyStreet::App', 'Test'); + +1; + +=head1 NAME + +fixmystreet_app_test.pl - Catalyst Test + +=head1 SYNOPSIS + +fixmystreet_app_test.pl [options] uri + + Options: + --help display this help and exits + + Examples: + fixmystreet_app_test.pl http://localhost/some_action + fixmystreet_app_test.pl /some_action + + See also: + perldoc Catalyst::Manual + perldoc Catalyst::Manual::Intro + +=head1 DESCRIPTION + +Run a Catalyst action from the command line. + +=head1 AUTHORS + +Catalyst Contributors, see Catalyst.pm + +=head1 COPYRIGHT + +This library is free software. You can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/setenv.pl b/setenv.pl new file mode 100755 index 000000000..6e9fab20c --- /dev/null +++ b/setenv.pl @@ -0,0 +1,87 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use List::MoreUtils 'uniq'; + +my $root; + +BEGIN { # add the local perllibs too + + # Can't use Path::Class here as we'd load the old debian one. + $root = __FILE__ =~ m{^(.*)/web/\.\..*$} ? $1 : `pwd`; + chomp($root); +} + +# Set the environment for the FixMyStreet project + +# Add the lib/perl5 in perl-external so that we can load local::lib from there +use lib "$root/perl-external/lib/perl5"; + +# Add the perl-external dirs properly using local::lib +use local::lib "$root/perl-external"; +use local::lib "$root/perl-external/local-lib"; + +use lib "$root/commonlib/perllib"; +use lib "$root/perllib"; +for ( "$root/commonlib/perllib", "$root/perllib" ) { + $ENV{PERL5LIB} = "$_:$ENV{PERL5LIB}"; +} + +# also set the path to our scripts etc +$ENV{PATH} = join ':', uniq "$root/bin", split( m/:/, $ENV{PATH} ); + +# now decide what to do - if no arguments print out shell arguments to set the +# environment. If there are arguments then run those so that they run correctly +if (@ARGV) { + system @ARGV; +} + +# we might want to require this file to configure something like a CGI script +elsif ( $0 eq __FILE__ ) { + + my @keys = sort 'PATH', grep { m{^PERL} } keys %ENV; + + print "export $_='$ENV{$_}'\n" for @keys; + print 'export PS1="(fms) $PS1"' . "\n"; + + print << "STOP"; + +# $0 - set up the environment for FixMyStreet. +# +# This script can be used one of two ways: +# +# With arguments executes the arguments with the environment correctly set - +# intended for things like the cron jobs: +# +# $0 env +# +# Or if no arguments prints out the bash shell commands needed to set up the +# environment - which is useful when developing. Use this to set your current +# shell: +# +# eval `$0` +STOP + +} +else { + + # we were just required - unload some modules to prevent old code + # getting in the way of loading newer code from the newly set directories. + use Class::Unload; + + my @modules = + sort + grep { m/File::/ } + map { s{\.pm$}{}; s{/}{::}g; $_ } + grep { m{\.pm$} } + keys %INC; + + for (@modules) { + Class::Unload->unload($_); + } +} + +1; + diff --git a/t/app/01app.t b/t/app/01app.t new file mode 100644 index 000000000..02ffcd217 --- /dev/null +++ b/t/app/01app.t @@ -0,0 +1,10 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +use Catalyst::Test 'FixMyStreet::App'; + +ok( request('/')->is_success, 'Request should succeed' ); + +done_testing(); diff --git a/t/app/02pod.t b/t/app/02pod.t new file mode 100644 index 000000000..ababc2eaa --- /dev/null +++ b/t/app/02pod.t @@ -0,0 +1,10 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD}; +eval "use Test::Pod 1.14"; +plan skip_all => 'Test::Pod 1.14 required' if $@; + +all_pod_files_ok(); diff --git a/t/app/03podcoverage.t b/t/app/03podcoverage.t new file mode 100644 index 000000000..6ddc5c6b6 --- /dev/null +++ b/t/app/03podcoverage.t @@ -0,0 +1,14 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD}; + +eval "use Test::Pod::Coverage 1.04"; +plan skip_all => 'Test::Pod::Coverage 1.04 required' if $@; + +eval "use Pod::Coverage 0.20"; +plan skip_all => 'Pod::Coverage 0.20 required' if $@; + +all_pod_coverage_ok(); diff --git a/t/app/controller/about.t b/t/app/controller/about.t new file mode 100644 index 000000000..aeca47d86 --- /dev/null +++ b/t/app/controller/about.t @@ -0,0 +1,26 @@ +use strict; +use warnings; + +use Test::More; +use Test::WWW::Mechanize::Catalyst 'FixMyStreet::App'; + +ok( my $mech = Test::WWW::Mechanize::Catalyst->new, 'Created mech object' ); + +# check that we can get the page +$mech->get_ok('/about'); +$mech->content_contains('About Us :: FixMyStreet.com'); +$mech->content_contains('html lang="en-gb"'); + +# check that geting the page as EHA produces a different page +ok $mech->host("reportemptyhomes.co.uk"), 'change host to reportemptyhomes'; +$mech->get_ok('/about'); +$mech->content_contains('About us :: Report Empty Homes'); +$mech->content_contains('html lang="en-gb"'); + +# check that geting the page as EHA in welsh produces a different page +ok $mech->host("cy.reportemptyhomes.co.uk"), 'host to cy.reportemptyhomes'; +$mech->get_ok('/about'); +$mech->content_contains('Amdanom ni :: Adrodd am Eiddo Gwag'); +$mech->content_contains('html lang="cy"'); + +done_testing(); diff --git a/t/app/controller/auth.t b/t/app/controller/auth.t new file mode 100644 index 000000000..6e1e8d58d --- /dev/null +++ b/t/app/controller/auth.t @@ -0,0 +1,217 @@ +use strict; +use warnings; + +use Test::More tests => 97; + +use FixMyStreet::TestMech; +my $mech = FixMyStreet::TestMech->new; + +my $test_email = 'test@example.com'; +my $test_password = 'foobar'; + +END { + ok( FixMyStreet::App->model('DB::User')->find( { email => $_ } )->delete, + "delete test user '$_'" ) + for ($test_email); +} + +$mech->get_ok('/auth'); + +# check that we can't reach a page that is only available to authenticated users +$mech->not_logged_in_ok; + +# check that submitting form with no / bad email creates an error. +$mech->get_ok('/auth'); + +for my $test ( + [ '' => 'enter an email address' ], + [ 'not an email' => 'check your email address is correct' ], + [ 'bob@foo' => 'check your email address is correct' ], + [ 'bob@foonaoedudnueu.co.uk' => 'check your email address is correct' ], + ) +{ + my ( $email, $error_message ) = @$test; + pass "--- testing bad email '$email' gives error '$error_message'"; + $mech->get_ok('/auth'); + $mech->content_lacks($error_message); + $mech->submit_form_ok( + { + form_name => 'general_auth', + fields => { email => $email, }, + button => 'email_login', + }, + "try to create an account with email '$email'" + ); + is $mech->uri->path, '/auth', "still on auth page"; + $mech->content_contains($error_message); +} + +# create a new account +$mech->clear_emails_ok; +$mech->get_ok('/auth'); +$mech->submit_form_ok( + { + form_name => 'general_auth', + fields => { email => $test_email, }, + button => 'email_login', + }, + "create an account for '$test_email'" +); +is $mech->uri->path, '/auth/token', "redirected to welcome page"; + +# check that we are not logged in yet +$mech->not_logged_in_ok; + +# check that we got one email +{ + $mech->email_count_is(1); + my $email = $mech->get_email; + $mech->clear_emails_ok; + is $email->header('Subject'), "Your FixMyStreet.com account details", + "subject is correct"; + is $email->header('To'), $test_email, "to is correct"; + + # extract the link + my ($link) = $email->body =~ m{(http://\S+)}; + ok $link, "Found a link in email '$link'"; + + # check that the user does not exist + sub get_user { + FixMyStreet::App->model('DB::User')->find( { email => $test_email } ); + } + ok !get_user(), "no user exists"; + + # visit the confirm link (with bad token) and check user no confirmed + $mech->get_ok( $link . 'XXX' ); + ok !get_user(), "no user exists"; + $mech->not_logged_in_ok; + + # visit the confirm link and check user is confirmed + $mech->get_ok($link); + ok get_user(), "user created"; + is $mech->uri->path, '/my', "redirected to the 'my' section of site"; + $mech->logged_in_ok; + + # logout and try to use the token again + $mech->log_out_ok; + $mech->get_ok($link); + is $mech->uri, $link, "not logged in"; + $mech->content_contains( 'Link too old or already used', + 'token now invalid' ); + $mech->not_logged_in_ok; +} + +# get a login email and change password +{ + $mech->clear_emails_ok; + $mech->get_ok('/auth'); + $mech->submit_form_ok( + { + form_name => 'general_auth', + fields => { email => "$test_email", }, + button => 'email_login', + }, + "email_login with '$test_email'" + ); + is $mech->uri->path, '/auth/token', "redirected to token page"; + + # rest is as before so no need to test + + # follow link and change password - check not prompted for old password + $mech->not_logged_in_ok; + + $mech->email_count_is(1); + my $email = $mech->get_email; + $mech->clear_emails_ok; + my ($link) = $email->body =~ m{(http://\S+)}; + $mech->get_ok($link); + + $mech->follow_link_ok( { url => '/auth/change_password' } ); + + ok my $form = $mech->form_name('change_password'), + "found change password form"; + is_deeply [ sort grep { $_ } map { $_->name } $form->inputs ], # + [ 'confirm', 'new_password' ], + "check we got expected fields (ie not old_password)"; + + # check the various ways the form can be wrong + for my $test ( + { new => '', conf => '', err => 'enter a password', }, + { new => 'secret', conf => '', err => 'do not match', }, + { new => '', conf => 'secret', err => 'do not match', }, + { new => 'secret', conf => 'not_secret', err => 'do not match', }, + ) + { + $mech->get_ok('/auth/change_password'); + $mech->content_lacks( $test->{err}, "did not find expected error" ); + $mech->submit_form_ok( + { + form_name => 'change_password', + fields => + { new_password => $test->{new}, confirm => $test->{conf}, }, + }, + "change_password with '$test->{new}' and '$test->{conf}'" + ); + $mech->content_contains( $test->{err}, "found expected error" ); + } + + my $user = + FixMyStreet::App->model('DB::User')->find( { email => $test_email } ); + ok $user, "got a user"; + ok !$user->password, "user has no password"; + + $mech->get_ok('/auth/change_password'); + $mech->submit_form_ok( + { + form_name => 'change_password', + fields => + { new_password => $test_password, confirm => $test_password, }, + }, + "change_password with '$test_password' and '$test_password'" + ); + is $mech->uri->path, '/auth/change_password', + "still on change password page"; + $mech->content_contains( 'password has been changed', + "found password changed" ); + + $user->discard_changes(); + ok $user->password, "user now has a password"; +} + +# login using valid details +$mech->get_ok('/auth'); +$mech->submit_form_ok( + { + form_name => 'general_auth', + fields => { + email => $test_email, + password => $test_password, + }, + button => 'login', + }, + "login with '$test_email' & '$test_password" +); +is $mech->uri->path, '/my', "redirected to correct page"; + +# logout +$mech->log_out_ok; + +# try to login with bad details +$mech->get_ok('/auth'); +$mech->submit_form_ok( + { + form_name => 'general_auth', + fields => { + email => $test_email, + password => 'not the password', + }, + button => 'login', + }, + "login with '$test_email' & '$test_password" +); +is $mech->uri->path, '/auth', "redirected to correct page"; +$mech->content_contains( 'Email or password wrong', 'found error message' ); + +# more test: +# TODO: test that email are always lowercased + diff --git a/t/app/controller/my.t b/t/app/controller/my.t new file mode 100644 index 000000000..1ed6806a4 --- /dev/null +++ b/t/app/controller/my.t @@ -0,0 +1,19 @@ +use strict; +use warnings; + +use Test::More tests => 11; + +use FixMyStreet::TestMech; +my $mech = FixMyStreet::TestMech->new; + +$mech->get_ok('/my'); +is $mech->uri->path, '/auth', "got sent to the login page"; + +# login +my $user = $mech->log_in_ok( 'test@example.com' ); +$mech->get_ok('/my'); +is $mech->uri->path, '/my', "stayed on '/my/' page"; + +# cleanup +$mech->delete_user( $user ); + diff --git a/t/app/controller/page_not_found.t b/t/app/controller/page_not_found.t new file mode 100644 index 000000000..9c8d7e5a6 --- /dev/null +++ b/t/app/controller/page_not_found.t @@ -0,0 +1,20 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 4; + +use Test::WWW::Mechanize::Catalyst 'FixMyStreet::App'; + +my $mech = Test::WWW::Mechanize::Catalyst->new; + +# homepage ok +$mech->get_ok('/'); + +# get 404 page +my $path_to_404 = '/bad/path/page_not_found'; +my $res = $mech->get($path_to_404); +ok !$res->is_success(), "want a bad response"; +is $res->code, 404, "got 404"; +$mech->content_contains($path_to_404); diff --git a/t/app/controller/report_import.t b/t/app/controller/report_import.t new file mode 100644 index 000000000..5c16324d3 --- /dev/null +++ b/t/app/controller/report_import.t @@ -0,0 +1,158 @@ +use strict; +use warnings; +use Test::More; + +use FixMyStreet::TestMech; +use Web::Scraper; +use Path::Class; + +my $mech = FixMyStreet::TestMech->new; +$mech->get_ok('/import'); + +my $sample_file = file(__FILE__)->parent->file("sample.jpg")->stringify; +ok -e $sample_file, "sample file $sample_file exists"; + +# submit an empty report to import - check we get all errors +subtest "Test creating bad partial entries" => sub { + + foreach my $test ( + { + fields => { email => 'bob', }, + errors => [ + 'You must supply a service', + 'Please enter a subject', + 'Please enter your name', + 'Please enter a valid email', + 'Either a location or a photo must be provided.', + ], + }, + { + fields => { email => 'bob@example.com' }, + errors => [ + 'You must supply a service', + 'Please enter a subject', + 'Please enter your name', + 'Either a location or a photo must be provided.', + ], + }, + { + fields => { lat => 1, lon => 1, }, + errors => [ + 'You must supply a service', + 'Please enter a subject', + 'Please enter your name', + 'Please enter your email', +'We had a problem with the supplied co-ordinates - outside the UK?', + ], + }, + { + fields => { photo => $sample_file, }, + errors => [ + 'You must supply a service', + 'Please enter a subject', + 'Please enter your name', + 'Please enter your email', + ], + }, + ) + { + $mech->get_ok('/import'); + + $mech->submit_form_ok( # + { with_fields => $test->{fields} }, + "fill in form" + ); + + is_deeply( $mech->import_errors, $test->{errors}, "expected errors" ); + } + +}; + +# submit an empty report to import - check we get all errors +subtest "Submit a correct entry" => sub { + + $mech->get_ok('/import'); + + $mech->submit_form_ok( # + { + with_fields => { + service => 'test-script', + name => 'Test User', + email => 'test@example.com', + subject => 'Test report', + detail => 'This is a test report', + photo => $sample_file, + } + }, + "fill in form" + ); + + is_deeply( $mech->import_errors, [], "got no errors" ); + is $mech->content, 'SUCCESS', "Got success response"; + + # check that we have received the email + $mech->email_count_is(1); + my $email = $mech->get_email; + $mech->clear_emails_ok; + + my ($token_url) = $email->body =~ m{(http://\S+)}; + ok $token_url, "Found a token url $token_url"; + + # go to the token url + $mech->get_ok($token_url); + + # check that we are not shown anything as we don't have a location yet + is_deeply $mech->visible_form_values, { pc => '' }, + "check only pc field is shown"; + + $mech->submit_form_ok( # + { with_fields => { pc => 'SW1A 1AA' } }, + "fill in postcode" + ); + + # check that we are not shown anything as we don't have a location yet + is_deeply $mech->visible_form_values, + { + name => 'Test User', + email => 'test@example.com', + title => 'Test report', + detail => 'This is a test report', + photo => '', + phone => '', + may_show_name => '1', + }, + "check imported fields are shown"; + + TODO: { + local $TODO = "'/report/123' urls not srved by catalyst yet"; + + # change the details + $mech->submit_form_ok( # + { + with_fields => { + name => 'New Test User', + email => 'test@example.com', + title => 'New Test report', + detail => 'This is a test report', + phone => '01234 567 890', + may_show_name => '1', + } + }, + "Update details and save" + ); + } + + # check that report has been created + my $user = + FixMyStreet::App->model('DB::User') + ->find( { email => 'test@example.com' } ); + ok $user, "Found a user"; + + my $report = $user->problems->first; + is $report->state, 'confirmed', 'is confirmed'; + is $report->title, 'New Test report', 'title is correct'; + + $mech->delete_user($user); +}; + +done_testing(); diff --git a/t/app/controller/report_new.t b/t/app/controller/report_new.t new file mode 100644 index 000000000..dca86db77 --- /dev/null +++ b/t/app/controller/report_new.t @@ -0,0 +1,465 @@ +use strict; +use warnings; +use Test::More; + +use FixMyStreet::TestMech; +use Web::Scraper; + +my $mech = FixMyStreet::TestMech->new; +$mech->get_ok('/report/new'); + +# test various locations on inital search box +foreach my $test ( + { + pc => '', # + errors => [], + pc_alternatives => [], + }, + { + pc => 'xxxxxxxxxxxxxxxxxxxxxxxxxxx', + errors => ['Sorry, we could not find that location.'], + pc_alternatives => [], + }, + { + pc => 'glenthorpe', + errors => [], + pc_alternatives => [ # TODO - should filter out these non-UK addresses + 'Glenthorpe Crescent, Leeds LS9 7, UK', + 'Glenthorpe Rd, Merton, Greater London SM4 4, UK', + 'Glenthorpe Ln, Katy, TX 77494, USA', + 'Glenthorpe Dr, Walnut, CA 91789, USA', + 'Glenthorpe Ave, Leeds LS9 7, UK', + 'Glenthorpe Ct, Katy, TX 77494, USA', + ], + }, + { + pc => 'Glenthorpe Ct, Katy, TX 77494, USA', + errors => + ['We had a problem with the supplied co-ordinates - outside the UK?'], + pc_alternatives => [], + }, + ) +{ + subtest "test bad pc value '$test->{pc}'" => sub { + $mech->get_ok('/report/new'); + $mech->submit_form_ok( { with_fields => { pc => $test->{pc} } }, + "bad location" ); + is_deeply $mech->form_errors, $test->{errors}, + "expected errors for pc '$test->{pc}'"; + is_deeply $mech->pc_alternatives, $test->{pc_alternatives}, + "expected alternatives for pc '$test->{pc}'"; + }; +} + +# check that exact queries result in the correct lat,lng +foreach my $test ( + { + pc => 'SW1A 1AA', + latitude => '51.5010096115539', + longitude => '-0.141587067110009', + }, + { + pc => 'Manchester', + latitude => '53.4807125', + longitude => '-2.2343765', + }, + { + pc => 'Glenthorpe Rd, Merton, Greater London SM4 4, UK', + latitude => '51.3937997', + longitude => '-0.2209596', + }, + ) +{ + subtest "check lat/lng for '$test->{pc}'" => sub { + $mech->get_ok('/report/new'); + $mech->submit_form_ok( { with_fields => { pc => $test->{pc} } }, + "good location" ); + is_deeply $mech->form_errors, [], "no errors for pc '$test->{pc}'"; + is_deeply $mech->extract_location, $test, + "got expected location for pc '$test->{pc}'"; + }; +} + +# test that the various bit of form get filled in and errors correctly +# generated. +foreach my $test ( + { + msg => 'all fields empty', + pc => 'SW1A 1AA', + fields => { + title => '', + detail => '', + photo => '', + name => '', + may_show_name => '1', + email => '', + phone => '', + }, + changes => {}, + errors => [ + 'Please enter a subject', + 'Please enter some details', + 'Please enter your name', + 'Please enter your email', + ], + }, + { + msg => 'may_show_name defaults to true', + pc => 'SW1A 1AA', + fields => { + title => '', + detail => '', + photo => '', + name => '', + may_show_name => undef, + email => '', + phone => '', + }, + changes => { may_show_name => '1' }, + errors => [ + 'Please enter a subject', + 'Please enter some details', + 'Please enter your name', + 'Please enter your email', + ], + }, + { + msg => 'may_show_name unchanged if name is present (stays false)', + pc => 'SW1A 1AA', + fields => { + title => '', + detail => '', + photo => '', + name => 'Bob Jones', + may_show_name => undef, + email => '', + phone => '', + }, + changes => {}, + errors => [ + 'Please enter a subject', + 'Please enter some details', + 'Please enter your email', + ], + }, + { + msg => 'may_show_name unchanged if name is present (stays true)', + pc => 'SW1A 1AA', + fields => { + title => '', + detail => '', + photo => '', + name => 'Bob Jones', + may_show_name => '1', + email => '', + phone => '', + }, + changes => {}, + errors => [ + 'Please enter a subject', + 'Please enter some details', + 'Please enter your email', + ], + }, + { + msg => 'title and details tidied up', + pc => 'SW1A 1AA', + fields => { + title => 'DOG SHIT ON WALLS', + detail => 'on this portakabin - more of a portaloo HEH!!', + photo => '', + name => 'Bob Jones', + may_show_name => '1', + email => '', + phone => '', + }, + changes => { + title => 'Dog poo on walls', + detail => + 'On this [portable cabin] - more of a [portable loo] HEH!!', + }, + errors => [ 'Please enter your email', ], + }, + { + msg => 'name too short', + pc => 'SW1A 1AA', + fields => { + title => 'Test title', + detail => 'Test detail', + photo => '', + name => 'DUDE', + may_show_name => '1', + email => '', + phone => '', + }, + changes => {}, + errors => [ +'Please enter your full name, councils need this information - if you do not wish your name to be shown on the site, untick the box', + 'Please enter your email', + ], + }, + { + msg => 'name is anonymous', + pc => 'SW1A 1AA', + fields => { + title => 'Test title', + detail => 'Test detail', + photo => '', + name => 'anonymous', + may_show_name => '1', + email => '', + phone => '', + }, + changes => {}, + errors => [ +'Please enter your full name, councils need this information - if you do not wish your name to be shown on the site, untick the box', + 'Please enter your email', + ], + }, + { + msg => 'email invalid', + pc => 'SW1A 1AA', + fields => { + title => 'Test title', + detail => 'Test detail', + photo => '', + name => 'Joe Smith', + may_show_name => '1', + email => 'not an email', + phone => '', + }, + changes => { email => 'notanemail', }, + errors => [ 'Please enter a valid email', ], + }, + { + msg => 'cleanup title and detail', + pc => 'SW1A 1AA', + fields => { + title => " Test title ", + detail => " first line \n\n second\nline\n\n ", + photo => '', + name => '', + may_show_name => '1', + email => '', + phone => '', + }, + changes => { + title => 'Test title', + detail => "First line\n\nSecond line", + }, + errors => [ 'Please enter your name', 'Please enter your email', ], + }, + { + msg => 'clean up name and email', + pc => 'SW1A 1AA', + fields => { + title => '', + detail => '', + photo => '', + name => ' Bob Jones ', + may_show_name => '1', + email => ' BOB @ExAmplE.COM ', + phone => '', + }, + changes => { + name => 'Bob Jones', + email => 'bob@example.com', + }, + errors => [ 'Please enter a subject', 'Please enter some details', ], + }, + ) +{ + subtest "check form errors where $test->{msg}" => sub { + $mech->get_ok('/report/new'); + + # submit initial pc form + $mech->submit_form_ok( { with_fields => { pc => $test->{pc} } }, + "submit location" ); + is_deeply $mech->form_errors, [], "no errors for pc '$test->{pc}'"; + + # submit the main form + $mech->submit_form_ok( { with_fields => $test->{fields} }, + "submit form" ); + + # check that we got the errors expected + is_deeply $mech->form_errors, $test->{errors}, "check errors"; + + # check that fields have changed as expected + my $new_values = { + %{ $test->{fields} }, # values added to form + %{ $test->{changes} }, # changes we expect + }; + is_deeply $mech->visible_form_values, $new_values, + "values correctly changed"; + }; +} + +subtest "test report creation for a user who does not have an account" => sub { + $mech->log_out_ok; + $mech->clear_emails_ok; + + # check that the user does not exist + my $test_email = 'test-1@example.com'; + ok !FixMyStreet::App->model('DB::User')->find( { email => $test_email } ), + "test user does not exist"; + + # submit initial pc form + $mech->get_ok('/report/new'); + $mech->submit_form_ok( { with_fields => { pc => 'SW1A 1AA', } }, + "submit location" ); + $mech->submit_form_ok( + { + with_fields => { + title => 'Test Report', + detail => 'Test report details.', + photo => '', + name => 'Joe Bloggs', + may_show_name => '1', + email => 'test-1@example.com', + phone => '07903 123 456', + } + }, + "submit good details" + ); + + # check that we got the errors expected + is_deeply $mech->form_errors, [], "check there were no errors"; + + # check that the user has been created + my $user = + FixMyStreet::App->model('DB::User')->find( { email => $test_email } ); + ok $user, "created new user"; + + # find the report + my $report = $user->problems->first; + ok $report, "Found the report"; + + # check that the report is not available yet. + is $report->state, 'unconfirmed', "report not confirmed"; + is $mech->get( '/report/' . $report->id )->code, 404, "report not found"; + + # receive token + my $email = $mech->get_email; + ok $email, "got an email"; + like $email->body, qr/confirm the problem/i, "confirm the problem"; + + my ($url) = $email->body =~ m{(http://\S+)}; + ok $url, "extracted confirm url '$url'"; + + # confirm token + $mech->get_ok($url); + $report->discard_changes; + is $report->state, 'confirmed', "Report is now confirmed"; + is $report->state, 'confirmed', "report is now confirmed"; + + TODO: { + local $TODO = "'/report/<<id>>' not handled by catalyst yet"; + $mech->get_ok( '/report/' . $report->id ); + } + + # user is created and logged in + $mech->logged_in_ok; + + # cleanup + $mech->delete_user($user); +}; + +#### test report creation for a user who has account but is not logged in +# come to site +# fill in report +# receive token +# confirm token +# report is confirmed + +#### test report creation for user with account and logged in +subtest "test report creation for a user who is logged in" => sub { + + # check that the user does not exist + my $test_email = 'test-2@example.com'; + + $mech->clear_emails_ok; + my $user = $mech->log_in_ok($test_email); + + # setup the user. + ok $user->update( + { + name => 'Test User', + phone => '01234 567 890', + } + ), + "set users details"; + + # submit initial pc form + $mech->get_ok('/report/new'); + $mech->submit_form_ok( { with_fields => { pc => 'SW1A 1AA', } }, + "submit location" ); + + # check that the fields are correctly prefilled + is_deeply( + $mech->visible_form_values, + { + title => '', + detail => '', + may_show_name => '1', + email => $test_email, + name => 'Test User', + phone => '01234 567 890', + photo => '', + }, + "user's details prefilled" + ); + + TODO: { + local $TODO = +"'/report/<<id>>' not handled by catalyst yet - form creation redirects to there on success if logged in"; + eval { + $mech->submit_form_ok( + { + with_fields => { + title => 'Test Report', + detail => 'Test report details.', + photo => '', + name => 'Joe Bloggs', + may_show_name => '1', + phone => '07903 123 456', + } + }, + "submit good details" + ); + }; + } + + # find the report + my $report = $user->problems->first; + ok $report, "Found the report"; + + # check that we got redirected to /report/ + is $mech->uri->path, "/report/" . $report->id, "redirected to report page"; + + # check that no emails have been sent + $mech->email_count_is(0); + + # check report is confirmed and available + is $report->state, 'confirmed', "report is now confirmed"; + TODO: { + local $TODO = "'/report/<<id>>' not handled by catalyst yet"; + $mech->get_ok( '/report/' . $report->id ); + } + + # user is still logged in + $mech->logged_in_ok; + + # cleanup + $mech->delete_user($user); +}; + +#### test uploading an image + +#### test completing a partial report (eq flickr upload) + +#### possibly manual testing +# create report without using map +# create report by clicking on may with javascript off +# create report with images off + +done_testing(); diff --git a/t/app/controller/sample.jpg b/t/app/controller/sample.jpg Binary files differnew file mode 100644 index 000000000..23198cb83 --- /dev/null +++ b/t/app/controller/sample.jpg diff --git a/t/app/helpers/send_email.t b/t/app/helpers/send_email.t new file mode 100644 index 000000000..adf2c56c1 --- /dev/null +++ b/t/app/helpers/send_email.t @@ -0,0 +1,44 @@ +#!/usr/bin/perl + +use strict; +use warnings; +use utf8; + +BEGIN { + use FixMyStreet; + FixMyStreet->test_mode(1); +} + +use Test::More tests => 5; + +use Email::Send::Test; +use Path::Class; + +use_ok 'FixMyStreet::App'; +my $c = FixMyStreet::App->new; + +# fake up the request a little +$c->req->uri( URI->new('http://localhost/') ); +$c->req->base( $c->req->uri ); + +# set some values in the stash +$c->stash->{foo} = 'bar'; + +# clear the email queue +Email::Send::Test->clear; + +# send the test email +ok $c->send_email( 'test.txt', { to => 'test@recipient.com' } ), + "sent an email"; + +# check it got templated and sent correctly +my @emails = Email::Send::Test->emails; +is scalar(@emails), 1, "caught one email"; + +# Get the email, check it has a date and then strip it out +my $email_as_string = $emails[0]->as_string; +ok $email_as_string =~ s{\s+Date:\s+\S.*?$}{}xms, "Found and stripped out date"; + +is $email_as_string, + file(__FILE__)->dir->file('send_email_sample.txt')->slurp, + "email is as expected"; diff --git a/t/app/helpers/send_email_sample.txt b/t/app/helpers/send_email_sample.txt new file mode 100644 index 000000000..c6bdac74f --- /dev/null +++ b/t/app/helpers/send_email_sample.txt @@ -0,0 +1,29 @@ +MIME-Version: 1.0 +Subject: test email =?utf-8?Q?=E2=98=BA?= +Content-Type: text/plain; charset="utf-8" +To: test@recipient.com +Content-Transfer-Encoding: quoted-printable +From: evdb@ecclestoad.co.uk + + Hello, + + This is a test email where foo: bar. + + utf8: =E6=88=91=E4=BB=AC=E5=BA=94=E8=AF=A5=E8=83=BD=E5=A4=9F=E6=97=A0= +=E7=BC=9D=E5=A4=84=E7=90=86UTF8=E7=BC=96=E7=A0=81 + + indented_text + + long line: Lorem ipsum dolor sit amet, consectetur adipisicing + elit, sed do eiusmod tempor incididunt ut labore et dolore + magna aliqua. Ut enim ad minim veniam, quis nostrud + exercitation ullamco laboris nisi ut aliquip ex ea commodo + consequat. Duis aute irure dolor in reprehenderit in voluptate + velit esse cillum dolore eu fugiat nulla pariatur. Excepteur + sint occaecat cupidatat non proident, sunt in culpa qui officia + deserunt mollit anim id est laborum. + + Yours, + FixMyStreet. + + diff --git a/t/app/load_general_config.t b/t/app/load_general_config.t new file mode 100644 index 000000000..3855c2565 --- /dev/null +++ b/t/app/load_general_config.t @@ -0,0 +1,13 @@ +#!/usr/bin/perl -w + +use strict; +use warnings; + +use Test::More tests => 2; + +use_ok 'FixMyStreet::App'; + +# GAZE_URL chosen as it is unlikely to change +is FixMyStreet::App->config->{GAZE_URL}, # + 'http://gaze.mysociety.org/gaze', # + "check that known config param is loaded"; diff --git a/t/app/model/db.t b/t/app/model/db.t new file mode 100644 index 000000000..bebd68f0b --- /dev/null +++ b/t/app/model/db.t @@ -0,0 +1,8 @@ +use strict; +use warnings; + +use Test::More; + +use_ok 'FixMyStreet::App::Model::DB'; + +done_testing(); diff --git a/t/app/model/token.t b/t/app/model/token.t new file mode 100644 index 000000000..12945975e --- /dev/null +++ b/t/app/model/token.t @@ -0,0 +1,96 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 45; + +use FixMyStreet; +use FixMyStreet::App; +use mySociety::AuthToken; +use mySociety::DBHandle 'dbh'; + +# set things up so that code using mySociety::DBHandle is happy +FixMyStreet->configure_mysociety_dbhandle(); + +# NOTE - remember that you need to explicitly dbh()->commit after making +# database changes with the mySociety::* modules. + +# create a token using DBIC and check we can read it using AuthToken, and vice +# versa + +my %tests = ( + nested_hash => { foo => 'bar', and => [ 'baz', 'bundy' ] }, + array => [ 'foo', 'bar' ], + scalar => 123, +); + +my $token_rs = FixMyStreet::App->model('DB::Token'); + +# create using DBIC +foreach my $test_data_name ( sort keys %tests ) { + my $test_data = $tests{$test_data_name}; + + pass "--- testing DBIC create using '$test_data_name'"; + + my $dbic_token = + $token_rs->create( { scope => 'testing', data => $test_data } ); + my $token = $dbic_token->token; + ok $token, "stored token '$token'"; + + is_deeply $dbic_token->data, $test_data, "data stored correctly using DBIC"; + + # read back using DBIC + is_deeply $token_rs->find( { token => $token, scope => 'testing' } )->data, + $test_data, + "data read back correctly with DBIC"; + + # read back using mySociety::AuthToken + is_deeply mySociety::AuthToken::retrieve( 'testing', $token ), + $test_data, "data read back correctly with m::AT"; + + # delete token + ok $dbic_token->delete, "delete token"; + + is $token_rs->find( { token => $token, scope => 'testing' } ), + undef, + "token gone for DBIC"; + + # read back using mySociety::AuthToken + is mySociety::AuthToken::retrieve( 'testing', $token ), + undef, "token gone with m::AT"; + +} + +# create using m::AT +foreach my $test_data_name ( sort keys %tests ) { + my $test_data = $tests{$test_data_name}; + + pass "--- testing m::AT create using '$test_data_name'"; + + my $token = mySociety::AuthToken::store( 'testing', $test_data ); + dbh->commit(); + ok $token, "stored token '$token'"; + + # read back using DBIC + is_deeply $token_rs->find( { token => $token, scope => 'testing' } )->data, + $test_data, + "data read back correctly with DBIC"; + + # read back using mySociety::AuthToken + is_deeply mySociety::AuthToken::retrieve( 'testing', $token ), + $test_data, "data read back correctly with m::AT"; + + # delete token + ok mySociety::AuthToken::destroy( 'testing', $token ), "destroy token"; + dbh->commit(); + + is $token_rs->find( { token => $token, scope => 'testing' } ), + undef, + "token gone for DBIC"; + + # read back using mySociety::AuthToken + is mySociety::AuthToken::retrieve( 'testing', $token ), + undef, "token gone with m::AT"; + +} diff --git a/t/app/view/email.t b/t/app/view/email.t new file mode 100644 index 000000000..4d7bbe8ff --- /dev/null +++ b/t/app/view/email.t @@ -0,0 +1,8 @@ +use strict; +use warnings; + +use Test::More; + +BEGIN { use_ok 'FixMyStreet::App::View::Email' } + +done_testing(); diff --git a/t/app/view/web.t b/t/app/view/web.t new file mode 100644 index 000000000..0f49b986b --- /dev/null +++ b/t/app/view/web.t @@ -0,0 +1,8 @@ +use strict; +use warnings; +use Test::More; +use Test::More; + +BEGIN { use_ok 'FixMyStreet::App::View::Web' } + +done_testing(); diff --git a/t/cobrand/loading.t b/t/cobrand/loading.t new file mode 100644 index 000000000..405ef4761 --- /dev/null +++ b/t/cobrand/loading.t @@ -0,0 +1,71 @@ +use strict; +use warnings; + +use Test::More; +use Sub::Override; + +use FixMyStreet; + +use_ok 'FixMyStreet::Cobrand'; + +# check that the allowed cobrands is correctly loaded from config +{ + my $allowed = FixMyStreet::Cobrand->get_allowed_cobrands; + ok $allowed, "got the allowed_cobrands"; + isa_ok $allowed, "ARRAY"; + cmp_ok scalar @$allowed, '>', 1, "got more than one"; + is join( '|', @$allowed ), FixMyStreet->config('ALLOWED_COBRANDS'), + "matches config value"; +} + +# fake the allowed cobrands for testing +my $override = Sub::Override->new( # + 'FixMyStreet::Cobrand::get_allowed_cobrands' => + sub { return ['emptyhomes'] } +); +is_deeply FixMyStreet::Cobrand->get_allowed_cobrands, ['emptyhomes'], + 'overidden get_allowed_cobrands'; + +sub run_host_tests { + my %host_tests = @_; + for my $host ( sort keys %host_tests ) { + is FixMyStreet::Cobrand->get_class_for_host($host), + "FixMyStreet::Cobrand::$host_tests{$host}", + "does $host -> F::C::$host_tests{$host}"; + } +} + +# get the cobrand class by host +run_host_tests( + 'www.fixmystreet.com' => 'Default', + 'reportemptyhomes.com' => 'EmptyHomes', + 'barnet.fixmystreet.com' => 'Default', # not in the allowed_cobrands list + 'some.odd.site.com' => 'Default', +); + +# now enable barnet too and check that it works +$override->replace( # + 'FixMyStreet::Cobrand::get_allowed_cobrands' => + sub { return [ 'emptyhomes', 'barnet' ] } +); + +# get the cobrand class by host +run_host_tests( + 'www.fixmystreet.com' => 'Default', + 'reportemptyhomes.com' => 'EmptyHomes', + 'barnet.fixmystreet.com' => 'Barnet', # found now it is in allowed_cobrands + 'some.odd.site.com' => 'Default', +); + +# check that the moniker works as expected both on class and object. +is FixMyStreet::Cobrand::EmptyHomes->moniker, 'emptyhomes', + 'class->moniker works'; +is FixMyStreet::Cobrand::EmptyHomes->new->moniker, 'emptyhomes', + 'object->moniker works'; + +# check is_default works +ok FixMyStreet::Cobrand::Default->is_default, '::Default is default'; +ok !FixMyStreet::Cobrand::EmptyHomes->is_default, '::Emptyhomes is not default'; + +# all done +done_testing(); diff --git a/t/fixmystreet.t b/t/fixmystreet.t new file mode 100644 index 000000000..d7f00b047 --- /dev/null +++ b/t/fixmystreet.t @@ -0,0 +1,37 @@ +use strict; +use warnings; +use Path::Class; + +use Test::More; +use Test::Exception; + +use_ok 'FixMyStreet'; + +# check that the path_to works +my $file_path = file(__FILE__)->absolute->stringify; +my $path_to_path = FixMyStreet->path_to('t/fixmystreet.t'); + +isa_ok $path_to_path, 'Path::Class::File'; +ok $path_to_path->is_absolute, "path is absolute"; +is "$path_to_path", $file_path, "got $file_path"; + +# check that the config gets loaded and is immutable +my $config = FixMyStreet->config; +isa_ok $config, 'HASH'; +is $config->{GAZE_URL}, 'http://gaze.mysociety.org/gaze', + "got GAZE_URL correctly"; +throws_ok( + sub { $config->{GAZE_URL} = 'some other value'; }, + qr/Modification of a read-only value attempted/, + 'attempt to change config caught' +); +is $config->{GAZE_URL}, 'http://gaze.mysociety.org/gaze', "GAZE_URL unchanged"; + +# check that we can get the value by key as well +is FixMyStreet->config('GAZE_URL'), 'http://gaze.mysociety.org/gaze', + "GAZE_URL correct when got by key"; +is FixMyStreet->config('BAD_KEY_DOES_NOT_EXIST'), undef, "config miss is undef"; + +# all done +done_testing(); + diff --git a/t/i18n.t b/t/i18n.t new file mode 100644 index 000000000..6a5d94fa2 --- /dev/null +++ b/t/i18n.t @@ -0,0 +1,39 @@ +use strict; +use warnings; + +use Test::More; + +use FixMyStreet; +use mySociety::Locale; + +# check that the mo files have been generated +die "You need to run 'commonlib/bin/gettext-makemo --quiet FixMyStreet' " + . "to generate the *.mo files needed." + unless -e FixMyStreet->path_to( + 'locale/cy_GB.UTF-8/LC_MESSAGES/FixMyStreet-EmptyHomes.mo'); + +# Example strings +my $english = "Sorry! Something's gone wrong."; +my $welsh = "Ymddiheuriadau! Mae rhywbeth wedi mynd o'i le."; + +# set english as the language +mySociety::Locale::negotiate_language( # + 'en-gb,English,en_GB|cy,Cymraeg,cy_GB', 'en_GB' +); + +mySociety::Locale::gettext_domain( 'FixMyStreet-EmptyHomes', 1 ); +mySociety::Locale::change(); +is _($english), $english, "english to english"; + +# set to welsh and check for translation +mySociety::Locale::change('cy'); +is _($english), $welsh, "english to welsh"; + +# check that being in a deep directory does not confuse the code +chdir FixMyStreet->path_to('t/app/controller') . ''; +mySociety::Locale::gettext_domain( 'FixMyStreet-EmptyHomes', 1, + FixMyStreet->path_to('locale')->stringify ); +mySociety::Locale::change('cy'); +is _($english), $welsh, "english to welsh (deep directory)"; + +done_testing(); diff --git a/templates/email/default/login.txt b/templates/email/default/login.txt new file mode 100644 index 000000000..c873e82af --- /dev/null +++ b/templates/email/default/login.txt @@ -0,0 +1,12 @@ +Subject: [% loc('Your FixMyStreet.com account details') %] + +Please click on the link below to confirm your email address. Then you will be able to view your problem reports. + +[% c.uri_for( '/auth/token', token ) %] + +We will never give away or sell your email address to anyone else without your permission. + +Yours, + the FixMyStreet.com team + + diff --git a/templates/emails/partial b/templates/email/default/partial.txt index d754744b5..279d76ea0 100644 --- a/templates/emails/partial +++ b/templates/email/default/partial.txt @@ -1,12 +1,12 @@ Subject: Confirm your report on FixMyStreet -Hi<?=$values['name']?>, +Hi [% report.name || report.email %], To confirm the report you have uploaded to FixMyStreet via -<?=$values['service']?>, and to check or add any details, +[% report.service %], and to check or add any details, please visit the following URL: -<?=$values['url']?> +[% token_url %] Thanks! diff --git a/templates/email/default/problem-confirm.txt b/templates/email/default/problem-confirm.txt new file mode 100644 index 000000000..e16c90037 --- /dev/null +++ b/templates/email/default/problem-confirm.txt @@ -0,0 +1,20 @@ +Subject: Confirm your problem on FixMyStreet + +Hi [% report.user.name %], + +Please click on the link below to confirm the problem you just +added to FixMyStreet: + +[% token_url %] + +If your email program does not let you click on this link, +copy and paste it into your web browser and press return. + +Your problem had the title: +[% report.title %] + +And details: +[% report.detail %] + +Yours, +The FixMyStreet team diff --git a/templates/email/default/test.txt b/templates/email/default/test.txt new file mode 100644 index 000000000..1200b8726 --- /dev/null +++ b/templates/email/default/test.txt @@ -0,0 +1,15 @@ +Subject: test email ☺ +From: bad-sender@duff.com + +Hello, + +This is a test email where foo: [% foo %]. + +utf8: æˆ‘ä»¬åº”è¯¥èƒ½å¤Ÿæ— ç¼å¤„ç†UTF8ç¼–ç + + indented_text + +long line: Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum. + +Yours, + FixMyStreet. diff --git a/templates/web/default/about/about.html b/templates/web/default/about/about.html new file mode 100644 index 000000000..7219f6320 --- /dev/null +++ b/templates/web/default/about/about.html @@ -0,0 +1,9 @@ +[% INCLUDE 'header.html', title => loc('About Us') %] + +<h1>[% loc('About us') %]</h1> + +<h2>FixMyStreet.com</h2> + +[%# FIXME - put in blurb here %] + +[% INCLUDE 'footer.html' %]
\ No newline at end of file diff --git a/templates/web/default/auth/change_password.html b/templates/web/default/auth/change_password.html new file mode 100644 index 000000000..d4a7f107b --- /dev/null +++ b/templates/web/default/auth/change_password.html @@ -0,0 +1,41 @@ +[% INCLUDE 'header.html', title => loc('Change Password') %] + +<h1>[% loc('Change Password') %]</h1> + +[% IF password_changed %] + <p>Your password has been changed!</p> +[% END %] + + +<form action="[% c.uri_for('change_password') %]" method="post" name="change_password"> + + [% IF password_error; + + errors = { + missing => loc('Please enter a password'), + mismatch => loc('The passwords do not match'), + other => loc('Please check the passwords and try again'), + }; + + loc_password_error = errors.$password_error || errors.other; + END %] + + + <div> + <span class="error">[% loc_password_error %]</span><br> + <label for="new_password">[% loc('Password:') %]</label> + <input type="password" name="new_password" value="[% new_password | html %]"> + <br> + + <label for="confirm">[% loc('Again:') %]</label> + <input type="password" name="confirm" value="[% confirm | html %]"> + <br> + + <label for="login"> </label> + <input type="submit" value="[% loc('Change Password') %]"> + </div> + +</form> + + +[% INCLUDE 'footer.html' %] diff --git a/templates/web/default/auth/general.html b/templates/web/default/auth/general.html new file mode 100644 index 000000000..e0d516cbd --- /dev/null +++ b/templates/web/default/auth/general.html @@ -0,0 +1,52 @@ +[% INCLUDE 'header.html', title => loc('Login or create an account') %] + +<h1>[% loc('Login or create an account') %]</h1> + + +<form action="[% c.uri_for() %]" method="post" name="general_auth"> + + [% IF email_error; + + # other keys include fqdn, mxcheck if you'd like to write a custom error message + + errors = { + missing => loc('Please enter an email address'), + other => loc('Please check your email address is correct') + }; + + loc_email_error = errors.$email_error || errors.other; + END %] + + + <div> + + [% IF loc_email_error %] + <span class="error">[% loc_email_error %]</span><br> + [% ELSIF login_error %] + <span class="error">Email or password wrong - please try again.</span><br> + [% END %] + + <label for="email">[% loc('Email:') %]</label> + <input type="text" name="email" value="[% email || '' | html %]"> + <br> + + <label for="password">[% loc('Password:') %]</label> + <input type="password" name="password" value=""> + <br> + <!-- FIXME - implement session length choosing + <label for="remember_me"> </label> + <input type="checkbox" name="remember_me"> + Remember me - do not use on a public computer + <br> --> + <label for="login"> </label> + <input type="submit" name="login" value="[% loc('Log me in') %]"> + + <h3>I don't have an account, or I've forgotten my password...</h3> + <label for="email_login"> </label> + <input type="submit" name="email_login" value="[% loc('Email the details I need to the address I entered above') %]"> + </div> + +</form> + + +[% INCLUDE 'footer.html' %] diff --git a/templates/web/default/auth/logout.html b/templates/web/default/auth/logout.html new file mode 100644 index 000000000..9f3390f0a --- /dev/null +++ b/templates/web/default/auth/logout.html @@ -0,0 +1,8 @@ +[% INCLUDE 'header.html', title => loc('Logout') %] + +<h1>[% loc('You have been logged out') %]</h1> + +<p>Please feel free to <a href="[% c.uri_for('/auth/') %]">login again</a>.</p> + + +[% INCLUDE 'footer.html' %]
\ No newline at end of file diff --git a/templates/web/default/auth/token.html b/templates/web/default/auth/token.html new file mode 100644 index 000000000..16dfbb11c --- /dev/null +++ b/templates/web/default/auth/token.html @@ -0,0 +1,25 @@ +[% INCLUDE 'header.html', title => loc('Confirm account') %] + +[% IF token_not_found %] + +<h1>[% loc('Error') %]</h1> + +<p>We have not been able to confirm your account - sorry. This may be because:</p> + +<ul> + <li>Link too old or already used</li> + <li>URL not copied correctly</li> + [%# FIXME - add more reasons here %] +</ul> + +[% ELSE %] + +<h1>[% loc('Please check you email') %]</h1> + +<p>We have sent you an email containing a link to confirm your account.</p> + +<p>If you do not receive the email in the next few minutes please check your spam folder.</p> + +[% END %] + +[% INCLUDE 'footer.html' %]
\ No newline at end of file diff --git a/templates/web/default/debug_footer.html b/templates/web/default/debug_footer.html new file mode 100644 index 000000000..cf504e5a2 --- /dev/null +++ b/templates/web/default/debug_footer.html @@ -0,0 +1,11 @@ +[% IF c.config.STAGING_SITE %] +<hr clear="both"> +<ul> + <li>cobrand.moniker: [% c.cobrand.moniker %]</li> + <li>additional_template_paths: [% additional_template_paths.join(', ') || '--empty--' %]</li> + <li>lang_code: [% lang_code %]</li> + <li>user.id: [% c.user.id || '--not logged in--' %]</li> + +</ul> +[% END %] + diff --git a/templates/web/default/debug_header.html b/templates/web/default/debug_header.html new file mode 100644 index 000000000..247e55128 --- /dev/null +++ b/templates/web/default/debug_header.html @@ -0,0 +1,5 @@ +[% IF c.config.STAGING_SITE %] + <p class="error"> + [% loc("This is a developer site; things might break at any time, and the database will be periodically deleted.") %] + </p> +[% END %] diff --git a/templates/web/default/email_sent.html b/templates/web/default/email_sent.html new file mode 100644 index 000000000..bcfcf8617 --- /dev/null +++ b/templates/web/default/email_sent.html @@ -0,0 +1,34 @@ +[% INCLUDE 'header.html', title => loc('Create a report') %] + +[% + messages = { + problem => { + action => loc('your problem will not be posted'), + worry => loc("we'll hang on to your problem report while you're checking your email."), + }, + update => { + action => loc('your update will not be posted'), + worry => loc("we'll hang on to your update while you're checking your email."), + }, + alert => { + action => loc('your alert will not be activated'), + worry => loc("we'll hang on to your alert while you're checking your email."), + }, + tms => { + action => 'your expression of interest will not be registered', + worry => "we'll hang on to your expression of interest while you're checking your email.", + } + } +%] +<h1>Nearly Done! Now check your email...</h1> + +<p>The confirmation email <strong>may</strong> take a few minutes to arrive — <em>please</em> be patient.</p> + +<p>If you use web-based email or have 'junk mail' filters, you may wish to check your bulk/spam mail folders: sometimes, our messages are marked that way.</p> + +<p>You must now click the link in the email we've just sent you — if you do not, [% messages.$email_type.action %].</p> + +<p>(Don't worry — [% messages.$email_type.worry %])</p> + + +[% INCLUDE 'footer.html' %]
\ No newline at end of file diff --git a/templates/web/default/errors/page_not_found.html b/templates/web/default/errors/page_not_found.html new file mode 100644 index 000000000..92ceb3106 --- /dev/null +++ b/templates/web/default/errors/page_not_found.html @@ -0,0 +1,7 @@ +<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN"> +<html><head> +<title>404 Not Found</title> +</head><body> +<h1>Not Found</h1> +<p>The requested URL [% c.req.uri.path %] was not found on this server.</p> +</body></html> diff --git a/templates/web/default/faq/faq-en-gb.html b/templates/web/default/faq/faq-en-gb.html new file mode 100755 index 000000000..cfe028f7a --- /dev/null +++ b/templates/web/default/faq/faq-en-gb.html @@ -0,0 +1,206 @@ +[% INCLUDE 'header.html', title => loc('Frequently Asked Questions') %] + +<h1>Frequently Asked Questions</h1> + <dl> + <dt>What is FixMyStreet?</dt> + <dd>FixMyStreet is a site to help people report, view, +or discuss local problems they’ve found to their local council by +simply locating them on a map. It launched in early February +2007.</dd> + <dt>What sort of problems should I report with FixMyStreet?</dt> + <dd>FixMyStreet is primarily for reporting things which are +<strong>broken or dirty or damaged or dumped, and need fixing, cleaning +or clearing</strong>, such as: + + <ul><li>Abandoned vehicles + <li>Dog Fouling + <li>Flyposting or graffiti + <li>Flytipping or litter + <li>Streetcleaning, such as broken glass in a cycle lane + <li>Unlit lamposts + <li>Potholes + </ul> + </dd> + + <dt>What isn’t FixMyStreet for?</dt> + <dd>FixMyStreet is not a way of getting in touch with your council for all + issues – please use FixMyStreet only for problems such as the above. We + often route problem reports via cleansing services or highways and so using + FixMyStreet for other matters may result in a delay in your report getting + to the right department. <strong>You will need to contact your council + directly for problems such as</strong>: + + <ul><li>Anti-social behaviour + <li>Any urgent or emergency problems + <li>Noise pollution or barking dogs + <li>Fires and smoke/smell pollution + <li>Missing wheelie bins or recycling boxes or missed rubbish collections + <li>Proposals for speed bumps/ CCTV/ pedestrian crossings/ new road layouts/ etc. + <li>Complaining about your neighbours + <li>Complaining about the council + <li>Joy riding, drug taking, animal cruelty, or other criminal activity + </ul> + <p>Councils often have direct hotlines for these sorts of issues.</p> + </dd> + + <dt>How do I use the site?</dt> + <dd>After entering a postcode or location, you are presented +with a map of that area. You can view problems already reported in that area, +or report ones of your own simply by clicking on the map at the location of +the problem.</dd> + <dt>How are the problems solved?</dt> + <dd>They are reported to the relevant council by email. The +council can then resolve the problem the way they normally would. +Alternatively, you can discuss the problem on the website with others, and +then together lobby the council to fix it, or fix it directly yourselves.</dd> + <dt>Is it free?</dt> + <dd>The site is free to use, yes. FixMyStreet is run +by a registered charity, though, so if you want to make a contribution, <a +href="https://secure.mysociety.org/donate/">please do</a>.</dd> + + <dt>Can I use FixMyStreet on my mobile?</dt> + <dd>There are two iPhone apps for FixMyStreet, one written by us in 2008 and + another much more recently by a volunteer, Martin Stephenson. Both are available for + download on the App Store: + <a href="http://itunes.apple.com/gb/app/fixmystreet/id297456545">FixMyStreet</a>, + <a href="http://itunes.apple.com/gb/app/streetreport/id371891859">StreetReport</a>. + There is an Android app written by a volunteer, Anna Powell-Smith, + available from the Android Market. + </dd> + + <dt>Why do you only cover the countries of Great Britain?</dt> + <dd>We would love to cover Northern Ireland, but as we were funded for + FixMyStreet by the Department for Constitutional Affairs (now the Ministry + of Justice), we were covered for Ordnance Survey data (but not OSNI data) + by the Pan-Governmental Agreement. The cost for these maps would be + prohibitively expensive for the small charity that we are – if you know of + any way we could get access to the Ordnance Survey for Northern Ireland's + maps so that we can add them to the site, that'd be great.</dd> + </dl> + + <h2>Practical Questions</h2> + <dl> + <dt>I’m from a council, where do you send the reports?</dt> + <dd>You can either leave a test report or <a href="/contact">contact us</a> +to find out where reports go at the moment. Also <a href="/contact">contact us</a> +to update the address or addresses we use.</dd> + <dt>Do you remove silly or illegal content?</dt> + <dd>FixMyStreet is not responsible for the content and accuracy +of material submitted by its users. We reserve the right to edit or remove any +problems or updates which we consider to be inappropriate upon being informed +by a user of the site.</dd> + <dt>Why does the site use kilometres for measurements?</dt> + <dd>Thanks for asking politely – we never quite understand why some of the rudest + emails we receive are on this topic. The British national + grid reference system, devised by Ordnance Survey (the British national + mapping agency) around the time of the second world war, uses eastings and + northings measured in metres and kilometres; the maps we use are from + Ordnance Survey and so this is what we use to display distances. + There you have it: not everything British is in miles!</dd> + + <dt>Why doesn’t dragging the map work on reporting-a-problem pages in Safari or Konqueror?</dt> + <dd>There’s a bug in these two browsers to do with setting images on form +submit buttons, which the map uses when reporting a problem. It’s fixed in the +latest nightly build of Safari, so will presumably be fixed in the next +release. Until then, I’ve sadly had to disable dragging to avoid people +dragging an empty square.</dd> + <dt>Why isn’t there a zoom button on the map?</dt> + <dd>There isn’t a zoom on the map as we want to keep things very local; + this might mean that you’ll need to pan around to figure out where the + problem is if you’re not familiar with the area. If you’re from the + council then the emailed version of the problem report will contain the + closest postal address to the pin on the map.</dd> + + <dt>This site is great – why aren’t you better publicised?</dt> + <dd>As a tiny charity we simply don’t have a publicity budget, and we + rely on word of mouth to advertise the site. We have a whole <a + href="posters/">array of posters, flyers and badges</a> if you’d like + to publicise us on the web or in your local area, and why not write to your + local paper to let them know about us?</dd> </dl> + + <h2><a name="privacy"></a>Privacy Questions</h2> + <dl> + <dt>Who gets to see my email address?</dt> + <dd>If you submit a problem, we pass on your details, and details +of the problem, to the council contact or contacts responsible for the +area where you located the problem. Other than the council, who obviously get your +email address, only people we authorise to view the FixMyStreet administration interface +will be able to see your email address and they will never use it for anything other than +to help administer FixMyStreet. Similarly with email addresses from updates. We will never give or sell your email address to anyone else, +unless we are obliged to by law. Your name will not be published anywhere unless you let us.</dd> + <dt>Will you send nasty, brutish spam to my email address?</dt> + <dd>Never. We will email you if someone leaves an update on a +problem you’ve reported, and send you a questionnaire email four weeks +after you submit a problem, asking for a status update; we’ll only ever +send you emails in relation to your problem.</dd> + <dt>What's this about the Guardian?</dt> + <dd>mySociety and the Guardian are working together to provide local versions of +FixMyStreet in Leeds, Edinburgh and Cardiff as part of the Guardian Local project. If you submit a problem or +provide an update in one of those cities, administrators from both mySociety and the Guardian will be able to see your +details. They will never use them for anything other than to help administer FixMyStreet, in accordance with this privacy +policy, and the Guardian's <a href="http://users.guardian.co.uk/help/article/0,,933905,00.html">privacy policy</a>. + </dd> + </dl> + <h2>Organisation Questions</h2> + <dl> + <dt>Who built FixMyStreet?</dt> + <dd>This site was built by <a href="http://www.mysociety.org/">mySociety</a>, in conjunction with the <a href="http://www.youngfoundation.org.uk/">Young Foundation</a>. +mySociety is the project of a registered charity which has grown out of the community of +volunteers who built sites like <a href="http://www.theyworkforyou.com/">TheyWorkForYou.com</a>. +mySociety’s primary mission is to build Internet projects which give people simple, tangible +benefits in the civic and community aspects of their lives. Our first project +was <a href="http://www.writetothem.com/">WriteToThem</a>, where you can write to any of your +elected representatives, for free. The charity is called UK Citizens Online Democracy and is charity number 1076346. mySociety +can be contacted by email at <a href="mailto:hello@mysociety.org">hello@mysociety.org</a>, +or by post at:<br> +mySociety<br> +PO Box 839<br> +Oxford<br> +OX1 9LG<br> +UK</dd> + <dt><img src="/i/moj.png" align="right" alt="Ministry of Justice" hspace="10">Who pays for it?</dt> + <dd>FixMyStreet was paid for via the Department for +Constitutional Affairs Innovations Fund.</dd> + <dt><a name="nfi"></a>Wasn’t this site called Neighbourhood Fix-It?</dt> + <dd>Yes, we changed the name mid June 2007. We decided +Neighbourhood Fix-It was a bit of a mouthful, hard to spell, and hard to publicise (does the URL have a dash in it or not?). The domain FixMyStreet became available, and everyone liked the name.</dd> + <dt>Do you need any help with the project?</dt> + <dd>Yes, we can use help in all sorts of ways, technical or +non-technical. Please see our <a +href="http://www.mysociety.org/helpus/">Get Involved page</a>.</dd> + <dt>I’d like a site like this for my own location/ where’s the "source code" to this site?</dt> + <dd> +<p>The software behind this site is open source, and available +to you mainly under the GNU Affero GPL software license. You can <a +href="http://github.com/mysociety/fixmystreet">download the +source code</a> and help us develop it. +You’re welcome to use it in your own projects, although you must also +make available the source code to any such projects.</p> +<p>Some Canadians at VisibleGovernment.ca wrote their own code for <a +href="http://www.fixmystreet.ca/">http://www.fixmystreet.ca/</a> which is +written in GeoDjango and available under an MIT licence at <a +href="http://github.com/visiblegovernment/django-fixmystreet/tree/master">github</a> +– it might well be more suitable for adapting than our code, and +definitely has better installation instructions at present. +</p> +</dd> + <dt>People build things, not organisations. Who <em>actually</em> built it?</dt> + <dd>Matthew Somerville and Francis Irving wrote the site, +Chris Lightfoot wrote the tileserver and map cutter, Richard Pope created +our pins, Deborah Kerr keeps things up-to-date and does user support, +Ayesha Garrett designed our posters, and Tom Steinberg managed it all. + +Thanks also to +<a href="http://www.ordnancesurvey.co.uk">Ordnance Survey</a> (for the maps, +UK postcodes, and UK addresses – data © Crown copyright, all +rights reserved, Ministry of Justice 100037819 2008), +Yahoo! for their BSD-licensed JavaScript libraries, the entire free software +community (this particular project was brought to you by Perl, PostgreSQL, +and the number 161.290) and <a +href="http://www.easynet.net/publicsector/">Easynet</a> (who kindly host all +our servers). + +Let us know if we’ve missed anyone.</dd> + </dl> + +[% INCLUDE 'footer.html' %] diff --git a/templates/web/default/footer.html b/templates/web/default/footer.html new file mode 100644 index 000000000..298a6a41d --- /dev/null +++ b/templates/web/default/footer.html @@ -0,0 +1,27 @@ +</div> +</div> + +<h2 class="v">[% loc('Navigation') %]</h2> +<ul id="navigation"> +<li><a href="/report/new" >[% loc("Report a problem") %]</a></li> +<li><a href="/reports" >[% loc("All reports") %]</a></li> +<li><a href="/alert$params{pc}" >[% loc("Local alerts") %]</a></li> +<li><a href="/faq" >[% loc("Help") %]</a></li> +<li><a href="/contact" >[% loc("Contact") %]</a></li> +</ul> + +[% loc('<a href="http://www.mysociety.org/"><img id="logo" width="133" height="26" src="/i/mysociety-dark.png" alt="View mySociety.org"><span id="logoie"></span></a>') %] + +[% #FIXME - should be handled in NO template override %] +[% IF c.config.COUNTRY == 'NO' %] + [% loc('Built by <a href="http://www.mysociety.org/">mySociety</a> and maintained by <a href="http://www.nuug.no/">NUUG</a>, using some <a href="http://github.com/mysociety/fixmystreet">clever</a> <a href="https://secure.mysociety.org/cvstrac/dir?d=mysociety/services/TilMa">code</a>.') %] +[% ELSE %] + [% loc('Built by <a href="http://www.mysociety.org/">mySociety</a>, using some <a href="http://github.com/mysociety/fixmystreet">clever</a> <a href="https://secure.mysociety.org/cvstrac/dir?d=mysociety/services/TilMa">code</a>.') %] +[% END %] + +[% INCLUDE 'tracking_code.html' %] + +[% INCLUDE 'debug_footer.html' %] + +</body> +</html> diff --git a/templates/web/default/header.html b/templates/web/default/header.html new file mode 100644 index 000000000..ec0a3554b --- /dev/null +++ b/templates/web/default/header.html @@ -0,0 +1,29 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd"> +<html lang="[% lang_code %]"> + <head> + <meta http-equiv="Content-Type" content="text/html; charset=utf-8"> + <script type="text/javascript" src="/yui/utilities.js"></script> + <script type="text/javascript" src="/js.js"></script> + + [% extra_js_verbatim IF extra_js_verbatim %] + + <title>[% title | html %] :: [% c.cobrand.site_title %]</title> + <style type="text/css">@import url("/css/core.css"); @import url("/css/main.css");</style> + <!--[if LT IE 7]> + <style type="text/css">@import url("/css/ie6.css");</style> + <![endif]--> + + [% IF rss %] + <link rel="alternate" type="application/rss+xml" title="[% rss.0 %]" href="[% rss.1 %]"> + [% END %] + + </head> + <body> + + <div id="header"> + <a href="/">[% loc('Fix<span id="my">My</span>Street') %]</a> + </div> + + <div id="wrapper"><div id="content"> + + [% INCLUDE 'debug_header.html' %] diff --git a/templates/web/default/my/my.html b/templates/web/default/my/my.html new file mode 100644 index 000000000..03b180a3a --- /dev/null +++ b/templates/web/default/my/my.html @@ -0,0 +1,18 @@ +[% INCLUDE 'header.html', title => loc('My Reports') %] + +<h1>[% loc('Your Reports') %]</h1> + +[% FOREACH p = c.user.problems %] + [% "<ul>" IF loop.first %] + + <li><a href="[% c.uri_for( '/report', p.id ) %]">[% p.title | html %]</a> ([% loc(p.state) %])</li> + + [% "</ul>" IF loop.last %] +[% END %] + + +[%# FIXME - put in blurb here %] + +<a href="/auth/change_password">change password</a> + +[% INCLUDE 'footer.html' %]
\ No newline at end of file diff --git a/templates/web/default/report/new/all_councils_text.html b/templates/web/default/report/new/all_councils_text.html new file mode 100644 index 000000000..2cd90b213 --- /dev/null +++ b/templates/web/default/report/new/all_councils_text.html @@ -0,0 +1,8 @@ +<p> +[% + tprintf( + loc('All the information you provide here will be sent to <strong>%s</strong>. The subject and details of the problem will be public, plus your name if you give us permission.'), + all_council_names.join( '</strong>' _ loc(' or ') _ '<strong>' ) + ); +%] +</p> diff --git a/templates/web/default/report/new/fill_in_details.html b/templates/web/default/report/new/fill_in_details.html new file mode 100644 index 000000000..c7ed908a8 --- /dev/null +++ b/templates/web/default/report/new/fill_in_details.html @@ -0,0 +1,155 @@ +[% INCLUDE 'header.html', title => loc('Reporting a problem') %] + +[% map_html %] + +<h1>[% loc('Reporting a problem') %]</h1> + +[% + IF report.used_map; + loc('You have located the problem at the point marked with a purple pin on the map. If this is not the correct location, simply click on the map again. '); + END; +%] + +[% IF area_ids_to_list.size == 0 %] + [% INCLUDE 'report/new/no_councils_text.html' %] +[% ELSIF area_ids_to_list.size == all_councils.size %] + [% INCLUDE 'report/new/all_councils_text.html' %] +[% ELSE %] + [% INCLUDE 'report/new/some_councils_text.html' %] +[% END %] + + +[% IF skipped %] + [% loc('Please fill in the form below with details of the problem, and describe the location as precisely as possible in the details box.') %] +[% ELSE %] + [% INCLUDE 'report/new/fill_in_details_text.html' %] +[% END %] + +<input type="hidden" name="latitude" value="[% latitude | html %]"> +<input type="hidden" name="longitude" value="[% longitude | html %]"> + +[% FOREACH error IN errors %] + [% '<ul class="error">' IF loop.first %] + <li>[% error %]</li> + [% '</ul>' IF loop.last %] +[% END %] + +<div id="problem_form"> + +[% INCLUDE 'report/new/form_heading.html' %] + +<div id="fieldset"> + + + + + +[% IF field_errors.council %] + <div class='form-error'>[% field_errors.council %]</div> +[% END %] + +[% IF category_options.size %] + [% IF field_errors.category %] + <div class='form-error'>[% field_errors.category %]</div> + [% END %] + + <div class="form-field"> + <label for="category">[% category_label | html %]</label> + <select name="category"> + [%- FOREACH cat_op IN category_options %] + <option value="[% cat_op | html %]"[% ' selected' IF report.category == cat_op %]>[% cat_op | html %]</option> + [%- END %] + </select> + </div> +[% END %] + +[% IF field_errors.title %] + <div class='form-error'>[% field_errors.title %]</div> +[% END %] + +<div class="form-field"> + <label for="form_title">[% loc('Subject:') %]</label> + <input type="text" value="[% report.title | html %]" name="title" id="form_title" size="25"> +</div> + +[% IF field_errors.detail %] + <div class='form-error'>[% field_errors.detail %]</div> +[% END %] + +<div class="form-field"> + <label for="form_detail">[% loc('Details:') %]</label> + <textarea name="detail" id="form_detail" rows="7" cols="26">[% report.detail | html %]</textarea> +</div> + +[% IF field_errors.photo %] + <div class='form-error'>[% field_errors.photo %]</div> +[% END %] + +<div class='form-field'> +[% IF upload_fileid || report.photo %] + <p>[% loc('You have already attached a photo to this report, attaching another one will replace it.') %]</p> + [% IF upload_fileid %] + <input type="hidden" name="upload_fileid" value="[% upload_fileid %]" /> + [% END %] + [% IF report.photo %] + <img align="right" src="/photo?id=[% report.id %]" hspace="5"> + [% END %] +[% END %] + + <label for="form_photo">[% loc('Photo:') %]</label> + <input type="file" name="photo" id="form_photo" > +</div> + + +[% IF field_errors.name %] + <div class='form-error'>[% field_errors.name %]</div> +[% END %] + +<div class='form-field'> + <label for="form_name">[% loc('Name:') %]</label> + <input type="text" value="[% report.name | html %]" name="name" id="form_name" size="25"> +</div> + + +<div class="checkbox"> + + [%# if there is nothing in the name field then set check box as default on form %] + <input type="checkbox" name="may_show_name" id="form_may_show_name" value="1"[% ' checked' IF !report.anonymous || !report.name %]> + + <!-- FIXME - empythomes should be 'Can we show your name on the site?'--> + <label for="form_may_show_name">[% loc('Can we show your name publicly?') %]</label> + <small>[% loc('(we never show your email address or phone number)') %]</small> +</div> + +[% IF field_errors.email %] + <div class='form-error'>[% field_errors.email %]</div> +[% END %] + +<div class="form-field"> + <label for="form_email">[% loc('Email:') %]</label> + <input type="text" value="[% report_user.email | html %]" name="email" id="form_email" size="25"> +</div> + +<div> + <label for="form_phone">[% loc('Phone:') %]</label> + <input type="text" value="[% report_user.phone | html %]" name="phone" id="form_phone" size="15"> + <small>[% loc('(optional)') %]</small> +</div> + +[% INCLUDE 'report/new/notes.html' %] + +[% IF partial_token %] + <input type="hidden" name="partial" value="[% partial_token.token %]"> +[% END %] + +<p id="problem_submit"> + <input type="hidden" name="submit_problem" value="1"> + <input type="submit" value="[% loc('Submit') %]"> +</p> + +</div> +</div> + +[% map_end %] + +[% INCLUDE 'footer.html' %]
\ No newline at end of file diff --git a/templates/web/default/report/new/fill_in_details_text.html b/templates/web/default/report/new/fill_in_details_text.html new file mode 100644 index 000000000..44c60ed6e --- /dev/null +++ b/templates/web/default/report/new/fill_in_details_text.html @@ -0,0 +1,10 @@ +[% + IF details != 'none'; + loc('Please fill in details of the problem below. The council won\'t be able +to help unless you leave as much detail as you can, so please describe the exact location of +the problem (e.g. on a wall), what it is, how long it has been there, a description (and a +photo of the problem if you have one), etc.'); + ELSE; + loc('Please fill in details of the problem below.'); + END; +%] diff --git a/templates/web/default/report/new/form_heading.html b/templates/web/default/report/new/form_heading.html new file mode 100644 index 000000000..e69de29bb --- /dev/null +++ b/templates/web/default/report/new/form_heading.html diff --git a/templates/web/default/report/new/no_councils_text.html b/templates/web/default/report/new/no_councils_text.html new file mode 100644 index 000000000..c3dade610 --- /dev/null +++ b/templates/web/default/report/new/no_councils_text.html @@ -0,0 +1,20 @@ + + +<p>[% + + nget( + 'We do not yet have details for the council that covers this location.', + 'We do not yet have details for the councils that cover this location.', + all_councils.size + ); + + loc("If you submit a problem here the subject and details of the problem will be public, but the problem will <strong>not</strong> be reported to the council."); + + tprintf( + loc("You can help us by finding a contact email address for local problems for %s and emailing it to us at <a href='mailto:%s'>%s</a>."), + all_council_names.join( loc(' or ') ), + c.cobrand.contact_email, + c.cobrand.contact_email + ); + +%]</p> diff --git a/templates/web/default/report/new/notes.html b/templates/web/default/report/new/notes.html new file mode 100644 index 000000000..44d1b5d83 --- /dev/null +++ b/templates/web/default/report/new/notes.html @@ -0,0 +1,15 @@ +<p>[% loc("Please note:") %]</p> + +<ul> + + <li>[% loc("We will only use your personal information in accordance with our <a href=\"/faq#privacy\">privacy policy.</a>") %]</li> + <li>[% loc("Please be polite, concise and to the point.") %]</li> + <li>[% loc("Please do not be abusive — abusing your council devalues the service for all users.") %]</li> + <li>[% loc("Writing your message entirely in block capitals makes it hard to read, as does a lack of punctuation.") %]</li> + <li>[% loc("Remember that FixMyStreet is primarily for reporting physical problems that can be fixed. If your problem is not appropriate for submission via this site remember that you can contact your council directly using their own website.") %]</li> + + [% IF c.config.COUNTRY == 'GB' %] + <li>[% loc("FixMyStreet and the Guardian are providing this service in partnership in <a href=\"/faq#privacy\">certain cities</a>. In those cities, both have access to any information submitted, including names and email addresses, and will use it only to ensure the smooth running of the service, in accordance with their privacy policies.") %]</li> + [% END %] + +</ul> diff --git a/templates/web/default/report/new/report_import.html b/templates/web/default/report/new/report_import.html new file mode 100644 index 000000000..7aa105afe --- /dev/null +++ b/templates/web/default/report/new/report_import.html @@ -0,0 +1,92 @@ +[% INCLUDE 'header.html', title => 'External import' %] + +<h1>External import</h1> + +<p>You may inject problem reports into FixMyStreet programatically using this +simple interface. Upon receipt, an email will be sent to the address given, +with a link the user must click in order to check the details of their report, +add any other information they wish, and then submit to the council. + +<p>This interface returns a plain text response; either <samp>SUCCESS</samp> if +the report has been successfully received, or if not, a list of errors, one per +line each starting with <samp>ERROR:</samp>. + +<p>You may submit the following information by POST to this URL +(i.e. <samp>[% c.uri_for('/import') %]</samp> ):</p> + +<style type="text/css" media="screen"> + input { + /* Hide the form elements - they are just here for simpler testing */ + display: none; + } +</style> + +<form method="POST" action="/import" enctype="multipart/form-data"> + +<dl> + <dt>service</dt> + <dd> + <em>Required</em>. + Name of application/service using this interface. + <input type="text" name="service" /> + </dd> + + <dt>id</dt> + <dd> + Unique ID of a user/device, for possible future use.<br> + <small>(e.g. used by Flickr import to know which accounts to look at)</small> + <input type="text" name="id" /> + </dd> + + <dt>subject</dt> + <dd> + <em>Required</em>. Subject of problem report. + <input type="text" name="subject" /> + </dd> + + <dt>detail</dt> + <dd> + Main body and details of problem report. + <input type="text" name="detail" /> + </dd> + + <dt>name</dt> + <dd> + <em>Required</em>. Name of problem reporter. + <input type="text" name="name" /> + </dd> + + <dt>email</dt> + <dd> + <em>Required</em>. Email address of problem reporter. + <input type="text" name="email" /> + </dd> + + <dt>phone</dt> + <dd> + Telephone number of problem reporter. + <input type="text" name="phone" /> + </dd> + + <dt>easting / northing</dt> + <dt>lat / lon</dt> + <dd> + Location of problem report. You can either supply eastings/northings, or WGS84 latitude/longitude. + <input type="text" name="easting" /> + <input type="text" name="northing" /> + <input type="text" name="lat" /> + <input type="text" name="lon" /> + </dd> + + <dt>photo</dt> + <dd> + Photo of problem (JPEG only). + <input type="file" name="photo" /> + </dd> +</dl> + +<input type="submit" /> + +</form> + +[% INCLUDE 'footer.html' %]
\ No newline at end of file diff --git a/templates/web/default/report/new/report_new.html b/templates/web/default/report/new/report_new.html new file mode 100644 index 000000000..7a7b9bdaf --- /dev/null +++ b/templates/web/default/report/new/report_new.html @@ -0,0 +1,50 @@ +[% INCLUDE 'header.html', title => loc('Reporting a problem') %] + +<h1>[% loc('Reporting a problem') %]</h1> + +[% IF location_error %] + <div class="error">[% location_error %]</div> +[% END %] + +[% IF partial_token %] + + <p style="margin-top: 0; color: #cc0000;"> + <img align="right" src="/photo?id=[% report.id %]" hspace="5"> + [% loc("Thanks for uploading your photo. We now need to locate your problem, so please enter a nearby street name or postcode in the box below :") %] + </p> + + <input type="hidden" name="partial" value="[% partial_token.token %]"> + +[% ELSE %] + Please select where to create this report: +[% END %] + +<form action="/report/new" method="POST"> + + [% IF pc_error %] + <div class='form-error'>[% pc_error %]</div> + [% END %] + + <div class="form-field"> + <label for="pc">Location:</label> + <input type="text" name="pc" value="[% pc %]"> + </div> + + <p> + <input type="hidden" name="partial" value="[% partial_token.token %]"> + <input type="submit" value="[% loc('Search') %]"> + </p> + + +</form> + +[% IF possible_location_matches %] + <p>[% loc('We found more than one match for that location. We show up to ten matches, please try a different search if yours is not here.') %]</p> + <ul class="pc_alternatives"> + [% FOREACH match IN possible_location_matches %] + <li><a href="[% c.uri_for( '', { pc => match }) %]">[% match | html %]</a></li> + [% END %] + </ul> +[% END %] + +[% INCLUDE 'footer.html' %]
\ No newline at end of file diff --git a/templates/web/default/report/new/some_councils_text.html b/templates/web/default/report/new/some_councils_text.html new file mode 100644 index 000000000..7de7c3f45 --- /dev/null +++ b/templates/web/default/report/new/some_councils_text.html @@ -0,0 +1,26 @@ +<p> +[% loc('All the information you provide here will be sent to') %] + +[% FOREACH council IN all_council_names %] + [% loc( ' or ') IF ! loop.first %] + <strong>[% council %]</strong> + [%- '.' IF loop.last %] +[% END %] + +[% + loc('The subject and details of the problem will be public, plus your name if you give us permission.'); + + nget( + 'We do <strong>not</strong> yet have details for the other council that covers this location.', + 'We do <strong>not</strong> yet have details for the other councils that cover this location.', + missing_details_councils.size + ); + + tprintf( + loc("You can help us by finding a contact email address for local problems for %s and emailing it to us at <a href='mailto:%s'>%s</a>."), + missing_details_council_names.join( loc(' or ') ), + c.cobrand.contact_email, + c.cobrand.contact_email + ); +%] + diff --git a/templates/web/default/tokens/abuse.html b/templates/web/default/tokens/abuse.html new file mode 100644 index 000000000..d1b952621 --- /dev/null +++ b/templates/web/default/tokens/abuse.html @@ -0,0 +1,7 @@ +[% INCLUDE 'header.html', title => loc('Error') %] + +<h1>[% loc('Error') %]</h1> + +<p>[% loc('Sorry, there has been an error confirming your problem.') %]</p> + +[% INCLUDE 'footer.html' %] diff --git a/templates/web/default/tokens/confirm_problem.html b/templates/web/default/tokens/confirm_problem.html new file mode 100644 index 000000000..23d5f52ee --- /dev/null +++ b/templates/web/default/tokens/confirm_problem.html @@ -0,0 +1,22 @@ +[% INCLUDE 'header.html', title => loc('Confirmation') %] + +<h1>[% loc('Confirmation') %]</h1> + +<p class="confirmed"> +[% + loc('You have successfully confirmed your problem'); + + IF problem.council; + loc(' and <strong>we will now send it to the council</strong>'); + END; + + tprintf( + loc( '. You can <a href="%s">view the problem on this site</a>.' ), + c.cobrand.url( '/report/' _ problem.id ) + ); +%] +</p> + +[% display_crossell_advert( problem.email, problem.name ) %] + +[% INCLUDE 'footer.html' %] diff --git a/templates/web/default/tokens/error.html b/templates/web/default/tokens/error.html new file mode 100644 index 000000000..76e22c119 --- /dev/null +++ b/templates/web/default/tokens/error.html @@ -0,0 +1,9 @@ +[% INCLUDE 'header.html', title => loc('Error') %] + +<h1>[% loc('Error') %]</h1> + +[% contact_url = c.cobrand.url('/contact'); %] + +<p>[% tprintf( loc('Thank you for trying to confirm your update or problem. We seem to have an error ourselves though, so <a href="%s">please let us know what went on</a> and we\'ll look into it.'), contact_url ) %]</p> + +[% INCLUDE 'footer.html' %] diff --git a/templates/web/default/tracking_code.html b/templates/web/default/tracking_code.html new file mode 100644 index 000000000..e5fc13793 --- /dev/null +++ b/templates/web/default/tracking_code.html @@ -0,0 +1,16 @@ +[% IF c.config.BASE_URL == "http://www.fixmystreet.com" %] +<!-- Piwik --> +<script type="text/javascript"> +var pkBaseURL = (("https:" == document.location.protocol) ? "https://piwik.mysociety.org/" : "http://piwik.mysociety.org/"); +document.write(unescape("%3Cscript src='" + pkBaseURL + "piwik.js' type='text/javascript'%3E%3C/script%3E")); +</script><script type="text/javascript"> +try { +var piwikTracker = Piwik.getTracker(pkBaseURL + "piwik.php", 8); +piwikTracker.trackPageView(); +piwikTracker.enableLinkTracking(); +} catch( err ) {} +</script><noscript><p><img src="http://piwik.mysociety.org/piwik.php?idsite=8" style="border:0" alt=""/></p></noscript> +<!-- End Piwik Tag --> +[% ELSE %] +<!-- Tracking code not inserted as "[% c.config.BASE_URL %]" not "http://www.fixmystreet.com" --> +[% END %] diff --git a/templates/web/emptyhomes/about/about.html b/templates/web/emptyhomes/about/about.html new file mode 100644 index 000000000..880f69b98 --- /dev/null +++ b/templates/web/emptyhomes/about/about.html @@ -0,0 +1,43 @@ +[% INCLUDE 'header.html', title => loc('About us') %] + +<h1>[% loc('About us') %]</h1> + +<div style="float: left; width: 48%;"> + + <h2>[% loc('The Empty Homes Agency') %]</h2> + + <p>[% loc('The Empty Homes agency is an independent campaigning charity. We + are not part of government, and have no formal links with local councils + although we work in cooperation with both. We exist to highlight the waste + of empty property and work with others to devise and promote sustainable + solutions to bring empty property back into use. We are based in London but + work across England. We also work in partnership with other charities across + the UK.') %]</p> + +</div> + +<div style="float: right; width:48%;"> + + <h2>[% loc('Shelter Cymru') %]</h2> + + <p>[% loc('Shelter Cymru is Wales’ people and homes charity and wants + everyone in Wales to have a decent home. We believe a home is a fundamental + right and essential to the health and well-being of people and communities. + We work for people in housing need. We have offices all over Wales and + prevent people from losing their homes by offering free, confidential and + independent advice. When necessary we constructively challenge on behalf of + people to ensure they are properly assisted and to improve practice and + learning. We believe that bringing empty homes back into use can make a + significant contribution to the supply of affordable homes in Wales.') %] + + <a href="http://www.sheltercymru.org.uk/shelter/advice/pdetail.asp?cat=20"> + [% loc('Further information about our work on empty homes.') %] + </a> + + </p> + +</div> + +<br clear="both"> + +[% INCLUDE 'footer.html' %]
\ No newline at end of file diff --git a/templates/web/emptyhomes/faq/faq-cy.html b/templates/web/emptyhomes/faq/faq-cy.html new file mode 100644 index 000000000..726ca0ad6 --- /dev/null +++ b/templates/web/emptyhomes/faq/faq-cy.html @@ -0,0 +1,63 @@ +[% INCLUDE 'header.html', title => loc('Frequently Asked Questions') %] + +<h1>Cwestiynau Cyffredin</h1> + +<dl> +<dt>Beth yw diben y safle hwn?</dt> +<dd>Diben y safle hwn yw ei gwneud mor hawdd â phosibl i chi gael tai gwag yn eich ardal yn ôl mewn defnydd. Mae’n caniatáu i chi weld adroddiadau am dai gwag a gweld beth sydd wedi cael ei wneud yn eu cylch. Mae’n gwneud cynghorau’n atebol am ymateb i’r tai gwag rydych chi’n rhoi gwybod amdanynt, ac am ddelio â nhw.</dd> +<dt>Sut ydw i’n defnyddio’r safle?</dt> +<dd>Rhowch god post neu gyfeiriad yn y blwch ar y dudalen hafan ac fe gyflwynir map o’r ardal honno i chi. Cliciwch ar y man lle mae’r eiddo gwag, llenwch y manylion, llwythwch ffotograff i fyny os oes un gennych a phwyswch anfon. A dyna’r cyfan. Gallwch hefyd weld adroddiadau am eiddo gwag eraill a gweld beth wnaed amdanyn nhw.</dd> +<dt>A yw’r gwasanaeth ar gael am ddim?</dt> +<dd>Ydy. Talwyd am gostau datblygu a chynnal y safle hwn gan yr Asiantaeth Tai Gwag a Shelter Cymru drwy haelioni eu cyllidwyr. Mae'r Asiantaeth Tai Gwag a Shelter Cymru yn elusennau cofrestredig, felly os ydych yn credu yn ein nodau a hoffech gyfrannu, mae croeso i chi wneud hynny. +<a href="http://www.emptyhomes.com/donate.html">Asiantaeth Tai Gwag</a> +/ <a href="http://www.sheltercymru.org.uk/shelter/cymraeg/howtohelp/ood.asp">Shelter Cymru</a>.</dd> + +<dt>Ydych chi’n cael gwared ar gynnwys gwirion neu anghyfreithlon?</dt> +<dd>Rydym yn cadw’r hawl i ddileu unrhyw adroddiadau neu ddiweddariadau yr ydym yn eu hystyried yn amhriodol.</dd> +<dt>Sut mae cynghorau’n dod ag eiddo gwag yn ôl mewn defnydd?</dt> +<dd><p>Mae gan bob cyngor yng Nghymru a Lloegr bwerau i ddod â thai gwag yn ôl mewn defnydd. Mae llawer ohonynt yn dda iawn wrth wneud hynny, nid yw rhai eraill. Mae’r rhan fwyaf o gynghorau’n ceisio helpu a dwyn perswâd ar y perchennog i ddod â’u heiddo yn ôl mewn defnydd; dim ond pan fydd help a pherswâd wedi methu y byddant yn defnyddio pwerau cyfreithiol fel Gorchmynion Rheoli Anheddau Gwag.</p> <p> +Mae’r rhan fwyaf o eiddo gwag yn cael eu dwyn yn ôl mewn defnydd ymhen hir a hwyr gan eu perchennog. Fodd bynnag, mewn achosion niferus, mae hyn yn cymryd blynyddoedd. Yn aml, bydd eiddo gwag yn dirywio’n gyflym – bydd chwyn yn eu goresgyn a bydd y tywydd yn ymosod arnynt. Maent yn aml yn cael eu defnyddio gan sgwatwyr, pobl sy’n tipio’n anghyfreithlon, fandaliaid ac weithiau cânt eu rhoi ar dân yn fwriadol. Mae’r gymdogaeth gyfan yn dioddef wrth aros i’r perchennog ddelio â’i eiddo.</p> <p> +Mae cynghorau’n helpu ac yn dwyn perswâd ar berchenogion i adfer eu heiddo i’w defnyddio yn gyflymach. +Hyd yn oed wedyn, gall y broses fod yn araf, yn enwedig os yw’r eiddo mewn cyflwr gwael iawn neu os yw’r perchennog yn amharod i wneud unrhyw beth. Yn y rhan fwyaf o achosion, bydd chwe mis yn mynd heibio cyn y gallwch ddisgwyl gweld unrhyw beth yn newid, weithiau hwy. Nid yw hyn yn golygu nad yw’r cyngor yn gwneud unrhyw beth, a dyma pam rydym ni’n annog y cyngor i ddiweddaru’r wefan fel y gallwch weld beth sy’n digwydd.</p> <p> +Byddwn yn cysylltu â chi ddwywaith (mis a chwe mis ar ôl i chi roi gwybod am yr eiddo gwag), fel y gallwch ddweud wrthym beth sydd wedi digwydd. Os nad yw’r cyngor yn gwneud unrhyw beth, neu os ydych chi’n meddwl bod eu hymateb yn annigonol, byddwn yn rhoi cyngor i chi ar beth i’w wneud nesaf.</p> <p> +Os taw’r llywodraeth neu un o’i hasiantaethau sy’n berchen ar yr eiddo gwag, nid oes gan gynghorau unrhyw bŵer i helpu’n aml. Fodd bynnag, mae’n bosibl y byddwch yn gallu gweithredu’ch hunan yn uniongyrchol gan ddefnyddio PROD: +<a href="http://www.emptyhomes.com/usefulinformation/policy_docs/prods.html">http://www.emptyhomes.com/usefulinformation/policy_docs/prods.html</a> +</dd> + <dt>A fydd adrodd am eiddo gwag yn gwneud unrhyw wahaniaeth?</dt> + <dd><p>Bydd. Gall cynghorau wneud gwahaniaeth gwirioneddol, ond mae ganddynt lawer o bethau i’w gwneud. Bydd llawer o gynghorau ddim ond yn delio ag eiddo gwag sydd wedi cael eu hysbysu iddyn nhw. Os nad yw pobl yn rhoi gwybod am eiddo gwag, mae’n bosibl iawn y daw cynghorau i’r casgliad bod meysydd gwaith eraill yn fwy pwysig.</p> <p> + Mae dros 840,000 o dai gwag yn y DU. Mae’r Asiantaeth Tai Gwag yn amcangyfrif bod dros hanner y rhain yn wag heb angen. Effaith hyn yw gostwng sylweddol yn y stoc tai sydd ar gael, gan fwydo argyfwng tai’r DU. Sgil-effaith y gwastraff hwn yw bod llawer mwy o bwysau’n cael ei roi ar dir adeiladau gan fod mwy o dai’n cael eu hadeiladu i ateb y diffyg. Mae’r Asiantaeth Tai Gwag yn amcangyfrif y byddai dod â dim ond chwarter tai gwag y DU yn ôl mewn defnydd yn rhoi cartrefi i 700,000 o bobl, yn arbed 160 cilometr sgwâr o dir ac yn arbed 10 miliwn tunnell fetrig o CO<sub>2</sub> dros adeiladu’r un nifer o dai newydd. + </dt> + </dl> + <h2>Cwestiynau Preifatrwydd </h2> + <dl> + <dt>Pwy sy’n cael gweld fy nghyfeiriad e-bost?</dt> + <dd>Os gwnaethoch gyflwyno eiddo gwag, wrth reswm, mae eich manylion yn cael eu darparu i ni. + Bydd eich enw’n cael ei arddangos ar y safle os ydych yn caniatáu i ni wneud hynny, ond nid eich cyfeiriad e-bost; + felly y mae hi gyda diweddariadau. Ni fyddwn byth yn rhoi nac yn gwerthu eich cyfeiriad e-bost i unrhyw un arall, oni bai ein bod ni’n gorfod gwneud hynny yn ôl y gyfraith.</dd> + <dt>A fyddwch chi’n anfon negeseuon sbam budr, bwystfilaidd at fy nghyfeiriad e-bost?</dt> + <dd>Byth. Byddwn yn anfon neges e-bost atoch os yw rhywun yn gadael diweddariad ar adroddiad a wnaed gennych, ac yn anfon holiaduron e-bost atoch chi bedair wythnos a chwe mis wedi i chi gyflwyno problem yn gofyn am ddiweddariad am ei statws; dim ond ynghylch eich problem y byddwn yn anfon negeseuon e-bost atoch chi.</dd> + </dl> + <h2>Cwestiynau am y Sefydliad </h2> + <dl> + <dt>Pwy adeiladodd y safle hwn?</dt> + <dd>Adeiladwyd y safle hwn gan <a href="http://www.mysociety.org/">mySociety</a>. + Mae mySociety yn brosiect elusen gofrestredig sydd wedi tyfu o gymuned o wirfoddolwyr a wnaeth adeiladu safleoedd fel <a href="http://www.theyworkforyou.com/">TheyWorkForYou</a>. + Prif genhadaeth mySociety yw adeiladu prosiectau ar y Rhyngrwyd sy’n cynnig manteision syml, dirnadwy i bobl yn yr agweddau dinesig a chymunedol ar eu bywydau. Ein prosiect cyntaf oedd <a href="http://www.writetothem.com/">WriteToThem</a>, lle gallwch ysgrifennu at eich cynrychiolwyr etholedig, am ddim. + <a href="https://secure.mysociety.org/donate/">Cyfrannu at mySociety</a></dd> + <dt>Lle mae’r "cod gwreiddiol" i’r safle hwn?</dt> + <dd>Y meddalwedd wrth gefn y safle hwn yw cod agored, ac mae ar gael i chi yn bennaf o dan drwydded meddalwedd GNU Affero GPL. Gallwch <a + href="http://github.com/mysociety/fixmystreet"> lawrlwytho’r cod gwreiddiol</a> a’n helpu ni i’w ddatblygu. + Mae croeso i chi hefyd ei ddefnyddio yn eich prosiectau eich hunan, er bod rhaid i chi ryddhau’r cod gwreiddiol i unrhyw brosiectau o’r fath.</dd> + <dt>Pobl sy’n adeiladu pethau, nid sefydliadau. Pwy wnaeth ei adeiladu <em>go iawn</em>?</dt> + <dd>Ysgrifennwyd yr addasiad hwn o <a href="http://www.fixmystreet.com/">Fix­MyStreet</a> + gan Matthew Somerville. Diolch i’r + <a href="http://www.ordnancesurvey.co.uk">Arolwg Ordnans</a> (am y mapiau, + codau post y DU a chyfeiriadau’r DU – data © Hawlfraint y Goron, cedwir pob hawl + , Y Weinyddiaeth Gyfiawnder 100037819 2008), + Yahoo! am eu llyfrgelloedd JavaScript wedi’u trwyddedu gan BSD, y gymuned meddalwedd am ddim gyfan (daethpwyd â’r prosiect arbennig hwn i chi gan Perl, PostgreSQL, + a’r rhif 161.290) ac <a + href="http://www.easynet.net/publicsector/">Easynet</a> (sydd mor garedig â gwesteia’n holl weinyddion). + + Rhowch wybod i ni os ydym wedi hepgor unrhyw un.</dd> + +[% INCLUDE 'footer.html' %] diff --git a/templates/web/emptyhomes/faq/faq-en-gb.html b/templates/web/emptyhomes/faq/faq-en-gb.html new file mode 100755 index 000000000..9d36634cd --- /dev/null +++ b/templates/web/emptyhomes/faq/faq-en-gb.html @@ -0,0 +1,114 @@ +[% INCLUDE 'header.html', title => loc('Frequently Asked Questions') %] + +<h1>Frequently Asked Questions</h1> + <dl> + <dt>What is this site for?</dt> + <dd>This site is to help make it as easy as possible for you to get +empty homes in your area put back into use. It allows you, to view empty homes +that have been reported and see what has been done about them. It makes +councils accountable for responding and dealing with the empty homes you +report.</dd> + <dt>How do I use the site?</dt> + <dd>Enter a postcode or address in the box on the homepage and you +are presented with a map of that area. Click where the empty property is, fill +in the details, upload a photo if you have one and press submit. That’s +it. You can also view other empty properties that have been reported and see +what has been done about them.</dd> + <dt>Is it free?</dt> + <dd>Yes. The costs of developing and running this site are shared +between the Empty Homes Agency and Shelter Cymru through the generosity of +their funders. Both the Empty Homes Agency and Shelter Cymru are registered charities, +so if you believe in their aims and would like to make a contribution, please do: +<a href="http://www.emptyhomes.com/donate.html">Empty Homes Agency</a> +or <a href="http://www.sheltercymru.org.uk/shelter/howtohelp/ood.asp">Shelter Cymru</a>.</dd> + <dt>Do you remove silly or illegal content?</dt> + <dd>We reserve the right to remove any reports or updates +which we consider to be inappropriate.</dd> + <dt>How do councils bring empty properties back into use?</dt> + <dd><p>All councils in England and Wales have powers to bring empty +homes back into use. Many are very good at it, some are not. Most councils seek +to persuade and help the owner to bring their property back into use; they only +use legal powers such as Empty Dwelling Management Orders when help and +persuasion have failed.</p> <p> +Most empty homes are brought back into use eventually by their owner. But in +many cases this takes years. Empty homes often decline fast – they become +overrun with weeds and attacked by the weather. They are often used by +squatters, fly tippers, vandals and are sometimes subject to arson. The whole +neighbourhood suffers waiting for the owner to deal with their property.</p> <p> +Councils help and persuade owners to bring their properties into use faster. +Even so the process can be slow, especially if the property is in very poor +repair or the owner is unwilling to do anything. In most cases it takes six +months before you can expect to see anything change, occasionally longer. This +doesn’t mean the council isn’t doing anything, which is why we encourage +councils to update the website so you can see what is happening.</p> <p> +We will contact you twice (a month and six months after you report the empty +home) so you can tell us what has happened. If the council doesn’t do anything, +or you think their response is inadequate we will advise you what you can do +next.</p> <p> +If the empty home is owned by the government or one its agencies, councils are +often powerless to help. However you might be able to take action directly +yourself using a PROD: +<a href="http://www.emptyhomes.com/usefulinformation/policy_docs/prods.html">http://www.emptyhomes.com/usefulinformation/policy_docs/prods.html</a> +</dd> + <dt>Will reporting an empty home make any difference?</dt> + <dd><p>Yes. Councils can make a real difference, but they have lots of +things to do. Many councils only deal with empty homes that are reported to +them. If people do not report empty homes, councils may well conclude that +other areas of work are more important.</p> <p> +There are over 840,000 empty homes in the UK. The Empty Homes Agency estimates +that over half of these are unnecessarily empty. The effect of this is to +significantly reduce the available housing stock fuelling the UK’s housing +crisis. A by-product of this waste is that far greater pressure is put on +building land as more homes are built to meet the shortfall. The Empty Homes +Agency estimate that bringing just a quarter of the UK’s empty homes into use +would provide homes for 700,000 people, save 160 square kilometres of land and +save 10 million tonnes of CO<sub>2</sub> over building the same number of new homes. +</dt> + </dl> + <h2>Privacy Questions</h2> + <dl> + <dt>Who gets to see my email address?</dt> + <dd>If you submit an empty property, your details are obviously provided to us. +Your name is displayed upon the site if you let us, but not your email address; +similarly with updates. We will never give or sell your email address to +anyone else, unless we are obliged to by law.</dd> + <dt>Will you send nasty, brutish spam to my email address?</dt> + <dd>Never. We will email you if someone leaves an update on a +report you’ve made, and send you questionnaire emails four weeks and six months +after you submit a problem, asking for a status update; we’ll only ever +send you emails in relation to your problem.</dd> + </dl> + <h2>Organisation Questions</h2> + <dl> + <dt>Who built this site?</dt> + <dd>This site was built by <a href="http://www.mysociety.org/">mySociety</a>. +mySociety is the project of a registered charity which has grown out of the community of +volunteers who built sites like <a href="http://www.theyworkforyou.com/">TheyWorkForYou</a>. +mySociety’s primary mission is to build Internet projects which give people simple, tangible +benefits in the civic and community aspects of their lives. Our first project +was <a href="http://www.writetothem.com/">WriteToThem</a>, where you can write to any of your +elected representatives, for free. +<a href="https://secure.mysociety.org/donate/">Donate to mySociety</a></dd> + <dt>Where’s the "source code" to this site?</dt> + <dd>The software behind this site is open source, and available +to you mainly under the GNU Affero GPL software license. You can <a +href="http://github.com/mysociety/fixmystreet">download the +source code</a> and help us develop it. +You’re welcome to use it in your own projects, although you must also +make available the source code to any such projects.</dd> + <dt>People build things, not organisations. Who <em>actually</em> built it?</dt> + <dd>This adaptation of <a href="http://www.fixmystreet.com/">Fix­MyStreet</a> +was written by Matthew Somerville. Thanks go to +<a href="http://www.ordnancesurvey.co.uk">Ordnance Survey</a> (for the maps, +UK postcodes, and UK addresses – data © Crown copyright, all +rights reserved, Ministry of Justice 100037819 2008), +Yahoo! for their BSD-licensed JavaScript libraries, the entire free software +community (this particular project was brought to you by Perl, PostgreSQL, +and the number 161.290) and <a +href="http://www.easynet.net/publicsector/">Easynet</a> (who kindly host all +our servers). + +Let us know if we’ve missed anyone.</dd> + </dl> + +[% INCLUDE 'footer.html' %] diff --git a/templates/web/emptyhomes/footer.html b/templates/web/emptyhomes/footer.html new file mode 100644 index 000000000..07973881d --- /dev/null +++ b/templates/web/emptyhomes/footer.html @@ -0,0 +1,38 @@ +</div> +</div> + +<div id="footer"> + +<div> +Empty Homes<br> +75 Westminster Bridge Road<br> +London, SE1 7HS +<br> +Tel: 020 7921 4450 <br> +Email: <a href="mailto:info@emptyhomes.com">info@emptyhomes.com</a> +</div> + +<div> +In conjunction with, in Wales:<br> +Shelter Cymru<br> +[% lang_code == 'cy' ? '25 Heol Walter<br>Abertawe' : '25 Walter Road<br>Swansea' %] +<br>SA1 5NN<br> +<a href="mailto:emptyhomes@sheltercymru.org.uk">emptyhomes@sheltercymru.org.uk</a> +</div> + +<div> +In Scotland:<br> +Kristen Miller, Scottish Empty Homes Partnership<br> +Shelter Scotland<br> +6 South Charlotte Street<br> +Edinburgh EH2 4AW<br> +Tel: 0344 515 2461 +</div> + +</div> + +[% INCLUDE 'debug_footer.html' %] + +</body> +</html> + diff --git a/templates/web/emptyhomes/header.html b/templates/web/emptyhomes/header.html new file mode 100644 index 000000000..5e86cb899 --- /dev/null +++ b/templates/web/emptyhomes/header.html @@ -0,0 +1,49 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd"> +<html lang="[% lang_code %]"> +<head> +<title>[% title | html %] :: [% c.cobrand.site_title %]</title> +<meta http-equiv="content-type" content="text/html; charset=utf-8"> +<script type="text/javascript" src="/yui/utilities.js"></script> +<script type="text/javascript" src="/js.js"></script> + +[% extra_js_verbatim IF extra_js_verbatim %] + +<style type="text/css"> +@import "/css/core.css"; +@import "/css/cobrands/emptyhomes/emptyhomes.css"; +</style> +<!--[if LT IE 7]> +<style type="text/css">@import url("/css/ie6.css");</style> +<![endif]--> + +[% IF rss %] + <link rel="alternate" type="application/rss+xml" title="[% rss.0 %]" href="[% rss.1 %]"> +[% END %] + +</head> +<body> + +[% INCLUDE 'debug_header.html' %] + +<div id="header"> +<a href="http://www.emptyhomes.com/"><img border="0" src="/i/eha-logo.jpeg" alt="Empty Homes Agency" width="91" height="71" align="middle"></a> +<a href="http://www.sheltercymru.org.uk/"><img border="0" src="/i/Sheltercymru47.gif" alt="Shelter Cymru" width="114" height="47" align="middle"></a> +</div> + +<div id="navigation"> + <ul> + <li><a href="/report/new" >[% loc("Report a problem") %]</a></li> + <li><a href="/reports" >[% loc("All reports") %]</a></li> + <li><a href="/alert" >[% loc("Local alerts") %]</a></li> + <li><a href="/faq" >[% loc("Help") %]</a></li> + <li><a href="/about" >[% loc('About us') %]</a></li> + [% IF lang_code == 'en-gb' %] + <li><a href="http://cy.[% c.cobrand.base_host %]">Cymraeg</a></li> + [% ELSE %] + <li><a href="http://en.[% c.cobrand.base_host %]">English</a></li> + [% END %] + </ul> +</div> + +<div id="wrapper"> +<div id="content"> diff --git a/templates/web/emptyhomes/report/new/all_councils_text.html b/templates/web/emptyhomes/report/new/all_councils_text.html new file mode 100644 index 000000000..8bdad1c1f --- /dev/null +++ b/templates/web/emptyhomes/report/new/all_councils_text.html @@ -0,0 +1,8 @@ +<p> +[% + tprintf( + loc('All the information you provide here will be sent to <strong>%s</strong>. On the site, we will show the subject and details of the problem, plus your name if you give us permission.'), + all_council_names.join( '</strong>' _ loc(' or ') _ '<strong>' ) + ); +%] +</p> diff --git a/templates/web/emptyhomes/report/new/fill_in_details_text.html b/templates/web/emptyhomes/report/new/fill_in_details_text.html new file mode 100644 index 000000000..b557a9942 --- /dev/null +++ b/templates/web/emptyhomes/report/new/fill_in_details_text.html @@ -0,0 +1,6 @@ +[% loc('Please fill in details of the empty property below, saying what type of +property it is e.g. an empty home, block of flats, office etc. Tell us +something about its condition and any other information you feel is relevant. +There is no need for you to give the exact address. Please be polite, concise +and to the point; writing your message entirely in block capitals makes it hard +to read, as does a lack of punctuation.') %] diff --git a/templates/web/emptyhomes/report/new/form_heading.html b/templates/web/emptyhomes/report/new/form_heading.html new file mode 100644 index 000000000..911804a58 --- /dev/null +++ b/templates/web/emptyhomes/report/new/form_heading.html @@ -0,0 +1 @@ +<h2>[% loc('Empty property details form') %]</h2> diff --git a/templates/web/emptyhomes/report/new/no_councils_text.html b/templates/web/emptyhomes/report/new/no_councils_text.html new file mode 100644 index 000000000..7edb75852 --- /dev/null +++ b/templates/web/emptyhomes/report/new/no_councils_text.html @@ -0,0 +1,6 @@ +<p> +[% + loc('We do not yet have details for the council that covers this location.'); + loc("If you submit a report here it will be left on the site, but not reported to the council – please still leave your report, so that we can show to the council the activity in their area."); +%] +</p> diff --git a/templates/web/emptyhomes/report/new/notes.html b/templates/web/emptyhomes/report/new/notes.html new file mode 100644 index 000000000..d355cc1ba --- /dev/null +++ b/templates/web/emptyhomes/report/new/notes.html @@ -0,0 +1 @@ +[%# This file deliberately left empty - there are no notes for EmptyHomes %]
\ No newline at end of file diff --git a/templates/web/emptyhomes/tokens/confirm_problem.html b/templates/web/emptyhomes/tokens/confirm_problem.html new file mode 100644 index 000000000..c4d246430 --- /dev/null +++ b/templates/web/emptyhomes/tokens/confirm_problem.html @@ -0,0 +1,39 @@ +[% INCLUDE 'header.html', title => loc('Confirmation') %] + +<h1>[% loc('Confirmation') %]</h1> + +[% IF problem.council %] + <p>[% + loc( + 'Thank you for reporting an empty property on ReportEmptyHomes.com. We have emailed the lead officer for empty homes in the council responsible with details, and asked them to do whatever they can to get the empty property back into use as soon as possible.' + ) + %]</p> + + <p>[% + loc( + 'It is worth noting however that the process can sometimes be slow, especially if the property is in very poor repair or the owner is unwilling to act. In most cases it can take six months or more before you can expect to see anything change and sometimes there may be considerable barries to a property being brought back into use. This doesn’t mean the council isn’t doing anything. We encourage councils to update the website so you can see what is happening. It may be a long process, but you reporting your concerns about this property to the council is a valuable first step.' + ) + %]</p> + + <p>[% + loc( + 'We may contact you periodically to ask if anything has changed with the property you reported.' + ) + %]</p> + + <p>[% + loc( + 'Thank you for using ReportEmptyHomes.com. Your action is already helping to resolve the UK’s empty homes crisis.' + ) + %]</p> +[% ELSE %] + <p>[% + loc( 'Thank you for reporting an empty property on ReportEmptyHomes.com.' ) + %]</p> +[% END %] + +<p> + <a href="[% c.uri_for( '/report', problem.id ) | html %]">[% loc('View your report') %]</a>. +</p> + +[% INCLUDE 'footer.html' %] diff --git a/templates/web/emptyhomes/tracking_code.html b/templates/web/emptyhomes/tracking_code.html new file mode 100644 index 000000000..73526d3bd --- /dev/null +++ b/templates/web/emptyhomes/tracking_code.html @@ -0,0 +1,12 @@ +<!-- Piwik --> +<script type="text/javascript"> +var pkBaseURL = (("https:" == document.location.protocol) ? "https://piwik.mysociety.org/" : "http://piwik.mysociety.org/"); +document.write(unescape("%3Cscript src='" + pkBaseURL + "piwik.js' type='text/javascript'%3E%3C/script%3E")); +</script><script type="text/javascript"> +try { +var piwikTracker = Piwik.getTracker(pkBaseURL + "piwik.php", 12); +piwikTracker.trackPageView(); +piwikTracker.enableLinkTracking(); +} catch( err ) {} +</script><noscript><img width=1 height=1 src="http://piwik.mysociety.org/piwik.php?idsite=12" style="border:0" alt=""></noscript> +<!-- End Piwik Tag --> diff --git a/templates/web/fiksgatami/faq/faq-nb.html b/templates/web/fiksgatami/faq/faq-nb.html new file mode 100644 index 000000000..94e5b20d6 --- /dev/null +++ b/templates/web/fiksgatami/faq/faq-nb.html @@ -0,0 +1,3 @@ +[% INCLUDE 'header.html', title => loc('Frequently Asked Questions') %] + +[% INCLUDE 'footer.html' %] diff --git a/templates/website/cobrands/barnet/footer b/templates/website/cobrands/barnet/footer index 40b9adce0..a0dbbb1e3 100644 --- a/templates/website/cobrands/barnet/footer +++ b/templates/website/cobrands/barnet/footer @@ -1,151 +1,151 @@ - </div>
- <br class="cl">
- </div><!-- end content -->
- </div><!-- end wrap -->
- <div id="left-column">
-
-
- <div id="navigation">
- <h2>Main Menu</h2>
- <ul>
- <li class="section"><a href="/">FixMyStreet</a>
- <ul>
- <li class="section">{{ ($ENV{REQUEST_URI} eq '/') ? '<strong>Report a problem</strong>' : '<a href="/">Report a problem</a>' }}</li>
- <li class="section">{{ ($ENV{REQUEST_URI} eq '/reports/Barnet') ? '<strong>All reports</strong>' : '<a href="/reports/Barnet">All reports</a>' }}</li>
- <li class="section">{{ ($ENV{REQUEST_URI} eq '/alert') ? '<strong>Local alerts</strong>' : '<a href="/alert">Local alerts</a>' }}</li>
- <li class="section">{{ ($ENV{REQUEST_URI} eq '/faq') ? '<strong>Help</strong>' : '<a href="/faq">Help</a>' }}</li>
- <li class="section">{{ ($ENV{REQUEST_URI} eq '/contact') ? '<strong>Contact</strong>' : '<a href="/contact">Contact</a>' }}</li>
- </ul>
- </ul>
- </div> <!-- end navigation -->
-
- <div id="online-services">
- <h2>Online Services</h2>
- <ul>
- <li><a href="http://www.barnet.gov.uk/">Barnet Council</a></li>
- </ul>
- <!-- <p class="browse-aloud">Listen to this site using <br><a href="#">Browser Aloud</a></p> -->
- </div> <!-- end online-services -->
-
-<!--
- <div id="useful-links">
- <h2>Useful Links</h2>
- <ul>
- <li><a href="http://www.barnet.gov.uk/">Council homepage</a></li>
- </ul>
- </div>
--->
-
- <div id="contact">
- <h2>Contact</h2>
- <dl>
- <dt>Council Address</dt>
- <dd>
- North London Business Park (NLBP),<br>
- Oakleigh Road South,<br>
- London.<br>
- N11 1NP<br>
- <a href="http://maps.google.co.uk/maps?f=q&hl=en&geocode=&q=N11+1NP+&sll=53.800651,-4.064941&sspn=11.823255,39.550781&ie=UTF8&ll=51.624877,-0.152156&spn=0.024244,0.077248&t=h&z=14">View map of Barnet</a>
- </dd>
- <dt>Phone Number</dt>
- <dd>020 8359 2000</dd>
- <dt>Text Number (SMS)</dt>
- <dd>07781 473279</dd>
- <dt>Fax Number</dt>
- <dd>020 8359 4156</dd>
- <dt>Typetalk</dt>
- <dd>18001 020 8359 2040</dd>
- <dt>Email</dt>
- <dd><a href="mailto:first.contact@barnet.gov.uk">first.contact@barnet.gov.uk</a></dd>
- </dl>
- </div> <!-- end useful-links -->
-
- </div><!-- end left-column -->
-
-
-<br class="cl">
-
- <div id="pre-footer">
-
- <div class="box-left">
-
- <dl>
- <dt>Council Address</dt>
- <dd>
- North London Business Park (NLBP),<br>
- Oakleigh Road South,<br>
- London.<br>
- N11 1NP<br>
- <a href="http://maps.google.co.uk/maps?f=q&hl=en&geocode=&q=N11+1NP+&sll=53.800651,-4.064941&sspn=11.823255,39.550781&ie=UTF8&ll=51.624877,-0.152156&spn=0.024244,0.077248&t=h&z=14">View map of Barnet</a>
- </dd>
- </dl>
- <dl>
- <dt>Phone Number</dt>
- <dd>020 8359 2000</dd>
- <dt>Text Number (SMS)</dt>
- <dd>07781 473279</dd>
- <dt>Fax Number</dt>
- <dd>020 8359 4156</dd>
- </dl>
- <dl>
- <dt>Typetalk</dt>
- <dd>18001 020 8359 2040</dd>
- <dt>Email</dt>
- <dd><a href="mailto:first.contact@barnet.gov.uk">first.contact@barnet.gov.uk</a></dd>
- </dl>
- </div>
- <div class="box-right">
- <!--
- <div class="social-bookmarking">
- <h2>Add this page to your social bookmarks:</h2>
- <ul>
- <li class="facebook"><a href="#">Facebook</a></li>
- <li class="delicious"><a href="#">delicious</a></li>
- <li class="technorati"><a href="#">Technorati</a></li>
- <li class="stumbleupon"><a href="#">StumbleUpon</a></li>
- <li class="google"><a href="#">Google</a></li>
- <li class="digg"><a href="#">Digg</a></li>
- </ul>
- <p>(<a href="#">What's social bookmarking?</a>)</p>
- </div>
- -->
- </div>
-
-<br class="cl">
- </div><!-- end pre-footer -->
-
-
-
-
- <div id="footer">
- <ul>
- <li><a href="http://www.barnet.gov.uk/copyright">Copyright</a></li>
- <li><a href="http://www.barnet.gov.uk/disclaimer">Disclaimer</a></li>
- <li><a href="http://www.barnet.gov.uk/privacy">Privacy Statement</a></li>
- <li><a href="http://www.barnet.gov.uk/website-accessibility">Accessibility Statement</a></li>
- <li><a href="http://www.barnet.gov.uk/atoz">A-Z</a></li>
- <li><a href="http://www.barnet.gov.uk/faq">FAQs</a></li>
- <li><a href="http://www.barnet.gov.uk/contact-us">Contact Us</a></li>
- <li><a href="http://www.barnet.gov.uk/help">Help</a></li>
- <li><a href="http://www.barnet.gov.uk/sitemap">Sitemap</a></li>
- <li><a href="http://www.barnet.gov.uk/what%27s_on">What's On</a></li>
- </ul>
- </div><!-- end footer -->
-
- </div><!-- end iewrap -->
-
-<!-- Piwik -->
-<script type="text/javascript">
-var pkBaseURL = (("https:" == document.location.protocol) ? "https://piwik.mysociety.org/" : "http://piwik.mysociety.org/");
-document.write(unescape("%3Cscript src='" + pkBaseURL + "piwik.js' type='text/javascript'%3E%3C/script%3E"));
-</script><script type="text/javascript">
-try {
-var piwikTracker = Piwik.getTracker(pkBaseURL + "piwik.php", 12);
-piwikTracker.trackPageView();
-piwikTracker.enableLinkTracking();
-} catch( err ) {}
-</script><noscript><img width=1 height=1 src="http://piwik.mysociety.org/piwik.php?idsite=12" style="border:0" alt=""></noscript>
-<!-- End Piwik Tag -->
-
- </body>
-</html>
+ </div> + <br class="cl"> + </div><!-- end content --> + </div><!-- end wrap --> + <div id="left-column"> + + + <div id="navigation"> + <h2>Main Menu</h2> + <ul> + <li class="section"><a href="/">FixMyStreet</a> + <ul> + <li class="section">{{ ($ENV{REQUEST_URI} eq '/report/new') ? '<strong>Report a problem</strong>' : '<a href="/report/new">Report a problem</a>' }}</li> + <li class="section">{{ ($ENV{REQUEST_URI} eq '/reports/Barnet') ? '<strong>All reports</strong>' : '<a href="/reports/Barnet">All reports</a>' }}</li> + <li class="section">{{ ($ENV{REQUEST_URI} eq '/alert') ? '<strong>Local alerts</strong>' : '<a href="/alert">Local alerts</a>' }}</li> + <li class="section">{{ ($ENV{REQUEST_URI} eq '/faq') ? '<strong>Help</strong>' : '<a href="/faq">Help</a>' }}</li> + <li class="section">{{ ($ENV{REQUEST_URI} eq '/contact') ? '<strong>Contact</strong>' : '<a href="/contact">Contact</a>' }}</li> + </ul> + </ul> + </div> <!-- end navigation --> + + <div id="online-services"> + <h2>Online Services</h2> + <ul> + <li><a href="http://www.barnet.gov.uk/">Barnet Council</a></li> + </ul> + <!-- <p class="browse-aloud">Listen to this site using <br><a href="#">Browser Aloud</a></p> --> + </div> <!-- end online-services --> + +<!-- + <div id="useful-links"> + <h2>Useful Links</h2> + <ul> + <li><a href="http://www.barnet.gov.uk/">Council homepage</a></li> + </ul> + </div> +--> + + <div id="contact"> + <h2>Contact</h2> + <dl> + <dt>Council Address</dt> + <dd> + North London Business Park (NLBP),<br> + Oakleigh Road South,<br> + London.<br> + N11 1NP<br> + <a href="http://maps.google.co.uk/maps?f=q&hl=en&geocode=&q=N11+1NP+&sll=53.800651,-4.064941&sspn=11.823255,39.550781&ie=UTF8&ll=51.624877,-0.152156&spn=0.024244,0.077248&t=h&z=14">View map of Barnet</a> + </dd> + <dt>Phone Number</dt> + <dd>020 8359 2000</dd> + <dt>Text Number (SMS)</dt> + <dd>07781 473279</dd> + <dt>Fax Number</dt> + <dd>020 8359 4156</dd> + <dt>Typetalk</dt> + <dd>18001 020 8359 2040</dd> + <dt>Email</dt> + <dd><a href="mailto:first.contact@barnet.gov.uk">first.contact@barnet.gov.uk</a></dd> + </dl> + </div> <!-- end useful-links --> + + </div><!-- end left-column --> + + +<br class="cl"> + + <div id="pre-footer"> + + <div class="box-left"> + + <dl> + <dt>Council Address</dt> + <dd> + North London Business Park (NLBP),<br> + Oakleigh Road South,<br> + London.<br> + N11 1NP<br> + <a href="http://maps.google.co.uk/maps?f=q&hl=en&geocode=&q=N11+1NP+&sll=53.800651,-4.064941&sspn=11.823255,39.550781&ie=UTF8&ll=51.624877,-0.152156&spn=0.024244,0.077248&t=h&z=14">View map of Barnet</a> + </dd> + </dl> + <dl> + <dt>Phone Number</dt> + <dd>020 8359 2000</dd> + <dt>Text Number (SMS)</dt> + <dd>07781 473279</dd> + <dt>Fax Number</dt> + <dd>020 8359 4156</dd> + </dl> + <dl> + <dt>Typetalk</dt> + <dd>18001 020 8359 2040</dd> + <dt>Email</dt> + <dd><a href="mailto:first.contact@barnet.gov.uk">first.contact@barnet.gov.uk</a></dd> + </dl> + </div> + <div class="box-right"> + <!-- + <div class="social-bookmarking"> + <h2>Add this page to your social bookmarks:</h2> + <ul> + <li class="facebook"><a href="#">Facebook</a></li> + <li class="delicious"><a href="#">delicious</a></li> + <li class="technorati"><a href="#">Technorati</a></li> + <li class="stumbleupon"><a href="#">StumbleUpon</a></li> + <li class="google"><a href="#">Google</a></li> + <li class="digg"><a href="#">Digg</a></li> + </ul> + <p>(<a href="#">What's social bookmarking?</a>)</p> + </div> + --> + </div> + +<br class="cl"> + </div><!-- end pre-footer --> + + + + + <div id="footer"> + <ul> + <li><a href="http://www.barnet.gov.uk/copyright">Copyright</a></li> + <li><a href="http://www.barnet.gov.uk/disclaimer">Disclaimer</a></li> + <li><a href="http://www.barnet.gov.uk/privacy">Privacy Statement</a></li> + <li><a href="http://www.barnet.gov.uk/website-accessibility">Accessibility Statement</a></li> + <li><a href="http://www.barnet.gov.uk/atoz">A-Z</a></li> + <li><a href="http://www.barnet.gov.uk/faq">FAQs</a></li> + <li><a href="http://www.barnet.gov.uk/contact-us">Contact Us</a></li> + <li><a href="http://www.barnet.gov.uk/help">Help</a></li> + <li><a href="http://www.barnet.gov.uk/sitemap">Sitemap</a></li> + <li><a href="http://www.barnet.gov.uk/what%27s_on">What's On</a></li> + </ul> + </div><!-- end footer --> + + </div><!-- end iewrap --> + +<!-- Piwik --> +<script type="text/javascript"> +var pkBaseURL = (("https:" == document.location.protocol) ? "https://piwik.mysociety.org/" : "http://piwik.mysociety.org/"); +document.write(unescape("%3Cscript src='" + pkBaseURL + "piwik.js' type='text/javascript'%3E%3C/script%3E")); +</script><script type="text/javascript"> +try { +var piwikTracker = Piwik.getTracker(pkBaseURL + "piwik.php", 12); +piwikTracker.trackPageView(); +piwikTracker.enableLinkTracking(); +} catch( err ) {} +</script><noscript><img width=1 height=1 src="http://piwik.mysociety.org/piwik.php?idsite=12" style="border:0" alt=""></noscript> +<!-- End Piwik Tag --> + + </body> +</html> diff --git a/templates/website/scambs-header b/templates/website/scambs-header index 326602de1..3ed09d912 100644 --- a/templates/website/scambs-header +++ b/templates/website/scambs-header @@ -69,7 +69,7 @@ <div id="left"> <div id="leftnav"> <ul> - <li class="first"><a href="/">Report a problem</a> + <li class="first"><a href="/report/new">Report a problem</a> <li class="first">About <li class="first">Recent successes <li class="first">Name and shame diff --git a/urls.txt b/urls.txt new file mode 100644 index 000000000..5c9b25f34 --- /dev/null +++ b/urls.txt @@ -0,0 +1,12 @@ +This is a list of some of the urls currently served: + +homepage: / +postcode search: /?pc=SW1A+1AA +placename: /?pc=Westminster +street (ambiguous): /?pc=St+Margaret+St +street (exact): /?pc=St+Margaret+St%2c+Westminster%2c+London+SW1A+2 + +all reports: /reports +council reports: /reports/Aberdeen +individual report: /report/173526 + diff --git a/web/about.cgi b/web/about.cgi deleted file mode 100755 index 6b0347ecf..000000000 --- a/web/about.cgi +++ /dev/null @@ -1,52 +0,0 @@ -#!/usr/bin/perl -w -I../perllib - -# about.cgi: -# For EHA -# -# Copyright (c) 2008 UK Citizens Online Democracy. All rights reserved. -# Email: matthew@mysociety.org. WWW: http://www.mysociety.org -# -# $Id: about.cgi,v 1.10 2009-08-03 10:45:28 matthew Exp $ - -use strict; -use Standard -db; - -my $lastmodified = (stat $0)[9]; - -# Main code for index.cgi -sub main { - my $q = shift; - print Page::header($q, title=>_('About us')); - if ($q->{site} eq 'emptyhomes') { - print $q->h1(_('About us')); - print '<div style="float: left; width: 48%;">'; - print _(<<ABOUTUS); -<h2>The Empty Homes Agency</h2> -<p>The Empty Homes agency is an independent campaigning charity. We are not -part of government, and have no formal links with local councils although we -work in cooperation with both. We exist to highlight the waste of empty -property and work with others to devise and promote sustainable solutions to -bring empty property back into use. We are based in London but work across -England. We also work in partnership with other charities across the UK.</p> -ABOUTUS - print '</div> <div style="float: right; width:48%;">'; - print _(<<ABOUTUS); -<h2>Shelter Cymru</h2> -Shelter Cymru is Wales’ people and homes charity and wants everyone in Wales to -have a decent home. We believe a home is a fundamental right and essential to -the health and well-being of people and communities. We work for people in -housing need. We have offices all over Wales and prevent people from losing -their homes by offering free, confidential and independent advice. When -necessary we constructively challenge on behalf of people to ensure they are -properly assisted and to improve practice and learning. We believe that -bringing empty homes back into use can make a significant contribution to the -supply of affordable homes in Wales. -<a href="http://www.sheltercymru.org.uk/shelter/advice/pdetail.asp?cat=20">Further information about our work on -empty homes</a>. -ABOUTUS - print '</div>'; - } - print Page::footer($q); -} -Page::do_fastcgi(\&main, $lastmodified); - diff --git a/web/confirm.cgi b/web/confirm.cgi index c4a37c67f..cb9f5d4c8 100755 --- a/web/confirm.cgi +++ b/web/confirm.cgi @@ -27,8 +27,6 @@ sub main { if ($data) { if ($type eq 'update') { $out = confirm_update($q, $data); - } elsif ($type eq 'problem') { - $out = confirm_problem($q, $data); } elsif ($type eq 'questionnaire') { $out = add_questionnaire($q, $data, $token); } @@ -120,72 +118,6 @@ sub confirm_update { return $out; } -sub confirm_problem { - my ($q, $id) = @_; - my $cobrand = Page::get_cobrand($q); - my ($council, $email, $name, $cobrand_data) = dbh()->selectrow_array("select council, email, name, cobrand_data from problem where id=?", {}, $id); - - (my $domain = $email) =~ s/^.*\@//; - if (dbh()->selectrow_array('select email from abuse where lower(email)=? or lower(email)=?', {}, lc($email), lc($domain))) { - dbh()->do("update problem set state='hidden', lastupdate=ms_current_timestamp() where id=?", {}, $id); - return $q->p(_('Sorry, there has been an error confirming your problem.')); - } else { - dbh()->do("update problem set state='confirmed', confirmed=ms_current_timestamp(), lastupdate=ms_current_timestamp() - where id=? and state='unconfirmed'", {}, $id); - } - my $out; - if ($q->{site} eq 'emptyhomes') { - if ($council) { - $out = $q->p(_('Thank you for reporting an empty property on -ReportEmptyHomes.com. We have emailed the lead officer for empty homes in the council -responsible with details, and asked them to do whatever they can to get the -empty property back into use as soon as possible.')) . -$q->p(_('It is worth noting however that the process can sometimes be slow, -especially if the property is in very poor repair or the owner is unwilling to -act. In most cases it can take six months or more before you can expect to see -anything change and sometimes there may be considerable barries to a property -being brought back into use. This doesn’t mean the council isn’t -doing anything. We encourage councils to update the website so you can -see what is happening. It may be a long process, but you reporting your -concerns about this property to the council is a valuable first step.')) . -$q->p(_('We may contact you periodically to ask if anything has changed -with the property you reported.')) . -$q->p(_('Thank you for using ReportEmptyHomes.com. Your action is already helping -to resolve the UK’s empty homes crisis.')) . -$q->p('<a href="/report/' . $id . '">' . _('View your report') . '</a>.'); - } else { - $out = $q->p(_('Thank you for reporting this empty property on ReportEmptyHomes.com. -At present the report cannot be sent through to the council for this area. We -are working with councils to link them into the system so that as many areas -as possible will be covered.')) . -$q->p('<a href="/report/' . $id . '">' . _('View your report') . '</a>.'); - } - } else { - my $report_url = Cobrand::url($cobrand, "/report/$id", $q); - $out = $q->p({class => 'confirmed'}, - _('You have successfully confirmed your problem') - . ($council ? _(' and <strong>we will now send it to the council</strong>') : '') - . sprintf(_('. You can <a href="%s">view the problem on this site</a>.'), $report_url) - ); - my $display_advert = Cobrand::allow_crosssell_adverts($cobrand); - if ($display_advert) { - $out .= CrossSell::display_advert($q, $email, $name); - } - my %vars = ( - url_report => $report_url, - url_home => Cobrand::url($cobrand, '/', $q), - ); - my $cobrand_page = Page::template_include('confirmed-problem', $q, Page::template_root($q), %vars); - $out = $cobrand_page if $cobrand_page; - } - - # Subscribe problem reporter to email updates - my $alert_id = FixMyStreet::Alert::create($email, 'new_updates', $cobrand, $cobrand_data, $id); - FixMyStreet::Alert::confirm($alert_id); - - return $out; -} - sub ask_questionnaire { my ($token, $q) = @_; my $cobrand = Page::get_cobrand($q); diff --git a/web/css/core.css b/web/css/core.css index b31e6bc0a..5b64d67b9 100644 --- a/web/css/core.css +++ b/web/css/core.css @@ -1,3 +1,4 @@ + #mysociety blockquote { border-left: solid 4px #666666; padding-left: 0.5em; @@ -349,6 +350,7 @@ } #mysociety #alert_photos h2 { font-size: 100%; + } #mysociety #alert_photos img { margin-bottom: 0.25em; diff --git a/web/fixmystreet_app_cgi.cgi b/web/fixmystreet_app_cgi.cgi new file mode 100755 index 000000000..7d60ce673 --- /dev/null +++ b/web/fixmystreet_app_cgi.cgi @@ -0,0 +1,35 @@ +#!/usr/bin/env perl + +BEGIN { # set all the paths to the perl code + use FindBin; + require "$FindBin::Bin/../setenv.pl"; +} + +use Catalyst::ScriptRunner; +Catalyst::ScriptRunner->run( 'FixMyStreet::App', 'CGI' ); + +1; + +=head1 NAME + +fixmystreet_app_cgi.pl - Catalyst CGI + +=head1 SYNOPSIS + +See L<Catalyst::Manual> + +=head1 DESCRIPTION + +Run a Catalyst application as a cgi script. + +=head1 AUTHORS + +Catalyst Contributors, see Catalyst.pm + +=head1 COPYRIGHT + +This library is free software. You can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + diff --git a/web/fixmystreet_app_fastcgi.cgi b/web/fixmystreet_app_fastcgi.cgi new file mode 100755 index 000000000..1059cbd34 --- /dev/null +++ b/web/fixmystreet_app_fastcgi.cgi @@ -0,0 +1,53 @@ +#!/usr/bin/env perl + +BEGIN { # set all the paths to the perl code + use FindBin; + require "$FindBin::Bin/../setenv.pl"; +} + +use Catalyst::ScriptRunner; +Catalyst::ScriptRunner->run( 'FixMyStreet::App', 'FastCGI' ); + +1; + +=head1 NAME + +fixmystreet_app_fastcgi.pl - Catalyst FastCGI + +=head1 SYNOPSIS + +fixmystreet_app_fastcgi.pl [options] + + Options: + -? -help display this help and exits + -l --listen Socket path to listen on + (defaults to standard input) + can be HOST:PORT, :PORT or a + filesystem path + -n --nproc specify number of processes to keep + to serve requests (defaults to 1, + requires -listen) + -p --pidfile specify filename for pid file + (requires -listen) + -d --daemon daemonize (requires -listen) + -M --manager specify alternate process manager + (FCGI::ProcManager sub-class) + or empty string to disable + -e --keeperr send error messages to STDOUT, not + to the webserver + --proc_title Set the process title (is possible) + +=head1 DESCRIPTION + +Run a Catalyst application as fastcgi. + +=head1 AUTHORS + +Catalyst Contributors, see Catalyst.pm + +=head1 COPYRIGHT + +This library is free software. You can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/web/index.cgi b/web/index.cgi index 186393f96..14d4177ac 100755 --- a/web/index.cgi +++ b/web/index.cgi @@ -943,11 +943,18 @@ sub display_location { map { Utils::truncate_coordinate($_) } # ( $latitude, $longitude ); - my $url_skip = NewURL($q, -retain=>1, - x => undef, 'y' => undef, - latitude => $short_lat, longitude => $short_lon, - 'submit_map'=>1, skipped=>1 + my $url_skip = NewURL( + $q, + -url => '/report/new', + -retain => 1, + x => undef, + y => undef, + latitude => $short_lat, + longitude => $short_lon, + submit_map => 1, + skipped => 1 ); + my $pc_h = ent($q->param('pc') || ''); my $rss_url; diff --git a/web/xsl.xsl b/web/xsl.xsl index 1aa0eef4b..12a4a93d5 100644 --- a/web/xsl.xsl +++ b/web/xsl.xsl @@ -18,7 +18,7 @@ <h2 class="v">Navigation</h2> <ul id="navigation"> -<li><a href="/">Report a problem</a></li> +<li><a href="/report/new">Report a problem</a></li> <li><a href="/reports">All reports</a></li> <li><a href="/faq">Help</a></li> <li><a href="/contact">Contact</a></li> |
