Catalyst-Model-DBIC-Schema-0.66/ 000755 000766 000024 00000000000 14461412703 016450 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/inc/ 000755 000766 000024 00000000000 14461412703 017221 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/README 000644 000766 000024 00000040150 14461412670 017333 0 ustar 00gknop staff 000000 000000 NAME
Catalyst::Model::DBIC::Schema - DBIx::Class::Schema Model Class
SYNOPSIS
First, prepare your database schema using DBIx::Class, see
Catalyst::Helper::Model::DBIC::Schema for how to generate a
DBIx::Class::Schema from your database using the Helper script, and
DBIx::Class::Schema::Loader::Base.
A typical usage of the helper script would be:
script/myapp_create.pl model FilmDB DBIC::Schema MyApp::Schema::FilmDB \
create=static dbi:mysql:filmdb dbusername dbpass \
quote_names=1
If you are unfamiliar with DBIx::Class, see DBIx::Class::Manual::Intro
first.
These examples assume that you already have a schema called
"MyApp::Schema::FilmDB", which defines some Result classes for tables in
"MyApp::Schema::FilmDB::Result::Actor" and
"MyApp::Schema::FilmDB::Result::Film". Either created by the helper
script (as shown above) or manually.
The helper also creates a Model in "lib/MyApp/Model/FilmDB.pm", if you
already have a schema you can create just the Model using:
script/myapp_create.pl model FilmDB DBIC::Schema MyApp::Schema::FilmDB
dbi:mysql:filmdb dbusername dbpass
The connect_info is optional and will be hardcoded into the Model if
provided. It's better to configure it in your Catalyst config file,
which will also override any hardcoded config, see "connect_info" for
examples.
Now you have a working Model which accesses your separate DBIC Schema.
This can be used/accessed in the normal Catalyst manner, via
"$c->model()":
my $db_model = $c->model('FilmDB'); # a Catalyst::Model
my $dbic = $c->model('FilmDB')->schema; # the actual DBIC object
There is also a shortcut, which returns a DBIx::Class::ResultSet
directly, instead of a Catalyst::Model:
my $rs = $c->model('FilmDB::Actor');
See DBIx::Class::ResultSet to find out more about which methods can be
called on ResultSets.
You can also define your own ResultSet methods to encapsulate the
database/business logic of your applications. These go into, for
example, "lib/MyApp/Schema/FilmDB/ResultSet/Actor.pm". The class must
inherit from DBIx::Class::ResultSet and is automatically loaded.
Then call your methods like any other DBIx::Class::ResultSet method:
$c->model('FilmDB::Actor')->SAG_members
Some examples:
# to access schema methods directly:
$c->model('FilmDB')->schema->source(...);
# to access the source object, resultset, and class:
$c->model('FilmDB')->source(...);
$c->model('FilmDB')->resultset(...);
$c->model('FilmDB')->class(...);
# For resultsets, there's an even quicker shortcut:
$c->model('FilmDB::Actor')
# is the same as $c->model('FilmDB')->resultset('Actor')
# To get the composed schema for making new connections:
my $newconn = $c->model('FilmDB')->composed_schema->connect(...);
# Or the same thing via a convenience shortcut:
my $newconn = $c->model('FilmDB')->connect(...);
# or, if your schema works on different storage drivers:
my $newconn = $c->model('FilmDB')->composed_schema->clone();
$newconn->storage_type('::LDAP');
$newconn->connection(...);
# and again, a convenience shortcut
my $newconn = $c->model('FilmDB')->clone();
$newconn->storage_type('::LDAP');
$newconn->connection(...);
To set up authentication, see "Setting up DBIC authentication" below.
DESCRIPTION
This is a Catalyst Model for DBIx::Class::Schema-based Models. See the
documentation for Catalyst::Helper::Model::DBIC::Schema for information
on generating these Models via Helper scripts.
When your Catalyst app starts up, a thin Model layer is created as an
interface to your DBIC Schema. It should be clearly noted that the model
object returned by "$c->model('FilmDB')" is NOT itself a DBIC schema or
resultset object, but merely a wrapper proving methods to access the
underlying schema.
In addition to this model class, a shortcut class is generated for each
source in the schema, allowing easy and direct access to a resultset of
the corresponding type. These generated classes are even thinner than
the model class, providing no public methods but simply hooking into
Catalyst's model() accessor via the ACCEPT_CONTEXT mechanism. The
complete contents of each generated class is roughly equivalent to the
following:
package MyApp::Model::FilmDB::Actor
sub ACCEPT_CONTEXT {
my ($self, $c) = @_;
$c->model('FilmDB')->resultset('Actor');
}
In short, there are three techniques available for obtaining a DBIC
resultset object:
# the long way
my $rs = $c->model('FilmDB')->schema->resultset('Actor');
# using the shortcut method on the model object
my $rs = $c->model('FilmDB')->resultset('Actor');
# using the generated class directly
my $rs = $c->model('FilmDB::Actor');
In order to add methods to a DBIC resultset, you cannot simply add them
to the source (row, table) definition class; you must define a separate
custom resultset class. This is just a matter of making a
"lib/MyApp/Schema/ResultSet/Actor.pm" class that inherits from
DBIx::Class::ResultSet, if you are using "load_namespaces" in
DBIx::Class::Schema, the default for helper script generated schemas.
See "Predefined searches" in DBIx::Class::Manual::Cookbook for
information on definining your own DBIx::Class::ResultSet classes for
use with "load_classes" in DBIx::Class::Schema, the old default.
CONFIG PARAMETERS
schema_class
This is the classname of your DBIx::Class::Schema Schema. It needs to be
findable in @INC, but it does not need to be inside the
"Catalyst::Model::" namespace. This parameter is required.
connect_info
This is a hashref or arrayref of connection parameters, which are
specific to your "storage_type" (see your storage type documentation for
more details). If you only need one parameter (e.g. the DSN), you can
just pass a string.
This is not required if "schema_class" already has connection
information defined inside itself (which isn't highly recommended, but
can be done.)
For DBIx::Class::Storage::DBI, which is the only supported
"storage_type" in DBIx::Class at the time of this writing, the
parameters are your dsn, username, password, and connect options
hashref.
See "connect_info" in DBIx::Class::Storage::DBI for a detailed
explanation of the arguments supported.
Examples:
connect_info => {
dsn => 'dbi:Pg:dbname=mypgdb',
user => 'postgres',
password => ''
}
connect_info => {
dsn => 'dbi:SQLite:dbname=foo.db',
on_connect_do => [
'PRAGMA synchronous = OFF',
]
}
connect_info => {
dsn => 'dbi:Pg:dbname=mypgdb',
user => 'postgres',
password => '',
pg_enable_utf8 => 1,
on_connect_do => [
'some SQL statement',
'another SQL statement',
],
}
Or using Config::General:
schema_class MyApp::Schema::FilmDB
traits Caching
dsn dbi:Pg:dbname=mypgdb
user postgres
password ""
auto_savepoint 1
quote_names 1
on_connect_do some SQL statement
on_connect_do another SQL statement
user_defined_schema_accessor foo
or
schema_class MyApp::Schema::FilmDB
connect_info dbi:SQLite:dbname=foo.db
Or using YAML:
Model::MyDB:
schema_class: MyDB
traits: Caching
connect_info:
dsn: dbi:Oracle:mydb
user: mtfnpy
password: mypass
LongReadLen: 1000000
LongTruncOk: 1
on_connect_call: 'datetime_setup'
quote_names: 1
The old arrayref style with hashrefs for DBI then DBIx::Class options is
also supported:
connect_info => [
'dbi:Pg:dbname=mypgdb',
'postgres',
'',
{
pg_enable_utf8 => 1,
},
{
auto_savepoint => 1,
on_connect_do => [
'some SQL statement',
'another SQL statement',
],
}
]
traits
Array of Traits to apply to the instance. Traits are Moose::Roles.
They are relative to the "MyApp::TraitFor::Model::DBIC::Schema::", then
the "Catalyst::TraitFor::Model::DBIC::Schema::" namespaces, unless
prefixed with "+" in which case they are taken to be a fully qualified
name. E.g.:
traits Caching
traits +MyApp::TraitFor::Model::Foo
A new instance is created at application time, so any consumed required
attributes, coercions and modifiers will work.
Traits are applied at "COMPONENT" in Catalyst::Component time using
CatalystX::Component::Traits.
"ref $self" will be an anon class if any traits are applied,
"$self->_original_class_name" will be the original class.
When writing a Trait, interesting points to modify are "BUILD", "setup"
and "ACCEPT_CONTEXT".
Traits that come with the distribution:
Catalyst::TraitFor::Model::DBIC::Schema::Caching
Catalyst::TraitFor::Model::DBIC::Schema::Replicated
Catalyst::TraitFor::Model::DBIC::Schema::SchemaProxy
Catalyst::TraitFor::Model::DBIC::Schema::PerRequestSchema
compose_namespaces
This model calls "compose_namespace" in DBIx::Class::Schema by default
to install classes into the model namespaces. You can turn that off by
setting this attribute to false. Default is true.
install_model_shortcuts
If you don't want shortcut models so you can do e.g.
"$c->model('DB::Book')" set this attribute to false, Default is true.
storage_type
Allows the use of a different "storage_type" than what is set in your
"schema_class" (which in turn defaults to "::DBI" if not set in current
DBIx::Class). Completely optional, and probably unnecessary for most
people until other storage backends become available for DBIx::Class.
ATTRIBUTES
The keys you pass in the model configuration are available as
attributes.
Other attributes available:
connect_info
Your connect_info args normalized to hashref form (with
dsn/user/password.) See "connect_info" in DBIx::Class::Storage::DBI for
more info on the hashref form of "connect_info".
model_name
The model name Catalyst uses to resolve this model, the part after
"::Model::" or "::M::" in your class name. E.g. if your class name is
"MyApp::Model::DB" the "model_name" will be "DB".
_default_cursor_class
What to reset your "cursor_class" in DBIx::Class::Storage::DBI to if a
custom one doesn't work out. Defaults to
DBIx::Class::Storage::DBI::Cursor.
ATTRIBUTES FROM MooseX::Traits::Pluggable
_original_class_name
The class name of your model before any "traits" are applied. E.g.
"MyApp::Model::DB".
_traits
Unresolved arrayref of traits passed in the config.
_resolved_traits
Traits you used resolved to full class names.
CONFIGURING YOUR SCHEMA AND RESULTSETS
See the documentation for
Catalyst::TraitFor::Model::DBIC::Schema::SchemaProxy for instructions on
how to pass config values from your Catalyst config to your
DBIx::Class::Schema and/or DBIx::Class::ResultSet classes.
METHODS
new
Instantiates the Model based on the above-documented ->config
parameters. The only required parameter is "schema_class".
"connect_info" is required in the case that "schema_class" does not
already have connection information defined for it.
schema
Accessor which returns the connected schema being used by the this
model. There are direct shortcuts on the model class itself for
schema->resultset, schema->source, and schema->class.
composed_schema
Accessor which returns the composed schema, which has no connection
info, which was used in constructing the "schema". Useful for creating
new connections based on the same schema/model. There are direct
shortcuts from the model object for composed_schema->clone and
composed_schema->connect
If "compose_namespaces" is not true, "composed_schema" is equivalent to
"$model->schema_class->clone".
clone
Shortcut for ->composed_schema->clone
connect
Shortcut for ->composed_schema->connect
source
Shortcut for ->schema->source
class
Shortcut for ->schema->class
resultset
Shortcut for ->schema->resultset
txn_do
Shortcut for ->schema->txn_do
txn_scope_guard
Shortcut for ->schema->txn_scope_guard
storage
Provides an accessor for the connected schema's storage object.
See DBIx::Class::Storage and DBIx::Class::Storage::DBI.
setup
Called at "BUILD" time before configuration, but after "connect_info" is
set. To do something after configuuration use "after BUILD =>".
Receives a hashref of args passed to "BUILD".
ACCEPT_CONTEXT
Point of extension for doing things at "$c->model" time with context,
returns the model instance, see "ACCEPT_CONTEXT" in
Catalyst::Manual::Intro for more information.
ENVIRONMENT
CMDS_NO_SOURCES
Set this variable if you will be using schemas with no sources
(Result classes) to disable the warning. The warning is there
because having no Result classes is usually a mistake.
Setting up DBIC authentication
You can set this up with Catalyst::Authentication::Store::DBIx::Class in
MyApp.pm:
package MyApp;
use Catalyst qw/... Authentication .../;
...
__PACKAGE__->config('Plugin::Authentication' =>
{
default_realm => 'members',
members => {
credential => {
class => 'Password',
password_field => 'password',
password_type => 'hashed'
password_hash_type => 'SHA-256'
},
store => {
class => 'DBIx::Class',
user_model => 'DB::User',
role_relation => 'roles',
role_field => 'rolename',
}
}
});
METHOD PROXYING
The automatic proxying to the underlying DBIx::Class::Schema has been
removed as of version 0.34, to enable this feature add "SchemaProxy" to
"traits".
See Catalyst::TraitFor::Model::DBIC::Schema::SchemaProxy.
SEE ALSO
General Catalyst Stuff:
Catalyst::Manual, Catalyst::Test, Catalyst::Request, Catalyst::Response,
Catalyst::Helper, Catalyst,
Stuff related to DBIC and this Model style:
DBIx::Class, DBIx::Class::Schema, DBIx::Class::Schema::Loader,
Catalyst::Helper::Model::DBIC::Schema, CatalystX::Component::Traits,
MooseX::Traits::Pluggable
Traits:
Catalyst::TraitFor::Model::DBIC::Schema::Caching,
Catalyst::TraitFor::Model::DBIC::Schema::Replicated,
Catalyst::TraitFor::Model::DBIC::Schema::SchemaProxy,
Catalyst::TraitFor::Model::DBIC::Schema::PerRequestSchema,
Catalyst::TraitFor::Model::DBIC::Schema::QueryLog
AUTHOR
Brandon L Black "blblack at gmail.com"
CONTRIBUTORS
caelum: Rafael Kitover "rkitover at cpan.org"
dandv: Dan Dascalescu "dandv at cpan.org"
bluefeet: Aran Deltac "bluefeet@cpan.org"
t0m: Tomas Doran "bobtfish@bobtfish.net"
osfameron: "osfameron@cpan.org"
ozum: Ozum Eldogan "ozum@ozum.net"
Pavel I. Shaydo "zwon@trinitum.org"
SineSwiper: Brendan Byrd
COPYRIGHT
Copyright (c) 2006 - 2010 the Catalyst::Model::DBIC::Schema "AUTHOR" and
"CONTRIBUTORS" as listed above.
LICENSE
This program is free software. You can redistribute it and/or modify it
under the same terms as Perl itself.
Catalyst-Model-DBIC-Schema-0.66/PaxHeader/Changes 000644 000766 000024 00000000210 14461412361 021705 x ustar 00gknop staff 000000 000000 30 mtime=1690703089.973061614
57 LIBARCHIVE.xattr.com.apple.provenance=AQAAq1dlpUhBqgg
49 SCHILY.xattr.com.apple.provenance= «We„HAȘ
Catalyst-Model-DBIC-Schema-0.66/Changes 000644 000766 000024 00000023453 14461412361 017752 0 ustar 00gknop staff 000000 000000 Revision history for Perl extension Catalyst::Model::DBIC::Schema
0.66 2023-07-30 07:45:00
- fix Makefile.PL to work properly in newer perls without . in @INC
- update repository link in metadata
- fix version requirement in test module
- fix link in Pod
- work around hack in Catalyst-Runtime 5.90080
0.65 2014-08-04 11:00:00
- Make compose_namespaces and install model shortcuts optional
0.64 2014-07-22 23:00:00
- Fix Replicated trait that got busted when someone assumed
Module::Runtime was a drop in replacement for Class::MOP::load_class
0.63 2014-05-05 22:56:43
- Make MooseX::MarkAsMethods a hard prerequisite (RT#94923)
- Fix t/08helper.t with Data::Dumper >= 2.151 (RT#94599)
0.62 2014-01-06 12:32:27
- Don't ship MYMETA.* files (RT#91808)
- Stop using deprecated Class::MOP::load_module
0.61 2013-06-19 12:48:34
- Fix test failure caused by hash randomisation in perl 5.17 (RT#82917)
0.60 2012-06-12 16:27:00
- Add per_request_schema hook to PerRequestSchema trait and docs
- Additional paranoia in types as it's possible for loading code
to clobber $_
0.59 2011-11-01 11:20:46
- update helper deps for new loader
0.58 2011-10-25 19:19:43
- remove ->make_immutable from the PerRequestSchema trait
0.57 2011-10-22 16:01:45
- add POD for PerRequestSchema trait
0.56 2011-10-22 15:34:59
- add PerRequestSchema trait (t0m)
0.55 Fri Sep 16 08:55:53 UTC 2011
- add DBD::SQLite to test_requires (RT#70357)
0.54 Fri Aug 5 11:29:00 EDT 2011
- Changed t/08helper.t to skip if required features are not installed.
- tweaked the Makefile.PL to support these changes
0.53 Wed Aug 3 03:45:07 UTC 2011
- check loader args after connect_info against loader methods and remove
them from connect_info
0.52 Thu Jul 28 22:07:38 UTC 2011
- fix a bug in loader args reading after connect_info (skip structs)
0.51 Wed Jul 27 20:57:47 UTC 2011
- warn when helper finds no tables
- accept loader args after connect_info
0.50 Fri May 20 22:45:07 UTC 2011
- change repository link to the new git repo
- get t/05testapp.t to run on Win32
0.49 Wed May 11 06:03:50 UTC 2011
- make sure storage_type class is loaded before ->isa check in
Replicated trait (RT#65791)
- fix regex stringification test for perl 5.14 (RT#68098)
- update connect_info POD (RT#66010)
0.48 Thu Dec 9 21:08:33 UTC 2010
- fix usage of Try::Tiny in helper
0.47 Wed Dec 8 22:21:06 UTC 2010
- fix loader version check
0.46 Wed Dec 8 13:35:28 UTC 2010
- make use_moose detection more robust
0.45 Wed Dec 8 12:05:58 UTC 2010
- fix bug where non-result files were picked up for Moose check
0.44 Tue Dec 7 03:50:48 UTC 2010
- do not upgrade non-Moose schemas to use_moose=1 (RT#60558)
- added col_collision_map => 'column_%s' as default loader option
(will take effect on release of loader 0.07003)
0.43 Sun Jul 25 01:00:34 UTC 2010
- add dep for MooseX::NonMoose for the use_moose=1 option
0.42 Sat Jul 24 23:14:27 UTC 2010
- add use_moose=1 to loader options by default for create=static
0.41 Wed Apr 28 08:42:13 EDT 2010
- allow configuring ResultSets using the SchemaProxy trait
0.40 Wed Feb 3 23:12:16 EST 2010
- fix Replicated trait deps
0.39 Mon Feb 1 10:08:51 EST 2010
- better 'on_connect_do' parsing in Helper
0.38 Fri Jan 15 06:41:24 EST 2010
- re-add the 'storage' proxy method
0.37 Thu Jan 14 10:20:43 EST 2010
- support single replicant hashref from config
0.36 Thu Jan 14 09:21:10 EST 2010
- upgrading a schema to use_namespaces=1 will also turn on
components=InflateColumn::DateTime (the default.)
0.35 Sun Dec 27 04:50:53 EST 2009
- forgot to edit Changes on last upload
0.34 Sun Dec 27 03:49:34 EST 2009
- move schema proxying into SchemaProxy trait which is off by default
0.33 Sat Dec 26 08:04:49 EST 2009
- fix test failure in 05testapp.t when env var not set (RT#53101)
0.32 Wed Dec 23 01:22:06 EST 2009
- Move documentation on setting up authentication into its own section
for clarity.
- Other misc documentation enhancements to make the docs more clear
about the important things to know.
- Convert Authentication Plugin configuration example to new style.
- Support Coderefs in loader options for helper
(patch from Ozum Eldogan ozum@ozum.net)
0.31 Sun Oct 18 18:50:00 BST 2009
- update for copyright info
0.30 Sun Oct 18 01:35:36 EDT 2009
- change no sources error to a warning (with a way to turn it off)
- write connect_info to Model without a create= option as well
0.29 Mon Sep 7 15:31:29 EDT 2009
- support for coderef connect_info's
0.28 Thu Aug 27 08:14:05 EDT 2009
- autobox issues in dep chain, bump CX::Component::Traits dep
(caelum)
0.27 Wed Aug 26 09:09:44 EDT 2009
- remove autobox usage due to reports of strange errors (caelum)
- make schema a delegate for model, config too (caelum)
0.26 Wed Jul 29 16:16:09 PDT 2009
- fix loading connect_info from schema-defined connection
(bluefeet, RT 48084)
- detect wrong case for "dbi:" DSN part in DBIC helper (caelum)
- Fix missing dep on Catalyst::Helper that made tests fail
(wintrmute, RT 47449)
0.25 Fri Jun 19 08:35:38 PDT 2009
- fix dep on Tie::IxHash that made tests fail
- add more attributes to ::Replicated trait
- fixed infinte loop in helper if SQLite connect_info has only
a DSN (dandv, RT #47101)
0.24 Tue Jun 16 06:18:58 PDT 2009
- Add tests for issues with Class::C3 which are caused to
applications which use new Catalyst but old DBIC, and have
use Class::C3 in the MyApp class (t0m)
- die on empty schema
- create=dynamic deprecation warning
- helper passes loader opts to dynamic schemas
- conversion to Moose
- cursor caching support (via
Catalyst::TraitFor::Model::DBIC::Schema::Caching)
- ::Storage::Replicated support (via ::Replicated trait)
- switch to hashref connect_info for DBIC 8100
- better helper option parsing, with support for more options
- more tests
0.23 Sun Mar 8 20:30:02 GMT 2009
- Kill a couple of warnings (one due to MRO::Compat)
0.22 Tue Mar 3 15:54:19 UTC 2009
- Fix oddly formatted error message.
- Doc patch to clarify generated classes
- Switch to use_namespaces and InflateColumn::DateTime for create=static
by default, with backcompat
- Switch to MRO::Compat from NEXT
- Add support for extra Schema::Loader options such as db_schema and
components
0.21 Fri Aug 22 00:26:05 UTC 2008
- doc fix (RT #31848)
- connection_info can be just the DSN instead of an arrayref
0.20 Wed May 23, 2007
- Fix for rt.cpan.org #22426
- Switch to Module::Install
- Assorted small pod and cleanliness fixes
- Some requirements bumped to the latest maint
releases of the same major feature release
0.18 Tue Aug 8 04:34:42 UTC 2006
- Version bump for public release, no functional change
0.17_01 Thu Jul 27 01:06:13 UTC 2006
- Updated for DBIC 0.07
0.16 Thu Jul 6 13:28:45 UTC 2006
- Bugfix for create=static and connect_info coderef snippets
- Be more verbose when connection_info is not set.
0.15 Tue Jun 6 01:33:57 UTC 2006
- Fixed a serious bug in create=static usage
- Re-arranged output generation so that the more likely
failure to generate Schemas via create= will cause the
helper to abort before generating the Model class itself
0.14 Mon Jun 5 23:34:35 UTC 2006
- Helpers merged, helper syntax changed
- Everything updated for Schema::Loader 0.03001 support, including
what amounts to using Loader in one-shot mode to generate
a manual Schema with matching Model.
- fixed stupid typo in docs
0.13 Wed Apr 26 2006
- noted support via mailing lists
0.12 Tue Apr 25 2006
- SYNOPSIS improved substantially to help newbies get started
0.11 Sun Mar 26 17:22:31 UTC 2006
- Removed on_connect_do config setting (it was only out
in public for 4 days...).
- Support for on_connect_do and sql_maker options as part
of connect_info
0.10 Wed Mar 22 07:06:02 UTC 2006
- Added on_connect_do config setting
- Added convenience method for ->schema->storage from paulm
0.08 Tue Feb 28 00:04:16 UTC 2006
- Bumped D::C::Schema::Loader recommendation to 0.02003
(should have been done last release)
- Removed the ->require stuff added in 0.07, it doesn't
do what it is supposed to do. For now, users can layer
at the Schema::Loader level rather than at Model.
0.07 Sun Feb 19 21:50:18 UTC 2006
- bugfix for ::SchemaLoader::Foo password argument, and
switch to connect_info argument of new Schema::Loader
- Added ->require for source classes, so that you can
layer in lib/MyApp/Model/Foo/Bar.pm on top of the
generated MyApp::Model::Foo::Bar.
0.06 Sat Feb 18 19:05:17 UTC 2006
- Fix simple pod-related bug introduced in last rev
- Added optional test that uses the helpers
0.05 Fri Feb 17 20:52:21 UTC 2006
- Stop showing the template pod in pod tools and cpan,
per Gavin's email.
- Bump DBIx::Class pre-req to 0.05006, to prevent likely but
subtle issues under mod_perl engines.
0.04 Mon Feb 13 04:22:49 UTC 2006
- First public release
Catalyst-Model-DBIC-Schema-0.66/MANIFEST 000644 000766 000024 00000002176 14461412673 017615 0 ustar 00gknop staff 000000 000000 .gitignore
Changes
inc/Module/AutoInstall.pm
inc/Module/Install.pm
inc/Module/Install/AutoInstall.pm
inc/Module/Install/Base.pm
inc/Module/Install/Can.pm
inc/Module/Install/Fetch.pm
inc/Module/Install/Include.pm
inc/Module/Install/Makefile.pm
inc/Module/Install/Metadata.pm
inc/Module/Install/Win32.pm
inc/Module/Install/WriteAll.pm
lib/Catalyst/Helper/Model/DBIC/Schema.pm
lib/Catalyst/Model/DBIC/Schema.pm
lib/Catalyst/Model/DBIC/Schema/Types.pm
lib/Catalyst/TraitFor/Model/DBIC/Schema/Caching.pm
lib/Catalyst/TraitFor/Model/DBIC/Schema/PerRequestSchema.pm
lib/Catalyst/TraitFor/Model/DBIC/Schema/Replicated.pm
lib/Catalyst/TraitFor/Model/DBIC/Schema/SchemaProxy.pm
Makefile.PL
MANIFEST This list of files
META.yml
README
t/01use.t
t/02pod.t
t/05testapp.t
t/06c3_issues.t
t/07connect_info.t
t/08helper.t
t/09schema_options.t
t/10literal_sql_through_accessor.t
t/lib/AnotherSchemaClass.pm
t/lib/AnotherSchemaClass/Result/User.pm
t/lib/AnotherSchemaClass/ResultSet/User.pm
t/lib/ASchemaClass.pm
t/lib/ASchemaClass/User.pm
t/lib/TestAppC3Fail.pm
t/lib/TestAppC3Fail/Model/DB.pm
t/lib/TestAppC3Fail/Schema/DB.pm
t/lib/TestAppC3Fail/Schema/DB/User.pm
Catalyst-Model-DBIC-Schema-0.66/t/ 000755 000766 000024 00000000000 14461412703 016713 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/META.yml 000644 000766 000024 00000002352 14461412670 017726 0 ustar 00gknop staff 000000 000000 ---
abstract: 'DBIx::Class::Schema Model Class'
author:
- 'Brandon L Black C'
build_requires:
DBD::SQLite: 0
ExtUtils::MakeMaker: 6.59
Storable: 0
Test::Exception: 0
Test::More: '0.94'
Test::Requires: 0
configure_requires:
ExtUtils::MakeMaker: 6.59
distribution_type: module
dynamic_config: 1
generated_by: 'Module::Install version 1.21'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
name: Catalyst-Model-DBIC-Schema
no_index:
directory:
- inc
- t
requires:
Carp::Clan: 0
Catalyst::Component::InstancePerContext: 0
Catalyst::Devel: '1.0'
Catalyst::Runtime: '5.80005'
CatalystX::Component::Traits: '0.14'
DBIx::Class: '0.08114'
DBIx::Class::Cursor::Cached: 0
DBIx::Class::Schema::Loader: '0.04005'
Hash::Merge: 0
List::MoreUtils: 0
Module::Runtime: '0.012'
Moose: '1.12'
MooseX::MarkAsMethods: '0.13'
MooseX::NonMoose: '0.16'
MooseX::Types: 0
MooseX::Types::LoadableClass: 0.009
Tie::IxHash: 0
Try::Tiny: 0
namespace::autoclean: 0.09
namespace::clean: 0
perl: 5.8.1
resources:
license: http://dev.perl.org/licenses/
repository: https://github.com/perl-catalyst/Catalyst-Model-DBIC-Schema.git
version: '0.66'
Catalyst-Model-DBIC-Schema-0.66/.gitignore 000644 000766 000024 00000000203 14461407424 020437 0 ustar 00gknop staff 000000 000000 META.yml
MYMETA.json
MYMETA.yml
Makefile
README
blib/
inc/
MANIFEST
MANIFEST.bak
pm_to_blib
Catalyst-Model-DBIC-Schema-*
*~
.#*
*#
Catalyst-Model-DBIC-Schema-0.66/lib/ 000755 000766 000024 00000000000 14461412703 017216 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/PaxHeader/Makefile.PL 000644 000766 000024 00000000210 14461411171 022362 x ustar 00gknop staff 000000 000000 30 mtime=1690702457.256913088
57 LIBARCHIVE.xattr.com.apple.provenance=AQAAq1dlpUhBqgg
49 SCHILY.xattr.com.apple.provenance= «We„HAȘ
Catalyst-Model-DBIC-Schema-0.66/Makefile.PL 000644 000766 000024 00000003027 14461411171 020422 0 ustar 00gknop staff 000000 000000 use lib '.';
use inc::Module::Install 0.91;
name 'Catalyst-Model-DBIC-Schema';
perl_version 5.008001;
all_from 'lib/Catalyst/Model/DBIC/Schema.pm';
requires 'DBIx::Class' => '0.08114';
requires 'Catalyst::Runtime' => '5.80005';
requires 'CatalystX::Component::Traits' => '0.14';
requires 'Moose' => '1.12';
requires 'MooseX::MarkAsMethods' => '0.13';
requires 'MooseX::Types';
requires 'MooseX::Types::LoadableClass' => 0.009;
requires 'Module::Runtime' => '0.012';
requires 'namespace::autoclean' => 0.09;
requires 'Carp::Clan';
requires 'List::MoreUtils';
requires 'Tie::IxHash';
requires 'Try::Tiny';
requires 'Catalyst::Component::InstancePerContext';
test_requires 'Test::More' => '0.94';
test_requires 'Test::Exception';
test_requires 'Storable';
test_requires 'Test::Requires';
test_requires 'DBD::SQLite';
feature 'Catalyst::Helper support',
-default => 0,
'Catalyst::Devel' => '1.0',
'DBIx::Class::Schema::Loader' => '0.04005',
'MooseX::NonMoose' => '0.16',
;
feature 'Caching support',
-default => 0,
'DBIx::Class::Cursor::Cached' => 0;
feature 'Replication support',
-default => 0,
'namespace::clean' => 0,
'Hash::Merge' => 0;
if(-e 'MANIFEST.SKIP') {
system("pod2text lib/Catalyst/Model/DBIC/Schema.pm > README");
}
realclean_files 'README';
auto_provides;
auto_install;
resources repository =>
'https://github.com/perl-catalyst/Catalyst-Model-DBIC-Schema.git';
WriteAll;
Catalyst-Model-DBIC-Schema-0.66/lib/Catalyst/ 000755 000766 000024 00000000000 14461412703 021002 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/lib/Catalyst/Helper/ 000755 000766 000024 00000000000 14461412703 022221 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/lib/Catalyst/TraitFor/ 000755 000766 000024 00000000000 14461412703 022534 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/lib/Catalyst/Model/ 000755 000766 000024 00000000000 14461412703 022042 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/lib/Catalyst/Model/DBIC/ 000755 000766 000024 00000000000 14461412703 022543 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/lib/Catalyst/Model/DBIC/PaxHeader/Schema.pm 000644 000766 000024 00000000210 14461412230 026236 x ustar 00gknop staff 000000 000000 30 mtime=1690703000.508535087
57 LIBARCHIVE.xattr.com.apple.provenance=AQAAq1dlpUhBqgg
49 SCHILY.xattr.com.apple.provenance= «We„HAȘ
Catalyst-Model-DBIC-Schema-0.66/lib/Catalyst/Model/DBIC/Schema.pm 000644 000766 000024 00000050114 14461412230 024275 0 ustar 00gknop staff 000000 000000 package Catalyst::Model::DBIC::Schema;
use Moose;
use mro 'c3';
extends 'Catalyst::Model';
with 'CatalystX::Component::Traits';
our $VERSION = '0.66';
$VERSION =~ tr/_//d;
use namespace::autoclean;
use Carp::Clan '^Catalyst::Model::DBIC::Schema';
use Data::Dumper;
use DBIx::Class ();
use Module::Runtime qw/use_module/;
use Catalyst::Model::DBIC::Schema::Types
qw/ConnectInfo SchemaClass Schema/;
use MooseX::Types::Moose qw/Str Bool/;
use MooseX::Types::LoadableClass qw/LoadableClass/;
=head1 NAME
Catalyst::Model::DBIC::Schema - DBIx::Class::Schema Model Class
=head1 SYNOPSIS
First, prepare your database schema using L, see
L for how to generate a
L from your database using the Helper script, and
L.
A typical usage of the helper script would be:
script/myapp_create.pl model FilmDB DBIC::Schema MyApp::Schema::FilmDB \
create=static dbi:mysql:filmdb dbusername dbpass \
quote_names=1
If you are unfamiliar with L, see L
first.
These examples assume that you already have a schema called
C, which defines some Result classes for tables in
C and
C. Either created by the helper script (as
shown above) or manually.
The helper also creates a Model in C, if you already
have a schema you can create just the Model using:
script/myapp_create.pl model FilmDB DBIC::Schema MyApp::Schema::FilmDB
dbi:mysql:filmdb dbusername dbpass
The connect_info is optional and will be hardcoded into the Model if provided.
It's better to configure it in your L config file, which will also
override any hardcoded config, see L for examples.
Now you have a working Model which accesses your separate DBIC Schema. This can
be used/accessed in the normal Catalyst manner, via C<< $c->model() >>:
my $db_model = $c->model('FilmDB'); # a Catalyst::Model
my $dbic = $c->model('FilmDB')->schema; # the actual DBIC object
There is also a shortcut, which returns a L directly,
instead of a L:
my $rs = $c->model('FilmDB::Actor');
See L to find out more about which methods can be
called on ResultSets.
You can also define your own ResultSet methods to encapsulate the
database/business logic of your applications. These go into, for example,
C. The class must inherit from
L and is automatically loaded.
Then call your methods like any other L method:
$c->model('FilmDB::Actor')->SAG_members
=head2 Some examples:
# to access schema methods directly:
$c->model('FilmDB')->schema->source(...);
# to access the source object, resultset, and class:
$c->model('FilmDB')->source(...);
$c->model('FilmDB')->resultset(...);
$c->model('FilmDB')->class(...);
# For resultsets, there's an even quicker shortcut:
$c->model('FilmDB::Actor')
# is the same as $c->model('FilmDB')->resultset('Actor')
# To get the composed schema for making new connections:
my $newconn = $c->model('FilmDB')->composed_schema->connect(...);
# Or the same thing via a convenience shortcut:
my $newconn = $c->model('FilmDB')->connect(...);
# or, if your schema works on different storage drivers:
my $newconn = $c->model('FilmDB')->composed_schema->clone();
$newconn->storage_type('::LDAP');
$newconn->connection(...);
# and again, a convenience shortcut
my $newconn = $c->model('FilmDB')->clone();
$newconn->storage_type('::LDAP');
$newconn->connection(...);
To set up authentication, see L below.
=head1 DESCRIPTION
This is a Catalyst Model for L-based Models. See
the documentation for L for
information on generating these Models via Helper scripts.
When your Catalyst app starts up, a thin Model layer is created as an interface
to your DBIC Schema. It should be clearly noted that the model object returned
by C<< $c->model('FilmDB') >> is NOT itself a DBIC schema or resultset object,
but merely a wrapper proving L to access the underlying
schema.
In addition to this model class, a shortcut class is generated for each
source in the schema, allowing easy and direct access to a resultset of the
corresponding type. These generated classes are even thinner than the model
class, providing no public methods but simply hooking into Catalyst's
model() accessor via the
L mechanism. The complete
contents of each generated class is roughly equivalent to the following:
package MyApp::Model::FilmDB::Actor
sub ACCEPT_CONTEXT {
my ($self, $c) = @_;
$c->model('FilmDB')->resultset('Actor');
}
In short, there are three techniques available for obtaining a DBIC
resultset object:
# the long way
my $rs = $c->model('FilmDB')->schema->resultset('Actor');
# using the shortcut method on the model object
my $rs = $c->model('FilmDB')->resultset('Actor');
# using the generated class directly
my $rs = $c->model('FilmDB::Actor');
In order to add methods to a DBIC resultset, you cannot simply add them to
the source (row, table) definition class; you must define a separate custom
resultset class. This is just a matter of making a
C class that inherits from
L, if you are using
L, the default for helper script generated
schemas.
See L
for information on definining your own L classes for
use with L, the old default.
=head1 CONFIG PARAMETERS
=head2 schema_class
This is the classname of your L Schema. It needs
to be findable in C<@INC>, but it does not need to be inside the
C namespace. This parameter is required.
=head2 connect_info
This is a hashref or arrayref of connection parameters, which are specific to
your C (see your storage type documentation for more details). If
you only need one parameter (e.g. the DSN), you can just pass a string.
This is not required if C already has connection information
defined inside itself (which isn't highly recommended, but can be done.)
For L, which is the only supported
C in L at the time of this writing, the
parameters are your dsn, username, password, and connect options hashref.
See L for a detailed explanation
of the arguments supported.
Examples:
connect_info => {
dsn => 'dbi:Pg:dbname=mypgdb',
user => 'postgres',
password => ''
}
connect_info => {
dsn => 'dbi:SQLite:dbname=foo.db',
on_connect_do => [
'PRAGMA synchronous = OFF',
]
}
connect_info => {
dsn => 'dbi:Pg:dbname=mypgdb',
user => 'postgres',
password => '',
pg_enable_utf8 => 1,
on_connect_do => [
'some SQL statement',
'another SQL statement',
],
}
Or using L:
schema_class MyApp::Schema::FilmDB
traits Caching
dsn dbi:Pg:dbname=mypgdb
user postgres
password ""
auto_savepoint 1
quote_names 1
on_connect_do some SQL statement
on_connect_do another SQL statement
user_defined_schema_accessor foo
or
schema_class MyApp::Schema::FilmDB
connect_info dbi:SQLite:dbname=foo.db
Or using L:
Model::MyDB:
schema_class: MyDB
traits: Caching
connect_info:
dsn: dbi:Oracle:mydb
user: mtfnpy
password: mypass
LongReadLen: 1000000
LongTruncOk: 1
on_connect_call: 'datetime_setup'
quote_names: 1
The old arrayref style with hashrefs for L then L options is also
supported:
connect_info => [
'dbi:Pg:dbname=mypgdb',
'postgres',
'',
{
pg_enable_utf8 => 1,
},
{
auto_savepoint => 1,
on_connect_do => [
'some SQL statement',
'another SQL statement',
],
}
]
=head2 traits
Array of Traits to apply to the instance. Traits are Ls.
They are relative to the C<< MyApp::TraitFor::Model::DBIC::Schema:: >>, then
the C<< Catalyst::TraitFor::Model::DBIC::Schema:: >> namespaces, unless
prefixed with C<+> in which case they are taken to be a fully qualified name.
E.g.:
traits Caching
traits +MyApp::TraitFor::Model::Foo
A new instance is created at application time, so any consumed required
attributes, coercions and modifiers will work.
Traits are applied at L time using
L.
C[ will be an anon class if any traits are applied, C<<
$self->_original_class_name >> will be the original class.
When writing a Trait, interesting points to modify are C, L and
L.
Traits that come with the distribution:
=over 4
=item L
=item L
=item L
=item L
=back
=head2 compose_namespaces
This model calls L by default to
install classes into the model namespaces. You can turn that off by
setting this attribute to false. Default is true.
=head2 install_model_shortcuts
If you don't want shortcut models so you can do e.g. C<< $c->model('DB::Book')
>> set this attribute to false, Default is true.
=head2 storage_type
Allows the use of a different C than what is set in your
C (which in turn defaults to C<::DBI> if not set in current
L). Completely optional, and probably unnecessary for most
people until other storage backends become available for L.
=head1 ATTRIBUTES
The keys you pass in the model configuration are available as attributes.
Other attributes available:
=head2 connect_info
Your connect_info args normalized to hashref form (with dsn/user/password.) See
L for more info on the hashref form of
L.
=head2 model_name
The model name L uses to resolve this model, the part after
C<::Model::> or C<::M::> in your class name. E.g. if your class name is
C the L will be C.
=head2 _default_cursor_class
What to reset your L to if a custom one
doesn't work out. Defaults to L.
=head1 ATTRIBUTES FROM L
=head2 _original_class_name
The class name of your model before any L are applied. E.g.
C.
=head2 _traits
Unresolved arrayref of traits passed in the config.
=head2 _resolved_traits
Traits you used resolved to full class names.
=head1 CONFIGURING YOUR SCHEMA AND RESULTSETS
See the documentation for
L for instructions on how
to pass config values from your L config to your
L and/or L classes.
=head1 METHODS
=head2 new
Instantiates the Model based on the above-documented ->config parameters.
The only required parameter is C. C is
required in the case that C does not already have connection
information defined for it.
=head2 schema
Accessor which returns the connected schema being used by the this model.
There are direct shortcuts on the model class itself for
schema->resultset, schema->source, and schema->class.
=head2 composed_schema
Accessor which returns the composed schema, which has no connection info,
which was used in constructing the L. Useful for creating
new connections based on the same schema/model. There are direct shortcuts
from the model object for composed_schema->clone and composed_schema->connect
If L is not true, L is equivalent to
C<< $model->schema_class->clone >>.
=head2 clone
Shortcut for ->composed_schema->clone
=head2 connect
Shortcut for ->composed_schema->connect
=head2 source
Shortcut for ->schema->source
=head2 class
Shortcut for ->schema->class
=head2 resultset
Shortcut for ->schema->resultset
=head2 txn_do
Shortcut for ->schema->txn_do
=head2 txn_scope_guard
Shortcut for ->schema->txn_scope_guard
=head2 storage
Provides an accessor for the connected schema's storage object.
See L and L.
=cut
has schema_class => (
is => 'ro',
isa => SchemaClass,
required => 1
);
has compose_namespaces => (is => 'ro', isa => Bool, default => 1 );
has install_model_shortcuts => (is => 'ro', isa => Bool, default => 1 );
has storage_type => (is => 'rw', isa => Str);
has connect_info => (is => 'rw', isa => ConnectInfo, coerce => 1);
has model_name => (
is => 'ro',
isa => Str,
required => 1,
lazy_build => 1,
);
has _default_cursor_class => (
is => 'ro',
isa => LoadableClass,
default => 'DBIx::Class::Storage::DBI::Cursor',
);
has schema => (is => 'rw', isa => Schema);
my $app_class;
before COMPONENT => sub {
$app_class = ref $_[1] || $_[1];
};
sub app_class { $app_class }
sub BUILD {
my ($self, $args) = @_;
my $class = $self->_original_class_name;
my $schema_class = $self->schema_class;
if( !$self->connect_info ) {
if($schema_class->storage && $schema_class->storage->connect_info) {
$self->connect_info($schema_class->storage->connect_info);
}
else {
die "Either ->config->{connect_info} must be defined for $class"
. " or $schema_class must have connect info defined on it."
. " Here's what we got:\n"
. Dumper($args);
}
}
if (exists $self->connect_info->{cursor_class}) {
eval { use_module($self->connect_info->{cursor_class}) }
or croak "invalid connect_info: Cannot load your cursor_class"
. " ".$self->connect_info->{cursor_class}.": $@";
}
$self->setup($args);
my $is_installed = defined $self->composed_schema;
if (not $is_installed) {
$self->composed_schema($self->compose_namespaces ?
$schema_class->compose_namespace($class)
:
$schema_class->clone
);
}
$self->schema($self->composed_schema->clone)
unless $self->schema;
$self->schema->storage_type($self->storage_type)
if $self->storage_type;
$self->schema->connection($self->connect_info);
if ((not $is_installed) && $self->install_model_shortcuts) {
$self->_install_rs_models;
}
}
sub clone { shift->composed_schema->clone(@_); }
sub connect { shift->composed_schema->connect(@_); }
# some proxy methods, see also SchemaProxy
sub resultset { shift->schema->resultset(@_); }
sub txn_do { shift->schema->txn_do(@_); }
sub txn_scope_guard { shift->schema->txn_scope_guard(@_); }
sub storage { shift->schema->storage(@_); }
=head2 setup
Called at C time before configuration, but after L is
set. To do something after configuuration use C<< after BUILD => >>.
Receives a hashref of args passed to C.
=cut
sub setup { 1 }
=head2 ACCEPT_CONTEXT
Point of extension for doing things at C<< $c->model >> time with context,
returns the model instance, see L for
more information.
=cut
sub ACCEPT_CONTEXT { shift }
sub _install_rs_models {
my $self = shift;
my $class = $self->_original_class_name;
no strict 'refs';
my @sources = $self->schema->sources;
unless (@sources) {
warn <<'EOF' unless $ENV{CMDS_NO_SOURCES};
******************************* WARNING ***************************************
* No sources found (did you forget to define your tables?) *
* *
* To turn off this warning, set the CMDS_NO_SOURCES environment variable. *
*******************************************************************************
EOF
}
foreach my $moniker (@sources) {
my $classname = "${class}::$moniker";
*{"${classname}::ACCEPT_CONTEXT"} = sub {
shift;
shift->model($self->model_name)->resultset($moniker);
}
}
}
sub _reset_cursor_class {
my $self = shift;
if ($self->storage->can('cursor_class')) {
$self->storage->cursor_class($self->_default_cursor_class)
if $self->storage->cursor_class ne $self->_default_cursor_class;
}
}
{
my %COMPOSED_CACHE;
sub composed_schema {
my $self = shift;
my $class = $self->_original_class_name;
my $store = \$COMPOSED_CACHE{$class}{$self->schema_class};
$$store = shift if @_;
return $$store
}
}
sub _build_model_name {
my $self = shift;
my $class = $self->_original_class_name;
(my $model_name = $class) =~ s/^[\w:]+::(?:Model|M):://;
return $model_name;
}
__PACKAGE__->meta->make_immutable;
=head1 ENVIRONMENT
=over 4
=item CMDS_NO_SOURCES
Set this variable if you will be using schemas with no sources (Result classes)
to disable the warning. The warning is there because having no Result classes
is usually a mistake.
=back
=head1 Setting up DBIC authentication
You can set this up with
L in MyApp.pm:
package MyApp;
use Catalyst qw/... Authentication .../;
...
__PACKAGE__->config('Plugin::Authentication' =>
{
default_realm => 'members',
members => {
credential => {
class => 'Password',
password_field => 'password',
password_type => 'hashed'
password_hash_type => 'SHA-256'
},
store => {
class => 'DBIx::Class',
user_model => 'DB::User',
role_relation => 'roles',
role_field => 'rolename',
}
}
});
=head1 METHOD PROXYING
The automatic proxying to the underlying L has been
removed as of version C<0.34>, to enable this feature add C to
L.
See L.
=head1 SEE ALSO
General Catalyst Stuff:
L, L, L,
L, L, L,
Stuff related to DBIC and this Model style:
L, L,
L, L,
L, L
Traits:
L,
L,
L,
L,
L
=head1 AUTHOR
Brandon L Black C
=head1 CONTRIBUTORS
caelum: Rafael Kitover C
dandv: Dan Dascalescu C
bluefeet: Aran Deltac C
t0m: Tomas Doran C
osfameron: C
ozum: Ozum Eldogan C
Pavel I. Shaydo C
SineSwiper: Brendan Byrd
=head1 COPYRIGHT
Copyright (c) 2006 - 2010
the Catalyst::Model::DBIC::Schema L and L
as listed above.
=head1 LICENSE
This program is free software. You can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
1;
# vim:sts=4 sw=4 et tw=80:
Catalyst-Model-DBIC-Schema-0.66/lib/Catalyst/Model/DBIC/Schema/ 000755 000766 000024 00000000000 14461412703 023743 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/lib/Catalyst/Model/DBIC/Schema/Types.pm 000644 000766 000024 00000007133 14461407424 025415 0 ustar 00gknop staff 000000 000000 package # hide from PAUSE
Catalyst::Model::DBIC::Schema::Types;
use MooseX::Types -declare => [qw/
ConnectInfo ConnectInfos Replicants SchemaClass CreateOption
Schema LoadedClass
/];
use Carp::Clan '^Catalyst::Model::DBIC::Schema';
use MooseX::Types::Moose qw/ArrayRef HashRef CodeRef Str ClassName/;
use MooseX::Types::LoadableClass qw/LoadableClass/;
use Scalar::Util 'reftype';
use List::MoreUtils 'all';
use Module::Runtime;
use namespace::clean -except => 'meta';
# So I restored the custom Type LoadedClass because 'LoadableClass' doesn't really
# exactly do the same thing, which busted the Replication trait. Please don't
# "clean this up" -JNAP
subtype LoadedClass,
as ClassName;
coerce LoadedClass,
from Str, # N.B. deliberate paranoia against $_ clobbering below
via { my $classname = $_; Module::Runtime::use_module($classname); $classname };
subtype SchemaClass,
as LoadableClass,
where { $_->isa('DBIx::Class::Schema') };
class_type Schema, { class => 'DBIx::Class::Schema' };
subtype ConnectInfo,
as HashRef,
where { exists $_->{dsn} || exists $_->{dbh_maker} },
message { 'Does not look like a valid connect_info' };
coerce ConnectInfo,
from Str,
via(\&_coerce_connect_info_from_str),
from ArrayRef,
via(\&_coerce_connect_info_from_arrayref),
from CodeRef,
via { +{ dbh_maker => $_ } },
;
# { connect_info => [ ... ] } coercion would be nice, but no chained coercions
# yet.
# Also no coercion from base type (yet,) but in Moose git already.
# from HashRef,
# via { $_->{connect_info} },
subtype ConnectInfos,
as ArrayRef[ConnectInfo],
message { "Not a valid array of connect_info's" };
coerce ConnectInfos,
from Str,
via { [ _coerce_connect_info_from_str() ] },
from CodeRef,
via { [ +{ dbh_maker => $_ } ] },
from HashRef,
via { [ $_ ] },
from ArrayRef,
via { [ map {
!ref $_ ? _coerce_connect_info_from_str()
: reftype $_ eq 'HASH' ? $_
: reftype $_ eq 'CODE' ? +{ dbh_maker => $_ }
: reftype $_ eq 'ARRAY' ? _coerce_connect_info_from_arrayref()
: croak 'invalid connect_info'
} @$_ ] };
# Helper stuff
subtype CreateOption,
as Str,
where { /^(?:static|dynamic)\z/ },
message { "Invalid create option, must be one of 'static' or 'dynamic'" };
sub _coerce_connect_info_from_arrayref {
my %connect_info;
# make a copy
$_ = [ @$_ ];
my $slurp_hashes = sub {
for my $i (0..1) {
my $extra = shift @$_;
last unless $extra;
croak "invalid connect_info"
unless ref $extra && reftype $extra eq 'HASH';
%connect_info = (%connect_info, %$extra);
}
};
if (!ref $_->[0]) { # array style
$connect_info{dsn} = shift @$_;
$connect_info{user} = shift @$_ if !ref $_->[0];
$connect_info{password} = shift @$_ if !ref $_->[0];
$slurp_hashes->();
croak "invalid connect_info" if @$_;
} elsif (ref $_->[0] && reftype $_->[0] eq 'CODE') {
$connect_info{dbh_maker} = shift @$_;
$slurp_hashes->();
croak "invalid connect_info" if @$_;
} elsif (@$_ == 1 && ref $_->[0] && reftype $_->[0] eq 'HASH') {
return $_->[0];
} else {
croak "invalid connect_info";
}
unless ($connect_info{dbh_maker}) {
for my $key (qw/user password/) {
$connect_info{$key} = ''
if not defined $connect_info{$key};
}
}
\%connect_info;
}
sub _coerce_connect_info_from_str {
+{ dsn => $_, user => '', password => '' }
}
1;
Catalyst-Model-DBIC-Schema-0.66/lib/Catalyst/TraitFor/Model/ 000755 000766 000024 00000000000 14461412703 023574 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/lib/Catalyst/TraitFor/Model/DBIC/ 000755 000766 000024 00000000000 14461412703 024275 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/lib/Catalyst/TraitFor/Model/DBIC/Schema/ 000755 000766 000024 00000000000 14461412703 025475 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/lib/Catalyst/TraitFor/Model/DBIC/Schema/Replicated.pm 000644 000766 000024 00000010723 14461407424 030116 0 ustar 00gknop staff 000000 000000 package Catalyst::TraitFor::Model::DBIC::Schema::Replicated;
## WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING
## If you make changes to this code and don't actually go and test it
## on a real replicated environment I will rip you an new hole. The
## test suite DOES NOT properly test this. --JNAP
use namespace::autoclean;
use Moose::Role;
use Carp::Clan '^Catalyst::Model::DBIC::Schema';
use Catalyst::Model::DBIC::Schema::Types qw/ConnectInfos LoadedClass/;
use MooseX::Types::Moose qw/Str HashRef/;
use Module::Runtime;
=head1 NAME
Catalyst::TraitFor::Model::DBIC::Schema::Replicated - Replicated storage support for
L
=head1 SYNOPSiS
__PACKAGE__->config({
traits => ['Replicated']
connect_info =>
['dbi:mysql:master', 'user', 'pass'],
replicants => [
['dbi:mysql:slave1', 'user', 'pass'],
['dbi:mysql:slave2', 'user', 'pass'],
['dbi:mysql:slave3', 'user', 'pass'],
],
balancer_args => {
master_read_weight => 0.3
}
});
=head1 DESCRIPTION
Sets your storage_type to L and connects
replicants provided in config. See that module for supported resultset
attributes.
The default L is
C<::Random>.
Sets the
L to
C<1> by default, meaning that you have the same chance of reading from master as
you do from replicants. Set to C<0> to turn off reads from master.
=head1 CONFIG PARAMETERS
=head2 replicants
Array of connect_info settings for every replicant.
The following can be set via L, or
as their own parameters. If set via separate parameters, they will override the
settings in C.
=head2 pool_type
See L.
=head2 pool_args
See L.
=head2 balancer_type
See L.
=head2 balancer_args
See L.
=cut
has replicants => (
is => 'ro', isa => ConnectInfos, coerce => 1, required => 1
);
# If you change LoadedClass with LoadableClass I will rip you a new hole,
# it doesn't work exactly the same - JNAP
has pool_type => (is => 'ro', isa => LoadedClass);
has pool_args => (is => 'ro', isa => HashRef);
has balancer_type => (is => 'ro', isa => Str);
has balancer_args => (is => 'ro', isa => HashRef);
after setup => sub {
my $self = shift;
# check storage_type compatibility (if configured)
if (my $storage_type = $self->storage_type) {
my $class = $storage_type =~ /^::/ ?
"DBIx::Class::Storage$storage_type"
: $storage_type;
# For some odd reason if you try to use 'use_module' as an export
# the code breaks. I guess something odd about MR and all these
# runtime loaded crazy trait code. Please don't "tidy the code up" -JNAP
Module::Runtime::use_module($class);
croak "This storage_type cannot be used with replication"
unless $class->isa('DBIx::Class::Storage::DBI::Replicated');
} else {
$self->storage_type('::DBI::Replicated');
}
my $connect_info = $self->connect_info;
$connect_info->{pool_type} = $self->pool_type
if $self->pool_type;
$connect_info->{pool_args} = $self->pool_args
if $self->pool_args;
$connect_info->{balancer_type} = $self->balancer_type ||
$connect_info->{balancer_type} || '::Random';
$connect_info->{balancer_args} = $self->balancer_args ||
$connect_info->{balancer_args} || {};
$connect_info->{balancer_args}{master_read_weight} = 1
unless exists $connect_info->{balancer_args}{master_read_weight};
};
sub BUILD {}
after BUILD => sub {
my $self = shift;
$self->storage->connect_replicants(map [ $_ ], @{ $self->replicants });
};
=head1 SEE ALSO
L, L,
L,
L
=head1 AUTHOR
See L and
L.
=head1 COPYRIGHT
See L.
=head1 LICENSE
This program is free software, you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
1;
Catalyst-Model-DBIC-Schema-0.66/lib/Catalyst/TraitFor/Model/DBIC/Schema/SchemaProxy.pm 000644 000766 000024 00000012053 14461407424 030302 0 ustar 00gknop staff 000000 000000 package Catalyst::TraitFor::Model::DBIC::Schema::SchemaProxy;
use namespace::autoclean;
use Moose::Role;
use Carp::Clan '^Catalyst::Model::DBIC::Schema';
use Catalyst::Model::DBIC::Schema::Types 'Schema';
=head1 NAME
Catalyst::TraitFor::Model::DBIC::Schema::SchemaProxy - Proxy Schema Methods and
Options from Model
=head1 DESCRIPTION
Allows you to call your L methods directly on the Model
instance, and passes config options to your L and
L attributes at C time.
Methods and attributes local to your C take precedence over
L or L methods and attributes.
=head1 CREATING SCHEMA CONFIG ATTRIBUTES
To create attributes in your C, use either Moose or
L, which is inherited from by all L
classes automatically. E.g.:
__PACKAGE__->mk_group_accessors(simple => qw/
config_key1
config_key2
...
/);
Or with L:
use Moose;
has config_key1 => (is => 'rw', default => 'default_value');
This code can be added after the md5sum on L
generated schemas.
At app startup, any non-local options will be passed to these accessors, and can
be accessed as usual via C<< $schema->config_key1 >>.
These config values go into your C block, along with normal config
values.
=head1 CREATING RESULTSET CONFIG ATTRIBUTES
You can create classdata on L classes to hold values
from L config.
The code for this looks something like this:
package MySchema::ResultSet::Foo;
use base 'DBIx::Class::ResultSet';
__PACKAGE__->mk_group_accessors(inherited => qw/
rs_config_key1
rs_config_key2
...
/);
__PACKAGE__->rs_config_key1('default_value');
Or, if you prefer L:
package MySchema::ResultSet::Foo;
use Moose;
use MooseX::NonMoose;
use MooseX::ClassAttribute;
extends 'DBIx::Class::ResultSet';
sub BUILDARGS { $_[2] } # important
class_has rs_config_key1 => (is => 'rw', default => 'default_value');
...
__PACKAGE__->meta->make_immutable;
1;
In your catalyst config, use the generated Model name as the config key, e.g.:
strict_passwords 1
=cut
after setup => sub {
my ($self, $args) = @_;
my $schema = $self->schema;
my $was_mutable = $self->meta->is_mutable;
$self->meta->make_mutable;
$self->meta->add_attribute('schema',
is => 'rw',
isa => Schema,
handles => $self->_delegates # this removes the attribute too
);
$self->meta->make_immutable unless $was_mutable;
$self->schema($schema) if $schema;
};
after BUILD => sub {
my ($self, $args) = @_;
$self->_pass_options_to_schema($args);
for my $source ($self->schema->sources) {
my $config_key = 'Model::' . $self->model_name . '::' . $source;
my $config = $self->app_class->config->{$config_key};
next unless $config;
$self->_pass_options_to_resultset($source, $config);
}
};
sub _delegates {
my $self = shift;
my $schema_meta = Class::MOP::Class->initialize($self->schema_class);
my @schema_methods = $schema_meta->get_all_method_names;
# combine with any already added by other schemas
my @handles = eval {
@{ $self->meta->find_attribute_by_name('schema')->handles }
};
# now kill the attribute, otherwise add_attribute in BUILD will not do the right
# thing (it clears the handles for some reason.) May be a Moose bug.
eval { $self->meta->remove_attribute('schema') };
my %schema_methods;
@schema_methods{ @schema_methods, @handles } = ();
@schema_methods = keys %schema_methods;
my @my_methods = $self->meta->get_all_method_names;
my %my_methods;
@my_methods{@my_methods} = ();
my @delegates;
for my $method (@schema_methods) {
push @delegates, $method unless exists $my_methods{$method};
}
return \@delegates;
}
sub _pass_options_to_schema {
my ($self, $args) = @_;
my @attributes = map {
$_->init_arg || ()
} $self->meta->get_all_attributes;
my %attributes;
@attributes{@attributes} = ();
for my $opt (keys %$args) {
if (not exists $attributes{$opt}) {
next unless $self->schema->can($opt);
$self->schema->$opt($args->{$opt});
}
}
}
sub _pass_options_to_resultset {
my ($self, $source, $args) = @_;
for my $opt (keys %$args) {
my $rs_class = $self->schema->source($source)->resultset_class;
next unless $rs_class->can($opt);
$rs_class->$opt($args->{$opt});
}
}
=head1 SEE ALSO
L, L
=head1 AUTHOR
See L and
L.
=head1 COPYRIGHT
See L.
=head1 LICENSE
This program is free software, you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
1;
Catalyst-Model-DBIC-Schema-0.66/lib/Catalyst/TraitFor/Model/DBIC/Schema/Caching.pm 000644 000766 000024 00000006044 14461407424 027377 0 ustar 00gknop staff 000000 000000 package Catalyst::TraitFor::Model::DBIC::Schema::Caching;
use namespace::autoclean;
use Moose::Role;
use Carp::Clan '^Catalyst::Model::DBIC::Schema';
use MooseX::Types::Moose 'Int';
use Module::Runtime 'use_module';
=head1 NAME
Catalyst::TraitFor::Model::DBIC::Schema::Caching - Query caching support for
Catalyst::Model::DBIC::Schema
=head1 SYNOPSIS
__PACKAGE__->config({
traits => ['Caching'],
connect_info =>
['dbi:mysql:db', 'user', 'pass'],
});
$c->model('DB::Table')->search({ foo => 'bar' }, { cache_for => 18000 });
=head1 DESCRIPTION
Enable caching support using L and
L.
In order for this to work, L must be configured and
loaded. A possible configuration would look like this:
class Cache::FastMmap
unlink_on_exit 1
share_file /tmp/myapp_share
Then in your queries, set the C ResultSet attribute to the number of
seconds you want the query results to be cached for, eg.:
$c->model('DB::Table')->search({ foo => 'bar' }, { cache_for => 18000 });
=head1 CONFIG PARAMETERS
=head2 caching
Turn caching on or off, you can use:
$c->model('DB')->caching(0);
=cut
has caching => (is => 'rw', isa => Int, default => 1);
after setup => sub {
my $self = shift;
return if !$self->caching;
$self->caching(0);
my $cursor_class = $self->connect_info->{cursor_class}
|| 'DBIx::Class::Cursor::Cached';
unless (eval { use_module($cursor_class) }) {
carp "Caching disabled, cannot load cursor class"
. " $cursor_class: $@";
return;
}
unless ($cursor_class->can('clear_cache')) {
carp "Caching disabled, cursor_class $cursor_class does not"
. " support it.";
return;
}
$self->connect_info->{cursor_class} = $cursor_class;
$self->caching(1);
};
before ACCEPT_CONTEXT => sub {
my ($self, $c) = @_;
return $self unless
$self->caching;
unless ($c->can('cache') && ref $c->cache) {
$c->log->warn("DBIx::Class cursor caching disabled, you don't seem to"
. " have a working Cache plugin.");
$self->caching(0);
$self->_reset_cursor_class;
return $self;
}
if (ref $self->schema->default_resultset_attributes) {
$self->schema->default_resultset_attributes->{cache_object} =
$c->cache;
} else {
$self->schema->default_resultset_attributes({
cache_object => $c->cache
});
}
};
=head1 SEE ALSO
L, L, L,
L, L
=head1 AUTHOR
See L and
L.
=head1 COPYRIGHT
See L.
=head1 LICENSE
This program is free software, you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
1;
Catalyst-Model-DBIC-Schema-0.66/lib/Catalyst/TraitFor/Model/DBIC/Schema/PerRequestSchema.pm 000644 000766 000024 00000004026 14461407424 031261 0 ustar 00gknop staff 000000 000000 package Catalyst::TraitFor::Model::DBIC::Schema::PerRequestSchema;
use Moose::Role;
use MooseX::MarkAsMethods autoclean => 1;
with 'Catalyst::Component::InstancePerContext';
=head1 NAME
Catalyst::TraitFor::Model::DBIC::Schema::PerRequestSchema - Clone the schema
with attributes for each requests
=head1 SYNOPSIS
__PACKAGE__->config({
traits => ['PerRequestSchema'],
});
sub per_request_schema_attributes {
my ($self, $c) = @_;
return (restricting_object => $c->user->obj);
}
### OR ###
sub per_request_schema {
my ($self, $c) = @_;
return $self->schema->schema_method($c->user->obj)
}
=head1 DESCRIPTION
Clones the schema for each new request with the attributes retrieved from your
C method, which you must implement. This method
is passed the context.
Alternatively, you could also override the C method if you
need access to the schema clone and/or need to separate out the Model/Schema
methods. (See examples above and the defaults in the code.)
=cut
sub build_per_context_instance {
my ( $self, $ctx ) = @_;
return $self unless blessed($ctx);
my $new = bless {%$self}, ref $self;
$new->schema($new->per_request_schema($ctx));
return $new;
}
# Thanks to Matt Trout for this idea
sub per_request_schema {
my ($self, $c) = @_;
return $self->schema->clone($self->per_request_schema_attributes($c));
}
### TODO: This should probably be more elegant ###
sub per_request_schema_attributes {
confess "Either per_request_schema_attributes needs to be created, or per_request_schema needs to be overridden!";
}
=head1 SEE ALSO
L, L
=head1 AUTHOR
See L and
L.
=head1 COPYRIGHT
See L.
=head1 LICENSE
This program is free software, you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
1;
Catalyst-Model-DBIC-Schema-0.66/lib/Catalyst/Helper/Model/ 000755 000766 000024 00000000000 14461412703 023261 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/lib/Catalyst/Helper/Model/DBIC/ 000755 000766 000024 00000000000 14461412703 023762 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/lib/Catalyst/Helper/Model/DBIC/PaxHeader/Schema.pm 000644 000766 000024 00000000210 14461412240 027456 x ustar 00gknop staff 000000 000000 30 mtime=1690703008.254656629
57 LIBARCHIVE.xattr.com.apple.provenance=AQAAq1dlpUhBqgg
49 SCHILY.xattr.com.apple.provenance= «We„HAȘ
Catalyst-Model-DBIC-Schema-0.66/lib/Catalyst/Helper/Model/DBIC/Schema.pm 000644 000766 000024 00000050157 14461412240 025524 0 ustar 00gknop staff 000000 000000 package Catalyst::Helper::Model::DBIC::Schema;
use namespace::autoclean;
use Moose;
no warnings 'uninitialized';
our $VERSION = '0.66';
$VERSION =~ tr/_//d;
use Carp;
use Tie::IxHash ();
use Data::Dumper ();
use List::Util 'first';
use MooseX::Types::Moose qw/Str HashRef Bool ArrayRef/;
use Catalyst::Model::DBIC::Schema::Types 'CreateOption';
use List::MoreUtils 'firstidx';
use Scalar::Util 'looks_like_number';
use File::Find 'finddepth';
use Try::Tiny;
use Cwd 'getcwd';
use Module::Runtime 'use_module';
=head1 NAME
Catalyst::Helper::Model::DBIC::Schema - Helper for DBIC Schema Models
=head1 SYNOPSIS
script/create.pl model CatalystModelName DBIC::Schema MyApp::SchemaClass \
[ create=dynamic | create=static ] [ traits=trait1,trait2... ] \
[ Schema::Loader opts ] [ dsn user pass ] \
[ other connect_info args ]
=head1 DESCRIPTION
Helper for the DBIC Schema Models.
=head2 Arguments:
C is the short name for the Catalyst Model class
being generated (i.e. callable with C<$c-Emodel('CatalystModelName')>).
C is the fully qualified classname of your Schema,
which might or might not yet exist. Note that you should have a good
reason to create this under a new global namespace, otherwise use an
existing top level namespace for your schema class.
C instructs this Helper to generate the named Schema
class for you, basing it on L (which
means the table information will always be dynamically loaded at
runtime from the database).
C instructs this Helper to generate the named Schema
class for you, using L in "one shot"
mode to create a standard, manually-defined L
setup, based on what the Loader sees in your database at this moment.
A Schema/Model pair generated this way will not require
L at runtime, and will not automatically
adapt itself to changes in your database structure. You can edit
the generated classes by hand to refine them.
C is the list of traits to apply to the model, see
L for details.
C are documented in L
and some examples are given in L below.
C arguments are the same as what L
expects, and are storage_type-specific. They are documented in
L. For DBI-based storage, these
arguments are the dsn, username, password, and connect options, respectively.
These are optional for existing Schemas, but required if you use either of the
C options.
username and password can be omitted for C dsns.
Use of either of the C options requires L.
=head1 TYPICAL EXAMPLES
Use DBIx::Class::Schema::Loader to create a static DBIx::Class::Schema,
and a Model which references it:
script/myapp_create.pl model CatalystModelName DBIC::Schema \
MyApp::SchemaClass create=static dbi:mysql:foodb myuname mypass
Same, with extra connect_info args
user and pass can be omitted for sqlite, since they are always empty
script/myapp_create.pl model CatalystModelName DBIC::Schema \
MyApp::SchemaClass create=static dbi:SQLite:foo.db \
AutoCommit=1 cursor_class=DBIx::Class::Cursor::Cached \
on_connect_do='["select 1", "select 2"]' quote_names=1
B
In C the above example would be:
script/myapp_create.pl model CatalystModelName DBIC::Schema \
MyApp::SchemaClass create=static dbi:SQLite:foo.db \
AutoCommit=1 cursor_class=DBIx::Class::Cursor::Cached \
on_connect_do="[\"select 1\", \"select 2\"]" quote_names=1
Same, but with extra Schema::Loader args (separate multiple values by commas):
script/myapp_create.pl model CatalystModelName DBIC::Schema \
MyApp::SchemaClass create=static db_schema=foodb components=Foo,Bar \
exclude='^(wibble|wobble)$' moniker_map='{ foo => "FOO" }' \
dbi:Pg:dbname=foodb myuname mypass
Coderefs are also supported:
script/myapp_create.pl model CatalystModelName DBIC::Schema \
MyApp::SchemaClass create=static \
inflect_singular='sub { $_[0] =~ /\A(.+?)(_id)?\z/; $1 }' \
moniker_map='sub { join(q{}, map ucfirst, split(/[\W_]+/, lc $_[0])); }' \
dbi:mysql:foodb myuname mypass
See L for a list of options
Create a dynamic DBIx::Class::Schema::Loader-based Schema,
and a Model which references it (B):
script/myapp_create.pl model CatalystModelName DBIC::Schema \
MyApp::SchemaClass create=dynamic dbi:mysql:foodb myuname mypass
Reference an existing Schema of any kind, and provide some connection information for ->config:
script/myapp_create.pl model CatalystModelName DBIC::Schema \
MyApp::SchemaClass dbi:mysql:foodb myuname mypass
Same, but don't supply connect information yet (you'll need to do this
in your app config, or [not recommended] in the schema itself).
script/myapp_create.pl model ModelName DBIC::Schema My::SchemaClass
=cut
has helper => (is => 'ro', isa => 'Catalyst::Helper', required => 1);
has create => (is => 'rw', isa => CreateOption);
has args => (is => 'ro', isa => ArrayRef);
has traits => (is => 'rw', isa => ArrayRef);
has schema_class => (is => 'ro', isa => Str, required => 1);
has loader_args => (is => 'rw', isa => HashRef);
has connect_info => (is => 'rw', isa => HashRef);
has old_schema => (is => 'rw', isa => Bool, lazy_build => 1);
has is_moose_schema => (is => 'rw', isa => Bool, lazy_build => 1);
has result_namespace => (is => 'rw', isa => Str, lazy_build => 1);
has components => (is => 'rw', isa => ArrayRef);
=head1 METHODS
=head2 mk_compclass
This is called by L with the commandline args to generate the
files.
=cut
sub mk_compclass {
my ($package, $helper, $schema_class, @args) = @_;
my $self = $package->new(
helper => $helper,
schema_class => $schema_class,
args => \@args
);
$self->run;
}
sub BUILD {
my $self = shift;
my $helper = $self->helper;
my @args = @{ $self->args || [] };
$helper->{schema_class} = $self->schema_class;
@args = $self->_cleanup_args(\@args);
my ($traits_idx, $traits);
if (($traits_idx = firstidx { ($traits) = /^traits=(\S*)\z/ } @args) != -1) {
my @traits = split /,/ => $traits;
$self->traits(\@traits);
$helper->{traits} = '['
.(join ',' => map { qq{'$_'} } @traits)
.']';
splice @args, $traits_idx, 1, ();
}
if ($args[0] && $args[0] =~ /^create=(\S*)\z/) {
$self->create($1);
shift @args;
if (@args) {
$self->_parse_loader_args(\@args);
$helper->{loader_args} = $self->_build_helper_loader_args;
}
}
my $dbi_dsn_part;
if (first { ($dbi_dsn_part) = /^(dbi):/i } @args) {
die
qq{DSN must start with 'dbi:' not '$dbi_dsn_part' (case matters!)}
if $dbi_dsn_part ne 'dbi';
$helper->{setup_connect_info} = 1;
$helper->{connect_info} =
$self->_build_helper_connect_info(\@args);
$self->_parse_connect_info(\@args);
}
$helper->{generator} = ref $self;
$helper->{generator_version} = $VERSION;
}
=head2 run
Can be called on an instance to generate the files.
=cut
sub run {
my $self = shift;
if ($self->create eq 'dynamic') {
$self->_print_dynamic_deprecation_warning;
$self->_gen_dynamic_schema;
} elsif ($self->create eq 'static') {
$self->_gen_static_schema;
}
$self->_gen_model;
}
sub _parse_loader_args {
my ($self, $args) = @_;
my %loader_args = $self->_read_loader_args($args);
while (my ($key, $val) = each %loader_args) {
next if $key =~ /^(?:components|constraint|exclude)\z/;
$loader_args{$key} = $self->_eval($val);
die "syntax error for loader args key '$key' with value '$val': $@"
if $@;
}
my @components = $self->_build_loader_components(
delete $loader_args{components},
$loader_args{use_namespaces},
);
$self->components(\@components);
for my $re_opt (qw/constraint exclude/) {
$loader_args{$re_opt} = qr/$loader_args{$re_opt}/
if exists $loader_args{$re_opt};
}
tie my %result, 'Tie::IxHash';
%result = (
relationships => 1,
use_moose => $self->is_moose_schema ? 1 : 0,
col_collision_map => 'column_%s',
(!$self->old_schema ? (
use_namespaces => 1
) : ()),
(@components ? (
components => \@components
) : ()),
(%loader_args ? %loader_args : ()),
);
$self->loader_args(\%result);
wantarray ? %result : \%result;
}
sub _read_loader_args {
my ($self, $args) = @_;
my %loader_args;
while (@$args && $args->[0] !~ /^dbi:/i) {
my ($key, $val) = split /=/, shift(@$args), 2;
if ($self->_is_struct($val)) {
$loader_args{$key} = $val;
} elsif ((my @vals = split /,/ => $val) > 1) {
$loader_args{$key} = \@vals;
} else {
$loader_args{$key} = $val;
}
}
# Use args after connect_info as loader args as well, because people always
# get the order confused.
my $i = 1;
if ($args->[0] =~ /sqlite/i) {
$i++ if $args->[$i] eq '';
$i++ if $args->[$i] eq '';
}
else {
$i += 2;
}
my $have_loader = try {
use_module('DBIx::Class::Schema::Loader::Base');
1;
};
if ($have_loader) {
while (defined $args->[$i]) {
$i++ while $self->_is_struct($args->[$i]);
last if not defined $args->[$i];
my ($key, $val) = split /=/, $args->[$i], 2;
if (not DBIx::Class::Schema::Loader::Base->can($key)) {
$i++;
next;
}
if ($self->_is_struct($val)) {
$loader_args{$key} = $val;
} elsif ((my @vals = split /,/ => $val) > 1) {
$loader_args{$key} = \@vals;
} else {
$loader_args{$key} = $val;
}
splice @$args, $i, 1;
}
}
wantarray ? %loader_args : \%loader_args;
}
sub _build_helper_loader_args {
my $self = shift;
my $args = $self->loader_args;
tie my %loader_args, 'Tie::IxHash';
while (my ($arg, $val) = each %$args) {
if (ref $val) {
$loader_args{$arg} = $self->_data_struct_to_string($val);
} else {
$loader_args{$arg} = qq{'$val'};
}
}
\%loader_args
}
sub _build_loader_components {
my ($self, $components, $use_namespaces) = @_;
my @components = $self->old_schema && (not $use_namespaces) ? ()
: ('InflateColumn::DateTime');
if ($components) {
$components = [ $components ] if !ref $components;
push @components, @$components;
}
wantarray ? @components : \@components;
}
sub _build_helper_connect_info {
my ($self, $connect_info) = @_;
my @connect_info = @$connect_info;
my ($dsn, $user, $password) = $self->_get_dsn_user_pass(\@connect_info);
tie my %helper_connect_info, 'Tie::IxHash';
%helper_connect_info = (
dsn => qq{'$dsn'},
user => qq{'$user'},
password => qq{'$password'}
);
for (@connect_info) {
if (/^\s*{.*}\s*\z/) {
my $hash = $self->_eval($_);
die "Syntax errorr in connect_info hash: $_: $@" if $@;
my %hash = %$hash;
for my $key (keys %hash) {
my $val = $hash{$key};
if (ref $val) {
$val = $self->_data_struct_to_string($val);
} else {
$val = $self->_quote($val);
}
$helper_connect_info{$key} = $val;
}
next;
}
my ($key, $val) = split /=/, $_, 2;
if ($key eq 'quote_char') {
$helper_connect_info{$key} = length($val) == 1 ?
$self->_quote($val) :
$self->_data_struct_to_string([split //, $val]);
} else {
$helper_connect_info{$key} = $self->_quote_unless_struct($val);
}
}
\%helper_connect_info
}
sub _build_old_schema {
my $self = shift;
return $self->result_namespace eq '' ? 1 : 0;
}
sub _build_is_moose_schema {
my $self = shift;
my @schema_parts = split '::', $self->schema_class;
my $result_dir = File::Spec->catfile(
$self->helper->{base}, 'lib', @schema_parts, $self->result_namespace
);
# assume yes for new schemas
return 1 if not -d $result_dir;
my $uses_moose = 1;
my $cwd = getcwd;
try {
finddepth(sub {
return if $File::Find::name !~ /\.pm\z/;
open my $fh, '<', $File::Find::name
or die "Could not open $File::Find::name: $!";
my $code = do { local $/; <$fh> };
close $fh;
$uses_moose = 0 if $code !~ /\nuse Moose;\n/;
die;
}, $result_dir);
};
chdir $cwd;
return $uses_moose;
}
sub _build_result_namespace {
my $self = shift;
my @schema_parts = split '::', $self->schema_class;
my $schema_pm =
File::Spec->catfile($self->helper->{base}, 'lib', @schema_parts) . '.pm';
if (not -f $schema_pm) {
eval { use_module('DBIx::Class::Schema::Loader') };
return 'Result' if $@;
return (try { DBIx::Class::Schema::Loader->VERSION('0.05') }) ? 'Result' : '';
}
open my $fh, '<', $schema_pm or die "Could not open $schema_pm: $!";
my $code = do { local $/; <$fh> };
close $fh;
my ($result_namespace) = $code =~ /result_namespace => '([^']+)'/;
return $result_namespace if $result_namespace;
return '' if $code =~ /->load_classes/;
return 'Result';
}
sub _data_struct_to_string {
my ($self, $data) = @_;
local $Data::Dumper::Terse = 1;
local $Data::Dumper::Quotekeys = 0;
local $Data::Dumper::Sortkeys = 1;
local $Data::Dumper::Indent = 0;
local $Data::Dumper::Useqq = 1;
return Data::Dumper->Dump([$data]);
}
sub _get_dsn_user_pass {
my ($self, $connect_info) = @_;
my $dsn = shift @$connect_info;
my ($user, $password);
if ($dsn =~ /sqlite/i) {
($user, $password) = ('', '');
shift @$connect_info while @$connect_info and $connect_info->[0] eq '';
} else {
($user, $password) = splice @$connect_info, 0, 2;
}
($dsn, $user, $password)
}
sub _parse_connect_info {
my ($self, $connect_info) = @_;
my @connect_info = @$connect_info;
my ($dsn, $user, $password) = $self->_get_dsn_user_pass(\@connect_info);
tie my %connect_info, 'Tie::IxHash';
@connect_info{qw/dsn user password/} = ($dsn, $user, $password);
for (@connect_info) {
if (/^\s*{.*}\s*\z/) {
my $hash = $self->_eval($_);
die "Syntax errorr in connect_info hash: $_: $@" if $@;
%connect_info = (%connect_info, %$hash);
next;
}
my ($key, $val) = split /=/, $_, 2;
if ($key eq 'quote_char') {
$connect_info{$key} = length($val) == 1 ? $val : [split //, $val];
} elsif ($key =~ /^(?:name_sep|limit_dialect)\z/) {
$connect_info{$key} = $val;
} else {
$connect_info{$key} = $self->_eval($val);
}
die "syntax error for connect_info key '$key' with value '$val': $@"
if $@;
}
$self->connect_info(\%connect_info);
\%connect_info
}
sub _is_struct {
my ($self, $val) = @_;
return $val =~ /^\s*(?:sub|[[{])/;
}
sub _quote {
my ($self, $val) = @_;
return 'q{'.$val.'}';
}
sub _quote_unless_struct {
my ($self, $val) = @_;
$val = $self->_quote($val) if not $self->_is_struct($val);
return $val;
}
sub _eval {
my ($self, $code) = @_;
return $code if looks_like_number $code;
return $code if not $self->_is_struct($code);
return eval "{no strict; $code}";
}
sub _gen_dynamic_schema {
my $self = shift;
my $helper = $self->helper;
my @schema_parts = split(/\:\:/, $self->schema_class);
my $schema_file_part = pop @schema_parts;
my $schema_dir = File::Spec->catfile(
$helper->{base}, 'lib', @schema_parts
);
my $schema_file = File::Spec->catfile(
$schema_dir, $schema_file_part . '.pm'
);
$helper->mk_dir($schema_dir);
$helper->render_file('schemaclass', $schema_file);
}
sub _gen_static_schema {
my $self = shift;
die "cannot load schema without connect info" unless $self->connect_info;
my $helper = $self->helper;
my $schema_dir = File::Spec->catfile($helper->{base}, 'lib');
try {
use_module('DBIx::Class::Schema::Loader')
}
catch {
die "Cannot load DBIx::Class::Schema::Loader: $_";
};
DBIx::Class::Schema::Loader->import(
"dump_to_dir:$schema_dir", 'make_schema_at'
);
make_schema_at(
$self->schema_class,
$self->loader_args,
[$self->connect_info]
);
require lib;
lib->import($schema_dir);
use_module($self->schema_class);
my @sources = $self->schema_class->sources;
if (not @sources) {
warn <<'EOF';
WARNING: No tables found, did you forget to specify db_schema?
EOF
}
}
sub _gen_model {
my $self = shift;
my $helper = $self->helper;
$helper->render_file('compclass', $helper->{file} );
}
sub _print_dynamic_deprecation_warning {
warn <);
exit 0 if $response =~ /^n(o)?\z/;
}
sub _cleanup_args {
my ($self, $args) = @_;
# remove blanks, ie. someoned doing foo \ bar
my @res = grep !/^\s+\z/, @$args;
# remove leading whitespace, ie. foo \ bar
s/^\s*// for @res;
@res
}
=head1 SEE ALSO
General Catalyst Stuff:
L, L, L,
L, L, L,
Stuff related to DBIC and this Model style:
L, L,
L, L
=head1 AUTHOR
See L and
L.
=head1 COPYRIGHT
See L.
=head1 LICENSE
This library is free software, you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
1;
__DATA__
=begin pod_to_ignore
__schemaclass__
package [% schema_class %];
use strict;
use base qw/DBIx::Class::Schema::Loader/;
__PACKAGE__->loader_options(
[%- FOREACH key = loader_args.keys %]
[% key %] => [% loader_args.${key} %],
[%- END -%]
);
=head1 NAME
[% schema_class %] - L class
=head1 SYNOPSIS
See L<[% app %]>
=head1 DESCRIPTION
Dynamic L schema for use in L<[% class %]>
=head1 GENERATED BY
[% generator %] - [% generator_version %]
=head1 AUTHOR
[% author.replace(',+$', '') %]
=head1 LICENSE
This library is free software, you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
1;
__compclass__
package [% class %];
use strict;
use base 'Catalyst::Model::DBIC::Schema';
__PACKAGE__->config(
schema_class => '[% schema_class %]',
[% IF traits %]traits => [% traits %],[% END %]
[% IF setup_connect_info %]connect_info => {
[%- FOREACH key = connect_info.keys %]
[% key %] => [% connect_info.${key} %],
[%- END -%]
}[% END %]
);
=head1 NAME
[% class %] - Catalyst DBIC Schema Model
=head1 SYNOPSIS
See L<[% app %]>
=head1 DESCRIPTION
L Model using schema L<[% schema_class %]>
=head1 GENERATED BY
[% generator %] - [% generator_version %]
=head1 AUTHOR
[% author.replace(',+$', '') %]
=head1 LICENSE
This library is free software, you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
1;
__END__
# vim:sts=4 sw=4:
Catalyst-Model-DBIC-Schema-0.66/t/02pod.t 000644 000766 000024 00000000277 14461407424 020036 0 ustar 00gknop staff 000000 000000 use Test::More;
eval "use Test::Pod 1.14";
plan skip_all => 'Test::Pod 1.14 required' if $@;
plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD};
all_pod_files_ok();
Catalyst-Model-DBIC-Schema-0.66/t/01use.t 000644 000766 000024 00000000224 14461407424 020037 0 ustar 00gknop staff 000000 000000 use strict;
use Test::More tests => 2;
BEGIN { use_ok('Catalyst::Model::DBIC::Schema') }
BEGIN { use_ok('Catalyst::Helper::Model::DBIC::Schema') }
Catalyst-Model-DBIC-Schema-0.66/t/07connect_info.t 000644 000766 000024 00000006051 14461407424 021721 0 ustar 00gknop staff 000000 000000 use strict;
use warnings;
use FindBin '$Bin';
use lib "$Bin/lib";
use Test::More;
use Test::Exception;
use Catalyst::Model::DBIC::Schema;
use ASchemaClass;
# execise the connect_info coercion
my $coderef = sub {};
my @tests = (
['dbi:SQLite:foo.db', '', ''],
{ dsn => 'dbi:SQLite:foo.db', user => '', password => '' },
['dbi:SQLite:foo.db', ''],
{ dsn => 'dbi:SQLite:foo.db', user => '', password => '' },
['dbi:SQLite:foo.db'],
{ dsn => 'dbi:SQLite:foo.db', user => '', password => '' },
'dbi:SQLite:foo.db',
{ dsn => 'dbi:SQLite:foo.db', user => '', password => '' },
['dbi:Pg:dbname=foo', 'user', 'pass',
{ pg_enable_utf8 => 1, auto_savepoint => 1 }],
{ dsn => 'dbi:Pg:dbname=foo', user => 'user', password => 'pass',
pg_enable_utf8 => 1, auto_savepoint => 1 },
['dbi:Pg:dbname=foo', 'user', 'pass',
{ pg_enable_utf8 => 1 }, { auto_savepoint => 1 }],
{ dsn => 'dbi:Pg:dbname=foo', user => 'user', password => 'pass',
pg_enable_utf8 => 1, auto_savepoint => 1 },
[ { dsn => 'dbi:Pg:dbname=foo', user => 'user', password => 'pass',
pg_enable_utf8 => 1, auto_savepoint => 1 } ],
{ dsn => 'dbi:Pg:dbname=foo', user => 'user', password => 'pass',
pg_enable_utf8 => 1, auto_savepoint => 1 },
[$coderef, { pg_enable_utf8 => 1, auto_savepoint => 1 }],
{ dbh_maker => $coderef, pg_enable_utf8 => 1, auto_savepoint => 1 },
);
my @invalid = (
{ foo => 'bar' },
[ { foo => 'bar' } ],
['dbi:Pg:dbname=foo', 'user', 'pass',
{ pg_enable_utf8 => 1 }, { AutoCommit => 1 }, { auto_savepoint => 1 }],
);
# ignore redefined warnings, and uninitialized warnings from old
# ::Storage::DBI::Replicated
local $SIG{__WARN__} = sub {
$_[0] !~ /(?:redefined|uninitialized)/i && warn @_
};
for (my $i = 0; $i < @tests; $i += 2) {
my $m = instance(
connect_info => $tests[$i]
);
is_deeply $m->connect_info, $tests[$i+1],
'connect_info coerced correctly';
}
throws_ok { instance(connect_info => $_) } qr/valid connect_info/i,
'invalid connect_info throws exception'
for @invalid;
# try as ConnectInfos (e.g.: replicants)
my @replicants = map $tests[$_], grep $_ % 2 == 0, 0..$#tests;
{
package TryConnectInfos;
use Moose;
use Catalyst::Model::DBIC::Schema::Types 'ConnectInfos';
has replicants => (is => 'ro', isa => ConnectInfos, coerce => 1);
}
my $m = TryConnectInfos->new(
replicants => \@replicants
);
lives_and {
is_deeply(TryConnectInfos->new(replicants => $tests[1])->replicants,
[ $tests[1] ])
} 'single replicant hashref coerces correctly';
is_deeply $m->replicants, [
map $tests[$_], grep $_ % 2, 0 .. $#tests
], 'replicant connect_infos coerced correctly';
{
ASchemaClass->connection( @{$tests[0]} );
my $m = instance();
is_deeply $m->connect_info, $tests[1],
'connect_info coerced correctly when defining connection in the schema class';
}
done_testing;
sub instance {
Catalyst::Model::DBIC::Schema->new({
schema_class => 'ASchemaClass',
@_
})
}
Catalyst-Model-DBIC-Schema-0.66/t/10literal_sql_through_accessor.t 000644 000766 000024 00000002366 14461407424 025211 0 ustar 00gknop staff 000000 000000 use strict;
use warnings;
use Test::More;
use Test::Exception;
use FindBin;
use lib "$FindBin::Bin/lib";
use File::Spec::Functions 'catfile';
use DBI;
my $test_dir = $FindBin::Bin;
my $db = catfile($test_dir, 'testdb.db');
my $dbh = DBI->connect("dbi:SQLite:$db", '', '', {
RaiseError => 1, PrintError => 0
});
$dbh->do(<<'EOF');
create table users (
id integer primary key,
first_name varchar(100),
middle_name varchar(100),
last_name varchar(100),
email_address varchar(100)
)
EOF
$dbh->disconnect;
my $model = instance();
my $rs = $model->resultset('User');
my $row = $rs->create({ first_name => 'Foo', last_name => 'Bar' });
$row->first_name(\['last_name']);
lives_ok {
$row->update;
} 'update survived';
$row->discard_changes;
is $row->first_name, 'Bar',
'row updated with literal SQL through accessor';
done_testing;
sub instance {
MyApp::Model::DB->COMPONENT('MyApp', {
schema_class => 'ASchemaClass',
connect_info => ["dbi:SQLite:$db", '', ''],
@_,
})
}
{
package MyApp;
use Catalyst;
}
{
package MyApp::Model::DB;
use base 'Catalyst::Model::DBIC::Schema';
}
END {
$model->storage->disconnect if $model;
unlink $db or die "Could not delete $db: $!";
}
Catalyst-Model-DBIC-Schema-0.66/t/09schema_options.t 000644 000766 000024 00000002366 14461407424 022277 0 ustar 00gknop staff 000000 000000 use strict;
use warnings;
use FindBin '$Bin';
use lib "$Bin/lib";
use Test::More;
use Test::Exception;
use Catalyst::Model::DBIC::Schema;
use ASchemaClass;
use AnotherSchemaClass;
# reusing the same app for 2 models, gets a redefined warning
$SIG{__WARN__} = sub { warn $_[0] unless $_[0] =~ /redefined/ };
ok((my $m = instance(a_schema_option => 'mtfnpy')), 'instance');
is $m->schema->a_schema_option, 'mtfnpy', 'option was passed from config';
lives_ok { $m->a_schema_option('pass the crack pipe') } 'delegate called';
is $m->schema->a_schema_option, 'pass the crack pipe', 'delegation works';
ok(($m = instance(schema_class => 'AnotherSchemaClass')), 'instance');
is $m->resultset('User')->rs_config_option, 'configured rs value',
'ResultSet option passed from config';
done_testing;
sub instance {
MyApp::Model::DB->COMPONENT('MyApp', {
traits => 'SchemaProxy',
schema_class => 'ASchemaClass',
connect_info => ['dbi:SQLite:foo.db', '', ''],
@_,
})
}
BEGIN {
package MyApp;
use Catalyst;
__PACKAGE__->config({
'Model::DB::User' => {
rs_config_option => 'configured rs value',
},
});
}
{
package MyApp::Model::DB;
use base 'Catalyst::Model::DBIC::Schema';
}
Catalyst-Model-DBIC-Schema-0.66/t/05testapp.t 000644 000766 000024 00000015104 14461407424 020732 0 ustar 00gknop staff 000000 000000 use strict;
use Test::More;
use FindBin;
use File::Spec::Functions qw/catfile catdir/;
use File::Find;
use Config;
use DBI;
use IPC::Open3 'open3';
plan skip_all => 'Enable this optional test with $ENV{C_M_DBIC_SCHEMA_TESTAPP}'
unless $ENV{C_M_DBIC_SCHEMA_TESTAPP};
my $test_params = [
[ 'TestSchema', 'DBIC::Schema', '' ],
[ 'TestSchemaDSN', 'DBIC::Schema', qw/fakedsn fakeuser fakepass/, '{ AutoCommit => 1 }' ],
[ 'TestSchemaDSN', 'DBIC::Schema', 'create=static', 'traits=Caching', q|moniker_map={ roles => 'ROLE' }|, 'constraint=^users\z', 'dbi:SQLite:testdb.db' ],
[ 'TestSchemaDSN', 'DBIC::Schema', 'create=static', 'traits=Caching', q|moniker_map={ roles => 'ROLE' }|, 'constraint=^users\z', 'dbi:SQLite:testdb.db', '', '', q|on_connect_do=['select 1', 'select 2']| ],
[ 'TestSchemaDSN', 'DBIC::Schema', 'create=static', 'traits=Caching', q|moniker_map={ roles => 'ROLE' }|, 'dbi:SQLite:testdb.db', q|on_connect_do=['select 1', 'select 2']| ],
[ 'TestSchemaDSN', 'DBIC::Schema', 'create=static', 'traits=Caching', 'inflect_singular=sub { $_[0] =~ /\A(.+?)(_id)?\z/; $1 }', q{moniker_map=sub { return join('', map ucfirst, split(/[\W_]+/, lc $_[0])); }}, 'dbi:SQLite:testdb.db' ],
];
my $test_dir = $FindBin::Bin;
my $blib_dir = catdir ($test_dir, '..', 'blib', 'lib');
my $cat_dir = catdir ($test_dir, 'TestApp');
my $catlib_dir = catdir ($cat_dir, 'lib');
my $schema_dir = catdir ($catlib_dir, 'TestSchemaDSN');
my $creator = catfile($cat_dir, 'script', 'testapp_create.pl');
my $model_dir = catdir ($catlib_dir, 'TestApp', 'Model');
my $db = catfile($cat_dir, 'testdb.db');
my $catalyst_pl;
foreach my $bin (split /(?:$Config{path_sep}|:)/, $ENV{PATH}) {
my $file = catfile($bin, 'catalyst.pl');
if (-f $file) {
$catalyst_pl = $file;
last;
}
}
plan skip_all => 'catalyst.pl not found' unless $catalyst_pl;
chdir($test_dir);
silent_exec("$^X $catalyst_pl TestApp");
chdir($cat_dir);
# create test db
my $dbh = DBI->connect("dbi:SQLite:$db", '', '', {
RaiseError => 1, PrintError => 0
});
$dbh->do(<<'EOF');
CREATE TABLE users (
id INTEGER PRIMARY KEY,
username TEXT,
password TEXT,
email_address TEXT,
first_name TEXT,
last_name TEXT,
active INTEGER
);
EOF
$dbh->do(<<'EOF');
CREATE TABLE roles (
id INTEGER PRIMARY KEY,
role TEXT
);
EOF
$dbh->disconnect;
foreach my $tparam (@$test_params) {
my ($model, $helper, @args) = @$tparam;
cleanup_schema();
silent_exec($^X, "-I$blib_dir", $creator, 'model', $model, $helper, $model, @args);
my $model_path = catfile($model_dir, $model . '.pm');
ok( -f $model_path, "$model_path is a file" );
my $compile_rv = silent_exec($^X, "-I$blib_dir", "-I$catlib_dir", "-c", $model_path);
ok($compile_rv == 0, "perl -c $model_path");
if (grep /create=static/, @args) {
my @result_files = result_files();
if (grep /constraint/, @args) {
is scalar @result_files, 1, 'constraint works';
} else {
is scalar @result_files, 2, 'correct number of tables';
}
for my $file (@result_files) {
my $code = code_for($file);
like $code, qr/use Moose;\n/, 'use_moose enabled';
like $code, qr/__PACKAGE__->meta->make_immutable;\n/, 'use_moose enabled';
}
}
}
# Test that use_moose=1 is not applied to existing non-moose schemas (RT#60558)
{
cleanup_schema();
silent_exec($^X, "-I$blib_dir", $creator, 'model',
'TestSchemaDSN', 'DBIC::Schema', 'TestSchemaDSN',
'create=static', 'use_moose=0', 'dbi:SQLite:testdb.db'
);
my @result_files = result_files();
for my $file (@result_files) {
my $code = code_for($file);
unlike $code, qr/use Moose;\n/, 'non use_moose=1 schema';
unlike $code, qr/__PACKAGE__->meta->make_immutable;\n/, 'non use_moose=1 schema';
}
silent_exec($^X, "-I$blib_dir", $creator, 'model',
'TestSchemaDSN', 'DBIC::Schema', 'TestSchemaDSN',
'create=static', 'dbi:SQLite:testdb.db'
);
for my $file (@result_files) {
my $code = code_for($file);
unlike $code, qr/use Moose;\n/,
'non use_moose=1 schema not upgraded to use_moose=1';
unlike $code, qr/__PACKAGE__->meta->make_immutable;\n/,
'non use_moose=1 schema not upgraded to use_moose=1';
}
}
# Test that a moose schema is not detected as a non-moose schema due to an
# errant file.
{
cleanup_schema();
silent_exec($^X, "-I$blib_dir", $creator, 'model',
'TestSchemaDSN', 'DBIC::Schema', 'TestSchemaDSN',
'create=static', 'dbi:SQLite:testdb.db'
);
mkdir "$schema_dir/.svn";
open my $fh, '>', "$schema_dir/.svn/foo"
or die "Could not open $schema_dir/.svn/foo for writing: $!";
print $fh "gargle\n";
close $fh;
mkdir "$schema_dir/Result/.svn";
open $fh, '>', "$schema_dir/Result/.svn/foo"
or die "Could not open $schema_dir/Result/.svn/foo for writing: $!";
print $fh "hlagh\n";
close $fh;
silent_exec($^X, "-I$blib_dir", $creator, 'model',
'TestSchemaDSN', 'DBIC::Schema', 'TestSchemaDSN',
'create=static', 'dbi:SQLite:testdb.db'
);
for my $file (result_files()) {
my $code = code_for($file);
like $code, qr/use Moose;\n/,
'use_moose detection not confused by version control files';
like $code, qr/__PACKAGE__->meta->make_immutable;\n/,
'use_moose detection not confused by version control files';
}
}
done_testing;
sub rm_rf {
my $name = $File::Find::name;
if(-d $name) { rmdir $name or warn "Cannot rmdir $name: $!" }
else { unlink $name or die "Cannot unlink $name: $!" }
}
sub cleanup_schema {
return unless -d $schema_dir;
finddepth({ wanted => \&rm_rf, no_chdir => 1 }, $schema_dir);
unlink "${schema_dir}.pm";
}
sub code_for {
my $file = shift;
open my $fh, '<', $file;
my $code = do { local $/; <$fh> };
close $fh;
return $code;
}
sub result_files {
my $result_dir = catfile($schema_dir, 'Result');
my @results;
opendir my $dir, $result_dir
or die "Could not open $result_dir: $!";
while (my $file = readdir $dir) {
next unless $file =~ /\.pm\z/;
push @results, catfile($result_dir, $file);
}
closedir $dir;
return @results;
}
sub silent_exec {
local *NULL;
open NULL, '+<', File::Spec->devnull;
my $pid = open3('<&NULL', '>&NULL', '>&NULL', @_);
waitpid $pid, 0;
return $?;
}
END {
if ($ENV{C_M_DBIC_SCHEMA_TESTAPP}) {
chdir($test_dir);
finddepth({ wanted => \&rm_rf, no_chdir => 1 }, $cat_dir);
}
}
# vim:sts=3 sw=3 et tw=80:
Catalyst-Model-DBIC-Schema-0.66/t/08helper.t 000644 000766 000024 00000014306 14461407424 020537 0 ustar 00gknop staff 000000 000000 use strict;
use warnings;
use FindBin '$Bin';
use lib "$Bin/lib";
use Test::More;
use Test::Exception;
use Catalyst::Helper::Model::DBIC::Schema;
use Storable 'dclone';
use Data::Dumper;
use Test::Requires qw(Catalyst::Helper DBIx::Class::Schema::Loader);
my $helper = Catalyst::Helper->new;
$helper->{base} = $Bin;
my $static = 'create=static';
my $dynamic = 'create=dynamic';
my $sqlite = 'dbi:SQLite:myapp.db';
my $pg = 'dbi:Pg:dbname=foo';
my $on_connect_do = 'on_connect_do=["select 1", "select 2"]';
my $quote_char = 'quote_char="';
my $name_sep = 'name_sep=.';
my $i;
$i = instance(schema_class => 'ASchemaClass');
is $i->old_schema, 1, '->load_classes detected correctly';
throws_ok { $i = instance(args => [$static, 'DbI:SQLite:myapp.db']) }
qr/case matters/i, "wrong case for 'dbi:' DSN part";
$i = instance(args => ['traits=Caching']);
is_deeply $i->traits, ['Caching'], 'one trait';
is $i->helper->{traits}, "['Caching']", 'one trait as string';
$i = instance(args => ['traits=Caching,Replicated']);
is_deeply $i->traits, ['Caching', 'Replicated'], 'two traits';
is $i->helper->{traits}, "['Caching','Replicated']", 'two traits as string';
$i = instance(args => [$static]);
is $i->create, 'static', 'create=static';
$i = instance(args => [$static,
q{moniker_map={ authors => "AUTHORS", books => "BOOKS" }}]
);
is_deeply $i->loader_args->{moniker_map},
{ authors => 'AUTHORS', books => 'BOOKS' },
'loader hash arg';
is $i->helper->{loader_args}{moniker_map},
q{{authors => "AUTHORS",books => "BOOKS"}},
'loader hash arg as string';
$i = instance(args => [$static, q{foo=["bar","baz"]}]);
is_deeply $i->loader_args->{foo}, ['bar', 'baz'], 'loader array arg';
is $i->helper->{loader_args}{foo},
q{["bar","baz"]},
'loader array arg as string';
$i = instance(args => [$static, q{components=TimeStamp}]);
is_deeply $i->components, ['InflateColumn::DateTime', 'TimeStamp'],
'extra component';
is $i->helper->{loader_args}{components},
q{["InflateColumn::DateTime","TimeStamp"]},
'components as string';
$i = instance(
schema_class => 'ASchemaClass',
args => [$static, q{components=TimeStamp}]
);
is_deeply $i->components, ['TimeStamp'],
'extra component with ->load_classes';
$i = instance(args => [$static, q{components=TimeStamp,Foo}]);
is_deeply $i->components, ['InflateColumn::DateTime', 'TimeStamp', 'Foo'],
'two extra components';
# Different versions of perl and Data::Dumper serialise regexes differently
my ($flagstart, $flagend, $postflag) = Dumper(qr//) =~ m{qr/(.*?)(\)?)/([a-z]*)};
$i = instance(args => [$static, q{constraint=^(foo|bar)$}]);
is $i->loader_args->{constraint}, qr/^(foo|bar)$/,
'constraint loader arg';
is $i->helper->{loader_args}{constraint},
qq{qr/$flagstart^(foo|bar)\$$flagend/$postflag},
'constraint loader arg as string';
$i = instance(args => [$static, q{exclude=^(foo|bar)$}]);
is $i->loader_args->{exclude}, qr/^(foo|bar)$/,
'exclude loader arg';
$i = instance(args => [$static, q{db_schema=foo;bar::baz/quux}]);
is $i->loader_args->{db_schema}, q{foo;bar::baz/quux},
'simple value loader arg';
$i = instance(args => [
$static, 'components=TimeStamp', $sqlite, $on_connect_do,
$quote_char, $name_sep
]);
is_deeply $i->components, ['InflateColumn::DateTime', 'TimeStamp'],
'extra component';
is $i->connect_info->{dsn}, $sqlite, 'connect_info dsn';
is $i->connect_info->{user}, '', 'sqlite omitted user';
is $i->connect_info->{password}, '', 'sqlite omitted password';
is_deeply $i->connect_info->{on_connect_do},
['select 1', 'select 2'], 'connect_info data struct';
is $i->helper->{connect_info}{on_connect_do},
q{["select 1", "select 2"]}, 'connect_info data struct as string';
is $i->connect_info->{quote_char}, '"', 'connect_info quote_char';
is $i->helper->{connect_info}{quote_char}, 'q{"}',
'connect_info quote_char as string';
is $i->connect_info->{name_sep}, '.', 'connect_info name_sep';
is $i->helper->{connect_info}{name_sep}, 'q{.}',
'connect_info name_sep as string';
$i = instance(args => [
$static, $sqlite, 'on_connect_do=PRAGMA foreign_keys = ON'
]);
is $i->connect_info->{on_connect_do},
'PRAGMA foreign_keys = ON', 'on_connect_do string';
is $i->helper->{connect_info}{on_connect_do},
'q{PRAGMA foreign_keys = ON}', 'on_connect_do string as string';
$i = instance(args => [
$static, 'components=TimeStamp', $sqlite, '', $on_connect_do,
$quote_char, $name_sep
]);
is $i->connect_info->{dsn}, $sqlite, 'connect_info dsn';
is $i->connect_info->{user}, '', 'sqlite user';
is $i->connect_info->{password}, '', 'sqlite omitted password';
$i = instance(args => [
$static, 'components=TimeStamp', $pg, 'user', 'pass', $on_connect_do,
$quote_char, $name_sep
]);
is $i->connect_info->{dsn}, $pg, 'connect_info dsn';
is $i->connect_info->{user}, 'user', 'user';
is $i->connect_info->{password}, 'pass', 'password';
$i = instance(args => [
$static, $pg, 'user', 'pass', 'quote_char=[]', $name_sep
]);
is_deeply $i->connect_info->{quote_char}, ['[', ']'],
'2 character quote_char';
is $i->helper->{connect_info}{quote_char}, '["[","]"]',
'2 character quote_char as string';
$i = instance(args => [
$static, 'components=TimeStamp', $sqlite, $on_connect_do,
$quote_char, $name_sep, '{ auto_savepoint => 1, AutoCommit => 0 }'
]);
is $i->connect_info->{auto_savepoint}, 1, 'connect_info arg from extra hash';
is $i->connect_info->{AutoCommit}, 0, 'connect_info arg from extra hash';
is $i->helper->{connect_info}{auto_savepoint}, 'q{1}',
'connect_info arg from extra hash as string';
is $i->helper->{connect_info}{AutoCommit}, 'q{0}',
'connect_info arg from extra hash as string';
$i = instance(args => [
$static, 'components=TimeStamp', $sqlite, $on_connect_do,
$quote_char, $name_sep, 'auto_savepoint=1', 'AutoCommit=0',
'db_schema=myschema',
]);
is $i->loader_args->{db_schema}, 'myschema',
'loader arg after connect_info';
ok ((not exists $i->helper->{connect_info}{db_schema}),
'loader args removed from connect_info');
done_testing;
sub instance {
Catalyst::Helper::Model::DBIC::Schema->new(
schema_class => 'AnotherSchemaClass',
helper => dclone($helper),
args => ['create=static'],
@_
)
}
Catalyst-Model-DBIC-Schema-0.66/t/lib/ 000755 000766 000024 00000000000 14461412703 017461 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/t/06c3_issues.t 000644 000766 000024 00000000462 14461407424 021154 0 ustar 00gknop staff 000000 000000 use strict;
use warnings;
use FindBin qw/$Bin/;
use lib "$Bin/lib";
use Test::More tests => 1;
# This fails for me on 5.8.8 with the following module versions:
#
# Class:C3 0.21
# Class::C3::Componentised 1.0005
# DBIx::Class 0.08013 (0.08099_05 works)
use TestAppC3Fail;
Catalyst-Model-DBIC-Schema-0.66/t/lib/PaxHeader/TestAppC3Fail.pm 000644 000766 000024 00000000210 14461410560 024322 x ustar 00gknop staff 000000 000000 30 mtime=1690702192.148650891
57 LIBARCHIVE.xattr.com.apple.provenance=AQAAq1dlpUhBqgg
49 SCHILY.xattr.com.apple.provenance= «We„HAȘ
Catalyst-Model-DBIC-Schema-0.66/t/lib/TestAppC3Fail.pm 000644 000766 000024 00000001146 14461410560 022362 0 ustar 00gknop staff 000000 000000 package TestAppC3Fail;
use strict;
use warnings;
use Class::C3; # This causes the fail, saying use MRO::Compat is fine..
our $VERSION = '0.0001';
use Catalyst::Runtime 5.70;
use Catalyst;
__PACKAGE__->config(
name => 'TestAppC3Fail',
);
my @keys = sort keys( %{ __PACKAGE__->config } );
__PACKAGE__->setup;
my @new_keys = sort
# Ignore key added by horrid hack in Catalyst::Runtime 5.90080
grep { $_ ne '__configured_from_psgi_middleware'}
keys( %{ __PACKAGE__->config } );
use Test::More;
is_deeply(\@new_keys, \@keys, 'Config keys correct')
or diag explain [\@keys, \@new_keys];
1;
Catalyst-Model-DBIC-Schema-0.66/t/lib/ASchemaClass/ 000755 000766 000024 00000000000 14461412703 021750 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/t/lib/ASchemaClass.pm 000644 000766 000024 00000000210 14461407424 022303 0 ustar 00gknop staff 000000 000000 package ASchemaClass;
use base 'DBIx::Class::Schema';
__PACKAGE__->load_classes;
use Moose;
has a_schema_option => (is => 'rw');
1;
Catalyst-Model-DBIC-Schema-0.66/t/lib/AnotherSchemaClass.pm 000644 000766 000024 00000000140 14461407424 023525 0 ustar 00gknop staff 000000 000000 package AnotherSchemaClass;
use base 'DBIx::Class::Schema';
__PACKAGE__->load_namespaces;
1;
Catalyst-Model-DBIC-Schema-0.66/t/lib/TestAppC3Fail/ 000755 000766 000024 00000000000 14461412703 022023 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/t/lib/AnotherSchemaClass/ 000755 000766 000024 00000000000 14461412703 023170 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/t/lib/AnotherSchemaClass/ResultSet/ 000755 000766 000024 00000000000 14461412703 025122 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/t/lib/AnotherSchemaClass/Result/ 000755 000766 000024 00000000000 14461412703 024446 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/t/lib/AnotherSchemaClass/Result/User.pm 000644 000766 000024 00000001117 14461407424 025726 0 ustar 00gknop staff 000000 000000 package AnotherSchemaClass::Result::User;
use strict;
use warnings;
use base 'DBIx::Class::Core';
__PACKAGE__->table("users");
__PACKAGE__->add_columns(
"id",
{ data_type => "integer", is_auto_increment => 1, is_nullable => 0 },
"first_name",
{ data_type => "varchar", is_nullable => 1, size => 100 },
"middle_name",
{ data_type => "varchar", is_nullable => 1, size => 100 },
"last_name",
{ data_type => "varchar", is_nullable => 1, size => 100 },
"email_address",
{ data_type => "varchar", is_nullable => 1, size => 100 },
);
__PACKAGE__->set_primary_key("id");
1;
Catalyst-Model-DBIC-Schema-0.66/t/lib/AnotherSchemaClass/ResultSet/User.pm 000644 000766 000024 00000000272 14461407424 026403 0 ustar 00gknop staff 000000 000000 package AnotherSchemaClass::ResultSet::User;
use strict;
use warnings;
use base 'DBIx::Class::ResultSet';
__PACKAGE__->mk_group_accessors(inherited => qw/
rs_config_option
/);
1;
Catalyst-Model-DBIC-Schema-0.66/t/lib/TestAppC3Fail/Schema/ 000755 000766 000024 00000000000 14461412703 023223 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/t/lib/TestAppC3Fail/Model/ 000755 000766 000024 00000000000 14461412703 023063 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/t/lib/TestAppC3Fail/Model/DB.pm 000644 000766 000024 00000000355 14461407424 023715 0 ustar 00gknop staff 000000 000000 package TestAppC3Fail::Model::DB;
use strict;
use warnings;
use base 'Catalyst::Model::DBIC::Schema';
__PACKAGE__->config(
schema_class => 'TestAppC3Fail::Schema::DB',
connect_info => [ 'DBI:SQLite:dbname=foo', '', '' ],
);
1;
Catalyst-Model-DBIC-Schema-0.66/t/lib/TestAppC3Fail/Schema/DB/ 000755 000766 000024 00000000000 14461412703 023510 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/t/lib/TestAppC3Fail/Schema/DB.pm 000644 000766 000024 00000000200 14461407424 024042 0 ustar 00gknop staff 000000 000000 package TestAppC3Fail::Schema::DB;
use strict;
use warnings;
use base 'DBIx::Class::Schema';
__PACKAGE__->load_classes;
1;
Catalyst-Model-DBIC-Schema-0.66/t/lib/TestAppC3Fail/Schema/DB/User.pm 000644 000766 000024 00000001116 14461407424 024767 0 ustar 00gknop staff 000000 000000 package TestAppC3Fail::Schema::DB::User;
use strict;
use warnings;
use base 'DBIx::Class::Core';
__PACKAGE__->table("users");
__PACKAGE__->add_columns(
"id",
{ data_type => "integer", is_auto_increment => 1, is_nullable => 0 },
"first_name",
{ data_type => "varchar", is_nullable => 1, size => 100 },
"middle_name",
{ data_type => "varchar", is_nullable => 1, size => 100 },
"last_name",
{ data_type => "varchar", is_nullable => 1, size => 100 },
"email_address",
{ data_type => "varchar", is_nullable => 1, size => 100 },
);
__PACKAGE__->set_primary_key("id");
1;
Catalyst-Model-DBIC-Schema-0.66/t/lib/ASchemaClass/User.pm 000644 000766 000024 00000001101 14461407424 023221 0 ustar 00gknop staff 000000 000000 package ASchemaClass::User;
use strict;
use warnings;
use base 'DBIx::Class::Core';
__PACKAGE__->table("users");
__PACKAGE__->add_columns(
"id",
{ data_type => "integer", is_auto_increment => 1, is_nullable => 0 },
"first_name",
{ data_type => "varchar", is_nullable => 1, size => 100 },
"middle_name",
{ data_type => "varchar", is_nullable => 1, size => 100 },
"last_name",
{ data_type => "varchar", is_nullable => 1, size => 100 },
"email_address",
{ data_type => "varchar", is_nullable => 1, size => 100 },
);
__PACKAGE__->set_primary_key("id");
1;
Catalyst-Model-DBIC-Schema-0.66/inc/Module/ 000755 000766 000024 00000000000 14461412703 020446 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/inc/Module/Install/ 000755 000766 000024 00000000000 14461412703 022054 5 ustar 00gknop staff 000000 000000 Catalyst-Model-DBIC-Schema-0.66/inc/Module/Install.pm 000644 000766 000024 00000027145 14461412667 022434 0 ustar 00gknop staff 000000 000000 #line 1
package Module::Install;
# For any maintainers:
# The load order for Module::Install is a bit magic.
# It goes something like this...
#
# IF ( host has Module::Install installed, creating author mode ) {
# 1. Makefile.PL calls "use inc::Module::Install"
# 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
# 3. The installed version of inc::Module::Install loads
# 4. inc::Module::Install calls "require Module::Install"
# 5. The ./inc/ version of Module::Install loads
# } ELSE {
# 1. Makefile.PL calls "use inc::Module::Install"
# 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
# 3. The ./inc/ version of Module::Install loads
# }
use 5.006;
use strict 'vars';
use Cwd ();
use File::Find ();
use File::Path ();
use vars qw{$VERSION $MAIN};
BEGIN {
# All Module::Install core packages now require synchronised versions.
# This will be used to ensure we don't accidentally load old or
# different versions of modules.
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
$VERSION = '1.21';
# Storage for the pseudo-singleton
$MAIN = undef;
*inc::Module::Install::VERSION = *VERSION;
@inc::Module::Install::ISA = __PACKAGE__;
}
sub import {
my $class = shift;
my $self = $class->new(@_);
my $who = $self->_caller;
#-------------------------------------------------------------
# all of the following checks should be included in import(),
# to allow "eval 'require Module::Install; 1' to test
# installation of Module::Install. (RT #51267)
#-------------------------------------------------------------
# Whether or not inc::Module::Install is actually loaded, the
# $INC{inc/Module/Install.pm} is what will still get set as long as
# the caller loaded module this in the documented manner.
# If not set, the caller may NOT have loaded the bundled version, and thus
# they may not have a MI version that works with the Makefile.PL. This would
# result in false errors or unexpected behaviour. And we don't want that.
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
unless ( $INC{$file} ) { die <<"END_DIE" }
Please invoke ${\__PACKAGE__} with:
use inc::${\__PACKAGE__};
not:
use ${\__PACKAGE__};
END_DIE
# This reportedly fixes a rare Win32 UTC file time issue, but
# as this is a non-cross-platform XS module not in the core,
# we shouldn't really depend on it. See RT #24194 for detail.
# (Also, this module only supports Perl 5.6 and above).
eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006;
# If the script that is loading Module::Install is from the future,
# then make will detect this and cause it to re-run over and over
# again. This is bad. Rather than taking action to touch it (which
# is unreliable on some platforms and requires write permissions)
# for now we should catch this and refuse to run.
if ( -f $0 ) {
my $s = (stat($0))[9];
# If the modification time is only slightly in the future,
# sleep briefly to remove the problem.
my $a = $s - time;
if ( $a > 0 and $a < 5 ) { sleep 5 }
# Too far in the future, throw an error.
my $t = time;
if ( $s > $t ) { die <<"END_DIE" }
Your installer $0 has a modification time in the future ($s > $t).
This is known to create infinite loops in make.
Please correct this, then run $0 again.
END_DIE
}
# Build.PL was formerly supported, but no longer is due to excessive
# difficulty in implementing every single feature twice.
if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
Module::Install no longer supports Build.PL.
It was impossible to maintain duel backends, and has been deprecated.
Please remove all Build.PL files and only use the Makefile.PL installer.
END_DIE
#-------------------------------------------------------------
# To save some more typing in Module::Install installers, every...
# use inc::Module::Install
# ...also acts as an implicit use strict.
$^H |= strict::bits(qw(refs subs vars));
#-------------------------------------------------------------
unless ( -f $self->{file} ) {
foreach my $key (keys %INC) {
delete $INC{$key} if $key =~ /Module\/Install/;
}
local $^W;
require "$self->{path}/$self->{dispatch}.pm";
File::Path::mkpath("$self->{prefix}/$self->{author}");
$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
$self->{admin}->init;
@_ = ($class, _self => $self);
goto &{"$self->{name}::import"};
}
local $^W;
*{"${who}::AUTOLOAD"} = $self->autoload;
$self->preload;
# Unregister loader and worker packages so subdirs can use them again
delete $INC{'inc/Module/Install.pm'};
delete $INC{'Module/Install.pm'};
# Save to the singleton
$MAIN = $self;
return 1;
}
sub autoload {
my $self = shift;
my $who = $self->_caller;
my $cwd = Cwd::getcwd();
my $sym = "${who}::AUTOLOAD";
$sym->{$cwd} = sub {
my $pwd = Cwd::getcwd();
if ( my $code = $sym->{$pwd} ) {
# Delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
}
unless ($$sym =~ s/([^:]+)$//) {
# XXX: it looks like we can't retrieve the missing function
# via $$sym (usually $main::AUTOLOAD) in this case.
# I'm still wondering if we should slurp Makefile.PL to
# get some context or not ...
my ($package, $file, $line) = caller;
die <<"EOT";
Unknown function is found at $file line $line.
Execution of $file aborted due to runtime errors.
If you're a contributor to a project, you may need to install
some Module::Install extensions from CPAN (or other repository).
If you're a user of a module, please contact the author.
EOT
}
my $method = $1;
if ( uc($method) eq $method ) {
# Do nothing
return;
} elsif ( $method =~ /^_/ and $self->can($method) ) {
# Dispatch to the root M:I class
return $self->$method(@_);
}
# Dispatch to the appropriate plugin
unshift @_, ( $self, $1 );
goto &{$self->can('call')};
};
}
sub preload {
my $self = shift;
unless ( $self->{extensions} ) {
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
);
}
my @exts = @{$self->{extensions}};
unless ( @exts ) {
@exts = $self->{admin}->load_all_extensions;
}
my %seen;
foreach my $obj ( @exts ) {
while (my ($method, $glob) = each %{ref($obj) . '::'}) {
next unless $obj->can($method);
next if $method =~ /^_/;
next if $method eq uc($method);
$seen{$method}++;
}
}
my $who = $self->_caller;
foreach my $name ( sort keys %seen ) {
local $^W;
*{"${who}::$name"} = sub {
${"${who}::AUTOLOAD"} = "${who}::$name";
goto &{"${who}::AUTOLOAD"};
};
}
}
sub new {
my ($class, %args) = @_;
delete $INC{'FindBin.pm'};
{
# to suppress the redefine warning
local $SIG{__WARN__} = sub {};
require FindBin;
}
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) {
delete $args{prefix};
}
return $args{_self} if $args{_self};
$base_path = VMS::Filespec::unixify($base_path) if $^O eq 'VMS';
$args{dispatch} ||= 'Admin';
$args{prefix} ||= 'inc';
$args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
$args{bundle} ||= 'inc/BUNDLES';
$args{base} ||= $base_path;
$class =~ s/^\Q$args{prefix}\E:://;
$args{name} ||= $class;
$args{version} ||= $class->VERSION;
unless ( $args{path} ) {
$args{path} = $args{name};
$args{path} =~ s!::!/!g;
}
$args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
$args{wrote} = 0;
bless( \%args, $class );
}
sub call {
my ($self, $method) = @_;
my $obj = $self->load($method) or return;
splice(@_, 0, 2, $obj);
goto &{$obj->can($method)};
}
sub load {
my ($self, $method) = @_;
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
) unless $self->{extensions};
foreach my $obj (@{$self->{extensions}}) {
return $obj if $obj->can($method);
}
my $admin = $self->{admin} or die <<"END_DIE";
The '$method' method does not exist in the '$self->{prefix}' path!
Please remove the '$self->{prefix}' directory and run $0 again to load it.
END_DIE
my $obj = $admin->load($method, 1);
push @{$self->{extensions}}, $obj;
$obj;
}
sub load_extensions {
my ($self, $path, $top) = @_;
my $should_reload = 0;
unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
$should_reload = 1;
}
foreach my $rv ( $self->find_extensions($path) ) {
my ($file, $pkg) = @{$rv};
next if $self->{pathnames}{$pkg};
local $@;
my $new = eval { local $^W; require $file; $pkg->can('new') };
unless ( $new ) {
warn $@ if $@;
next;
}
$self->{pathnames}{$pkg} =
$should_reload ? delete $INC{$file} : $INC{$file};
push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
}
$self->{extensions} ||= [];
}
sub find_extensions {
my ($self, $path) = @_;
my @found;
File::Find::find( {no_chdir => 1, wanted => sub {
my $file = $File::Find::name;
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
my $subpath = $1;
return if lc($subpath) eq lc($self->{dispatch});
$file = "$self->{path}/$subpath.pm";
my $pkg = "$self->{name}::$subpath";
$pkg =~ s!/!::!g;
# If we have a mixed-case package name, assume case has been preserved
# correctly. Otherwise, root through the file to locate the case-preserved
# version of the package name.
if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
my $content = Module::Install::_read($File::Find::name);
my $in_pod = 0;
foreach ( split /\n/, $content ) {
$in_pod = 1 if /^=\w/;
$in_pod = 0 if /^=cut/;
next if ($in_pod || /^=cut/); # skip pod text
next if /^\s*#/; # and comments
if ( m/^\s*package\s+($pkg)\s*;/i ) {
$pkg = $1;
last;
}
}
}
push @found, [ $file, $pkg ];
}}, $path ) if -d $path;
@found;
}
#####################################################################
# Common Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
sub _read {
local *FH;
open( FH, '<', $_[0] ) or die "open($_[0]): $!";
binmode FH;
my $string = do { local $/; };
close FH or die "close($_[0]): $!";
return $string;
}
sub _readperl {
my $string = Module::Install::_read($_[0]);
$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
$string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
$string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
return $string;
}
sub _readpod {
my $string = Module::Install::_read($_[0]);
$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
return $string if $_[0] =~ /\.pod\z/;
$string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
$string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
$string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
$string =~ s/^\n+//s;
return $string;
}
sub _write {
local *FH;
open( FH, '>', $_[0] ) or die "open($_[0]): $!";
binmode FH;
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
close FH or die "close($_[0]): $!";
}
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
sub _version {
my $s = shift || 0;
my $d =()= $s =~ /(\.)/g;
if ( $d >= 2 ) {
# Normalise multipart versions
$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
}
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map {
$_ . '0' x (3 - length $_)
} $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
sub _cmp {
_version($_[1]) <=> _version($_[2]);
}
# Cloned from Params::Util::_CLASS
sub _CLASS {
(
defined $_[0]
and
! ref $_[0]
and
$_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
) ? $_[0] : undef;
}
1;
# Copyright 2008 - 2012 Adam Kennedy.
Catalyst-Model-DBIC-Schema-0.66/inc/Module/AutoInstall.pm 000644 000766 000024 00000062311 14461412670 023251 0 ustar 00gknop staff 000000 000000 #line 1
package Module::AutoInstall;
use strict;
use Cwd ();
use File::Spec ();
use ExtUtils::MakeMaker ();
use vars qw{$VERSION};
BEGIN {
$VERSION = '1.21';
}
# special map on pre-defined feature sets
my %FeatureMap = (
'' => 'Core Features', # XXX: deprecated
'-core' => 'Core Features',
);
# various lexical flags
my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $InstallDepsTarget, $HasCPANPLUS );
my (
$Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps,
$UpgradeDeps
);
my ( $PostambleActions, $PostambleActionsNoTest, $PostambleActionsUpgradeDeps,
$PostambleActionsUpgradeDepsNoTest, $PostambleActionsListDeps,
$PostambleActionsListAllDeps, $PostambleUsed, $NoTest);
# See if it's a testing or non-interactive session
_accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN );
_init();
sub _accept_default {
$AcceptDefault = shift;
}
sub _installdeps_target {
$InstallDepsTarget = shift;
}
sub missing_modules {
return @Missing;
}
sub do_install {
__PACKAGE__->install(
[
$Config
? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
: ()
],
@Missing,
);
}
# initialize various flags, and/or perform install
sub _init {
foreach my $arg (
@ARGV,
split(
/[\s\t]+/,
$ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || ''
)
)
{
if ( $arg =~ /^--config=(.*)$/ ) {
$Config = [ split( ',', $1 ) ];
}
elsif ( $arg =~ /^--installdeps=(.*)$/ ) {
__PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) );
exit 0;
}
elsif ( $arg =~ /^--upgradedeps=(.*)$/ ) {
$UpgradeDeps = 1;
__PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) );
exit 0;
}
elsif ( $arg =~ /^--default(?:deps)?$/ ) {
$AcceptDefault = 1;
}
elsif ( $arg =~ /^--check(?:deps)?$/ ) {
$CheckOnly = 1;
}
elsif ( $arg =~ /^--skip(?:deps)?$/ ) {
$SkipInstall = 1;
}
elsif ( $arg =~ /^--test(?:only)?$/ ) {
$TestOnly = 1;
}
elsif ( $arg =~ /^--all(?:deps)?$/ ) {
$AllDeps = 1;
}
}
}
# overrides MakeMaker's prompt() to automatically accept the default choice
sub _prompt {
goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault;
my ( $prompt, $default ) = @_;
my $y = ( $default =~ /^[Yy]/ );
print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] ';
print "$default\n";
return $default;
}
# the workhorse
sub import {
my $class = shift;
my @args = @_ or return;
my $core_all;
print "*** $class version " . $class->VERSION . "\n";
print "*** Checking for Perl dependencies...\n";
my $cwd = Cwd::getcwd();
$Config = [];
my $maxlen = length(
(
sort { length($b) <=> length($a) }
grep { /^[^\-]/ }
map {
ref($_)
? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} )
: ''
}
map { +{@args}->{$_} }
grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} }
)[0]
);
# We want to know if we're under CPAN early to avoid prompting, but
# if we aren't going to try and install anything anyway then skip the
# check entirely since we don't want to have to load (and configure)
# an old CPAN just for a cosmetic message
$UnderCPAN = _check_lock(1) unless $SkipInstall || $InstallDepsTarget;
while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) {
my ( @required, @tests, @skiptests );
my $default = 1;
my $conflict = 0;
if ( $feature =~ m/^-(\w+)$/ ) {
my $option = lc($1);
# check for a newer version of myself
_update_to( $modules, @_ ) and return if $option eq 'version';
# sets CPAN configuration options
$Config = $modules if $option eq 'config';
# promote every features to core status
$core_all = ( $modules =~ /^all$/i ) and next
if $option eq 'core';
next unless $option eq 'core';
}
print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n";
$modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' );
unshift @$modules, -default => &{ shift(@$modules) }
if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward compatibility
while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) {
if ( $mod =~ m/^-(\w+)$/ ) {
my $option = lc($1);
$default = $arg if ( $option eq 'default' );
$conflict = $arg if ( $option eq 'conflict' );
@tests = @{$arg} if ( $option eq 'tests' );
@skiptests = @{$arg} if ( $option eq 'skiptests' );
next;
}
printf( "- %-${maxlen}s ...", $mod );
if ( $arg and $arg =~ /^\D/ ) {
unshift @$modules, $arg;
$arg = 0;
}
# XXX: check for conflicts and uninstalls(!) them.
my $cur = _version_of($mod);
if (_version_cmp ($cur, $arg) >= 0)
{
print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n";
push @Existing, $mod => $arg;
$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
}
else {
if (not defined $cur) # indeed missing
{
print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n";
}
else
{
# no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above
print "too old. ($cur < $arg)\n";
}
push @required, $mod => $arg;
}
}
next unless @required;
my $mandatory = ( $feature eq '-core' or $core_all );
if (
!$SkipInstall
and (
$CheckOnly
or ($mandatory and $UnderCPAN)
or $AllDeps
or $InstallDepsTarget
or _prompt(
qq{==> Auto-install the }
. ( @required / 2 )
. ( $mandatory ? ' mandatory' : ' optional' )
. qq{ module(s) from CPAN?},
$default ? 'y' : 'n',
) =~ /^[Yy]/
)
)
{
push( @Missing, @required );
$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
}
elsif ( !$SkipInstall
and $default
and $mandatory
and
_prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', )
=~ /^[Nn]/ )
{
push( @Missing, @required );
$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
}
else {
$DisabledTests{$_} = 1 for map { glob($_) } @tests;
}
}
if ( @Missing and not( $CheckOnly or $UnderCPAN) ) {
require Config;
my $make = $Config::Config{make};
if ($InstallDepsTarget) {
print
"*** To install dependencies type '$make installdeps' or '$make installdeps_notest'.\n";
}
else {
print
"*** Dependencies will be installed the next time you type '$make'.\n";
}
# make an educated guess of whether we'll need root permission.
print " (You may need to do that as the 'root' user.)\n"
if eval '$>';
}
print "*** $class configuration finished.\n";
chdir $cwd;
# import to main::
no strict 'refs';
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
return (@Existing, @Missing);
}
sub _running_under {
my $thing = shift;
print <<"END_MESSAGE";
*** Since we're running under ${thing}, I'll just let it take care
of the dependency's installation later.
END_MESSAGE
return 1;
}
# Check to see if we are currently running under CPAN.pm and/or CPANPLUS;
# if we are, then we simply let it taking care of our dependencies
sub _check_lock {
return unless @Missing or @_;
if ($ENV{PERL5_CPANM_IS_RUNNING}) {
return _running_under('cpanminus');
}
my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING};
if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS');
}
require CPAN;
if ($CPAN::VERSION > '1.89') {
if ($cpan_env) {
return _running_under('CPAN');
}
return; # CPAN.pm new enough, don't need to check further
}
# last ditch attempt, this -will- configure CPAN, very sorry
_load_cpan(1); # force initialize even though it's already loaded
# Find the CPAN lock-file
my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" );
return unless -f $lock;
# Check the lock
local *LOCK;
return unless open(LOCK, $lock);
if (
( $^O eq 'MSWin32' ? _under_cpan() : == getppid() )
and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore'
) {
print <<'END_MESSAGE';
*** Since we're running under CPAN, I'll just let it take care
of the dependency's installation later.
END_MESSAGE
return 1;
}
close LOCK;
return;
}
sub install {
my $class = shift;
my $i; # used below to strip leading '-' from config keys
my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } );
my ( @modules, @installed, @modules_to_upgrade );
while (my ($pkg, $ver) = splice(@_, 0, 2)) {
# grep out those already installed
if (_version_cmp(_version_of($pkg), $ver) >= 0) {
push @installed, $pkg;
if ($UpgradeDeps) {
push @modules_to_upgrade, $pkg, $ver;
}
}
else {
push @modules, $pkg, $ver;
}
}
if ($UpgradeDeps) {
push @modules, @modules_to_upgrade;
@installed = ();
@modules_to_upgrade = ();
}
return @installed unless @modules; # nothing to do
return @installed if _check_lock(); # defer to the CPAN shell
print "*** Installing dependencies...\n";
return unless _connected_to('cpan.org');
my %args = @config;
my %failed;
local *FAILED;
if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) {
while () { chomp; $failed{$_}++ }
close FAILED;
my @newmod;
while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) {
push @newmod, ( $k => $v ) unless $failed{$k};
}
@modules = @newmod;
}
if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) {
_install_cpanplus( \@modules, \@config );
} else {
_install_cpan( \@modules, \@config );
}
print "*** $class installation finished.\n";
# see if we have successfully installed them
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) {
push @installed, $pkg;
}
elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) {
print FAILED "$pkg\n";
}
}
close FAILED if $args{do_once};
return @installed;
}
sub _install_cpanplus {
my @modules = @{ +shift };
my @config = _cpanplus_config( @{ +shift } );
my $installed = 0;
require CPANPLUS::Backend;
my $cp = CPANPLUS::Backend->new;
my $conf = $cp->configure_object;
return unless $conf->can('conf') # 0.05x+ with "sudo" support
or _can_write($conf->_get_build('base')); # 0.04x
# if we're root, set UNINST=1 to avoid trouble unless user asked for it.
my $makeflags = $conf->get_conf('makeflags') || '';
if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) {
# 0.03+ uses a hashref here
$makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST};
} else {
# 0.02 and below uses a scalar
$makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' )
if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } );
}
$conf->set_conf( makeflags => $makeflags );
$conf->set_conf( prereqs => 1 );
while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) {
$conf->set_conf( $key, $val );
}
my $modtree = $cp->module_tree;
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
print "*** Installing $pkg...\n";
MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall;
my $success;
my $obj = $modtree->{$pkg};
if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) {
my $pathname = $pkg;
$pathname =~ s/::/\\W/;
foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
delete $INC{$inc};
}
my $rv = $cp->install( modules => [ $obj->{module} ] );
if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) {
print "*** $pkg successfully installed.\n";
$success = 1;
} else {
print "*** $pkg installation cancelled.\n";
$success = 0;
}
$installed += $success;
} else {
print << ".";
*** Could not find a version $ver or above for $pkg; skipping.
.
}
MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall;
}
return $installed;
}
sub _cpanplus_config {
my @config = ();
while ( @_ ) {
my ($key, $value) = (shift(), shift());
if ( $key eq 'prerequisites_policy' ) {
if ( $value eq 'follow' ) {
$value = CPANPLUS::Internals::Constants::PREREQ_INSTALL();
} elsif ( $value eq 'ask' ) {
$value = CPANPLUS::Internals::Constants::PREREQ_ASK();
} elsif ( $value eq 'ignore' ) {
$value = CPANPLUS::Internals::Constants::PREREQ_IGNORE();
} else {
die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n";
}
push @config, 'prereqs', $value;
} elsif ( $key eq 'force' ) {
push @config, $key, $value;
} elsif ( $key eq 'notest' ) {
push @config, 'skiptest', $value;
} else {
die "*** Cannot convert option $key to CPANPLUS version.\n";
}
}
return @config;
}
sub _install_cpan {
my @modules = @{ +shift };
my @config = @{ +shift };
my $installed = 0;
my %args;
_load_cpan();
require Config;
if (CPAN->VERSION < 1.80) {
# no "sudo" support, probe for writableness
return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) )
and _can_write( $Config::Config{sitelib} );
}
# if we're root, set UNINST=1 to avoid trouble unless user asked for it.
my $makeflags = $CPAN::Config->{make_install_arg} || '';
$CPAN::Config->{make_install_arg} =
join( ' ', split( ' ', $makeflags ), 'UNINST=1' )
if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } );
# don't show start-up info
$CPAN::Config->{inhibit_startup_message} = 1;
# set additional options
while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) {
( $args{$opt} = $arg, next )
if $opt =~ /^(?:force|notest)$/; # pseudo-option
$CPAN::Config->{$opt} = $opt eq 'urllist' ? [$arg] : $arg;
}
if ($args{notest} && (not CPAN::Shell->can('notest'))) {
die "Your version of CPAN is too old to support the 'notest' pragma";
}
local $CPAN::Config->{prerequisites_policy} = 'follow';
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall;
print "*** Installing $pkg...\n";
my $obj = CPAN::Shell->expand( Module => $pkg );
my $success = 0;
if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) {
my $pathname = $pkg;
$pathname =~ s/::/\\W/;
foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
delete $INC{$inc};
}
my $rv = do {
if ($args{force}) {
CPAN::Shell->force( install => $pkg )
} elsif ($args{notest}) {
CPAN::Shell->notest( install => $pkg )
} else {
CPAN::Shell->install($pkg)
}
};
$rv ||= eval {
$CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, )
->{install}
if $CPAN::META;
};
if ( $rv eq 'YES' ) {
print "*** $pkg successfully installed.\n";
$success = 1;
}
else {
print "*** $pkg installation failed.\n";
$success = 0;
}
$installed += $success;
}
else {
print << ".";
*** Could not find a version $ver or above for $pkg; skipping.
.
}
MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall;
}
return $installed;
}
sub _has_cpanplus {
return (
$HasCPANPLUS = (
$INC{'CPANPLUS/Config.pm'}
or _load('CPANPLUS::Shell::Default')
)
);
}
# make guesses on whether we're under the CPAN installation directory
sub _under_cpan {
require Cwd;
require File::Spec;
my $cwd = File::Spec->canonpath( Cwd::getcwd() );
my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} );
return ( index( $cwd, $cpan ) > -1 );
}
sub _update_to {
my $class = __PACKAGE__;
my $ver = shift;
return
if _version_cmp( _version_of($class), $ver ) >= 0; # no need to upgrade
if (
_prompt( "==> A newer version of $class ($ver) is required. Install?",
'y' ) =~ /^[Nn]/
)
{
die "*** Please install $class $ver manually.\n";
}
print << ".";
*** Trying to fetch it from CPAN...
.
# install ourselves
_load($class) and return $class->import(@_)
if $class->install( [], $class, $ver );
print << '.'; exit 1;
*** Cannot bootstrap myself. :-( Installation terminated.
.
}
# check if we're connected to some host, using inet_aton
sub _connected_to {
my $site = shift;
return (
( _load('Socket') and Socket::inet_aton($site) ) or _prompt(
qq(
*** Your host cannot resolve the domain name '$site', which
probably means the Internet connections are unavailable.
==> Should we try to install the required module(s) anyway?), 'n'
) =~ /^[Yy]/
);
}
# check if a directory is writable; may create it on demand
sub _can_write {
my $path = shift;
mkdir( $path, 0755 ) unless -e $path;
return 1 if -w $path;
print << ".";
*** You are not allowed to write to the directory '$path';
the installation may fail due to insufficient permissions.
.
if (
eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt(
qq(
==> Should we try to re-execute the autoinstall process with 'sudo'?),
((-t STDIN) ? 'y' : 'n')
) =~ /^[Yy]/
)
{
# try to bootstrap ourselves from sudo
print << ".";
*** Trying to re-execute the autoinstall process with 'sudo'...
.
my $missing = join( ',', @Missing );
my $config = join( ',',
UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
if $Config;
return
unless system( 'sudo', $^X, $0, "--config=$config",
"--installdeps=$missing" );
print << ".";
*** The 'sudo' command exited with error! Resuming...
.
}
return _prompt(
qq(
==> Should we try to install the required module(s) anyway?), 'n'
) =~ /^[Yy]/;
}
# load a module and return the version it reports
sub _load {
my $mod = pop; # method/function doesn't matter
my $file = $mod;
$file =~ s|::|/|g;
$file .= '.pm';
local $@;
return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 );
}
# report version without loading a module
sub _version_of {
my $mod = pop; # method/function doesn't matter
my $file = $mod;
$file =~ s|::|/|g;
$file .= '.pm';
foreach my $dir ( @INC ) {
next if ref $dir;
my $path = File::Spec->catfile($dir, $file);
next unless -e $path;
require ExtUtils::MM_Unix;
return ExtUtils::MM_Unix->parse_version($path);
}
return undef;
}
# Load CPAN.pm and it's configuration
sub _load_cpan {
return if $CPAN::VERSION and $CPAN::Config and not @_;
require CPAN;
# CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to
# CPAN::HandleConfig->load. CPAN reports that the redirection
# is deprecated in a warning printed at the user.
# CPAN-1.81 expects CPAN::HandleConfig->load, does not have
# $CPAN::HandleConfig::VERSION but cannot handle
# CPAN::Config->load
# Which "versions expect CPAN::Config->load?
if ( $CPAN::HandleConfig::VERSION
|| CPAN::HandleConfig->can('load')
) {
# Newer versions of CPAN have a HandleConfig module
CPAN::HandleConfig->load;
} else {
# Older versions had the load method in Config directly
CPAN::Config->load;
}
}
# compare two versions, either use Sort::Versions or plain comparison
# return values same as <=>
sub _version_cmp {
my ( $cur, $min ) = @_;
return -1 unless defined $cur; # if 0 keep comparing
return 1 unless $min;
$cur =~ s/\s+$//;
# check for version numbers that are not in decimal format
if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) {
if ( ( $version::VERSION or defined( _load('version') )) and
version->can('new')
) {
# use version.pm if it is installed.
return version->new($cur) <=> version->new($min);
}
elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) )
{
# use Sort::Versions as the sorting algorithm for a.b.c versions
return Sort::Versions::versioncmp( $cur, $min );
}
warn "Cannot reliably compare non-decimal formatted versions.\n"
. "Please install version.pm or Sort::Versions.\n";
}
# plain comparison
local $^W = 0; # shuts off 'not numeric' bugs
return $cur <=> $min;
}
# nothing; this usage is deprecated.
sub main::PREREQ_PM { return {}; }
sub _make_args {
my %args = @_;
$args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing }
if $UnderCPAN or $TestOnly;
if ( $args{EXE_FILES} and -e 'MANIFEST' ) {
require ExtUtils::Manifest;
my $manifest = ExtUtils::Manifest::maniread('MANIFEST');
$args{EXE_FILES} =
[ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ];
}
$args{test}{TESTS} ||= 't/*.t';
$args{test}{TESTS} = join( ' ',
grep { !exists( $DisabledTests{$_} ) }
map { glob($_) } split( /\s+/, $args{test}{TESTS} ) );
my $missing = join( ',', @Missing );
my $config =
join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
if $Config;
$PostambleActions = (
($missing and not $UnderCPAN)
? "\$(PERL) $0 --config=$config --installdeps=$missing"
: "\$(NOECHO) \$(NOOP)"
);
my $deps_list = join( ',', @Missing, @Existing );
$PostambleActionsUpgradeDeps =
"\$(PERL) $0 --config=$config --upgradedeps=$deps_list";
my $config_notest =
join( ',', (UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config}),
'notest', 1 )
if $Config;
$PostambleActionsNoTest = (
($missing and not $UnderCPAN)
? "\$(PERL) $0 --config=$config_notest --installdeps=$missing"
: "\$(NOECHO) \$(NOOP)"
);
$PostambleActionsUpgradeDepsNoTest =
"\$(PERL) $0 --config=$config_notest --upgradedeps=$deps_list";
$PostambleActionsListDeps =
'@$(PERL) -le "print for @ARGV" '
. join(' ', map $Missing[$_], grep $_ % 2 == 0, 0..$#Missing);
my @all = (@Missing, @Existing);
$PostambleActionsListAllDeps =
'@$(PERL) -le "print for @ARGV" '
. join(' ', map $all[$_], grep $_ % 2 == 0, 0..$#all);
return %args;
}
# a wrapper to ExtUtils::MakeMaker::WriteMakefile
sub Write {
require Carp;
Carp::croak "WriteMakefile: Need even number of args" if @_ % 2;
if ($CheckOnly) {
print << ".";
*** Makefile not written in check-only mode.
.
return;
}
my %args = _make_args(@_);
no strict 'refs';
$PostambleUsed = 0;
local *MY::postamble = \&postamble unless defined &MY::postamble;
ExtUtils::MakeMaker::WriteMakefile(%args);
print << "." unless $PostambleUsed;
*** WARNING: Makefile written with customized MY::postamble() without
including contents from Module::AutoInstall::postamble() --
auto installation features disabled. Please contact the author.
.
return 1;
}
sub postamble {
$PostambleUsed = 1;
my $fragment;
$fragment .= <<"AUTO_INSTALL" if !$InstallDepsTarget;
config :: installdeps
\t\$(NOECHO) \$(NOOP)
AUTO_INSTALL
$fragment .= <<"END_MAKE";
checkdeps ::
\t\$(PERL) $0 --checkdeps
installdeps ::
\t$PostambleActions
installdeps_notest ::
\t$PostambleActionsNoTest
upgradedeps ::
\t$PostambleActionsUpgradeDeps
upgradedeps_notest ::
\t$PostambleActionsUpgradeDepsNoTest
listdeps ::
\t$PostambleActionsListDeps
listalldeps ::
\t$PostambleActionsListAllDeps
END_MAKE
return $fragment;
}
1;
__END__
#line 1197
Catalyst-Model-DBIC-Schema-0.66/inc/Module/Install/Win32.pm 000644 000766 000024 00000003403 14461412670 023317 0 ustar 00gknop staff 000000 000000 #line 1
package Module::Install::Win32;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.21';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
# determine if the user needs nmake, and download it if needed
sub check_nmake {
my $self = shift;
$self->load('can_run');
$self->load('get_file');
require Config;
return unless (
$^O eq 'MSWin32' and
$Config::Config{make} and
$Config::Config{make} =~ /^nmake\b/i and
! $self->can_run('nmake')
);
print "The required 'nmake' executable not found, fetching it...\n";
require File::Basename;
my $rv = $self->get_file(
url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe',
ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe',
local_dir => File::Basename::dirname($^X),
size => 51928,
run => 'Nmake15.exe /o > nul',
check_for => 'Nmake.exe',
remove => 1,
);
die <<'END_MESSAGE' unless $rv;
-------------------------------------------------------------------------------
Since you are using Microsoft Windows, you will need the 'nmake' utility
before installation. It's available at:
http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe
or
ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe
Please download the file manually, save it to a directory in %PATH% (e.g.
C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to
that directory, and run "Nmake15.exe" from there; that will create the
'nmake.exe' file needed by this module.
You may then resume the installation process described in README.
-------------------------------------------------------------------------------
END_MESSAGE
}
1;
Catalyst-Model-DBIC-Schema-0.66/inc/Module/Install/Can.pm 000644 000766 000024 00000006405 14461412670 023123 0 ustar 00gknop staff 000000 000000 #line 1
package Module::Install::Can;
use strict;
use Config ();
use ExtUtils::MakeMaker ();
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.21';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
# check if we can load some module
### Upgrade this to not have to load the module if possible
sub can_use {
my ($self, $mod, $ver) = @_;
$mod =~ s{::|\\}{/}g;
$mod .= '.pm' unless $mod =~ /\.pm$/i;
my $pkg = $mod;
$pkg =~ s{/}{::}g;
$pkg =~ s{\.pm$}{}i;
local $@;
eval { require $mod; $pkg->VERSION($ver || 0); 1 };
}
# Check if we can run some command
sub can_run {
my ($self, $cmd) = @_;
my $_cmd = $cmd;
return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
next if $dir eq '';
require File::Spec;
my $abs = File::Spec->catfile($dir, $cmd);
return $abs if (-x $abs or $abs = MM->maybe_command($abs));
}
return;
}
# Can our C compiler environment build XS files
sub can_xs {
my $self = shift;
# Ensure we have the CBuilder module
$self->configure_requires( 'ExtUtils::CBuilder' => 0.27 );
# Do we have the configure_requires checker?
local $@;
eval "require ExtUtils::CBuilder;";
if ( $@ ) {
# They don't obey configure_requires, so it is
# someone old and delicate. Try to avoid hurting
# them by falling back to an older simpler test.
return $self->can_cc();
}
# Do we have a working C compiler
my $builder = ExtUtils::CBuilder->new(
quiet => 1,
);
unless ( $builder->have_compiler ) {
# No working C compiler
return 0;
}
# Write a C file representative of what XS becomes
require File::Temp;
my ( $FH, $tmpfile ) = File::Temp::tempfile(
"compilexs-XXXXX",
SUFFIX => '.c',
);
binmode $FH;
print $FH <<'END_C';
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
int main(int argc, char **argv) {
return 0;
}
int boot_sanexs() {
return 1;
}
END_C
close $FH;
# Can the C compiler access the same headers XS does
my @libs = ();
my $object = undef;
eval {
local $^W = 0;
$object = $builder->compile(
source => $tmpfile,
);
@libs = $builder->link(
objects => $object,
module_name => 'sanexs',
);
};
my $result = $@ ? 0 : 1;
# Clean up all the build files
foreach ( $tmpfile, $object, @libs ) {
next unless defined $_;
1 while unlink;
}
return $result;
}
# Can we locate a (the) C compiler
sub can_cc {
my $self = shift;
if ($^O eq 'VMS') {
require ExtUtils::CBuilder;
my $builder = ExtUtils::CBuilder->new(
quiet => 1,
);
return $builder->have_compiler;
}
my @chunks = split(/ /, $Config::Config{cc}) or return;
# $Config{cc} may contain args; try to find out the program part
while (@chunks) {
return $self->can_run("@chunks") || (pop(@chunks), next);
}
return;
}
# Fix Cygwin bug on maybe_command();
if ( $^O eq 'cygwin' ) {
require ExtUtils::MM_Cygwin;
require ExtUtils::MM_Win32;
if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) {
*ExtUtils::MM_Cygwin::maybe_command = sub {
my ($self, $file) = @_;
if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) {
ExtUtils::MM_Win32->maybe_command($file);
} else {
ExtUtils::MM_Unix->maybe_command($file);
}
}
}
}
1;
__END__
#line 245
Catalyst-Model-DBIC-Schema-0.66/inc/Module/Install/Fetch.pm 000644 000766 000024 00000004627 14461412670 023457 0 ustar 00gknop staff 000000 000000 #line 1
package Module::Install::Fetch;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.21';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
sub get_file {
my ($self, %args) = @_;
my ($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
$args{url} = $args{ftp_url}
or (warn("LWP support unavailable!\n"), return);
($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
}
$|++;
print "Fetching '$file' from $host... ";
unless (eval { require Socket; Socket::inet_aton($host) }) {
warn "'$host' resolve failed!\n";
return;
}
return unless $scheme eq 'ftp' or $scheme eq 'http';
require Cwd;
my $dir = Cwd::getcwd();
chdir $args{local_dir} or return if exists $args{local_dir};
if (eval { require LWP::Simple; 1 }) {
LWP::Simple::mirror($args{url}, $file);
}
elsif (eval { require Net::FTP; 1 }) { eval {
# use Net::FTP to get past firewall
my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
$ftp->login("anonymous", 'anonymous@example.com');
$ftp->cwd($path);
$ftp->binary;
$ftp->get($file) or (warn("$!\n"), return);
$ftp->quit;
} }
elsif (my $ftp = $self->can_run('ftp')) { eval {
# no Net::FTP, fallback to ftp.exe
require FileHandle;
my $fh = FileHandle->new;
local $SIG{CHLD} = 'IGNORE';
unless ($fh->open("|$ftp -n")) {
warn "Couldn't open ftp: $!\n";
chdir $dir; return;
}
my @dialog = split(/\n/, <<"END_FTP");
open $host
user anonymous anonymous\@example.com
cd $path
binary
get $file $file
quit
END_FTP
foreach (@dialog) { $fh->print("$_\n") }
$fh->close;
} }
else {
warn "No working 'ftp' program available!\n";
chdir $dir; return;
}
unless (-f $file) {
warn "Fetching failed: $@\n";
chdir $dir; return;
}
return if exists $args{size} and -s $file != $args{size};
system($args{run}) if exists $args{run};
unlink($file) if $args{remove};
print(((!exists $args{check_for} or -e $args{check_for})
? "done!" : "failed! ($!)"), "\n");
chdir $dir; return !$?;
}
1;
Catalyst-Model-DBIC-Schema-0.66/inc/Module/Install/Makefile.pm 000644 000766 000024 00000027437 14461412667 024155 0 ustar 00gknop staff 000000 000000 #line 1
package Module::Install::Makefile;
use strict 'vars';
use ExtUtils::MakeMaker ();
use Module::Install::Base ();
use Fcntl qw/:flock :seek/;
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.21';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
sub Makefile { $_[0] }
my %seen = ();
sub prompt {
shift;
# Infinite loop protection
my @c = caller();
if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
}
# In automated testing or non-interactive session, always use defaults
if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) {
local $ENV{PERL_MM_USE_DEFAULT} = 1;
goto &ExtUtils::MakeMaker::prompt;
} else {
goto &ExtUtils::MakeMaker::prompt;
}
}
# Store a cleaned up version of the MakeMaker version,
# since we need to behave differently in a variety of
# ways based on the MM version.
my $makemaker = eval $ExtUtils::MakeMaker::VERSION;
# If we are passed a param, do a "newer than" comparison.
# Otherwise, just return the MakeMaker version.
sub makemaker {
( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0
}
# Ripped from ExtUtils::MakeMaker 6.56, and slightly modified
# as we only need to know here whether the attribute is an array
# or a hash or something else (which may or may not be appendable).
my %makemaker_argtype = (
C => 'ARRAY',
CONFIG => 'ARRAY',
# CONFIGURE => 'CODE', # ignore
DIR => 'ARRAY',
DL_FUNCS => 'HASH',
DL_VARS => 'ARRAY',
EXCLUDE_EXT => 'ARRAY',
EXE_FILES => 'ARRAY',
FUNCLIST => 'ARRAY',
H => 'ARRAY',
IMPORTS => 'HASH',
INCLUDE_EXT => 'ARRAY',
LIBS => 'ARRAY', # ignore ''
MAN1PODS => 'HASH',
MAN3PODS => 'HASH',
META_ADD => 'HASH',
META_MERGE => 'HASH',
PL_FILES => 'HASH',
PM => 'HASH',
PMLIBDIRS => 'ARRAY',
PMLIBPARENTDIRS => 'ARRAY',
PREREQ_PM => 'HASH',
CONFIGURE_REQUIRES => 'HASH',
SKIP => 'ARRAY',
TYPEMAPS => 'ARRAY',
XS => 'HASH',
# VERSION => ['version',''], # ignore
# _KEEP_AFTER_FLUSH => '',
clean => 'HASH',
depend => 'HASH',
dist => 'HASH',
dynamic_lib=> 'HASH',
linkext => 'HASH',
macro => 'HASH',
postamble => 'HASH',
realclean => 'HASH',
test => 'HASH',
tool_autosplit => 'HASH',
# special cases where you can use makemaker_append
CCFLAGS => 'APPENDABLE',
DEFINE => 'APPENDABLE',
INC => 'APPENDABLE',
LDDLFLAGS => 'APPENDABLE',
LDFROM => 'APPENDABLE',
);
sub makemaker_args {
my ($self, %new_args) = @_;
my $args = ( $self->{makemaker_args} ||= {} );
foreach my $key (keys %new_args) {
if ($makemaker_argtype{$key}) {
if ($makemaker_argtype{$key} eq 'ARRAY') {
$args->{$key} = [] unless defined $args->{$key};
unless (ref $args->{$key} eq 'ARRAY') {
$args->{$key} = [$args->{$key}]
}
push @{$args->{$key}},
ref $new_args{$key} eq 'ARRAY'
? @{$new_args{$key}}
: $new_args{$key};
}
elsif ($makemaker_argtype{$key} eq 'HASH') {
$args->{$key} = {} unless defined $args->{$key};
foreach my $skey (keys %{ $new_args{$key} }) {
$args->{$key}{$skey} = $new_args{$key}{$skey};
}
}
elsif ($makemaker_argtype{$key} eq 'APPENDABLE') {
$self->makemaker_append($key => $new_args{$key});
}
}
else {
if (defined $args->{$key}) {
warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n};
}
$args->{$key} = $new_args{$key};
}
}
return $args;
}
# For mm args that take multiple space-separated args,
# append an argument to the current list.
sub makemaker_append {
my $self = shift;
my $name = shift;
my $args = $self->makemaker_args;
$args->{$name} = defined $args->{$name}
? join( ' ', $args->{$name}, @_ )
: join( ' ', @_ );
}
sub build_subdirs {
my $self = shift;
my $subdirs = $self->makemaker_args->{DIR} ||= [];
for my $subdir (@_) {
push @$subdirs, $subdir;
}
}
sub clean_files {
my $self = shift;
my $clean = $self->makemaker_args->{clean} ||= {};
%$clean = (
%$clean,
FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_),
);
}
sub realclean_files {
my $self = shift;
my $realclean = $self->makemaker_args->{realclean} ||= {};
%$realclean = (
%$realclean,
FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_),
);
}
sub libs {
my $self = shift;
my $libs = ref $_[0] ? shift : [ shift ];
$self->makemaker_args( LIBS => $libs );
}
sub inc {
my $self = shift;
$self->makemaker_args( INC => shift );
}
sub _wanted_t {
}
sub tests_recursive {
my $self = shift;
my $dir = shift || 't';
unless ( -d $dir ) {
die "tests_recursive dir '$dir' does not exist";
}
my %tests = map { $_ => 1 } split / /, ($self->tests || '');
require File::Find;
File::Find::find(
sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 },
$dir
);
$self->tests( join ' ', sort keys %tests );
}
sub write {
my $self = shift;
die "&Makefile->write() takes no arguments\n" if @_;
# Check the current Perl version
my $perl_version = $self->perl_version;
if ( $perl_version ) {
eval "use $perl_version; 1"
or die "ERROR: perl: Version $] is installed, "
. "but we need version >= $perl_version";
}
# Make sure we have a new enough MakeMaker
require ExtUtils::MakeMaker;
if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) {
# This previous attempted to inherit the version of
# ExtUtils::MakeMaker in use by the module author, but this
# was found to be untenable as some authors build releases
# using future dev versions of EU:MM that nobody else has.
# Instead, #toolchain suggests we use 6.59 which is the most
# stable version on CPAN at time of writing and is, to quote
# ribasushi, "not terminally fucked, > and tested enough".
# TODO: We will now need to maintain this over time to push
# the version up as new versions are released.
$self->build_requires( 'ExtUtils::MakeMaker' => 6.59 );
$self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 );
} else {
# Allow legacy-compatibility with 5.005 by depending on the
# most recent EU:MM that supported 5.005.
$self->build_requires( 'ExtUtils::MakeMaker' => 6.36 );
$self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 );
}
# Generate the MakeMaker params
my $args = $self->makemaker_args;
$args->{DISTNAME} = $self->name;
$args->{NAME} = $self->module_name || $self->name;
$args->{NAME} =~ s/-/::/g;
$args->{VERSION} = $self->version or die <<'EOT';
ERROR: Can't determine distribution version. Please specify it
explicitly via 'version' in Makefile.PL, or set a valid $VERSION
in a module, and provide its file path via 'version_from' (or
'all_from' if you prefer) in Makefile.PL.
EOT
if ( $self->tests ) {
my @tests = split ' ', $self->tests;
my %seen;
$args->{test} = {
TESTS => (join ' ', grep {!$seen{$_}++} @tests),
};
} elsif ( $Module::Install::ExtraTests::use_extratests ) {
# Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness.
# So, just ignore our xt tests here.
} elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
$args->{test} = {
TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ),
};
}
if ( $] >= 5.005 ) {
$args->{ABSTRACT} = $self->abstract;
$args->{AUTHOR} = join ', ', @{$self->author || []};
}
if ( $self->makemaker(6.10) ) {
$args->{NO_META} = 1;
#$args->{NO_MYMETA} = 1;
}
if ( $self->makemaker(6.17) and $self->sign ) {
$args->{SIGN} = 1;
}
unless ( $self->is_admin ) {
delete $args->{SIGN};
}
if ( $self->makemaker(6.31) and $self->license ) {
$args->{LICENSE} = $self->license;
}
my $prereq = ($args->{PREREQ_PM} ||= {});
%$prereq = ( %$prereq,
map { @$_ } # flatten [module => version]
map { @$_ }
grep $_,
($self->requires)
);
# Remove any reference to perl, PREREQ_PM doesn't support it
delete $args->{PREREQ_PM}->{perl};
# Merge both kinds of requires into BUILD_REQUIRES
my $build_prereq = ($args->{BUILD_REQUIRES} ||= {});
%$build_prereq = ( %$build_prereq,
map { @$_ } # flatten [module => version]
map { @$_ }
grep $_,
($self->configure_requires, $self->build_requires)
);
# Remove any reference to perl, BUILD_REQUIRES doesn't support it
delete $args->{BUILD_REQUIRES}->{perl};
# Delete bundled dists from prereq_pm, add it to Makefile DIR
my $subdirs = ($args->{DIR} || []);
if ($self->bundles) {
my %processed;
foreach my $bundle (@{ $self->bundles }) {
my ($mod_name, $dist_dir) = @$bundle;
delete $prereq->{$mod_name};
$dist_dir = File::Basename::basename($dist_dir); # dir for building this module
if (not exists $processed{$dist_dir}) {
if (-d $dist_dir) {
# List as sub-directory to be processed by make
push @$subdirs, $dist_dir;
}
# Else do nothing: the module is already present on the system
$processed{$dist_dir} = undef;
}
}
}
unless ( $self->makemaker('6.55_03') ) {
%$prereq = (%$prereq,%$build_prereq);
delete $args->{BUILD_REQUIRES};
}
if ( my $perl_version = $self->perl_version ) {
eval "use $perl_version; 1"
or die "ERROR: perl: Version $] is installed, "
. "but we need version >= $perl_version";
if ( $self->makemaker(6.48) ) {
$args->{MIN_PERL_VERSION} = $perl_version;
}
}
if ($self->installdirs) {
warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS};
$args->{INSTALLDIRS} = $self->installdirs;
}
my %args = map {
( $_ => $args->{$_} ) } grep {defined($args->{$_} )
} keys %$args;
my $user_preop = delete $args{dist}->{PREOP};
if ( my $preop = $self->admin->preop($user_preop) ) {
foreach my $key ( keys %$preop ) {
$args{dist}->{$key} = $preop->{$key};
}
}
my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
$self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
}
sub fix_up_makefile {
my $self = shift;
my $makefile_name = shift;
my $top_class = ref($self->_top) || '';
my $top_version = $self->_top->VERSION || '';
my $preamble = $self->preamble
? "# Preamble by $top_class $top_version\n"
. $self->preamble
: '';
my $postamble = "# Postamble by $top_class $top_version\n"
. ($self->postamble || '');
local *MAKEFILE;
open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
eval { flock MAKEFILE, LOCK_EX };
my $makefile = do { local $/; };
$makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
$makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
$makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
$makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
$makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
# Module::Install will never be used to build the Core Perl
# Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
# PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
$makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
#$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
# Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
$makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g;
# XXX - This is currently unused; not sure if it breaks other MM-users
# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
seek MAKEFILE, 0, SEEK_SET;
truncate MAKEFILE, 0;
print MAKEFILE "$preamble$makefile$postamble" or die $!;
close MAKEFILE or die $!;
1;
}
sub preamble {
my ($self, $text) = @_;
$self->{preamble} = $text . $self->{preamble} if defined $text;
$self->{preamble};
}
sub postamble {
my ($self, $text) = @_;
$self->{postamble} ||= $self->admin->postamble;
$self->{postamble} .= $text if defined $text;
$self->{postamble}
}
1;
__END__
#line 544
Catalyst-Model-DBIC-Schema-0.66/inc/Module/Install/WriteAll.pm 000644 000766 000024 00000002376 14461412670 024150 0 ustar 00gknop staff 000000 000000 #line 1
package Module::Install::WriteAll;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.21';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
sub WriteAll {
my $self = shift;
my %args = (
meta => 1,
sign => 0,
inline => 0,
check_nmake => 1,
@_,
);
$self->sign(1) if $args{sign};
$self->admin->WriteAll(%args) if $self->is_admin;
$self->check_nmake if $args{check_nmake};
unless ( $self->makemaker_args->{PL_FILES} ) {
# XXX: This still may be a bit over-defensive...
unless ($self->makemaker(6.25)) {
$self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL';
}
}
# Until ExtUtils::MakeMaker support MYMETA.yml, make sure
# we clean it up properly ourself.
$self->realclean_files('MYMETA.yml');
if ( $args{inline} ) {
$self->Inline->write;
} else {
$self->Makefile->write;
}
# The Makefile write process adds a couple of dependencies,
# so write the META.yml files after the Makefile.
if ( $args{meta} ) {
$self->Meta->write;
}
# Experimental support for MYMETA
if ( $ENV{X_MYMETA} ) {
if ( $ENV{X_MYMETA} eq 'JSON' ) {
$self->Meta->write_mymeta_json;
} else {
$self->Meta->write_mymeta_yaml;
}
}
return 1;
}
1;
Catalyst-Model-DBIC-Schema-0.66/inc/Module/Install/AutoInstall.pm 000644 000766 000024 00000004162 14461412670 024657 0 ustar 00gknop staff 000000 000000 #line 1
package Module::Install::AutoInstall;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.21';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
sub AutoInstall { $_[0] }
sub run {
my $self = shift;
$self->auto_install_now(@_);
}
sub write {
my $self = shift;
$self->auto_install(@_);
}
sub auto_install {
my $self = shift;
return if $self->{done}++;
# Flatten array of arrays into a single array
my @core = map @$_, map @$_, grep ref,
$self->build_requires, $self->requires;
my @config = @_;
# We'll need Module::AutoInstall
$self->include('Module::AutoInstall');
require Module::AutoInstall;
my @features_require = Module::AutoInstall->import(
(@config ? (-config => \@config) : ()),
(@core ? (-core => \@core) : ()),
$self->features,
);
my %seen;
my @requires = map @$_, map @$_, grep ref, $self->requires;
while (my ($mod, $ver) = splice(@requires, 0, 2)) {
$seen{$mod}{$ver}++;
}
my @build_requires = map @$_, map @$_, grep ref, $self->build_requires;
while (my ($mod, $ver) = splice(@build_requires, 0, 2)) {
$seen{$mod}{$ver}++;
}
my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires;
while (my ($mod, $ver) = splice(@configure_requires, 0, 2)) {
$seen{$mod}{$ver}++;
}
my @deduped;
while (my ($mod, $ver) = splice(@features_require, 0, 2)) {
push @deduped, $mod => $ver unless $seen{$mod}{$ver}++;
}
$self->requires(@deduped);
$self->makemaker_args( Module::AutoInstall::_make_args() );
my $class = ref($self);
$self->postamble(
"# --- $class section:\n" .
Module::AutoInstall::postamble()
);
}
sub installdeps_target {
my ($self, @args) = @_;
$self->include('Module::AutoInstall');
require Module::AutoInstall;
Module::AutoInstall::_installdeps_target(1);
$self->auto_install(@args);
}
sub auto_install_now {
my $self = shift;
$self->auto_install(@_);
Module::AutoInstall::do_install();
}
1;
Catalyst-Model-DBIC-Schema-0.66/inc/Module/Install/Include.pm 000644 000766 000024 00000001015 14461412670 023775 0 ustar 00gknop staff 000000 000000 #line 1
package Module::Install::Include;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.21';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
sub include {
shift()->admin->include(@_);
}
sub include_deps {
shift()->admin->include_deps(@_);
}
sub auto_include {
shift()->admin->auto_include(@_);
}
sub auto_include_deps {
shift()->admin->auto_include_deps(@_);
}
sub auto_include_dependent_dists {
shift()->admin->auto_include_dependent_dists(@_);
}
1;
Catalyst-Model-DBIC-Schema-0.66/inc/Module/Install/Metadata.pm 000644 000766 000024 00000043437 14461412667 024156 0 ustar 00gknop staff 000000 000000 #line 1
package Module::Install::Metadata;
use strict 'vars';
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.21';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
my @boolean_keys = qw{
sign
};
my @scalar_keys = qw{
name
module_name
abstract
version
distribution_type
tests
installdirs
};
my @tuple_keys = qw{
configure_requires
build_requires
requires
recommends
bundles
resources
};
my @resource_keys = qw{
homepage
bugtracker
repository
};
my @array_keys = qw{
keywords
author
};
*authors = \&author;
sub Meta { shift }
sub Meta_BooleanKeys { @boolean_keys }
sub Meta_ScalarKeys { @scalar_keys }
sub Meta_TupleKeys { @tuple_keys }
sub Meta_ResourceKeys { @resource_keys }
sub Meta_ArrayKeys { @array_keys }
foreach my $key ( @boolean_keys ) {
*$key = sub {
my $self = shift;
if ( defined wantarray and not @_ ) {
return $self->{values}->{$key};
}
$self->{values}->{$key} = ( @_ ? $_[0] : 1 );
return $self;
};
}
foreach my $key ( @scalar_keys ) {
*$key = sub {
my $self = shift;
return $self->{values}->{$key} if defined wantarray and !@_;
$self->{values}->{$key} = shift;
return $self;
};
}
foreach my $key ( @array_keys ) {
*$key = sub {
my $self = shift;
return $self->{values}->{$key} if defined wantarray and !@_;
$self->{values}->{$key} ||= [];
push @{$self->{values}->{$key}}, @_;
return $self;
};
}
foreach my $key ( @resource_keys ) {
*$key = sub {
my $self = shift;
unless ( @_ ) {
return () unless $self->{values}->{resources};
return map { $_->[1] }
grep { $_->[0] eq $key }
@{ $self->{values}->{resources} };
}
return $self->{values}->{resources}->{$key} unless @_;
my $uri = shift or die(
"Did not provide a value to $key()"
);
$self->resources( $key => $uri );
return 1;
};
}
foreach my $key ( grep { $_ ne "resources" } @tuple_keys) {
*$key = sub {
my $self = shift;
return $self->{values}->{$key} unless @_;
my @added;
while ( @_ ) {
my $module = shift or last;
my $version = shift || 0;
push @added, [ $module, $version ];
}
push @{ $self->{values}->{$key} }, @added;
return map {@$_} @added;
};
}
# Resource handling
my %lc_resource = map { $_ => 1 } qw{
homepage
license
bugtracker
repository
};
sub resources {
my $self = shift;
while ( @_ ) {
my $name = shift or last;
my $value = shift or next;
if ( $name eq lc $name and ! $lc_resource{$name} ) {
die("Unsupported reserved lowercase resource '$name'");
}
$self->{values}->{resources} ||= [];
push @{ $self->{values}->{resources} }, [ $name, $value ];
}
$self->{values}->{resources};
}
# Aliases for build_requires that will have alternative
# meanings in some future version of META.yml.
sub test_requires { shift->build_requires(@_) }
sub install_requires { shift->build_requires(@_) }
# Aliases for installdirs options
sub install_as_core { $_[0]->installdirs('perl') }
sub install_as_cpan { $_[0]->installdirs('site') }
sub install_as_site { $_[0]->installdirs('site') }
sub install_as_vendor { $_[0]->installdirs('vendor') }
sub dynamic_config {
my $self = shift;
my $value = @_ ? shift : 1;
if ( $self->{values}->{dynamic_config} ) {
# Once dynamic we never change to static, for safety
return 0;
}
$self->{values}->{dynamic_config} = $value ? 1 : 0;
return 1;
}
# Convenience command
sub static_config {
shift->dynamic_config(0);
}
sub perl_version {
my $self = shift;
return $self->{values}->{perl_version} unless @_;
my $version = shift or die(
"Did not provide a value to perl_version()"
);
# Normalize the version
$version = $self->_perl_version($version);
# We don't support the really old versions
unless ( $version >= 5.005 ) {
die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
}
$self->{values}->{perl_version} = $version;
}
sub all_from {
my ( $self, $file ) = @_;
unless ( defined($file) ) {
my $name = $self->name or die(
"all_from called with no args without setting name() first"
);
$file = join('/', 'lib', split(/-/, $name)) . '.pm';
$file =~ s{.*/}{} unless -e $file;
unless ( -e $file ) {
die("all_from cannot find $file from $name");
}
}
unless ( -f $file ) {
die("The path '$file' does not exist, or is not a file");
}
$self->{values}{all_from} = $file;
# Some methods pull from POD instead of code.
# If there is a matching .pod, use that instead
my $pod = $file;
$pod =~ s/\.pm$/.pod/i;
$pod = $file unless -e $pod;
# Pull the different values
$self->name_from($file) unless $self->name;
$self->version_from($file) unless $self->version;
$self->perl_version_from($file) unless $self->perl_version;
$self->author_from($pod) unless @{$self->author || []};
$self->license_from($pod) unless $self->license;
$self->abstract_from($pod) unless $self->abstract;
return 1;
}
sub provides {
my $self = shift;
my $provides = ( $self->{values}->{provides} ||= {} );
%$provides = (%$provides, @_) if @_;
return $provides;
}
sub auto_provides {
my $self = shift;
return $self unless $self->is_admin;
unless (-e 'MANIFEST') {
warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
return $self;
}
# Avoid spurious warnings as we are not checking manifest here.
local $SIG{__WARN__} = sub {1};
require ExtUtils::Manifest;
local *ExtUtils::Manifest::manicheck = sub { return };
require Module::Build;
my $build = Module::Build->new(
dist_name => $self->name,
dist_version => $self->version,
license => $self->license,
);
$self->provides( %{ $build->find_dist_packages || {} } );
}
sub feature {
my $self = shift;
my $name = shift;
my $features = ( $self->{values}->{features} ||= [] );
my $mods;
if ( @_ == 1 and ref( $_[0] ) ) {
# The user used ->feature like ->features by passing in the second
# argument as a reference. Accomodate for that.
$mods = $_[0];
} else {
$mods = \@_;
}
my $count = 0;
push @$features, (
$name => [
map {
ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
} @$mods
]
);
return @$features;
}
sub features {
my $self = shift;
while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
$self->feature( $name, @$mods );
}
return $self->{values}->{features}
? @{ $self->{values}->{features} }
: ();
}
sub no_index {
my $self = shift;
my $type = shift;
push @{ $self->{values}->{no_index}->{$type} }, @_ if $type;
return $self->{values}->{no_index};
}
sub read {
my $self = shift;
$self->include_deps( 'YAML::Tiny', 0 );
require YAML::Tiny;
my $data = YAML::Tiny::LoadFile('META.yml');
# Call methods explicitly in case user has already set some values.
while ( my ( $key, $value ) = each %$data ) {
next unless $self->can($key);
if ( ref $value eq 'HASH' ) {
while ( my ( $module, $version ) = each %$value ) {
$self->can($key)->($self, $module => $version );
}
} else {
$self->can($key)->($self, $value);
}
}
return $self;
}
sub write {
my $self = shift;
return $self unless $self->is_admin;
$self->admin->write_meta;
return $self;
}
sub version_from {
require ExtUtils::MM_Unix;
my ( $self, $file ) = @_;
$self->version( ExtUtils::MM_Unix->parse_version($file) );
# for version integrity check
$self->makemaker_args( VERSION_FROM => $file );
}
sub abstract_from {
require ExtUtils::MM_Unix;
my ( $self, $file ) = @_;
$self->abstract(
bless(
{ DISTNAME => $self->name },
'ExtUtils::MM_Unix'
)->parse_abstract($file)
);
}
# Add both distribution and module name
sub name_from {
my ($self, $file) = @_;
if (
Module::Install::_read($file) =~ m/
^ \s*
package \s*
([\w:]+)
[\s|;]*
/ixms
) {
my ($name, $module_name) = ($1, $1);
$name =~ s{::}{-}g;
$self->name($name);
unless ( $self->module_name ) {
$self->module_name($module_name);
}
} else {
die("Cannot determine name from $file\n");
}
}
sub _extract_perl_version {
if (
$_[0] =~ m/
^\s*
(?:use|require) \s*
v?
([\d_\.]+)
\s* ;
/ixms
) {
my $perl_version = $1;
$perl_version =~ s{_}{}g;
return $perl_version;
} else {
return;
}
}
sub perl_version_from {
my $self = shift;
my $perl_version=_extract_perl_version(Module::Install::_read($_[0]));
if ($perl_version) {
$self->perl_version($perl_version);
} else {
warn "Cannot determine perl version info from $_[0]\n";
return;
}
}
sub author_from {
my $self = shift;
my $content = Module::Install::_read($_[0]);
if ($content =~ m/
=head \d \s+ (?:authors?)\b \s*
([^\n]*)
|
=head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
.*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
([^\n]*)
/ixms) {
my $author = $1 || $2;
# XXX: ugly but should work anyway...
if (eval "require Pod::Escapes; 1") {
# Pod::Escapes has a mapping table.
# It's in core of perl >= 5.9.3, and should be installed
# as one of the Pod::Simple's prereqs, which is a prereq
# of Pod::Text 3.x (see also below).
$author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
{
defined $2
? chr($2)
: defined $Pod::Escapes::Name2character_number{$1}
? chr($Pod::Escapes::Name2character_number{$1})
: do {
warn "Unknown escape: E<$1>";
"E<$1>";
};
}gex;
}
elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) {
# Pod::Text < 3.0 has yet another mapping table,
# though the table name of 2.x and 1.x are different.
# (1.x is in core of Perl < 5.6, 2.x is in core of
# Perl < 5.9.3)
my $mapping = ($Pod::Text::VERSION < 2)
? \%Pod::Text::HTML_Escapes
: \%Pod::Text::ESCAPES;
$author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
{
defined $2
? chr($2)
: defined $mapping->{$1}
? $mapping->{$1}
: do {
warn "Unknown escape: E<$1>";
"E<$1>";
};
}gex;
}
else {
$author =~ s{E}{<}g;
$author =~ s{E}{>}g;
}
$self->author($author);
} else {
warn "Cannot determine author info from $_[0]\n";
}
}
#Stolen from M::B
my %license_urls = (
perl => 'http://dev.perl.org/licenses/',
apache => 'http://apache.org/licenses/LICENSE-2.0',
artistic => 'http://opensource.org/licenses/artistic-license.php',
lgpl => 'http://opensource.org/licenses/lgpl-license.php',
bsd => 'http://opensource.org/licenses/bsd-license.php',
gpl => 'http://opensource.org/licenses/gpl-license.php',
gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
mit => 'http://opensource.org/licenses/mit-license.php',
mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
open_source => undef,
unrestricted => undef,
restrictive => undef,
unknown => undef,
# these are not actually allowed in meta-spec v1.4 but are left here for compatibility:
apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1',
artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
);
sub license {
my $self = shift;
return $self->{values}->{license} unless @_;
my $license = shift or die(
'Did not provide a value to license()'
);
$license = __extract_license($license) || lc $license;
$self->{values}->{license} = $license;
# Automatically fill in license URLs
if ( $license_urls{$license} ) {
$self->resources( license => $license_urls{$license} );
}
return 1;
}
sub _extract_license {
my $pod = shift;
my $matched;
return __extract_license(
($matched) = $pod =~ m/
(=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?)
(=head \d.*|=cut.*|)\z
/xms
) || __extract_license(
($matched) = $pod =~ m/
(=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?)
(=head \d.*|=cut.*|)\z
/xms
);
}
sub __extract_license {
my $license_text = shift or return;
my @phrases = (
'(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1,
'(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1,
'Artistic and GPL' => 'perl', 1,
'GNU general public license' => 'gpl', 1,
'GNU public license' => 'gpl', 1,
'GNU lesser general public license' => 'lgpl', 1,
'GNU lesser public license' => 'lgpl', 1,
'GNU library general public license' => 'lgpl', 1,
'GNU library public license' => 'lgpl', 1,
'GNU Free Documentation license' => 'unrestricted', 1,
'GNU Affero General Public License' => 'open_source', 1,
'(?:Free)?BSD license' => 'bsd', 1,
'Artistic license 2\.0' => 'artistic_2', 1,
'Artistic license' => 'artistic', 1,
'Apache (?:Software )?license' => 'apache', 1,
'GPL' => 'gpl', 1,
'LGPL' => 'lgpl', 1,
'BSD' => 'bsd', 1,
'Artistic' => 'artistic', 1,
'MIT' => 'mit', 1,
'Mozilla Public License' => 'mozilla', 1,
'Q Public License' => 'open_source', 1,
'OpenSSL License' => 'unrestricted', 1,
'SSLeay License' => 'unrestricted', 1,
'zlib License' => 'open_source', 1,
'proprietary' => 'proprietary', 0,
);
while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
$pattern =~ s#\s+#\\s+#gs;
if ( $license_text =~ /\b$pattern\b/i ) {
return $license;
}
}
return '';
}
sub license_from {
my $self = shift;
if (my $license=_extract_license(Module::Install::_read($_[0]))) {
$self->license($license);
} else {
warn "Cannot determine license info from $_[0]\n";
return 'unknown';
}
}
sub _extract_bugtracker {
my @links = $_[0] =~ m#L<(
https?\Q://rt.cpan.org/\E[^>]+|
https?\Q://github.com/\E[\w_]+/[\w_]+/issues|
https?\Q://code.google.com/p/\E[\w_\-]+/issues/list
)>#gx;
my %links;
@links{@links}=();
@links=keys %links;
return @links;
}
sub bugtracker_from {
my $self = shift;
my $content = Module::Install::_read($_[0]);
my @links = _extract_bugtracker($content);
unless ( @links ) {
warn "Cannot determine bugtracker info from $_[0]\n";
return 0;
}
if ( @links > 1 ) {
warn "Found more than one bugtracker link in $_[0]\n";
return 0;
}
# Set the bugtracker
bugtracker( $links[0] );
return 1;
}
sub requires_from {
my $self = shift;
my $content = Module::Install::_readperl($_[0]);
my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg;
while ( @requires ) {
my $module = shift @requires;
my $version = shift @requires;
$self->requires( $module => $version );
}
}
sub test_requires_from {
my $self = shift;
my $content = Module::Install::_readperl($_[0]);
my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
while ( @requires ) {
my $module = shift @requires;
my $version = shift @requires;
$self->test_requires( $module => $version );
}
}
# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
# numbers (eg, 5.006001 or 5.008009).
# Also, convert double-part versions (eg, 5.8)
sub _perl_version {
my $v = $_[-1];
$v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
$v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
$v =~ s/(\.\d\d\d)000$/$1/;
$v =~ s/_.+$//;
if ( ref($v) ) {
# Numify
$v = $v + 0;
}
return $v;
}
sub add_metadata {
my $self = shift;
my %hash = @_;
for my $key (keys %hash) {
warn "add_metadata: $key is not prefixed with 'x_'.\n" .
"Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/;
$self->{values}->{$key} = $hash{$key};
}
}
######################################################################
# MYMETA Support
sub WriteMyMeta {
die "WriteMyMeta has been deprecated";
}
sub write_mymeta_yaml {
my $self = shift;
# We need YAML::Tiny to write the MYMETA.yml file
unless ( eval { require YAML::Tiny; 1; } ) {
return 1;
}
# Generate the data
my $meta = $self->_write_mymeta_data or return 1;
# Save as the MYMETA.yml file
print "Writing MYMETA.yml\n";
YAML::Tiny::DumpFile('MYMETA.yml', $meta);
}
sub write_mymeta_json {
my $self = shift;
# We need JSON to write the MYMETA.json file
unless ( eval { require JSON; 1; } ) {
return 1;
}
# Generate the data
my $meta = $self->_write_mymeta_data or return 1;
# Save as the MYMETA.yml file
print "Writing MYMETA.json\n";
Module::Install::_write(
'MYMETA.json',
JSON->new->pretty(1)->canonical->encode($meta),
);
}
sub _write_mymeta_data {
my $self = shift;
# If there's no existing META.yml there is nothing we can do
return undef unless -f 'META.yml';
# We need Parse::CPAN::Meta to load the file
unless ( eval { require Parse::CPAN::Meta; 1; } ) {
return undef;
}
# Merge the perl version into the dependencies
my $val = $self->Meta->{values};
my $perl = delete $val->{perl_version};
if ( $perl ) {
$val->{requires} ||= [];
my $requires = $val->{requires};
# Canonize to three-dot version after Perl 5.6
if ( $perl >= 5.006 ) {
$perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e
}
unshift @$requires, [ perl => $perl ];
}
# Load the advisory META.yml file
my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
my $meta = $yaml[0];
# Overwrite the non-configure dependency hashes
delete $meta->{requires};
delete $meta->{build_requires};
delete $meta->{recommends};
if ( exists $val->{requires} ) {
$meta->{requires} = { map { @$_ } @{ $val->{requires} } };
}
if ( exists $val->{build_requires} ) {
$meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
}
return $meta;
}
1;
Catalyst-Model-DBIC-Schema-0.66/inc/Module/Install/Base.pm 000644 000766 000024 00000002147 14461412667 023301 0 ustar 00gknop staff 000000 000000 #line 1
package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
$VERSION = '1.21';
}
# Suspend handler for "redefined" warnings
BEGIN {
my $w = $SIG{__WARN__};
$SIG{__WARN__} = sub { $w };
}
#line 42
sub new {
my $class = shift;
unless ( defined &{"${class}::call"} ) {
*{"${class}::call"} = sub { shift->_top->call(@_) };
}
unless ( defined &{"${class}::load"} ) {
*{"${class}::load"} = sub { shift->_top->load(@_) };
}
bless { @_ }, $class;
}
#line 61
sub AUTOLOAD {
local $@;
my $func = eval { shift->_top->autoload } or return;
goto &$func;
}
#line 75
sub _top {
$_[0]->{_top};
}
#line 90
sub admin {
$_[0]->_top->{admin}
or
Module::Install::Base::FakeAdmin->new;
}
#line 106
sub is_admin {
! $_[0]->admin->isa('Module::Install::Base::FakeAdmin');
}
sub DESTROY {}
package Module::Install::Base::FakeAdmin;
use vars qw{$VERSION};
BEGIN {
$VERSION = $Module::Install::Base::VERSION;
}
my $fake;
sub new {
$fake ||= bless(\@_, $_[0]);
}
sub AUTOLOAD {}
sub DESTROY {}
# Restore warning handler
BEGIN {
$SIG{__WARN__} = $SIG{__WARN__}->();
}
1;
#line 159
]