...And this is what the products that we make do:
these are the consequences. They either empower
people, or they steal bits of their lives.
Because experiences are all we have in life:
if you think about them as grains of sand in an
hour glass, once those grains are gone – they are
gone. And experiences with people and experiences
with things: they use up the same grains.
That's why we have a profound responsibility to
respect the experiences of the people that we
build for...
-- Aral Balkan: Free is a Lie TNW 2014
https://youtu.be/upu0gwGi4FE?t=1548
This set of commits is unusual - the 2+kloc of changes (in lib/ alone) do not
add any new runtime functionality, nor do these changes alter significantly
any aspect of DBIC's runtime operation. Instead this is a culmination of a
nearly 4 months long death-march [1] ensuring the increasingly complex and
more frequent ( courtesy of rising use of Moo(se) ) failure modes can be
reasoned about and acted upon by ordinary users, without the need to reach
out to a support channel.
The changeset has been extensively tested against 247 downstream CPAN dists
(as described at the end of commit
12e7015a) and against several darkpan
test suites. As of this merge there are no known issues except RT#114440 [2]
and a number of dists (enumerated in
12e7015a) now emitting *REALLY LOUD*
though warranted and actionable, diagnostic messages.
The diagnostic is emitted directly on STDERR - this was a deliberate choice
designed to:
1) prevent various test suites from failing due to unexpected warnings
2) make the warnings *harder* to silence by a well meaning but often too
eager-yet-not-sufficiently-dilligent staffer, before the warnings had
a chance to reach a senior developer
What follows is a little bit of gory technical details on the commit series,
as the work is both generic/interesting enough to be applied to other large
scale systems, and is "clever" enough to not be easily reasoned about without
a summary. Think of this as a blog post within an unusual medium ;)
=== BACKGROUND
==============
Some necessary history: DBIC as a project is rather old [3][4]. When it got
started Moose wasn't a thing. Neither (for perspective) was jQuery or even
Tw(i)tt(e)r. The software it was modeled on (Class::DBI) has "single-level"
metadata: you have one class per table, and columns/accessor were defined on
that class and that was it. At the time mst made the brilliant decision to
keep the original class-based API (so that the CDBI test suite can be reused
almost verbatim, see
ea2e61bf) while at the same time moving the metadata to
a "metaclass instance" of sorts. The way this worked was for each level of:
- Individual Result Class (class itself, not instance)
- Result Class attached to a Schema class
- Result Class attached to a Schema instance
to have a separate copy-on-the-spot created metadata instance object of
DBIx::Class::ResultSource. One can easily see this by executing:
~/dbic_checkout$ perl -Ilib -It/lib -MDBICTest -MData::Dumper -e '
my $s = DBICTest->init_schema;
$Data::Dumper::Maxdepth = 1;
warn Dumper [
DBICTest::Schema::Artist->result_source_instance,
DBICTest::Schema->source("Artist"),
$s->source("Artist"),
]
'
The technique (and ingenious design) worked great. The downside was that
nobody ever really audited the entire stack past the original implementation.
The codebase grew, and mistakes started to seep in: sometimes modifications
(add_columns, etc) would happen on a derivative metadata instance, while the
getters would still be invoked on the "parent" (which at this point was
oblivious of its "child" existence, and vice versa). In addition there was a
weird accessor split: given a result instance one could reach *different*
metadata instances via either result_source() or result_source_instance(). To
add insult to the injury the latter method is never defined anywhere, and was
always dynamically brought to life at runtime via an accessor maker call on
each individual class [5].
If that wasn't bad enough, some (but crucially *not* all) routines used to
manipulate resultsource metadata were proxied [6] to the main Result classes,
also aiming at allowing the reuse of the existing Class::DBI test suite, and
to provide a more familiar environment to Class::DBI converts. The complete
map of current metadata manipulation methods and their visibility from a
typical ResultClass can be seen at the end of commit message
28ef9468.
The downside was that to an outsider it would seem only natural that if in
order to make something metadata-related happen, one normally calls:
SomeResultClass->set_primary_key
then it makes sense that one should be able to override it via:
sub SomeResultClass::set_primary_key {
my $ret = shift->next::method(@_);
{ do extra stuff }
}
That thinking has been applied to pretty much all straight-pass-through
getters in the wild, with the expectation that DBIC will respect them
throughout, like e.g. [7]. In reality this never happened - half of DBIC
would never even look at the Result class and instead simply called the
needed method on the result source instance directly. As noted in
28ef9468:
the overwhelmingly common practice is to hook a method in a Result class and
to "hope for the best". A rare example of "doing it right" would be
DBIx::Class::ResultSource::MultipleTableInheritance [8], but as can be seen
from its SYNOPSIS the API is rather counterintuitive ( what is table_class()
anyway?! ) and more importantly - the earlier example seems "just right".
Another innovation (remember: pre-Moose) was the use of the just-in-time
implemented [9] alternative C3 method resolution order (MRO)[10] right on top
of the default perl DFS MRO. While DBIC used multiple inheritance (MI) from
the start, with all the corresponding problems [11][12][13] and non-scalable
"solutions" [14], it wasn't until C3 MRO became available that the true
potential of the resulting plugin system became clear. To this day (mid-2016)
MI, as used within the DBIC ecosystem, remains the single most flexible (and
thus superior given the problem domain) plugin-system on CPAN, easily
surpassing rigid delegation, and having an upper hand on role-based solutions
as promoted by the Moo(se) ecosystem. It must be noted that delegation and/or
roles are not without uses - they are an excellent (and frankly should be a
default) choice for many application-level systems. It is the mid-level to
low-level libraries like DBIC, where the stateless nature of a predictable
yet non-coordinated call-order resolution truly begins to shine.
=== PROBLEM(S)
==============
Things stayed undisturbed for a while, until around 2012~2013 folks started
showing up with more and more complaints which all traced to Moo(se)-based
subclassing. Originally the C3 MRO composition worked just fine, because
almost invariably a ->load_components() call (which explicitly switches the
callER MRO) would have happened early enough in the life of any end-user
Result/ResultSource class. But when extends()/with() got more prominent this
was lost. The more complex the inheritance chain - the more likely that the
topmost leaf class is in fact stuck under DFS mro with everything going
sideways from there. Sometimes with truly mindbending failure cases as [15].
There was no clear solution at the time, and aside from some toothless
documentation warnings [16] nothing was done to address this (in fact even
the doc-patch itself is incomplete as noted in [17]).
The inconsistencies, and the resulting mistakes, however, were all localized,
and even though the problems were often major, each instance was sufficiently
different (and bizarre) that each individual deployment could neither report
them properly, nor find the time to reason through the layers of history in
order to arrive at a solution they fully understand. Yet the original design
which solidified towards the end of 2007 was *just* good enough to keep being
kicked down the road.
But people kept writing more and more MOP-inspired stuff. Given the general
tendency of perl code to get "all over the place", the desire was only
natural to standardize on "one true way" of doing OO throughout an entire
end-user project/app. And there were more and more ways in the wild to
combine/abstract individual Result classes and ResultSet components. The
comprehensive DBIx::Class::Helpers [18] are just the tip of the heap of
all possible permutations DBIC is exposed to. Towards mid-2015 it became
utterly untenable to brush off problems with "meh, just don't do that and all
will be be fine".
On the personal front I first ran into the baroque jenga tower head-on when
I tried to make sense of the ResultSource subsystem in an airport lounge
pre-YAPC::EU 2011 (Riga). I honestly do not remember *why* I started digging
in this direction but the result of that attempt (and the later effort to
revive it) got immortalized in my local tree [19]. Enough said.
Next was the dash to implement sane relationship resolution semantics in
03f6d1f7, and then in 350e8d57 (which was actually needed to allow for
d0cefd99 to take place... sigh). During that journey 4006691d made a subtle
but fatal in the long run change - it upset the balance of which source
instance object we looked at during *some* (but not all) codepaths. The
really sad part is that I had the feeling that something is not right, and
even made a record of it as the last paragraph of
350e8d57. But light
testing did not reveal anything, and I irresponsibly shipped everything
as-is a bit later. It wasn't until Oct 2015 that someone noticed this being
an actual problem [20]. Early attempts to fix it quickly demonstrated just
how deep the rabbit hole goes, and were the main reason the entirety of
this work was undertaken: the accumulated debt simply did not leave any room
for a half-way solution :/
=== SOLUTION(S)
===============
The writeup below describes only the final set of commits: it does not cover
driving into and backing out of at least 3 dead-ends, nor does it cover the
5 distinct rewrites and re-shuffles of the entire stack as more and more
involved testing revealed more and more involved failure modes. I must stress
that if you plan to undertake a similar crusade against another projects
architectural debt you are in for a rough (but *not* impossible!) ride. The
height of the "tenacity-bar" necessary to pull off such work is not reflected
in any way within the seemingly effortless walkthrough that follows. It is
also worth acknowledging that the code at times is incredibly terse and hard
to follow: this was a deliberate choice as the extra diagnostic sites that
are enabled during runtime had to be implemented as "close to the VM", so to
speak, as possible. In isolation none of the contortions are warranted, but
because I ended up with so many of them the result does pay off. See comments
within individual commit messages for various performance impacts for more
info.
As first order of business some mechanism was needed to track the logical
relationship between the 3 levels of ResultSource instances as shown earlier
in this writeup. Luckily, the user-unfriendly nature of the metadata stack
meant there are very few spots on CPAN (and to the best of my knowledge
on DarkPAN) that do anything exotic with the subsystem. This means the
simplest thing would in fact work and was implemented as
534aff61: corral
all instantiations of ResultSource objects (and Schema objects while we are
at it) [21]. This code ensured that nothing in the stack will create an
instance of either class-type without our knowledge. With that in place, we
also provide an explicit clone method [22] encouraging folks to use that
whenever possible. The switch of all relevant callsites within DBIC itself
was verified through another check within new [23], guarded by the same
compile-time assertion constant (which in turn was provided by both the CI
and the local smoke-script from
5b87fc0f)
With the above in place, ensuring 99.99% of the ResultSource "derivative"
instances were obtained via $rsrc->clone, it was time for
0ff33686. A simple
private registry hash with object addresses as keys and this hash as values:
{
derivatives => {
addr_derived_rsrc_1 => $reference_to_infohash_of_derived_rsrc_1,
addr_derived_rsrc_2 => $reference_to_infohash_of_derived_rsrc_2,
...
},
weakref => $weak_reference_of_self,
}
As necessary for any structure holding addresses of object references, a
CLONE "renumbering" routine takes care of keeping everything in sync on
iThread spawns (if you believe that iThreads are evil and one shouldn't go
through the trouble: be reminded that any call of fork() within a Win32 perl
is effectively an iThread, and fork() can and *is* being called by some CPAN
modules [24] implicitly).
Now that we had a good handle on "what came from where", the first major
diagnostic milestone
73f54e27 could be covered. As can be seen in the table
of methods in commit
28ef9468 there are only a handful of attributes on an
actual ResultSource class. A couple new Class::Accessor::Grouped method types
were added, which would behave just like the 'simple' and 'component_class'
they were replacing, but with a twist:
- any setter-based change would record its callsite in any derivative that
was being tracked by
0ff33686, effectively marking that derivative stale
- any getter call would consult its own entry in the metadata instance
"stale log", and complain that things have moved on based on the callsite
the setter left earlier
The result is the exact warning as described in commit message
73f54e27. Of
course there are some extra considerations - some high-level setters (e.g.
remove_columns) do call a getter underneath to do their job. These cases had
to be short-circuited by using a local()-based "setter callstack" mark. But
in general the changeset has been surprisingly non-invasive: once the proper
hook points were identified the rest was a breeze. There was also a brief
scratching of heads when the last stages of DarkPAN tests emitted errors
which I myself could not explain for a while, until the reason (and trivial
solution) were identified in
d56e05c7 and [25].
As a brief detour, I considered switching ResultSource to a proper Moo class,
but quickly abandoned this idea as there are no provision for clean get-time
triggers. Nevertheless the attempt was a useful demonstration what does it
take to switch a low-level class (which means many somewhat questionable uses
by consumers in the wild) to Moo(se) with zero loss of functionality. The
result is preserved for posterity as
8ae83f0e [26].
While working on the above and
f064a2ab (the solution to RT#107462 [20]), it
occurred to me that the confusion of having both result_source_instance()
and result_source() can be reduced further by forcing all "getter" calls to
go through result_source() which is defined in Row.pm and is thus always
available. The result was the improved diagnostic as described in the commit
message of
e570488a, but also a useful set of assertions that were used to
weed out many of the wrinkles [27].
The next major step was to resolve once and for all the fallout from
incorrect inheritance composition. The highly dynamic nature of all Perl's
programs, an "eternal compile/execute/compile/execute... cycle", meant that
just "fixing things" as DBIC sees them would not work - calling set_mro()
could do little when called late enough. This led to the revert of the
originally-promising "forced c3-fication" of the stack
7648acb5. Instead
the practical design turned out to be "let the user know and carry on".
The first part of getting there was to devise a way to precisely and very
quickly tell "what does a class look like right now?" I have been brooding
over how to do this since mid-February, but it wasn't until I noticed
the excellent App::Isa::Splain [28] by @kentfredric, that the final interface
came into focus:
296248c3 (with several minor fixups later on). Here I want
to take a moment to apologize to @kentfredric, as he was led on a several
week long wild-goose chase due to a misguided comment of mine [29] :(
Amusingly while implementing this I hit a wall related to perl 5.8 (for the
first time in 6+ years): As stated in the timings at the end of commit
message
296248c3 and as elaborated in [30] - the non-core MRO is just too
expensive to work with. This resulted in a 1.5 week long detour to try to
squeeze every last ounce of performance. Amusingly I ran into a lot of
"interesting" stuff along the way [31][32][33] The result was not only a
semi-usable 5.8 implementation, but even running on 5.10+ was sped up about
2 times in the end, which translated into tangible gains in the end: the
number cited as 16% in
12e7015a was originally 28%(!). The moral of this
story? - gerontoperlia [34] makes your modern foundation code better.
With a reliable way to tell what each methods "variant stack" looks like, it
was trivial to implement the 'valid_c3_composition' part of ::SanityChecker -
one would simply check a class' MRO, and in case of 'dfs' compare all stacks
to what they would look like if the MRO were 'c3' [35].
In parallel but unrelated to the above the ever increasing tightening of
various DBIC internal callpaths (
e5053694, d99f2db7, 3b020224 ) had to be
addressed in some way. The urgency truly "hit home" when testing revealed
RT#114440 [2] - it was nothing short of a miracle this code survived that
long without being utterly broken by other components. The solution came out
of crossing the work on describe_class_methods (
296248c3) with the concept
of the fail_on_internal_call guard (
77c3a5dc). We already have a list of
method "shadowing stacks" (to borrow @kentfredric's terminology) - if we find
a way to annotate methods in a way that we can tell when a "non-overrideable"
method was in fact overridden - we will be able to report this to the user.
The somewhat fallen out of favor subsystem of function attributes was chosen
to carry out the "annotation" task. It must be noted that this is one of the
few uses of attributes on CPAN that is architecturally consistent with how
attributes were originally implemented. An attribute is meant to attach to
a specific reference ( in our case a code reference ), instead of a name.
This is also why the FETCH/MODIFY_type_ATTRIBUTE API operates strictly with
references. As an illustration why tracking attributes by name is fraught
with peril consider the following:
perl -e '
use Data::Dumper;
use Moose;
use MooseX::MethodAttributes;
sub somemethod :Method_expected_to_always_returns_true { return 1 };
around somemethod => sub { return 0 };
warn Dumper {
attributes => __PACKAGE__->meta->get_method("somemethod")->attributes,
result => __PACKAGE__->somemethod
};
'
It should also be noted that as of this merge describe_class_methods lacks
a mechanism to "see" code references captured by around-type modifiers, and
by extension the "around-ed" function's attributes will not appear in the
"shadowed stack". A future modification of Class::Method::Modifiers, allowing
minimal introspection of what was done to which coderef should alleviate most
of this problem.
Once all relevant methods were tagged with a 'DBIC_method_is_indirect_sugar'
attribute in
1b822bd3, it was trivial to implement the schema sanity check
no_indirect_method_overrides which simply ensures no user-provided method
"shadows" a superclass method with the 'sugar' attribute set [36].
The success of the attribute-based approach prompted a pass of annotating
all the methods DBIC generates for one reason or another:
09d8fb4a. Aside
from enabling the last improvement, it also allowed to replicate a part of
the DBIx::Class::IntrospectableM2M functionality in core, without elevating
the status of the m2m sugar methods in any way (the historic labeling of
these helpers as relationships is a long standing source of confusion). See
the commit message of
09d8fb4a for a couple use-cases.
The last piece of the puzzle
28ef9468 addressed the "override and hope for
the best" duality of ResultSource proxied methods as described at the start
of this writeup and at [37]. What we essentially do is add an around() [38]
for every method in ResultSource, which then checks whether it was called via
ResultSourceProxy (inherited from DBIx::Class::Core), or directly via the
ResultSource instance: i.e. MySchema::Result::Foo->proxied vs $rsrc->proxied
IFF we are called directly and there *is* an override of the same method on
the currently-used $rsrc->result_class we either follow one of the options
as given by an attribute annotation [37], or we emit a diag message so that
the user can do something about it.
That was easy wasn't it?
=== FINAL THOUGHTS
==================
This work took about 50 person-days to carry out, and for obvious reasons
expanded to cover a much larger period of actual wall-time. While I am by
far not the most efficient developer that I have met, I am pretty sure that
the process of planning, designing, implementing and testing all of this
could not have been significantly accelerated. Even at the (laughable) rate
of $50/h The Perl Foundation is willing to pay for unique talent [39] this
endeavor would cost at least $20,000 USD - way beyond the scope (and aim?)
of a TPF grant. On the other hand it would be surprising if this work can
be qualified as unnecessary. I personally estimate that the savings due to
the proper diagnostics alone will "make up" for the effort within the first
month of wide deployment of these improvements. Time will tell of course, as
the stream of questions is only about to start come the first days of August.
In any case - this project is by far not the only one in dire need of such
"humane" overhaul. Moo, Catalyst, various pieces of the toolchain, and other
staples of what is known as "modern perl5" are in similar or worse shape:
a situation which can *not* be rectified simply by "writing patches" without
a concerted effort directed by a single [40] dedicated individual.
I yet again strongly urge the "powers of Perl" to reconsider their hands-off
approach to funding the consistently shrinking pool of maintainers. *PLEASE*
consider stealing (in the spirit of tradition) the proven successful model of
RubyTogether [41] before you end up losing even more maintainers like myself.
Peter "ribasushi" Rabbitson
Outgoing maintainer of a cornerstone Perl5 ecosystem project
( in the future you may be needing https://archive.org/web/ to see some of these )
[1] https://gist.github.com/ribasushi/
6ea33c921927c7571f02e5c8b09688ef
[2] https://rt.cpan.org/Ticket/Display.html?id=114440#txn-1627249
[3] http://static.spanner.org/lists/cdbi/2005/07/25/
90c9f5f1.html
[4] http://lists.digitalcraftsmen.net/pipermail/classdbi/2005-August/000039.html
[5] https://metacpan.org/source/RIBASUSHI/DBIx-Class-0.082840/lib/DBIx/Class/ResultSourceProxy/Table.pm#L17-21
[6] https://metacpan.org/source/RIBASUSHI/DBIx-Class-0.082840/lib/DBIx/Class/ResultSourceProxy.pm#L53-87
[7] https://metacpan.org/source/VANSTYN/RapidApp-1.2000/lib/RapidApp/DBIC/Component/VirtualColumnsExt.pm#L52-67
[8] https://metacpan.org/pod/DBIx::Class::ResultSource::MultipleTableInheritance#SYNOPSIS
[9] https://twitter.com/hashtag/dammitstevan
[10] https://en.wikipedia.org/wiki/C3_linearization
[11] https://en.wikipedia.org/wiki/Multiple_inheritance#The_diamond_problem
[12] http://static.spanner.org/lists/cdbi/2005/07/25/
caf44f84.html
[13] http://static.spanner.org/lists/cdbi/2005/07/26/
e593c147.html
[14] http://static.spanner.org/lists/cdbi/2005/07/26/
ea509a6a.html (... tell people "Be Careful!" )
[15] https://blog.afoolishmanifesto.com/posts/mros-and-you/
[16] https://metacpan.org/pod/DBIx::Class::ResultSet#ResultSet-subclassing-with-Moose-and-similar-constructor-providers
[17] https://github.com/dbsrgits/dbix-class/pull/49#issuecomment-
47637403
[18] https://metacpan.org/release/DBIx-Class-Helpers
[19] http://i.imgur.com/A3acsCD.png
[20] https://rt.cpan.org/Ticket/Display.html?id=107462
[21] https://github.com/dbsrgits/dbix-class/blob/
534aff61/lib/DBIx/Class/_Util.pm#L1082-L1135
[22] https://github.com/dbsrgits/dbix-class/blob/
534aff61/lib/DBIx/Class/ResultSource.pm#L160-L184
[23] https://github.com/dbsrgits/dbix-class/blob/
534aff61/lib/DBIx/Class/ResultSource.pm#L126-L143
[24] http://grep.cpan.me/?q=my+%5C%24pid%3D+fork+dist%3DXML-Twig
[25] https://github.com/ctrlo/GADS/pull/9/files
[26] http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/DBIx-Class-Historic.git;a=commitdiff;h=
8ae83f0e
[27] https://github.com/dbsrgits/dbix-class/blob/
e570488a/t/lib/DBICTest/BaseSchema.pm#L379-L528
[28] https://metacpan.org/pod/App::Isa::Splain#SYNOPSIS
[29] https://github.com/kentnl/Devel-Isa-Explainer/issues/1#issuecomment-
212248379
[30] https://github.com/dbsrgits/dbix-class/blob/
12e7015a/lib/DBIx/Class/Schema/SanityChecker.pm#L92-L102
[31] https://twitter.com/ribasushi/status/
753678208076242944
[32] https://github.com/dbsrgits/dbix-class/commit/
296248c3#diff-c13797cc2e5864c4a1d6a92ba65871b6R801
[33] https://github.com/dbsrgits/dbix-class/blob/
1cf2ad8b/lib/DBIx/Class/_Util.pm#L663-L664
[34] https://youtu.be/2Ln0YHtKgaI?t=3731
[35] https://github.com/dbsrgits/dbix-class/blob/
12e7015a/lib/DBIx/Class/Schema/SanityChecker.pm#L484-L505
[36] https://github.com/dbsrgits/dbix-class/blob/
12e7015a/lib/DBIx/Class/Schema/SanityChecker.pm#L359-L394
[37] https://github.com/dbsrgits/dbix-class/blob/
28ef9468/lib/DBIx/Class/MethodAttributes.pm#L242-L298
[38] https://github.com/dbsrgits/dbix-class/blob/
28ef9468/lib/DBIx/Class/ResultSourceProxy.pm#L137-L333
[39] http://news.perlfoundation.org/2016/02/grant-proposal-perl-6-performa.html#comment-
38362169
[40] http://queue.acm.org/detail.cfm?id=2349257 ( ... quality happens only if somebody has the responsibility for it, and that "somebody" can be no more than one single person )
[41] https://rubytogether.org/roadmap
the maintainer believe this is safe, but this is a very complex
area and reality may turn out to be different. If **ANYHTING** at
all seems out of place, please file a report at once
+ - The unique constraint info (including the primary key columns) is no
+ longer shared between related (class and schema-level) ResultSource
+ instances. If your app stops working with no obvious pointers, set
+ DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE=1 to obtain extra info
- Neither exception_action() nor $SIG{__DIE__} handlers are invoked
on recoverable errors. This ensures that the retry logic is fully
insulated from changes in control flow, as the handlers are only
invoked when an error is leaving the DBIC internals to be handled by
the caller (n.b. https://github.com/PerlDancer/Dancer2/issues/1125)
(also fixes the previously rejected RT#63874)
+ - Overrides of ResultSourceProxy-provided methods are no longer skipped
+ silently: a one-per-callsite warning is issued any time this tricky
+ situation is encoutered https://is.gd/dbic_rsrcproxy_methodattr
- $result->related_resultset() no longer passes extra arguments to
an underlying search_rs(), as by design these arguments would be
used only on the first call to ->related_resultset(), and ignored
instead of silently discarding the argument
* New Features
+ - DBIC now performs a range of sanity checks on the entire hierarchy
+ of Schema/Result/ResultSet classes loudly alerting the end user to
+ potential extremely hard-to-diagnose pitfalls ( RT#93976, also fully
+ addresses https://blog.afoolishmanifesto.com/posts/mros-and-you/ )
- InflateColumn::DateTime now accepts the ecosystem-standard option
'time_zone', in addition to the DBIC-only 'timezone' (GH#28)
- Massively optimised literal SQL snippet scanner - fixes all known
specific DateTime::Format dependencies
* Fixes
+ - Fix regresion (0.082800) of certain calls being presented stale
+ result source metadata (RT#107462)
- Fix incorrect SQL generated with invalid {rows} on complex resultset
operations, generally more robust handling of rows/offset attrs
- Fix incorrect $storage state on unexpected RDBMS disconnects and
use base qw/DBIx::Class::Schema/;
__PACKAGE__->load_namespaces;
+# no point taxing 5.8, but otherwise leave the default: a user may
+# be interested in exploring and seeing what broke
+__PACKAGE__->schema_sanity_checker('')
+ if DBIx::Class::_ENV_::OLD_MRO;
+
1;
use warnings;
use base qw( DBIx::Class::MethodAttributes Class::Accessor::Grouped );
-use mro 'c3';
-use Scalar::Util qw/weaken blessed/;
+use Scalar::Util 'blessed';
use DBIx::Class::_Util 'fail_on_internal_call';
use namespace::clean;
-sub mk_classdata {
+sub mk_classdata :DBIC_method_is_indirect_sugar {
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
shift->mk_classaccessor(@_);
}
-sub mk_classaccessor {
+sub mk_classaccessor :DBIC_method_is_indirect_sugar {
my $self = shift;
$self->mk_group_accessors('inherited', $_[0]);
(@_ > 1)
;
}
-my $successfully_loaded_components;
+sub mk_group_accessors {
+ my $class = shift;
+ my $type = shift;
+
+ $class->next::method($type, @_);
+
+ # label things
+ if( $type =~ /^ ( inflated_ | filtered_ )? column $/x ) {
+
+ $class = ref $class
+ if length ref $class;
+
+ for my $acc_pair (
+ map
+ { [ $_, "_${_}_accessor" ] }
+ map
+ { ref $_ ? $_->[0] : $_ }
+ @_
+ ) {
+
+ for my $i (0, 1) {
+
+ my $acc_name = $acc_pair->[$i];
+
+ attributes->import(
+ $class,
+ (
+ $class->can($acc_name)
+ ||
+ Carp::confess("Accessor '$acc_name' we just created on $class can't be found...?")
+ ),
+ 'DBIC_method_is_generated_from_resultsource_metadata',
+ ($i
+ ? "DBIC_method_is_${type}_extra_accessor"
+ : "DBIC_method_is_${type}_accessor"
+ ),
+ )
+ }
+ }
+ }
+}
sub get_component_class {
my $class = $_[0]->get_inherited($_[1]);
- # It's already an object, just go for it.
- return $class if blessed $class;
-
- if (defined $class and ! $successfully_loaded_components->{$class} ) {
+ no strict 'refs';
+ if (
+ defined $class
+ and
+ # inherited CAG can't be set to undef effectively, so people may use ''
+ length $class
+ and
+ # It's already an object, just go for it.
+ ! defined blessed $class
+ and
+ ! ${"${class}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"}
+ ) {
$_[0]->ensure_class_loaded($class);
- mro::set_mro( $class, 'c3' );
-
- no strict 'refs';
- $successfully_loaded_components->{$class}
- = ${"${class}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"}
- = do { \(my $anon = 'loaded') };
- weaken($successfully_loaded_components->{$class});
+ ${"${class}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"}
+ = do { \(my $anon = 'loaded') };
}
$class;
return $class->next::method($group => map lc, @cols);
}
-sub add_columns {
+sub add_columns :DBIC_method_is_bypassable_resultsource_proxy {
my ($class, @cols) = @_;
- return $class->result_source_instance->add_columns(map lc, @cols);
+ return $class->result_source->add_columns(map lc, @cols);
}
sub has_a {
__PACKAGE__->mk_classdata('_column_groups' => { });
-sub columns {
+sub columns :DBIC_method_is_bypassable_resultsource_proxy {
my $proto = shift;
my $class = ref $proto || $proto;
my $group = shift || "All";
$class->_register_column_group($group => @cols);
}
-sub add_columns {
+sub add_columns :DBIC_method_is_bypassable_resultsource_proxy {
my ($class, @cols) = @_;
- $class->result_source_instance->add_columns(@cols);
+ $class->result_source->add_columns(@cols);
}
sub _register_column_group {
}
}
-sub all_columns { return shift->result_source_instance->columns; }
+sub all_columns { return shift->result_source->columns; }
sub primary_column {
my ($class) = @_;
$sth->execute(@$execute_args);
- my @ret;
+ my (@ret, $rsrc);
while (my $row = $sth->fetchrow_hashref) {
- push(@ret, $class->inflate_result($class->result_source_instance, $row));
+ push(@ret, $class->inflate_result(
+ ( $rsrc ||= $class->result_source ),
+ $row
+ ));
}
return @ret;
}
else {
$self->belongs_to($col, $f_class);
- $rel_info = $self->result_source_instance->relationship_info($col);
+ $rel_info = $self->result_source->relationship_info($col);
}
$rel_info->{args} = \%args;
if( !$f_key and !@f_method ) {
$class->ensure_class_loaded($f_class);
- my $f_source = $f_class->result_source_instance;
+ my $f_source = $f_class->result_source;
($f_key) = grep { $f_source->relationship_info($_)->{class} eq $class }
$f_source->relationships;
}
$class->next::method($rel, $f_class, $f_key, $args);
- my $rel_info = $class->result_source_instance->relationship_info($rel);
+ my $rel_info = $class->result_source->relationship_info($rel);
$args->{mapping} = \@f_method;
$args->{foreign_key} = $f_key;
$rel_info->{args} = $args;
);
if (@f_method) {
- quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel), { '$rf' => \sub { my $o = shift; $o = $o->$_ for @f_method; $o } };
+ my @qsub_args = (
+ { '$rf' => \sub { my $o = shift; $o = $o->$_ for @f_method; $o } },
+ { attributes => [ 'DBIC_method_is_generated_from_resultsource_metadata' ] },
+ );
+
+ quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel), @qsub_args;
my $rs = shift->related_resultset(%s)->search_rs( @_);
$rs->{attrs}{record_filter} = $rf;
return (wantarray ? $rs->all : $rs);
{ proxy => \@columns });
}
- my $rel_info = $class->result_source_instance->relationship_info($rel);
+ my $rel_info = $class->result_source->relationship_info($rel);
$rel_info->{args}{import} = \@columns;
$class->_extend_meta(
my $fr_num = 1; # skip us and the calling carp*
- my (@f, $origin);
+ my (@f, $origin, $eval_src);
while (@f = CORE::caller($fr_num++)) {
- next if
- ( $f[3] eq '(eval)' or $f[3] =~ /::__ANON__$/ );
+ undef $eval_src;
+
+ next if (
+ $f[2] == 0
+ or
+ # there is no value reporting a sourceless eval frame
+ (
+ ( $f[3] eq '(eval)' or $f[1] =~ /^\(eval \d+\)$/ )
+ and
+ not defined ( $eval_src = (CORE::caller($fr_num))[6] )
+ )
+ or
+ $f[3] =~ /::__ANON__$/
+ );
$origin ||= (
$f[3] =~ /^ (.+) :: ([^\:]+) $/x
}
my $site = @f # if empty - nothing matched - full stack
- ? "at $f[1] line $f[2]"
+ ? ( "at $f[1] line $f[2]" . ( $eval_src ? "\n === BEGIN $f[1]\n$eval_src\n === END $f[1]" : '' ) )
: Carp::longmess()
;
# this warns of subtle bugs introduced by UTF8Columns hacky handling of store_column
# if and only if it is placed before something overriding store_column
-#
-# and also enforces C3 mro on all components
-my $mro_already_set;
sub inject_base {
my $class = shift;
my ($target, @complist) = @_;
unshift @target_isa, $comp;
}
- # only examine from $_[2] onwards
- # C::C3::C already sets c3 on $_[1]
- mro::set_mro( $_ => 'c3' ) for grep {
- $mro_already_set->{$_} ? 0 : ( $mro_already_set->{$_} = 1 )
- } @_[1 .. $#_];
-
$class->next::method(@_);
}
=cut
sub resultset_instance {
- $_[0]->result_source_instance->resultset
+ $_[0]->result_source->resultset
}
=begin hidden
# Yep. this is horrific. Basically what's happening here is that
# (with good reason) DBIx::Class::Schema copies the result source for
# registration. Because we have a retarded setup order forced on us we need
-# to actually make our ->result_source_instance -be- the source used, and we
+# to actually make our ->result_source -be- the source used, and we
# need to get the source name and schema into ourselves. So this makes it
# happen.
}
my($source, $result_class) = @{$class->_result_source_instance};
- return unless blessed $source;
+ return undef unless blessed $source;
if ($result_class ne $class) { # new class
# Give this new class its own source and register it.
- $source = $source->new({
- %$source,
+ $source = $source->clone(
source_name => $class,
result_class => $class
- } );
+ );
$class->_result_source_instance([$source, $class]);
$class->_maybe_attach_source_to_schema($source);
}
sub filter_column {
my ($self, $col, $attrs) = @_;
- my $colinfo = $self->result_source_instance->column_info($col);
+ my $colinfo = $self->result_source->columns_info([$col])->{$col};
$self->throw_exception("FilterColumn can not be used on a column with a declared InflateColumn inflator")
if defined $colinfo->{_inflate_info} and $self->isa('DBIx::Class::InflateColumn');
- $self->throw_exception("No such column $col to filter")
- unless $self->result_source_instance->has_column($col);
-
$self->throw_exception('filter_column expects a hashref of filter specifications')
unless ref $attrs eq 'HASH';
return $value if is_literal_value($value);
- my $info = $self->result_source->column_info($col)
- or $self->throw_exception("No column info for $col");
+ my $info = $self->result_source->columns_info([$col])->{$col};
return $value unless exists $info->{_filter_info};
return $value if is_literal_value($value);
- my $info = $self->result_source->column_info($col) or
- $self->throw_exception("No column info for $col");
+ my $info = $self->result_source->columns_info([$col])->{$col};
return $value unless exists $info->{_filter_info};
my ($self, $col) = @_;
$self->throw_exception("$col is not a filtered column")
- unless exists $self->result_source->column_info($col)->{_filter_info};
+ unless exists $self->result_source->columns_info->{$col}{_filter_info};
return $self->{_filtered_column}{$col}
if exists $self->{_filtered_column}{$col};
sub inflate_column {
my ($self, $col, $attrs) = @_;
- my $colinfo = $self->result_source_instance->column_info($col);
+ my $colinfo = $self->result_source->columns_info([$col])->{$col};
$self->throw_exception("InflateColumn can not be used on a column with a declared FilterColumn filter")
if defined $colinfo->{_filter_info} and $self->isa('DBIx::Class::FilterColumn');
- $self->throw_exception("No such column $col to inflate")
- unless $self->result_source_instance->has_column($col);
$self->throw_exception("inflate_column needs attr hashref")
unless ref $attrs eq 'HASH';
+
$colinfo->{_inflate_info} = $attrs;
my $acc = $colinfo->{accessor};
$self->mk_group_accessors('inflated_column' => [ (defined $acc ? $acc : $col), $col]);
is_literal_value($value) #that would be a not-yet-reloaded literal update
);
- my $info = $self->result_source->column_info($col)
- or $self->throw_exception("No column info for $col");
+ my $info = $self->result_source->columns_info([$col])->{$col};
return $value unless exists $info->{_inflate_info};
is_literal_value($value)
);
- my $info = $self->result_source->column_info($col) or
- $self->throw_exception("No column info for $col");
+ my $info = $self->result_source->columns_info([$col])->{$col};
return $value unless exists $info->{_inflate_info};
my ($self, $col) = @_;
$self->throw_exception("$col is not an inflated column")
- unless exists $self->result_source->column_info($col)->{_inflate_info};
+ unless exists $self->result_source->columns_info->{$col}{_inflate_info};
# we take care of keeping things in sync
return $self->{_inflated_column}{$col}
sub _file_column_file {
my ($self, $column, $filename) = @_;
- my $column_info = $self->result_source->column_info($column);
+ my $column_info = $self->result_source->columns_info->{$column};
return unless $column_info->{is_file_column};
#
# do not attempt to deploy() this view
- __PACKAGE__->result_source_instance->is_virtual(1);
+ __PACKAGE__->result_source->is_virtual(1);
- __PACKAGE__->result_source_instance->view_definition(q[
+ __PACKAGE__->result_source->view_definition(q[
SELECT u.* FROM user u
INNER JOIN user_friends f ON u.id = f.user_id
WHERE f.friend_user_id = ?
use DBIx::Class::_Util qw( uniq refdesc visit_namespaces );
use Scalar::Util qw( weaken refaddr );
-use mro 'c3';
use namespace::clean;
my ( $attr_cref_registry, $attr_cache_active );
sub VALID_DBIC_CODE_ATTRIBUTE {
#my ($class, $attr) = @_;
- # initially no valid attributes
- 0;
+###
+### !!! IMPORTANT !!!
+###
+### *DO NOT* yield to the temptation of using free-form-argument attributes.
+### The technique was proven instrumental in Catalyst a decade ago, and
+### was more recently revived in Sub::Attributes. Yet, while on the surface
+### they seem immensely useful, per-attribute argument lists are in fact an
+### architectural dead end.
+###
+### In other words: you are *very strongly urged* to ensure the regex below
+### does not allow anything beyond qr/^ DBIC_method_is_ [A-Z_a-z0-9]+ $/x
+###
+
+ $_[1] =~ /^ DBIC_method_is_ (?:
+ indirect_sugar
+ |
+ (?: bypassable | mandatory ) _resultsource_proxy
+ |
+ generated_from_resultsource_metadata
+ |
+ (?: inflated_ | filtered_ )? column_ (?: extra_)? accessor
+ |
+ single_relationship_accessor
+ |
+ (?: multi | filter ) _relationship_ (?: extra_ )? accessor
+ |
+ proxy_to_relationship
+ |
+ m2m_ (?: extra_)? sugar (?:_with_attrs)?
+ ) $/x;
}
sub FETCH_CODE_ATTRIBUTES {
The following method attributes are currently recognized under the C<DBIC_*>
prefix:
-=over
+=head3 DBIC_method_is_indirect_sugar
-=item * None so far
+The presence of this attribute indicates a helper "sugar" method. Overriding
+such methods in your subclasses will be of limited success at best, as DBIC
+itself and various plugins are much more likely to invoke alternative direct
+call paths, bypassing your override entirely. Good examples of this are
+L<DBIx::Class::ResultSet/create> and L<DBIx::Class::Schema/connect>.
-=back
+See also the check
+L<DBIx::Class::Schema::SanityChecker/no_indirect_method_overrides>.
+
+=head3 DBIC_method_is_mandatory_resultsource_proxy
+
+=head3 DBIC_method_is_bypassable_resultsource_proxy
+
+The presence of one of these attributes on a L<proxied ResultSource
+method|DBIx::Class::Manual::ResultClass/DBIx::Class::ResultSource> indicates
+how DBIC will behave when someone calls e.g.:
+
+ $some_result->result_source->add_columns(...)
+
+as opposed to the conventional
+
+ SomeResultClass->add_columns(...)
+
+This distinction becomes important when someone declares a sub named after
+one of the (currently 22) methods proxied from a
+L<Result|DBIx::Class::Manual::ResultClass> to
+L<ResultSource|DBIx::Class::ResultSource>. While there are obviously no
+problems when these methods are called at compile time, there is a lot of
+ambiguity whether an override of something like
+L<columns_info|DBIx::Class::ResultSource/columns_info> will be respected by
+DBIC and various plugins during runtime operations.
+
+It must be noted that there is a reason for this weird situation: during the
+original design of DBIC the "ResultSourceProxy" system was established in
+order to allow easy transition from Class::DBI. Unfortunately it was not
+well abstracted away: it is rather difficult to use a custom ResultSource
+subclass. The expansion of the DBIC project never addressed this properly
+in the years since. As a result when one wishes to override a part of the
+ResultSource functionality, the overwhelming practice is to hook a method
+in a Result class and "hope for the best".
+
+The subtle changes of various internal call-chains in C<DBIC v0.0829xx> make
+this silent uncertainty untenable. As a solution any such override will now
+issue a descriptive warning that it has been bypassed during a
+C<< $rsrc->overriden_function >> invocation. A user B<must> determine how
+each individual override must behave in this situation, and tag it with one
+of the above two attributes.
+
+Naturally any override marked with C<..._bypassable_resultsource_proxy> will
+behave like it did before: it will be silently ignored. This is the attribute
+you want to set if your code appears to work fine, and you do not wish to
+receive the warning anymore (though you are strongly encouraged to understand
+the other option).
+
+However overrides marked with C<..._mandatory_resultsource_proxy> will always
+be reinvoked by DBIC itself, so that any call of the form:
+
+ $some_result->result_source->columns_info(...)
+
+will be transformed into:
+
+ $some_result->result_source->result_class->columns_info(...)
+
+with the rest of the callchain flowing out of that (provided the override did
+invoke L<next::method|mro/next::method> where appropriate)
+
+=head3 DBIC_method_is_generated_from_resultsource_metadata
+
+This attribute is applied to all methods dynamically installed after various
+invocations of L<ResultSource metadata manipulation
+methods|DBIx::Class::Manual::ResultClass/DBIx::Class::ResultSource>. Notably
+this includes L<add_columns|DBIx::Class::ResultSource/add_columns>,
+L<add_relationship|DBIx::Class::ResultSource/add_relationship>,
+L<the proxied relationship attribute|DBIx::Class::Relationship::Base/proxy>
+and the various L<relationship
+helpers|DBIx::Class::Manual::ResultClass/DBIx::Class::Relationship>,
+B<except> the L<M2M helper|DBIx::Class::Relationship/many_to_many> (given its
+effects are never reflected as C<ResultSource metadata>).
+
+=head3 DBIC_method_is_column_accessor
+
+This attribute is applied to all methods dynamically installed as a result of
+invoking L<add_columns|DBIx::Class::ResultSource/add_columns>.
+
+=head3 DBIC_method_is_inflated_column_accessor
+
+This attribute is applied to all methods dynamically installed as a result of
+invoking L<inflate_column|DBIx::Class::InflateColumn/inflate_column>.
+
+=head3 DBIC_method_is_filtered_column_accessor
+
+This attribute is applied to all methods dynamically installed as a result of
+invoking L<filter_column|DBIx::Class::FilterColumn/filter_column>.
+
+=head3 DBIC_method_is_*column_extra_accessor
+
+For historical reasons any L<Class::Accessor::Grouped> accessor is generated
+twice as C<{name}> and C<_{name}_accessor>. The second method is marked with
+C<DBIC_method_is_*column_extra_accessor> correspondingly.
+
+=head3 DBIC_method_is_single_relationship_accessor
+
+This attribute is applied to all methods dynamically installed as a result of
+invoking L<might_have|DBIx::Class::Relationship/might_have>,
+L<has_one|DBIx::Class::Relationship/has_one> or
+L<belongs_to|DBIx::Class::Relationship/belongs_to> (though for C<belongs_to>
+see L<...filter_rel...|/DBIC_method_is_filter_relationship_accessor> below.
+
+=head3 DBIC_method_is_multi_relationship_accessor
+
+This attribute is applied to the main method dynamically installed as a result
+of invoking L<has_many|DBIx::Class::Relationship/has_many>.
+
+=head3 DBIC_method_is_multi_relationship_extra_accessor
+
+This attribute is applied to the two extra methods dynamically installed as a
+result of invoking L<has_many|DBIx::Class::Relationship/has_many>:
+C<$relname_rs> and C<add_to_$relname>.
+
+=head3 DBIC_method_is_filter_relationship_accessor
+
+This attribute is applied to (legacy) methods dynamically installed as a
+result of invoking L<belongs_to|DBIx::Class::Relationship/belongs_to> with an
+already-existing identically named column. The method is internally
+implemented as an L<inflated_column|/DBIC_method_is_inflated_column_accessor>
+and is labeled with both atributes at the same time.
+
+=head3 DBIC_method_is_filter_relationship_extra_accessor
+
+Same as L</DBIC_method_is_*column_extra_accessor>.
+
+=head3 DBIC_method_is_proxy_to_relationship
+
+This attribute is applied to methods dynamically installed as a result of
+providing L<the proxied relationship
+attribute|DBIx::Class::Relationship::Base/proxy>.
+
+=head3 DBIC_method_is_m2m_sugar
+
+=head3 DBIC_method_is_m2m_sugar_with_attrs
+
+One of the above attributes is applied to the main method dynamically
+installed as a result of invoking
+L<many_to_many|DBIx::Class::Relationship/many_to_many>. The C<_with_atrs> suffix
+serves to indicate whether the user supplied any C<\%attrs> to the
+C<many_to_many> call. There is deliberately no mechanism to retrieve the actual
+supplied values: if you really need this functionality you would need to rely on
+L<DBIx::Class::IntrospectableM2M>.
+
+=head3 DBIC_method_is_extra_m2m_sugar
+
+=head3 DBIC_method_is_extra_m2m_sugar_with_attrs
+
+One of the above attributes is applied to the extra B<four> methods dynamically
+installed as a result of invoking
+L<many_to_many|DBIx::Class::Relationship/many_to_many>: C<$m2m_rs>, C<add_to_$m2m>,
+C<remove_from_$m2m> and C<set_$m2m>.
=head1 METHODS
my ($class, $rel, $acc_type) = @_;
if ($acc_type eq 'single') {
- quote_sub "${class}::${rel}" => sprintf(<<'EOC', perlstring $rel);
+
+ my @qsub_args = ( {}, {
+ attributes => [qw(
+ DBIC_method_is_single_relationship_accessor
+ DBIC_method_is_generated_from_resultsource_metadata
+ )]
+ });
+
+
+ quote_sub "${class}::${rel}" => sprintf(<<'EOC', perlstring $rel), @qsub_args;
my $self = shift;
if (@_) {
EOC
}
elsif ($acc_type eq 'filter') {
- $class->throw_exception("No such column '$rel' to filter")
- unless $class->result_source_instance->has_column($rel);
- my $f_class = $class->result_source_instance
- ->relationship_info($rel)
- ->{class};
+ my $rsrc = $class->result_source_instance;
+
+ $rsrc->throw_exception("No such column '$rel' to filter")
+ unless $rsrc->has_column($rel);
+
+ my $f_class = $rsrc->relationship_info($rel)->{class};
$class->inflate_column($rel, {
inflate => sub {
return $pk_val;
},
});
+
+
+ # god this is horrible...
+ my $acc =
+ $rsrc->columns_info->{$rel}{accessor}
+ ||
+ $rel
+ ;
+
+ # because CDBI may elect to never make an accessor at all...
+ if( my $main_cref = $class->can($acc) ) {
+
+ attributes->import(
+ $class,
+ $main_cref,
+ qw(
+ DBIC_method_is_filter_relationship_accessor
+ DBIC_method_is_generated_from_resultsource_metadata
+ ),
+ );
+
+ if( my $extra_cref = $class->can("_${acc}_accessor") ) {
+ attributes->import(
+ $class,
+ $extra_cref,
+ qw(
+ DBIC_method_is_filter_relationship_extra_accessor
+ DBIC_method_is_generated_from_resultsource_metadata
+ ),
+ );
+ }
+ }
}
elsif ($acc_type eq 'multi') {
- quote_sub "${class}::${rel}_rs", sprintf( <<'EOC', perlstring $rel );
+
+ my @qsub_args = (
+ {},
+ {
+ attributes => [qw(
+ DBIC_method_is_multi_relationship_accessor
+ DBIC_method_is_generated_from_resultsource_metadata
+ DBIC_method_is_indirect_sugar
+ )]
+ },
+ );
+
+
+ quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel ), @qsub_args;
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call;
- shift->related_resultset(%s)->search_rs( @_ )
+ DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray;
+ shift->related_resultset(%s)->search( @_ )
EOC
- quote_sub "${class}::add_to_${rel}", sprintf( <<'EOC', perlstring $rel );
+
+ $qsub_args[1]{attributes}[0]
+ =~ s/^DBIC_method_is_multi_relationship_accessor$/DBIC_method_is_multi_relationship_extra_accessor/
+ or die "Unexpected attr '$qsub_args[1]{attributes}[0]' ...";
+
+
+ quote_sub "${class}::${rel}_rs", sprintf( <<'EOC', perlstring $rel ), @qsub_args;
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call;
- shift->create_related( %s => @_ );
+ shift->related_resultset(%s)->search_rs( @_ )
EOC
- quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel );
+
+ quote_sub "${class}::add_to_${rel}", sprintf( <<'EOC', perlstring $rel ), @qsub_args;
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call;
- DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray;
- shift->related_resultset(%s)->search( @_ )
+ shift->create_related( %s => @_ );
EOC
+
}
else {
$class->throw_exception("No such relationship accessor type '$acc_type'");
=cut
-sub search_related {
+sub search_related :DBIC_method_is_indirect_sugar {
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
shift->related_resultset(shift)->search(@_);
}
=cut
-sub search_related_rs {
+sub search_related_rs :DBIC_method_is_indirect_sugar {
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
shift->related_resultset(shift)->search_rs(@_)
}
=cut
-sub count_related {
+sub count_related :DBIC_method_is_indirect_sugar {
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
shift->related_resultset(shift)->search_rs(@_)->count;
}
=cut
-sub find_related {
+sub find_related :DBIC_method_is_indirect_sugar {
#my ($self, $rel, @args) = @_;
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
return shift->related_resultset(shift)->find(@_);
=cut
-sub update_or_create_related {
+sub update_or_create_related :DBIC_method_is_indirect_sugar {
#my ($self, $rel, @args) = @_;
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
shift->related_resultset(shift)->update_or_create(@_);
$class->throw_exception(
"No such column '$f_key' declared yet on ${class} ($guess)"
- ) unless $class->result_source_instance->has_column($f_key);
+ ) unless $class->result_source->has_column($f_key);
$class->ensure_class_loaded($f_class);
my $f_rsrc = dbic_internal_try {
- $f_class->result_source_instance;
+ $f_class->result_source;
}
catch {
$class->throw_exception(
"Foreign class '$f_class' does not seem to be a Result class "
- . "(or it simply did not load entirely due to a circular relation chain)"
+ . "(or it simply did not load entirely due to a circular relation chain): $_"
);
};
and
(keys %$cond)[0] =~ /^foreign\./
and
- $class->result_source_instance->has_column($rel)
+ $class->result_source->has_column($rel)
) ? 'filter' : 'single';
my $fk_columns = ($acc_type eq 'single' and ref $cond eq 'HASH')
unless (ref $cond) {
- my $pri = $class->result_source_instance->_single_pri_col_or_die;
+ my $pri = $class->result_source->_single_pri_col_or_die;
my ($f_key,$guess);
if (defined $cond && length $cond) {
# FIXME - this check needs to be moved to schema-composition time...
# # only perform checks if the far side appears already loaded
-# if (my $f_rsrc = dbic_internal_try { $f_class->result_source_instance } ) {
+# if (my $f_rsrc = dbic_internal_try { $f_class->result_source } ) {
# $class->throw_exception(
# "No such column '$f_key' on foreign class ${f_class} ($guess)"
# ) if !$f_rsrc->has_column($f_key);
sub _has_one {
my ($class, $join_type, $rel, $f_class, $cond, $attrs) = @_;
unless (ref $cond) {
- my $pri = $class->result_source_instance->_single_pri_col_or_die;
+ my $pri = $class->result_source->_single_pri_col_or_die;
my ($f_key,$guess,$f_rsrc);
if (defined $cond && length $cond) {
$class->ensure_class_loaded($f_class);
$f_rsrc = dbic_internal_try {
- my $r = $f_class->result_source_instance;
+ my $r = $f_class->result_source;
die "There got to be some columns by now... (exception caught and rewritten by catch below)"
unless $r->columns;
$r;
# FIXME - this check needs to be moved to schema-composition time...
# # only perform checks if the far side was not preloaded above *AND*
-# # appears to have been loaded by something else (has a rsrc_instance)
-# if (! $f_rsrc and $f_rsrc = dbic_internal_try { $f_class->result_source_instance }) {
+# # appears to have been loaded by something else (has a rsrc)
+# if (! $f_rsrc and $f_rsrc = dbic_internal_try { $f_class->result_source }) {
# $class->throw_exception(
# "No such column '$f_key' on foreign class ${f_class} ($guess)"
# ) if !$f_rsrc->has_column($f_key);
return unless $self_id =~ /^self\.(.*)$/;
my $key = $1;
- $class->throw_exception("Defining rel on ${class} that includes '$key' but no such column defined here yet")
- unless $class->result_source_instance->has_column($key);
- my $column_info = $class->result_source_instance->column_info($key);
- if ( $column_info->{is_nullable} ) {
- carp(qq'"might_have/has_one" must not be on columns with is_nullable set to true ($class/$key). This might indicate an incorrect use of those relationship helpers instead of belongs_to.');
- }
+
+ my $column_info = $class->result_source->columns_info->{$key}
+ or $class->throw_exception(
+ "Defining rel on ${class} that includes '$key' "
+ . 'but no such column defined there yet'
+ );
+
+ carp(
+ "'might_have'/'has_one' must not be used on columns with is_nullable "
+ . "set to true ($class/$key). This almost certainly indicates an "
+ . "incorrect use of these relationship helpers instead of 'belongs_to'"
+ ) if $column_info->{is_nullable};
}
}
}
}
- my $qsub_attrs = {
- '$rel_attrs' => \{ alias => $f_rel, %{ $rel_attrs||{} } },
- '$carp_unique' => \$cu,
- };
+ my @main_meth_qsub_args = (
+ {},
+ { attributes => [
+ 'DBIC_method_is_indirect_sugar',
+ ( keys( %{$rel_attrs||{}} )
+ ? 'DBIC_method_is_m2m_sugar_with_attrs'
+ : 'DBIC_method_is_m2m_sugar'
+ ),
+ ] },
+ );
- quote_sub "${class}::${rs_meth}", sprintf( <<'EOC', map { perlstring $_ } ( "${class}::${meth}", $rel, $f_rel ) ), $qsub_attrs;
+
+ quote_sub "${class}::${meth}", sprintf( <<'EOC', $rs_meth ), @main_meth_qsub_args;
+
+ DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call;
+ DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray;
+
+ my $rs = shift->%s( @_ );
+
+ wantarray ? $rs->all : $rs;
+EOC
+
+
+ my @extra_meth_qsub_args = (
+ {
+ '$rel_attrs' => \{ alias => $f_rel, %{ $rel_attrs||{} } },
+ '$carp_unique' => \$cu,
+ },
+ { attributes => [
+ 'DBIC_method_is_indirect_sugar',
+ ( keys( %{$rel_attrs||{}} )
+ ? 'DBIC_method_is_m2m_extra_sugar_with_attrs'
+ : 'DBIC_method_is_m2m_extra_sugar'
+ ),
+ ] },
+ );
+
+
+ quote_sub "${class}::${rs_meth}", sprintf( <<'EOC', map { perlstring $_ } ( "${class}::${meth}", $rel, $f_rel ) ), @extra_meth_qsub_args;
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
and
;
EOC
-
- quote_sub "${class}::${meth}", sprintf( <<'EOC', $rs_meth );
-
- DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call;
- DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray;
-
- my $rs = shift->%s( @_ );
-
- wantarray ? $rs->all : $rs;
-EOC
+ # the above is the only indirect method, the 3 below have too much logic
+ shift @{$extra_meth_qsub_args[1]{attributes}};
- quote_sub "${class}::${add_meth}", sprintf( <<'EOC', $add_meth, $rel, $f_rel ), $qsub_attrs;
+ quote_sub "${class}::${add_meth}", sprintf( <<'EOC', $add_meth, $rel, $f_rel ), @extra_meth_qsub_args;
( @_ >= 2 and @_ <= 3 ) or $_[0]->throw_exception(
"'%1$s' expects an object or hashref to link to, and an optional hashref of link data"
my $guard;
- # the API needs is always expected to return the far object, possibly
+ # the API is always expected to return the far object, possibly
# creating it in the process
if( not defined Scalar::Util::blessed( $far_obj ) ) {
EOC
- quote_sub "${class}::${set_meth}", sprintf( <<'EOC', $set_meth, $add_meth, $rel, $f_rel ), $qsub_attrs;
+ quote_sub "${class}::${set_meth}", sprintf( <<'EOC', $set_meth, $add_meth, $rel, $f_rel ), @extra_meth_qsub_args;
my $self = shift;
EOC
- quote_sub "${class}::${remove_meth}", sprintf( <<'EOC', $remove_meth, $rel, $f_rel );
+ # the last method needs no captures - just kill it all with fire
+ $extra_meth_qsub_args[0] = {};
+
+
+ quote_sub "${class}::${remove_meth}", sprintf( <<'EOC', $remove_meth, $rel, $f_rel ), @extra_meth_qsub_args;
$_[0]->throw_exception("'%1$s' expects an object")
unless defined Scalar::Util::blessed( $_[1] );
my ($class, $rel, $proxy_args) = @_;
my %proxy_map = $class->_build_proxy_map_from($proxy_args);
- quote_sub "${class}::$_", sprintf( <<'EOC', $rel, $proxy_map{$_} )
+ my @qsub_args = ( {}, {
+ attributes => [qw(
+ DBIC_method_is_proxy_to_relationship
+ DBIC_method_is_generated_from_resultsource_metadata
+ )],
+ } );
+
+ quote_sub "${class}::$_", sprintf( <<'EOC', $rel, $proxy_map{$_} ), @qsub_args
my $self = shift;
my $relobj = $self->%1$s;
if (@_ && !defined $relobj) {
use warnings;
use base 'DBIx::Class';
-use mro 'c3';
use DBIx::Class::Carp;
use DBIx::Class::ResultSetColumn;
=cut
-sub search_related {
+sub search_related :DBIC_method_is_indirect_sugar {
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
return shift->related_resultset(shift)->search(@_);
}
=cut
-sub search_related_rs {
+sub search_related_rs :DBIC_method_is_indirect_sugar {
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
return shift->related_resultset(shift)->search_rs(@_);
}
=cut
-sub count_literal {
+sub count_literal :DBIC_method_is_indirect_sugar {
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
shift->search_literal(@_)->count
}
=cut
-sub first {
+sub first :DBIC_method_is_indirect_sugar {
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
return $_[0]->reset->next;
}
=cut
-sub create {
+sub create :DBIC_method_is_indirect_sugar {
#my ($self, $col_data) = @_;
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
return shift->new_result(shift)->insert;
=cut
-sub min {
+sub min :DBIC_method_is_indirect_sugar {
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
$_[0]->func('MIN');
}
=cut
-sub min_rs {
+sub min_rs :DBIC_method_is_indirect_sugar {
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
$_[0]->func_rs('MIN')
}
=cut
-sub max {
+sub max :DBIC_method_is_indirect_sugar {
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
$_[0]->func('MAX');
}
=cut
-sub max_rs {
+sub max_rs :DBIC_method_is_indirect_sugar {
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
$_[0]->func_rs('MAX')
}
=cut
-sub sum {
+sub sum :DBIC_method_is_indirect_sugar {
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
$_[0]->func('SUM');
}
=cut
-sub sum_rs {
+sub sum_rs :DBIC_method_is_indirect_sugar {
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
$_[0]->func_rs('SUM')
}
my $self = shift;
my $resultset_class = $self . $self->table_resultset_class_suffix;
no strict 'refs';
- if (@{"$resultset_class\::ISA"}) {
- $self->result_source_instance->resultset_class($resultset_class);
- } else {
- $self->result_source_instance->resultset_class
- ($self->base_resultset_class);
- }
+ $self->result_source->resultset_class(
+ ( scalar @{"${resultset_class}::ISA"} )
+ ? $resultset_class
+ : $self->base_resultset_class
+ );
}
=head1 FURTHER QUESTIONS?
package DBIx::Class::ResultSource;
+### !!!NOTE!!!
+#
+# Some of the methods defined here will be around()-ed by code at the
+# end of ::ResultSourceProxy. The reason for this strange arrangement
+# is that the list of around()s of methods in this # class depends
+# directly on the list of may-not-be-defined-yet methods within
+# ::ResultSourceProxy itself.
+# If this sounds terrible - it is. But got to work with what we have.
+#
+
use strict;
use warnings;
use base 'DBIx::Class::ResultSource::RowParser';
-use mro 'c3';
use DBIx::Class::Carp;
-use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION dbic_internal_try fail_on_internal_call );
+use DBIx::Class::_Util qw(
+ UNRESOLVABLE_CONDITION
+ dbic_internal_try fail_on_internal_call
+ refdesc emit_loud_diag
+);
use SQL::Abstract 'is_literal_value';
use Devel::GlobalDestruction;
-use Scalar::Util qw/blessed weaken isweak/;
+use Scalar::Util qw( blessed weaken isweak refaddr );
# FIXME - somehow breaks ResultSetManager, do not remove until investigated
use DBIx::Class::ResultSet;
use namespace::clean;
-__PACKAGE__->mk_group_accessors(simple => qw/
- source_name name source_info
- _ordered_columns _columns _primaries _unique_constraints
- _relationships resultset_attributes
- column_info_from_storage sqlt_deploy_callback
-/);
-
-__PACKAGE__->mk_group_accessors(component_class => qw/
+my @hashref_attributes = qw(
+ source_info resultset_attributes
+ _columns _unique_constraints _relationships
+);
+my @arrayref_attributes = qw(
+ _ordered_columns _primaries
+);
+__PACKAGE__->mk_group_accessors(rsrc_instance_specific_attribute =>
+ @hashref_attributes,
+ @arrayref_attributes,
+ qw( source_name name column_info_from_storage sqlt_deploy_callback ),
+);
+
+__PACKAGE__->mk_group_accessors(rsrc_instance_specific_handler => qw(
resultset_class
result_class
-/);
+));
=head1 NAME
__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
__PACKAGE__->table('year2000cds');
- __PACKAGE__->result_source_instance->is_virtual(1);
- __PACKAGE__->result_source_instance->view_definition(
+ __PACKAGE__->result_source->is_virtual(1);
+ __PACKAGE__->result_source->view_definition(
"SELECT cdid, artist, title FROM cd WHERE year ='2000'"
);
=cut
-sub new {
- my ($class, $attrs) = @_;
- $class = ref $class if ref $class;
-
- my $new = bless { %{$attrs || {}} }, $class;
- $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
- $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
- $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
- $new->{_columns} = { %{$new->{_columns}||{}} };
- $new->{_relationships} = { %{$new->{_relationships}||{}} };
- $new->{name} ||= "!!NAME NOT SET!!";
- $new->{_columns_info_loaded} ||= 0;
- $new->{sqlt_deploy_callback} ||= 'default_sqlt_deploy_hook';
- return $new;
+{
+ my $rsrc_registry;
+
+ sub __derived_instances {
+ map {
+ (defined $_->{weakref})
+ ? $_->{weakref}
+ : ()
+ } values %{ $rsrc_registry->{ refaddr($_[0]) }{ derivatives } }
+ }
+
+ sub new {
+ my ($class, $attrs) = @_;
+ $class = ref $class if ref $class;
+
+ my $ancestor = delete $attrs->{__derived_from};
+
+ my $self = bless { %$attrs }, $class;
+
+
+ DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE
+ and
+ # a constructor with 'name' as sole arg clearly isn't "inheriting" from anything
+ ( not ( keys(%$self) == 1 and exists $self->{name} ) )
+ and
+ defined CORE::caller(1)
+ and
+ (CORE::caller(1))[3] !~ / ::new$ | ^ DBIx::Class :: (?:
+ ResultSourceProxy::Table::table
+ |
+ ResultSourceProxy::Table::_init_result_source_instance
+ |
+ ResultSource::clone
+ ) $ /x
+ and
+ local $Carp::CarpLevel = $Carp::CarpLevel + 1
+ and
+ Carp::confess("Incorrect instantiation of '$self': you almost certainly wanted to call ->clone() instead");
+
+
+ my $own_slot = $rsrc_registry->{
+ my $own_addr = refaddr $self
+ } = { derivatives => {} };
+
+ weaken( $own_slot->{weakref} = $self );
+
+ if(
+ length ref $ancestor
+ and
+ my $ancestor_slot = $rsrc_registry->{
+ my $ancestor_addr = refaddr $ancestor
+ }
+ ) {
+
+ # on ancestry recording compact registry slots, prevent unbound growth
+ for my $r ( $rsrc_registry, map { $_->{derivatives} } values %$rsrc_registry ) {
+ defined $r->{$_}{weakref} or delete $r->{$_}
+ for keys %$r;
+ }
+
+ weaken( $_->{$own_addr} = $own_slot ) for map
+ { $_->{derivatives} }
+ (
+ $ancestor_slot,
+ (grep
+ { defined $_->{derivatives}{$ancestor_addr} }
+ values %$rsrc_registry
+ ),
+ )
+ ;
+ }
+
+
+ $self->{resultset_class} ||= 'DBIx::Class::ResultSet';
+ $self->{name} ||= "!!NAME NOT SET!!";
+ $self->{_columns_info_loaded} ||= 0;
+ $self->{sqlt_deploy_callback} ||= 'default_sqlt_deploy_hook';
+
+ $self->{$_} = { %{ $self->{$_} || {} } }
+ for @hashref_attributes, '__metadata_divergencies';
+
+ $self->{$_} = [ @{ $self->{$_} || [] } ]
+ for @arrayref_attributes;
+
+ $self;
+ }
+
+ sub DBIx::Class::__Rsrc_Ancestry_iThreads_handler__::CLONE {
+ for my $r ( $rsrc_registry, map { $_->{derivatives} } values %$rsrc_registry ) {
+ %$r = map {
+ defined $_->{weakref}
+ ? ( refaddr $_->{weakref} => $_ )
+ : ()
+ } values %$r
+ }
+ }
+
+
+ # needs direct access to $rsrc_registry under an assert
+ #
+ sub set_rsrc_instance_specific_attribute {
+
+ # only mark if we are setting something different
+ if (
+ (
+ defined( $_[2] )
+ xor
+ defined( $_[0]->{$_[1]} )
+ )
+ or
+ (
+ # both defined
+ defined( $_[2] )
+ and
+ (
+ # differ in ref-ness
+ (
+ length ref( $_[2] )
+ xor
+ length ref( $_[0]->{$_[1]} )
+ )
+ or
+ # both refs (the mark-on-same-ref is deliberate)
+ length ref( $_[2] )
+ or
+ # both differing strings
+ $_[2] ne $_[0]->{$_[1]}
+ )
+ )
+ ) {
+
+ my $callsite;
+ # need to protect $_ here
+ for my $derivative (
+ $_[0]->__derived_instances,
+
+ # DO NOT REMOVE - this blob is marking *ancestors* as tainted, here to
+ # weed out any fallout from https://github.com/dbsrgits/dbix-class/commit/9e36e3ec
+ # Note that there is no way to kill this warning, aside from never
+ # calling set_primary_key etc more than once per hierarchy
+ # (this is why the entire thing is guarded by an assert)
+ (
+ (
+ DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE
+ and
+ grep { $_[1] eq $_ } qw( _unique_constraints _primaries source_info )
+ )
+ ? (
+ map
+ { defined($_->{weakref}) ? $_->{weakref} : () }
+ grep
+ { defined( ( $_->{derivatives}{refaddr($_[0])} || {} )->{weakref} ) }
+ values %$rsrc_registry
+ )
+ : ()
+ ),
+ ) {
+
+ $derivative->{__metadata_divergencies}{$_[1]}{ $callsite ||= do {
+
+ #
+ # FIXME - this is horrible, but it's the best we can do for now
+ # Replace when Carp::Skip is written (it *MUST* take this use-case
+ # into consideration)
+ #
+ my ($cs) = DBIx::Class::Carp::__find_caller(__PACKAGE__);
+
+ my ($fr_num, @fr) = 1;
+ while( @fr = CORE::caller($fr_num++) ) {
+ $cs =~ /^ \Qat $fr[1] line $fr[2]\E (?: $ | \n )/x
+ and
+ $fr[3] =~ s/.+:://
+ and
+ last
+ }
+
+ # FIXME - using refdesc here isn't great, but I can't think of anything
+ # better at this moment
+ @fr
+ ? "@{[ refdesc $_[0] ]}->$fr[3](...) $cs"
+ : "$cs"
+ ;
+ } } = 1;
+ }
+ }
+
+ $_[0]->{$_[1]} = $_[2];
+ }
+}
+
+sub get_rsrc_instance_specific_attribute {
+
+ $_[0]->__emit_stale_metadata_diag( $_[1] ) if (
+ ! $_[0]->{__in_rsrc_setter_callstack}
+ and
+ $_[0]->{__metadata_divergencies}{$_[1]}
+ );
+
+ $_[0]->{$_[1]};
+}
+
+
+# reuse the elaborate set logic of instance_specific_attr
+sub set_rsrc_instance_specific_handler {
+ $_[0]->set_rsrc_instance_specific_attribute($_[1], $_[2]);
+
+ # trigger a load for the case of $foo->handler_accessor("bar")->new
+ $_[0]->get_rsrc_instance_specific_handler($_[1])
+ if defined wantarray;
+}
+
+# This is essentially the same logic as get_component_class
+# (in DBIC::AccessorGroup). However the latter is a grouped
+# accessor type, and here we are strictly after a 'simple'
+# So we go ahead and recreate the logic as found in ::AG
+sub get_rsrc_instance_specific_handler {
+
+ # emit desync warnings if any
+ my $val = $_[0]->get_rsrc_instance_specific_attribute( $_[1] );
+
+ # plain string means class - load it
+ no strict 'refs';
+ if (
+ defined $val
+ and
+ # inherited CAG can't be set to undef effectively, so people may use ''
+ length $val
+ and
+ ! defined blessed $val
+ and
+ ! ${"${val}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"}
+ ) {
+ $_[0]->ensure_class_loaded($val);
+
+ ${"${val}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"}
+ = do { \(my $anon = 'loaded') };
+ }
+
+ $val;
+}
+
+
+sub __construct_stale_metadata_diag {
+ return '' unless $_[0]->{__metadata_divergencies}{$_[1]};
+
+ my ($fr_num, @fr);
+
+ # find the CAG getter FIRST
+ # allows unlimited user-namespace overrides without screwing around with
+ # $LEVEL-like crap
+ while(
+ @fr = CORE::caller(++$fr_num)
+ and
+ $fr[3] ne 'DBIx::Class::ResultSource::get_rsrc_instance_specific_attribute'
+ ) { 1 }
+
+ Carp::confess( "You are not supposed to call __construct_stale_metadata_diag here..." )
+ unless @fr;
+
+ # then find the first non-local, non-private reportable callsite
+ while (
+ @fr = CORE::caller(++$fr_num)
+ and
+ (
+ $fr[2] == 0
+ or
+ $fr[3] eq '(eval)'
+ or
+ $fr[1] =~ /^\(eval \d+\)$/
+ or
+ $fr[3] =~ /::(?: __ANON__ | _\w+ )$/x
+ or
+ $fr[0] =~ /^DBIx::Class::ResultSource/
+ )
+ ) { 1 }
+
+ my $by = ( @fr and $fr[3] =~ s/.+::// )
+ # FIXME - using refdesc here isn't great, but I can't think of anything
+ # better at this moment
+ ? " by 'getter' @{[ refdesc $_[0] ]}->$fr[3](...)\n within the callstack beginning"
+ : ''
+ ;
+
+ # Given the full stacktrace combined with the really involved callstack
+ # there is no chance the emitter will properly deduplicate this
+ # Only complain once per callsite per source
+ return( ( $by and $_[0]->{__encountered_divergencies}{$by}++ )
+
+ ? ''
+
+ : "$_[0] (the metadata instance of source '@{[ $_[0]->source_name ]}') is "
+ . "*OUTDATED*, and does not reflect the modifications of its "
+ . "*ancestors* as follows:\n"
+ . join( "\n",
+ map
+ { " * $_->[0]" }
+ sort
+ { $a->[1] cmp $b->[1] }
+ map
+ { [ $_, ( $_ =~ /( at .+? line \d+)/ ) ] }
+ keys %{ $_[0]->{__metadata_divergencies}{$_[1]} }
+ )
+ . "\nStale metadata accessed${by}"
+ );
+}
+
+sub __emit_stale_metadata_diag {
+ emit_loud_diag(
+ msg => (
+ # short circuit: no message - no diag
+ $_[0]->__construct_stale_metadata_diag($_[1])
+ ||
+ return 0
+ ),
+ # the constructor already does deduplication
+ emit_dups => 1,
+ confess => DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE,
+ );
+}
+
+=head2 clone
+
+ $rsrc_instance->clone( atribute_name => overriden_value );
+
+A wrapper around L</new> inheriting any defaults from the callee. This method
+also not normally invoked directly by end users.
+
+=cut
+
+sub clone {
+ my $self = shift;
+
+ $self->new({
+ (
+ (length ref $self)
+ ? ( %$self, __derived_from => $self )
+ : ()
+ ),
+ (
+ (@_ == 1 and ref $_[0] eq 'HASH')
+ ? %{ $_[0] }
+ : @_
+ ),
+ });
}
=pod
sub add_columns {
my ($self, @cols) = @_;
+
+ local $self->{__in_rsrc_setter_callstack} = 1
+ unless $self->{__in_rsrc_setter_callstack};
+
$self->_ordered_columns(\@cols) unless $self->_ordered_columns;
- my @added;
+ my ( @added, $colinfos );
my $columns = $self->_columns;
+
while (my $col = shift @cols) {
- my $column_info = {};
- if ($col =~ s/^\+//) {
- $column_info = $self->column_info($col);
- }
+ my $column_info =
+ (
+ $col =~ s/^\+//
+ and
+ ( $colinfos ||= $self->columns_info )->{$col}
+ )
+ ||
+ {}
+ ;
# If next entry is { ... } use that for the column info, if not
# use an empty hashref
push(@added, $col) unless exists $columns->{$col};
$columns->{$col} = $column_info;
}
+
push @{ $self->_ordered_columns }, @added;
+ $self->_columns($columns);
return $self;
}
-sub add_column {
+sub add_column :DBIC_method_is_indirect_sugar {
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
shift->add_columns(@_)
}
=cut
-sub column_info {
- my ($self, $column) = @_;
- $self->throw_exception("No such column $column")
- unless exists $self->_columns->{$column};
-
- if ( ! $self->_columns->{$column}{data_type}
- and ! $self->{_columns_info_loaded}
- and $self->column_info_from_storage
- and my $stor = dbic_internal_try { $self->schema->storage } )
- {
- $self->{_columns_info_loaded}++;
-
- # try for the case of storage without table
- dbic_internal_try {
- my $info = $stor->columns_info_for( $self->from );
- my $lc_info = { map
- { (lc $_) => $info->{$_} }
- ( keys %$info )
- };
-
- foreach my $col ( keys %{$self->_columns} ) {
- $self->_columns->{$col} = {
- %{ $self->_columns->{$col} },
- %{ $info->{$col} || $lc_info->{lc $col} || {} }
- };
- }
- };
- }
+sub column_info :DBIC_method_is_indirect_sugar {
+ DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
- return $self->_columns->{$column};
+ #my ($self, $column) = @_;
+ $_[0]->columns_info([ $_[1] ])->{$_[1]};
}
=head2 columns
}
}
else {
+ # the shallow copy is crucial - there are exists() checks within
+ # the wider codebase
%ret = %$colinfo;
}
sub remove_columns {
my ($self, @to_remove) = @_;
+ local $self->{__in_rsrc_setter_callstack} = 1
+ unless $self->{__in_rsrc_setter_callstack};
+
my $columns = $self->_columns
or return;
$self->_ordered_columns([ grep { not $to_remove{$_} } @{$self->_ordered_columns} ]);
}
-sub remove_column {
+sub remove_column :DBIC_method_is_indirect_sugar {
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
shift->remove_columns(@_)
}
sub set_primary_key {
my ($self, @cols) = @_;
+ local $self->{__in_rsrc_setter_callstack} = 1
+ unless $self->{__in_rsrc_setter_callstack};
+
my $colinfo = $self->columns_info(\@cols);
for my $col (@cols) {
carp_unique(sprintf (
sub sequence {
my ($self,$seq) = @_;
+ local $self->{__in_rsrc_setter_callstack} = 1
+ unless $self->{__in_rsrc_setter_callstack};
+
my @pks = $self->primary_columns
or return;
sub add_unique_constraint {
my $self = shift;
+ local $self->{__in_rsrc_setter_callstack} = 1
+ unless $self->{__in_rsrc_setter_callstack};
+
if (@_ > 2) {
$self->throw_exception(
'add_unique_constraint() does not accept multiple constraints, use '
=cut
-sub add_unique_constraints {
+sub add_unique_constraints :DBIC_method_is_indirect_sugar {
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
my $self = shift;
=back
- __PACKAGE__->result_source_instance->sqlt_deploy_callback('mycallbackmethod');
+ __PACKAGE__->result_source->sqlt_deploy_callback('mycallbackmethod');
or
- __PACKAGE__->result_source_instance->sqlt_deploy_callback(sub {
+ __PACKAGE__->result_source->sqlt_deploy_callback(sub {
my ($source_instance, $sqlt_table) = @_;
...
} );
sub schema {
if (@_ > 1) {
- $_[0]->{schema} = $_[1];
+ # invoke the mark-diverging logic
+ $_[0]->set_rsrc_instance_specific_attribute( schema => $_[1] );
}
else {
- $_[0]->{schema} || do {
+ $_[0]->get_rsrc_instance_specific_attribute( 'schema' ) || do {
my $name = $_[0]->{source_name} || '_unnamed_';
my $err = 'Unable to perform storage-dependent operations with a detached result source '
. "(source '$name' is not associated with a schema).";
=cut
-sub storage {
+sub storage :DBIC_method_is_indirect_sugar {
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
$_[0]->schema->storage
}
sub add_relationship {
my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
+
+ local $self->{__in_rsrc_setter_callstack} = 1
+ unless $self->{__in_rsrc_setter_callstack};
+
$self->throw_exception("Can't create relationship without join condition")
unless $cond;
$attrs ||= {};
# auto-increment
my $rel_source = $self->related_source($rel_name);
+ my $colinfos;
+
foreach my $p ($self->primary_columns) {
- if (exists $keyhash->{$p}) {
- unless (defined($rel_data->{$keyhash->{$p}})
- || $rel_source->column_info($keyhash->{$p})
- ->{is_auto_increment}) {
- return 0;
- }
- }
+ return 0 if (
+ exists $keyhash->{$p}
+ and
+ ! defined( $rel_data->{$keyhash->{$p}} )
+ and
+ ! ( $colinfos ||= $rel_source->columns_info )
+ ->{$keyhash->{$p}}{is_auto_increment}
+ )
}
return 1;
else {
my $class = $self->relationship_info($rel)->{class};
$self->ensure_class_loaded($class);
- $class->result_source_instance;
+ $class->result_source;
}
}
use warnings;
use base 'DBIx::Class';
-use mro 'c3';
use Try::Tiny;
use warnings;
use base 'DBIx::Class::ResultSource';
-use mro 'c3';
=head1 NAME
use warnings;
use base 'DBIx::Class::ResultSource';
-use mro 'c3';
-__PACKAGE__->mk_group_accessors(
- 'simple' => qw(is_virtual view_definition deploy_depends_on) );
+__PACKAGE__->mk_group_accessors( rsrc_instance_specific_attribute => qw(
+ is_virtual view_definition deploy_depends_on
+));
=head1 NAME
__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
__PACKAGE__->table('year2000cds');
- __PACKAGE__->result_source_instance->is_virtual(1);
- __PACKAGE__->result_source_instance->view_definition(
+ __PACKAGE__->result_source->is_virtual(1);
+ __PACKAGE__->result_source->view_definition(
"SELECT cdid, artist, title FROM cd WHERE year ='2000'"
);
__PACKAGE__->add_columns(
If you modified the schema to include a placeholder
- __PACKAGE__->result_source_instance->view_definition(
+ __PACKAGE__->result_source->view_definition(
"SELECT cdid, artist, title FROM cd WHERE year = ?"
);
and ensuring you have is_virtual set to true:
- __PACKAGE__->result_source_instance->is_virtual(1);
+ __PACKAGE__->result_source->is_virtual(1);
You could now say:
=head2 is_virtual
- __PACKAGE__->result_source_instance->is_virtual(1);
+ __PACKAGE__->result_source->is_virtual(1);
Set to true for a virtual view, false or unset for a real
database-based view.
=head2 view_definition
- __PACKAGE__->result_source_instance->view_definition(
+ __PACKAGE__->result_source->view_definition(
"SELECT cdid, artist, title FROM cd WHERE year ='2000'"
);
=head2 deploy_depends_on
- __PACKAGE__->result_source_instance->deploy_depends_on(
+ __PACKAGE__->result_source->deploy_depends_on(
["MyApp::Schema::Result::Year","MyApp::Schema::Result::CD"]
);
$self->schema( $s );
}
else {
- $rs->source_name( $self->source_moniker );
+ # FIXME do not use accessor here - will trigger the divergent meta logic
+ # Ideally this should be investigated and fixed properly, but the
+ # codepath is so obscure, and the trigger point (t/52leaks.t) so bizarre
+ # that... meh.
+ $rs->{source_name} = $self->source_moniker;
+
$rs->{_detached_thaw} = 1;
$self->_detached_source( $rs );
}
use warnings;
use base 'DBIx::Class';
-use mro 'c3';
-use Scalar::Util 'blessed';
-use DBIx::Class::_Util qw( quote_sub fail_on_internal_call );
+# ! LOAD ORDER SENSITIVE !
+# needs to be loaded early to query method attributes below
+# and to do the around()s properly
+use DBIx::Class::ResultSource;
+my @wrap_rsrc_methods = qw(
+ add_columns
+ add_relationship
+);
+
+use DBIx::Class::_Util qw(
+ quote_sub perlstring fail_on_internal_call describe_class_methods
+);
use namespace::clean;
+# FIXME: this is truly bizarre, not sure why it is this way since 93405cf0
+# This value *IS* *DIFFERENT* from source_name in the underlying rsrc
+# instance, and there is *ZERO EFFORT* made to synchronize them...
+# FIXME: Due to the above marking this as a rsrc_proxy method is also out
+# of the question...
__PACKAGE__->mk_group_accessors('inherited_ro_instance' => 'source_name');
-sub get_inherited_ro_instance { shift->get_inherited(@_) }
+sub get_inherited_ro_instance { $_[0]->get_inherited($_[1]) }
sub set_inherited_ro_instance {
- my $self = shift;
-
- $self->throw_exception ("Cannot set @{[shift]} on an instance")
- if blessed $self;
+ $_[0]->throw_exception ("Cannot set '$_[1]' on an instance")
+ if length ref $_[0];
- $self->set_inherited(@_);
+ $_[0]->set_inherited( $_[1], $_[2] );
}
-
-sub add_columns {
+sub add_columns :DBIC_method_is_bypassable_resultsource_proxy {
my ($class, @cols) = @_;
- my $source = $class->result_source_instance;
+ my $source = $class->result_source;
+ local $source->{__callstack_includes_rsrc_proxy_method} = "add_columns";
+
$source->add_columns(@cols);
+
+ my $colinfos;
foreach my $c (grep { !ref } @cols) {
# If this is an augment definition get the real colname.
$c =~ s/^\+//;
- $class->register_column($c => $source->column_info($c));
+ $class->register_column(
+ $c,
+ ( $colinfos ||= $source->columns_info )->{$c}
+ );
}
}
-sub add_column {
+sub add_column :DBIC_method_is_indirect_sugar {
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
shift->add_columns(@_)
}
-
-sub add_relationship {
+sub add_relationship :DBIC_method_is_bypassable_resultsource_proxy {
my ($class, $rel, @rest) = @_;
- my $source = $class->result_source_instance;
+ my $source = $class->result_source;
+ local $source->{__callstack_includes_rsrc_proxy_method} = "add_relationship";
+
$source->add_relationship($rel => @rest);
$class->register_relationship($rel => $source->relationship_info($rel));
}
# legacy resultset_class accessor, seems to be used by cdbi only
-sub iterator_class {
+sub iterator_class :DBIC_method_is_indirect_sugar {
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
- shift->result_source_instance->resultset_class(@_)
+ shift->result_source->resultset_class(@_)
}
for my $method_to_proxy (qw/
relationship_info
has_relationship
/) {
- quote_sub __PACKAGE__."::$method_to_proxy", sprintf( <<'EOC', $method_to_proxy );
+ my $qsub_opts = { attributes => [
+ do {
+ no strict 'refs';
+ attributes::get( \&{"DBIx::Class::ResultSource::$method_to_proxy"} );
+ }
+ ] };
+
+ # bypassable default for backcompat, except for indirect methods
+ # ( those will simply warn during the sanheck )
+ if(! grep
+ { $_ eq 'DBIC_method_is_indirect_sugar' }
+ @{ $qsub_opts->{attributes} }
+ ) {
+ push @wrap_rsrc_methods, $method_to_proxy;
+ push @{ $qsub_opts->{atributes} }, 'DBIC_method_is_bypassable_resultsource_proxy';
+ }
+
+ quote_sub __PACKAGE__."::$method_to_proxy", sprintf( <<'EOC', $method_to_proxy ), {}, $qsub_opts;
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call;
- shift->result_source_instance->%s (@_);
+
+ my $rsrc = shift->result_source;
+ local $rsrc->{__callstack_includes_rsrc_proxy_method} = q(%1$s);
+ $rsrc->%1$s (@_);
EOC
}
+# This is where the "magic" of detecting/invoking the proper overridden
+# Result method takes place. It isn't implemented as a stateless out-of-band
+# SanityCheck as invocation requires certain state in the $rsrc object itself
+# in order not to loop over itself. It is not in ResultSource.pm either
+# because of load order and because the entire stack is just terrible :/
+#
+# The code is not easily readable, as it it optimized for execution time
+# (this stuff will be run all the time across the entire install base :/ )
+#
+{
+ our %__rsrc_proxy_meta_cache;
+
+ sub DBIx::Class::__RsrcProxy_iThreads_handler__::CLONE {
+ # recreating this cache is pretty cheap: just blow it away
+ %__rsrc_proxy_meta_cache = ();
+ }
+
+ for my $method_to_wrap (@wrap_rsrc_methods) {
+
+ my @src_args = (
+ perlstring $method_to_wrap,
+ );
+
+ my $orig = do {
+ no strict 'refs';
+ \&{"DBIx::Class::ResultSource::$method_to_wrap"}
+ };
+
+ my %unclassified_override_warn_emitted;
+
+ my @qsub_args = (
+ {
+ # ref to hashref, this is how S::Q works
+ '$rsrc_proxy_meta_cache' => \\%__rsrc_proxy_meta_cache,
+ '$unclassified_override_warn_emitted' => \\%unclassified_override_warn_emitted,
+ '$orig' => \$orig,
+ },
+ { attributes => [ attributes::get($orig) ] }
+ );
+
+ quote_sub "DBIx::Class::ResultSource::$method_to_wrap", sprintf( <<'EOC', @src_args ), @qsub_args;
+
+ my $overridden_proxy_cref;
+
+ # fall through except when...
+ return &$orig unless (
+
+ # FIXME - this may be necessary some day, but skip the hit for now
+ # Scalar::Util::reftype $_[0] eq 'HASH'
+ # and
+
+ # there is a class to check in the first place
+ defined $_[0]->{result_class}
+
+ and
+ # we are not in a reinvoked callstack
+ (
+ ( $_[0]->{__callstack_includes_rsrc_proxy_method} || '' )
+ ne
+ %1$s
+ )
+
+ and
+ # there is a proxied method in the first place
+ (
+ ( $rsrc_proxy_meta_cache->{address}{%1$s} ||= 0 + (
+ DBIx::Class::ResultSourceProxy->can(%1$s)
+ ||
+ -1
+ ) )
+ >
+ 0
+ )
+
+ and
+ # the proxied method *is overridden*
+ (
+ $rsrc_proxy_meta_cache->{address}{%1$s}
+ !=
+ # the can() should not be able to fail in theory, but the
+ # result class may not inherit from ::Core *at all*
+ # hence we simply ||ourselves to paper over this eventuality
+ (
+ ( $overridden_proxy_cref = $_[0]->{result_class}->can(%1$s) )
+ ||
+ $rsrc_proxy_meta_cache->{address}{%1$s}
+ )
+ )
+
+ and
+ # no short-circuiting atributes
+ (! grep
+ {
+ # checking that:
+ #
+ # - Override is not something DBIC plastered on top of things
+ # One would think this is crazy, yet there it is... sigh:
+ # https://metacpan.org/source/KARMAN/DBIx-Class-RDBOHelpers-0.12/t/lib/MyDBIC/Schema/Cd.pm#L26-27
+ #
+ # - And is not an m2m crapfest
+ #
+ # - And is not something marked as bypassable
+
+ $_ =~ / ^ DBIC_method_is_ (?:
+ generated_from_resultsource_metadata
+ |
+ m2m_ (?: extra_)? sugar (?:_with_attrs)?
+ |
+ bypassable_resultsource_proxy
+ ) $ /x
+ }
+ keys %%{ $rsrc_proxy_meta_cache->{attrs}{$overridden_proxy_cref} ||= {
+ map { $_ => 1 } attributes::get($overridden_proxy_cref)
+ }}
+ )
+ );
+
+ # Getting this far means that there *is* an override
+ # and it is *not* marked for a skip
+
+ # we were asked to loop back through the Result override
+ if (
+ $rsrc_proxy_meta_cache->{attrs}
+ {$overridden_proxy_cref}
+ {DBIC_method_is_mandatory_resultsource_proxy}
+ ) {
+ local $_[0]->{__callstack_includes_rsrc_proxy_method} = %1$s;
+
+ # replace $self without compromising aliasing
+ splice @_, 0, 1, $_[0]->{result_class};
+
+ return &$overridden_proxy_cref;
+ }
+ # complain (sparsely) and carry on
+ else {
+
+ # FIXME!!! - terrible, need to swap for something saner later
+ my ($cs) = DBIx::Class::Carp::__find_caller( __PACKAGE__ );
+
+ my $key = $cs . $overridden_proxy_cref;
+
+ unless( $unclassified_override_warn_emitted->{$key} ) {
+
+ # find the real origin
+ my @meth_stack = @{ DBIx::Class::_Util::describe_class_methods(
+ ref $_[0]->{result_class} || $_[0]->{result_class}
+ )->{methods}{%1$s} };
+
+ my $in_class = (shift @meth_stack)->{via_class};
+
+ my $possible_supers;
+ while (
+ @meth_stack
+ and
+ $meth_stack[0]{via_class} ne __PACKAGE__
+ ) {
+ push @$possible_supers, (shift @meth_stack)->{via_class};
+ }
+
+ $possible_supers = $possible_supers
+ ? sprintf(
+ ' ( and possible SUPERs: %%s )',
+ join ', ', map
+ { join '::', $_, %1$s }
+ @$possible_supers
+ )
+ : ''
+ ;
+
+ my $fqmeth = $in_class . '::' . %1$s . '()';
+
+ DBIx::Class::_Util::emit_loud_diag(
+ # Repurpose the assertion envvar ( the override-check is independent
+ # from the schema san-checker, but the spirit is the same )
+ confess => $ENV{DBIC_ASSERT_NO_FAILING_SANITY_CHECKS},
+ msg =>
+ "The override method $fqmeth$possible_supers has been bypassed "
+ . "$cs\n"
+ . "In order to silence this warning you must tag the "
+ . "definition of $fqmeth with one of the attributes "
+ . "':DBIC_method_is_bypassable_resultsource_proxy' or "
+ . "':DBIC_method_is_mandatory_resultsource_proxy' ( see "
+ . "https://is.gd/dbic_rsrcproxy_methodattr for more info )\n"
+ );
+
+ # only set if we didn't throw
+ $unclassified_override_warn_emitted->{$key} = 1;
+ }
+
+ return &$orig;
+ }
+EOC
+
+ }
+
+ Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
+}
+
+# CI sanity check that all annotations make sense
+if(
+ DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE
+ and
+ # no point taxing 5.8 with this
+ ! DBIx::Class::_ENV_::OLD_MRO
+) {
+
+ my ( $rsrc_methods, $rsrc_proxy_methods, $base_methods ) = map {
+ describe_class_methods($_)->{methods}
+ } qw(
+ DBIx::Class::ResultSource
+ DBIx::Class::ResultSourceProxy
+ DBIx::Class
+ );
+
+ delete $rsrc_methods->{$_}, delete $rsrc_proxy_methods->{$_}
+ for keys %$base_methods;
+
+ (
+ $rsrc_methods->{$_}
+ and
+ ! $rsrc_proxy_methods->{$_}[0]{attributes}{DBIC_method_is_indirect_sugar}
+ )
+ or
+ delete $rsrc_proxy_methods->{$_}
+ for keys %$rsrc_proxy_methods;
+
+ # see fat FIXME at top of file
+ delete @{$rsrc_proxy_methods}{qw( source_name _source_name_accessor )};
+
+ if (
+ ( my $proxied = join "\n", map "\t$_", sort keys %$rsrc_proxy_methods )
+ ne
+ ( my $wrapped = join "\n", map "\t$_", sort @wrap_rsrc_methods )
+ ) {
+ Carp::confess(
+ "Unexpected mismatch between the list of proxied methods:\n\n$proxied"
+ . "\n\nand the list of wrapped rsrc methods:\n\n$wrapped\n\n"
+ );
+ }
+}
+
1;
use Scalar::Util 'blessed';
use namespace::clean;
+# FIXME - both of these *PROBABLY* need to be 'inherited_ro_instance' type
__PACKAGE__->mk_classaccessor(table_class => 'DBIx::Class::ResultSource::Table');
-
# FIXME: Doesn't actually do anything yet!
__PACKAGE__->mk_group_accessors( inherited => 'table_alias' );
sub _init_result_source_instance {
my $class = shift;
- $class->mk_group_accessors( inherited => 'result_source_instance' )
+ $class->mk_group_accessors( inherited => [ result_source_instance => '_result_source' ] )
unless $class->can('result_source_instance');
- my $table = $class->result_source_instance;
- return $table
- if $table and $table->result_class eq $class;
+ # might be pre-made for us courtesy of DBIC::DB::result_source_instance()
+ my $rsrc = $class->result_source_instance;
+
+ return $rsrc
+ if $rsrc and $rsrc->result_class eq $class;
my $table_class = $class->table_class;
$class->ensure_class_loaded($table_class);
- if( $table ) {
- $table = $table_class->new({
- %$table,
+ if( $rsrc ) {
+ #
+ # NOTE! - not using clone() here and *NOT* marking source as derived
+ # from the one already existing on the class (if any)
+ #
+ $rsrc = $table_class->new({
+ %$rsrc,
result_class => $class,
source_name => undef,
schema => undef
});
}
else {
- $table = $table_class->new({
+ $rsrc = $table_class->new({
name => undef,
result_class => $class,
source_name => undef,
});
}
- $class->result_source_instance($table);
-
- return $table;
+ $class->result_source_instance($rsrc);
}
=head1 NAME
=cut
sub table {
+ return $_[0]->result_source->name unless @_ > 1;
+
my ($class, $table) = @_;
- return $class->result_source_instance->name unless $table;
unless (blessed $table && $table->isa($class->table_class)) {
+ my $ancestor = $class->can('result_source_instance')
+ ? $class->result_source_instance
+ : undef
+ ;
+
+ # Folks calling ->table on a class *might* expect the name
+ # to shift everywhere, but that can't happen
+ # So what we do is mark the ancestor as "dirty"
+ # even though it will have no "derived" link to the one we
+ # will use afterwards
+ if(
+ defined $ancestor
+ and
+ $ancestor->name ne $table
+ and
+ scalar $ancestor->__derived_instances
+ ) {
+ # Trigger the "descendants are dirty" logic, without giving
+ # it an explicit externally-callable interface
+ # This is ugly as sin, but likely saner in the long run
+ local $ancestor->{__in_rsrc_setter_callstack} = 1
+ unless $ancestor->{__in_rsrc_setter_callstack};
+ my $old_name = $ancestor->name;
+ $ancestor->set_rsrc_instance_specific_attribute( name => "\0" );
+ $ancestor->set_rsrc_instance_specific_attribute( name => $old_name );
+ }
+
+
my $table_class = $class->table_class;
$class->ensure_class_loaded($table_class);
+
+ # NOTE! - not using clone() here and *NOT* marking source as derived
+ # from the one already existing on the class (if any)
+ # This is logically sound as we are operating at class-level, and is
+ # in fact necessary, as otherwise any base-class with a "dummy" table
+ # will be marked as an ancestor of everything
$table = $table_class->new({
- $class->can('result_source_instance')
- ? %{$class->result_source_instance||{}}
- : ()
- ,
+ %{ $ancestor || {} },
name => $table,
result_class => $class,
});
}
- $class->mk_group_accessors(inherited => 'result_source_instance')
+ $class->mk_group_accessors( inherited => [ result_source_instance => '_result_source' ] )
unless $class->can('result_source_instance');
- $class->result_source_instance($table);
-
- return $class->result_source_instance->name;
+ $class->result_source_instance($table)->name;
}
=head2 table_class
$rsrc ||= $h->resolve;
}
- $new->result_source($rsrc) if $rsrc;
+ $new->result_source_instance($rsrc) if $rsrc;
if (my $col_from_rel = delete $attrs->{-cols_from_relations}) {
@{$new->{_ignore_at_insert}={}}{@$col_from_rel} = ();
}
- my ($related,$inflated);
+ my( $related, $inflated, $colinfos );
foreach my $key (keys %$attrs) {
if (ref $attrs->{$key} and ! is_literal_value($attrs->{$key}) ) {
next;
}
elsif (
- $rsrc->has_column($key)
- and
- $rsrc->column_info($key)->{_inflate_info}
+ ( $colinfos ||= $rsrc->columns_info )
+ ->{$key}{_inflate_info}
) {
$inflated->{$key} = $attrs->{$key};
next;
$self->in_storage(0);
}
else {
- my $rsrc = dbic_internal_try { $self->result_source_instance }
- or $self->throw_exception("Can't do class delete without a ResultSource instance");
-
my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
- $rsrc->resultset->search(@_)->delete;
+ $self->result_source->resultset->search_rs(@_)->delete;
}
return $self;
}
return undef
unless ( $rsrc = $self->result_source )->has_column($column);
- my $colinfo = $rsrc->column_info ($column);
+ my $colinfo = $rsrc->columns_info->{$column};
# cache for speed (the object may *not* have a resultsource instance)
if (
sub set_inflated_columns {
my ( $self, $upd ) = @_;
- my $rsrc;
+
+ my ($rsrc, $colinfos);
+
foreach my $key (keys %$upd) {
if (ref $upd->{$key}) {
$rsrc ||= $self->result_source;
);
}
elsif (
- $rsrc->has_column($key)
- and
- exists $rsrc->column_info($key)->{_inflate_info}
+ exists( (
+ ( $colinfos ||= $rsrc->columns_info )->{$key}
+ ||
+ {}
+ )->{_inflate_info} )
) {
$self->set_inflated_column($key, delete $upd->{$key});
}
my $new = { _column_data => $col_data };
bless $new, ref $self;
- $new->result_source($rsrc);
+ $new->result_source_instance($rsrc);
$new->set_inflated_columns($changes);
$new->insert;
=cut
-sub insert_or_update {
+sub insert_or_update :DBIC_method_is_indirect_sugar {
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
shift->update_or_insert(@_);
}
=cut
-sub result_source {
- $_[0]->throw_exception( 'result_source can be called on instances only' )
- unless ref $_[0];
-
+sub result_source :DBIC_method_is_indirect_sugar {
+ # While getter calls are routed through here for sensible exception text
+ # it makes no sense to have setters do the same thing
+ DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
+ and
@_ > 1
- ? $_[0]->{_result_source} = $_[1]
-
- # note this is a || not a ||=, the difference is important
- : $_[0]->{_result_source} || do {
- $_[0]->can('result_source_instance')
- ? $_[0]->result_source_instance
- : $_[0]->throw_exception(
- "No result source instance registered for @{[ ref $_[0] ]}, did you forget to call @{[ ref $_[0] ]}->table(...) ?"
- )
- }
- ;
+ and
+ fail_on_internal_call;
+
+ # this is essentially a `shift->result_source_instance(@_)` with handholding
+ &{
+ $_[0]->can('result_source_instance')
+ ||
+ $_[0]->throw_exception(
+ "No ResultSource instance registered for '@{[ $_[0] ]}', did you forget to call @{[ ref $_[0] || $_[0] ]}->table(...) ?"
+ )
+ };
}
=head2 register_column
if (
! DBIx::Class::_Util::in_internal_try
and
- my $rsrc = dbic_internal_try { $self->result_source }
+ # FIXME - the try is 99% superfluous, but just in case
+ my $rsrc = dbic_internal_try { $self->result_source_instance }
) {
$rsrc->throw_exception(@_)
}
use warnings;
use base 'DBIx::Class';
-use mro 'c3';
use DBIx::Class::Carp;
use Try::Tiny;
-use Scalar::Util qw/weaken blessed/;
+use Scalar::Util qw( weaken blessed refaddr );
use DBIx::Class::_Util qw(
+ false emit_loud_diag refdesc
refcount quote_sub scope_guard
is_exception dbic_internal_try
fail_on_internal_call emit_loud_diag
__PACKAGE__->mk_classaccessor('class_mappings' => {});
__PACKAGE__->mk_classaccessor('source_registrations' => {});
+__PACKAGE__->mk_group_accessors( component_class => 'schema_sanity_checker' );
+__PACKAGE__->schema_sanity_checker(
+ DBIx::Class::_ENV_::OLD_MRO ? false :
+ 'DBIx::Class::Schema::SanityChecker'
+);
+
=head1 NAME
DBIx::Class::Schema - composable schemas
my $rs_class = ref ($_[0]) || $_[0];
return dbic_internal_try {
- $rs_class->result_source_instance
+ $rs_class->result_source
} catch {
$me->throw_exception (
"Attempt to load_namespaces() class $rs_class failed - are you sure this is a real Result Class?: $_"
use base qw/DBIx::Class::Schema/;
__PACKAGE__->default_resultset_attributes( { software_limit => 1 } );
+=head2 schema_sanity_checker
+
+=over 4
+
+=item Arguments: L<perform_schema_sanity_checks()|DBIx::Class::Schema::SanityChecker/perform_schema_sanity_checks> provider
+
+=item Return Value: L<perform_schema_sanity_checks()|DBIx::Class::Schema::SanityChecker/perform_schema_sanity_checks> provider
+
+=item Default value: L<DBIx::Class::Schema::SanityChecker>
+
+=back
+
+On every call to L</connection> if the value of this attribute evaluates to
+true, DBIC will invoke
+C<< L<$schema_sanity_checker|/schema_sanity_checker>->L<perform_schema_sanity_checks|DBIx::Class::Schema::SanityChecker/perform_schema_sanity_checks>($schema) >>
+before returning. The return value of this invocation is ignored.
+
+B<YOU ARE STRONGLY URGED> to
+L<learn more about the reason|DBIx::Class::Schema::SanityChecker/WHY> this
+feature was introduced. Blindly disabling the checker on existing projects
+B<may result in data corruption> after upgrade to C<< DBIC >= v0.082900 >>.
+
+Example:
+
+ package My::Schema;
+ use base qw/DBIx::Class::Schema/;
+ __PACKAGE__->schema_sanity_checker('My::Schema::SanityChecker');
+
+ # or to disable all checks:
+ __PACKAGE__->schema_sanity_checker('');
+
+Note: setting the value to C<undef> B<will not> have the desired effect,
+due to an implementation detail of L<Class::Accessor::Grouped> inherited
+accessors. In order to disable any and all checks you must set this
+attribute to an empty string as shown in the second example above.
+
=head2 exception_action
=over 4
=cut
-sub connect {
+sub connect :DBIC_method_is_indirect_sugar {
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
shift->clone->connection(@_);
}
=cut
sub source {
- my $self = shift;
+ my ($self, $source_name) = @_;
$self->throw_exception("source() expects a source name")
- unless @_;
+ unless $source_name;
+
+ my $source_registrations;
- my $source_name = shift;
+ my $rsrc =
+ ( $source_registrations = $self->source_registrations )->{$source_name}
+ ||
+ # if we got here, they probably passed a full class name
+ $source_registrations->{ $self->class_mappings->{$source_name} || '' }
+ ||
+ $self->throw_exception( "Can't find source for ${source_name}" )
+ ;
+
+ # DO NOT REMOVE:
+ # We need to prevent alterations of pre-existing $@ due to where this call
+ # sits in the overall stack ( *unless* of course there is an actual error
+ # to report ). set_mro does alter $@ (and yes - it *can* throw an exception)
+ # We do not use local because set_mro *can* throw an actual exception
+ # We do not use a try/catch either, as on one hand it would slow things
+ # down for no reason (we would always rethrow), but also because adding *any*
+ # try/catch block below will segfault various threading tests on older perls
+ # ( which in itself is a FIXME but ENOTIMETODIG )
+ my $old_dollarat = $@;
+
+ no strict 'refs';
+ mro::set_mro($_, 'c3') for
+ grep
+ {
+ # some pseudo-sources do not have a result/resultset yet
+ defined $_
+ and
+ (
+ (
+ ${"${_}::__INITIAL_MRO_UPON_DBIC_LOAD__"}
+ ||= mro::get_mro($_)
+ )
+ ne
+ 'c3'
+ )
+ }
+ map
+ { length ref $_ ? ref $_ : $_ }
+ ( $rsrc, $rsrc->result_class, $rsrc->resultset_class )
+ ;
- my $sreg = $self->source_registrations;
- return $sreg->{$source_name} if exists $sreg->{$source_name};
+ # DO NOT REMOVE - see comment above
+ $@ = $old_dollarat;
- # if we got here, they probably passed a full class name
- my $mapped = $self->class_mappings->{$source_name};
- $self->throw_exception("Can't find source for ${source_name}")
- unless $mapped && exists $sreg->{$mapped};
- return $sreg->{$mapped};
+ $rsrc;
}
=head2 class
=cut
-sub populate {
+sub populate :DBIC_method_is_indirect_sugar {
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
my ($self, $name, $data) = @_;
data B<in-place> on C<$self>. You should probably be calling
L</connect> to get a properly L<cloned|/clone> Schema object instead.
+If the accessor L</schema_sanity_checker> returns a true value C<$checker>,
+the following call will take place before return:
+C<< L<$checker|/schema_sanity_checker>->L<perform_schema_sanity_checks(C<$self>)|DBIx::Class::Schema::SanityChecker/perform_schema_sanity_checks> >>
+
=head3 Overloading
Overload C<connection> to change the behaviour of C<connect>.
=cut
+my $default_off_stderr_blurb_emitted;
sub connection {
my ($self, @info) = @_;
return $self if !@info && $self->storage;
my $storage = $storage_class->new( $self => $args||{} );
$storage->connect_info(\@info);
$self->storage($storage);
- return $self;
+
+
+###
+### Begin 5.8 "you have not selected a checker" warning
+###
+ # We can not blanket-enable this on 5.8 - it is just too expensive for
+ # day to day execution. We also can't just go silent - there are genuine
+ # regressions ( due to core changes) for which this is the only line of
+ # defense. So instead we whine on STDERR that folks need to do something
+ #
+ # Beyond suboptimal, but given the constraints the best we can do :(
+ #
+ # This should stay around for at least 3~4 years
+ #
+ DBIx::Class::_ENV_::OLD_MRO
+ and
+ ! $default_off_stderr_blurb_emitted
+ and
+ length ref $self->schema_sanity_checker
+ and
+ length ref __PACKAGE__->schema_sanity_checker
+ and
+ (
+ refaddr( $self->schema_sanity_checker )
+ ==
+ refaddr( __PACKAGE__->schema_sanity_checker )
+ )
+ and
+ emit_loud_diag(
+ msg => sprintf(
+ "Sanity checks for schema %s are disabled on this perl $]: "
+ . '*THIS IS POTENTIALLY VERY DANGEROUS*. You are strongly urged to '
+ . "read http://is.gd/dbic_sancheck_5_008 before proceeding\n",
+ ( defined( blessed $self ) ? refdesc $self : "'$self'" )
+ ))
+ and
+ $default_off_stderr_blurb_emitted = 1;
+###
+### End 5.8 "you have not selected a checker" warning
+###
+
+
+ if( my $checker = $self->schema_sanity_checker ) {
+ $checker->perform_schema_sanity_checks($self);
+ }
+
+ $self;
}
sub _normalize_storage_type {
my $target_class = "${target}::${source_name}";
$self->inject_base($target_class, $orig_source->result_class, ($base || ()) );
- # register_source examines result_class, and then returns us a clone
- my $new_source = $schema->register_source($source_name, bless
- { %$orig_source, result_class => $target_class },
- ref $orig_source,
+ $schema->register_source(
+ $source_name,
+ $orig_source->clone(
+ result_class => $target_class
+ ),
);
-
- if ($target_class->can('result_source_instance')) {
- # give the class a schema-less source copy
- $target_class->result_source_instance( bless
- { %$new_source, schema => ref $new_source->{schema} || $new_source->{schema} },
- ref $new_source,
- );
- }
}
# Legacy stuff, not inserting INDIRECT assertions
Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
+ # Give each composed class yet another *schema-less* source copy
+ # this is used for the freeze/thaw cycle
+ #
+ # This is not covered by any tests directly, but is indirectly exercised
+ # in t/cdbi/sweet/08pager by re-setting the schema on an existing object
+ # FIXME - there is likely a much cheaper way to take care of this
+ for my $source_name ($self->sources) {
+
+ my $target_class = "${target}::${source_name}";
+
+ $target_class->result_source_instance(
+ $self->source($source_name)->clone(
+ result_class => $target_class,
+ schema => ( ref $schema || $schema ),
+ )
+ );
+ }
+
return $schema;
}
$self->class_mappings({ %{$from->class_mappings} });
$self->source_registrations({ %{$from->source_registrations} });
- foreach my $source_name ($from->sources) {
- my $source = $from->source($source_name);
- my $new = $source->new($source);
- # we use extra here as we want to leave the class_mappings as they are
- # but overwrite the source_registrations entry with the new source
- $self->register_extra_source($source_name => $new);
- }
+ # we use extra here as we want to leave the class_mappings as they are
+ # but overwrite the source_registrations entry with the new source
+ $self->register_extra_source( $_ => $from->source($_) )
+ for $from->sources;
if ($from->storage) {
$self->storage($from->storage);
Registers a class which isa DBIx::Class::ResultSourceProxy. Equivalent to
calling:
- $schema->register_source($source_name, $component_class->result_source_instance);
+ $schema->register_source($source_name, $component_class->result_source);
=cut
sub register_class {
my ($self, $source_name, $to_register) = @_;
- $self->register_source($source_name => $to_register->result_source_instance);
+ $self->register_source($source_name => $to_register->result_source);
}
=head2 register_source
sub register_extra_source { shift->_register_source(@_, { extra => 1 }) }
sub _register_source {
- my ($self, $source_name, $source, $params) = @_;
+ my ($self, $source_name, $supplied_rsrc, $params) = @_;
+
+ my $derived_rsrc = $supplied_rsrc->clone({
+ source_name => $source_name,
+ });
- $source = $source->new({ %$source, source_name => $source_name });
+ # Do not move into the clone-hashref above: there are things
+ # on CPAN that do hook 'sub schema' </facepalm>
+ # https://metacpan.org/source/LSAUNDERS/DBIx-Class-Preview-1.000003/lib/DBIx/Class/ResultSource/Table/Previewed.pm#L9-38
+ $derived_rsrc->schema($self);
- $source->schema($self);
- weaken $source->{schema} if ref($self);
+ weaken $derived_rsrc->{schema}
+ if length( my $schema_class = ref($self) );
my %reg = %{$self->source_registrations};
- $reg{$source_name} = $source;
+ $reg{$source_name} = $derived_rsrc;
$self->source_registrations(\%reg);
- return $source if $params->{extra};
+ return $derived_rsrc if $params->{extra};
- my $rs_class = $source->result_class;
- if ($rs_class and my $rsrc = dbic_internal_try { $rs_class->result_source_instance } ) {
+ my( $result_class, $result_class_level_rsrc );
+ if (
+ $result_class = $derived_rsrc->result_class
+ and
+ # There are known cases where $rs_class is *ONLY* an inflator, without
+ # any hint of a rsrc (e.g. DBIx::Class::KiokuDB::EntryProxy)
+ $result_class_level_rsrc = dbic_internal_try { $result_class->result_source_instance }
+ ) {
my %map = %{$self->class_mappings};
+
+ carp (
+ "$result_class already had a registered source which was replaced by "
+ . 'this call. Perhaps you wanted register_extra_source(), though it is '
+ . 'more likely you did something wrong.'
+ ) if (
+ exists $map{$result_class}
+ and
+ $map{$result_class} ne $source_name
+ and
+ $result_class_level_rsrc != $supplied_rsrc
+ );
+
+ $map{$result_class} = $source_name;
+ $self->class_mappings(\%map);
+
+
+ my $schema_class_level_rsrc;
if (
- exists $map{$rs_class}
+ # we are called on a schema instance, not on the class
+ length $schema_class
+
and
- $map{$rs_class} ne $source_name
+
+ # the schema class also has a registration with the same name
+ $schema_class_level_rsrc = dbic_internal_try { $schema_class->source($source_name) }
+
+ and
+
+ # what we are registering on the schema instance *IS* derived
+ # from the class-level (top) rsrc...
+ ( grep { $_ == $derived_rsrc } $result_class_level_rsrc->__derived_instances )
+
and
- $rsrc ne $_[2] # orig_source
+
+ # ... while the schema-class-level has stale-markers
+ keys %{ $schema_class_level_rsrc->{__metadata_divergencies} || {} }
) {
- carp
- "$rs_class already had a registered source which was replaced by this call. "
- . 'Perhaps you wanted register_extra_source(), though it is more likely you did '
- . 'something wrong.'
+ my $msg =
+ "The ResultSource instance you just registered on '$self' as "
+ . "'$source_name' seems to have no relation to $schema_class->"
+ . "source('$source_name') which in turn is marked stale (likely due "
+ . "to recent $result_class->... direct class calls). This is almost "
+ . "always a mistake: perhaps you forgot a cycle of "
+ . "$schema_class->unregister_source( '$source_name' ) / "
+ . "$schema_class->register_class( '$source_name' => '$result_class' )"
;
- }
- $map{$rs_class} = $source_name;
- $self->class_mappings(\%map);
+ DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE
+ ? emit_loud_diag( msg => $msg, confess => 1 )
+ : carp_unique($msg)
+ ;
+ }
}
- return $source;
+ $derived_rsrc;
}
my $global_phase_destroy;
my $source = $schema->source($source_name);
my $class = $source->result_class;
#warn "$source_name $class $source ".$source->storage;
- $class->mk_classaccessor(result_source_instance => $source);
+
+ $class->mk_group_accessors( inherited => [ result_source_instance => '_result_source' ] );
+ # explicit set-call, avoid mro update lag
+ $class->set_inherited( result_source_instance => $source );
+
$class->mk_classaccessor(resultset_instance => $source->resultset);
$class->mk_classaccessor(class_resolver => $schema);
}
--- /dev/null
+package DBIx::Class::Schema::SanityChecker;
+
+use strict;
+use warnings;
+
+use DBIx::Class::_Util qw(
+ dbic_internal_try refdesc uniq serialize
+ describe_class_methods emit_loud_diag
+);
+use DBIx::Class ();
+use DBIx::Class::Exception ();
+use Scalar::Util qw( blessed refaddr );
+use namespace::clean;
+
+=head1 NAME
+
+DBIx::Class::Schema::SanityChecker - Extensible "critic" for your Schema class hierarchy
+
+=head1 SYNOPSIS
+
+ package MyApp::Schema;
+ use base 'DBIx::Class::Schema';
+
+ # this is the default on Perl v5.10 and later
+ __PACKAGE__->schema_sanity_checker('DBIx::Class::Schema::SanityChecker');
+ ...
+
+=head1 DESCRIPTION
+
+This is the default implementation of the Schema and related classes
+L<validation framework|DBIx::Class::Schema/schema_sanity_checker>.
+
+The validator is B<enabled by default> on perls C<v5.10> and above. See
+L</Performance considerations> for discussion of the runtime effects.
+
+Use of this class begins by invoking L</perform_schema_sanity_checks>
+(usually via L<DBIx::Class::Schema/connection>), which in turn starts
+invoking validators I<C<check_$checkname()>> in the order listed in
+L</available_checks>. For each set of returned errors (if any)
+I<C<format_$checkname_errors()>> is called and the resulting strings are
+passed to L</emit_errors>, where final headers are prepended and the entire
+thing is printed on C<STDERR>.
+
+The class does not provide a constructor, due to the lack of state to be
+passed around: object orientation was chosen purely for the ease of
+overriding parts of the chain of events as described above. The general
+pattern of communicating errors between the individual methods (both
+before and after formatting) is an arrayref of hash references.
+
+=head2 WHY
+
+DBIC existed for more than a decade without any such setup validation
+fanciness, let alone something that is enabled by default (which in turn
+L<isn't free|/Performance considerations>). The reason for this relatively
+drastic change is a set of revamps within the metadata handling framework,
+in order to resolve once and for all problems like
+L<RT#107462|https://rt.cpan.org/Ticket/Display.html?id=107462>,
+L<RT#114440|https://rt.cpan.org/Ticket/Display.html?id=114440>, etc. While
+DBIC internals are now way more robust than they were before, this comes at
+a price: some non-issues in code that has been working for a while, will
+now become hard to explain, or if you are unlucky: B<silent breakages>.
+
+Thus, in order to protect existing codebases to the fullest extent possible,
+the executive decision (and substantial effort) was made to introduce this
+on-by-default setup validation framework. A massive amount of work has been
+invested ensuring that none of the builtin checks emit a false-positive:
+each and every complaint made by these checks B<should be investigated>.
+
+=head2 Performance considerations
+
+First of all - after your connection has been established - there is B<no
+runtime penalty> whenever the checks are enabled.
+
+By default the checks are triggered every time
+L<DBIx::Class::Schema/connection> is called. Thus there is a
+noticeable startup slowdown, most notably during testing (each test is
+effectively a standalone program connecting anew). As an example the test
+execution phase of the L<DBIx::Class::Helpers> C<v2.032002> distribution
+suffers a consistent slowdown of about C<16%>. This is considered a relatively
+small price to pay for the benefits provided.
+
+Nevertheless, there are valid cases for disabling the checks during
+day-to-day development, and having them run only during CI builds. In fact
+the test suite of DBIC does exactly this as can be seen in
+F<t/lib/DBICTest/BaseSchema.pm>:
+
+ ~/dbic_repo$ git show 39636786 | perl -ne "print if 16..61"
+
+Whatever you do, B<please do not disable the checks entirely>: it is not
+worth the risk.
+
+=head3 Perl5.8
+
+The situation with perl interpreters before C<v5.10.0> is sadly more
+complicated: due to lack of built-in L<pluggable mro support|mro>, the
+mechanism used to interrogate various classes is
+L<< B<much> slower|https://github.com/dbsrgits/dbix-class/commit/296248c3 >>.
+As a result the very same version of L<DBIx::Class::Helpers>
+L<mentioned above|/Performance considerations> takes a C<B<220%>> hit on its
+test execution time (these numbers are observed with the speedups of
+L<Class::C3::XS> available, without them the slowdown reaches the whopping
+C<350%>).
+
+Therefore, on these versions of perl the sanity checks are B<not enabled> by
+default. Instead a C<false> placeholder value is inserted into the
+L<schema_sanity_checker attribute|DBIx::Class::Schema/schema_sanity_checker>,
+urging the user to decide for themselves how to proceed.
+
+It is the author's B<strongest> recommendation to find a way to run the
+checks on your codebase continuously, even if it takes much longer. Refer to
+the last paragraph of L</Performance considerations> above for an example how
+to do this during CI builds only.
+
+=head2 Validations provided by this module
+
+=head3 no_indirect_method_overrides
+
+There are many methods within DBIC which are
+L<"strictly sugar"|DBIx::Class::MethodAttributes/DBIC_method_is_indirect_sugar>
+and should never be overridden by your application (e.g. see warnings at the
+end of L<DBIx::Class::ResultSet/create> and L<DBIx::Class::Schema/connect>).
+Starting with C<v0.082900> DBIC is much more aggressive in calling the
+underlying non-sugar methods directly, which in turn means that almost all
+user-side overrides of sugar methods are never going to be invoked. These
+situations are now reliably detected and reported individually (you may
+end up with a lot of output on C<STDERR> due to this).
+
+Note: B<ANY AND ALL ISSUES> reported by this check B<*MUST*> be resolved
+before upgrading DBIC in production. Malfunctioning business logic and/or
+B<SEVERE DATA LOSS> may result otherwise.
+
+=head3 valid_c3_composition
+
+Looks through everything returned by L</all_schema_related_classes>, and
+for any class that B<does not> already utilize L<c3 MRO|mro/The C3 MRO> a
+L<method shadowing map|App::Isa::Splain/SYNOPSIS> is calculated and then
+compared to the shadowing map as if C<c3 MRO> was requested in the first place.
+Any discrepancies are reported in order to clearly identify L<hard to explain
+bugs|https://blog.afoolishmanifesto.com/posts/mros-and-you> especially when
+encountered within complex inheritance hierarchies.
+
+=head3 no_inheritance_crosscontamination
+
+Checks that every individual L<Schema|DBIx::Class::Schema>,
+L<Storage|DBIx::Class::Storage>, L<ResultSource|DBIx::Class::ResultSource>,
+L<ResultSet|DBIx::Class::ResultSet>
+and L<Result|DBIx::Class::Manual::ResultClass> class does not inherit from
+an unexpected DBIC base class: e.g. an error will be raised if your
+C<MyApp::Schema> inherits from both C<DBIx::Class::Schema> and
+C<DBIx::Class::ResultSet>.
+
+=head1 METHODS
+
+=head2 perform_schema_sanity_checks
+
+=over
+
+=item Arguments: L<$schema|DBIx::Class::Schema>
+
+=item Return Value: unspecified (ignored by caller)
+
+=back
+
+The entry point expected by the
+L<validation framework|DBIx::Class::Schema/schema_sanity_checker>. See
+L</DESCRIPTION> for details.
+
+=cut
+
+sub perform_schema_sanity_checks {
+ my ($self, $schema) = @_;
+
+ local $DBIx::Class::_Util::describe_class_query_cache->{'!internal!'} = {}
+ if
+ # does not make a measurable difference on 5.10+
+ DBIx::Class::_ENV_::OLD_MRO
+ and
+ # the callstack shouldn't really be recursive, but for completeness...
+ ! $DBIx::Class::_Util::describe_class_query_cache->{'!internal!'}
+ ;
+
+ my (@errors_found, $schema_desc);
+ for my $ch ( @{ $self->available_checks } ) {
+
+ my $err = $self->${\"check_$ch"} ( $schema );
+
+ push @errors_found, map
+ {
+ {
+ check_name => $ch,
+ formatted_error => $_,
+ schema_desc => ( $schema_desc ||=
+ ( length ref $schema )
+ ? refdesc $schema
+ : "'$schema'"
+ ),
+ }
+ }
+ @{
+ $self->${\"format_${ch}_errors"} ( $err )
+ ||
+ []
+ }
+ if @$err;
+ }
+
+ $self->emit_errors(\@errors_found)
+ if @errors_found;
+}
+
+=head2 available_checks
+
+=over
+
+=item Arguments: none
+
+=item Return Value: \@list_of_check_names
+
+=back
+
+The list of checks L</perform_schema_sanity_checks> will perform on the
+provided L<$schema|DBIx::Class::Schema> object. For every entry returned
+by this method, there must be a pair of I<C<check_$checkname()>> and
+I<C<format_$checkname_errors()>> methods available.
+
+Override this method to add checks to the
+L<currently available set|/Validations provided by this module>.
+
+=cut
+
+sub available_checks { [qw(
+ valid_c3_composition
+ no_inheritance_crosscontamination
+ no_indirect_method_overrides
+)] }
+
+=head2 emit_errors
+
+=over
+
+=item Arguments: \@list_of_formatted_errors
+
+=item Return Value: unspecified (ignored by caller)
+
+=back
+
+Takes an array reference of individual errors returned by various
+I<C<format_$checkname_errors()>> formatters, and outputs them on C<STDERR>.
+
+This method is the most convenient integration point for a 3rd party logging
+framework.
+
+Each individual error is expected to be a hash reference with all values being
+plain strings as follows:
+
+ {
+ schema_desc => $human_readable_description_of_the_passed_in_schema
+ check_name => $name_of_the_check_as_listed_in_available_checks()
+ formatted_error => $error_text_as_returned_by_format_$checkname_errors()
+ }
+
+If the environment variable C<DBIC_ASSERT_NO_FAILING_SANITY_CHECKS> is set to
+a true value this method will throw an exception with the same text. Those who
+prefer to take no chances could set this variable permanently as part of their
+deployment scripts.
+
+=cut
+
+# *NOT* using carp_unique and the warn framework - make
+# it harder to accidentaly silence problems via $SIG{__WARN__}
+sub emit_errors {
+ #my ($self, $errs) = @_;
+
+ my @final_error_texts = map {
+ sprintf( "Schema %s failed the '%s' sanity check: %s\n",
+ @{$_}{qw( schema_desc check_name formatted_error )}
+ );
+ } @{$_[1]};
+
+ emit_loud_diag(
+ msg => $_
+ ) for @final_error_texts;
+
+ # Do not use the constant - but instead check the env every time
+ # This will allow people to start auditing their apps piecemeal
+ DBIx::Class::Exception->throw( join "\n", @final_error_texts, ' ' )
+ if $ENV{DBIC_ASSERT_NO_FAILING_SANITY_CHECKS};
+}
+
+=head2 all_schema_related_classes
+
+=over
+
+=item Arguments: L<$schema|DBIx::Class::Schema>
+
+=item Return Value: @sorted_list_of_unique_class_names
+
+=back
+
+This is a convenience method providing a list (not an arrayref) of
+"interesting classes" related to the supplied schema. The returned list
+currently contains the following class names:
+
+=over
+
+=item * The L<Schema|DBIx::Class::Schema> class itself
+
+=item * The associated L<Storage|DBIx::Class::Schema/storage> class if any
+
+=item * The classes of all L<registered ResultSource instances|DBIx::Class::Schema/sources> if any
+
+=item * All L<Result|DBIx::Class::ResultSource/result_class> classes for all registered ResultSource instances
+
+=item * All L<ResultSet|DBIx::Class::ResultSource/resultset_class> classes for all registered ResultSource instances
+
+=back
+
+=cut
+
+sub all_schema_related_classes {
+ my ($self, $schema) = @_;
+
+ sort( uniq( map {
+ ( not defined $_ ) ? ()
+ : ( defined blessed $_ ) ? ref $_
+ : $_
+ } (
+ $schema,
+ $schema->storage,
+ ( map {
+ $_,
+ $_->result_class,
+ $_->resultset_class,
+ } map { $schema->source($_) } $schema->sources ),
+ )));
+}
+
+
+sub format_no_indirect_method_overrides_errors {
+ # my ($self, $errors) = @_;
+
+ [ map { sprintf(
+ "Method(s) %s override the convenience shortcut %s::%s(): "
+ . 'it is almost certain these overrides *MAY BE COMPLETELY IGNORED* at '
+ . 'runtime. You MUST reimplement each override to hook a method from the '
+ . "chain of calls within the convenience shortcut as seen when running:\n "
+ . '~$ perl -M%2$s -MDevel::Dwarn -e "Ddie { %3$s => %2$s->can(q(%3$s)) }"',
+ join (', ', map { "$_()" } sort @{ $_->{by} } ),
+ $_->{overriden}{via_class},
+ $_->{overriden}{name},
+ )} @{ $_[1] } ]
+}
+
+sub check_no_indirect_method_overrides {
+ my ($self, $schema) = @_;
+
+ my( @err, $seen_shadowing_configurations );
+
+ METHOD_STACK:
+ for my $method_stack ( map {
+ values %{ describe_class_methods($_)->{methods_with_supers} || {} }
+ } $self->all_schema_related_classes($schema) ) {
+
+ my $nonsugar_methods;
+
+ for (@$method_stack) {
+
+ push @$nonsugar_methods, $_ and next
+ unless $_->{attributes}{DBIC_method_is_indirect_sugar};
+
+ push @err, {
+ overriden => {
+ name => $_->{name},
+ via_class => (
+ # this way we report a much better Dwarn oneliner in the error
+ $_->{attributes}{DBIC_method_is_bypassable_resultsource_proxy}
+ ? 'DBIx::Class::ResultSource'
+ : $_->{via_class}
+ ),
+ },
+ by => [ map { "$_->{via_class}::$_->{name}" } @$nonsugar_methods ],
+ } if (
+ $nonsugar_methods
+ and
+ ! $seen_shadowing_configurations->{
+ join "\0",
+ map
+ { refaddr $_ }
+ (
+ $_,
+ @$nonsugar_methods,
+ )
+ }++
+ )
+ ;
+
+ next METHOD_STACK;
+ }
+ }
+
+ \@err
+}
+
+
+sub format_valid_c3_composition_errors {
+ # my ($self, $errors) = @_;
+
+ [ map { sprintf(
+ "Class '%s' %s using the '%s' MRO affecting the lookup order of the "
+ . "following method(s): %s. You MUST add the following line to '%1\$s' "
+ . "right after strict/warnings:\n use mro 'c3';",
+ $_->{class},
+ ( ($_->{initial_mro} eq $_->{current_mro}) ? 'is' : 'was originally' ),
+ $_->{initial_mro},
+ join (', ', map { "$_()" } sort keys %{$_->{affected_methods}} ),
+ )} @{ $_[1] } ]
+}
+
+
+my $base_ISA = {
+ map { $_ => 1 } @{mro::get_linear_isa("DBIx::Class")}
+};
+
+sub check_valid_c3_composition {
+ my ($self, $schema) = @_;
+
+ my @err;
+
+ #
+ # A *very* involved check, to absolutely minimize false positives
+ # If this check returns an issue - it *better be* a real one
+ #
+ for my $class ( $self->all_schema_related_classes($schema) ) {
+
+ my $desc = do {
+ no strict 'refs';
+ describe_class_methods({
+ class => $class,
+ ( ${"${class}::__INITIAL_MRO_UPON_DBIC_LOAD__"}
+ ? ( use_mro => ${"${class}::__INITIAL_MRO_UPON_DBIC_LOAD__"} )
+ : ()
+ ),
+ })
+ };
+
+ # is there anything to check?
+ next unless (
+ ! $desc->{mro}{is_c3}
+ and
+ $desc->{methods_with_supers}
+ and
+ my @potentially_problematic_method_stacks =
+ grep
+ {
+ # at least 2 variants came via inheritance (not ours)
+ (
+ (grep { $_->{via_class} ne $class } @$_)
+ >
+ 1
+ )
+ and
+ #
+ # last ditch effort to skip examining an alternative mro
+ # IFF the entire "foreign" stack is located in the "base isa"
+ #
+ # This allows for extra efficiency (as there are several
+ # with_supers methods that would always be there), but more
+ # importantly saves one from tripping on the nonsensical yet
+ # begrudgingly functional (as in - no adverse effects):
+ #
+ # use base 'DBIx::Class';
+ # use base 'DBIx::Class::Schema';
+ #
+ (
+ grep {
+ # not ours
+ $_->{via_class} ne $class
+ and
+ # not from the base stack either
+ ! $base_ISA->{$_->{via_class}}
+ } @$_
+ )
+ }
+ values %{ $desc->{methods_with_supers} }
+ );
+
+ my $affected_methods;
+
+ for my $stack (@potentially_problematic_method_stacks) {
+
+ # If we got so far - we need to see what the class would look
+ # like under c3 and compare, sigh
+ #
+ # Note that if the hierarchy is *really* fucked (like the above
+ # double-base e.g.) then recalc under 'c3' WILL FAIL, hence the
+ # extra eval: if we fail we report things as "jumbled up"
+ #
+ $affected_methods->{$stack->[0]{name}} = [
+ map { $_->{via_class} } @$stack
+ ] unless dbic_internal_try {
+
+ serialize($stack)
+ eq
+ serialize(
+ describe_class_methods({ class => $class, use_mro => 'c3' })
+ ->{methods}
+ ->{$stack->[0]{name}}
+ )
+ };
+ }
+
+ push @err, {
+ class => $class,
+ isa => $desc->{isa},
+ initial_mro => $desc->{mro}{type},
+ current_mro => mro::get_mro($class),
+ affected_methods => $affected_methods,
+ } if $affected_methods;
+ }
+
+ \@err;
+}
+
+
+sub format_no_inheritance_crosscontamination_errors {
+ # my ($self, $errors) = @_;
+
+ [ map { sprintf(
+ "Class '%s' registered in the role of '%s' unexpectedly inherits '%s': "
+ . 'you must resolve this by either removing an erroneous `use base` call '
+ . "or switching to Moo(se)-style delegation (i.e. the 'handles' keyword)",
+ $_->{class},
+ $_->{type},
+ $_->{unexpectedly_inherits},
+ )} @{ $_[1] } ]
+}
+
+sub check_no_inheritance_crosscontamination {
+ my ($self, $schema) = @_;
+
+ my @err;
+
+ my $to_check = {
+ Schema => [ $schema ],
+ Storage => [ $schema->storage ],
+ ResultSource => [ map { $schema->source($_) } $schema->sources ],
+ };
+
+ $to_check->{ResultSet} = [
+ map { $_->resultset_class } @{$to_check->{ResultSource}}
+ ];
+
+ $to_check->{Core} = [
+ map { $_->result_class } @{$to_check->{ResultSource}}
+ ];
+
+ # Reduce everything to a unique sorted list of class names
+ $_ = [ sort( uniq( map {
+ ( not defined $_ ) ? ()
+ : ( defined blessed $_ ) ? ref $_
+ : $_
+ } @$_ ) ) ] for values %$to_check;
+
+ for my $group ( sort keys %$to_check ) {
+ for my $class ( @{ $to_check->{$group} } ) {
+ for my $foreign_base (
+ map { "DBIx::Class::$_" } sort grep { $_ ne $group } keys %$to_check
+ ) {
+
+ push @err, {
+ class => $class,
+ type => ( $group eq 'Core' ? 'ResultClass' : $group ),
+ unexpectedly_inherits => $foreign_base
+ } if $class->isa($foreign_base);
+ }
+ }
+ }
+
+ \@err;
+}
+
+1;
+
+__END__
+
+=head1 FURTHER QUESTIONS?
+
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
use strict;
use warnings;
+# no point sanity checking, unless we are running asserts
+__PACKAGE__->schema_sanity_checker(
+ DBIx::Class::_ENV_::ASSERT_NO_FAILING_SANITY_CHECKS
+ ? 'DBIx::Class::Schema::SanityChecker'
+ : ''
+);
+
__PACKAGE__->register_class('Table', 'DBIx::Class::Version::Table');
package # Hide from PAUSE
use strict;
use warnings;
+# no point sanity checking, unless we are running asserts
+__PACKAGE__->schema_sanity_checker(
+ DBIx::Class::_ENV_::ASSERT_NO_FAILING_SANITY_CHECKS
+ ? 'DBIx::Class::Schema::SanityChecker'
+ : ''
+);
+
__PACKAGE__->register_class('TableCompat', 'DBIx::Class::Version::TableCompat');
__PACKAGE__->cursor_class('DBIx::Class::Cursor');
-sub cursor {
+sub cursor :DBIC_method_is_indirect_sugar {
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
shift->cursor_class(@_);
}
if ($driver) {
my $storage_class = "DBIx::Class::Storage::DBI::${driver}";
if ($self->load_optional_class($storage_class)) {
- mro::set_mro($storage_class, 'c3');
+
+ no strict 'refs';
+ mro::set_mro($storage_class, 'c3') if
+ (
+ ${"${storage_class}::__INITIAL_MRO_UPON_DBIC_LOAD__"}
+ ||= mro::get_mro($storage_class)
+ )
+ ne
+ 'c3'
+ ;
+
bless $self, $storage_class;
$self->_rebless();
}
sub _dbh_last_insert_id {
my ($self, $dbh, $source, @columns) = @_;
my @ids = ();
+ my $ci = $source->columns_info(\@columns);
foreach my $col (@columns) {
- my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
+ my $seq = ( $ci->{$col}{sequence} ||= $self->get_autoinc_seq($source,$col));
my $id = $self->_sequence_fetch( 'CURRVAL', $seq );
push @ids, $id;
}
sub _is_lob_column {
my ($self, $source, $column) = @_;
- return $self->_is_lob_type($source->column_info($column)->{data_type});
+ return $self->_is_lob_type(
+ $source->columns_info([$column])->{$column}{data_type}
+ );
}
sub _prep_for_execute {
# try to insert explicit 'DEFAULT's instead (except for identity, timestamp
# and computed columns)
if (not %$to_insert) {
+
+ my $ci;
+ # same order as add_columns
for my $col ($source->columns) {
next if $col eq $identity_col;
- my $info = $source->column_info($col);
-
- next if ref $info->{default_value} eq 'SCALAR'
- || (exists $info->{data_type} && (not defined $info->{data_type}));
-
- next if $info->{data_type} && $info->{data_type} =~ /^timestamp\z/i;
+ my $info = ( $ci ||= $source->columns_info )->{$col};
+
+ next if (
+ ref $info->{default_value} eq 'SCALAR'
+ or
+ (
+ exists $info->{data_type}
+ and
+ ! defined $info->{data_type}
+ )
+ or
+ (
+ ( $info->{data_type} || '' )
+ =~ /^timestamp\z/i
+ )
+ );
$to_insert->{$col} = \'DEFAULT';
}
if (@_) {
foreach my $col (@_) {
$self->throw_exception("column $col doesn't exist")
- unless $self->result_source_instance->has_column($col);
+ unless $self->result_source->has_column($col);
}
return $self->_utf8_columns({ map { $_ => 1 } @_ });
} else {
DBIC_SHUFFLE_UNORDERED_RESULTSETS
DBIC_ASSERT_NO_INTERNAL_WANTARRAY
DBIC_ASSERT_NO_INTERNAL_INDIRECT_CALLS
+ DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE
+ DBIC_ASSERT_NO_FAILING_SANITY_CHECKS
DBIC_STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE
DBIC_STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE
)
exit 70;
}
- my $msg = "\n$0: $args->{msg}";
+ my $msg = "\n" . join( ': ',
+ ( $0 eq '-e' ? () : $0 ),
+ $args->{msg}
+ );
# when we die - we usually want to keep doing it
$args->{emit_dups} = !!$args->{confess}
{
package DB;
$fr = [ CORE::caller(1) ];
- $argdesc = ref $DB::args[0]
- ? DBIx::Class::_Util::refdesc($DB::args[0])
- : ( $DB::args[0] . '' )
+ $argdesc =
+ ( not defined $DB::args[0] ) ? 'UNAVAILABLE'
+ : ( length ref $DB::args[0] ) ? DBIx::Class::_Util::refdesc($DB::args[0])
+ : $DB::args[0] . ''
;
};
: $fr
;
+
+ die "\nMethod $fr->[3] is not marked with the 'DBIC_method_is_indirect_sugar' attribute\n\n" unless (
+
+ # unlikely but who knows...
+ ! @$fr
+
+ or
+
+ # This is a weird-ass double-purpose method, only one branch of which is marked
+ # as an illegal indirect call
+ # Hence the 'indirect' attribute makes no sense
+ # FIXME - likely need to mark this in some other manner
+ $fr->[3] eq 'DBIx::Class::ResultSet::new'
+
+ or
+
+ # RsrcProxy stuff is special and not attr-annotated on purpose
+ # Yet it is marked (correctly) as fail_on_internal_call(), as DBIC
+ # itself should not call these methods as first-entry
+ $fr->[3] =~ /^DBIx::Class::ResultSourceProxy::[^:]+$/
+
+ or
+
+ # FIXME - there is likely a more fine-graned way to escape "foreign"
+ # callers, based on annotations... (albeit a slower one)
+ # For the time being just skip in a dumb way
+ $fr->[3] !~ /^DBIx::Class|^DBICx::|^DBICTest::/
+
+ or
+
+ grep
+ { $_ eq 'DBIC_method_is_indirect_sugar' }
+ do { no strict 'refs'; attributes::get( \&{ $fr->[3] }) }
+ );
+
+
if (
- $argdesc
+ defined $fr->[0]
and
$check_fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
and
}
}
+if (DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE) {
+
+ no warnings 'redefine';
+
+ my $next_bless = defined(&CORE::GLOBAL::bless)
+ ? \&CORE::GLOBAL::bless
+ : sub { CORE::bless($_[0], $_[1]) }
+ ;
+
+ *CORE::GLOBAL::bless = sub {
+ my $class = (@_ > 1) ? $_[1] : CORE::caller();
+
+ # allow for reblessing (role application)
+ return $next_bless->( $_[0], $class )
+ if defined blessed $_[0];
+
+ my $obj = $next_bless->( $_[0], $class );
+
+ my $calling_sub = (CORE::caller(1))[3] || '';
+
+ (
+ # before 5.18 ->isa() will choke on the "0" package
+ # which we test for in several obscure cases, sigh...
+ !( DBIx::Class::_ENV_::PERL_VERSION < 5.018 )
+ or
+ $class
+ )
+ and
+ (
+ (
+ $calling_sub !~ /^ (?:
+ DBIx::Class::Schema::clone
+ |
+ DBIx::Class::DB::setup_schema_instance
+ )/x
+ and
+ $class->isa("DBIx::Class::Schema")
+ )
+ or
+ (
+ $calling_sub ne 'DBIx::Class::ResultSource::new'
+ and
+ $class->isa("DBIx::Class::ResultSource")
+ )
+ )
+ and
+ local $Carp::CarpLevel = $Carp::CarpLevel + 1
+ and
+ Carp::confess("Improper instantiation of '$obj': you *MUST* call the corresponding constructor");
+
+
+ $obj;
+ };
+}
+
1;
name => $table_name,
type => 'TABLE',
);
+
+ my $ci = $source->columns_info;
+
+ # same order as add_columns
foreach my $col ($source->columns)
{
# assuming column_info in dbic is the same as DBI (?)
is_auto_increment => 0,
is_foreign_key => 0,
is_nullable => 0,
- %{$source->column_info($col)}
+ %{$ci->{$col} || {}}
);
if ($colinfo{is_nullable}) {
$colinfo{default} = '' unless exists $colinfo{default};
return !!$_[0];
}
-
# this is incredibly horrible...
# demonstrate utter breakage of the reconnection/retry logic
#
: (0)
) {
- no warnings qw/once redefine/;
+ # doing it here instead of the actual class to keep the main thing under dfs
+ # and thus keep catching false positives (so far none, but one never knows)
+ mro::set_mro("DBICTest::Schema", "c3");
+
my $old_connection = DBICTest::Schema->can('connection');
+
+ no warnings qw/once redefine/;
local *DBICTest::Schema::connection = set_subname 'DBICTest::Schema::connection' => sub {
my $s = shift->$old_connection(@_);
$s->storage->_use_insert_returning ($use_insert_returning);
for my $use_insert_returning ($test_server_supports_insert_returning ? (1,0) : (0) ) {
for my $force_ora_joins ($test_server_supports_only_orajoins ? (0) : (0,1) ) {
- no warnings qw/once redefine/;
+ # doing it here instead of the actual class to keep the main thing under dfs
+ # and thus keep catching false positives (so far none, but one never knows)
+ mro::set_mro("DBICTest::Schema", "c3");
+
my $old_connection = DBICTest::Schema->can('connection');
+
+ no warnings qw/once redefine/;
local *DBICTest::Schema::connection = set_subname 'DBICTest::Schema::connection' => sub {
my $s = shift->$old_connection (@_);
$s->storage->_use_insert_returning ($use_insert_returning);
{ "foreign.id" => "self.link" },
);
}
- qr{"might_have/has_one" must not be on columns with is_nullable set to true},
+ qr{'might_have'/'has_one' must not be used on columns with is_nullable set to true},
'might_have should warn if the self.id column is nullable';
{
{
package DBICTest::PartialSchema;
- use base qw/DBIx::Class::Schema/;
+ use base qw/DBICTest::BaseSchema/;
__PACKAGE__->load_classes(
{ 'DBICTest::Schema' => [qw/
package Music::DBI;
use base qw(DBIx::Class::CDBICompat);
use Class::DBI::Plugin::DeepAbstractSearch;
+
+BEGIN {
+ # offset the warning from DBIx::Class::Schema on 5.8
+ # keep the ::Schema default as-is otherwise
+ DBIx::Class::_ENV_::OLD_MRO
+ and
+ ( eval <<'EOS' or die $@ );
+
+ sub setup_schema_instance {
+ my $s = shift->next::method(@_);
+ $s->schema_sanity_checker('');
+ $s;
+ }
+
+ 1;
+EOS
+}
+
__PACKAGE__->connection(@DSN);
my $sql = <<'SQL_END';
use base qw/DBIx::Class/;
+BEGIN {
+ # offset the warning from DBIx::Class::Schema on 5.8
+ # keep the ::Schema default as-is otherwise
+ DBIx::Class::_ENV_::OLD_MRO
+ and
+ ( eval <<'EOS' or die $@ );
+
+ sub setup_schema_instance {
+ my $s = shift->next::method(@_);
+ $s->schema_sanity_checker('');
+ $s;
+ }
+
+ 1;
+EOS
+}
+
__PACKAGE__->load_components(qw/CDBICompat Core DB/);
my $DB = DBICTest->_sqlite_dbfilename;
use DBI;
use DBICTest;
+BEGIN {
+ # offset the warning from DBIx::Class::Schema on 5.8
+ # keep the ::Schema default as-is otherwise
+ DBIx::Class::_ENV_::OLD_MRO
+ and
+ ( eval <<'EOS' or die $@ );
+
+ sub setup_schema_instance {
+ my $s = shift->next::method(@_);
+ $s->schema_sanity_checker('');
+ $s;
+ }
+
+ 1;
+EOS
+}
+
use base qw(DBIx::Class::CDBICompat);
my @connect = (@ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/}, { PrintError => 0});
dbg DEBUG_TEST_CONCURRENCY_LOCKS PEEPEENESS
);
use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/;
+
+# The actual ASSERT logic is in BaseSchema for pesky load-order reasons
+# Hence run this through once, *before* DBICTest::Schema and friends load
+BEGIN {
+ if (
+ DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE
+ or
+ DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
+ ) {
+ require DBIx::Class::Row;
+ require DBICTest::BaseSchema;
+ DBICTest::BaseSchema->connect( sub {} );
+ }
+}
+
use DBICTest::Schema;
use DBIx::Class::_Util qw( detected_reinvoked_destructor scope_guard modver_gt_or_eq );
use Carp;
my $clan_connect_caller = '*UNKNOWN*';
my $i;
- while ( my ($pack, $file, $line) = caller(++$i) ) {
+ while ( my ($pack, $file, $line) = CORE::caller(++$i) ) {
next if $file eq __FILE__;
next if $pack =~ /^DBIx::Class|^Try::Tiny/;
$clan_connect_caller = "$file line $line";
use Fcntl qw(:DEFAULT :seek :flock);
use IO::Handle ();
-use DBIx::Class::_Util 'scope_guard';
+use DBIx::Class::_Util qw( emit_loud_diag scope_guard set_subname get_subname );
use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry);
use DBICTest::Util qw( local_umask tmpdir await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS );
+use Scalar::Util qw( refaddr weaken );
+use Devel::GlobalDestruction ();
use namespace::clean;
+# Unless we are running assertions there is no value in checking ourselves
+# during regular tests - the CI will do it for us
+#
+if (
+ DBIx::Class::_ENV_::ASSERT_NO_FAILING_SANITY_CHECKS
+ and
+ # full-blown 5.8 sanity-checking is waaaaaay too slow, even for CI
+ (
+ ! DBIx::Class::_ENV_::OLD_MRO
+ or
+ # still run a couple test with this, even on 5.8
+ $ENV{DBICTEST_OLD_MRO_SANITY_CHECK_ASSERTIONS}
+ )
+) {
+
+ __PACKAGE__->schema_sanity_checker('DBIx::Class::Schema::SanityChecker');
+
+ # Repeat the check on going out of scope (will catch weird runtime tinkering)
+ # Add only in case we will be using it, as it slows tests down
+ eval <<'EOD' or die $@;
+
+ sub DESTROY {
+ if (
+ ! Devel::GlobalDestruction::in_global_destruction()
+ and
+ my $checker = $_[0]->schema_sanity_checker
+ ) {
+ $checker->perform_schema_sanity_checks($_[0]);
+ }
+
+ # *NOT* using next::method here - it (currently) will confuse Class::C3
+ # in some obscure cases ( 5.8 naturally )
+ shift->SUPER::DESTROY();
+ }
+
+ 1;
+
+EOD
+
+}
+else {
+ # otherwise just unset the default
+ __PACKAGE__->schema_sanity_checker('');
+}
+
+
if( $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} ) {
my $ea = __PACKAGE__->exception_action( sub {
}
}
-my $weak_registry = {};
+my ( $weak_registry, $assertion_arounds ) = ( {}, {} );
+
+sub DBICTest::__RsrcRedefiner_iThreads_handler__::CLONE {
+ if( DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE ) {
+ %$assertion_arounds = map {
+ (defined $_)
+ ? ( refaddr($_) => $_ )
+ : ()
+ } values %$assertion_arounds;
+
+ weaken($_) for values %$assertion_arounds;
+ }
+}
sub connection {
my $self = shift->next::method(@_);
]);
}
+ #
+ # Check an explicit level of indirection: makes sure that folks doing
+ # use `base "DBIx::Class::Core"; __PACKAGE__->add_column("foo")`
+ # will see the correct error message
+ #
+ # In the future this all is likely to be folded into a single method in
+ # some way, but that's a fight for another maint
+ #
+ if( DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE ) {
+
+ for my $class_of_interest (
+ 'DBIx::Class::Row',
+ map { $self->class($_) } ($self->sources)
+ ) {
+
+ my $orig_rsrc = $class_of_interest->can('result_source')
+ or die "How did we get here?!";
+
+ unless ( $assertion_arounds->{refaddr $orig_rsrc} ) {
+
+ my ($origin) = get_subname($orig_rsrc);
+
+ no warnings 'redefine';
+ no strict 'refs';
+
+ *{"${origin}::result_source"} = my $replacement = set_subname "${origin}::result_source" => sub {
+
+
+ @_ > 1
+ and
+ (CORE::caller(0))[1] !~ / (?: ^ | [\/\\] ) x?t [\/\\] .+? \.t $ /x
+ and
+ emit_loud_diag(
+ msg => 'Incorrect indirect call of result_source() as setter must be changed to result_source_instance()',
+ confess => 1,
+ );
+
+
+ grep {
+ ! (CORE::caller($_))[7]
+ and
+ ( (CORE::caller($_))[3] || '' ) eq '(eval)'
+ and
+ ( (CORE::caller($_))[1] || '' ) !~ / (?: ^ | [\/\\] ) x?t [\/\\] .+? \.t $ /x
+ } (0..2)
+ and
+ # these evals are legit
+ ( (CORE::caller(4))[3] || '' ) !~ /^ (?:
+ DBIx::Class::Schema::_ns_get_rsrc_instance
+ |
+ DBIx::Class::Relationship::BelongsTo::belongs_to
+ |
+ DBIx::Class::Relationship::HasOne::_has_one
+ |
+ Class::C3::Componentised::.+
+ ) $/x
+ and
+ emit_loud_diag(
+ # not much else we can do (aside from exit(1) which is too obnoxious)
+ msg => 'Incorrect call of result_source() in an eval',
+ );
+
+
+ &$orig_rsrc;
+ };
+
+ weaken( $assertion_arounds->{refaddr $replacement} = $replacement );
+
+ attributes->import(
+ $origin,
+ $replacement,
+ attributes::get($orig_rsrc)
+ );
+ }
+
+
+ # no rsrc_instance to mangle
+ next if $class_of_interest eq 'DBIx::Class::Row';
+
+
+ my $orig_rsrc_instance = $class_of_interest->can('result_source_instance')
+ or die "How did we get here?!";
+
+ # Do the around() per definition-site as result_source_instance is a CAG inherited cref
+ unless ( $assertion_arounds->{refaddr $orig_rsrc_instance} ) {
+
+ my ($origin) = get_subname($orig_rsrc_instance);
+
+ no warnings 'redefine';
+ no strict 'refs';
+
+ *{"${origin}::result_source_instance"} = my $replacement = set_subname "${origin}::result_source_instance" => sub {
+
+
+ @_ == 1
+ and
+ # special cased as we do not care whether there is a source
+ ( (CORE::caller(4))[3] || '' ) ne 'DBIx::Class::Schema::_register_source'
+ and
+ # special case because I am paranoid
+ ( (CORE::caller(4))[3] || '' ) ne 'DBIx::Class::Row::throw_exception'
+ and
+ ( (CORE::caller(1))[3] || '' ) !~ / ^ DBIx::Class:: (?:
+ Row::result_source
+ |
+ Row::throw_exception
+ |
+ ResultSourceProxy::Table:: (?: _init_result_source_instance | table )
+ |
+ ResultSourceHandle::STORABLE_thaw
+ ) $ /x
+ and
+ (CORE::caller(0))[1] !~ / (?: ^ | [\/\\] ) x?t [\/\\] .+? \.t $ /x
+ and
+ emit_loud_diag(
+ msg => 'Incorrect direct call of result_source_instance() as getter must be changed to result_source()',
+ confess => 1
+ );
+
+
+ grep {
+ ! (CORE::caller($_))[7]
+ and
+ ( (CORE::caller($_))[3] || '' ) eq '(eval)'
+ and
+ ( (CORE::caller($_))[1] || '' ) !~ / (?: ^ | [\/\\] ) x?t [\/\\] .+? \.t $ /x
+ } (0..2)
+ and
+ # special cased as we do not care whether there is a source
+ ( (CORE::caller(4))[3] || '' ) ne 'DBIx::Class::Schema::_register_source'
+ and
+ # special case because I am paranoid
+ ( (CORE::caller(4))[3] || '' ) ne 'DBIx::Class::Row::throw_exception'
+ and
+ # special case for Storable, which in turn calls from an eval
+ ( (CORE::caller(1))[3] || '' ) ne 'DBIx::Class::ResultSourceHandle::STORABLE_thaw'
+ and
+ emit_loud_diag(
+ # not much else we can do (aside from exit(1) which is too obnoxious)
+ msg => 'Incorrect call of result_source_instance() in an eval',
+ skip_frames => 1,
+ show_dups => 1,
+ );
+
+ &$orig_rsrc_instance;
+ };
+
+ weaken( $assertion_arounds->{refaddr $replacement} = $replacement );
+
+ attributes->import(
+ $origin,
+ $replacement,
+ attributes::get($orig_rsrc_instance)
+ );
+ }
+ }
+
+ Class::C3::initialize if DBIx::Class::_ENV_::OLD_MRO;
+ }
+ #
+ # END Check an explicit level of indirection
+
return $self;
}
use base qw/DBICTest::Schema::CD/;
+# FIXME not entirely sure *why* this particular bit trips up tests
+# and even more mysteriously: only a single oracle test...
+# Running out of time and no local Oracle so can't investigate :/
+use mro 'c3';
+
__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
__PACKAGE__->table('year2000cds');
use base 'DBICTest::BaseSchema';
-sub connect { exit 70 } # this is what the test will expect to see
+sub connection { exit 70 } # this is what the test will expect to see
1;
use base 'DBICTest::BaseSchema';
-sub connect {
+sub connection {
my($self, @opt) = @_;
@opt == 4
and $opt[0] eq 'klaatu'
--- /dev/null
+BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
+
+use strict;
+use warnings;
+
+use Test::More;
+
+use DBICTest;
+
+my $ar = DBICTest->init_schema->resultset("Artist")->find(1);
+
+ok (! $ar->can("not_yet_there_column"), "No accessor for nonexitentcolumn" );
+
+$ar->add_column("not_yet_there_column");
+ok ($ar->has_column("not_yet_there_column"), "Metadata correct after nonexitentcolumn addition" );
+ok ($ar->can("not_yet_there_column"), "Accessor generated for nonexitentcolumn" );
+
+$ar->not_yet_there_column('I EXIST \o/');
+
+is { $ar->get_columns }->{not_yet_there_column}, 'I EXIST \o/', "Metadata propagates to mutli-column methods";
+
+done_testing;
--- /dev/null
+BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
+
+BEGIN { $ENV{DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE} = 0 }
+
+use strict;
+use warnings;
+no warnings 'qw';
+
+use Test::More;
+
+use DBICTest;
+
+my $schema = DBICTest->init_schema;
+my $rsrc = $schema->source("Artist");
+
+is( (eval($_)||die $@), $rsrc, "Same source object after $_" ) for qw(
+ $rsrc->resultset->result_source,
+ $rsrc->resultset->next->result_source,
+ $rsrc->resultset->next->result_source_instance,
+ $schema->resultset("Artist")->result_source,
+ $schema->resultset("Artist")->next->result_source,
+ $schema->resultset("Artist")->next->result_source_instance,
+);
+
+done_testing;
--- /dev/null
+BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
+
+$ENV{DBIC_ASSERT_NO_FAILING_SANITY_CHECKS} = 1;
+
+use strict;
+use warnings;
+
+use Test::More;
+
+use DBICTest;
+use Sub::Quote 'quote_sub';
+
+my $colinfo = DBICTest::Schema::Artist->result_source->column_info('artistid');
+
+my $schema = DBICTest->init_schema ( no_deploy => 1 );
+my $rsrc = $schema->source("Artist");
+
+for my $overrides_marked_mandatory (0, 1) {
+ my $call_count;
+ my @methods_to_override = qw(
+ add_columns columns_info
+ );
+
+ my $attr = { attributes => [
+ $overrides_marked_mandatory
+ ? 'DBIC_method_is_mandatory_resultsource_proxy'
+ : 'DBIC_method_is_bypassable_resultsource_proxy'
+ ] };
+
+ for (@methods_to_override) {
+ $call_count->{$_} = 0;
+
+ quote_sub( "DBICTest::Schema::Artist::$_", <<'EOC', { '$cnt' => \\($call_count->{$_}) }, $attr );
+ $$cnt++;
+ shift->next::method(@_);
+EOC
+ }
+
+ Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
+
+ is_deeply
+ $rsrc->columns_info->{artistid},
+ $colinfo,
+ 'Expected result from rsrc getter',
+ ;
+
+ $rsrc->add_columns("bar");
+
+ is_deeply
+ $call_count,
+ {
+ add_columns => ($overrides_marked_mandatory ? 1 : 0),
+
+ # ResultSourceProxy::add_columns will call colinfos as well
+ columns_info => ($overrides_marked_mandatory ? 2 : 0),
+ },
+ 'expected rsrc proxy override callcounts',
+ ;
+}
+
+done_testing;
+# Test is sufficiently involved to *want* to run with "maximum paranoia"
+BEGIN { $ENV{DBICTEST_OLD_MRO_SANITY_CHECK_ASSERTIONS} = 1 }
+
BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
use strict;
+# Test is sufficiently involved to *want* to run with "maximum paranoia"
+BEGIN { $ENV{DBICTEST_OLD_MRO_SANITY_CHECK_ASSERTIONS} = 1 }
+
BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
use strict;
BEGIN {
+ delete $ENV{DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE};
+
plan skip_all =>
'Skipping RH perl performance bug tests as DBIC_NO_WARN_BAD_PERL set'
if ( $ENV{DBIC_NO_WARN_BAD_PERL} );
use Module::Runtime 'require_module';
use lib 'maint/.Generated_Pod/lib';
use DBICTest;
+use DBIx::Class::Schema::SanityChecker;
use namespace::clean;
# this has already been required but leave it here for CPANTS static analysis
resolve_prefetch
STORABLE_freeze
STORABLE_thaw
+ get_rsrc_instance_specific_attribute
+ set_rsrc_instance_specific_attribute
+ get_rsrc_instance_specific_handler
+ set_rsrc_instance_specific_handler
/],
},
'DBIx::Class::ResultSet' => {
connection
/]
},
+ 'DBIx::Class::Schema::SanityChecker' => {
+ ignore => [ map {
+ qr/^ (?: check_${_} | format_${_}_errors ) $/x
+ } @{ DBIx::Class::Schema::SanityChecker->available_checks } ]
+ },
'DBIx::Class::Admin' => {
ignore => [ qw/
# build parms up from ignore list
my $parms = {};
- $parms->{trustme} =
- [ map { qr/^$_$/ } @{ $ex->{ignore} } ]
- if exists($ex->{ignore});
+ $parms->{trustme} = [ map
+ { ref $_ eq 'Regexp' ? $_ : qr/^\Q$_\E$/ }
+ @{ $ex->{ignore} }
+ ] if exists($ex->{ignore});
# run the test with the potentially modified parm set
Test::Pod::Coverage::pod_coverage_ok($module, $parms, "$module POD coverage");
use Test::More;
use DBICTest;
use DBIx::Class::Optional::Dependencies;
+use DBIx::Class::_Util 'uniq';
my @global_ISA_tail = qw(
DBIx::Class
Class::Accessor::Grouped
);
-is(
- mro::get_mro($_),
- 'c3',
- "Correct mro on base class '$_'",
-) for grep { $_ =~ /^DBIx::Class/ } @global_ISA_tail;
-
{
package AAA;
use base "DBIx::Class::Core";
+ use mro 'c3';
}
{
my $art = DBICTest->init_schema->resultset("Artist")->next;
-check_ancestry($_) for (
- ref( $art ),
- ref( $art->result_source ),
- ref( $art->result_source->resultset ),
- ref( $art->result_source->schema ),
- ( map
- { ref $art->result_source->schema->source($_) }
- $art->result_source->schema->sources
- ),
- qw( AAA BBB CCC ),
- ((! DBIx::Class::Optional::Dependencies->req_ok_for('cdbicompat') ) ? () : do {
- unshift @INC, 't/cdbi/testlib';
- map { eval "require $_" or die $@; $_ } qw(
- Film Lazy Actor ActorAlias ImplicitInflate
- );
- }),
-);
+check_ancestry($_) for uniq map
+ { length ref $_ ? ref $_ : $_ }
+ (
+ $art,
+ $art->result_source,
+ $art->result_source->resultset,
+ ( map
+ { $_, $_->result_class, $_->resultset_class }
+ map
+ { $art->result_source->schema->source($_) }
+ $art->result_source->schema->sources
+ ),
+ qw( AAA BBB CCC ),
+ ((! DBIx::Class::Optional::Dependencies->req_ok_for('cdbicompat') ) ? () : do {
+ unshift @INC, 't/cdbi/testlib';
+ map { eval "require $_" or die $@; $_ } qw(
+ Film Lazy Actor ActorAlias ImplicitInflate
+ );
+ }),
+ )
+;
use DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server;
"Correct end of \@ISA for '$class'"
);
- # check the remainder
- for my $c (@linear_ISA) {
- # nothing to see there
- next if $c =~ /^DBICTest::/;
-
- next if mro::get_mro($c) eq 'c3';
-
- fail( "Incorrect mro '@{[ mro::get_mro($c) ]}' on '$c' (parent of '$class')" );
- }
+ is(
+ mro::get_mro($class),
+ 'c3',
+ "Expected mro on class '$class' automatically set",
+ );
}
done_testing;
--- /dev/null
+BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
+
+# things will die if this is set
+BEGIN { $ENV{DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE} = 0 }
+
+use strict;
+use warnings;
+
+use Test::More;
+
+use DBICTest::Util 'capture_stderr';
+use DBICTest;
+
+my ($fn) = __FILE__ =~ /( [^\/\\]+ ) $/x;
+my @divergence_lines;
+
+my $art = DBICTest->init_schema->resultset("Artist")->find(1);
+
+push @divergence_lines, __LINE__ + 1;
+DBICTest::Schema::Artist->add_columns("Something_New");
+
+push @divergence_lines, __LINE__ + 1;
+$_->add_column("Something_New_2") for grep
+ { $_ != $art->result_source }
+ DBICTest::Schema::Artist->result_source_instance->__derived_instances
+;
+
+push @divergence_lines, __LINE__ + 1;
+DBICTest::Schema::Artist->result_source_instance->name("foo");
+
+my $orig_class_rsrc_before_table_triggered_reinit = DBICTest::Schema::Artist->result_source_instance;
+
+push @divergence_lines, __LINE__ + 1;
+DBICTest::Schema::Artist->table("bar");
+
+is(
+ capture_stderr {
+ ok(
+ DBICTest::Schema::Artist->has_column( "Something_New" ),
+ 'Added column visible'
+ );
+
+ ok(
+ (! DBICTest::Schema::Artist->has_column( "Something_New_2" ) ),
+ 'Column added on children not visible'
+ );
+ },
+ '',
+ 'No StdErr output during rsrc augmentation'
+);
+
+my $err = capture_stderr {
+ ok(
+ ! $art->has_column($_),
+ "Column '$_' not visible on @{[ $art->table ]}"
+ ) for qw(Something_New Something_New_2);
+};
+
+# Tricky text - check it painstakingly as things may go off
+# in very subtle ways
+my $expected_warning_1 = join '.+?', map { quotemeta $_ }
+ "@{[ $art->result_source ]} (the metadata instance of source 'Artist') is *OUTDATED*",
+
+ "${orig_class_rsrc_before_table_triggered_reinit}->add_columns(...) at",
+ "$fn line $divergence_lines[0]",
+
+ "@{[ DBICTest::Schema->source('Artist') ]}->add_column(...) at",
+ "$fn line $divergence_lines[1]",
+
+ "Stale metadata accessed by 'getter' @{[ $art->result_source ]}->has_column(...)",
+;
+
+like
+ $err,
+ qr/$expected_warning_1/s,
+ 'Correct warning on diverged metadata'
+;
+
+my $expected_warning_2 = join '.+?', map { quotemeta $_ }
+ "@{[ $art->result_source ]} (the metadata instance of source 'Artist') is *OUTDATED*",
+
+ "${orig_class_rsrc_before_table_triggered_reinit}->name(...) at",
+ "$fn line $divergence_lines[2]",
+
+ "${orig_class_rsrc_before_table_triggered_reinit}->table(...) at",
+ "$fn line $divergence_lines[3]",
+
+ "Stale metadata accessed by 'getter' @{[ $art->result_source ]}->table(...)",
+;
+
+like
+ $err,
+ qr/$expected_warning_2/s,
+ 'Correct warning on diverged metadata'
+;
+
+done_testing;
--- /dev/null
+BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
+
+# things will die if this is set
+BEGIN { $ENV{DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE} = 0 }
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Warn;
+
+use DBICTest;
+
+my $s = DBICTest->init_schema( no_deploy => 1 );
+
+
+warnings_exist {
+ DBICTest::Schema::Artist->add_column("somethingnew");
+ $s->unregister_source("Artist");
+ $s->register_class( Artist => "DBICTest::Schema::Artist" );
+}
+ qr/The ResultSource instance you just registered on .+ \Qas 'Artist' seems to have no relation to DBICTest::Schema->source('Artist') which in turn is marked stale/,
+ 'Expected warning on incomplete re-register of schema-class-level source'
+;
+
+done_testing;
--- /dev/null
+BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
+
+BEGIN { delete $ENV{DBIC_ASSERT_NO_FAILING_SANITY_CHECKS} }
+
+use strict;
+use warnings;
+
+use Test::More;
+
+use DBICTest::Util 'capture_stderr';
+use DBICTest;
+
+
+{
+ package DBICTest::Some::BaseResult;
+ use base "DBIx::Class::Core";
+
+ # order is important
+ __PACKAGE__->load_components(qw( FilterColumn InflateColumn::DateTime ));
+}
+
+{
+ package DBICTest::Some::Result;
+ use base "DBICTest::Some::BaseResult";
+
+ __PACKAGE__->table("sometable");
+
+ __PACKAGE__->add_columns(
+ somecolumn => { data_type => "datetime" },
+ );
+}
+
+{
+ package DBICTest::Some::Schema;
+ use base "DBIx::Class::Schema";
+ __PACKAGE__->schema_sanity_checker("DBIx::Class::Schema::SanityChecker");
+ __PACKAGE__->register_class( some_result => "DBICTest::Some::Result" );
+}
+
+like(
+ capture_stderr {
+ DBICTest::Some::Schema->connection(sub {} );
+ },
+ qr/Class 'DBICTest::Some::Result' was originally using the 'dfs' MRO affecting .+ register_column\(\)/,
+ 'Proper incorrect composition warning emitted on StdErr'
+);
+
+done_testing;
BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
+# Test is sufficiently involved to *want* to run with "maximum paranoia"
+BEGIN { $ENV{DBICTEST_OLD_MRO_SANITY_CHECK_ASSERTIONS} = 1 }
+
use warnings;
use strict;
--- /dev/null
+use warnings;
+use strict;
+
+use Config;
+BEGIN {
+ my $skipall;
+
+ if( ! $Config{useithreads} ) {
+ $skipall = 'your perl does not support ithreads';
+ }
+ elsif( "$]" < 5.008005 ) {
+ $skipall = 'DBIC does not actively support threads before perl 5.8.5';
+ }
+ elsif( $INC{'Devel/Cover.pm'} ) {
+ $skipall = 'Devel::Cover does not work with ithreads yet';
+ }
+
+ if( $skipall ) {
+ print "1..0 # SKIP $skipall\n";
+ exit 0;
+ }
+}
+
+use threads;
+use Test::More;
+use DBIx::Class::_Util 'hrefaddr';
+use Scalar::Util 'weaken';
+
+{
+ package DBICTest::Ancestry::Result;
+
+ use base 'DBIx::Class::Core';
+
+ __PACKAGE__->table("foo");
+}
+
+{
+ package DBICTest::Ancestry::Schema;
+
+ use base 'DBIx::Class::Schema';
+
+ __PACKAGE__->register_class( r => "DBICTest::Ancestry::Result" );
+}
+
+my $schema = DBICTest::Ancestry::Schema->clone;
+my $rsrc = $schema->resultset("r")->result_source->clone;
+
+threads->new( sub {
+
+ my $another_rsrc = $rsrc->clone;
+
+ is_deeply
+ refaddrify( DBICTest::Ancestry::Result->result_source_instance->__derived_instances ),
+ refaddrify(
+ DBICTest::Ancestry::Schema->source("r"),
+ $schema->source("r"),
+ $rsrc,
+ $another_rsrc,
+ )
+ ;
+
+ undef $schema;
+ undef $rsrc;
+ $another_rsrc->schema(undef);
+
+ is_deeply
+ refaddrify( DBICTest::Ancestry::Result->result_source_instance->__derived_instances ),
+ refaddrify(
+ DBICTest::Ancestry::Schema->source("r"),
+ $another_rsrc,
+ )
+ ;
+
+ # tasty crashes without this
+ select( undef, undef, undef, 0.2 );
+})->join;
+
+sub refaddrify {
+ [ sort map { hrefaddr $_ } @_ ];
+}
+
+done_testing;
DBICTEST_DEBUG_CONCURRENCY_LOCKS
)};
+ # ensures the checker won't be disabled in
+ # t/lib/DBICTest/BaseSchema.pm
+ $ENV{DBIC_ASSERT_NO_FAILING_SANITY_CHECKS} = 1;
+
$ENV{DBICTEST_ANFANG_DEFANG} = 1;
# make sure extras do not load even when this is set
projects / dbsrgits/DBIx-Class.git / commitdiff