diff --git a/.dir-locals.el b/.dir-locals.el new file mode 100644 index 000000000..14bf8b91e --- /dev/null +++ b/.dir-locals.el @@ -0,0 +1,7 @@ +((nil . ((indent-tabs-mode . nil))) + (cperl-mode . ((cperl-indent-level . 2) + (cperl-continued-statement-offset . 2) + (cperl-continued-brace-offset . 0) + (cperl-close-paren-offset . -2) + (cperl-indent-subs-specially . nil) + (indent-tabs-mode . nil)))) diff --git a/.mailmap b/.mailmap index 587e076a4..ffbbe5d9b 100644 --- a/.mailmap +++ b/.mailmap @@ -5,29 +5,43 @@ # https://www.kernel.org/pub/software/scm/git/docs/git-shortlog.html#_mapping_authors Alexander Hartmaier +Alexander Kuznetsov Amiri Barksdale Andrew Rodland Arthur Axel "fREW" Schmidt -Brendan Byrd -Brendan Byrd -Brendan Byrd +Ash Berlin +Brendan Byrd +Brendan Byrd +Brendan Byrd Brian Phillips +Christian Walde +Jess Robinson Dagfinn Ilmari Mannsåker David Kamholz David Schmidt David Schmidt David Schmidt Devin Austin +Duncan Garland Felix Antonius Wilhelm Ostmann +Fitz Elliott Gerda Shank Gianni Ceccarelli Gordon Irving Hakim Cassimally +Henry Van Styn +Jason M. Mills Jonathan Chu +Jose Luis Martinez +Kent Fredric Matt Phillips Norbert Csongrádi -Roman Filippov Peter Rabbitson -Tim Bunce +Roman Filippov +Ronald J Kimball +Samuel Kaufman +Tim Bunce Toby Corkindale +Tommy Butler +Ton Voon Wallace Reis diff --git a/.travis.yml b/.travis.yml index ed2c04e70..f008808ff 100644 --- a/.travis.yml +++ b/.travis.yml @@ -18,7 +18,7 @@ # possible set of deps *without testing them*. This ensures we stay within # a reasonable build-time and still run as many of our tests as possible # -# * The perl builds and the DBIC tests run under NUMTHREADS number of threads. +# * The perl builds and the DBIC tests run under VCPU_USE number of threads. # The testing of dependencies under CLEANTEST runs single-threaded, at least # until we fix our entire dep-chain to safely pass under -j # @@ -28,6 +28,8 @@ # functionality is moved to scripts. More about the problem (and the # WONTFIX "explanation") here: https://github.com/travis-ci/travis-ci/issues/497 # +# the entire run times out after 50 minutes, or after 5 minutes without +# console output # # Smoke all branches except for blocked* and wip/* @@ -68,196 +70,264 @@ notifications: language: perl perl: - - "5.18" + - "5.8" + - "5.20-extras" env: - CLEANTEST=false - - CLEANTEST=true + - CLEANTEST=true VCPU_USE=1 + +sudo: true matrix: + fast_finish: true include: - # this particular perl is quite widespread - - perl: 5.8.8_thr_mb + # CLEANTEST of minimum supported with non-tracing poisoning + - perl: 5.8.3_nt_mb env: - CLEANTEST=true - - BREWOPTS="-Duseithreads -Dusemorebits" - - BREWVER=5.8.8 + - POISON_ENV=true + - DBIC_TRACE_PROFILE=console_monochrome + - BREWVER=5.8.3 + - BREWOPTS="-Dusemorebits" - # so is this one (test a sane CPAN.pm) - - perl: 5.12.4_thr_mb + # Full Test of minimum supported without threads with non-tracing poisoning + - perl: 5.8.3_nt env: - - CLEANTEST=true - - BREWOPTS="-Duseithreads -Dusemorebits" - - BREWVER=5.12.4 + - CLEANTEST=false + - POISON_ENV=true + - BREWVER=5.8.3 - # this is the perl suse ships - - perl: 5.10.0_thr_dbg + # Full Test of minimum supported with threads with non-tracing poisoning + - perl: 5.8.5_thr env: - - CLEANTEST=true - - BREWOPTS="-DDEBUGGING -Duseithreads" - - BREWVER=5.10.0 + - CLEANTEST=false + - POISON_ENV=true + - DBIC_TRACE_PROFILE=console + - BREWVER=5.8.5 + - BREWOPTS="-Duseithreads" - # CLEANTEST of minimum supported - - perl: 5.8.3_nt_mb + # CLEANTEST of solaris-like perl with non-tracing poisoning + - perl: 5.8.4_nt env: - CLEANTEST=true - - BREWOPTS="-Dusemorebits" - - BREWVER=5.8.3 + - POISON_ENV=true + - DBIC_TRACE_PROFILE=console + - BREWVER=5.8.4 - # Full Test of minimum supported with threads - - perl: 5.8.5_thr + # CLEANTEST: this particular perl is quite widespread + - perl: 5.8.8_thr env: - - CLEANTEST=false + - CLEANTEST=true + - BREWVER=5.8.8 - BREWOPTS="-Duseithreads" - - BREWVER=5.8.5 - - DBIC_TRACE_PROFILE=console - # Full Test of minimum supported without threads - - perl: 5.8.3_nt + # CLEANTEST: this is the perl suse ships, with env poisoning + - perl: 5.10.0_thr_dbg env: - - CLEANTEST=false - - BREWOPTS="" - - BREWVER=5.8.3 - - DBIC_TRACE_PROFILE=console_monochrome + - CLEANTEST=true + - POISON_ENV=true + - BREWVER=5.10.0 + - BREWOPTS="-DDEBUGGING -Duseithreads" + + # CLEANTEST: this one is in a number of debian-based LTS (test a sane CPAN.pm) + - perl: 5.14.2_thr_mb + env: + - CLEANTEST=true + - BREWVER=5.14.2 + - BREWOPTS="-Duseithreads -Dusemorebits" ### # some permutations of tracing and envvar poisoning - - perl: 5.16.2_thr_mb + - perl: 5.12.3_thr env: - - CLEANTEST=false + - CLEANTEST=true - POISON_ENV=true - DBIC_TRACE=1 - - DBIC_MULTICREATE_DEBUG=0 - - BREWOPTS="-Duseithreads -Dusemorebits" - - BREWVER=5.16.2 - - - perl: 5.18 - env: - - CLEANTEST=false - - POISON_ENV=true + - DBIC_MULTICREATE_DEBUG=1 + - DBIC_STORAGE_RETRY_DEBUG=1 - DBIC_TRACE_PROFILE=console + - BREWVER=5.12.3 + - BREWOPTS="-Duseithreads" - - perl: 5.8 + - perl: 5.16.3_thr_mb env: - - CLEANTEST=true + - CLEANTEST=false - POISON_ENV=true - DBIC_TRACE=1 - - DBIC_TRACE_PROFILE=console + - BREWVER=5.16.3 + - BREWOPTS="-Duseithreads -Dusemorebits" - - perl: 5.18 + - perl: 5.18-extras env: - CLEANTEST=false - POISON_ENV=true - DBIC_TRACE=1 - DBIC_TRACE_PROFILE=console_monochrome - - DBIC_MULTICREATE_DEBUG=0 + - DBICTEST_VIA_REPLICATED=0 ### # Start of the allow_failures block - # old threaded with blead CPAN - - perl: devcpan_5.8.7_thr + # threaded oldest possible with blead CPAN + - perl: devcpan_5.8.1_thr_mb env: - CLEANTEST=true - - BREWOPTS="-Duseithreads" - - BREWVER=5.8.7 - DEVREL_DEPS=true + - BREWVER=5.8.1 + - BREWOPTS="-Duseithreads -Dusemorebits" - # 5.10.0 threaded with blead CPAN - - perl: devcpan_5.10.0_thr_mb + # oldest possible with blead CPAN with poisoning + - perl: devcpan_5.8.1 env: - CLEANTEST=true - - BREWOPTS="-Duseithreads -Dusemorebits" - - BREWVER=5.10.0 - DEVREL_DEPS=true + - POISON_ENV=true + - BREWVER=5.8.1 + + # 5.8.3 with blead CPAN + - perl: devcpan_5.8.3_mb + env: + - CLEANTEST=false + - DEVREL_DEPS=true + - BREWVER=5.8.3 + - BREWOPTS="-Dusemorebits" - # 5.12.2 with blead CPAN - - perl: devcpan_5.12.2_thr + # 5.8.7 threaded with blead CPAN with non-tracing poisoning + - perl: devcpan_5.8.7_thr env: - CLEANTEST=true + - DEVREL_DEPS=true + - POISON_ENV=true + - BREWVER=5.8.7 - BREWOPTS="-Duseithreads" - - BREWVER=5.12.2 + + # 5.8.8 threaded MB (exercises P5#72210) + - perl: devcpan_5.8.8_thr_mb + env: + - CLEANTEST=true - DEVREL_DEPS=true + - BREWVER=5.8.8 + - BREWOPTS="-Duseithreads -Dusemorebits" - # recentish threaded stable with blead CPAN - - perl: devcpan_5.18.2_thr_mb + # 5.10.0 threaded with blead CPAN + - perl: devcpan_5.10.0_thr_mb env: - - CLEANTEST=false + - CLEANTEST=true + - DEVREL_DEPS=true + - BREWVER=5.10.0 - BREWOPTS="-Duseithreads -Dusemorebits" - - BREWVER=5.18.2 + + # 5.12.1 with blead CPAN + - perl: devcpan_5.12.1_thr + env: + - CLEANTEST=true - DEVREL_DEPS=true + - BREWVER=5.12.1 + - BREWOPTS="-Duseithreads" - # bleadperl with stock CPAN, full depchain test + # bleadperl with stock CPAN, full depchain test with non-tracing poisoning - perl: bleadperl env: - CLEANTEST=true + - POISON_ENV=true - BREWVER=blead # bleadperl with blead CPAN - perl: devcpan_bleadperl_thr_mb env: - CLEANTEST=false - - BREWOPTS="-Duseithreads -Dusemorebits" - - BREWVER=blead - DEVREL_DEPS=true + - BREWVER=blead + - BREWOPTS="-Duseithreads -Dusemorebits" + # CLEANTEST of http://schplog.schmorp.de/2015-06-06-a-stable-perl.html with non-tracing poisoning + - perl: schmorp_stableperl_thr_mb + env: + - CLEANTEST=true + - POISON_ENV=true + - BREWVER=schmorp_stableperl + - BREWOPTS="-Duseithreads -Dusemorebits" # which ones of the above can fail allow_failures: # these run with various dev snapshots - allowed to fail + - perl: devcpan_5.8.1_thr_mb + - perl: devcpan_5.8.1 + - perl: devcpan_5.8.3_mb - perl: devcpan_5.8.7_thr + - perl: devcpan_5.8.8_thr_mb - perl: devcpan_5.10.0_thr_mb - - perl: devcpan_5.12.2_thr - - perl: devcpan_5.18.2_thr_mb + - perl: devcpan_5.12.1_thr - perl: bleadperl - perl: devcpan_bleadperl_thr_mb + - perl: schmorp_stableperl_thr_mb -# sourcing the files is *EXTREMELY* important - otherwise -# no envvars will survive - -# the entire run times out after 50 minutes, or after 5 minutes without -# console output +### +### For the following two phases -e is *set* +### before_install: + # common functions for all run phases below + # + # this is an exporter - sourcing it is crucial + # among other things it also sets -e + # + - source maint/travis-ci_scripts/common.bash + # Sets global envvars, downloads/configures debs based on CLEANTEST # Sets extra DBICTEST_* envvars # + # this is an exporter - sourcing it is crucial + # - source maint/travis-ci_scripts/10_before_install.bash install: # Build and switch to a custom perl if requested # Configure the perl env, preinstall some generic toolchain parts + # Possibly poison the environment + # + # this is an exporter - sourcing it is crucial # - source maint/travis-ci_scripts/20_install.bash +### +### From this point on -e is *unset*, rely on travis' error handling +### + - set +e + before_script: # Preinstall/install deps based on envvars/CLEANTEST # - - source maint/travis-ci_scripts/30_before_script.bash + # need to invoke the after_failure script manually + # because 'after_failure' runs only after 'script' fails + # + - maint/getstatus maint/travis-ci_scripts/30_before_script.bash || ( maint/travis-ci_scripts/50_after_failure.bash && /bin/false ) script: # Run actual tests # - - source maint/travis-ci_scripts/40_script.bash + - maint/getstatus maint/travis-ci_scripts/40_script.bash + +### +### Set -e back, work around https://github.com/travis-ci/travis-ci/issues/3533 +### + - set -e after_success: # Check if we can assemble a dist properly if not in CLEANTEST # - - source maint/travis-ci_scripts/50_after_success.bash + - maint/getstatus maint/travis-ci_scripts/50_after_success.bash after_failure: - # No tasks yet + # Final sysinfo printout on fail # - #- source maint/travis-ci_scripts/50_after_failure.bash + - maint/getstatus maint/travis-ci_scripts/50_after_failure.bash after_script: # No tasks yet # - #- source maint/travis-ci_scripts/60_after_script.bash - - # if we do not unset this before we terminate the travis teardown will - # mark the entire job as failed - - set +e + #- maint/getstatus maint/travis-ci_scripts/60_after_script.bash diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 000000000..5db327936 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,223 @@ +# +# The list of the awesome folks behind DBIx::Class +# +# This utf8-encoded file lists every code author and idea contributor +# in alphabetical order +# +# Entry format (all elements optional, order is mandatory): +# (ircnick:) (name) () +# +# +# *** EVEN THOUGH FIELDS ARE OPTIONAL, COMMITTERS ARE QUITE *** +# *** STRONGLY URGED TO KEEP THIS LIST AS COMPLETE AS POSSIBLE *** +# +# *** IN OTHER WORDS - DO NOT BE LAZY *** +# + +abraxxa: Alexander Hartmaier +acca: Alexander Kuznetsov +aherzog: Adam Herzog +Alexander Keusch +alexrj: Alessandro Ranellucci +alnewkirk: Al Newkirk +Altreus: Alastair McGowan-Douglas +amiri: Amiri Barksdale +amoore: Andrew Moore +Andrew Mehta +andrewalker: Andre Walker +andyg: Andy Grundman +ank: Andres Kievsky +arc: Aaron Crane +arcanez: Justin Hunter +ash: Ash Berlin +bert: Norbert Csongrádi +bfwg: Colin Newell +blblack: Brandon L. Black +bluefeet: Aran Deltac +boghead: Bryan Beeley +bphillips: Brian Phillips +brd: Brad Davis +Brian Kirkbride +bricas: Brian Cassidy +brunov: Bruno Vecchi +caelum: Rafael Kitover +caldrin: Maik Hentsche +castaway: Jess Robinson +chorny: Alexandr Ciornii +cj: C.J. Adams-Collier +claco: Christopher H. Laco +clkao: CL Kao +Ctrl-O http://ctrlo.com/ +da5id: David Jack Olrik +dams: Damien Krotkine +dandv: Dan Dascalescu +dariusj: Darius Jokilehto +davewood: David Schmidt +daxim: Lars Dɪᴇᴄᴋᴏᴡ 迪拉斯 +dduncan: Darren Duncan +debolaz: Anders Nor Berle +dew: Dan Thomas +dim0xff: Dmitry Latin +dkubb: Dan Kubb +dnm: Justin Wheeler +dpetrov: Dimitar Petrov +Dr^ZigMan: Robert Stone +dsteinbrunner: David Steinbrunner +duncan_dmg: Duncan Garland +dwc: Daniel Westermann-Clark +dyfrgi: Michael Leuchtenburg +edenc: Eden Cardim +Eligo http://eligo.co.uk/ +ether: Karen Etheridge +evdb: Edmund von der Burg +faxm0dem: Fabien Wernli +felliott: Fitz Elliott +freetime: Bill Moseley +frew: Arthur Axel "fREW" Schmidt +gbjk: Gareth Kirwan +geotheve: Georgina Thevenet +Getty: Torsten Raudssus +goraxe: Gordon Irving +gphat: Cory G Watson +Grant Street Group http://www.grantstreet.com/ +groditi: Guillermo Roditi +gshank: Gerda Shank +guacamole: Fred Steinberg +Haarg: Graham Knop +hobbs: Andrew Rodland +Ian Wells +idn: Ian Norton +ilmari: Dagfinn Ilmari Mannsåker +ingy: Ingy döt Net +initself: Mike Baas +ironcamel: Naveed Massjouni +jasonmay: Jason May +jawnsy: Jonathan Yu +jegade: Jens Gassmann +jeneric: Eric A. Miller +jesper: Jesper Krogh +Jesse Sheidlower +jgoulah: John Goulah +jguenther: Justin Guenther +jhannah: Jay Hannah +jmac: Jason McIntosh +jmmills: Jason M. Mills +jnapiorkowski: John Napiorkowski +Joe Carlson +jon: Jon Schutz +Jordan Metzmeier +jshirley: J. Shirley +kaare: Kaare Rasmussen +kd: Kieren Diment +kentnl: Kent Fredric +kkane: Kevin L. Kane +konobi: Scott McWhirter +lamoz: Konstantin A. Pustovalov +Lasse Makholm +lejeunerenard: Sean Zellmer +littlesavage: Alexey Illarionov +lukes: Luke Saunders +marcus: Marcus Ramberg +mateu: Mateu X. Hunter +Matt LeBlanc +Matt Sickler +mattlaw: Matt Lawrence +mattp: Matt Phillips +mdk: Mark Keating +melo: Pedro Melo +metaperl: Terrence Brannon +michaelr: Michael Reddick +milki: Jonathan Chu +minty: Murray Walker +mithaldu: Christian Walde +mjemmeson: Michael Jemmeson +mna: Maya +mo: Moritz Onken +moltar: Roman Filippov +moritz: Moritz Lenz +mrf: Mike Francis +mst: Matt S. Trout +mstratman: Mark A. Stratman +ned: Neil de Carteret +nigel: Nigel Metheringham +ningu: David Kamholz +Nniuq: Ron "Quinn" Straight" +norbi: Norbert Buchmuller +nothingmuch: Yuval Kogman +nuba: Nuba Princigalli +Numa: Dan Sully +oalders: Olaf Alders +Olly Betts +osfameron: Hakim Cassimally +ovid: Curtis "Ovid" Poe +oyse: Øystein Torget +paulm: Paul Makepeace +penguin: K J Cheetham +perigrin: Chris Prather +Peter Siklósi +Peter Valdemar Mørch +peter: Peter Collingbourne +phaylon: Robert Sedlacek +plu: Johannes Plunien +Possum: Daniel LeWarne +pplu: Jose Luis Martinez +quicksilver: Jules Bean +racke: Stefan Hornburg +rafl: Florian Ragwitz +rainboxx: Matthias Dietrich +rbo: Robert Bohne +rbuels: Robert Buels +rdj: Ryan D Johnson +Relequestual: Ben Hutton +renormalist: Steffen Schwigon +ribasushi: Peter Rabbitson +rjbs: Ricardo Signes +Robert Krimen +Robert Olson +robkinyon: Rob Kinyon +Roman Ardern-Corris +ruoso: Daniel Ruoso +Sadrak: Felix Antonius Wilhelm Ostmann +sc_: Just Another Perl Hacker +schwern: Michael G Schwern +Scott R. Godin +scotty: Scotty Allen +semifor: Marc Mims +Simon Elliott +SineSwiper: Brendan Byrd +skaufman: Samuel Kaufman +solomon: Jared Johnson +spb: Stephen Bennett +Squeeks +srezic: Slaven Rezic +sszabo: Stephan Szabo +Stephen Peters +stonecolddevin: Devin Austin +talexb: Alex Beamish +tamias: Ronald J Kimball +TBSliver: Tom Bloor +teejay: Aaron Trevena +theorbtwo: James Mastros +Thomas Kratz +timbunce: Tim Bunce +tinita: Tina Mueller +Todd Lipcon +Tom Hukins +tommy: Tommy Butler +tonvoon: Ton Voon +triode: Pete Gamache +typester: Daisuke Murase +uree: Oriol Soriano +uwe: Uwe Voelker +vanstyn: Henry Van Styn +victori: Victor Igumnov +wdh: Will Hawes +wesm: Wes Malone +willert: Sebastian Willert +wintermute: Toby Corkindale +wreis: Wallace Reis +xenoterracide: Caleb Cushing +xmikew: Mike Wisener +yrlnry: Mark Jason Dominus +zamolxes: Bogdan Lucaciu +Zefram: Andrew Main diff --git a/Changes b/Changes index 387cb0a05..f5b552f87 100644 --- a/Changes +++ b/Changes @@ -1,9 +1,162 @@ Revision history for DBIx::Class + * Notable Changes and Deprecations + - $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 + afterwards. Instead an exception (detailing the fix) is thrown. + - Calling the set_* many-to-many helper with a list (instead of an + arrayref) now emits a deprecation warning + + * New Features + - DBIx::Class::Optional::Dependencies now properly understands + combinations of requirements and does the right thing with e.g. + ->req_list_for([qw( rdbms_oracle ic_dt )]) bringing in the Oracle + specific DateTime::Format dependencies + + * Fixes + - Ensure failing on_connect* / on_disconnect* are dealt with properly, + notably on_connect* failures now properly abort the entire connect + - Make sure exception objects stringifying to '' are properly handled + and warned about (GH#15) + - Fix corner case of stringify-only overloaded objects being used in + create()/populate() + - Fix several corner cases with Many2Many over custom relationships + - Fix t/52leaks.t failures on compilerless systems (RT#104429) + - Fix t/storage/quote_names.t failures on systems with specified Oracle + test credentials while missing the optional Math::Base36 + - Fix the Sybase ASE storage incorrectly attempting to retrieve an + autoinc value when inserting rows containing blobs (GH#82) + - Fix test failures when DBICTEST_SYBASE_DSN is set (unnoticed change + in error message wording during 0.082800 and a bogus test) + + * Misc + - Fix invalid variable names in ResultSource::View examples + - Skip tests in a way more intelligent and speedy manner when optional + dependencies are missing + - Make the Optional::Dependencies error messages cpanm-friendly + - Incompatibly change values (not keys) of the hash returned by + Optional::Dependencies::req_group_list (no known users in the wild) + - Protect tests and codebase from incomplete caller() overrides, like + e.g. RT#32640 + - Stop using bare $] throughout - protects the codebase from issues + similar (but likely not limited to) P5#72210 + +0.082820 2015-03-20 20:35 (UTC) + * Fixes + - Protect destructors from rare but possible double execution, and + loudly warn the user whenever the problem is encountered (GH#63) + - Relax the 'self_result_object' argument check in the relationship + resolution codepath, restoring exotic uses of inflate_result + http://lists.scsys.co.uk/pipermail/dbix-class/2015-January/011876.html + - Fix updating multiple CLOB/BLOB columns on Oracle + - Fix exception on complex update/delete under a replicated setup + http://lists.scsys.co.uk/pipermail/dbix-class/2015-January/011903.html + - Fix uninitialized warnings on empty hashes passed to join/prefetch + https://github.com/vanstyn/RapidApp/commit/6f41f6e48 and + http://lists.scsys.co.uk/pipermail/dbix-class/2015-February/011921.html + - Fix hang in t/72pg.t when run against DBD::Pg 3.5.0. The ping() + implementation changes due to RT#100648 made an alarm() based + timeout lock-prone. + + * Misc + - Remove warning about potential side effects of RT#79576 (scheduled) + - Various doc improvements (GH#35, GH#62, GH#66, GH#70, GH#71, GH#72) + - Depend on newer Moo, to benefit from a safer runtime (RT#93004) + - Fix intermittent failures in the LeakTracer on 5.18+ + - Fix failures of t/54taint.t on Windows with spaces in the $^X + executable path (RT#101615) + +0.082810 2014-10-25 13:58 (UTC) * Fixes + - Fix incorrect collapsing-parser source being generated in the + presence of unicode data among the collapse-points + - Fix endless loop on BareSourcelessResultClass->throw_exception(...) + + * Misc + - Depend on newer SQL::Abstract (fixing overly-aggressive parenthesis + opener: RT#99503) + - Depend on newer Moo, fixing some interoperability issues: + http://lists.scsys.co.uk/pipermail/dbix-class/2014-October/011787.html + +0.082801 2014-10-05 23:55 (UTC) + * Known Issues + - Passing large amounts of objects with stringification overload + directly to DBIx::Class may result in strange action at a distance + exceptions. More info (and a workaround description) can be found + under "Note" at https://metacpan.org/pod/SQL::Abstract#is_plain_value + - The relationship condition resolution fixes come with the side effect + of returning more complete data, tripping up *some* users of an + undocumented but widely used internal function. In particular + https://rt.cpan.org/Ticket/Display.html?id=91375#txn-1407239 + + * Notable Changes and Deprecations + - DBIC::FilterColumn now properly bypasses \'' and \[] literals, just + like the rest of DBIC + - DBIC::FilterColumn "from_storage" handler is now invoked on NULLs + returned from storage + - find() now throws an exception if some of the supplied values are + managed by DBIC::FilterColumn (RT#95054) + - Custom condition relationships are now invoked with a slightly + different signature (existing coderefs will continue to work) + - Add extra custom condition coderef attribute 'foreign_values' + to allow for proper reverse-relationship-like behavior + (i.e. $result->set_from_related($custom_rel, $foreign_result_object) + - When in a transaction, DBIC::Ordered now seamlesly handles result + objects that went out of sync with the storage (RT#96499) + - CDBICompat::columns() now supports adding columns through supplied + Class::DBI::Column instances (GH#52) + - Deprecate { col1 => col2 } expressions in manual {from} structures + (at some point of time manual {from} will be deprecated entirely) + + * Fixes + - Fix Resultset delete/update affecting *THE ENTIRE TABLE* in cases + of empty (due to conditions) resultsets with multi-column keys - Fix on_connect_* not always firing in some cases - a race condition existed between storage accessor setters and the determine_driver routines, triggering a connection before the set-cycle is finished + - Fix collapse being ignored on single-origin selection (RT#95658) + - Fix incorrect behavior on custom result_class inflators altering + the amount of returned results + - Fix failure to detect stable order criteria when in iterator + mode of a has_many prefetch off a search_related chain + - Prevent erroneous database hit when accessing prefetched related + resultsets with no rows + - Proper exceptions on malformed relationship conditions (RT#92234) + - Fix incorrect handling of custom relationship conditions returning + SQLA literal expressions + - Fix long standing bug with populate() missing data from hashrefs with + different keysets: http://is.gd/2011_dbic_populate_gotcha (RT#92723) + - Fix multi-value literal populate not working with simplified bind + specifications + - Massively improve the implied resultset condition parsing - now all + applicable conditions within a resultset should be properly picked + up by create() and populate() + - Ensure definitive condition extractor handles bizarre corner cases + without bombing out (RT#93244) + - Fix set_column on non-native (+columns) selections (RT#86685) + - Fix set_inflated_column incorrectly handling \[] literals (GH#44) + - Ensure that setting a column to a literal invariably marks it dirty + - Fix copy() not working correctly with extra selections present + - Work around exception objects with broken string overloading in one + additional codepath (missed in 0.08260) + - Fix more inconsistencies of the quote_names attribute propagating + to SQL::Translator (partially RT#87731) + - Fix SQLT constraint naming when DBIC table names are fully qualified + (PR#48) + - Ensure ::Schema::Versioned connects only once by reusing the main + connection (GH#57) + - Fix inability to handle multiple consecutive transactions with + savepoints on DBD::SQLite < 1.39 + - Fix CDBICompat to match Class::DBI behavior handling non-result + blessed has_a (implicit deflate via stringification and inflate via + blind new) (GH#51) + + * Misc + - Ensure source metadata calls always take place on the result source + instance registered with the caller + - IFF DBIC_TRACE output defaults to STDERR we now silence the possible + wide-char warnings if the trace happens to contain unicode 0.08270 2014-01-30 21:54 (PST) * Fixes diff --git a/LICENSE b/LICENSE new file mode 100644 index 000000000..f1a0df51b --- /dev/null +++ b/LICENSE @@ -0,0 +1,409 @@ +This is free software; you can redistribute it and/or modify it under the +same terms as the Perl5 (v5.0.0 ~ v5.20.0) programming language system +itself: under the terms of either: + +a) the "Artistic License 1.0" as published by The Perl Foundation + http://www.perlfoundation.org/artistic_license_1_0 + +b) the GNU General Public License as published by the Free Software Foundation; + either version 1 http://www.gnu.org/licenses/gpl-1.0.html + or (at your option) any later version + +PLEASE NOTE: It is the current maintainers intention to keep the dual +licensing intact. Until this notice is removed, releases will continue to +be available under both the standard GPL and the less restrictive Artistic +licenses. + +Verbatim copies of both licenses are included below: + + + +--- The Artistic License 1.0 --- + + The "Artistic License" + + Preamble + +The intent of this document is to state the conditions under which a +Package may be copied, such that the Copyright Holder maintains some +semblance of artistic control over the development of the package, +while giving the users of the package the right to use and distribute +the Package in a more-or-less customary fashion, plus the right to make +reasonable modifications. + +Definitions: + + "Package" refers to the collection of files distributed by the + Copyright Holder, and derivatives of that collection of files + created through textual modification. + + "Standard Version" refers to such a Package if it has not been + modified, or has been modified in accordance with the wishes + of the Copyright Holder as specified below. + + "Copyright Holder" is whoever is named in the copyright or + copyrights for the package. + + "You" is you, if you're thinking about copying or distributing + this Package. + + "Reasonable copying fee" is whatever you can justify on the + basis of media cost, duplication charges, time of people involved, + and so on. (You will not be required to justify it to the + Copyright Holder, but only to the computing community at large + as a market that must bear the fee.) + + "Freely Available" means that no fee is charged for the item + itself, though there may be fees involved in handling the item. + It also means that recipients of the item may redistribute it + under the same conditions they received it. + +1. You may make and give away verbatim copies of the source form of the +Standard Version of this Package without restriction, provided that you +duplicate all of the original copyright notices and associated disclaimers. + +2. You may apply bug fixes, portability fixes and other modifications +derived from the Public Domain or from the Copyright Holder. A Package +modified in such a way shall still be considered the Standard Version. + +3. You may otherwise modify your copy of this Package in any way, provided +that you insert a prominent notice in each changed file stating how and +when you changed that file, and provided that you do at least ONE of the +following: + + a) place your modifications in the Public Domain or otherwise make them + Freely Available, such as by posting said modifications to Usenet or + an equivalent medium, or placing the modifications on a major archive + site such as uunet.uu.net, or by allowing the Copyright Holder to include + your modifications in the Standard Version of the Package. + + b) use the modified Package only within your corporation or organization. + + c) rename any non-standard executables so the names do not conflict + with standard executables, which must also be provided, and provide + a separate manual page for each non-standard executable that clearly + documents how it differs from the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. + +4. You may distribute the programs of this Package in object code or +executable form, provided that you do at least ONE of the following: + + a) distribute a Standard Version of the executables and library files, + together with instructions (in the manual page or equivalent) on where + to get the Standard Version. + + b) accompany the distribution with the machine-readable source of + the Package with your modifications. + + c) give non-standard executables non-standard names, and clearly + document the differences in manual pages (or equivalent), together + with instructions on where to get the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. + +5. You may charge a reasonable copying fee for any distribution of this +Package. You may charge any fee you choose for support of this +Package. You may not charge a fee for this Package itself. However, +you may distribute this Package in aggregate with other (possibly +commercial) programs as part of a larger (possibly commercial) software +distribution provided that you do not advertise this Package as a +product of your own. You may embed this Package's interpreter within +an executable of yours (by linking); this shall be construed as a mere +form of aggregation, provided that the complete Standard Version of the +interpreter is so embedded. + +6. The scripts and library files supplied as input to or produced as +output from the programs of this Package do not automatically fall +under the copyright of this Package, but belong to whoever generated +them, and may be sold commercially, and may be aggregated with this +Package. If such scripts or library files are aggregated with this +Package via the so-called "undump" or "unexec" methods of producing a +binary executable image, then distribution of such an image shall +neither be construed as a distribution of this Package nor shall it +fall under the restrictions of Paragraphs 3 and 4, provided that you do +not represent such an executable image as a Standard Version of this +Package. + +7. C subroutines (or comparably compiled subroutines in other +languages) supplied by you and linked into this Package in order to +emulate subroutines and variables of the language defined by this +Package shall not be considered part of this Package, but are the +equivalent of input as in Paragraph 6, provided these subroutines do +not change the language in any way that would cause it to fail the +regression tests for the language. + +8. Aggregation of this Package with a commercial distribution is always +permitted provided that the use of this Package is embedded; that is, +when no overt attempt is made to make this Package's interfaces visible +to the end user of the commercial distribution. Such use shall not be +construed as a distribution of this Package. + +9. The name of the Copyright Holder may not be used to endorse or promote +products derived from this software without specific prior written permission. + +10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED +WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + +--- end of The Artistic License 1.0 --- + + + + +--- The GNU General Public License, Version 1, February 1989 --- + + GNU GENERAL PUBLIC LICENSE + Version 1, February 1989 + + Copyright (C) 1989 Free Software Foundation, Inc. + 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The license agreements of most software companies try to keep users +at the mercy of those companies. By contrast, our General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. The +General Public License applies to the Free Software Foundation's +software and to any other program whose authors commit to using it. +You can use it for your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Specifically, the General Public License is designed to make +sure that you have the freedom to give away or sell copies of free +software, that you receive source code or can get it if you want it, +that you can change the software or use pieces of it in new free +programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of a such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must tell them their rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any program or other work which +contains a notice placed by the copyright holder saying it may be +distributed under the terms of this General Public License. The +"Program", below, refers to any such program or work, and a "work based +on the Program" means either the Program or any work containing the +Program or a portion of it, either verbatim or with modifications. Each +licensee is addressed as "you". + + 1. You may copy and distribute verbatim copies of the Program's source +code as you receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice and +disclaimer of warranty; keep intact all the notices that refer to this +General Public License and to the absence of any warranty; and give any +other recipients of the Program a copy of this General Public License +along with the Program. You may charge a fee for the physical act of +transferring a copy. + + 2. You may modify your copy or copies of the Program or any portion of +it, and copy and distribute such modifications under the terms of Paragraph +1 above, provided that you also do the following: + + a) cause the modified files to carry prominent notices stating that + you changed the files and the date of any change; and + + b) cause the whole of any work that you distribute or publish, that + in whole or in part contains the Program or any part thereof, either + with or without modifications, to be licensed at no charge to all + third parties under the terms of this General Public License (except + that you may choose to grant warranty protection to some or all + third parties, at your option). + + c) If the modified program normally reads commands interactively when + run, you must cause it, when started running for such interactive use + in the simplest and most usual way, to print or display an + announcement including an appropriate copyright notice and a notice + that there is no warranty (or else, saying that you provide a + warranty) and that users may redistribute the program under these + conditions, and telling the user how to view a copy of this General + Public License. + + d) You may charge a fee for the physical act of transferring a + copy, and you may at your option offer warranty protection in + exchange for a fee. + +Mere aggregation of another independent work with the Program (or its +derivative) on a volume of a storage or distribution medium does not bring +the other work under the scope of these terms. + + 3. You may copy and distribute the Program (or a portion or derivative of +it, under Paragraph 2) in object code or executable form under the terms of +Paragraphs 1 and 2 above provided that you also do one of the following: + + a) accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of + Paragraphs 1 and 2 above; or, + + b) accompany it with a written offer, valid for at least three + years, to give any third party free (except for a nominal charge + for the cost of distribution) a complete machine-readable copy of the + corresponding source code, to be distributed under the terms of + Paragraphs 1 and 2 above; or, + + c) accompany it with the information you received as to where the + corresponding source code may be obtained. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form alone.) + +Source code for a work means the preferred form of the work for making +modifications to it. For an executable file, complete source code means +all the source code for all modules it contains; but, as a special +exception, it need not include source code for modules which are standard +libraries that accompany the operating system on which the executable +file runs, or for standard header files or definitions files that +accompany that operating system. + + 4. You may not copy, modify, sublicense, distribute or transfer the +Program except as expressly provided under this General Public License. +Any attempt otherwise to copy, modify, sublicense, distribute or transfer +the Program is void, and will automatically terminate your rights to use +the Program under this License. However, parties who have received +copies, or rights to use copies, from you under this General Public +License will not have their licenses terminated so long as such parties +remain in full compliance. + + 5. By copying, distributing or modifying the Program (or any work based +on the Program) you indicate your acceptance of this license to do so, +and all its terms and conditions. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the original +licensor to copy, distribute or modify the Program subject to these +terms and conditions. You may not impose any further restrictions on the +recipients' exercise of the rights granted herein. + + 7. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of the license which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +the license, you may choose any version ever published by the Free Software +Foundation. + + 8. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + Appendix: How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to humanity, the best way to achieve this is to make it +free software which everyone can redistribute and change under these +terms. + + To do so, attach the following notices to the program. It is safest to +attach them to the start of each source file to most effectively convey +the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) 19yy + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 1, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) 19xx name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the +appropriate parts of the General Public License. Of course, the +commands you use may be called something other than `show w' and `show +c'; they could even be mouse-clicks or menu items--whatever suits your +program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + program `Gnomovision' (a program to direct compilers to make passes + at assemblers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +That's all there is to it! + +--- end of The GNU General Public License, Version 1, February 1989 --- + + diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP index 5e2f3f3aa..64f490c92 100644 --- a/MANIFEST.SKIP +++ b/MANIFEST.SKIP @@ -1,4 +1,4 @@ -^(?!script/|examples/|lib/|inc/|t/|xt/|Makefile\.PL$|maint/|README$|MANIFEST$|Changes$|META\.(?:yml|json)$) +^(?!script/|examples/|lib/|inc/|t/|xt/|Makefile\.PL$|maint/|README$|MANIFEST$|Changes$|AUTHORS$|LICENSE$|META\.(?:yml|json)$) # Avoid version control files. \bRCS\b diff --git a/Makefile.PL b/Makefile.PL index 492368ef2..5f931f118 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -3,7 +3,13 @@ use warnings; use 5.008001; use inc::Module::Install 1.06; -BEGIN { makemaker_args( NORECURS => 1 ) } # needs to happen early for old EUMM +BEGIN { + # needs to happen early for old EUMM + makemaker_args( NORECURS => 1 ); + + local @INC = ('lib', @INC); + require DBIx::Class::Optional::Dependencies; +} ## ## DO NOT USE THIS HACK IN YOUR DISTS!!! (it makes #toolchain sad) @@ -15,37 +21,15 @@ BEGIN { $Module::Install::AUTHOR = 0 if (grep { $ENV{"PERL5_${_}_IS_RUNNING"} } (qw/CPANM CPANPLUS CPAN/) ); } -homepage 'http://www.dbix-class.org/'; -resources 'IRC' => 'irc://irc.perl.org/#dbix-class'; -resources 'license' => 'http://dev.perl.org/licenses/'; -resources 'repository' => 'https://github.com/dbsrgits/DBIx-Class'; -resources 'MailingList' => 'http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/dbix-class'; -resources 'bugtracker' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBIx-Class'; - -name 'DBIx-Class'; +name 'DBIx-Class'; +version_from 'lib/DBIx/Class.pm'; perl_version '5.008001'; -all_from 'lib/DBIx/Class.pm'; -Meta->{values}{x_authority} = 'cpan:RIBASUSHI'; - -# nothing determined at runtime, except for possibly SQLT dep, see -# comment further down -dynamic_config 0; - -tests_recursive (qw| - t -|); - -install_script (qw| - script/dbicadmin -|); ### ### DO NOT ADD OPTIONAL DEPENDENCIES HERE, EVEN AS recommends() ### All of them *MUST* go to DBIx::Class::Optional::Dependencies ### my $runtime_requires = { - # FIXME - temporary, needs throwing out for something more efficient - 'Data::Compare' => '1.22', # DBI itself should be capable of installation and execution in pure-perl # mode. However it has never been tested yet, so consider XS for the time @@ -69,7 +53,7 @@ my $runtime_requires = { 'Sub::Name' => '0.04', # pure-perl (FatPack-able) libs - 'Class::Accessor::Grouped' => '0.10010', + 'Class::Accessor::Grouped' => '0.10012', 'Class::C3::Componentised' => '1.0009', 'Class::Inspector' => '1.24', 'Config::Any' => '0.20', @@ -78,13 +62,13 @@ my $runtime_requires = { 'Data::Page' => '2.00', 'Devel::GlobalDestruction' => '0.09', 'Hash::Merge' => '0.12', - 'Moo' => '1.002', + 'Moo' => '2.000', 'MRO::Compat' => '0.12', 'Module::Find' => '0.07', 'namespace::clean' => '0.24', 'Path::Class' => '0.18', 'Scope::Guard' => '0.03', - 'SQL::Abstract' => '1.77', + 'SQL::Abstract' => '1.81', 'Try::Tiny' => '0.07', # Technically this is not a core dependency - it is only required @@ -103,40 +87,53 @@ my $test_requires = { 'Test::Warn' => '0.21', 'Test::More' => '0.94', - # needed for testing only, not for operation - # we will move away from this dep eventually, perhaps to DBD::CSV or something -### -### IMPORTANT - do not raise this dependency -### even though many bugfixes are present in newer versions, the general DBIC -### rule is to bend over backwards for available DBDs (given upgrading them is -### often *not* easy or even possible) -### - 'DBD::SQLite' => '1.29', - # this is already a dep of n::c, but just in case - used by t/55namespaces_cleaned.t # remove and do a manual glob-collection if n::c is no longer a dep 'Package::Stash' => '0.28', + + # needed for testing only, not for operation + # we will move away from this dep eventually, perhaps to DBD::CSV or something + %{ DBIx::Class::Optional::Dependencies->req_list_for('test_rdbms_sqlite') }, }; -# if the user has this env var set and no SQLT installed, tests will fail -# Note - this is added as test_requires *directly*, so it gets properly +# if the user has some of these env vars set and the deps are not available, +# tests will fail +# Note - these are added as test_requires *directly*, so they get properly # excluded on META.yml cleansing (even though no dist can be created from this) -# we force this req regarless of author_deps, worst case scenario it will +# we force these reqs regarless of author_deps, worst case scenario they will # be specified twice # -# also note that we *do* set dynamic_config => 0, as this is the only thing -# that we determine dynamically, and in all fairness if someone sets the -# envvar *and* is not running a full Makefile/make/maketest cycle - they get +# also note that we *do* set dynamic_config => 0, as these are the only things +# that we determine dynamically, and in all fairness if someone sets these +# envvars *and* is not running a full Makefile/make/maketest cycle - they get # to keep the pieces -if ($ENV{DBICTEST_SQLT_DEPLOY}) { - local @INC = ('lib', @INC); - require DBIx::Class::Optional::Dependencies; - my $dep_req = DBIx::Class::Optional::Dependencies->req_list_for('deploy'); - for (keys %$dep_req) { - test_requires ($_ => $dep_req->{$_}) +if ( my @optdeps = ( + $ENV{DBICTEST_SQLT_DEPLOY} ? 'deploy' : (), + $ENV{DBICTEST_VIA_REPLICATED} ? 'replicated' : (), +)) { + my $extra_deps = DBIx::Class::Optional::Dependencies->req_list_for(\@optdeps); + for (keys %$extra_deps) { + test_requires ($_ => $extra_deps->{$_}) } } +tests_recursive ( + 't', + ( ( + $Module::Install::AUTHOR + or + $ENV{DBICTEST_RUN_ALL_TESTS} + or + ( $ENV{TRAVIS}||'' ) eq 'true' + or + ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL5_CPANM_IS_RUNNING} and ! $ENV{RELEASE_TESTING} ) + ) ? 'xt' : () ), +); + +install_script (qw| + script/dbicadmin +|); + # this is so we can order requires alphabetically # copies are needed for potential author requires injection my $reqs = { @@ -184,10 +181,22 @@ for my $mod (sort keys %final_req) { # IFF we are running interactively auto_install(); -WriteAll(); +{ + # M::I understands unicode in meta but does not write with the right + # layers - fhtagn!!! + local $SIG{__WARN__} = sub { warn $_[0] unless $_[0] =~ /Wide character in print/ }; + WriteAll(); +} exit 0; + +### +### Nothing user-serviceable beyond this point +### (none of this executes on regular install) +### + + # needs to be here to keep 5.8 string eval happy # (the include of Makefile.PL.inc loop) my $mm_proto; diff --git a/examples/Benchmarks/semicolon_vs_comma_rowparser/comma.src b/examples/Benchmarks/semicolon_vs_comma_rowparser/comma.src new file mode 100644 index 000000000..95d4f964b --- /dev/null +++ b/examples/Benchmarks/semicolon_vs_comma_rowparser/comma.src @@ -0,0 +1,83 @@ +### BEGIN LITERAL STRING EVAL + my $rows_pos = 0; + my ($result_pos, @collapse_idx, $cur_row_data, %cur_row_ids ); + + # this loop is a bit arcane - the rationale is that the passed in + # $_[0] will either have only one row (->next) or will have all + # rows already pulled in (->all and/or unordered). Given that the + # result can be rather large - we reuse the same already allocated + # array, since the collapsed prefetch is smaller by definition. + # At the end we cut the leftovers away and move on. + while ($cur_row_data = ( + ( + $rows_pos >= 0 + and + ( + $_[0][$rows_pos++] + or + # It may be tempting to drop the -1 and undef $rows_pos instead + # thus saving the >= comparison above as well + # However NULL-handlers and underdefined root markers both use + # $rows_pos as a last-resort-uniqueness marker (it either is + # monotonically increasing while we parse ->all, or is set at + # a steady -1 when we are dealing with a single root node). For + # the time being the complication of changing all callsites seems + # overkill, for what is going to be a very modest saving of ops + ( ($rows_pos = -1), undef ) + ) + ) + or + ( $_[1] and $_[1]->() ) + ) ) { + + # the undef checks may or may not be there + # depending on whether we prune or not + # + # due to left joins some of the ids may be NULL/undef, and + # won't play well when used as hash lookups + # we also need to differentiate NULLs on per-row/per-col basis + # (otherwise folding of optional 1:1s will be greatly confused +( @cur_row_ids{( 0, 1, 5, 6, 8, 10 )} = ( +@{$cur_row_data}[( 0, 1, 5, 6, 8, 10 )] + ) ), + + # in the case of an underdefined root - calculate the virtual id (otherwise no code at all) + + + # if we were supplied a coderef - we are collapsing lazily (the set + # is ordered properly) + # as long as we have a result already and the next result is new we + # return the pre-read data and bail +( $_[1] and $result_pos and ! $collapse_idx[0]{ $cur_row_ids{1} } and (unshift @{$_[2]}, $cur_row_data) and last ), + + # the rel assemblers +( $collapse_idx[0]{ $cur_row_ids{1} } //= $_[0][$result_pos++] = [ { "genreid" => $cur_row_data->[4], "latest_cd" => $cur_row_data->[7], "year" => $cur_row_data->[3] } ] ), +( $collapse_idx[0]{ $cur_row_ids{1} }[1]{"existing_single_track"} //= $collapse_idx[1]{ $cur_row_ids{1} } = [ ] ), +( $collapse_idx[1]{ $cur_row_ids{1} }[1]{"cd"} //= $collapse_idx[2]{ $cur_row_ids{1} } = [ ] ), +( $collapse_idx[2]{ $cur_row_ids{1} }[1]{"artist"} //= $collapse_idx[3]{ $cur_row_ids{1} } = [ { "artistid" => $cur_row_data->[1] } ] ), +( ( ! defined $cur_row_data->[6] ) + ? $collapse_idx[3]{ $cur_row_ids{1} }[1]{"cds"} = [] + : do { +( (! $collapse_idx[4]{ $cur_row_ids{1} }{ $cur_row_ids{6} }) and push @{$collapse_idx[3]{ $cur_row_ids{1} }[1]{"cds"}}, $collapse_idx[4]{ $cur_row_ids{1} }{ $cur_row_ids{6} } = [ { "cdid" => $cur_row_data->[6], "genreid" => $cur_row_data->[9], "year" => $cur_row_data->[2] } ] ), +( ( ! defined $cur_row_data->[8] ) + ? $collapse_idx[4]{ $cur_row_ids{1} }{ $cur_row_ids{6} }[1]{"tracks"} = [] + : do { +( (! $collapse_idx[5]{ $cur_row_ids{1} }{ $cur_row_ids{6} }{ $cur_row_ids{8} }) and push @{$collapse_idx[4]{ $cur_row_ids{1} }{ $cur_row_ids{6} }[1]{"tracks"}}, $collapse_idx[5]{ $cur_row_ids{1} }{ $cur_row_ids{6} }{ $cur_row_ids{8} } = [ { "title" => $cur_row_data->[8] } ] ), +} ), +} ), +( ( ! defined $cur_row_data->[5] ) + ? $collapse_idx[0]{ $cur_row_ids{1} }[1]{"tracks"} = [] + : do { +( (! $collapse_idx[6]{ $cur_row_ids{1} }{ $cur_row_ids{5} }) and push @{$collapse_idx[0]{ $cur_row_ids{1} }[1]{"tracks"}}, $collapse_idx[6]{ $cur_row_ids{1} }{ $cur_row_ids{5} } = [ { "title" => $cur_row_data->[5] } ] ), +( ( ! defined $cur_row_data->[10] ) + ? $collapse_idx[6]{ $cur_row_ids{1} }{ $cur_row_ids{5} }[1]{"lyrics"} = [] + : do { +( $collapse_idx[6]{ $cur_row_ids{1} }{ $cur_row_ids{5} }[1]{"lyrics"} //= $collapse_idx[7]{ $cur_row_ids{1} }{ $cur_row_ids{5} }{ $cur_row_ids{10} } = [ ] ), +( (! $collapse_idx[8]{ $cur_row_ids{0} }{ $cur_row_ids{1} }{ $cur_row_ids{5} }{ $cur_row_ids{10} }) and push @{$collapse_idx[7]{ $cur_row_ids{1} }{ $cur_row_ids{5} }{ $cur_row_ids{10} }[1]{"existing_lyric_versions"}}, $collapse_idx[8]{ $cur_row_ids{0} }{ $cur_row_ids{1} }{ $cur_row_ids{5} }{ $cur_row_ids{10} } = [ { "lyric_id" => $cur_row_data->[10], "text" => $cur_row_data->[0] } ] ), +} ), +} ), + + } + + $#{$_[0]} = $result_pos - 1; # truncate the passed in array to where we filled it with results +### END LITERAL STRING EVAL diff --git a/examples/Benchmarks/semicolon_vs_comma_rowparser/semicol.src b/examples/Benchmarks/semicolon_vs_comma_rowparser/semicol.src new file mode 100644 index 000000000..3d33e96a6 --- /dev/null +++ b/examples/Benchmarks/semicolon_vs_comma_rowparser/semicol.src @@ -0,0 +1,83 @@ +### BEGIN LITERAL STRING EVAL + my $rows_pos = 0; + my ($result_pos, @collapse_idx, $cur_row_data, %cur_row_ids ); + + # this loop is a bit arcane - the rationale is that the passed in + # $_[0] will either have only one row (->next) or will have all + # rows already pulled in (->all and/or unordered). Given that the + # result can be rather large - we reuse the same already allocated + # array, since the collapsed prefetch is smaller by definition. + # At the end we cut the leftovers away and move on. + while ($cur_row_data = ( + ( + $rows_pos >= 0 + and + ( + $_[0][$rows_pos++] + or + # It may be tempting to drop the -1 and undef $rows_pos instead + # thus saving the >= comparison above as well + # However NULL-handlers and underdefined root markers both use + # $rows_pos as a last-resort-uniqueness marker (it either is + # monotonically increasing while we parse ->all, or is set at + # a steady -1 when we are dealing with a single root node). For + # the time being the complication of changing all callsites seems + # overkill, for what is going to be a very modest saving of ops + ( ($rows_pos = -1), undef ) + ) + ) + or + ( $_[1] and $_[1]->() ) + ) ) { + + # the undef checks may or may not be there + # depending on whether we prune or not + # + # due to left joins some of the ids may be NULL/undef, and + # won't play well when used as hash lookups + # we also need to differentiate NULLs on per-row/per-col basis + # (otherwise folding of optional 1:1s will be greatly confused +@cur_row_ids{( 0, 1, 5, 6, 8, 10 )} = ( +@{$cur_row_data}[( 0, 1, 5, 6, 8, 10 )] + ); + + # in the case of an underdefined root - calculate the virtual id (otherwise no code at all) + + + # if we were supplied a coderef - we are collapsing lazily (the set + # is ordered properly) + # as long as we have a result already and the next result is new we + # return the pre-read data and bail +$_[1] and $result_pos and ! $collapse_idx[0]{ $cur_row_ids{1} } and (unshift @{$_[2]}, $cur_row_data) and last; + + # the rel assemblers +$collapse_idx[0]{ $cur_row_ids{1} } //= $_[0][$result_pos++] = [ { "genreid" => $cur_row_data->[4], "latest_cd" => $cur_row_data->[7], "year" => $cur_row_data->[3] } ]; +$collapse_idx[0]{ $cur_row_ids{1} }[1]{"existing_single_track"} //= $collapse_idx[1]{ $cur_row_ids{1} } = [ ]; +$collapse_idx[1]{ $cur_row_ids{1} }[1]{"cd"} //= $collapse_idx[2]{ $cur_row_ids{1} } = [ ]; +$collapse_idx[2]{ $cur_row_ids{1} }[1]{"artist"} //= $collapse_idx[3]{ $cur_row_ids{1} } = [ { "artistid" => $cur_row_data->[1] } ]; +( ! defined $cur_row_data->[6] ) + ? $collapse_idx[3]{ $cur_row_ids{1} }[1]{"cds"} = [] + : do { +(! $collapse_idx[4]{ $cur_row_ids{1} }{ $cur_row_ids{6} }) and push @{$collapse_idx[3]{ $cur_row_ids{1} }[1]{"cds"}}, $collapse_idx[4]{ $cur_row_ids{1} }{ $cur_row_ids{6} } = [ { "cdid" => $cur_row_data->[6], "genreid" => $cur_row_data->[9], "year" => $cur_row_data->[2] } ]; +( ! defined $cur_row_data->[8] ) + ? $collapse_idx[4]{ $cur_row_ids{1} }{ $cur_row_ids{6} }[1]{"tracks"} = [] + : do { +(! $collapse_idx[5]{ $cur_row_ids{1} }{ $cur_row_ids{6} }{ $cur_row_ids{8} }) and push @{$collapse_idx[4]{ $cur_row_ids{1} }{ $cur_row_ids{6} }[1]{"tracks"}}, $collapse_idx[5]{ $cur_row_ids{1} }{ $cur_row_ids{6} }{ $cur_row_ids{8} } = [ { "title" => $cur_row_data->[8] } ]; +}; +}; +( ! defined $cur_row_data->[5] ) + ? $collapse_idx[0]{ $cur_row_ids{1} }[1]{"tracks"} = [] + : do { +(! $collapse_idx[6]{ $cur_row_ids{1} }{ $cur_row_ids{5} }) and push @{$collapse_idx[0]{ $cur_row_ids{1} }[1]{"tracks"}}, $collapse_idx[6]{ $cur_row_ids{1} }{ $cur_row_ids{5} } = [ { "title" => $cur_row_data->[5] } ]; +( ! defined $cur_row_data->[10] ) + ? $collapse_idx[6]{ $cur_row_ids{1} }{ $cur_row_ids{5} }[1]{"lyrics"} = [] + : do { +$collapse_idx[6]{ $cur_row_ids{1} }{ $cur_row_ids{5} }[1]{"lyrics"} //= $collapse_idx[7]{ $cur_row_ids{1} }{ $cur_row_ids{5} }{ $cur_row_ids{10} } = [ ]; +(! $collapse_idx[8]{ $cur_row_ids{0} }{ $cur_row_ids{1} }{ $cur_row_ids{5} }{ $cur_row_ids{10} }) and push @{$collapse_idx[7]{ $cur_row_ids{1} }{ $cur_row_ids{5} }{ $cur_row_ids{10} }[1]{"existing_lyric_versions"}}, $collapse_idx[8]{ $cur_row_ids{0} }{ $cur_row_ids{1} }{ $cur_row_ids{5} }{ $cur_row_ids{10} } = [ { "lyric_id" => $cur_row_data->[10], "text" => $cur_row_data->[0] } ]; +}; +}; + + } + + $#{$_[0]} = $result_pos - 1; # truncate the passed in array to where we filled it with results +### END LITERAL STRING EVAL diff --git a/examples/Benchmarks/semicolon_vs_comma_rowparser/sloppy_bench.pl b/examples/Benchmarks/semicolon_vs_comma_rowparser/sloppy_bench.pl new file mode 100644 index 000000000..fb12fb89c --- /dev/null +++ b/examples/Benchmarks/semicolon_vs_comma_rowparser/sloppy_bench.pl @@ -0,0 +1,28 @@ +use warnings; +use strict; + +use Benchmark qw( cmpthese :hireswallclock); +use Sereal; +use Devel::Dwarn; + +my ($semicol, $comma) = map { + my $src = do { local (@ARGV, $/) = $_; <> }; + eval "sub { use strict; use warnings; use warnings FATAL => 'uninitialized'; $src }" or die $@; +} qw( semicol.src comma.src ); + +my $enc = Sereal::Encoder->new; +my $dec = Sereal::Decoder->new; + +for my $iters ( 100, 10_000, 100_000 ) { + my $dataset = []; + push @$dataset, [ (scalar @$dataset) x 11 ] + while @$dataset < $iters; + + my $ice = $enc->encode($dataset); + + print "\nTiming $iters 'rows'...\n"; + cmpthese( -10, { + semicol => sub { $semicol->($dec->decode($ice)) }, + comma => sub { $comma->($dec->decode($ice)) }, + }) +} diff --git a/examples/Schema/MyApp/Schema/Result/Artist.pm b/examples/Schema/MyApp/Schema/Result/Artist.pm index 70074b17d..3cde36c92 100644 --- a/examples/Schema/MyApp/Schema/Result/Artist.pm +++ b/examples/Schema/MyApp/Schema/Result/Artist.pm @@ -21,7 +21,7 @@ __PACKAGE__->set_primary_key('artistid'); __PACKAGE__->add_unique_constraint([qw( name )]); -__PACKAGE__->has_many('cds' => 'MyApp::Schema::Result::Cd'); +__PACKAGE__->has_many('cds' => 'MyApp::Schema::Result::Cd', 'artistid'); 1; diff --git a/examples/Schema/MyApp/Schema/Result/Cd.pm b/examples/Schema/MyApp/Schema/Result/Cd.pm index 9b0602c24..d78874409 100644 --- a/examples/Schema/MyApp/Schema/Result/Cd.pm +++ b/examples/Schema/MyApp/Schema/Result/Cd.pm @@ -12,7 +12,7 @@ __PACKAGE__->add_columns( data_type => 'integer', is_auto_increment => 1 }, - artist => { + artistid => { data_type => 'integer', }, title => { @@ -26,9 +26,9 @@ __PACKAGE__->add_columns( __PACKAGE__->set_primary_key('cdid'); -__PACKAGE__->add_unique_constraint([qw( title artist )]); +__PACKAGE__->add_unique_constraint([qw( title artistid )]); -__PACKAGE__->belongs_to('artist' => 'MyApp::Schema::Result::Artist'); -__PACKAGE__->has_many('tracks' => 'MyApp::Schema::Result::Track'); +__PACKAGE__->belongs_to('artist' => 'MyApp::Schema::Result::Artist', 'artistid'); +__PACKAGE__->has_many('tracks' => 'MyApp::Schema::Result::Track', 'cdid'); 1; diff --git a/examples/Schema/MyApp/Schema/Result/Track.pm b/examples/Schema/MyApp/Schema/Result/Track.pm index dc0951a7c..a32a27e89 100644 --- a/examples/Schema/MyApp/Schema/Result/Track.pm +++ b/examples/Schema/MyApp/Schema/Result/Track.pm @@ -12,7 +12,7 @@ __PACKAGE__->add_columns( data_type => 'integer', is_auto_increment => 1 }, - cd => { + cdid => { data_type => 'integer', }, title => { @@ -22,8 +22,8 @@ __PACKAGE__->add_columns( __PACKAGE__->set_primary_key('trackid'); -__PACKAGE__->add_unique_constraint([qw( title cd )]); +__PACKAGE__->add_unique_constraint([qw( title cdid )]); -__PACKAGE__->belongs_to('cd' => 'MyApp::Schema::Result::Cd'); +__PACKAGE__->belongs_to('cd' => 'MyApp::Schema::Result::Cd', 'cdid'); 1; diff --git a/examples/Schema/insertdb.pl b/examples/Schema/insertdb.pl index c57460e73..ae919b372 100755 --- a/examples/Schema/insertdb.pl +++ b/examples/Schema/insertdb.pl @@ -31,7 +31,7 @@ } $schema->populate('Cd', [ - [qw/title artist/], + [qw/title artistid/], @cds, ]); @@ -55,6 +55,6 @@ } $schema->populate('Track',[ - [qw/cd title/], + [qw/cdid title/], @tracks, ]); diff --git a/examples/Schema/testdb.pl b/examples/Schema/testdb.pl index 2a1061a51..32cbd6daf 100755 --- a/examples/Schema/testdb.pl +++ b/examples/Schema/testdb.pl @@ -53,7 +53,8 @@ sub get_tracks_by_artist { } ); while (my $track = $rs->next) { - print $track->title . "\n"; + print $track->title . " (from the CD '" . $track->cd->title + . "')\n"; } print "\n"; } @@ -70,7 +71,7 @@ sub get_cd_by_track { } ); my $cd = $rs->first; - print $cd->title . "\n\n"; + print $cd->title . " has the track '$tracktitle'.\n\n"; } sub get_cds_by_artist { @@ -104,7 +105,7 @@ sub get_artist_by_track { } ); my $artist = $rs->first; - print $artist->name . "\n\n"; + print $artist->name . " recorded the track '$tracktitle'.\n\n"; } sub get_artist_by_cd { @@ -119,5 +120,5 @@ sub get_artist_by_cd { } ); my $artist = $rs->first; - print $artist->name . "\n\n"; + print $artist->name . " recorded the CD '$cdtitle'.\n\n"; } diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm index ba237a2ee..863cb190b 100644 --- a/lib/DBIx/Class.pm +++ b/lib/DBIx/Class.pm @@ -11,7 +11,7 @@ our $VERSION; # $VERSION declaration must stay up here, ahead of any other package # declarations, as to not confuse various modules attempting to determine # this ones version, whether that be s.c.o. or Module::Metadata, etc -$VERSION = '0.08270'; +$VERSION = '0.082899_15'; $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases @@ -25,7 +25,14 @@ use DBIx::Class::StartupCheck; use DBIx::Class::Exception; __PACKAGE__->mk_group_accessors(inherited => '_skip_namespace_frames'); -__PACKAGE__->_skip_namespace_frames('^DBIx::Class|^SQL::Abstract|^Try::Tiny|^Class::Accessor::Grouped|^Context::Preserve'); +__PACKAGE__->_skip_namespace_frames('^DBIx::Class|^SQL::Abstract|^Try::Tiny|^Class::Accessor::Grouped|^Context::Preserve|^Moose::Meta::'); + +# FIXME - this is not really necessary, and is in +# fact going to slow things down a bit +# However it is the right thing to do in order to get +# various install bases to highlight their brokenness +# Remove at some unknown point in the future +sub DESTROY { &DBIx::Class::_Util::detected_reinvoked_destructor } sub mk_classdata { shift->mk_classaccessor(@_); @@ -57,12 +64,16 @@ sub _attr_cache { }; } +# *DO NOT* change this URL nor the identically named =head1 below +# it is linked throughout the ecosystem +sub DBIx::Class::_ENV_::HELP_URL () { + 'http://p3rl.org/DBIx::Class#GETTING_HELP/SUPPORT' +} + 1; __END__ -=encoding UTF-8 - =head1 NAME DBIx::Class - Extensible and flexible object <-> relational mapper. @@ -74,13 +85,15 @@ To get the most out of DBIx::Class with the least confusion it is strongly recommended to read (at the very least) the L in the order presented there. -=head1 HOW TO GET HELP +=cut + +=head1 GETTING HELP/SUPPORT -Due to the complexity of its problem domain, DBIx::Class is a relatively +Due to the sheer size of its problem domain, DBIx::Class is a relatively complex framework. After you start using DBIx::Class questions will inevitably arise. If you are stuck with a problem or have doubts about a particular -approach do not hesitate to contact the community with your questions. The -list below is sorted by "fastest response time": +approach do not hesitate to contact us via any of the following options (the +list is sorted by "fastest response time"): =over @@ -249,8 +262,10 @@ Contributions are always welcome, in all usable forms (we especially welcome documentation improvements). The delivery methods include git- or unified-diff formatted patches, GitHub pull requests, or plain bug reports either via RT or the Mailing list. Contributors are generally -granted full access to the official repository after their first patch -passes successful review. +granted access to the official repository after their first several +patches pass successful review. Don't hesitate to +L either of the L with +any further questions you may have. =for comment FIXME: Getty, frew and jnap need to get off their asses and finish the contrib section so we can link it here ;) @@ -275,279 +290,44 @@ accessible at the following locations: =back -=head1 AUTHOR - -mst: Matt S. Trout - -(I mostly consider myself "project founder" these days but the AUTHOR heading -is traditional :) - -=head1 CONTRIBUTORS - -abraxxa: Alexander Hartmaier - -acca: Alexander Kuznetsov - -aherzog: Adam Herzog - -Alexander Keusch - -alexrj: Alessandro Ranellucci - -alnewkirk: Al Newkirk - -amiri: Amiri Barksdale - -amoore: Andrew Moore - -andrewalker: Andre Walker - -andyg: Andy Grundman - -ank: Andres Kievsky - -arc: Aaron Crane - -arcanez: Justin Hunter - -ash: Ash Berlin - -bert: Norbert Csongrádi - -blblack: Brandon L. Black - -bluefeet: Aran Deltac - -bphillips: Brian Phillips - -boghead: Bryan Beeley - -brd: Brad Davis - -bricas: Brian Cassidy - -brunov: Bruno Vecchi - -caelum: Rafael Kitover - -caldrin: Maik Hentsche - -castaway: Jess Robinson - -claco: Christopher H. Laco - -clkao: CL Kao - -da5id: David Jack Olrik - -dariusj: Darius Jokilehto - -davewood: David Schmidt - -daxim: Lars Dɪᴇᴄᴋᴏᴡ 迪拉斯 - -debolaz: Anders Nor Berle - -dew: Dan Thomas - -dkubb: Dan Kubb - -dnm: Justin Wheeler - -dpetrov: Dimitar Petrov - -dwc: Daniel Westermann-Clark - -dyfrgi: Michael Leuchtenburg - -edenc: Eden Cardim - -ether: Karen Etheridge - -felliott: Fitz Elliott - -freetime: Bill Moseley - -frew: Arthur Axel "fREW" Schmidt - -goraxe: Gordon Irving - -gphat: Cory G Watson - -Grant Street Group L - -groditi: Guillermo Roditi - -Haarg: Graham Knop - -hobbs: Andrew Rodland - -ilmari: Dagfinn Ilmari MannsEker - -initself: Mike Baas - -ironcamel: Naveed Massjouni - -jawnsy: Jonathan Yu - -jasonmay: Jason May - -jesper: Jesper Krogh - -jgoulah: John Goulah - -jguenther: Justin Guenther +=head1 AUTHORS -jhannah: Jay Hannah +Even though a large portion of the source I to be written by just a +handful of people, this library continues to remain a collaborative effort - +perhaps one of the most successful such projects on L. +It is important to remember that ideas do not always result in a direct code +contribution, but deserve acknowledgement just the same. Time and time again +the seemingly most insignificant questions and suggestions have been shown +to catalyze monumental improvements in consistency, accuracy and performance. -jmac: Jason McIntosh +=for comment this line is replaced with the author list at dist-building time -jnapiorkowski: John Napiorkowski +The canonical source of authors and their details is the F file at +the root of this distribution (or repository). The canonical source of +per-line authorship is the L history +itself. -jon: Jon Schutz +=head1 CAT HERDERS -jshirley: J. Shirley +The fine folks nudging the project in a particular direction: -kaare: Kaare Rasmussen - -konobi: Scott McWhirter - -littlesavage: Alexey Illarionov - -lukes: Luke Saunders - -marcus: Marcus Ramberg - -mattlaw: Matt Lawrence - -mattp: Matt Phillips - -michaelr: Michael Reddick - -milki: Jonathan Chu - -mithaldu: Christian Walde - -mjemmeson: Michael Jemmeson - -mstratman: Mark A. Stratman - -ned: Neil de Carteret - -nigel: Nigel Metheringham - -ningu: David Kamholz - -Nniuq: Ron "Quinn" Straight" - -norbi: Norbert Buchmuller - -nuba: Nuba Princigalli - -Numa: Dan Sully - -ovid: Curtis "Ovid" Poe - -oyse: Eystein Torget - -paulm: Paul Makepeace - -penguin: K J Cheetham - -perigrin: Chris Prather - -peter: Peter Collingbourne - -Peter Siklósi - -Peter Valdemar MErch - -phaylon: Robert Sedlacek - -plu: Johannes Plunien - -Possum: Daniel LeWarne - -quicksilver: Jules Bean - -rafl: Florian Ragwitz - -rainboxx: Matthias Dietrich - -rbo: Robert Bohne - -rbuels: Robert Buels - -rdj: Ryan D Johnson - -ribasushi: Peter Rabbitson - -rjbs: Ricardo Signes - -robkinyon: Rob Kinyon - -Robert Olson - -moltar: Roman Filippov - -Sadrak: Felix Antonius Wilhelm Ostmann - -sc_: Just Another Perl Hacker - -scotty: Scotty Allen - -semifor: Marc Mims - -SineSwiper: Brendan Byrd - -solomon: Jared Johnson - -spb: Stephen Bennett - -Squeeks - -sszabo: Stephan Szabo - -talexb: Alex Beamish - -tamias: Ronald J Kimball - -teejay : Aaron Trevena - -Todd Lipcon - -Tom Hukins - -tonvoon: Ton Voon - -triode: Pete Gamache - -typester: Daisuke Murase - -victori: Victor Igumnov - -wdh: Will Hawes - -wesm: Wes Malone - -willert: Sebastian Willert - -wreis: Wallace Reis - -xenoterracide: Caleb Cushing +=over -yrlnry: Mark Jason Dominus +B: Peter Rabbitson +(present day maintenance and controlled evolution) -zamolxes: Bogdan Lucaciu +B: Jess Robinson +(lions share of the reference documentation and manuals) -Zefram: Andrew Main +B: Matt S Trout (project founder - +original idea, architecture and implementation) -=head1 COPYRIGHT +=back -Copyright (c) 2005 - 2011 the DBIx::Class L and L -as listed above. +=head1 COPYRIGHT AND LICENSE -=head1 LICENSE +Copyright (c) 2005 by mst, castaway, ribasushi, and other DBIx::Class +L as listed above and in F. This library is free software and may be distributed under the same terms -as perl itself. +as perl5 itself. See F for the complete licensing terms. diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm index c999a6b49..ea25e4f79 100644 --- a/lib/DBIx/Class/AccessorGroup.pm +++ b/lib/DBIx/Class/AccessorGroup.pm @@ -44,13 +44,15 @@ DBIx::Class::AccessorGroup - See Class::Accessor::Grouped This class now exists in its own right on CPAN as Class::Accessor::Grouped -=head1 AUTHOR AND CONTRIBUTORS +=head1 FURTHER QUESTIONS? -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut - diff --git a/lib/DBIx/Class/Admin.pm b/lib/DBIx/Class/Admin.pm index b30aa0a3b..65c703dc4 100644 --- a/lib/DBIx/Class/Admin.pm +++ b/lib/DBIx/Class/Admin.pm @@ -1,10 +1,14 @@ package DBIx::Class::Admin; +use warnings; +use strict; + # check deps BEGIN { - use DBIx::Class; - die('The following modules are required for DBIx::Class::Admin ' . DBIx::Class::Optional::Dependencies->req_missing_for ('admin') ) - unless DBIx::Class::Optional::Dependencies->req_ok_for ('admin'); + require DBIx::Class::Optional::Dependencies; + if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('admin') ) { + die "The following extra modules are required for DBIx::Class::Admin: $missing\n"; + } } use JSON::Any qw(DWIW PP JSON CPANEL XS); @@ -15,7 +19,7 @@ use MooseX::Types::JSON qw(JSON); use MooseX::Types::Path::Class qw(Dir File); use MooseX::Types::LoadableClass qw(LoadableClass); use Try::Tiny; -use namespace::autoclean; +use namespace::clean; =head1 NAME @@ -339,8 +343,6 @@ sub create { $sqlt_type ||= $self->sql_type(); my $schema = $self->schema(); - # create the dir if does not exist - $self->sql_dir->mkpath() if ( ! -d $self->sql_dir); $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $preversion, $sqlt_args ); } @@ -451,7 +453,7 @@ sub insert { $rs ||= $self->resultset(); $set ||= $self->set(); my $resultset = $self->schema->resultset($rs); - my $obj = $resultset->create( $set ); + my $obj = $resultset->new_result($set)->insert; print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet); } @@ -582,13 +584,16 @@ sub _find_stanza { return $cfg; } -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -See L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut diff --git a/lib/DBIx/Class/Admin/Usage.pm b/lib/DBIx/Class/Admin/Usage.pm index e703edea0..d479ae5dc 100644 --- a/lib/DBIx/Class/Admin/Usage.pm +++ b/lib/DBIx/Class/Admin/Usage.pm @@ -41,7 +41,7 @@ sub pod_authorlic_text { return join ("\n\n", '=head1 AUTHORS', - 'See L', + 'See L', '=head1 LICENSE', 'You may distribute this code under the same terms as Perl itself', '=cut', diff --git a/lib/DBIx/Class/CDBICompat.pm b/lib/DBIx/Class/CDBICompat.pm index ee983fd7e..f3697c217 100644 --- a/lib/DBIx/Class/CDBICompat.pm +++ b/lib/DBIx/Class/CDBICompat.pm @@ -2,22 +2,15 @@ package DBIx::Class::CDBICompat; use strict; use warnings; -use base qw/DBIx::Class::Core DBIx::Class::DB/; - -# Modules CDBICompat needs that DBIx::Class does not. -my @Extra_Modules = qw( - Class::Trigger - DBIx::ContextualFetch - Clone -); -my @didnt_load; -for my $module (@Extra_Modules) { - push @didnt_load, $module unless eval qq{require $module}; +BEGIN { + require DBIx::Class::Optional::Dependencies; + if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for('cdbicompat')) { + die "The following extra modules are required for DBIx::Class::CDBICompat: $missing\n"; + } } -__PACKAGE__->throw_exception("@{[ join ', ', @didnt_load ]} are missing and are required for CDBICompat") - if @didnt_load; +use base qw/DBIx::Class::Core DBIx::Class::DB/; __PACKAGE__->load_own_components(qw/ Constraints @@ -45,9 +38,10 @@ __PACKAGE__->load_own_components(qw/ Iterator /); - #DBIx::Class::ObjIndexStubs 1; +__END__ + =head1 NAME DBIx::Class::CDBICompat - Class::DBI Compatibility layer. @@ -165,13 +159,13 @@ Relationships between tables (has_a, has_many...) must be declared after all tab =back -=head1 AUTHOR AND CONTRIBUTORS - -See L and L in DBIx::Class - -=head1 LICENSE +=head1 FURTHER QUESTIONS? -You may distribute this code under the same terms as Perl itself. +Check the list of L. -=cut +=head1 COPYRIGHT AND LICENSE +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/CDBICompat/AbstractSearch.pm b/lib/DBIx/Class/CDBICompat/AbstractSearch.pm index 4192c4797..8f5910614 100644 --- a/lib/DBIx/Class/CDBICompat/AbstractSearch.pm +++ b/lib/DBIx/Class/CDBICompat/AbstractSearch.pm @@ -34,4 +34,17 @@ sub search_where { return $class->resultset_instance->search($where, $attr); } +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. + +=cut + 1; diff --git a/lib/DBIx/Class/CDBICompat/AccessorMapping.pm b/lib/DBIx/Class/CDBICompat/AccessorMapping.pm index 1ea49e877..15559371c 100644 --- a/lib/DBIx/Class/CDBICompat/AccessorMapping.pm +++ b/lib/DBIx/Class/CDBICompat/AccessorMapping.pm @@ -4,14 +4,21 @@ package # hide from PAUSE Indexer use strict; use warnings; +use Scalar::Util 'blessed'; +use namespace::clean; + sub mk_group_accessors { my ($class, $group, @cols) = @_; foreach my $col (@cols) { - my($accessor, $col) = ref $col ? @$col : (undef, $col); + my($accessor, $col) = ref $col eq 'ARRAY' ? @$col : (undef, $col); my($ro_meth, $wo_meth); - if( defined $accessor and ($accessor ne $col)) { + if (defined blessed $col and $col->isa('Class::DBI::Column')) { + $ro_meth = $col->accessor; + $wo_meth = $col->mutator; + } + elsif (defined $accessor and ($accessor ne $col)) { $ro_meth = $wo_meth = $accessor; } else { diff --git a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm index d804d029c..f4c8ac80a 100644 --- a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm +++ b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm @@ -4,7 +4,6 @@ package # hide from PAUSE use strict; use warnings; use Sub::Name (); -use Storable 'dclone'; use List::Util (); use base qw/DBIx::Class::Row/; @@ -43,7 +42,7 @@ sub _register_column_group { # Must do a complete deep copy else column groups # might accidentally be shared. - my $groups = dclone $class->_column_groups; + my $groups = DBIx::Class::_Util::deep_clone( $class->_column_groups ); if ($group eq 'Primary') { $class->set_primary_key(@cols); diff --git a/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm b/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm index 4e47ed3de..c5c1fe179 100644 --- a/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm +++ b/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm @@ -102,4 +102,17 @@ sub STORE { : $obj->set_column($col => shift); } +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. + +=cut + 1; diff --git a/lib/DBIx/Class/CDBICompat/Constructor.pm b/lib/DBIx/Class/CDBICompat/Constructor.pm index f2e78b925..65ce576f1 100644 --- a/lib/DBIx/Class/CDBICompat/Constructor.pm +++ b/lib/DBIx/Class/CDBICompat/Constructor.pm @@ -1,14 +1,13 @@ package # hide from PAUSE DBIx::Class::CDBICompat::Constructor; -use base qw(DBIx::Class::CDBICompat::ImaDBI); - -use Sub::Name(); - use strict; use warnings; +use base 'DBIx::Class::CDBICompat::ImaDBI'; + use Carp; +use DBIx::Class::_Util qw(quote_sub perlstring); __PACKAGE__->set_sql(Retrieve => <<''); SELECT __ESSENTIAL__ @@ -17,17 +16,16 @@ WHERE %s sub add_constructor { my ($class, $method, $fragment) = @_; - return croak("constructors needs a name") unless $method; - no strict 'refs'; - my $meth = "$class\::$method"; - return carp("$method already exists in $class") - if *$meth{CODE}; + croak("constructors needs a name") unless $method; + + carp("$method already exists in $class") && return + if $class->can($method); - *$meth = Sub::Name::subname $meth => sub { - my $self = shift; - $self->sth_to_objects($self->sql_Retrieve($fragment), \@_); - }; + quote_sub "${class}::${method}" => sprintf( <<'EOC', perlstring $fragment ); + my $self = shift; + $self->sth_to_objects($self->sql_Retrieve(%s), \@_); +EOC } 1; diff --git a/lib/DBIx/Class/CDBICompat/Copy.pm b/lib/DBIx/Class/CDBICompat/Copy.pm index 0ab6092f6..77e7b5be7 100644 --- a/lib/DBIx/Class/CDBICompat/Copy.pm +++ b/lib/DBIx/Class/CDBICompat/Copy.pm @@ -33,4 +33,17 @@ sub copy { return $self->next::method({ $primary_columns[0] => $arg }); } +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. + +=cut + 1; diff --git a/lib/DBIx/Class/CDBICompat/DestroyWarning.pm b/lib/DBIx/Class/CDBICompat/DestroyWarning.pm index 115bf3d5b..61d243c42 100644 --- a/lib/DBIx/Class/CDBICompat/DestroyWarning.pm +++ b/lib/DBIx/Class/CDBICompat/DestroyWarning.pm @@ -3,8 +3,12 @@ package # hide from PAUSE use strict; use warnings; +use DBIx::Class::_Util 'detected_reinvoked_destructor'; +use namespace::clean; sub DESTROY { + return if &detected_reinvoked_destructor; + my ($self) = @_; my $class = ref $self; warn "$class $self destroyed without saving changes to " diff --git a/lib/DBIx/Class/CDBICompat/ImaDBI.pm b/lib/DBIx/Class/CDBICompat/ImaDBI.pm index aaa19a02e..0ec699386 100644 --- a/lib/DBIx/Class/CDBICompat/ImaDBI.pm +++ b/lib/DBIx/Class/CDBICompat/ImaDBI.pm @@ -4,66 +4,13 @@ package # hide from PAUSE use strict; use warnings; use DBIx::ContextualFetch; -use Sub::Name (); +use DBIx::Class::_Util qw(quote_sub perlstring); use base qw(Class::Data::Inheritable); __PACKAGE__->mk_classdata('sql_transformer_class' => 'DBIx::Class::CDBICompat::SQLTransformer'); -__PACKAGE__->mk_classdata('_transform_sql_handler_order' - => [ qw/TABLE ESSENTIAL JOIN IDENTIFIER/ ] ); - -__PACKAGE__->mk_classdata('_transform_sql_handlers' => - { - 'TABLE' => - sub { - my ($self, $class, $data) = @_; - return $class->result_source_instance->name unless $data; - my ($f_class, $alias) = split(/=/, $data); - $f_class ||= $class; - $self->{_classes}{$alias} = $f_class; - return $f_class->result_source_instance->name." ${alias}"; - }, - 'ESSENTIAL' => - sub { - my ($self, $class, $data) = @_; - $class = $data ? $self->{_classes}{$data} : $class; - return join(', ', $class->columns('Essential')); - }, - 'IDENTIFIER' => - sub { - my ($self, $class, $data) = @_; - $class = $data ? $self->{_classes}{$data} : $class; - return join ' AND ', map "$_ = ?", $class->primary_columns; - }, - 'JOIN' => - sub { - my ($self, $class, $data) = @_; - my ($from, $to) = split(/ /, $data); - my ($from_class, $to_class) = @{$self->{_classes}}{$from, $to}; - my ($rel_obj) = grep { $_->{class} && $_->{class} eq $to_class } - map { $from_class->relationship_info($_) } - $from_class->relationships; - unless ($rel_obj) { - ($from, $to) = ($to, $from); - ($from_class, $to_class) = ($to_class, $from_class); - ($rel_obj) = grep { $_->{class} && $_->{class} eq $to_class } - map { $from_class->relationship_info($_) } - $from_class->relationships; - } - $self->throw_exception( "No relationship to JOIN from ${from_class} to ${to_class}" ) - unless $rel_obj; - my $join = $from_class->storage->sql_maker->_join_condition( - scalar $from_class->result_source_instance->_resolve_condition( - $rel_obj->{cond}, $to, $from - ) - ); - return $join; - } - - } ); - sub db_Main { return $_[0]->storage->dbh; } @@ -81,26 +28,20 @@ sub __driver { sub set_sql { my ($class, $name, $sql) = @_; - no strict 'refs'; - my $sql_name = "sql_${name}"; - my $full_sql_name = join '::', $class, $sql_name; - *$full_sql_name = Sub::Name::subname $full_sql_name, - sub { - my $sql = $sql; - my $class = shift; - return $class->storage->dbh_do( - _prepare_sth => $class->transform_sql($sql, @_) - ); - }; - if ($sql =~ /select/i) { - my $search_name = "search_${name}"; - my $full_search_name = join '::', $class, $search_name; - *$full_search_name = Sub::Name::subname $full_search_name, - sub { - my ($class, @args) = @_; - my $sth = $class->$sql_name; - return $class->sth_to_objects($sth, \@args); - }; + + quote_sub "${class}::sql_${name}", sprintf( <<'EOC', perlstring $sql ); + my $class = shift; + return $class->storage->dbh_do( + _prepare_sth => $class->transform_sql(%s, @_) + ); +EOC + + + if ($sql =~ /select/i) { # FIXME - this should be anchore surely...? + quote_sub "${class}::search_${name}", sprintf( <<'EOC', "sql_$name" ); + my ($class, @args) = @_; + $class->sth_to_objects( $class->%s, \@args); +EOC } } diff --git a/lib/DBIx/Class/CDBICompat/Iterator.pm b/lib/DBIx/Class/CDBICompat/Iterator.pm index eb60177af..86a3838c4 100644 --- a/lib/DBIx/Class/CDBICompat/Iterator.pm +++ b/lib/DBIx/Class/CDBICompat/Iterator.pm @@ -32,9 +32,21 @@ sub _init_result_source_instance { return $table; } +=head1 FURTHER QUESTIONS? +Check the list of L. -package DBIx::Class::CDBICompat::Iterator::ResultSet; +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. + +=cut + +package # hide + DBIx::Class::CDBICompat::Iterator::ResultSet; use strict; use warnings; diff --git a/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm b/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm index 5dd626803..f3c472da4 100644 --- a/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm +++ b/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm @@ -31,4 +31,17 @@ sub remove_from_object_index {} sub clear_object_index {} +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. + +=cut + 1; diff --git a/lib/DBIx/Class/CDBICompat/Pager.pm b/lib/DBIx/Class/CDBICompat/Pager.pm index 36fbce9b1..203b59855 100644 --- a/lib/DBIx/Class/CDBICompat/Pager.pm +++ b/lib/DBIx/Class/CDBICompat/Pager.pm @@ -2,6 +2,10 @@ package # hide from PAUSE DBIx::Class::CDBICompat::Pager; use strict; + +# even though fatalization has been proven over and over to be a universally +# bad idea, this line has been part of the code from the beginning +# leaving the compat layer as-is, something may in fact depend on that use warnings FATAL => 'all'; *pager = \&page; diff --git a/lib/DBIx/Class/CDBICompat/Relationship.pm b/lib/DBIx/Class/CDBICompat/Relationship.pm index b0c10fae6..95e414d1c 100644 --- a/lib/DBIx/Class/CDBICompat/Relationship.pm +++ b/lib/DBIx/Class/CDBICompat/Relationship.pm @@ -3,7 +3,8 @@ package use strict; use warnings; -use Sub::Name (); + +use DBIx::Class::_Util 'quote_sub'; =head1 NAME @@ -23,20 +24,26 @@ my %method2key = ( args => 'args', ); +quote_sub __PACKAGE__ . "::$_" => "\$_[0]->{$method2key{$_}}" + for keys %method2key; + sub new { my($class, $args) = @_; return bless $args, $class; } -for my $method (keys %method2key) { - my $key = $method2key{$method}; - my $code = sub { - $_[0]->{$key}; - }; +=head1 FURTHER QUESTIONS? - no strict 'refs'; - *{$method} = Sub::Name::subname $method, $code; -} +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. + +=cut 1; diff --git a/lib/DBIx/Class/CDBICompat/Relationships.pm b/lib/DBIx/Class/CDBICompat/Relationships.pm index 58b29e06c..05afe748b 100644 --- a/lib/DBIx/Class/CDBICompat/Relationships.pm +++ b/lib/DBIx/Class/CDBICompat/Relationships.pm @@ -3,11 +3,11 @@ package # hide from PAUSE use strict; use warnings; -use Sub::Name (); -use base qw/Class::Data::Inheritable/; +use base 'Class::Data::Inheritable'; use Clone; use DBIx::Class::CDBICompat::Relationship; +use DBIx::Class::_Util qw(quote_sub perlstring); __PACKAGE__->mk_classdata('__meta_info' => {}); @@ -40,6 +40,13 @@ sub _declare_has_a { my $rel_info; + # Class::DBI allows Non database has_a with implicit deflate and inflate + # Hopefully the following will catch Non-database tables. + if( !$f_class->isa('DBIx::Class::Row') and !$f_class->isa('Class::DBI::Row') ) { + $args{'inflate'} ||= sub { $f_class->new(shift) }; # implicit inflate by calling new + $args{'deflate'} ||= sub { shift() . '' }; # implicit deflate by stringification + } + if ($args{'inflate'} || $args{'deflate'}) { # Non-database has_a if (!ref $args{'inflate'}) { my $meth = $args{'inflate'}; @@ -119,19 +126,14 @@ sub has_many { ); if (@f_method) { - no strict 'refs'; - no warnings 'redefine'; - my $post_proc = sub { my $o = shift; $o = $o->$_ for @f_method; $o; }; - my $name = join '::', $class, $rel; - *$name = Sub::Name::subname $name, - sub { - my $rs = shift->search_related($rel => @_); - $rs->{attrs}{record_filter} = $post_proc; - return (wantarray ? $rs->all : $rs); - }; + quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel), { '$rf' => \sub { my $o = shift; $o = $o->$_ for @f_method; $o } }; + my $rs = shift->search_related( %s => @_); + $rs->{attrs}{record_filter} = $rf; + return (wantarray ? $rs->all : $rs); +EOC + return 1; } - } @@ -160,14 +162,19 @@ sub might_have { sub _extend_meta { my ($class, $type, $rel, $val) = @_; - my %hash = %{ Clone::clone($class->__meta_info || {}) }; + +### Explicitly not using the deep cloner as Clone exhibits specific behavior +### wrt CODE references - it simply passes them as-is to the new structure +### (without deparse/eval cycles). There likely is code that relies on this +### so we just let sleeping dogs lie. + my $hash = Clone::clone($class->__meta_info || {}); $val->{self_class} = $class; $val->{type} = $type; $val->{accessor} = $rel; - $hash{$type}{$rel} = DBIx::Class::CDBICompat::Relationship->new($val); - $class->__meta_info(\%hash); + $hash->{$type}{$rel} = DBIx::Class::CDBICompat::Relationship->new($val); + $class->__meta_info($hash); } @@ -200,4 +207,21 @@ sub search { $self->next::method($where, $attrs); } +sub new_related { + return shift->search_related(shift)->new_result(shift); +} + +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. + +=cut + 1; diff --git a/lib/DBIx/Class/CDBICompat/Retrieve.pm b/lib/DBIx/Class/CDBICompat/Retrieve.pm index 34be5f383..87f531818 100644 --- a/lib/DBIx/Class/CDBICompat/Retrieve.pm +++ b/lib/DBIx/Class/CDBICompat/Retrieve.pm @@ -2,8 +2,11 @@ package # hide from PAUSE DBIx::Class::CDBICompat::Retrieve; use strict; -use warnings FATAL => 'all'; +# even though fatalization has been proven over and over to be a universally +# bad idea, this line has been part of the code from the beginning +# leaving the compat layer as-is, something may in fact depend on that +use warnings FATAL => 'all'; sub retrieve { my $self = shift; diff --git a/lib/DBIx/Class/CDBICompat/SQLTransformer.pm b/lib/DBIx/Class/CDBICompat/SQLTransformer.pm index 711c464c5..fd54b7e21 100644 --- a/lib/DBIx/Class/CDBICompat/SQLTransformer.pm +++ b/lib/DBIx/Class/CDBICompat/SQLTransformer.pm @@ -100,5 +100,17 @@ sub _do_transformation { return 1; } -1; +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. +=cut + +1; diff --git a/lib/DBIx/Class/Carp.pm b/lib/DBIx/Class/Carp.pm index 69eab4744..2456d02e8 100644 --- a/lib/DBIx/Class/Carp.pm +++ b/lib/DBIx/Class/Carp.pm @@ -21,7 +21,7 @@ sub __find_caller { my $fr_num = 1; # skip us and the calling carp* my (@f, $origin); - while (@f = caller($fr_num++)) { + while (@f = CORE::caller($fr_num++)) { next if ( $f[3] eq '(eval)' or $f[3] =~ /::__ANON__$/ ); @@ -33,7 +33,7 @@ sub __find_caller { and ############################# # Need a way to parameterize this for Carp::Skip - $1 !~ /^(?: DBIx::Class::Storage::BlockRunner | Context::Preserve | Try::Tiny | Class::Accessor::Grouped | Class::C3::Componentised | Module::Runtime )$/x + $1 !~ /^(?: DBIx::Class::Storage::BlockRunner | Context::Preserve | Try::Tiny | Class::Accessor::Grouped | Class::C3::Componentised | Module::Runtime | Sub::Uplevel )$/x and $2 !~ /^(?: throw_exception | carp | carp_unique | carp_once | dbh_do | txn_do | with_deferred_fk_checks)$/x ############################# @@ -54,11 +54,15 @@ sub __find_caller { ? "at $f[1] line $f[2]" : Carp::longmess() ; - $origin ||= '{UNKNOWN}'; return ( $site, - $origin =~ /::/ ? "$origin(): " : "$origin: ", # cargo-cult from Carp::Clan + ( + # cargo-cult from Carp::Clan + ! defined $origin ? '' + : $origin =~ /::/ ? "$origin(): " + : "$origin: " + ), ); }; @@ -127,6 +131,8 @@ sub unimport { 1; +__END__ + =head1 NAME DBIx::Class::Carp - Provides advanced Carp::Clan-like warning functions for DBIx::Class internals @@ -179,4 +185,15 @@ same ruleset as L). Like L but warns only once for the life of the perl interpreter (regardless of callsite). +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. + =cut diff --git a/lib/DBIx/Class/Core.pm b/lib/DBIx/Class/Core.pm index 39407dc84..9c6b30684 100644 --- a/lib/DBIx/Class/Core.pm +++ b/lib/DBIx/Class/Core.pm @@ -16,6 +16,8 @@ __PACKAGE__->load_components(qw/ 1; +__END__ + =head1 NAME DBIx::Class::Core - Core set of DBIx::Class modules @@ -51,12 +53,13 @@ The core modules currently are: A better overview of the methods found in a Result class can be found in L. -=head1 AUTHOR AND CONTRIBUTORS - -See L and L in DBIx::Class +=head1 FURTHER QUESTIONS? -=head1 LICENSE +Check the list of L. -You may distribute this code under the same terms as Perl itself. +=head1 COPYRIGHT AND LICENSE -=cut +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Cursor.pm b/lib/DBIx/Class/Cursor.pm index 2031ac499..95cbe557a 100644 --- a/lib/DBIx/Class/Cursor.pm +++ b/lib/DBIx/Class/Cursor.pm @@ -81,4 +81,17 @@ sub all { return @all; } +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. + +=cut + 1; diff --git a/lib/DBIx/Class/DB.pm b/lib/DBIx/Class/DB.pm index 9f12a981a..b7e539473 100644 --- a/lib/DBIx/Class/DB.pm +++ b/lib/DBIx/Class/DB.pm @@ -267,13 +267,16 @@ Alias for L =end hidden -=head1 AUTHOR AND CONTRIBUTORS +=head1 FURTHER QUESTIONS? -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut diff --git a/lib/DBIx/Class/Exception.pm b/lib/DBIx/Class/Exception.pm index 07f587ddb..a5e9945ec 100644 --- a/lib/DBIx/Class/Exception.pm +++ b/lib/DBIx/Class/Exception.pm @@ -40,8 +40,8 @@ overload fallback to give natural boolean/numeric values. This is meant for internal use by L's C code, and shouldn't be used directly elsewhere. -Expects a scalar exception message. The optional argument -C<$stacktrace> tells it to output a full trace similar to L. +Expects a scalar exception message. The optional boolean C<$stacktrace> +causes it to output a full trace similar to L. DBIx::Class::Exception->throw('Foo'); try { ... } catch { DBIx::Class::Exception->throw(shift) } @@ -61,7 +61,7 @@ sub throw { # skip all frames that match the original caller, or any of # the dbic-wide classdata patterns my ($ln, $calling) = DBIx::Class::Carp::__find_caller( - '^' . caller() . '$', + '^' . CORE::caller() . '$', 'DBIx::Class', ); @@ -88,13 +88,16 @@ sub rethrow { die shift; } -=head1 AUTHOR AND CONTRIBUTORS +=head1 FURTHER QUESTIONS? -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut diff --git a/lib/DBIx/Class/FilterColumn.pm b/lib/DBIx/Class/FilterColumn.pm index cee647e1e..fedbf79c5 100644 --- a/lib/DBIx/Class/FilterColumn.pm +++ b/lib/DBIx/Class/FilterColumn.pm @@ -2,16 +2,17 @@ package DBIx::Class::FilterColumn; use strict; use warnings; -use base qw/DBIx::Class::Row/; +use base 'DBIx::Class::Row'; +use SQL::Abstract 'is_literal_value'; +use namespace::clean; sub filter_column { my ($self, $col, $attrs) = @_; my $colinfo = $self->column_info($col); - $self->throw_exception('FilterColumn does not work with InflateColumn') - if $self->isa('DBIx::Class::InflateColumn') && - defined $colinfo->{_inflate_info}; + $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->has_column($col); @@ -31,9 +32,9 @@ sub filter_column { sub _column_from_storage { my ($self, $col, $value) = @_; - return $value unless defined $value; + return $value if is_literal_value($value); - my $info = $self->column_info($col) + my $info = $self->result_source->column_info($col) or $self->throw_exception("No column info for $col"); return $value unless exists $info->{_filter_info}; @@ -46,7 +47,9 @@ sub _column_from_storage { sub _column_to_storage { my ($self, $col, $value) = @_; - my $info = $self->column_info($col) or + return $value if is_literal_value($value); + + my $info = $self->result_source->column_info($col) or $self->throw_exception("No column info for $col"); return $value unless exists $info->{_filter_info}; @@ -60,20 +63,25 @@ sub get_filtered_column { my ($self, $col) = @_; $self->throw_exception("$col is not a filtered column") - unless exists $self->column_info($col)->{_filter_info}; + unless exists $self->result_source->column_info($col)->{_filter_info}; return $self->{_filtered_column}{$col} if exists $self->{_filtered_column}{$col}; my $val = $self->get_column($col); - return $self->{_filtered_column}{$col} = $self->_column_from_storage($col, $val); + return $self->{_filtered_column}{$col} = $self->_column_from_storage( + $col, $val + ); } sub get_column { my ($self, $col) = @_; + if (exists $self->{_filtered_column}{$col}) { - return $self->{_column_data}{$col} ||= $self->_column_to_storage ($col, $self->{_filtered_column}{$col}); + return $self->{_column_data}{$col} ||= $self->_column_to_storage ( + $col, $self->{_filtered_column}{$col} + ); } return $self->next::method ($col); @@ -83,10 +91,12 @@ sub get_column { sub get_columns { my $self = shift; - foreach my $col (keys %{$self->{_filtered_column}||{}}) { - $self->{_column_data}{$col} ||= $self->_column_to_storage ($col, $self->{_filtered_column}{$col}) - if exists $self->{_filtered_column}{$col}; - } + $self->{_column_data}{$_} = $self->_column_to_storage ( + $_, $self->{_filtered_column}{$_} + ) for grep + { ! exists $self->{_column_data}{$_} } + keys %{$self->{_filtered_column}||{}} + ; $self->next::method (@_); } @@ -100,54 +110,65 @@ sub store_column { $self->next::method(@_); } +sub has_column_loaded { + my ($self, $col) = @_; + return 1 if exists $self->{_filtered_column}{$col}; + return $self->next::method($col); +} + sub set_filtered_column { my ($self, $col, $filtered) = @_; - # do not blow up the cache via set_column unless necessary - # (filtering may be expensive!) - if (exists $self->{_filtered_column}{$col}) { - return $filtered - if ($self->_eq_column_values ($col, $filtered, $self->{_filtered_column}{$col} ) ); - - $self->make_column_dirty ($col); # so the comparison won't run again + # unlike IC, FC does not need to deal with the 'filter' abomination + # thus we can short-curcuit filtering entirely and never call set_column + # in case this is already a dirty change OR the row never touched storage + if ( + ! $self->in_storage + or + $self->is_column_changed($col) + ) { + $self->make_column_dirty($col); + delete $self->{_column_data}{$col}; } - - $self->set_column($col, $self->_column_to_storage($col, $filtered)); + else { + $self->set_column($col, $self->_column_to_storage($col, $filtered)); + }; return $self->{_filtered_column}{$col} = $filtered; } sub update { - my ($self, $attrs, @rest) = @_; + my ($self, $data, @rest) = @_; - foreach my $key (keys %{$attrs||{}}) { - if ( - $self->has_column($key) - && - exists $self->column_info($key)->{_filter_info} - ) { - $self->set_filtered_column($key, delete $attrs->{$key}); + my $colinfos = $self->result_source->columns_info; + + foreach my $col (keys %{$data||{}}) { + if ( exists $colinfos->{$col}{_filter_info} ) { + $self->set_filtered_column($col, delete $data->{$col}); # FIXME update() reaches directly into the object-hash # and we may *not* have a filtered value there - thus # the void-ctx filter-trigger - $self->get_column($key) unless exists $self->{_column_data}{$key}; + $self->get_column($col) unless exists $self->{_column_data}{$col}; } } - return $self->next::method($attrs, @rest); + return $self->next::method($data, @rest); } sub new { - my ($class, $attrs, @rest) = @_; - my $source = $attrs->{-result_source} + my ($class, $data, @rest) = @_; + + my $rsrc = $data->{-result_source} or $class->throw_exception('Sourceless rows are not supported with DBIx::Class::FilterColumn'); - my $obj = $class->next::method($attrs, @rest); - foreach my $key (keys %{$attrs||{}}) { - if ($obj->has_column($key) && - exists $obj->column_info($key)->{_filter_info} ) { - $obj->set_filtered_column($key, $attrs->{$key}); + my $obj = $class->next::method($data, @rest); + + my $colinfos = $rsrc->columns_info; + + foreach my $col (keys %{$data||{}}) { + if (exists $colinfos->{$col}{_filter_info} ) { + $obj->set_filtered_column($col, $data->{$col}); } } @@ -156,6 +177,8 @@ sub new { 1; +__END__ + =head1 NAME DBIx::Class::FilterColumn - Automatically convert column data @@ -240,3 +263,14 @@ and one, using code like this:- In this case the C is not required, as just passing the database value through to perl does the right thing. + +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/InflateColumn.pm b/lib/DBIx/Class/InflateColumn.pm index 9214582a4..27bde589e 100644 --- a/lib/DBIx/Class/InflateColumn.pm +++ b/lib/DBIx/Class/InflateColumn.pm @@ -3,7 +3,9 @@ package DBIx::Class::InflateColumn; use strict; use warnings; -use base qw/DBIx::Class::Row/; +use base 'DBIx::Class::Row'; +use SQL::Abstract 'is_literal_value'; +use namespace::clean; =head1 NAME @@ -87,9 +89,8 @@ sub inflate_column { my $colinfo = $self->column_info($col); - $self->throw_exception("InflateColumn does not work with FilterColumn") - if $self->isa('DBIx::Class::FilterColumn') && - defined $colinfo->{_filter_info}; + $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->has_column($col); @@ -103,26 +104,45 @@ sub inflate_column { sub _inflated_column { my ($self, $col, $value) = @_; - return $value unless defined $value; # NULL is NULL is NULL - my $info = $self->column_info($col) + + return $value if ( + ! defined $value # NULL is NULL is NULL + or + 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"); + return $value unless exists $info->{_inflate_info}; - my $inflate = $info->{_inflate_info}{inflate}; - $self->throw_exception("No inflator for $col") unless defined $inflate; - return $inflate->($value, $self); + + return ( + $info->{_inflate_info}{inflate} + || + $self->throw_exception("No inflator found for '$col'") + )->($value, $self); } sub _deflated_column { my ($self, $col, $value) = @_; -# return $value unless ref $value && blessed($value); # If it's not an object, don't touch it - ## Leave scalar refs (ala SQL::Abstract literal SQL), untouched, deflate all other refs - return $value unless (ref $value && ref($value) ne 'SCALAR'); - my $info = $self->column_info($col) or + + ## Deflate any refs except for literals, pass through plain values + return $value if ( + ! length ref $value + or + is_literal_value($value) + ); + + my $info = $self->result_source->column_info($col) or $self->throw_exception("No column info for $col"); + return $value unless exists $info->{_inflate_info}; - my $deflate = $info->{_inflate_info}{deflate}; - $self->throw_exception("No deflator for $col") unless defined $deflate; - return $deflate->($value, $self); + + return ( + $info->{_inflate_info}{deflate} + || + $self->throw_exception("No deflator found for '$col'") + )->($value, $self); } =head2 get_inflated_column @@ -138,13 +158,15 @@ Throws an exception if the column requested is not an inflated column. sub get_inflated_column { my ($self, $col) = @_; + $self->throw_exception("$col is not an inflated column") - unless exists $self->column_info($col)->{_inflate_info}; + unless exists $self->result_source->column_info($col)->{_inflate_info}; + + # we take care of keeping things in sync return $self->{_inflated_column}{$col} if exists $self->{_inflated_column}{$col}; my $val = $self->get_column($col); - return $val if ref $val eq 'SCALAR'; #that would be a not-yet-reloaded sclarref update return $self->{_inflated_column}{$col} = $self->_inflated_column($col, $val); } @@ -159,15 +181,22 @@ analogous to L. =cut sub set_inflated_column { - my ($self, $col, $inflated) = @_; - $self->set_column($col, $self->_deflated_column($col, $inflated)); -# if (blessed $inflated) { - if (ref $inflated && ref($inflated) ne 'SCALAR') { - $self->{_inflated_column}{$col} = $inflated; - } else { + my ($self, $col, $value) = @_; + + # pass through deflated stuff + if (! length ref $value or is_literal_value($value)) { + $self->set_column($col, $value); delete $self->{_inflated_column}{$col}; } - return $inflated; + # need to call set_column with the deflate cycle so that + # relationship caches are nuked if any + # also does the compare-for-dirtyness and change tracking dance + else { + $self->set_column($col, $self->_deflated_column($col, $value)); + $self->{_inflated_column}{$col} = $value; + } + + return $value; } =head2 store_inflated_column @@ -180,15 +209,18 @@ as dirty. This is directly analogous to L. =cut sub store_inflated_column { - my ($self, $col, $inflated) = @_; -# unless (blessed $inflated) { - unless (ref $inflated && ref($inflated) ne 'SCALAR') { - delete $self->{_inflated_column}{$col}; - $self->store_column($col => $inflated); - return $inflated; + my ($self, $col, $value) = @_; + + if (! length ref $value or is_literal_value($value)) { + delete $self->{_inflated_column}{$col}; + $self->store_column($col => $value); } - delete $self->{_column_data}{$col}; - return $self->{_inflated_column}{$col} = $inflated; + else { + delete $self->{_column_data}{$col}; + $self->{_inflated_column}{$col} = $value; + } + + return $value; } =head1 SEE ALSO @@ -201,19 +233,16 @@ sub store_inflated_column { =back -=head1 AUTHOR - -Matt S. Trout - -=head1 CONTRIBUTORS - -Daniel Westermann-Clark (documentation) +=head1 FURTHER QUESTIONS? -Jess Robinson +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut diff --git a/lib/DBIx/Class/InflateColumn/DateTime.pm b/lib/DBIx/Class/InflateColumn/DateTime.pm index 3162223fb..7abf5acfe 100644 --- a/lib/DBIx/Class/InflateColumn/DateTime.pm +++ b/lib/DBIx/Class/InflateColumn/DateTime.pm @@ -78,8 +78,8 @@ deflation/inflation as defined in the storage class. For instance, for a C field the methods C and C would be called on deflation/inflation. If the storage class does not provide a specialized inflator/deflator, C<[parse|format]_datetime> will -be used as a fallback. See L for more information on -date formatting. +be used as a fallback. See L +for more information on date formatting. For more help with using components, see L. @@ -310,15 +310,13 @@ use the old way you'll see a warning - please fix your code then! =back -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -Matt S. Trout +Check the list of L. -=head1 CONTRIBUTORS - -Aran Deltac - -=head1 LICENSE - -You may distribute this code under the same terms as Perl itself. +=head1 COPYRIGHT AND LICENSE +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/InflateColumn/File.pm b/lib/DBIx/Class/InflateColumn/File.pm index aa06dbc84..3a515a8f6 100644 --- a/lib/DBIx/Class/InflateColumn/File.pm +++ b/lib/DBIx/Class/InflateColumn/File.pm @@ -43,10 +43,14 @@ sub register_column { sub _file_column_file { my ($self, $column, $filename) = @_; - my $column_info = $self->column_info($column); + my $column_info = $self->result_source->column_info($column); return unless $column_info->{is_file_column}; + # DO NOT CHANGE + # This call to id() is generally incorrect - will not DTRT on + # multicolumn key. However changing this may introduce + # backwards-comp regressions, thus leaving as is my $id = $self->id || $self->throw_exception( 'id required for filename generation' ); @@ -60,8 +64,10 @@ sub _file_column_file { sub delete { my ( $self, @rest ) = @_; - for ( $self->columns ) { - if ( $self->column_info($_)->{is_file_column} ) { + my $colinfos = $self->result_source->columns_info; + + for ( keys %$colinfos ) { + if ( $colinfos->{$_}{is_file_column} ) { rmtree( [$self->_file_column_file($_)->dir], 0, 0 ); last; # if we've deleted one, we've deleted them all } @@ -75,9 +81,11 @@ sub insert { # cache our file columns so we can write them to the fs # -after- we have a PK + my $colinfos = $self->result_source->columns_info; + my %file_column; - for ( $self->columns ) { - if ( $self->column_info($_)->{is_file_column} ) { + for ( keys %$colinfos ) { + if ( $colinfos->{$_}{is_file_column} ) { $file_column{$_} = $self->$_; $self->store_column($_ => $self->$_->{filename}); } @@ -206,14 +214,16 @@ Method made to be overridden for callback purposes. sub _file_column_callback {} -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -Victor Igumnov +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -This library is free software, you can redistribute it and/or modify -it under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut diff --git a/lib/DBIx/Class/Manual.pod b/lib/DBIx/Class/Manual.pod index 60cced0cc..9b1761fcc 100644 --- a/lib/DBIx/Class/Manual.pod +++ b/lib/DBIx/Class/Manual.pod @@ -55,5 +55,13 @@ documentation. It should behave the same way. Existing components, and documentation and example on how to develop new ones. -=cut +=head1 FURTHER QUESTIONS? +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Manual/Component.pod b/lib/DBIx/Class/Manual/Component.pod index 6865aacd7..07142d999 100644 --- a/lib/DBIx/Class/Manual/Component.pod +++ b/lib/DBIx/Class/Manual/Component.pod @@ -132,6 +132,13 @@ L - Basic row methods. L -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -Aran Clary Deltac +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Manual/Cookbook.pod b/lib/DBIx/Class/Manual/Cookbook.pod index 0cb560bdf..d08022ae3 100644 --- a/lib/DBIx/Class/Manual/Cookbook.pod +++ b/lib/DBIx/Class/Manual/Cookbook.pod @@ -146,8 +146,9 @@ Next, you can execute your complex query using bind parameters like this: ); ... and you'll get back a perfect L (except, of course, -that you cannot modify the rows it contains, e.g. cannot call L, -L, ... on it). +that you cannot modify the rows it contains, e.g. cannot call +L or +L on it). Note that you cannot have bind parameters unless is_virtual is set to true. @@ -448,8 +449,8 @@ See also L is either too slow or does -not work at all, you can try the +and L is either +too slow or does not work at all, you can try the L L attribute, which skips over records to simulate limits in the Perl layer. @@ -1065,7 +1066,7 @@ See L for more documentation. Sometimes you have a (set of) result objects that you want to put into a resultset without the need to hit the DB again. You can do that by using the -L method: +L method: my @uploadable_groups; while (my $group = $groups->next) { @@ -1380,9 +1381,11 @@ row. } In this example it might be hard to see where the rollbacks, releases and -commits are happening, but it works just the same as for plain L<>: If -the C-block around C fails, a rollback is issued. If the C -succeeds, the transaction is committed (or the savepoint released). +commits are happening, but it works just the same as for plain +L: If the L-block +around L fails, a rollback is issued. +If the L succeeds, the transaction is committed +(or the savepoint released). While you can get more fine-grained control using C, C and C, it is strongly recommended to use C with coderefs. @@ -1734,30 +1737,30 @@ L and L family of methods: $resultset->create({ - numbers => [1, 2, 3] + numbers => [1, 2, 3], }); - $result->update( - { - numbers => [1, 2, 3] - }, - { - day => '2008-11-24' - } - ); + $result->update({ + numbers => [1, 2, 3], + }); In conditions (e.g. C<\%cond> in the L family of methods) you cannot directly use array references (since this is interpreted as a list of values to be Ced), but you can use the following syntax to force passing them as bind values: - $resultset->search( - { - numbers => \[ '= ?', [numbers => [1, 2, 3]] ] - } - ); + $resultset->search({ + numbers => { -value => [1, 2, 3] }, + }); + +Or using the more generic (and more cumbersome) literal syntax: + + $resultset->search({ + numbers => \[ '= ?', [ numbers => [1, 2, 3] ] ] + }); + -See L and L and L for more explanation. Note that L sets L to C, so you must pass the bind values (the C<[1, 2, 3]> arrayref in the above example) wrapped in @@ -1767,11 +1770,11 @@ C<< [column_name => value] >>. =head2 Formatting DateTime objects in queries To ensure C conditions containing L arguments are properly -formatted to be understood by your RDBMS, you must use the C +formatted to be understood by your RDBMS, you must use the L formatter returned by L to format any L objects you pass to L conditions. Any L object attached to your -L provides a correct C formatter, so +L provides a correct L formatter, so all you have to do is: my $dtf = $schema->storage->datetime_parser; @@ -1790,12 +1793,11 @@ Without doing this the query will contain the simple stringification of the C object, which almost never matches the RDBMS expectations. This kludge is necessary only for conditions passed to -L, whereas -L, -L, -L (but not L) are all +L and L, +whereas L and +L (but not L) are L-aware and will do the right thing when supplied -an inflated C object. +an inflated L object. =head2 Using Unicode @@ -1840,7 +1842,7 @@ See L for further details. =head3 Oracle Information about Oracle support for unicode can be found in -L. +L. =head3 PostgreSQL @@ -2202,10 +2204,9 @@ classes dynamically based on the database schema then there will be a significant startup delay. For production use a statically defined schema (which can be generated -using L to dump -the database schema once - see +using L to dump the database schema once - see L and -L for more +L for more details on creating static schemas from a database). =head2 Move Common Startup into a Base Class @@ -2251,10 +2252,11 @@ avoiding L. =head2 Cached statements -L normally caches all statements with L<< prepare_cached()|DBI/prepare_cached >>. -This is normally a good idea, but if too many statements are cached, the database may use too much -memory and may eventually run out and fail entirely. If you suspect this may be the case, you may want -to examine DBI's L<< CachedKids|DBI/CachedKidsCachedKids_(hash_ref) >> hash: +L normally caches all statements with +L. This is normally a good idea, but if +too many statements are cached, the database may use too much memory and may +eventually run out and fail entirely. If you suspect this may be the case, +you may want to examine DBI's L hash: # print all currently cached prepared statements print for keys %{$schema->storage->dbh->{CachedKids}}; @@ -2277,3 +2279,14 @@ You can accomplish this with L or L: }); =cut + +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Manual/DocMap.pod b/lib/DBIx/Class/Manual/DocMap.pod index b6eaa25ae..0b4966baf 100644 --- a/lib/DBIx/Class/Manual/DocMap.pod +++ b/lib/DBIx/Class/Manual/DocMap.pod @@ -60,3 +60,15 @@ are used most often. =item L - Making objects out of your column values. =back + +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. + diff --git a/lib/DBIx/Class/Manual/Example.pod b/lib/DBIx/Class/Manual/Example.pod index 59b114e80..3f9b882e5 100644 --- a/lib/DBIx/Class/Manual/Example.pod +++ b/lib/DBIx/Class/Manual/Example.pod @@ -8,368 +8,108 @@ This tutorial will guide you through the process of setting up and testing a very basic CD database using SQLite, with DBIx::Class::Schema as the database frontend. -The database consists of the following: - - table 'artist' with columns: artistid, name - table 'cd' with columns: cdid, artist, title, year - table 'track' with columns: trackid, cd, title +The database structure is based on the following rules: + An artist can have many cds, and each cd belongs to just one artist. + A cd can have many tracks, and each track belongs to just one cd. -And these rules exists: +The database is implemented with the following: - one artist can have many cds - one cd belongs to one artist - one cd can have many tracks - one track belongs to one cd + table 'artist' with columns: artistid, name + table 'cd' with columns: cdid, artistid, title, year + table 'track' with columns: trackid, cdid, title +Each of the table's first columns is the primary key; any subsequent +keys are foreign keys. =head2 Installation -Install DBIx::Class via CPAN should be sufficient. - -=head3 Create the database/tables - -First make and change the directory: - - mkdir app - cd app - mkdir db - cd db - -This example uses SQLite which is a dependency of DBIx::Class, so you -shouldn't have to install extra software. - -Save the following into a example.sql in the directory db - - CREATE TABLE artist ( - artistid INTEGER PRIMARY KEY, - name TEXT NOT NULL - ); - - CREATE TABLE cd ( - cdid INTEGER PRIMARY KEY, - artist INTEGER NOT NULL REFERENCES artist(artistid), - title TEXT NOT NULL - ); - - CREATE TABLE track ( - trackid INTEGER PRIMARY KEY, - cd INTEGER NOT NULL REFERENCES cd(cdid), - title TEXT NOT NULL - ); - -and create the SQLite database file: - - sqlite3 example.db < example.sql - -=head3 Set up DBIx::Class::Schema +You'll need to install DBIx::Class via CPAN, and you'll also need to +install sqlite3 (not sqlite) if it's not already intalled. -Change directory back from db to the directory app: +=head3 The database/tables/data - cd ../ +Your distribution already comes with a pre-filled SQLite database +F. You can see it by e.g. -Now create some more directories: + cpanm --look DBIx::Class - mkdir MyApp - mkdir MyApp/Schema - mkdir MyApp/Schema/Result - mkdir MyApp/Schema/ResultSet +If for some reason the file is unreadable on your system, you can +recreate it as follows: -Then, create the following DBIx::Class::Schema classes: + cp -a /examples/Schema dbicapp + cd dbicapp + rm db/example.db + sqlite3 db/example.db < db/example.sql + perl insertdb.pl -MyApp/Schema.pm: +=head3 Testing the database - package MyApp::Schema; - use base qw/DBIx::Class::Schema/; - __PACKAGE__->load_namespaces; +Enter the example Schema directory - 1; + cd /examples/Schema +Run the script testdb.pl, which will test that the database has +successfully been filled. -MyApp/Schema/Result/Artist.pm: +When this script is run, it should output the following: - package MyApp::Schema::Result::Artist; - use base qw/DBIx::Class::Core/; - __PACKAGE__->table('artist'); - __PACKAGE__->add_columns(qw/ artistid name /); - __PACKAGE__->set_primary_key('artistid'); - __PACKAGE__->has_many('cds' => 'MyApp::Schema::Result::Cd'); + get_tracks_by_cd(Bad): + Leave Me Alone + Smooth Criminal + Dirty Diana - 1; + get_tracks_by_artist(Michael Jackson): + Billie Jean (from the CD 'Thriller') + Beat It (from the CD 'Thriller') + Leave Me Alone (from the CD 'Bad') + Smooth Criminal (from the CD 'Bad') + Dirty Diana (from the CD 'Bad') + get_cd_by_track(Stan): + The Marshall Mathers LP has the track 'Stan'. -MyApp/Schema/Result/Cd.pm: + get_cds_by_artist(Michael Jackson): + Thriller + Bad - package MyApp::Schema::Result::Cd; - use base qw/DBIx::Class::Core/; - __PACKAGE__->load_components(qw/InflateColumn::DateTime/); - __PACKAGE__->table('cd'); - __PACKAGE__->add_columns(qw/ cdid artist title year/); - __PACKAGE__->set_primary_key('cdid'); - __PACKAGE__->belongs_to('artist' => 'MyApp::Schema::Result::Artist'); - __PACKAGE__->has_many('tracks' => 'MyApp::Schema::Result::Track'); + get_artist_by_track(Dirty Diana): + Michael Jackson recorded the track 'Dirty Diana'. - 1; + get_artist_by_cd(The Marshall Mathers LP): + Eminem recorded the CD 'The Marshall Mathers LP'. -MyApp/Schema/Result/Track.pm: +=head3 Discussion about the results - package MyApp::Schema::Result::Track; - use base qw/DBIx::Class::Core/; - __PACKAGE__->table('track'); - __PACKAGE__->add_columns(qw/ trackid cd title /); - __PACKAGE__->set_primary_key('trackid'); - __PACKAGE__->belongs_to('cd' => 'MyApp::Schema::Result::Cd'); +The data model defined in this example has an artist with multiple CDs, +and a CD with multiple tracks; thus, it's simple to traverse from a +track back to a CD, and from there back to an artist. This is +demonstrated in the get_tracks_by_artist routine, where we easily walk +from the individual track back to the title of the CD that the track +came from ($track->cd->title). - 1; - - -=head3 Write a script to insert some records - -insertdb.pl - - #!/usr/bin/perl - - use strict; - use warnings; - - use MyApp::Schema; - - my $schema = MyApp::Schema->connect('dbi:SQLite:db/example.db'); - - my @artists = (['Michael Jackson'], ['Eminem']); - $schema->populate('Artist', [ - [qw/name/], - @artists, - ]); - - my %albums = ( - 'Thriller' => 'Michael Jackson', - 'Bad' => 'Michael Jackson', - 'The Marshall Mathers LP' => 'Eminem', - ); - - my @cds; - foreach my $lp (keys %albums) { - my $artist = $schema->resultset('Artist')->find({ - name => $albums{$lp} - }); - push @cds, [$lp, $artist->id]; - } - - $schema->populate('Cd', [ - [qw/title artist/], - @cds, - ]); - - - my %tracks = ( - 'Beat It' => 'Thriller', - 'Billie Jean' => 'Thriller', - 'Dirty Diana' => 'Bad', - 'Smooth Criminal' => 'Bad', - 'Leave Me Alone' => 'Bad', - 'Stan' => 'The Marshall Mathers LP', - 'The Way I Am' => 'The Marshall Mathers LP', - ); - - my @tracks; - foreach my $track (keys %tracks) { - my $cdname = $schema->resultset('Cd')->find({ - title => $tracks{$track}, - }); - push @tracks, [$cdname->id, $track]; - } - - $schema->populate('Track',[ - [qw/cd title/], - @tracks, - ]); - -=head3 Create and run the test scripts - -testdb.pl: - - #!/usr/bin/perl - - use strict; - use warnings; - - use MyApp::Schema; - - my $schema = MyApp::Schema->connect('dbi:SQLite:db/example.db'); - # for other DSNs, e.g. MySQL, see the perldoc for the relevant dbd - # driver, e.g perldoc L. - - get_tracks_by_cd('Bad'); - get_tracks_by_artist('Michael Jackson'); - - get_cd_by_track('Stan'); - get_cds_by_artist('Michael Jackson'); - - get_artist_by_track('Dirty Diana'); - get_artist_by_cd('The Marshall Mathers LP'); - - - sub get_tracks_by_cd { - my $cdtitle = shift; - print "get_tracks_by_cd($cdtitle):\n"; - my $rs = $schema->resultset('Track')->search( - { - 'cd.title' => $cdtitle - }, - { - join => [qw/ cd /], - } - ); - while (my $track = $rs->next) { - print $track->title . "\n"; - } - print "\n"; - } - - sub get_tracks_by_artist { - my $artistname = shift; - print "get_tracks_by_artist($artistname):\n"; - my $rs = $schema->resultset('Track')->search( - { - 'artist.name' => $artistname - }, - { - join => { - 'cd' => 'artist' - }, - } - ); - while (my $track = $rs->next) { - print $track->title . "\n"; - } - print "\n"; - } - - - sub get_cd_by_track { - my $tracktitle = shift; - print "get_cd_by_track($tracktitle):\n"; - my $rs = $schema->resultset('Cd')->search( - { - 'tracks.title' => $tracktitle - }, - { - join => [qw/ tracks /], - } - ); - my $cd = $rs->first; - print $cd->title . "\n\n"; - } - - sub get_cds_by_artist { - my $artistname = shift; - print "get_cds_by_artist($artistname):\n"; - my $rs = $schema->resultset('Cd')->search( - { - 'artist.name' => $artistname - }, - { - join => [qw/ artist /], - } - ); - while (my $cd = $rs->next) { - print $cd->title . "\n"; - } - print "\n"; - } - - - - sub get_artist_by_track { - my $tracktitle = shift; - print "get_artist_by_track($tracktitle):\n"; - my $rs = $schema->resultset('Artist')->search( - { - 'tracks.title' => $tracktitle - }, - { - join => { - 'cds' => 'tracks' - } - } - ); - my $artist = $rs->first; - print $artist->name . "\n\n"; - } - - sub get_artist_by_cd { - my $cdtitle = shift; - print "get_artist_by_cd($cdtitle):\n"; - my $rs = $schema->resultset('Artist')->search( - { - 'cds.title' => $cdtitle - }, - { - join => [qw/ cds /], - } - ); - my $artist = $rs->first; - print $artist->name . "\n\n"; - } - - - -It should output: - - get_tracks_by_cd(Bad): - Dirty Diana - Smooth Criminal - Leave Me Alone - - get_tracks_by_artist(Michael Jackson): - Beat it - Billie Jean - Dirty Diana - Smooth Criminal - Leave Me Alone - - get_cd_by_track(Stan): - The Marshall Mathers LP - - get_cds_by_artist(Michael Jackson): - Thriller - Bad - - get_artist_by_track(Dirty Diana): - Michael Jackson - - get_artist_by_cd(The Marshall Mathers LP): - Eminem - -=head1 Notes - -A reference implementation of the database and scripts in this example -are available in the main distribution for DBIx::Class under the -directory F. - -With these scripts we're relying on @INC looking in the current -working directory. You may want to add the MyApp namespaces to -@INC in a different way when it comes to deployment. - -The F script is an excellent start for testing your database -model. +Note also that in the get_tracks_by_cd and get_tracks_by_artist +routines, the result set is called multiple times with the 'next' +iterator. In contrast, get_cd_by_track uses the 'first' result set +method, since only one CD is expected to have a specific track. This example uses L to load in the appropriate L classes from the C namespace, and any required L classes from the -C namespace (although we created the directory -in the directions above we did not add, or need to add, any resultset -classes). +C namespace (although we did not add, nor needed +any such classes in this example). + +=head1 FURTHER QUESTIONS? -=head1 TODO +Check the list of L. -=head1 AUTHOR +=head1 COPYRIGHT AND LICENSE - sc_ from irc.perl.org#dbix-class - Kieren Diment - Nigel Metheringham +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut diff --git a/lib/DBIx/Class/Manual/FAQ.pod b/lib/DBIx/Class/Manual/FAQ.pod index 71595d515..b8dbe17c5 100644 --- a/lib/DBIx/Class/Manual/FAQ.pod +++ b/lib/DBIx/Class/Manual/FAQ.pod @@ -78,19 +78,19 @@ lot later. If your database server allows you to run queries across multiple databases at once, then so can DBIx::Class. All you need to do is make sure you write the database name as part of the -L call. Eg: +L call. Eg: __PACKAGE__->table('mydb.mytablename'); -And load all the Result classes for both / all databases using one -L call. +And load all the Result classes for both / all databases by calling +L. =item .. use DBIx::Class across PostgreSQL/DB2/Oracle schemas? -Add the name of the schema to the L -as part of the name, and make sure you give the one user you are going -to connect with has permissions to read/write all the schemas/tables as -necessary. +Add the name of the schema to the table name, when invoking +L, and make sure the user +you are about to connect as has permissions to read/write all the +schemas/tables as necessary. =back @@ -154,7 +154,7 @@ See L. =item .. use a relationship? Use its name. An accessor is created using the name. See examples in -L. +L. =back @@ -262,6 +262,39 @@ alter session statements on database connection establishment: ->on_connect_do("ALTER SESSION SET NLS_SORT = 'BINARY_CI'"); ->on_connect_do("ALTER SESSION SET NLS_SORT = 'GERMAN_CI'"); +=item .. format a DateTime object for searching? + +L and L +do not take L into account, and so your L +object will not be correctly deflated into a format your RDBMS expects. + +The L method on your +storage object can be used to return the object that would normally do this, so +it's easy to do it manually: + + my $dtf = $schema->storage->datetime_parser; + my $rs = $schema->resultset('users')->search( + { + signup_date => { + -between => [ + $dtf->format_datetime($dt_start), + $dtf->format_datetime($dt_end), + ], + } + }, + ); + +With in a Result Class method, you can get this from the +L|DBIx::Class::Row/result_source>. + + my $dtf = $self->result_source->storage->datetime_parser; + +This kludge is necessary only for conditions passed to +L and L, +whereas L and L +(but not L) are +L-aware and will do the right thing when supplied +an inflated L object. =back @@ -451,8 +484,8 @@ what create_related() from L does, you could add this to Book.pm: sub foo { - my ($self, $relname, $col_data) = @_; - return $self->related_resultset($relname)->create($col_data); + my ($self, $rel_name, $col_data) = @_; + return $self->related_resultset($rel_name)->create($col_data); } Invoked like this: @@ -658,3 +691,14 @@ Taken from: L. =back + +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Manual/Features.pod b/lib/DBIx/Class/Manual/Features.pod index a28bb3558..e71f952e7 100644 --- a/lib/DBIx/Class/Manual/Features.pod +++ b/lib/DBIx/Class/Manual/Features.pod @@ -6,9 +6,9 @@ DBIx::Class::Manual::Features - A boatload of DBIx::Class features with links to =head2 Large Community -Currently there are 88 people listed as contributors to DBIC. That ranges -from documentation help, to test help, to added features, to entire database -support. +There are L listed in +F. That ranges from documentation help, to test help, to added +features, to entire database support. =head2 Active Community @@ -479,7 +479,9 @@ on our system (Microsoft SQL) is: ) rpt_score WHERE rno__row__index BETWEEN 1 AND 1 -See: L, L, and L. +See: L, +L, and +L. =head2 bonus rel methods @@ -661,5 +663,15 @@ Better: price => \['price + ?', [inc => $inc]], }); -See L +See L +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Manual/Glossary.pod b/lib/DBIx/Class/Manual/Glossary.pod index 136355da7..ae783a5e9 100644 --- a/lib/DBIx/Class/Manual/Glossary.pod +++ b/lib/DBIx/Class/Manual/Glossary.pod @@ -66,11 +66,11 @@ relationships must be used. A Schema object represents your entire table collection, plus the connection to the database. You can create one or more schema objects, connected to various databases, with various users, using the same set -of table L definitions. +of table L definitions. At least one L class is needed per database. -=head2 Result class +=head2 Result Class A Result class defines both a source of data (usually one per table), and the methods that will be available in the L objects @@ -87,7 +87,7 @@ ResultSource objects represent the source of your data, these are sometimes (incorrectly) called table objects. ResultSources do not need to be directly created, a ResultSource -instance is created for each L in your L, by +instance is created for each L in your L, by the proxied methods C and C. See also: L @@ -148,17 +148,20 @@ to issue multiple SQL queries. A normalised database is a sane database. Each table contains only data belonging to one concept, related tables refer to the key field or fields of each other. Some links to webpages about normalisation -can be found in L. +can be found in L. =head2 Related data In SQL, related data actually refers to data that are normalised into the same table. (Yes. DBIC does mis-use this term.) -=head1 AUTHOR AND CONTRIBUTORS +=head1 FURTHER QUESTIONS? -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Manual/Intro.pod b/lib/DBIx/Class/Manual/Intro.pod index f13e14e1a..c4c928ed4 100644 --- a/lib/DBIx/Class/Manual/Intro.pod +++ b/lib/DBIx/Class/Manual/Intro.pod @@ -471,4 +471,13 @@ information on this can be found in L =back -=cut +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Manual/Joining.pod b/lib/DBIx/Class/Manual/Joining.pod index 625a4d90e..bc4f84658 100644 --- a/lib/DBIx/Class/Manual/Joining.pod +++ b/lib/DBIx/Class/Manual/Joining.pod @@ -242,7 +242,7 @@ To join two relations at the same level, use an arrayref instead: Or combine the two: - join => { room => [ 'chair', { table => 'leg' } ] + join => { room => [ 'chair', { table => 'leg' } ] } =head2 Table aliases @@ -274,3 +274,13 @@ The aliases are: C and C. =cut +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Manual/QuickStart.pod b/lib/DBIx/Class/Manual/QuickStart.pod index 1d7415a35..0c31ac089 100644 --- a/lib/DBIx/Class/Manual/QuickStart.pod +++ b/lib/DBIx/Class/Manual/QuickStart.pod @@ -192,3 +192,14 @@ L. Continue with L and L. + +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Manual/Reading.pod b/lib/DBIx/Class/Manual/Reading.pod index cb352a27f..45ecdbd90 100644 --- a/lib/DBIx/Class/Manual/Reading.pod +++ b/lib/DBIx/Class/Manual/Reading.pod @@ -179,12 +179,13 @@ Examples and explaining paragraphs can be repeated as necessary. =back -=head1 AUTHOR AND CONTRIBUTORS +=head1 FURTHER QUESTIONS? -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. - -=cut +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Manual/ResultClass.pod.proto b/lib/DBIx/Class/Manual/ResultClass.pod.proto index 29ff9e9f1..310acaaef 100644 --- a/lib/DBIx/Class/Manual/ResultClass.pod.proto +++ b/lib/DBIx/Class/Manual/ResultClass.pod.proto @@ -51,10 +51,13 @@ C. This document serves as a general overview of C declaration best practices, and offers an index of the available methods (and the Components/Roles which provide them). -=head1 AUTHOR AND CONTRIBUTORS +=head1 FURTHER QUESTIONS? -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Manual/Troubleshooting.pod b/lib/DBIx/Class/Manual/Troubleshooting.pod index b28a960b7..f6057d5d6 100644 --- a/lib/DBIx/Class/Manual/Troubleshooting.pod +++ b/lib/DBIx/Class/Manual/Troubleshooting.pod @@ -158,5 +158,13 @@ can grow very large. The solution is to use the smallest practical value for LongReadLen. -=cut +=head1 FURTHER QUESTIONS? +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Optional/Dependencies.pm b/lib/DBIx/Class/Optional/Dependencies.pm index 23ffebed8..cf0cb7630 100644 --- a/lib/DBIx/Class/Optional/Dependencies.pm +++ b/lib/DBIx/Class/Optional/Dependencies.pm @@ -1,9 +1,19 @@ package DBIx::Class::Optional::Dependencies; -use warnings; -use strict; +### This may look crazy, but it in fact tangibly ( by 50(!)% ) shortens +# the skip-test time when everything requested is unavailable +BEGIN { + if ( $ENV{RELEASE_TESTING} ) { + require warnings and warnings->import; + require strict and strict->import; + } +} -use Carp (); +sub croak { + require Carp; + Carp::croak(@_); +}; +### # NO EXTERNAL NON-5.8.1 CORE DEPENDENCIES EVER (e.g. C::A::G) # This module is to be loaded by Makefile.PM on a pristine system @@ -11,110 +21,70 @@ use Carp (); # POD is generated automatically by calling _gen_pod from the # Makefile.PL in $AUTHOR mode -# NOTE: the rationale for 2 JSON::Any versions is that -# we need the newer only to work around JSON::XS, which -# itself is an optional dep -my $min_json_any = { - 'JSON::Any' => '1.23', -}; -my $test_and_dist_json_any = { - 'JSON::Any' => '1.31', -}; - +# *DELIBERATELY* not making a group for these - they must disappear +# forever as optdeps in the first place my $moose_basic = { 'Moose' => '0.98', 'MooseX::Types' => '0.21', 'MooseX::Types::LoadableClass' => '0.011', }; -my $replicated = { - %$moose_basic, -}; +my $dbic_reqs = { -my $admin_basic = { - %$moose_basic, - %$min_json_any, - 'MooseX::Types::Path::Class' => '0.05', - 'MooseX::Types::JSON' => '0.02', - 'namespace::autoclean' => '0.09', -}; + # NOTE: the rationale for 2 JSON::Any versions is that + # we need the newer only to work around JSON::XS, which + # itself is an optional dep + _json_any => { + req => { + 'JSON::Any' => '1.23', + }, + }, -my $admin_script = { - %$moose_basic, - %$admin_basic, - 'Getopt::Long::Descriptive' => '0.081', - 'Text::CSV' => '1.16', -}; + _json_xs_compatible_json_any => { + req => { + 'JSON::Any' => '1.31', + }, + }, -my $datetime_basic = { - 'DateTime' => '0.55', - 'DateTime::Format::Strptime' => '1.2', -}; + # a common placeholder for engines with IC::DT support based off DT::F::S + _ic_dt_strptime_based => { + augment => { + ic_dt => { + req => { + 'DateTime::Format::Strptime' => '1.2', + }, + }, + } + }, -my $id_shortener = { - 'Math::BigInt' => '1.80', - 'Math::Base36' => '0.07', -}; + _rdbms_generic_odbc => { + req => { + 'DBD::ODBC' => 0, + } + }, -my $rdbms_sqlite = { - 'DBD::SQLite' => '0', -}; -my $rdbms_pg = { - 'DBD::Pg' => '0', -}; -my $rdbms_mssql_odbc = { - 'DBD::ODBC' => '0', -}; -my $rdbms_mssql_sybase = { - 'DBD::Sybase' => '0', -}; -my $rdbms_mssql_ado = { - 'DBD::ADO' => '0', -}; -my $rdbms_msaccess_odbc = { - 'DBD::ODBC' => '0', -}; -my $rdbms_msaccess_ado = { - 'DBD::ADO' => '0', -}; -my $rdbms_mysql = { - 'DBD::mysql' => '0', -}; -my $rdbms_oracle = { - 'DBD::Oracle' => '0', - %$id_shortener, -}; -my $rdbms_ase = { - 'DBD::Sybase' => '0', -}; -my $rdbms_db2 = { - 'DBD::DB2' => '0', -}; -my $rdbms_db2_400 = { - 'DBD::ODBC' => '0', -}; -my $rdbms_informix = { - 'DBD::Informix' => '0', -}; -my $rdbms_sqlanywhere = { - 'DBD::SQLAnywhere' => '0', -}; -my $rdbms_sqlanywhere_odbc = { - 'DBD::ODBC' => '0', -}; -my $rdbms_firebird = { - 'DBD::Firebird' => '0', -}; -my $rdbms_firebird_interbase = { - 'DBD::InterBase' => '0', -}; -my $rdbms_firebird_odbc = { - 'DBD::ODBC' => '0', -}; + _rdbms_generic_ado => { + req => { + 'DBD::ADO' => 0, + } + }, + + # must list any dep used by adhoc testing + # this prevents the "skips due to forgotten deps" issue + test_adhoc => { + req => { + 'Class::DBI::Plugin::DeepAbstractSearch' => '0', + 'Class::DBI' => '3.000005', + 'Date::Simple' => '3.03', + 'YAML' => '0', + 'Class::Unload' => '0.07', + 'Time::Piece' => '0', + 'Time::Piece::MySQL' => '0', + }, + }, -my $reqs = { replicated => { - req => $replicated, + req => $moose_basic, pod => { title => 'Storage::Replicated', desc => 'Modules required for L', @@ -122,16 +92,18 @@ my $reqs = { }, test_replicated => { + include => 'replicated', req => { - %$replicated, - 'Test::Moose' => '0', + 'Test::Moose' => '0', }, }, - admin => { + include => '_json_any', req => { - %$admin_basic, + %$moose_basic, + 'MooseX::Types::Path::Class' => '0.05', + 'MooseX::Types::JSON' => '0.02', }, pod => { title => 'DBIx::Class::Admin', @@ -140,8 +112,10 @@ my $reqs = { }, admin_script => { + include => 'admin', req => { - %$admin_script, + 'Getopt::Long::Descriptive' => '0.081', + 'Text::CSV' => '1.16', }, pod => { title => 'dbicadmin', @@ -151,21 +125,46 @@ my $reqs = { deploy => { req => { - 'SQL::Translator' => '0.11016', + 'SQL::Translator' => '0.11018', }, pod => { title => 'Storage::DBI::deploy()', - desc => 'Modules required for L and L', + desc => 'Modules required for L and L', + }, + }, + + ic_dt => { + req => { + 'DateTime' => '0.55', + 'DateTime::TimeZone::OlsonDB' => 0, + }, + pod => { + title => 'InflateColumn::DateTime support', + desc => + 'Modules required for L. ' + . 'Note that this group does not require much on its own, but ' + . 'instead is augmented by various RDBMS-specific groups. See the ' + . 'documentation of each C group for details', }, }, id_shortener => { - req => $id_shortener, + req => { + 'Math::BigInt' => '1.80', + 'Math::Base36' => '0.07', + }, }, - test_component_accessor => { + cdbicompat => { req => { - 'Class::Unload' => '0.07', + 'Class::Data::Inheritable' => '0', + 'Class::Trigger' => '0', + 'DBIx::ContextualFetch' => '0', + 'Clone' => '0.32', + }, + pod => { + title => 'DBIx::Class::CDBICompat support', + desc => 'Modules required for L' }, }, @@ -173,6 +172,7 @@ my $reqs = { req => { 'Test::Pod' => '1.42', }, + release_testing_mandatory => 1, }, test_podcoverage => { @@ -180,6 +180,7 @@ my $reqs = { 'Test::Pod::Coverage' => '1.08', 'Pod::Coverage' => '0.20', }, + release_testing_mandatory => 1, }, test_whitespace => { @@ -187,22 +188,23 @@ my $reqs = { 'Test::EOL' => '1.0', 'Test::NoTabs' => '0.9', }, + release_testing_mandatory => 1, }, test_strictures => { req => { 'Test::Strict' => '0.20', }, + release_testing_mandatory => 1, }, test_prettydebug => { - req => $min_json_any, + include => '_json_any', }, test_admin_script => { + include => [qw( admin_script _json_xs_compatible_json_any )], req => { - %$admin_script, - %$test_and_dist_json_any, 'JSON' => 0, 'JSON::PP' => 0, 'Cpanel::JSON::XS' => 0, @@ -223,62 +225,47 @@ my $reqs = { }, }, - test_dt => { - req => $datetime_basic, - }, - - test_dt_sqlite => { - req => { - %$datetime_basic, - # t/36datetime.t - # t/60core.t - 'DateTime::Format::SQLite' => '0', - }, - }, - - test_dt_mysql => { - req => { - %$datetime_basic, - # t/inflate/datetime_mysql.t - # (doesn't need Mysql itself) - 'DateTime::Format::MySQL' => '0', - }, - }, - - test_dt_pg => { - req => { - %$datetime_basic, - # t/inflate/datetime_pg.t - # (doesn't need PG itself) - 'DateTime::Format::Pg' => '0.16004', - }, - }, - - test_cdbicompat => { - req => { - 'Class::DBI::Plugin::DeepAbstractSearch' => '0', - %$datetime_basic, - 'Time::Piece::MySQL' => '0', - 'Date::Simple' => '3.03', - }, - }, # this is just for completeness as SQLite # is a core dep of DBIC for testing rdbms_sqlite => { req => { - %$rdbms_sqlite, + 'DBD::SQLite' => 0, }, pod => { title => 'SQLite support', desc => 'Modules required to connect to SQLite', }, + augment => { + ic_dt => { + req => { + 'DateTime::Format::SQLite' => '0', + }, + }, + }, + }, + + # centralize the specification, as we have ICDT tests which can + # test the full behavior of RDBMS-specific ICDT on top of bare SQLite + _ic_dt_pg_base => { + augment => { + ic_dt => { + req => { + 'DateTime::Format::Pg' => '0.16004', + }, + }, + }, + }, + + ic_dt_pg => { + include => [qw( ic_dt _ic_dt_pg_base )], }, rdbms_pg => { + include => '_ic_dt_pg_base', req => { # when changing this list make sure to adjust xt/optional_deps.t - %$rdbms_pg, + 'DBD::Pg' => 0, }, pod => { title => 'PostgreSQL support', @@ -286,10 +273,12 @@ my $reqs = { }, }, + _rdbms_mssql_common => { + include => '_ic_dt_strptime_based', + }, + rdbms_mssql_odbc => { - req => { - %$rdbms_mssql_odbc, - }, + include => [qw( _rdbms_generic_odbc _rdbms_mssql_common )], pod => { title => 'MSSQL support via DBD::ODBC', desc => 'Modules required to connect to MSSQL via DBD::ODBC', @@ -297,8 +286,9 @@ my $reqs = { }, rdbms_mssql_sybase => { + include => '_rdbms_mssql_common', req => { - %$rdbms_mssql_sybase, + 'DBD::Sybase' => 0, }, pod => { title => 'MSSQL support via DBD::Sybase', @@ -307,19 +297,19 @@ my $reqs = { }, rdbms_mssql_ado => { - req => { - %$rdbms_mssql_ado, - }, + include => [qw( _rdbms_generic_ado _rdbms_mssql_common )], pod => { title => 'MSSQL support via DBD::ADO (Windows only)', desc => 'Modules required to connect to MSSQL via DBD::ADO. This particular DBD is available on Windows only', }, }, + _rdbms_msaccess_common => { + include => '_ic_dt_strptime_based', + }, + rdbms_msaccess_odbc => { - req => { - %$rdbms_msaccess_odbc, - }, + include => [qw( _rdbms_generic_odbc _rdbms_msaccess_common )], pod => { title => 'MS Access support via DBD::ODBC', desc => 'Modules required to connect to MS Access via DBD::ODBC', @@ -327,18 +317,33 @@ my $reqs = { }, rdbms_msaccess_ado => { - req => { - %$rdbms_msaccess_ado, - }, + include => [qw( _rdbms_generic_ado _rdbms_msaccess_common )], pod => { title => 'MS Access support via DBD::ADO (Windows only)', desc => 'Modules required to connect to MS Access via DBD::ADO. This particular DBD is available on Windows only', }, }, + # centralize the specification, as we have ICDT tests which can + # test the full behavior of RDBMS-specific ICDT on top of bare SQLite + _ic_dt_mysql_base => { + augment => { + ic_dt => { + req => { + 'DateTime::Format::MySQL' => '0', + }, + }, + }, + }, + + ic_dt_mysql => { + include => [qw( ic_dt _ic_dt_mysql_base )], + }, + rdbms_mysql => { + include => '_ic_dt_mysql_base', req => { - %$rdbms_mysql, + 'DBD::mysql' => 0, }, pod => { title => 'MySQL support', @@ -347,18 +352,27 @@ my $reqs = { }, rdbms_oracle => { + include => 'id_shortener', req => { - %$rdbms_oracle, + 'DBD::Oracle' => 0, }, pod => { title => 'Oracle support', desc => 'Modules required to connect to Oracle', }, + augment => { + ic_dt => { + req => { + 'DateTime::Format::Oracle' => '0', + }, + }, + }, }, rdbms_ase => { + include => '_ic_dt_strptime_based', req => { - %$rdbms_ase, + 'DBD::Sybase' => 0, }, pod => { title => 'Sybase ASE support', @@ -366,9 +380,20 @@ my $reqs = { }, }, + _rdbms_db2_common => { + augment => { + ic_dt => { + req => { + 'DateTime::Format::DB2' => '0', + }, + }, + }, + }, + rdbms_db2 => { + include => '_rdbms_db2_common', req => { - %$rdbms_db2, + 'DBD::DB2' => 0, }, pod => { title => 'DB2 support', @@ -377,9 +402,7 @@ my $reqs = { }, rdbms_db2_400 => { - req => { - %$rdbms_db2_400, - }, + include => [qw( _rdbms_generic_odbc _rdbms_db2_common )], pod => { title => 'DB2 on AS/400 support', desc => 'Modules required to connect to DB2 on AS/400', @@ -387,8 +410,9 @@ my $reqs = { }, rdbms_informix => { + include => '_ic_dt_strptime_based', req => { - %$rdbms_informix, + 'DBD::Informix' => 0, }, pod => { title => 'Informix support', @@ -396,9 +420,14 @@ my $reqs = { }, }, + _rdbms_sqlanywhere_common => { + include => '_ic_dt_strptime_based', + }, + rdbms_sqlanywhere => { + include => '_rdbms_sqlanywhere_common', req => { - %$rdbms_sqlanywhere, + 'DBD::SQLAnywhere' => 0, }, pod => { title => 'SQLAnywhere support', @@ -407,18 +436,21 @@ my $reqs = { }, rdbms_sqlanywhere_odbc => { - req => { - %$rdbms_sqlanywhere_odbc, - }, + include => [qw( _rdbms_generic_odbc _rdbms_sqlanywhere_common )], pod => { title => 'SQLAnywhere support via DBD::ODBC', desc => 'Modules required to connect to SQLAnywhere via DBD::ODBC', }, }, + _rdbms_firebird_common => { + include => '_ic_dt_strptime_based', + }, + rdbms_firebird => { + include => '_rdbms_firebird_common', req => { - %$rdbms_firebird, + 'DBD::Firebird' => 0, }, pod => { title => 'Firebird support', @@ -427,8 +459,9 @@ my $reqs = { }, rdbms_firebird_interbase => { + include => '_rdbms_firebird_common', req => { - %$rdbms_firebird_interbase, + 'DBD::InterBase' => 0, }, pod => { title => 'Firebird support via DBD::InterBase', @@ -437,195 +470,223 @@ my $reqs = { }, rdbms_firebird_odbc => { - req => { - %$rdbms_firebird_odbc, - }, + include => [qw( _rdbms_generic_odbc _rdbms_firebird_common )], pod => { title => 'Firebird support via DBD::ODBC', desc => 'Modules required to connect to Firebird via DBD::ODBC', }, }, -# the order does matter because the rdbms support group might require -# a different version that the test group - test_rdbms_pg => { + test_rdbms_sqlite => { + include => 'rdbms_sqlite', req => { - $ENV{DBICTEST_PG_DSN} - ? ( - # when changing this list make sure to adjust xt/optional_deps.t - %$rdbms_pg, - ($^O ne 'MSWin32' ? ('Sys::SigAction' => '0') : ()), - 'DBD::Pg' => '2.009002', - ) : () + ### + ### IMPORTANT - do not raise this dependency + ### even though many bugfixes are present in newer versions, the general DBIC + ### rule is to bend over backwards for available DBDs (given upgrading them is + ### often *not* easy or even possible) + ### + 'DBD::SQLite' => '1.29', }, }, - test_rdbms_mssql_odbc => { + test_rdbms_pg => { + include => 'rdbms_pg', + env => [ + DBICTEST_PG_DSN => 1, + DBICTEST_PG_USER => 0, + DBICTEST_PG_PASS => 0, + ], req => { - $ENV{DBICTEST_MSSQL_ODBC_DSN} - ? ( - %$rdbms_mssql_odbc, - ) : () + # the order does matter because the rdbms support group might require + # a different version that the test group + # + # when changing this list make sure to adjust xt/optional_deps.t + 'DBD::Pg' => '2.009002', # specific version to test bytea }, }, + test_rdbms_mssql_odbc => { + include => 'rdbms_mssql_odbc', + env => [ + DBICTEST_MSSQL_ODBC_DSN => 1, + DBICTEST_MSSQL_ODBC_USER => 0, + DBICTEST_MSSQL_ODBC_PASS => 0, + ], + }, + test_rdbms_mssql_ado => { - req => { - $ENV{DBICTEST_MSSQL_ADO_DSN} - ? ( - %$rdbms_mssql_ado, - ) : () - }, + include => 'rdbms_mssql_ado', + env => [ + DBICTEST_MSSQL_ADO_DSN => 1, + DBICTEST_MSSQL_ADO_USER => 0, + DBICTEST_MSSQL_ADO_PASS => 0, + ], }, test_rdbms_mssql_sybase => { - req => { - $ENV{DBICTEST_MSSQL_DSN} - ? ( - %$rdbms_mssql_sybase, - ) : () - }, + include => 'rdbms_mssql_sybase', + env => [ + DBICTEST_MSSQL_DSN => 1, + DBICTEST_MSSQL_USER => 0, + DBICTEST_MSSQL_PASS => 0, + ], }, test_rdbms_msaccess_odbc => { + include => 'rdbms_msaccess_odbc', + env => [ + DBICTEST_MSACCESS_ODBC_DSN => 1, + DBICTEST_MSACCESS_ODBC_USER => 0, + DBICTEST_MSACCESS_ODBC_PASS => 0, + ], req => { - $ENV{DBICTEST_MSACCESS_ODBC_DSN} - ? ( - %$rdbms_msaccess_odbc, - %$datetime_basic, - 'Data::GUID' => '0', - ) : () + 'Data::GUID' => '0', }, }, test_rdbms_msaccess_ado => { + include => 'rdbms_msaccess_ado', + env => [ + DBICTEST_MSACCESS_ADO_DSN => 1, + DBICTEST_MSACCESS_ADO_USER => 0, + DBICTEST_MSACCESS_ADO_PASS => 0, + ], req => { - $ENV{DBICTEST_MSACCESS_ADO_DSN} - ? ( - %$rdbms_msaccess_ado, - %$datetime_basic, - 'Data::GUID' => 0, - ) : () + 'Data::GUID' => 0, }, }, test_rdbms_mysql => { - req => { - $ENV{DBICTEST_MYSQL_DSN} - ? ( - %$rdbms_mysql, - ) : () - }, + include => 'rdbms_mysql', + env => [ + DBICTEST_MYSQL_DSN => 1, + DBICTEST_MYSQL_USER => 0, + DBICTEST_MYSQL_PASS => 0, + ], }, test_rdbms_oracle => { + include => 'rdbms_oracle', + env => [ + DBICTEST_ORA_DSN => 1, + DBICTEST_ORA_USER => 0, + DBICTEST_ORA_PASS => 0, + ], req => { - $ENV{DBICTEST_ORA_DSN} - ? ( - %$rdbms_oracle, - 'DateTime::Format::Oracle' => '0', - 'DBD::Oracle' => '1.24', - ) : () + 'DBD::Oracle' => '1.24', }, }, test_rdbms_ase => { - req => { - $ENV{DBICTEST_SYBASE_DSN} - ? ( - %$rdbms_ase, - ) : () - }, + include => 'rdbms_ase', + env => [ + DBICTEST_SYBASE_DSN => 1, + DBICTEST_SYBASE_USER => 0, + DBICTEST_SYBASE_PASS => 0, + ], }, test_rdbms_db2 => { - req => { - $ENV{DBICTEST_DB2_DSN} - ? ( - %$rdbms_db2, - ) : () - }, + include => 'rdbms_db2', + env => [ + DBICTEST_DB2_DSN => 1, + DBICTEST_DB2_USER => 0, + DBICTEST_DB2_PASS => 0, + ], }, test_rdbms_db2_400 => { - req => { - $ENV{DBICTEST_DB2_400_DSN} - ? ( - %$rdbms_db2_400, - ) : () - }, + include => 'rdbms_db2_400', + env => [ + DBICTEST_DB2_400_DSN => 1, + DBICTEST_DB2_400_USER => 0, + DBICTEST_DB2_400_PASS => 0, + ], }, test_rdbms_informix => { - req => { - $ENV{DBICTEST_INFORMIX_DSN} - ? ( - %$rdbms_informix, - ) : () - }, + include => 'rdbms_informix', + env => [ + DBICTEST_INFORMIX_DSN => 1, + DBICTEST_INFORMIX_USER => 0, + DBICTEST_INFORMIX_PASS => 0, + ], }, test_rdbms_sqlanywhere => { - req => { - $ENV{DBICTEST_SQLANYWHERE_DSN} - ? ( - %$rdbms_sqlanywhere, - ) : () - }, + include => 'rdbms_sqlanywhere', + env => [ + DBICTEST_SQLANYWHERE_DSN => 1, + DBICTEST_SQLANYWHERE_USER => 0, + DBICTEST_SQLANYWHERE_PASS => 0, + ], }, test_rdbms_sqlanywhere_odbc => { - req => { - $ENV{DBICTEST_SQLANYWHERE_ODBC_DSN} - ? ( - %$rdbms_sqlanywhere_odbc, - ) : () - }, + include => 'rdbms_sqlanywhere_odbc', + env => [ + DBICTEST_SQLANYWHERE_ODBC_DSN => 1, + DBICTEST_SQLANYWHERE_ODBC_USER => 0, + DBICTEST_SQLANYWHERE_ODBC_PASS => 0, + ], }, test_rdbms_firebird => { - req => { - $ENV{DBICTEST_FIREBIRD_DSN} - ? ( - %$rdbms_firebird, - ) : () - }, + include => 'rdbms_firebird', + env => [ + DBICTEST_FIREBIRD_DSN => 1, + DBICTEST_FIREBIRD_USER => 0, + DBICTEST_FIREBIRD_PASS => 0, + ], }, test_rdbms_firebird_interbase => { - req => { - $ENV{DBICTEST_FIREBIRD_INTERBASE_DSN} - ? ( - %$rdbms_firebird_interbase, - ) : () - }, + include => 'rdbms_firebird_interbase', + env => [ + DBICTEST_FIREBIRD_INTERBASE_DSN => 1, + DBICTEST_FIREBIRD_INTERBASE_USER => 0, + DBICTEST_FIREBIRD_INTERBASE_PASS => 0, + ], }, test_rdbms_firebird_odbc => { - req => { - $ENV{DBICTEST_FIREBIRD_ODBC_DSN} - ? ( - %$rdbms_firebird_odbc, - ) : () - }, + include => 'rdbms_firebird_odbc', + env => [ + DBICTEST_FIREBIRD_ODBC_DSN => 1, + DBICTEST_FIREBIRD_ODBC_USER => 0, + DBICTEST_FIREBIRD_ODBC_PASS => 0, + ], }, test_memcached => { + env => [ + DBICTEST_MEMCACHED => 1, + ], req => { - $ENV{DBICTEST_MEMCACHED} - ? ( - 'Cache::Memcached' => 0, - ) : () + 'Cache::Memcached' => 0, }, }, dist_dir => { + # we need to run the dbicadmin so we can self-generate its POD + # also we do not want surprises in case JSON::XS is in the path + # so make sure we get an always-working JSON::Any + include => [qw( + admin_script + _json_xs_compatible_json_any + id_shortener + deploy + test_pod + test_podcoverage + test_whitespace + test_strictures + )], req => { - %$test_and_dist_json_any, 'ExtUtils::MakeMaker' => '6.64', - 'Pod::Inherit' => '0.90', - 'Pod::Tree' => '0', - } + 'Module::Install' => '1.06', + 'Pod::Inherit' => '0.91', + }, }, dist_upload => { @@ -633,107 +694,478 @@ my $reqs = { 'CPAN::Uploader' => '0.103001', }, }, - }; -our %req_availability_cache; -sub req_list_for { - my ($class, $group) = @_; - Carp::croak "req_list_for() expects a requirement group name" - unless $group; +### Public API + +sub import { + my $class = shift; + + if (@_) { + + my $action = shift; + + if ($action eq '-die_without') { + my $err; + { + local $@; + eval { $class->die_unless_req_ok_for(\@_); 1 } + or $err = $@; + } + die "\n$err\n" if $err; + } + elsif ($action eq '-list_missing') { + print $class->modreq_missing_for(\@_); + print "\n"; + exit 0; + } + elsif ($action eq '-skip_all_without') { + + # sanity check - make sure ->current_test is 0 and no plan has been declared + do { + local $@; + defined eval { + Test::Builder->new->current_test + or + Test::Builder->new->has_plan + }; + } and croak("Unable to invoke -skip_all_without after testing has started"); - my $deps = $reqs->{$group}{req} - or Carp::croak "Requirement group '$group' does not exist"; + if ( my $missing = $class->req_missing_for(\@_) ) { - return { %$deps }; + die ("\nMandatory requirements not satisfied during release-testing: $missing\n\n") + if $ENV{RELEASE_TESTING} and $class->_groups_to_reqs(\@_)->{release_testing_mandatory}; + + print "1..0 # SKIP requirements not satisfied: $missing\n"; + exit 0; + } + } + elsif ($action =~ /^-/) { + croak "Unknown import-time action '$action'"; + } + else { + croak "$class is not an exporter, unable to import '$action'"; + } + } + + 1; } +sub unimport { + croak( __PACKAGE__ . " does not implement unimport" ); +} -sub die_unless_req_ok_for { - my ($class, $group) = @_; +# OO for (mistakenly considered) ease of extensibility, not due to any need to +# carry state of any sort. This API is currently used outside, so leave as-is. +# FIXME - make sure to not propagate this further if module is extracted as a +# standalone library - keep the stupidity to a DBIC-secific shim! +# +sub req_list_for { + shift->_groups_to_reqs(shift)->{effective_modreqs}; +} + +sub modreq_list_for { + shift->_groups_to_reqs(shift)->{modreqs}; +} - Carp::croak "die_unless_req_ok_for() expects a requirement group name" - unless $group; +sub req_group_list { + +{ map + { $_ => $_[0]->_groups_to_reqs($_) } + grep { $_ !~ /^_/ } keys %$dbic_reqs + } +} - $class->_check_deps($group)->{status} - or die sprintf( "Required modules missing, unable to continue: %s\n", $class->_check_deps($group)->{missing} ); +sub req_errorlist_for { shift->modreq_errorlist_for(shift) } # deprecated +sub modreq_errorlist_for { + my ($self, $groups) = @_; + $self->_errorlist_for_modreqs( $self->_groups_to_reqs($groups)->{modreqs} ); } sub req_ok_for { - my ($class, $group) = @_; + shift->req_missing_for(shift) ? 0 : 1; +} + +sub req_missing_for { + my ($self, $groups) = @_; + + my $reqs = $self->_groups_to_reqs($groups); + + my $mods_missing = $reqs->{missing_envvars} + ? $self->_list_physically_missing_modules( $reqs->{modreqs} ) + : $self->modreq_missing_for($groups) + ; - Carp::croak "req_ok_for() expects a requirement group name" - unless $group; + return '' if + ! $mods_missing + and + ! $reqs->{missing_envvars} + ; + + my @res = $mods_missing || (); - return $class->_check_deps($group)->{status}; + push @res, 'the following group(s) of environment variables: ' . join ' and ', sort map + { __envvar_group_desc($_) } + @{$reqs->{missing_envvars}} + if $reqs->{missing_envvars}; + + return ( + ( join ' as well as ', @res ) + . + ( $reqs->{modreqs_fully_documented} ? " (see @{[ ref $self || $self ]} documentation for details)" : '' ), + ); } -sub req_missing_for { - my ($class, $group) = @_; +sub modreq_missing_for { + my ($self, $groups) = @_; + + my $reqs = $self->_groups_to_reqs($groups); + my $modreq_errors = $self->_errorlist_for_modreqs($reqs->{modreqs}) + or return ''; + + join ' ', map + { $reqs->{modreqs}{$_} ? "$_~$reqs->{modreqs}{$_}" : $_ } + sort { lc($a) cmp lc($b) } keys %$modreq_errors + ; +} + +my $tb; +sub skip_without { + my ($self, $groups) = @_; + + $tb ||= do { local $@; eval { Test::Builder->new } } + or croak "Calling skip_without() before loading Test::Builder makes no sense"; + + if ( my $err = $self->req_missing_for($groups) ) { + my ($fn, $ln) = (caller(0))[1,2]; + $tb->skip("block in $fn around line $ln requires $err"); + local $^W = 0; + last SKIP; + } - Carp::croak "req_missing_for() expects a requirement group name" - unless $group; + 1; +} - return $class->_check_deps($group)->{missing}; +sub die_unless_req_ok_for { + if (my $err = shift->req_missing_for(shift) ) { + die "Unable to continue due to missing requirements: $err\n"; + } } -sub req_errorlist_for { - my ($class, $group) = @_; - Carp::croak "req_errorlist_for() expects a requirement group name" - unless $group; - return $class->_check_deps($group)->{errorlist}; +### Private functions + +# potentially shorten group desc +sub __envvar_group_desc { + my @envs = @{$_[0]}; + + my (@res, $last_prefix); + while (my $ev = shift @envs) { + my ($pref, $sep, $suff) = split / ([\_\-]) (?= [^\_\-]+ \z )/x, $ev; + + if ( defined $sep and ($last_prefix||'') eq $pref ) { + push @res, "...${sep}${suff}" + } + else { + push @res, $ev; + } + + $last_prefix = $pref if $sep; + } + + join '/', @res; } -sub _check_deps { - my ($class, $group) = @_; +my $groupname_re = qr/ [a-z_] [0-9_a-z]* /x; +my $modname_re = qr/ [A-Z_a-z] [0-9A-Z_a-z]* (?:::[0-9A-Z_a-z]+)* /x; +my $modver_re = qr/ [0-9]+ (?: \. [0-9]+ )? /x; + +# Expand includes from a random group in a specific order: +# nonvariable groups first, then their includes, then the variable groups, +# then their includes. +# This allows reliably marking the rest of the mod reqs as variable (this is +# also why variable includes are currently not allowed) +sub __expand_includes { + my ($groups, $seen) = @_; + + # !! DIFFERENT !! behavior and return depending on invocation mode + # (easier to recurse this way) + my $is_toplevel = $seen + ? 0 + : !! ($seen = {}) + ; + + my ($res_per_type, $missing_envvars); + + # breadth-first evaluation, with non-variable includes on top + for my $g (@$groups) { + + croak "Invalid requirement group name '$g': only ascii alphanumerics and _ are allowed" + if $g !~ qr/ \A $groupname_re \z/x; + + my $r = $dbic_reqs->{$g} + or croak "Requirement group '$g' is not defined"; + + # always do this check *before* the $seen check + croak "Group '$g' with variable effective_modreqs can not be specified as an 'include'" + if ( $r->{env} and ! $is_toplevel ); + + next if $seen->{$g}++; + + my $req_type = 'static'; - return $req_availability_cache{$group} ||= do { + if ( my @e = @{$r->{env}||[]} ) { - my $deps = $class->req_list_for ($group); + croak "Unexpected 'env' attribute under group '$g' (only allowed in test_* groups)" + unless $g =~ /^test_/; - my %errors; - for my $mod (keys %$deps) { - my $req_line = "require $mod;"; - if (my $ver = $deps->{$mod}) { - $req_line .= "$mod->VERSION($ver);"; + croak "Unexpected *odd* list in 'env' under group '$g'" + if @e % 2; + + # deconstruct the whole thing + my (@group_envnames_list, $some_envs_required, $some_required_missing); + while (@e) { + push @group_envnames_list, my $envname = shift @e; + + # env required or not + next unless shift @e; + + $some_envs_required ||= 1; + + $some_required_missing ||= ( + ! defined $ENV{$envname} + or + ! length $ENV{$envname} + ); } - eval $req_line; + croak "None of the envvars in group '$g' declared as required, making the requirement moot" + unless $some_envs_required; - $errors{$mod} = $@ if $@; + if ($some_required_missing) { + push @{$missing_envvars->{$g}}, \@group_envnames_list; + $req_type = 'variable'; + } } - my $res; + push @{$res_per_type->{"base_${req_type}"}}, $g; + + if (my $i = $dbic_reqs->{$g}{include}) { + $i = [ $i ] unless ref $i eq 'ARRAY'; + + croak "Malformed 'include' for group '$g': must be another existing group name or arrayref of existing group names" + unless @$i; - if (keys %errors) { - my $missing = join (', ', map { $deps->{$_} ? "$_ >= $deps->{$_}" : $_ } (sort keys %errors) ); - $missing .= " (see $class for details)" if $reqs->{$group}{pod}; - $res = { - status => 0, - errorlist => \%errors, - missing => $missing, - }; + push @{$res_per_type->{"incs_${req_type}"}}, @$i; + } + } + + my @ret = map { + @{ $res_per_type->{"base_${_}"} || [] }, + ( $res_per_type->{"incs_${_}"} ? __expand_includes( $res_per_type->{"incs_${_}"}, $seen ) : () ), + } qw(static variable); + + return ! $is_toplevel ? @ret : do { + my $rv = {}; + $rv->{$_} = { + idx => 1 + keys %$rv, + missing_envvars => $missing_envvars->{$_}, + } for @ret; + $rv->{$_}{user_requested} = 1 for @$groups; + $rv; + }; +} + +### Private OO API +our %req_unavailability_cache; + +# this method is just a lister and envvar/metadata checker - it does not try to load anything +sub _groups_to_reqs { + my ($self, $want) = @_; + + $want = [ $want || () ] + unless ref $want eq 'ARRAY'; + + croak "@{[ (caller(1))[3] ]}() expects a requirement group name or arrayref of group names" + unless @$want; + + my $ret = { + modreqs => {}, + modreqs_fully_documented => 1, + }; + + my $groups; + for my $piece (@$want) { + if ($piece =~ qr/ \A $groupname_re \z /x) { + push @$groups, $piece; + } + elsif ( my ($mod, $ver) = $piece =~ qr/ \A ($modname_re) \>\= ($modver_re) \z /x ) { + croak "Ad hoc module specification lists '$mod' twice" + if exists $ret->{modreqs}{$mod}; + + croak "Ad hoc module specification '${mod} >= $ver' (or greater) not listed in the test_adhoc optdep group" if ( + ! defined $dbic_reqs->{test_adhoc}{req}{$mod} + or + $dbic_reqs->{test_adhoc}{req}{$mod} < $ver + ); + + $ret->{modreqs}{$mod} = $ver; + $ret->{modreqs_fully_documented} = 0; } else { - $res = { - status => 1, - errorlist => {}, - missing => '', - }; + croak "Unsupported argument '$piece' supplied to @{[ (caller(1))[3] ]}()" } + } - $res; - }; + my $all_groups = __expand_includes($groups); + + # pre-assemble list of augmentations, perform basic sanity checks + # Note that below we *DO NOT* respect the source/target reationship, but + # instead always default to augment the "later" group + # This is done so that the "stable/variable" boundary keeps working as + # expected + my $augmentations; + for my $requesting_group (keys %$all_groups) { + if (my $ag = $dbic_reqs->{$requesting_group}{augment}) { + for my $target_group (keys %$ag) { + + croak "Group '$requesting_group' claims to augment a non-existent group '$target_group'" + unless $dbic_reqs->{$target_group}; + + croak "Augmentation combined with variable effective_modreqs currently unsupported for group '$requesting_group'" + if $dbic_reqs->{$requesting_group}{env}; + + croak "Augmentation of group '$target_group' with variable effective_modreqs unsupported (requested by '$requesting_group')" + if $dbic_reqs->{$target_group}{env}; + + if (my @foreign = grep { $_ ne 'req' } keys %{$ag->{$target_group}} ) { + croak "Only 'req' augmentations are currently supported (group '$requesting_group' attempts to alter '$foreign[0]' of group '$target_group'"; + } + + $ret->{augments}{$target_group} = 1; + + # no augmentation for stuff that hasn't been selected + if ( $all_groups->{$target_group} and my $ar = $ag->{$target_group}{req} ) { + push @{$augmentations->{ + ( $all_groups->{$requesting_group}{idx} < $all_groups->{$target_group}{idx} ) + ? $target_group + : $requesting_group + }}, $ar; + } + } + } + } + + for my $group (sort { $all_groups->{$a}{idx} <=> $all_groups->{$b}{idx} } keys %$all_groups ) { + + my $group_reqs = $dbic_reqs->{$group}{req}; + + # sanity-check + for my $req_bag ($group_reqs, @{ $augmentations->{$group} || [] } ) { + for (keys %$req_bag) { + + $_ =~ / \A $modname_re \z /x + or croak "Requirement '$_' in group '$group' is not a valid module name"; + + # !!!DO NOT CHANGE!!! + # remember - version.pm may not be available on the system + croak "Requirement '$_' in group '$group' specifies an invalid version '$req_bag->{$_}' (only plain non-underscored floating point decimals are supported)" + if ( ($req_bag->{$_}||0) !~ qr/ \A $modver_re \z /x ); + } + } + + if (my $e = $all_groups->{$group}{missing_envvars}) { + push @{$ret->{missing_envvars}}, @$e; + } + + # assemble into the final ret + for my $type ( + 'modreqs', + ( $ret->{missing_envvars} ? () : 'effective_modreqs' ), + ) { + for my $req_bag ($group_reqs, @{ $augmentations->{$group} || [] } ) { + for my $mod (keys %$req_bag) { + + $ret->{$type}{$mod} = $req_bag->{$mod}||0 if ( + + ! exists $ret->{$type}{$mod} + or + # we sanitized the version to be numeric above - we can just -gt it + ($req_bag->{$mod}||0) > $ret->{$type}{$mod} + + ); + } + } + } + + $ret->{modreqs_fully_documented} &&= !!$dbic_reqs->{$group}{pod} + if $all_groups->{$group}{user_requested}; + + $ret->{release_testing_mandatory} ||= !!$dbic_reqs->{$group}{release_testing_mandatory}; + } + + return $ret; } -sub req_group_list { - return { map { $_ => { %{ $reqs->{$_}{req} || {} } } } (keys %$reqs) }; + +# this method tries to find/load specified modreqs and returns a hashref of +# module/loaderror pairs for anything that failed +sub _errorlist_for_modreqs { + # args supposedly already went through _groups_to_reqs and are therefore sanitized + # safe to eval at will + my ($self, $reqs) = @_; + + my $ret; + + for my $m ( keys %$reqs ) { + my $v = $reqs->{$m}; + + if (! exists $req_unavailability_cache{$m}{$v} ) { + local $@; + eval( "require $m;" . ( $v ? "$m->VERSION(q($v))" : '' ) ); + $req_unavailability_cache{$m}{$v} = $@; + } + + $ret->{$m} = $req_unavailability_cache{$m}{$v} + if $req_unavailability_cache{$m}{$v}; + } + + $ret; } +# Unlike the above DO NOT try to load anything +# This is executed when some needed envvars are not available +# which in turn means a module load will never be reached anyway +# This is important because some modules (especially DBDs) can be +# *really* fickle when a require() is attempted, with pretty confusing +# side-effects (especially on windows) +sub _list_physically_missing_modules { + my ($self, $modreqs) = @_; + + # in case there is a coderef in @INC there is nothing we can definitively prove + # so short circuit directly + return '' if grep { length ref $_ } @INC; + + my @definitely_missing; + for my $mod (keys %$modreqs) { + (my $fn = $mod . '.pm') =~ s|::|/|g; + + push @definitely_missing, $mod unless grep + # this should work on any combination of slashes + { $_ and -d $_ and -f "$_/$fn" and -r "$_/$fn" } + @INC + ; + } + + join ' ', map + { $modreqs->{$_} ? "$_~$modreqs->{$_}" : $_ } + sort { lc($a) cmp lc($b) } @definitely_missing + ; +} + + # This is to be called by the author only (automatically in Makefile.PL) sub _gen_pod { my ($class, $distver, $pod_dir) = @_; @@ -762,11 +1194,16 @@ sub _gen_pod { File::Path::mkpath([$dir]); - my $sqltver = $class->req_list_for ('deploy')->{'SQL::Translator'} + my $sqltver = $class->req_list_for('deploy')->{'SQL::Translator'} or die "Hrmm? No sqlt dep?"; - my @chunks = ( - <<"EOC", + + my @chunks; + +#@@ +#@@ HEADER +#@@ + push @chunks, <<"EOC"; ######################################################################### ##################### A U T O G E N E R A T E D ######################## ######################################################################### @@ -775,152 +1212,415 @@ sub _gen_pod { # will be lost. If you need to change the generated text edit _gen_pod() # at the end of $modfn # + +=head1 NAME + +$class - Optional module dependency specifications (for module authors) EOC - '=head1 NAME', - "$class - Optional module dependency specifications (for module authors)", - '=head1 SYNOPSIS', - <<"EOS", -Somewhere in your build-file (e.g. L's Makefile.PL): + + +#@@ +#@@ SYNOPSIS HEADING +#@@ + push @chunks, <<"EOC"; +=head1 SYNOPSIS + +Somewhere in your build-file (e.g. L's F): ... - configure_requires 'DBIx::Class' => '$distver'; + \$EUMM_ARGS{CONFIGURE_REQUIRES} = { + \%{ \$EUMM_ARGS{CONFIGURE_REQUIRES} || {} }, + 'DBIx::Class' => '$distver', + }; - require $class; + ... - my \$deploy_deps = $class->req_list_for('deploy'); + my %DBIC_DEPLOY_AND_ORACLE_DEPS = %{ eval { + require $class; + $class->req_list_for([qw( deploy rdbms_oracle ic_dt )]); + } || {} }; - for (keys %\$deploy_deps) { - requires \$_ => \$deploy_deps->{\$_}; - } + \$EUMM_ARGS{PREREQ_PM} = { + \%DBIC_DEPLOY_AND_ORACLE_DEPS, + \%{ \$EUMM_ARGS{PREREQ_PM} || {} }, + }; ... -Note that there are some caveats regarding C, more info -can be found at L -EOS - '=head1 DESCRIPTION', - <<'EOD', + ExtUtils::MakeMaker::WriteMakefile(\%EUMM_ARGS); + +B: The C protection within the example is due to support for +requirements during L build phase|CPAN::Meta::Spec/Phases> +not being available on a sufficient portion of production installations of +Perl. Robust support for such dependency requirements is available in the +L installer only since version C<1.94_56> first made available for +production with perl version C<5.12>. It is the belief of the current +maintainer that support for requirements during the C build phase +will not be sufficiently ubiquitous until the B at the earliest, +hence the extra care demonstrated above. It should also be noted that some +3rd party installers (e.g. L) do the right thing +with configure requirements independent from the versions of perl and CPAN +available. +EOC + + +#@@ +#@@ DESCRIPTION HEADING +#@@ + push @chunks, <<'EOC'; +=head1 DESCRIPTION + Some of the less-frequently used features of L have external module dependencies on their own. In order not to burden the average user -with modules he will never use, these optional dependencies are not included +with modules they will never use, these optional dependencies are not included in the base Makefile.PL. Instead an exception with a descriptive message is -thrown when a specific feature is missing one or several modules required for -its operation. This module is the central holding place for the current list +thrown when a specific feature can't find one or several modules required for +its operation. This module is the central holding place for the current list of such dependencies, for DBIx::Class core authors, and DBIx::Class extension authors alike. -EOD - '=head1 CURRENT REQUIREMENT GROUPS', - <<'EOD', -Dependencies are organized in C and each group can list one or more -required modules, with an optional minimum version (or 0 for any version). -The group name can be used in the -EOD - ); - for my $group (sort keys %$reqs) { - my $p = $reqs->{$group}{pod} - or next; +Dependencies are organized in L where each +group can list one or more required modules, with an optional minimum version +(or 0 for any version). In addition groups prefixed with C can specify +a set of environment variables, some (or all) of which are marked as required +for the group to be considered by L + +Each group name (or a combination thereof) can be used in the +L as described below. +EOC + - my $modlist = $reqs->{$group}{req} - or next; +#@@ +#@@ REQUIREMENT GROUPLIST HEADING +#@@ + push @chunks, '=head1 CURRENT REQUIREMENT GROUPS'; - next unless keys %$modlist; + my $standalone_info; + + for my $group (sort keys %$dbic_reqs) { + + my $info = $standalone_info->{$group} ||= $class->_groups_to_reqs($group); + + next unless ( + $info->{modreqs_fully_documented} + and + ( $info->{augments} or $info->{modreqs} ) + ); + + my $p = $dbic_reqs->{$group}{pod}; push @chunks, ( "=head2 $p->{title}", - "$p->{desc}", + "=head3 $group", + $p->{desc}, '=over', - ( map { "=item * $_" . ($modlist->{$_} ? " >= $modlist->{$_}" : '') } (sort keys %$modlist) ), - '=back', - "Requirement group: B<$group>", ); + + if ( keys %{ $info->{modreqs}||{} } ) { + push @chunks, map + { "=item * $_" . ($info->{modreqs}{$_} ? " >= $info->{modreqs}{$_}" : '') } + ( sort keys %{ $info->{modreqs} } ) + ; + } + else { + push @chunks, '=item * No standalone requirements', + } + + push @chunks, '=back'; + + for my $ag ( sort keys %{ $info->{augments} || {} } ) { + my $ag_info = $standalone_info->{$ag} ||= $class->_groups_to_reqs($ag); + + my $newreqs = $class->modreq_list_for([ $group, $ag ]); + for (keys %$newreqs) { + delete $newreqs->{$_} if ( + ( defined $info->{modreqs}{$_} and $info->{modreqs}{$_} == $newreqs->{$_} ) + or + ( defined $ag_info->{modreqs}{$_} and $ag_info->{modreqs}{$_} == $newreqs->{$_} ) + ); + } + + if (keys %$newreqs) { + push @chunks, ( + "Combined with L additionally requires:", + '=over', + ( map + { "=item * $_" . ($newreqs->{$_} ? " >= $newreqs->{$_}" : '') } + ( sort keys %$newreqs ) + ), + '=back', + ); + } + } } - push @chunks, ( - '=head1 METHODS', - '=head2 req_group_list', - '=over', - '=item Arguments: none', - '=item Return Value: \%list_of_requirement_groups', - '=back', - <<'EOD', + +#@@ +#@@ API DOCUMENTATION HEADING +#@@ + push @chunks, <<'EOC'; + +=head1 IMPORT-LIKE ACTIONS + +Even though this module is not an L, it recognizes several C +supplied to its C method. + +=head2 -skip_all_without + +=over + +=item Arguments: @group_names + +=back + +A convenience wrapper for use during testing: +EOC + + push @chunks, " use $class -skip_all_without => qw(admin test_rdbms_mysql);"; + + push @chunks, 'Roughly equivalent to the following code:'; + + push @chunks, sprintf <<'EOS', ($class) x 2; + + BEGIN { + require %s; + if ( my $missing = %s->req_missing_for(\@group_names_) ) { + print "1..0 # SKIP requirements not satisfied: $missing\n"; + exit 0; + } + } +EOS + + push @chunks, <<'EOC'; + +It also takes into account the C environment variable and +behaves like L for any requirement groups marked as +C. + +=head2 -die_without + +=over + +=item Arguments: @group_names + +=back + +A convenience wrapper around L: +EOC + + push @chunks, " use $class -die_without => qw(deploy admin);"; + + push @chunks, <<'EOC'; + +=head2 -list_missing + +=over + +=item Arguments: @group_names + +=back + +A convenience wrapper around L: + + perl -Ilib -MDBIx::Class::Optional::Dependencies=-list_missing,deploy,admin | cpanm + +=head1 METHODS + +=head2 req_group_list + +=over + +=item Arguments: none + +=item Return Value: \%list_of_requirement_groups + +=back + This method should be used by DBIx::Class packagers, to get a hashref of all -dependencies keyed by dependency group. Each key (group name) can be supplied -to one of the group-specific methods below. -EOD - - '=head2 req_list_for', - '=over', - '=item Arguments: $group_name', - '=item Return Value: \%list_of_module_version_pairs', - '=back', - <<'EOD', +dependencies B by dependency group. Each key (group name), or a combination +thereof (as an arrayref) can be supplied to the methods below. +The B of the returned hash are currently a set of options B. If you have use for any of the contents - contact the +maintainers, instead of treating this as public (left alone stable) API. + +=head2 req_list_for + +=over + +=item Arguments: $group_name | \@group_names + +=item Return Value: \%set_of_module_version_pairs + +=back + This method should be used by DBIx::Class extension authors, to determine the -version of modules a specific feature requires in the B version of -DBIx::Class. See the L for a real-world -example. -EOD - - '=head2 req_ok_for', - '=over', - '=item Arguments: $group_name', - '=item Return Value: 1|0', - '=back', - <<'EOD', -Returns true or false depending on whether all modules required by -C<$group_name> are present on the system and loadable. -EOD - - '=head2 req_missing_for', - '=over', - '=item Arguments: $group_name', - '=item Return Value: $error_message_string', - '=back', - <<"EOD", -Returns a single line string suitable for inclusion in larger error messages. -This method would normally be used by DBIx::Class core-module author, to -indicate to the user that he needs to install specific modules before he will -be able to use a specific feature. +version of modules a specific set of features requires for this version of +DBIx::Class (regardless of their availability on the system). +See the L for a real-world example. + +When handling C groups this method behaves B from +L below (and is the only such inconsistency among the +C methods). If a particular group declares as requirements some +C and these requirements are not satisfied (the envvars +are unset) - then the C of this group are not included in +the returned list. + +=head2 modreq_list_for + +=over + +=item Arguments: $group_name | \@group_names + +=item Return Value: \%set_of_module_version_pairs + +=back + +Same as L but does not take into consideration any +C - returns just the list of required +modules. + +=head2 req_ok_for + +=over + +=item Arguments: $group_name | \@group_names + +=item Return Value: 1|0 + +=back + +Returns true or false depending on whether all modules/envvars required by +the group(s) are loadable/set on the system. + +=head2 req_missing_for + +=over + +=item Arguments: $group_name | \@group_names + +=item Return Value: $error_message_string + +=back + +Returns a single-line string suitable for inclusion in larger error messages. +This method would normally be used by DBIx::Class core features, to indicate to +the user that they need to install specific modules and/or set specific +environment variables before being able to use a specific feature set. For example if some of the requirements for C are not available, the returned string could look like: +EOC - SQL::Translator >= $sqltver (see $class for details) + push @chunks, qq{ "SQL::Translator~$sqltver" (see $class documentation for details)}; + push @chunks, <<'EOC'; The author is expected to prepend the necessary text to this message before -returning the actual error seen by the user. -EOD - - '=head2 die_unless_req_ok_for', - '=over', - '=item Arguments: $group_name', - '=back', - <<'EOD', -Checks if L passes for the supplied C<$group_name>, and +returning the actual error seen by the user. See also L + +=head2 modreq_missing_for + +=over + +=item Arguments: $group_name | \@group_names + +=item Return Value: $error_message_string + +=back + +Same as L except that the error string is guaranteed to be +either empty, or contain a set of module requirement specifications suitable +for piping to e.g. L. The method explicitly does not +attempt to validate the state of required environment variables (if any). + +For instance if some of the requirements for C are not available, +the returned string could look like: +EOC + + push @chunks, qq{ "SQL::Translator~$sqltver"}; + + push @chunks, <<'EOC'; + +See also L. + +=head2 skip_without + +=over + +=item Arguments: $group_name | \@group_names + +=back + +A convenience wrapper around L. It does not take neither +a reason (it is generated by L) nor an amount of skipped tests +(it is always C<1>, thus mandating unconditional use of +L). Most useful in combination with ad hoc +requirement specifications: +EOC + + push @chunks, <skip_without([ deploy YAML>=0.90 ]); + + ... + } +EOC + + push @chunks, <<'EOC'; + +=head2 die_unless_req_ok_for + +=over + +=item Arguments: $group_name | \@group_names + +=back + +Checks if L passes for the supplied group(s), and in case of failure throws an exception including the information -from L. -EOD - - '=head2 req_errorlist_for', - '=over', - '=item Arguments: $group_name', - '=item Return Value: \%list_of_loaderrors_per_module', - '=back', - <<'EOD', +from L. See also L. + +=head2 modreq_errorlist_for + +=over + +=item Arguments: $group_name | \@group_names + +=item Return Value: \%set_of_loaderrors_per_module + +=back + Returns a hashref containing the actual errors that occurred while attempting -to load each module in the requirement group. -EOD - '=head1 AUTHOR', - 'See L.', - '=head1 LICENSE', - 'You may distribute this code under the same terms as Perl itself', - ); +to load each module in the requirement group(s). + +=head2 req_errorlist_for + +Deprecated method name, equivalent (via proxy) to L. + +EOC + +#@@ +#@@ FOOTER +#@@ + push @chunks, <<'EOC'; +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. +EOC - open (my $fh, '>', $podfn) or Carp::croak "Unable to write to $podfn: $!"; - print $fh join ("\n\n", @chunks); - print $fh "\n"; - close ($fh); + eval { + open (my $fh, '>', $podfn) or die; + print $fh join ("\n\n", @chunks) or die; + print $fh "\n" or die; + close ($fh) or die; + } or croak( "Unable to write $podfn: " . ( $! || $@ || 'unknown error') ); } 1; diff --git a/lib/DBIx/Class/Ordered.pm b/lib/DBIx/Class/Ordered.pm index 5e40dc0c2..4c9a14c6b 100644 --- a/lib/DBIx/Class/Ordered.pm +++ b/lib/DBIx/Class/Ordered.pm @@ -147,7 +147,7 @@ Returns an B resultset of all other objects in the same group excluding the one you called it on. The ordering is a backwards-compatibility artifact - if you need -a resultset with no ordering applied use L +a resultset with no ordering applied use C<_siblings> =cut sub siblings { @@ -367,7 +367,30 @@ sub move_to { my $position_column = $self->position_column; - if ($self->is_column_changed ($position_column) ) { + my $is_txn; + if ($is_txn = $self->result_source->schema->storage->transaction_depth) { + # Reload position state from storage + # The thinking here is that if we are in a transaction, it is + # *more likely* the object went out of sync due to resultset + # level shenanigans. Instead of always reloading (slow) - go + # ahead and hand-hold only in the case of higher layers + # requesting the safety of a txn + + $self->store_column( + $position_column, + ( $self->result_source + ->resultset + ->search($self->_storage_ident_condition, { rows => 1, columns => $position_column }) + ->cursor + ->next + )[0] || $self->throw_exception( + sprintf "Unable to locate object '%s' in storage - object went ouf of sync...?", + $self->ID + ), + ); + delete $self->{_dirty_columns}{$position_column}; + } + elsif ($self->is_column_changed ($position_column) ) { # something changed our position, we need to know where we # used to be - use the stashed value $self->store_column($position_column, delete $self->{_column_data_in_storage}{$position_column}); @@ -380,7 +403,7 @@ sub move_to { return 0; } - my $guard = $self->result_source->schema->txn_scope_guard; + my $guard = $is_txn ? undef : $self->result_source->schema->txn_scope_guard; my ($direction, @between); if ( $from_position < $to_position ) { @@ -402,7 +425,7 @@ sub move_to { $self->_shift_siblings ($direction, @between); $self->_ordered_internal_update({ $position_column => $new_pos_val }); - $guard->commit; + $guard->commit if $guard; return 1; } @@ -719,20 +742,13 @@ sub _shift_siblings { if ( first { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) ) ) { - my $cursor = $shift_rs->search ( + my $clean_rs = $rsrc->resultset; + + for ( $shift_rs->search ( {}, { order_by => { "-$ord", $position_column }, select => [$position_column, @pcols] } - )->cursor; - my $rs = $rsrc->resultset; - - my @all_data = $cursor->all; - while (my $data = shift @all_data) { - my $pos = shift @$data; - my $cond; - for my $i (0.. $#pcols) { - $cond->{$pcols[$i]} = $data->[$i]; - } - - $rs->find($cond)->update ({ $position_column => $pos + ( ($op eq '+') ? 1 : -1 ) }); + )->cursor->all ) { + my $pos = shift @$_; + $clean_rs->find(@$_)->update ({ $position_column => $pos + ( ($op eq '+') ? 1 : -1 ) }); } } else { @@ -861,33 +877,31 @@ will prevent such race conditions going undetected. =head2 Multiple Moves -Be careful when issuing move_* methods to multiple objects. If -you've pre-loaded the objects then when you move one of the objects -the position of the other object will not reflect their new value -until you reload them from the database - see -L. +If you have multiple same-group result objects already loaded from storage, +you need to be careful when executing C operations on them: +without a L reload the L of the +"siblings" will be out of sync with the underlying storage. + +Starting from version C<0.082800> DBIC will implicitly perform such +reloads when the C happens as a part of a transaction +(a good example of such situation is C<< $ordered_resultset->delete_all >>). -There are times when you will want to move objects as groups, such -as changing the parent of several objects at once - this directly -conflicts with this problem. One solution is for us to write a -ResultSet class that supports a parent() method, for example. Another -solution is to somehow automagically modify the objects that exist -in the current object's result set to have the new position value. +If it is not possible for you to wrap the entire call-chain in a transaction, +you will need to call L to get an object +up-to-date before proceeding, otherwise undefined behavior will result. =head2 Default Values Using a database defined default_value on one of your group columns could result in the position not being assigned correctly. -=head1 AUTHOR - - Original code framework - Aran Deltac - - Constraints support and code generalisation - Peter Rabbitson +=head1 FURTHER QUESTIONS? -=head1 LICENSE +Check the list of L. -You may distribute this code under the same terms as Perl itself. +=head1 COPYRIGHT AND LICENSE +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/PK.pm b/lib/DBIx/Class/PK.pm index cb204b751..9bda5cac4 100644 --- a/lib/DBIx/Class/PK.pm +++ b/lib/DBIx/Class/PK.pm @@ -87,7 +87,7 @@ sub ID { sub _create_ID { my ($self, %vals) = @_; - return undef unless 0 == grep { !defined } values %vals; + return undef if grep { !defined } values %vals; return join '|', ref $self || $self, $self->result_source->name, map { $_ . '=' . $vals{$_} } sort keys %vals; } @@ -134,15 +134,17 @@ sub _mk_ident_cond { return \%cond; } -1; - -=head1 AUTHOR AND CONTRIBUTORS +=head1 FURTHER QUESTIONS? -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut +1; diff --git a/lib/DBIx/Class/PK/Auto.pm b/lib/DBIx/Class/PK/Auto.pm index 26bd6df72..b4d509cb3 100644 --- a/lib/DBIx/Class/PK/Auto.pm +++ b/lib/DBIx/Class/PK/Auto.pm @@ -7,6 +7,8 @@ use warnings; 1; +__END__ + =head1 NAME DBIx::Class::PK::Auto - Automatic primary key class @@ -41,12 +43,13 @@ The code that was handled here is now in Row for efficiency. The code that was handled here is now in ResultSource, and is being proxied to Row as well. -=head1 AUTHOR AND CONTRIBUTORS - -See L and L in DBIx::Class +=head1 FURTHER QUESTIONS? -=head1 LICENSE +Check the list of L. -You may distribute this code under the same terms as Perl itself. +=head1 COPYRIGHT AND LICENSE -=cut +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/PK/Auto/DB2.pm b/lib/DBIx/Class/PK/Auto/DB2.pm index c7fed5905..1962d79fd 100644 --- a/lib/DBIx/Class/PK/Auto/DB2.pm +++ b/lib/DBIx/Class/PK/Auto/DB2.pm @@ -10,6 +10,8 @@ __PACKAGE__->load_components(qw/PK::Auto/); 1; +__END__ + =head1 NAME DBIx::Class::PK::Auto::DB2 - (DEPRECATED) Automatic primary key class for DB2 @@ -18,12 +20,13 @@ DBIx::Class::PK::Auto::DB2 - (DEPRECATED) Automatic primary key class for DB2 Just load PK::Auto instead; auto-inc is now handled by Storage. -=head1 AUTHOR AND CONTRIBUTORS - -See L and L in DBIx::Class +=head1 FURTHER QUESTIONS? -=head1 LICENSE +Check the list of L. -You may distribute this code under the same terms as Perl itself. +=head1 COPYRIGHT AND LICENSE -=cut +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/PK/Auto/MSSQL.pm b/lib/DBIx/Class/PK/Auto/MSSQL.pm index ce0ee2cc3..5704ffeec 100644 --- a/lib/DBIx/Class/PK/Auto/MSSQL.pm +++ b/lib/DBIx/Class/PK/Auto/MSSQL.pm @@ -10,6 +10,8 @@ __PACKAGE__->load_components(qw/PK::Auto/); 1; +__END__ + =head1 NAME DBIx::Class::PK::Auto::MSSQL - (DEPRECATED) Automatic primary key class for MSSQL @@ -18,12 +20,13 @@ DBIx::Class::PK::Auto::MSSQL - (DEPRECATED) Automatic primary key class for MSSQ Just load PK::Auto instead; auto-inc is now handled by Storage. -=head1 AUTHOR AND CONTRIBUTORS - -See L and L in DBIx::Class +=head1 FURTHER QUESTIONS? -=head1 LICENSE +Check the list of L. -You may distribute this code under the same terms as Perl itself. +=head1 COPYRIGHT AND LICENSE -=cut +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/PK/Auto/MySQL.pm b/lib/DBIx/Class/PK/Auto/MySQL.pm index fd152f767..10fbfd653 100644 --- a/lib/DBIx/Class/PK/Auto/MySQL.pm +++ b/lib/DBIx/Class/PK/Auto/MySQL.pm @@ -10,6 +10,8 @@ __PACKAGE__->load_components(qw/PK::Auto/); 1; +__END__ + =head1 NAME DBIx::Class::PK::Auto::MySQL - (DEPRECATED) Automatic primary key class for MySQL @@ -18,12 +20,13 @@ DBIx::Class::PK::Auto::MySQL - (DEPRECATED) Automatic primary key class for MySQ Just load PK::Auto instead; auto-inc is now handled by Storage. -=head1 AUTHOR AND CONTRIBUTORS - -See L and L in DBIx::Class +=head1 FURTHER QUESTIONS? -=head1 LICENSE +Check the list of L. -You may distribute this code under the same terms as Perl itself. +=head1 COPYRIGHT AND LICENSE -=cut +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/PK/Auto/Oracle.pm b/lib/DBIx/Class/PK/Auto/Oracle.pm index 45e4b0dfd..391b72a69 100644 --- a/lib/DBIx/Class/PK/Auto/Oracle.pm +++ b/lib/DBIx/Class/PK/Auto/Oracle.pm @@ -10,6 +10,8 @@ __PACKAGE__->load_components(qw/PK::Auto/); 1; +__END__ + =head1 NAME DBIx::Class::PK::Auto::Oracle - (DEPRECATED) Automatic primary key class for Oracle @@ -18,12 +20,13 @@ DBIx::Class::PK::Auto::Oracle - (DEPRECATED) Automatic primary key class for Ora Just load PK::Auto instead; auto-inc is now handled by Storage. -=head1 AUTHOR AND CONTRIBUTORS - -See L and L in DBIx::Class +=head1 FURTHER QUESTIONS? -=head1 LICENSE +Check the list of L. -You may distribute this code under the same terms as Perl itself. +=head1 COPYRIGHT AND LICENSE -=cut +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/PK/Auto/Pg.pm b/lib/DBIx/Class/PK/Auto/Pg.pm index a1b24cdad..1ad32b6a7 100644 --- a/lib/DBIx/Class/PK/Auto/Pg.pm +++ b/lib/DBIx/Class/PK/Auto/Pg.pm @@ -10,6 +10,8 @@ __PACKAGE__->load_components(qw/PK::Auto/); 1; +__END__ + =head1 NAME DBIx::Class::PK::Auto::Pg - (DEPRECATED) Automatic primary key class for Pg @@ -18,12 +20,13 @@ DBIx::Class::PK::Auto::Pg - (DEPRECATED) Automatic primary key class for Pg Just load PK::Auto instead; auto-inc is now handled by Storage. -=head1 AUTHOR AND CONTRIBUTORS - -See L and L in DBIx::Class +=head1 FURTHER QUESTIONS? -=head1 LICENSE +Check the list of L. -You may distribute this code under the same terms as Perl itself. +=head1 COPYRIGHT AND LICENSE -=cut +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/PK/Auto/SQLite.pm b/lib/DBIx/Class/PK/Auto/SQLite.pm index 3bc5c5ef9..e98f7f08b 100644 --- a/lib/DBIx/Class/PK/Auto/SQLite.pm +++ b/lib/DBIx/Class/PK/Auto/SQLite.pm @@ -10,6 +10,8 @@ __PACKAGE__->load_components(qw/PK::Auto/); 1; +__END__ + =head1 NAME DBIx::Class::PK::Auto::SQLite - (DEPRECATED) Automatic primary key class for SQLite @@ -18,12 +20,13 @@ DBIx::Class::PK::Auto::SQLite - (DEPRECATED) Automatic primary key class for SQL Just load PK::Auto instead; auto-inc is now handled by Storage. -=head1 AUTHOR AND CONTRIBUTORS - -See L and L in DBIx::Class +=head1 FURTHER QUESTIONS? -=head1 LICENSE +Check the list of L. -You may distribute this code under the same terms as Perl itself. +=head1 COPYRIGHT AND LICENSE -=cut +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Relationship.pm b/lib/DBIx/Class/Relationship.pm index 427b5aaea..195514ce6 100644 --- a/lib/DBIx/Class/Relationship.pm +++ b/lib/DBIx/Class/Relationship.pm @@ -13,6 +13,10 @@ __PACKAGE__->load_own_components(qw/ Base /); +1; + +__END__ + =head1 NAME DBIx::Class::Relationship - Inter-table relationships @@ -105,7 +109,7 @@ L. All helper methods are called similar to the following template: - __PACKAGE__->$method_name('relname', 'Foreign::Class', \%cond|\@cond|\&cond?, \%attrs?); + __PACKAGE__->$method_name('rel_name', 'Foreign::Class', \%cond|\@cond|\&cond?, \%attrs?); Both C and C are optional. Pass C for C if you want to use the default value for it, but still want to set C. @@ -327,7 +331,7 @@ The second is almost exactly the same as the accessor method but "_rs" is added to the end of the method name, eg C<$accessor_name_rs()>. This method works just like the normal accessor, except that it always returns a resultset, even in list context. The third method, named C<< -add_to_$relname >>, will also be added to your Row items; this allows +add_to_$rel_name >>, will also be added to your Row items; this allows you to insert new related items, using the same mechanism as in L. @@ -629,17 +633,13 @@ L for a L which can be assigned to relationships as well. -=cut - -1; - -=head1 AUTHOR AND CONTRIBUTORS - -See L and L in DBIx::Class - -=head1 LICENSE +=head1 FURTHER QUESTIONS? -You may distribute this code under the same terms as Perl itself. +Check the list of L. -=cut +=head1 COPYRIGHT AND LICENSE +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm index 3a12f2836..40deeafa4 100644 --- a/lib/DBIx/Class/Relationship/Accessor.pm +++ b/lib/DBIx/Class/Relationship/Accessor.pm @@ -3,9 +3,8 @@ package # hide from PAUSE use strict; use warnings; -use Sub::Name; use DBIx::Class::Carp; -use DBIx::Class::_Util 'fail_on_internal_wantarray'; +use DBIx::Class::_Util qw(quote_sub perlstring); use namespace::clean; our %_pod_inherit_config = @@ -23,81 +22,91 @@ sub register_relationship { sub add_relationship_accessor { my ($class, $rel, $acc_type) = @_; - my %meth; + if ($acc_type eq 'single') { - my $rel_info = $class->relationship_info($rel); - $meth{$rel} = sub { + quote_sub "${class}::${rel}" => sprintf(<<'EOC', perlstring $rel); my $self = shift; + if (@_) { - $self->set_from_related($rel, @_); - return $self->{_relationship_data}{$rel} = $_[0]; - } elsif (exists $self->{_relationship_data}{$rel}) { - return $self->{_relationship_data}{$rel}; - } else { - my $cond = $self->result_source->_resolve_condition( - $rel_info->{cond}, $rel, $self, $rel + $self->set_from_related( %1$s => @_ ); + return $self->{_relationship_data}{%1$s} = $_[0]; + } + elsif (exists $self->{_relationship_data}{%1$s}) { + return $self->{_relationship_data}{%1$s}; + } + else { + my $relcond = $self->result_source->_resolve_relationship_condition( + rel_name => %1$s, + foreign_alias => %1$s, + self_alias => 'me', + self_result_object => $self, + ); + + return undef if ( + $relcond->{join_free_condition} + and + $relcond->{join_free_condition} ne DBIx::Class::_Util::UNRESOLVABLE_CONDITION + and + scalar grep { not defined $_ } values %%{ $relcond->{join_free_condition} || {} } + and + $self->result_source->relationship_info(%1$s)->{attrs}{undef_on_null_fk} ); - if ($rel_info->{attrs}->{undef_on_null_fk}){ - return undef unless ref($cond) eq 'HASH'; - return undef if grep { not defined $_ } values %$cond; - } - my $val = $self->find_related($rel, {}, {}); + + my $val = $self->search_related( %1$s )->single; return $val unless $val; # $val instead of undef so that null-objects can go through - return $self->{_relationship_data}{$rel} = $val; + return $self->{_relationship_data}{%1$s} = $val; } - }; - } elsif ($acc_type eq 'filter') { +EOC + } + elsif ($acc_type eq 'filter') { $class->throw_exception("No such column '$rel' to filter") unless $class->has_column($rel); + my $f_class = $class->relationship_info($rel)->{class}; - $class->inflate_column($rel, - { inflate => sub { - my ($val, $self) = @_; - return $self->find_or_new_related($rel, {}, {}); - }, - deflate => sub { - my ($val, $self) = @_; - $self->throw_exception("'$val' isn't a $f_class") unless $val->isa($f_class); - - # MASSIVE FIXME - this code assumes we pointed at the PK, but the belongs_to - # helper does not check any of this - # fixup the code a bit to make things saner, but ideally 'filter' needs to - # be deprecated ASAP and removed shortly after - # Not doing so before 0.08250 however, too many things in motion already - my ($pk_col, @rest) = $val->result_source->_pri_cols_or_die; - $self->throw_exception( - "Relationship '$rel' of type 'filter' can not work with a multicolumn primary key on source '$f_class'" - ) if @rest; - - my $pk_val = $val->get_column($pk_col); - carp_unique ( - "Unable to deflate 'filter'-type relationship '$rel' (related object " - . "primary key not retrieved), assuming undef instead" - ) if ( ! defined $pk_val and $val->in_storage ); - - return $pk_val; - } - } - ); - } elsif ($acc_type eq 'multi') { - $meth{$rel} = sub { - DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and wantarray and my $sog = fail_on_internal_wantarray($_[0]); - shift->search_related($rel, @_) - }; - $meth{"${rel}_rs"} = sub { shift->search_related_rs($rel, @_) }; - $meth{"add_to_${rel}"} = sub { shift->create_related($rel, @_); }; - } else { - $class->throw_exception("No such relationship accessor type '$acc_type'"); + + $class->inflate_column($rel, { + inflate => sub { + my ($val, $self) = @_; + return $self->find_or_new_related($rel, {}, {}); + }, + deflate => sub { + my ($val, $self) = @_; + $self->throw_exception("'$val' isn't a $f_class") unless $val->isa($f_class); + + # MASSIVE FIXME - this code assumes we pointed at the PK, but the belongs_to + # helper does not check any of this + # fixup the code a bit to make things saner, but ideally 'filter' needs to + # be deprecated ASAP and removed shortly after + # Not doing so before 0.08250 however, too many things in motion already + my ($pk_col, @rest) = $val->result_source->_pri_cols_or_die; + $self->throw_exception( + "Relationship '$rel' of type 'filter' can not work with a multicolumn primary key on source '$f_class'" + ) if @rest; + + my $pk_val = $val->get_column($pk_col); + carp_unique ( + "Unable to deflate 'filter'-type relationship '$rel' (related object " + . "primary key not retrieved), assuming undef instead" + ) if ( ! defined $pk_val and $val->in_storage ); + + return $pk_val; + }, + }); } - { - no strict 'refs'; - no warnings 'redefine'; - foreach my $meth (keys %meth) { - my $name = join '::', $class, $meth; - *$name = subname($name, $meth{$meth}); - } + elsif ($acc_type eq 'multi') { + + quote_sub "${class}::${rel}_rs", "shift->search_related_rs( $rel => \@_ )"; + quote_sub "${class}::add_to_${rel}", "shift->create_related( $rel => \@_ )"; + quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel ); + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray; + shift->search_related( %s => @_ ) +EOC + } + else { + $class->throw_exception("No such relationship accessor type '$acc_type'"); } + } 1; diff --git a/lib/DBIx/Class/Relationship/Base.pm b/lib/DBIx/Class/Relationship/Base.pm index 20a9c17dd..f5d34f81d 100644 --- a/lib/DBIx/Class/Relationship/Base.pm +++ b/lib/DBIx/Class/Relationship/Base.pm @@ -7,6 +7,7 @@ use base qw/DBIx::Class/; use Scalar::Util qw/weaken blessed/; use Try::Tiny; +use DBIx::Class::_Util 'UNRESOLVABLE_CONDITION'; use namespace::clean; =head1 NAME @@ -38,11 +39,11 @@ methods, for predefined ones, look in L. =over 4 -=item Arguments: 'relname', 'Foreign::Class', $condition, $attrs +=item Arguments: $rel_name, $foreign_class, $condition, $attrs =back - __PACKAGE__->add_relationship('relname', + __PACKAGE__->add_relationship('rel_name', 'Foreign::Class', $condition, $attrs); @@ -180,11 +181,32 @@ L and the resulting SQL will be used verbatim as the C clause of the C statement associated with this relationship. While every coderef-based condition must return a valid C clause, it may -elect to additionally return a simplified join-free condition hashref when -invoked as C<< $result->relationship >>, as opposed to -C<< $rs->related_resultset('relationship') >>. In this case C<$result> is -passed to the coderef as C<< $args->{self_rowobj} >>, so a user can do the -following: +elect to additionally return a simplified B join-free condition +consisting of a hashref with B. This boils down to two scenarios: + +=over + +=item * + +When relationship resolution is invoked after C<< $result->$rel_name >>, as +opposed to C<< $rs->related_resultset($rel_name) >>, the C<$result> object +is passed to the coderef as C<< $args->{self_result_object} >>. + +=item * + +Alternatively when the user-space invokes resolution via +C<< $result->set_from_related( $rel_name => $foreign_values_or_object ) >>, the +corresponding data is passed to the coderef as C<< $args->{foreign_values} >>, +B in the form of a hashref. If a foreign result object is supplied +(which is valid usage of L), its values will be extracted +into hashref form by calling L. + +=back + +Note that the above scenarios are mutually exclusive, that is you will be supplied +none or only one of C and C. In other words if +you define your condition coderef as: sub { my $args = shift; @@ -194,14 +216,17 @@ following: "$args->{foreign_alias}.artist" => { -ident => "$args->{self_alias}.artistid" }, "$args->{foreign_alias}.year" => { '>', "1979", '<', "1990" }, }, - $args->{self_rowobj} && { - "$args->{foreign_alias}.artist" => $args->{self_rowobj}->artistid, + ! $args->{self_result_object} ? () : { + "$args->{foreign_alias}.artist" => $args->{self_result_object}->artistid, "$args->{foreign_alias}.year" => { '>', "1979", '<', "1990" }, }, + ! $args->{foreign_values} ? () : { + "$args->{self_alias}.artistid" => $args->{foreign_values}{artist}, + } ); } -Now this code: +Then this code: my $artist = $schema->resultset("Artist")->find({ id => 4 }); $artist->cds_80s->all; @@ -218,25 +243,46 @@ With the bind values: '4', '1990', '1979' -Note that in order to be able to use -L<< $result->create_related|DBIx::Class::Relationship::Base/create_related >>, -the coderef must not only return as its second such a "simple" condition -hashref which does not depend on joins being available, but the hashref must -contain only plain values/deflatable objects, such that the result can be -passed directly to L. For -instance the C constraint in the above example prevents the relationship -from being used to create related objects (an exception will be thrown). +While this code: + + my $cd = $schema->resultset("CD")->search({ artist => 1 }, { rows => 1 })->single; + my $artist = $schema->resultset("Artist")->new({}); + $artist->set_from_related('cds_80s'); + +Will properly set the C<< $artist->artistid >> field of this new object to C<1> + +Note that in order to be able to use L (and by extension +L<< $result->create_related|DBIx::Class::Relationship::Base/create_related >>), +the returned join free condition B contain only plain values/deflatable +objects. For instance the C constraint in the above example prevents +the relationship from being used to create related objects using +C<< $artst->create_related( cds_80s => { title => 'blah' } ) >> (an +exception will be thrown). In order to allow the user to go truly crazy when generating a custom C clause, the C<$args> hashref passed to the subroutine contains some extra metadata. Currently the supplied coderef is executed as: $relationship_info->{cond}->({ - self_alias => The alias of the invoking resultset ('me' in case of a result object), - foreign_alias => The alias of the to-be-joined resultset (often matches relname), - self_resultsource => The invocant's resultsource, - foreign_relname => The relationship name (does *not* always match foreign_alias), - self_rowobj => The invocant itself in case of a $result_object->$relationship call + self_resultsource => The resultsource instance on which rel_name is registered + rel_name => The relationship name (does *NOT* always match foreign_alias) + + self_alias => The alias of the invoking resultset + foreign_alias => The alias of the to-be-joined resultset (does *NOT* always match rel_name) + + # only one of these (or none at all) will ever be supplied to aid in the + # construction of a join-free condition + + self_result_object => The invocant *object* itself in case of a call like + $result_object->$rel_name( ... ) + + foreign_values => A *hashref* of related data: may be passed in directly or + derived via ->get_columns() from a related object in case of + $result_object->set_from_related( $rel_name, $foreign_result_object ) + + # deprecated inconsistent names, will be forever available for legacy code + self_rowobj => Old deprecated slot for self_result_object + foreign_relname => Old deprecated slot for rel_name }); =head3 attributes @@ -288,7 +334,7 @@ Then, assuming MyApp::Schema::LinerNotes has an accessor named notes, you can do For a 'belongs_to relationship, note the 'cascade_update': - MyApp::Schema::Track->belongs_to( cd => 'DBICTest::Schema::CD', 'cd, + MyApp::Schema::Track->belongs_to( cd => 'MyApp::Schema::CD', 'cd, { proxy => ['title'], cascade_update => 1 } ); $track->title('New Title'); @@ -299,7 +345,7 @@ For a 'belongs_to relationship, note the 'cascade_update': A hashref where each key is the accessor you want installed in the main class, and its value is the name of the original in the foreign class. - MyApp::Schema::Track->belongs_to( cd => 'DBICTest::Schema::CD', 'cd', { + MyApp::Schema::Track->belongs_to( cd => 'MyApp::Schema::CD', 'cd', { proxy => { cd_title => 'title' }, }); @@ -309,7 +355,7 @@ This will create an accessor named C on the C<$track> result object. NOTE: you can pass a nested struct too, for example: - MyApp::Schema::Track->belongs_to( cd => 'DBICTest::Schema::CD', 'cd', { + MyApp::Schema::Track->belongs_to( cd => 'MyApp::Schema::CD', 'cd', { proxy => [ 'year', { cd_title => 'title' } ], }); @@ -360,7 +406,7 @@ the relationship attributes. The C relationship does not update across relationships by default, so if you have a 'proxy' attribute on a belongs_to and want to -use 'update' on it, you muse set C<< cascade_update => 1 >>. +use 'update' on it, you must set C<< cascade_update => 1 >>. This is not a RDMS style cascade update - it purely means that when an object has update called on it, all the related objects also @@ -453,48 +499,49 @@ this instance (like in the case of C relationships). =cut sub related_resultset { - my $self = shift; + $_[0]->throw_exception( + '$result->related_resultset() no longer accepts extra search arguments, ' + . 'you need to switch to ...->related_resultset($relname)->search_rs(...) ' + . 'instead (it was never documented and more importantly could never work ' + . 'reliably due to the heavy caching involved)' + ) if @_ > 2; - $self->throw_exception("Can't call *_related as class methods") - unless ref $self; + $_[0]->throw_exception("Can't call *_related as class methods") + unless ref $_[0]; - my $rel = shift; + return $_[0]->{related_resultsets}{$_[1]} + if defined $_[0]->{related_resultsets}{$_[1]}; - return $self->{related_resultsets}{$rel} - if defined $self->{related_resultsets}{$rel}; + my ($self, $rel) = @_; return $self->{related_resultsets}{$rel} = do { - my $rel_info = $self->relationship_info($rel) - or $self->throw_exception( "No such relationship '$rel'" ); + my $rsrc = $self->result_source; - my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); - $attrs = { %{$rel_info->{attrs} || {}}, %$attrs }; + my $rel_info = $rsrc->relationship_info($rel) + or $self->throw_exception( "No such relationship '$rel'" ); - $self->throw_exception( "Invalid query: @_" ) - if (@_ > 1 && (@_ % 2 == 1)); - my $query = ((@_ > 1) ? {@_} : shift); + my $cond_res = $rsrc->_resolve_relationship_condition( + rel_name => $rel, + self_result_object => $self, - my $rsrc = $self->result_source; + # this may look weird, but remember that we are making a resultset + # out of an existing object, with the new source being at the head + # of the FROM chain. Having a 'me' alias is nothing but expected there + foreign_alias => 'me', - # condition resolution may fail if an incomplete master-object prefetch - # is encountered - that is ok during prefetch construction (not yet in_storage) - my ($cond, $is_crosstable) = try { - $rsrc->_resolve_condition( $rel_info->{cond}, $rel, $self, $rel ) - } - catch { - if ($self->in_storage) { - $self->throw_exception ($_); - } + self_alias => "!!!\xFF()!!!_SHOULD_NEVER_BE_SEEN_IN_USE_!!!()\xFF!!!", - $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION; # RV - }; + # not strictly necessary, but shouldn't hurt either + require_join_free_condition => !!(ref $rel_info->{cond} ne 'CODE'), + ); # keep in mind that the following if() block is part of a do{} - no return()s!!! - if ($is_crosstable) { - $self->throw_exception ( - "A cross-table relationship condition returned for statically declared '$rel'" - ) unless ref $rel_info->{cond} eq 'CODE'; + if ( + ! $cond_res->{join_free_condition} + and + ref $rel_info->{cond} eq 'CODE' + ) { # A WHOREIFFIC hack to reinvoke the entire condition resolution # with the correct alias. Another way of doing this involves a @@ -506,20 +553,28 @@ sub related_resultset { # root alias as 'me', instead of $rel (as opposed to invoking # $rs->search_related) - local $rsrc->{_relationships}{me} = $rsrc->{_relationships}{$rel}; # make the fake 'me' rel + # make the fake 'me' rel + local $rsrc->{_relationships}{me} = { + %{ $rsrc->{_relationships}{$rel} }, + _original_name => $rel, + }; + my $obj_table_alias = lc($rsrc->source_name) . '__row'; $obj_table_alias =~ s/\W+/_/g; $rsrc->resultset->search( $self->ident_condition($obj_table_alias), { alias => $obj_table_alias }, - )->search_related('me', $query, $attrs) + )->search_related('me', undef, $rel_info->{attrs}) } else { + # FIXME - this conditional doesn't seem correct - got to figure out # at some point what it does. Also the entire UNRESOLVABLE_CONDITION # business seems shady - we could simply not query *at all* - if ($cond eq $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION) { + my $attrs; + if ( $cond_res->{join_free_condition} eq UNRESOLVABLE_CONDITION ) { + $attrs = { %{$rel_info->{attrs}} }; my $reverse = $rsrc->reverse_relationship_info($rel); foreach my $rev_rel (keys %$reverse) { if ($reverse->{$rev_rel}{attrs}{accessor} && $reverse->{$rev_rel}{attrs}{accessor} eq 'multi') { @@ -529,29 +584,10 @@ sub related_resultset { } } } - elsif (ref $cond eq 'ARRAY') { - $cond = [ map { - if (ref $_ eq 'HASH') { - my $hash; - foreach my $key (keys %$_) { - my $newkey = $key !~ /\./ ? "me.$key" : $key; - $hash->{$newkey} = $_->{$key}; - } - $hash; - } else { - $_; - } - } @$cond ]; - } - elsif (ref $cond eq 'HASH') { - foreach my $key (grep { ! /\./ } keys %$cond) { - $cond->{"me.$key"} = delete $cond->{$key}; - } - } - $query = ($query ? { '-and' => [ $cond, $query ] } : $cond); $rsrc->related_source($rel)->resultset->search( - $query, $attrs + $cond_res->{join_free_condition}, + $attrs || $rel_info->{attrs}, ); } }; @@ -627,38 +663,15 @@ your storage until you call L on it. =cut sub new_related { - my ($self, $rel, $values) = @_; - - # FIXME - this is a bad position for this (also an identical copy in - # set_from_related), but I have no saner way to hook, and I absolutely - # want this to throw at least for coderefs, instead of the "insert a NULL - # when it gets hard" insanity --ribasushi - # - # sanity check - currently throw when a complex coderef rel is encountered - # FIXME - should THROW MOAR! - - if (ref $self) { # cdbi calls this as a class method, /me vomits - - my $rsrc = $self->result_source; - my $rel_info = $rsrc->relationship_info($rel) - or $self->throw_exception( "No such relationship '$rel'" ); - my (undef, $crosstable, $cond_targets) = $rsrc->_resolve_condition ( - $rel_info->{cond}, $rel, $self, $rel - ); - - $self->throw_exception("Custom relationship '$rel' does not resolve to a join-free condition fragment") - if $crosstable; - - if (my @unspecified_rel_condition_chunks = grep { ! exists $values->{$_} } @{$cond_targets||[]} ) { - $self->throw_exception(sprintf ( - "Custom relationship '%s' not definitive - returns conditions instead of values for column(s): %s", - $rel, - map { "'$_'" } @unspecified_rel_condition_chunks - )); - } - } - - return $self->search_related($rel)->new_result($values); + my ($self, $rel, $data) = @_; + + return $self->search_related($rel)->new_result( $self->result_source->_resolve_relationship_condition ( + infer_values_based_on => $data, + rel_name => $rel, + self_result_object => $self, + foreign_alias => $rel, + self_alias => 'me', + )->{inferred_values} ); } =head2 create_related @@ -792,44 +805,21 @@ call set_from_related on the book. This is called internally when you pass existing objects as values to L, or pass an object to a belongs_to accessor. -The columns are only set in the local copy of the object, call L to -set them in the storage. +The columns are only set in the local copy of the object, call +L to update them in the storage. =cut sub set_from_related { my ($self, $rel, $f_obj) = @_; - my $rsrc = $self->result_source; - my $rel_info = $rsrc->relationship_info($rel) - or $self->throw_exception( "No such relationship '$rel'" ); - - if (defined $f_obj) { - my $f_class = $rel_info->{class}; - $self->throw_exception( "Object '$f_obj' isn't a ".$f_class ) - unless blessed $f_obj and $f_obj->isa($f_class); - } - - - # FIXME - this is a bad position for this (also an identical copy in - # new_related), but I have no saner way to hook, and I absolutely - # want this to throw at least for coderefs, instead of the "insert a NULL - # when it gets hard" insanity --ribasushi - # - # sanity check - currently throw when a complex coderef rel is encountered - # FIXME - should THROW MOAR! - my ($cond, $crosstable, $cond_targets) = $rsrc->_resolve_condition ( - $rel_info->{cond}, $f_obj, $rel, $rel - ); - $self->throw_exception("Custom relationship '$rel' does not resolve to a join-free condition fragment") - if $crosstable; - $self->throw_exception(sprintf ( - "Custom relationship '%s' not definitive - returns conditions instead of values for column(s): %s", - $rel, - map { "'$_'" } @$cond_targets - )) if $cond_targets; - - $self->set_columns($cond); + $self->set_columns( $self->result_source->_resolve_relationship_condition ( + infer_values_based_on => {}, + rel_name => $rel, + foreign_values => $f_obj, + foreign_alias => $rel, + self_alias => 'me', + )->{inferred_values} ); return 1; } @@ -986,13 +976,16 @@ Removes the link between the current object and the related object. Note that the related object itself won't be deleted unless you call ->delete() on it. This method just removes the link between the two objects. -=head1 AUTHOR AND CONTRIBUTORS +=head1 FURTHER QUESTIONS? -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut diff --git a/lib/DBIx/Class/Relationship/BelongsTo.pm b/lib/DBIx/Class/Relationship/BelongsTo.pm index b594d3abe..a538f4466 100644 --- a/lib/DBIx/Class/Relationship/BelongsTo.pm +++ b/lib/DBIx/Class/Relationship/BelongsTo.pm @@ -60,6 +60,8 @@ sub belongs_to { else { if (ref $cond eq 'HASH') { # ARRAY is also valid my $cond_rel; + # FIXME This loop is ridiculously incomplete and dangerous + # staving off changes until implmentation of the swindon consensus for (keys %$cond) { if (m/\./) { # Explicit join condition $cond_rel = $cond; @@ -89,6 +91,7 @@ sub belongs_to { $class->add_relationship($rel, $f_class, $cond, { + is_depends_on => 1, accessor => $acc_type, $fk_columns ? ( fk_columns => $fk_columns ) : (), %{$attrs || {}} @@ -98,14 +101,4 @@ sub belongs_to { return 1; } -# Attempt to remove the POD so it (maybe) falls off the indexer - -#=head1 AUTHORS -# -#Alexander Hartmaier -# -#Matt S. Trout -# -#=cut - 1; diff --git a/lib/DBIx/Class/Relationship/HasMany.pm b/lib/DBIx/Class/Relationship/HasMany.pm index fd84b3048..eecda46da 100644 --- a/lib/DBIx/Class/Relationship/HasMany.pm +++ b/lib/DBIx/Class/Relationship/HasMany.pm @@ -46,6 +46,7 @@ sub has_many { join_type => 'LEFT', cascade_delete => $default_cascade, cascade_copy => $default_cascade, + is_depends_on => 0, %{$attrs||{}} }); } diff --git a/lib/DBIx/Class/Relationship/HasOne.pm b/lib/DBIx/Class/Relationship/HasOne.pm index 7935a2b1e..94981dcc3 100644 --- a/lib/DBIx/Class/Relationship/HasOne.pm +++ b/lib/DBIx/Class/Relationship/HasOne.pm @@ -77,6 +77,7 @@ sub _has_one { { accessor => 'single', cascade_update => $default_cascade, cascade_delete => $default_cascade, + is_depends_on => 0, ($join_type ? ('join_type' => $join_type) : ()), %{$attrs || {}} }); 1; @@ -91,8 +92,9 @@ sub _validate_has_one_condition { my $self_id = $cond->{$foreign_id}; # we can ignore a bad $self_id because add_relationship handles this - # warning + # exception 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->has_column($key); diff --git a/lib/DBIx/Class/Relationship/ManyToMany.pm b/lib/DBIx/Class/Relationship/ManyToMany.pm index ef63b0884..c000a84bd 100644 --- a/lib/DBIx/Class/Relationship/ManyToMany.pm +++ b/lib/DBIx/Class/Relationship/ManyToMany.pm @@ -5,9 +5,12 @@ use strict; use warnings; use DBIx::Class::Carp; -use Sub::Name 'subname'; -use Scalar::Util 'blessed'; -use DBIx::Class::_Util 'fail_on_internal_wantarray'; +use DBIx::Class::_Util qw(fail_on_internal_wantarray quote_sub); + +# FIXME - this souldn't be needed +my $cu; +BEGIN { $cu = \&carp_unique } + use namespace::clean; our %_pod_inherit_config = @@ -26,10 +29,6 @@ sub many_to_many { "missing foreign relation in many-to-many" ) unless $f_rel; - { - no strict 'refs'; - no warnings 'redefine'; - my $add_meth = "add_to_${meth}"; my $remove_meth = "remove_from_${meth}"; my $set_meth = "set_${meth}"; @@ -57,95 +56,142 @@ EOW } } - $rel_attrs->{alias} ||= $f_rel; - - my $rs_meth_name = join '::', $class, $rs_meth; - *$rs_meth_name = subname $rs_meth_name, sub { - my $self = shift; - my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}; - my $rs = $self->search_related($rel)->search_related( - $f_rel, @_ > 0 ? @_ : undef, { %{$rel_attrs||{}}, %$attrs } - ); - return $rs; + my $qsub_attrs = { + '$rel_attrs' => \{ alias => $f_rel, %{ $rel_attrs||{} } }, + '$carp_unique' => \$cu, }; - my $meth_name = join '::', $class, $meth; - *$meth_name = subname $meth_name, sub { - DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and wantarray and my $sog = fail_on_internal_wantarray($_[0]); - my $self = shift; - my $rs = $self->$rs_meth( @_ ); - return (wantarray ? $rs->all : $rs); - }; + quote_sub "${class}::${rs_meth}", sprintf( <<'EOC', $rel, $f_rel ), $qsub_attrs; - my $add_meth_name = join '::', $class, $add_meth; - *$add_meth_name = subname $add_meth_name, sub { - my $self = shift; - @_ > 0 or $self->throw_exception( - "${add_meth} needs an object or hashref" + # this little horror is there replicating a deprecation from + # within search_rs() itself + shift->search_related_rs( q{%1$s} ) + ->search_related_rs( + q{%2$s}, + undef, + ( @_ > 1 and ref $_[-1] eq 'HASH' ) + ? { %%$rel_attrs, %%{ pop @_ } } + : $rel_attrs + )->search_rs(@_) + ; +EOC + + + quote_sub "${class}::${meth}", sprintf( <<'EOC', $rs_meth ); + + 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 + + + quote_sub "${class}::${add_meth}", sprintf( <<'EOC', $add_meth, $rel, $f_rel ), $qsub_attrs; + + ( @_ >= 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 $source = $self->result_source; - my $schema = $source->schema; - my $rel_source_name = $source->relationship_info($rel)->{source}; - my $rel_source = $schema->resultset($rel_source_name)->result_source; - my $f_rel_source_name = $rel_source->relationship_info($f_rel)->{source}; - my $f_rel_rs = $schema->resultset($f_rel_source_name)->search({}, $rel_attrs||{}); - - my $obj; - if (ref $_[0]) { - if (ref $_[0] eq 'HASH') { - $obj = $f_rel_rs->find_or_create($_[0]); - } else { - $obj = $_[0]; - } - } else { - $obj = $f_rel_rs->find_or_create({@_}); + + $_[0]->throw_exception( + "The optional link data supplied to '%1$s' is not a hashref (it was previously ignored)" + ) if $_[2] and ref $_[2] ne 'HASH'; + + my( $self, $far_obj ) = @_; + + my $guard; + + # the API needs is always expected to return the far object, possibly + # creating it in the process + if( not defined Scalar::Util::blessed( $far_obj ) ) { + + $guard = $self->result_source->schema->storage->txn_scope_guard; + + # reify the hash into an actual object + $far_obj = $self->result_source + ->related_source( q{%2$s} ) + ->related_source( q{%3$s} ) + ->resultset + ->search_rs( undef, $rel_attrs ) + ->find_or_create( $far_obj ); } - my $link_vals = @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}; - my $link = $self->search_related($rel)->new_result($link_vals); - $link->set_from_related($f_rel, $obj); + my $link = $self->new_related( + q{%2$s}, + $_[2] || {}, + ); + + $link->set_from_related( q{%3$s}, $far_obj ); + $link->insert(); - return $obj; - }; - my $set_meth_name = join '::', $class, $set_meth; - *$set_meth_name = subname $set_meth_name, sub { + $guard->commit if $guard; + + $far_obj; +EOC + + + quote_sub "${class}::${set_meth}", sprintf( <<'EOC', $set_meth, $add_meth, $rel, $f_rel ), $qsub_attrs; + my $self = shift; - @_ > 0 or $self->throw_exception( - "{$set_meth} needs a list of objects or hashrefs" + + my $set_to = ( ref $_[0] eq 'ARRAY' ) + ? ( shift @_ ) + : do { + $carp_unique->( + "Calling '%1$s' with a list of items to link to is deprecated, use an arrayref instead" + ); + + # gobble up everything from @_ into a new arrayref + [ splice @_ ] + } + ; + + # make sure folks are not invoking a bizarre mix of deprecated and curent syntax + $self->throw_exception( + "'%1$s' expects an arrayref of objects or hashrefs to link to, and an optional hashref of link data" + ) if ( + @_ > 1 + or + ( @_ and ref $_[0] ne 'HASH' ) ); - my @to_set = (ref($_[0]) eq 'ARRAY' ? @{ $_[0] } : @_); + + my $guard; + + # there will only be a single delete() op, unless we have what to set to + $guard = $self->result_source->schema->storage->txn_scope_guard + if @$set_to; + # if there is a where clause in the attributes, ensure we only delete # rows that are within the where restriction - if ($rel_attrs && $rel_attrs->{where}) { - $self->search_related( $rel, $rel_attrs->{where},{join => $f_rel})->delete; - } else { - $self->search_related( $rel, {} )->delete; - } + $self->search_related( + q{%3$s}, + ( $rel_attrs->{where} + ? ( $rel_attrs->{where}, { join => q{%4$s} } ) + : () + ) + )->delete; + # add in the set rel objects - $self->$add_meth($_, ref($_[1]) ? $_[1] : {}) for (@to_set); - }; + $self->%2$s( + $_, + @_, # at this point @_ is either empty or contains a lone link-data hash + ) for @$set_to; - my $remove_meth_name = join '::', $class, $remove_meth; - *$remove_meth_name = subname $remove_meth_name, sub { - my ($self, $obj) = @_; - $self->throw_exception("${remove_meth} needs an object") - unless blessed ($obj); - my $rel_source = $self->search_related($rel)->result_source; - my $cond = $rel_source->relationship_info($f_rel)->{cond}; - my ($link_cond, $crosstable) = $rel_source->_resolve_condition( - $cond, $obj, $f_rel, $f_rel - ); + $guard->commit if $guard; +EOC - $self->throw_exception( - "Custom relationship '$rel' does not resolve to a join-free condition, " - ."unable to use with the ManyToMany helper '$f_rel'" - ) if $crosstable; - $self->search_related($rel, $link_cond)->delete; - }; + quote_sub "${class}::${remove_meth}", sprintf( <<'EOC', $remove_meth, $rel, $f_rel ); + + $_[0]->throw_exception("'%1$s' expects an object") + unless defined Scalar::Util::blessed( $_[1] ); + + $_[0]->search_related_rs( q{%2$s} ) + ->search_rs( $_[1]->ident_condition( q{%3$s} ), { join => q{%3$s} } ) + ->delete; +EOC - } } 1; diff --git a/lib/DBIx/Class/Relationship/ProxyMethods.pm b/lib/DBIx/Class/Relationship/ProxyMethods.pm index 6f204f617..0db5780da 100644 --- a/lib/DBIx/Class/Relationship/ProxyMethods.pm +++ b/lib/DBIx/Class/Relationship/ProxyMethods.pm @@ -3,8 +3,9 @@ package # hide from PAUSE use strict; use warnings; -use Sub::Name (); -use base qw/DBIx::Class/; +use base 'DBIx::Class'; +use DBIx::Class::_Util 'quote_sub'; +use namespace::clean; our %_pod_inherit_config = ( @@ -22,21 +23,17 @@ sub register_relationship { sub proxy_to_related { my ($class, $rel, $proxy_args) = @_; my %proxy_map = $class->_build_proxy_map_from($proxy_args); - no strict 'refs'; - no warnings 'redefine'; - foreach my $meth_name ( keys %proxy_map ) { - my $proxy_to_col = $proxy_map{$meth_name}; - my $name = join '::', $class, $meth_name; - *$name = Sub::Name::subname $name => sub { - my $self = shift; - my $relobj = $self->$rel; - if (@_ && !defined $relobj) { - $relobj = $self->create_related($rel, { $proxy_to_col => $_[0] }); - @_ = (); - } - return ($relobj ? $relobj->$proxy_to_col(@_) : undef); - } - } + + quote_sub "${class}::$_", sprintf( <<'EOC', $rel, $proxy_map{$_} ) + my $self = shift; + my $relobj = $self->%1$s; + if (@_ && !defined $relobj) { + $relobj = $self->create_related( %1$s => { %2$s => $_[0] } ); + @_ = (); + } + $relobj ? $relobj->%2$s(@_) : undef; +EOC + for keys %proxy_map } sub _build_proxy_map_from { diff --git a/lib/DBIx/Class/ResultClass/HashRefInflator.pm b/lib/DBIx/Class/ResultClass/HashRefInflator.pm index 4d002abee..65d2adbbb 100644 --- a/lib/DBIx/Class/ResultClass/HashRefInflator.pm +++ b/lib/DBIx/Class/ResultClass/HashRefInflator.pm @@ -103,6 +103,9 @@ sub inflate_result { return $mk_hash->($_[2], $_[3], 'is_root'); } +1; + +__END__ =head1 CAVEATS @@ -131,6 +134,13 @@ The returned hash contains the raw database values. =back -=cut +=head1 FURTHER QUESTIONS? -1; +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index ffade2120..3d1a3a154 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -5,10 +5,12 @@ use warnings; use base qw/DBIx::Class/; use DBIx::Class::Carp; use DBIx::Class::ResultSetColumn; +use DBIx::Class::ResultClass::HashRefInflator; use Scalar::Util qw/blessed weaken reftype/; -use DBIx::Class::_Util 'fail_on_internal_wantarray'; +use DBIx::Class::_Util qw( + fail_on_internal_wantarray fail_on_internal_call UNRESOLVABLE_CONDITION +); use Try::Tiny; -use Data::Compare (); # no imports!!! guard against insane architecture # not importing first() as it will clash with our own method use List::Util (); @@ -57,7 +59,7 @@ just stores all the conditions needed to create the query. A basic ResultSet representing the data of an entire table is returned by calling C on a L and passing in a -L name. +L name. my $users_rs = $schema->resultset('User'); @@ -78,34 +80,6 @@ However, if it is used in a boolean context it is B true. So if you want to check if a resultset has any results, you must use C. -=head1 CUSTOM ResultSet CLASSES THAT USE Moose - -If you want to make your custom ResultSet classes with L, use a template -similar to: - - package MyApp::Schema::ResultSet::User; - - use Moose; - use namespace::autoclean; - use MooseX::NonMoose; - extends 'DBIx::Class::ResultSet'; - - sub BUILDARGS { $_[2] } - - ...your code... - - __PACKAGE__->meta->make_immutable; - - 1; - -The L is necessary so that the L constructor does not -clash with the regular ResultSet constructor. Alternatively, you can use: - - __PACKAGE__->meta->make_immutable(inline_constructor => 0); - -The L is necessary because the -signature of the ResultSet C is C<< ->new($source, \%args) >>. - =head1 EXAMPLES =head2 Chaining resultsets @@ -193,6 +167,93 @@ Which is the same as: See: L, L, L, L, L. +=head2 Custom ResultSet classes + +To add methods to your resultsets, you can subclass L, similar to: + + package MyApp::Schema::ResultSet::User; + + use strict; + use warnings; + + use base 'DBIx::Class::ResultSet'; + + sub active { + my $self = shift; + $self->search({ $self->current_source_alias . '.active' => 1 }); + } + + sub unverified { + my $self = shift; + $self->search({ $self->current_source_alias . '.verified' => 0 }); + } + + sub created_n_days_ago { + my ($self, $days_ago) = @_; + $self->search({ + $self->current_source_alias . '.create_date' => { + '<=', + $self->result_source->schema->storage->datetime_parser->format_datetime( + DateTime->now( time_zone => 'UTC' )->subtract( days => $days_ago ) + )} + }); + } + + sub users_to_warn { shift->active->unverified->created_n_days_ago(7) } + + 1; + +See L on how DBIC can discover and +automatically attach L-specific +L classes. + +=head3 ResultSet subclassing with Moose and similar constructor-providers + +Using L or L in your ResultSet classes is usually overkill, but +you may find it useful if your ResultSets contain a lot of business logic +(e.g. C, C, etc) or if you just prefer to organize +your code via roles. + +In order to write custom ResultSet classes with L you need to use the +following template. The L is necessary due to the +unusual signature of the L C<< ->new($source, \%args) >>. + + use Moo; + extends 'DBIx::Class::ResultSet'; + sub BUILDARGS { $_[2] } # ::RS::new() expects my ($class, $rsrc, $args) = @_ + + ...your code... + + 1; + +If you want to build your custom ResultSet classes with L, you need +a similar, though a little more elaborate template in order to interface the +inlining of the L-provided +L, +with the DBIC one. + + package MyApp::Schema::ResultSet::User; + + use Moose; + use MooseX::NonMoose; + extends 'DBIx::Class::ResultSet'; + + sub BUILDARGS { $_[2] } # ::RS::new() expects my ($class, $rsrc, $args) = @_ + + ...your code... + + __PACKAGE__->meta->make_immutable; + + 1; + +The L is necessary so that the L constructor does not +entirely overwrite the DBIC one (in contrast L does this automatically). +Alternatively, you can skip L and get by with just L +instead by doing: + + __PACKAGE__->meta->make_immutable(inline_constructor => 0); + =head1 METHODS =head2 new @@ -240,14 +301,18 @@ creation B. See also warning pertaining to L. sub new { my $class = shift; - return $class->new_result(@_) if ref $class; + + if (ref $class) { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + return $class->new_result(@_); + } my ($source, $attrs) = @_; $source = $source->resolve if $source->isa('DBIx::Class::ResultSourceHandle'); $attrs = { %{$attrs||{}} }; - delete @{$attrs}{qw(_last_sqlmaker_alias_map _related_results_construction)}; + delete @{$attrs}{qw(_last_sqlmaker_alias_map _simple_passthrough_construction)}; if ($attrs->{page}) { $attrs->{rows} ||= 10; @@ -328,7 +393,7 @@ sub search { my $rs = $self->search_rs( @_ ); if (wantarray) { - DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = fail_on_internal_wantarray($rs); + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = fail_on_internal_wantarray; return $rs->all; } elsif (defined wantarray) { @@ -585,59 +650,22 @@ sub _normalize_selection { sub _stack_cond { my ($self, $left, $right) = @_; - # collapse single element top-level conditions - # (single pass only, unlikely to need recursion) - for ($left, $right) { - if (ref $_ eq 'ARRAY') { - if (@$_ == 0) { - $_ = undef; - } - elsif (@$_ == 1) { - $_ = $_->[0]; - } - } - elsif (ref $_ eq 'HASH') { - my ($first, $more) = keys %$_; - - # empty hash - if (! defined $first) { - $_ = undef; - } - # one element hash - elsif (! defined $more) { - if ($first eq '-and' and ref $_->{'-and'} eq 'HASH') { - $_ = $_->{'-and'}; - } - elsif ($first eq '-or' and ref $_->{'-or'} eq 'ARRAY') { - $_ = $_->{'-or'}; - } - } - } - } - - # merge hashes with weeding out of duplicates (simple cases only) - if (ref $left eq 'HASH' and ref $right eq 'HASH') { - - # shallow copy to destroy - $right = { %$right }; - for (grep { exists $right->{$_} } keys %$left) { - # the use of eq_deeply here is justified - the rhs of an - # expression can contain a lot of twisted weird stuff - delete $right->{$_} if Data::Compare::Compare( $left->{$_}, $right->{$_} ); - } - - $right = undef unless keys %$right; - } - + ( + (ref $_ eq 'ARRAY' and !@$_) + or + (ref $_ eq 'HASH' and ! keys %$_) + ) and $_ = undef for ($left, $right); - if (defined $left xor defined $right) { + # either one of the two undef + if ( (defined $left) xor (defined $right) ) { return defined $left ? $left : $right; } - elsif (! defined $left) { - return undef; + # both undef + elsif ( ! defined $left ) { + return undef } else { - return { -and => [ $left, $right ] }; + return $self->result_source->schema->storage->_collapse_cond({ -and => [$left, $right] }); } } @@ -784,40 +812,41 @@ sub find { . "corresponding to the columns of the specified unique constraint '$constraint_name'" ) unless @c_cols == @_; - $call_cond = {}; @{$call_cond}{@c_cols} = @_; } - my %related; + # process relationship data if any for my $key (keys %$call_cond) { if ( - my $keyref = ref($call_cond->{$key}) + length ref($call_cond->{$key}) and my $relinfo = $rsrc->relationship_info($key) + and + # implicitly skip has_many's (likely MC) + (ref (my $val = delete $call_cond->{$key}) ne 'ARRAY' ) ) { - my $val = delete $call_cond->{$key}; - - next if $keyref eq 'ARRAY'; # has_many for multi_create - - my $rel_q = $rsrc->_resolve_condition( + my ($rel_cond, $crosstable) = $rsrc->_resolve_condition( $relinfo->{cond}, $val, $key, $key ); - die "Can't handle complex relationship conditions in find" if ref($rel_q) ne 'HASH'; - @related{keys %$rel_q} = values %$rel_q; + + $self->throw_exception("Complex condition via relationship '$key' is unsupported in find()") + if $crosstable or ref($rel_cond) ne 'HASH'; + + # supplement condition + # relationship conditions take precedence (?) + @{$call_cond}{keys %$rel_cond} = values %$rel_cond; } } - # relationship conditions take precedence (?) - @{$call_cond}{keys %related} = values %related; - my $alias = exists $attrs->{alias} ? $attrs->{alias} : $self->{attrs}{alias}; my $final_cond; if (defined $constraint_name) { $final_cond = $self->_qualify_cond_columns ( - $self->_build_unique_cond ( - $constraint_name, - $call_cond, + $self->result_source->_minimal_valueset_satisfying_constraint( + constraint_name => $constraint_name, + values => ($self->_merge_with_rscond($call_cond))[0], + carp_on_nulls => 1, ), $alias, @@ -832,23 +861,42 @@ sub find { # relationship } else { + my (@unique_queries, %seen_column_combinations, $ci, @fc_exceptions); + # no key was specified - fall down to heuristics mode: # run through all unique queries registered on the resultset, and # 'OR' all qualifying queries together - my (@unique_queries, %seen_column_combinations); - for my $c_name ($rsrc->unique_constraint_names) { + # + # always start from 'primary' if it exists at all + for my $c_name ( sort { + $a eq 'primary' ? -1 + : $b eq 'primary' ? 1 + : $a cmp $b + } $rsrc->unique_constraint_names) { + next if $seen_column_combinations{ join "\x00", sort $rsrc->unique_constraint_columns($c_name) }++; - push @unique_queries, try { - $self->_build_unique_cond ($c_name, $call_cond, 'croak_on_nulls') - } || (); + try { + push @unique_queries, $self->_qualify_cond_columns( + $self->result_source->_minimal_valueset_satisfying_constraint( + constraint_name => $c_name, + values => ($self->_merge_with_rscond($call_cond))[0], + columns_info => ($ci ||= $self->result_source->columns_info), + ), + $alias + ); + } + catch { + push @fc_exceptions, $_ if $_ =~ /\bFilterColumn\b/; + }; } - $final_cond = @unique_queries - ? [ map { $self->_qualify_cond_columns($_, $alias) } @unique_queries ] - : $self->_non_unique_find_fallback ($call_cond, $attrs) + $final_cond = + @unique_queries ? \@unique_queries + : @fc_exceptions ? $self->throw_exception(join "; ", map { $_ =~ /(.*) at .+ line \d+$/s } @fc_exceptions ) + : $self->_non_unique_find_fallback ($call_cond, $attrs) ; } @@ -901,51 +949,20 @@ sub _qualify_cond_columns { } sub _build_unique_cond { - my ($self, $constraint_name, $extra_cond, $croak_on_null) = @_; - - my @c_cols = $self->result_source->unique_constraint_columns($constraint_name); - - # combination may fail if $self->{cond} is non-trivial - my ($final_cond) = try { - $self->_merge_with_rscond ($extra_cond) - } catch { - +{ %$extra_cond } - }; - - # trim out everything not in $columns - $final_cond = { map { - exists $final_cond->{$_} - ? ( $_ => $final_cond->{$_} ) - : () - } @c_cols }; - - if (my @missing = grep - { ! ($croak_on_null ? defined $final_cond->{$_} : exists $final_cond->{$_}) } - (@c_cols) - ) { - $self->throw_exception( sprintf ( "Unable to satisfy requested constraint '%s', no values for column(s): %s", - $constraint_name, - join (', ', map { "'$_'" } @missing), - ) ); - } - - if ( - !$croak_on_null - and - !$ENV{DBIC_NULLABLE_KEY_NOWARN} - and - my @undefs = sort grep { ! defined $final_cond->{$_} } (keys %$final_cond) - ) { - carp_unique ( sprintf ( - "NULL/undef values supplied for requested unique constraint '%s' (NULL " - . 'values in column(s): %s). This is almost certainly not what you wanted, ' - . 'though you can set DBIC_NULLABLE_KEY_NOWARN to disable this warning.', - $constraint_name, - join (', ', map { "'$_'" } @undefs), - )); - } - - return $final_cond; + carp_unique sprintf + '_build_unique_cond is a private method, and moreover is about to go ' + . 'away. Please contact the development team at %s if you believe you ' + . 'have a genuine use for this method, in order to discuss alternatives.', + DBIx::Class::_ENV_::HELP_URL, + ; + + my ($self, $constraint_name, $cond, $croak_on_null) = @_; + + $self->result_source->_minimal_valueset_satisfying_constraint( + constraint_name => $constraint_name, + values => $cond, + carp_on_nulls => !$croak_on_null + ); } =head2 search_related @@ -1090,39 +1107,6 @@ sub single { $self->_construct_results->[0]; } - -# _collapse_query -# -# Recursively collapse the query, accumulating values for each column. - -sub _collapse_query { - my ($self, $query, $collapsed) = @_; - - $collapsed ||= {}; - - if (ref $query eq 'ARRAY') { - foreach my $subquery (@$query) { - next unless ref $subquery; # -or - $collapsed = $self->_collapse_query($subquery, $collapsed); - } - } - elsif (ref $query eq 'HASH') { - if (keys %$query and (keys %$query)[0] eq '-and') { - foreach my $subquery (@{$query->{-and}}) { - $collapsed = $self->_collapse_query($subquery, $collapsed); - } - } - else { - foreach my $col (keys %$query) { - my $value = $query->{$col}; - $collapsed->{$col}{$value}++; - } - } - } - - return $collapsed; -} - =head2 get_column =over 4 @@ -1164,7 +1148,7 @@ You most likely want to use L with specific operators. For more information, see L. -This method is deprecated and will be removed in 0.09. Use L +This method is deprecated and will be removed in 0.09. Use L instead. An example conversion is: ->search_like({ foo => 'bar' }); @@ -1323,7 +1307,7 @@ sub _construct_results { and $rsrc->schema ->storage - ->_main_source_order_by_portion_is_stable($rsrc, $attrs->{order_by}, $attrs->{where}) + ->_extract_colinfo_of_stable_main_source_order_by_portion($attrs) ) ? 1 : 0 ) unless defined $attrs->{_ordered_for_collapse}; @@ -1399,16 +1383,12 @@ sub _construct_results { $self->{_result_inflator}{is_hri} = ( ( ! $self->{_result_inflator}{is_core_row} and - $inflator_cref == ( - require DBIx::Class::ResultClass::HashRefInflator - && - DBIx::Class::ResultClass::HashRefInflator->can('inflate_result') - ) + $inflator_cref == \&DBIx::Class::ResultClass::HashRefInflator::inflate_result ) ? 1 : 0 ) unless defined $self->{_result_inflator}{is_hri}; - if (! $attrs->{_related_results_construction}) { - # construct a much simpler array->hash folder for the one-table cases right here + if ($attrs->{_simple_passthrough_construction}) { + # construct a much simpler array->hash folder for the one-table HRI cases right here if ($self->{_result_inflator}{is_hri}) { for my $r (@$rows) { $r = { map { $infmap->[$_] => $r->[$_] } 0..$#$infmap }; @@ -1421,15 +1401,19 @@ sub _construct_results { # # crude unscientific benchmarking indicated the shortcut eval is not worth it for # this particular resultset size - elsif (@$rows < 60) { + elsif ( $self->{_result_inflator}{is_core_row} and @$rows < 60 ) { for my $r (@$rows) { $r = $inflator_cref->($res_class, $rsrc, { map { $infmap->[$_] => $r->[$_] } (0..$#$infmap) } ); } } else { eval sprintf ( - '$_ = $inflator_cref->($res_class, $rsrc, { %s }) for @$rows', - join (', ', map { "\$infmap->[$_] => \$_->[$_]" } 0..$#$infmap ) + ( $self->{_result_inflator}{is_core_row} + ? '$_ = $inflator_cref->($res_class, $rsrc, { %s }) for @$rows' + # a custom inflator may be a multiplier/reductor - put it in direct list ctx + : '@$rows = map { $inflator_cref->($res_class, $rsrc, { %s } ) } @$rows' + ), + ( join (', ', map { "\$infmap->[$_] => \$_->[$_]" } 0..$#$infmap ) ) ); } } @@ -1476,6 +1460,9 @@ sub _construct_results { if @violating_idx; $unrolled_non_null_cols_to_check = join (',', @$check_non_null_cols); + + utf8::upgrade($unrolled_non_null_cols_to_check) + if DBIx::Class::_ENV_::STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE; } my $next_cref = @@ -1502,10 +1489,15 @@ EOS $next_cref ? ( $next_cref, $self->{_stashed_rows} = [] ) : (), ); - # Special-case multi-object HRI - there is no $inflator_cref pass - unless ($self->{_result_inflator}{is_hri}) { + # simple in-place substitution, does not regrow $rows + if ($self->{_result_inflator}{is_core_row}) { $_ = $inflator_cref->($res_class, $rsrc, @$_) for @$rows } + # Special-case multi-object HRI - there is no $inflator_cref pass at all + elsif ( ! $self->{_result_inflator}{is_hri} ) { + # the inflator may be a multiplier/reductor - put it in list ctx + @$rows = map { $inflator_cref->($res_class, $rsrc, @$_) } @$rows; + } } # The @$rows check seems odd at first - why wouldn't we want to warn @@ -1550,8 +1542,8 @@ L<"table"|DBIx::Class::Manual::Glossary/"ResultSource"> class. Note that changing the result_class will also remove any components that were originally loaded in the source class via -L. Any overloaded methods -in the original source class will not run. +L. +Any overloaded methods in the original source class will not run. =cut @@ -2003,7 +1995,6 @@ sub _rs_update_delete { $guard = $storage->txn_scope_guard; - $cond = []; for my $row ($subrs->cursor->all) { push @$cond, { map { $idcols->[$_] => $row->[$_] } @@ -2013,11 +2004,11 @@ sub _rs_update_delete { } } - my $res = $storage->$op ( + my $res = $cond ? $storage->$op ( $rsrc, $op eq 'update' ? $values : (), $cond, - ); + ) : '0E0'; $guard->commit if $guard; @@ -2227,127 +2218,275 @@ case there are obviously no benefits to using this method over L. sub populate { my $self = shift; - # cruft placed in standalone method - my $data = $self->_normalize_populate_args(@_); + # this is naive and just a quick check + # the types will need to be checked more thoroughly when the + # multi-source populate gets added + my $data = ( + ref $_[0] eq 'ARRAY' + and + ( @{$_[0]} or return ) + and + ( ref $_[0][0] eq 'HASH' or ref $_[0][0] eq 'ARRAY' ) + and + $_[0] + ) or $self->throw_exception('Populate expects an arrayref of hashrefs or arrayref of arrayrefs'); - return unless @$data; + # FIXME - no cref handling + # At this point assume either hashes or arrays if(defined wantarray) { - my @created = map { $self->create($_) } @$data; - return wantarray ? @created : \@created; - } - else { - my $first = $data->[0]; + my (@results, $guard); - # if a column is a registered relationship, and is a non-blessed hash/array, consider - # it relationship data - my (@rels, @columns); - my $rsrc = $self->result_source; - my $rels = { map { $_ => $rsrc->relationship_info($_) } $rsrc->relationships }; - for (keys %$first) { - my $ref = ref $first->{$_}; - $rels->{$_} && ($ref eq 'ARRAY' or $ref eq 'HASH') - ? push @rels, $_ - : push @columns, $_ + if (ref $data->[0] eq 'ARRAY') { + # column names only, nothing to do + return if @$data == 1; + + $guard = $self->result_source->schema->storage->txn_scope_guard + if @$data > 2; + + @results = map + { my $vals = $_; $self->new_result({ map { $data->[0][$_] => $vals->[$_] } 0..$#{$data->[0]} })->insert } + @{$data}[1 .. $#$data] ; } + else { + + $guard = $self->result_source->schema->storage->txn_scope_guard + if @$data > 1; + + @results = map { $self->new_result($_)->insert } @$data; + } + + $guard->commit if $guard; + return wantarray ? @results : \@results; + } + + # we have to deal with *possibly incomplete* related data + # this means we have to walk the data structure twice + # whether we want this or not + # jnap, I hate you ;) + my $rsrc = $self->result_source; + my $rel_info = { map { $_ => $rsrc->relationship_info($_) } $rsrc->relationships }; + + my ($colinfo, $colnames, $slices_with_rels); + my $data_start = 0; + + DATA_SLICE: + for my $i (0 .. $#$data) { - my @pks = $rsrc->primary_columns; + my $current_slice_seen_rel_infos; - ## do the belongs_to relationships - foreach my $index (0..$#$data) { +### Determine/Supplement collists +### BEWARE - This is a hot piece of code, a lot of weird idioms were used + if( ref $data->[$i] eq 'ARRAY' ) { - # delegate to create() for any dataset without primary keys with specified relationships - if (grep { !defined $data->[$index]->{$_} } @pks ) { - for my $r (@rels) { - if (grep { ref $data->[$index]{$r} eq $_ } qw/HASH ARRAY/) { # a related set must be a HASH or AoH - my @ret = $self->populate($data); - return; + # positional(!) explicit column list + if ($i == 0) { + # column names only, nothing to do + return if @$data == 1; + + $colinfo->{$data->[0][$_]} = { pos => $_, name => $data->[0][$_] } and push @$colnames, $data->[0][$_] + for 0 .. $#{$data->[0]}; + + $data_start = 1; + + next DATA_SLICE; + } + else { + for (values %$colinfo) { + if ($_->{is_rel} ||= ( + $rel_info->{$_->{name}} + and + ( + ref $data->[$i][$_->{pos}] eq 'ARRAY' + or + ref $data->[$i][$_->{pos}] eq 'HASH' + or + ( defined blessed $data->[$i][$_->{pos}] and $data->[$i][$_->{pos}]->isa('DBIx::Class::Row') ) + ) + and + 1 + )) { + + # moar sanity check... sigh + for ( ref $data->[$i][$_->{pos}] eq 'ARRAY' ? @{$data->[$i][$_->{pos}]} : $data->[$i][$_->{pos}] ) { + if ( defined blessed $_ and $_->isa('DBIx::Class::Row' ) ) { + carp_unique("Fast-path populate() with supplied related objects is not possible - falling back to regular create()"); + return my $throwaway = $self->populate(@_); + } + } + + push @$current_slice_seen_rel_infos, $rel_info->{$_->{name}}; } } } - foreach my $rel (@rels) { - next unless ref $data->[$index]->{$rel} eq "HASH"; - my $result = $self->related_resultset($rel)->create($data->[$index]->{$rel}); - my ($reverse_relname, $reverse_relinfo) = %{$rsrc->reverse_relationship_info($rel)}; - my $related = $result->result_source->_resolve_condition( - $reverse_relinfo->{cond}, - $self, - $result, - $rel, - ); + if ($current_slice_seen_rel_infos) { + push @$slices_with_rels, { map { $colnames->[$_] => $data->[$i][$_] } 0 .. $#$colnames }; - delete $data->[$index]->{$rel}; - $data->[$index] = {%{$data->[$index]}, %$related}; - - push @columns, keys %$related if $index == 0; + # this is needed further down to decide whether or not to fallback to create() + $colinfo->{$colnames->[$_]}{seen_null} ||= ! defined $data->[$i][$_] + for 0 .. $#$colnames; } } + elsif( ref $data->[$i] eq 'HASH' ) { - ## inherit the data locked in the conditions of the resultset - my ($rs_data) = $self->_merge_with_rscond({}); - delete @{$rs_data}{@columns}; + for ( sort keys %{$data->[$i]} ) { - ## do bulk insert on current row - $rsrc->storage->insert_bulk( - $rsrc, - [@columns, keys %$rs_data], - [ map { [ @$_{@columns}, values %$rs_data ] } @$data ], - ); + $colinfo->{$_} ||= do { - ## do the has_many relationships - foreach my $item (@$data) { + $self->throw_exception("Column '$_' must be present in supplied explicit column list") + if $data_start; # it will be 0 on AoH, 1 on AoA - my $main_row; + push @$colnames, $_; - foreach my $rel (@rels) { - next unless ref $item->{$rel} eq "ARRAY" && @{ $item->{$rel} }; - - $main_row ||= $self->new_result({map { $_ => $item->{$_} } @pks}); + # RV + { pos => $#$colnames, name => $_ } + }; - my $child = $main_row->$rel; + if ($colinfo->{$_}{is_rel} ||= ( + $rel_info->{$_} + and + ( + ref $data->[$i]{$_} eq 'ARRAY' + or + ref $data->[$i]{$_} eq 'HASH' + or + ( defined blessed $data->[$i]{$_} and $data->[$i]{$_}->isa('DBIx::Class::Row') ) + ) + and + 1 + )) { + + # moar sanity check... sigh + for ( ref $data->[$i]{$_} eq 'ARRAY' ? @{$data->[$i]{$_}} : $data->[$i]{$_} ) { + if ( defined blessed $_ and $_->isa('DBIx::Class::Row' ) ) { + carp_unique("Fast-path populate() with supplied related objects is not possible - falling back to regular create()"); + return my $throwaway = $self->populate(@_); + } + } - my $related = $child->result_source->_resolve_condition( - $rels->{$rel}{cond}, - $child, - $main_row, - $rel, - ); + push @$current_slice_seen_rel_infos, $rel_info->{$_}; + } + } - my @rows_to_add = ref $item->{$rel} eq 'ARRAY' ? @{$item->{$rel}} : ($item->{$rel}); - my @populate = map { {%$_, %$related} } @rows_to_add; + if ($current_slice_seen_rel_infos) { + push @$slices_with_rels, $data->[$i]; - $child->populate( \@populate ); + # this is needed further down to decide whether or not to fallback to create() + $colinfo->{$_}{seen_null} ||= ! defined $data->[$i]{$_} + for keys %{$data->[$i]}; } } + else { + $self->throw_exception('Unexpected populate() data structure member type: ' . ref $data->[$i] ); + } + + if ( grep + { $_->{attrs}{is_depends_on} } + @{ $current_slice_seen_rel_infos || [] } + ) { + carp_unique("Fast-path populate() of belongs_to relationship data is not possible - falling back to regular create()"); + return my $throwaway = $self->populate(@_); + } } -} + if( $slices_with_rels ) { -# populate() arguments went over several incarnations -# What we ultimately support is AoH -sub _normalize_populate_args { - my ($self, $arg) = @_; + # need to exclude the rel "columns" + $colnames = [ grep { ! $colinfo->{$_}{is_rel} } @$colnames ]; - if (ref $arg eq 'ARRAY') { - if (!@$arg) { - return []; - } - elsif (ref $arg->[0] eq 'HASH') { - return $arg; + # extra sanity check - ensure the main source is in fact identifiable + # the localizing of nullability is insane, but oh well... the use-case is legit + my $ci = $rsrc->columns_info($colnames); + + $ci->{$_} = { %{$ci->{$_}}, is_nullable => 0 } + for grep { ! $colinfo->{$_}{seen_null} } keys %$ci; + + unless( $rsrc->_identifying_column_set($ci) ) { + carp_unique("Fast-path populate() of non-uniquely identifiable rows with related data is not possible - falling back to regular create()"); + return my $throwaway = $self->populate(@_); } - elsif (ref $arg->[0] eq 'ARRAY') { - my @ret; - my @colnames = @{$arg->[0]}; - foreach my $values (@{$arg}[1 .. $#$arg]) { - push @ret, { map { $colnames[$_] => $values->[$_] } (0 .. $#colnames) }; + } + +### inherit the data locked in the conditions of the resultset + my ($rs_data) = $self->_merge_with_rscond({}); + delete @{$rs_data}{@$colnames}; # passed-in stuff takes precedence + + # if anything left - decompose rs_data + my $rs_data_vals; + if (keys %$rs_data) { + push @$rs_data_vals, $rs_data->{$_} + for sort keys %$rs_data; + } + +### start work + my $guard; + $guard = $rsrc->schema->storage->txn_scope_guard + if $slices_with_rels; + +### main source data + # FIXME - need to switch entirely to a coderef-based thing, + # so that large sets aren't copied several times... I think + $rsrc->storage->_insert_bulk( + $rsrc, + [ @$colnames, sort keys %$rs_data ], + [ map { + ref $data->[$_] eq 'ARRAY' + ? ( + $slices_with_rels ? [ @{$data->[$_]}[0..$#$colnames], @{$rs_data_vals||[]} ] # the collist changed + : $rs_data_vals ? [ @{$data->[$_]}, @$rs_data_vals ] + : $data->[$_] + ) + : [ @{$data->[$_]}{@$colnames}, @{$rs_data_vals||[]} ] + } $data_start .. $#$data ], + ); + +### do the children relationships + if ( $slices_with_rels ) { + my @rels = grep { $colinfo->{$_}{is_rel} } keys %$colinfo + or die 'wtf... please report a bug with DBIC_TRACE=1 output (stacktrace)'; + + for my $sl (@$slices_with_rels) { + + my ($main_proto, $main_proto_rs); + for my $rel (@rels) { + next unless defined $sl->{$rel}; + + $main_proto ||= { + %$rs_data, + (map { $_ => $sl->{$_} } @$colnames), + }; + + unless (defined $colinfo->{$rel}{rs}) { + + $colinfo->{$rel}{rs} = $rsrc->related_source($rel)->resultset; + + $colinfo->{$rel}{fk_map} = { reverse %{ $rsrc->_resolve_relationship_condition( + rel_name => $rel, + self_alias => "\xFE", # irrelevant + foreign_alias => "\xFF", # irrelevant + )->{identity_map} || {} } }; + + } + + $colinfo->{$rel}{rs}->search({ map # only so that we inherit them values properly, no actual search + { + $_ => { '=' => + ( $main_proto_rs ||= $rsrc->resultset->search($main_proto) ) + ->get_column( $colinfo->{$rel}{fk_map}{$_} ) + ->as_query + } + } + keys %{$colinfo->{$rel}{fk_map}} + })->populate( ref $sl->{$rel} eq 'ARRAY' ? $sl->{$rel} : [ $sl->{$rel} ] ); + + 1; } - return \@ret; } } - $self->throw_exception('Populate expects an arrayref of hashrefs or arrayref of arrayrefs'); + $guard->commit if $guard; } =head2 pager @@ -2443,7 +2582,7 @@ sub new_result { $self->throw_exception( "new_result takes only one argument - a hashref of values" ) if @_ > 2; - $self->throw_exception( "new_result expects a hashref" ) + $self->throw_exception( "Result object instantiation requires a hashref as argument" ) unless (ref $values eq 'HASH'); my ($merged_cond, $cols_from_relations) = $self->_merge_with_rscond($values); @@ -2482,51 +2621,33 @@ sub new_result { sub _merge_with_rscond { my ($self, $data) = @_; - my (%new_data, @cols_from_relations); + my ($implied_data, @cols_from_relations); my $alias = $self->{attrs}{alias}; if (! defined $self->{cond}) { # just massage $data below } - elsif ($self->{cond} eq $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION) { - %new_data = %{ $self->{attrs}{related_objects} || {} }; # nothing might have been inserted yet - @cols_from_relations = keys %new_data; - } - elsif (ref $self->{cond} ne 'HASH') { - $self->throw_exception( - "Can't abstract implicit construct, resultset condition not a hash" - ); + elsif ($self->{cond} eq UNRESOLVABLE_CONDITION) { + $implied_data = $self->{attrs}{related_objects}; # nothing might have been inserted yet + @cols_from_relations = keys %{ $implied_data || {} }; } else { - # precedence must be given to passed values over values inherited from - # the cond, so the order here is important. - my $collapsed_cond = $self->_collapse_cond($self->{cond}); - my %implied = %{$self->_remove_alias($collapsed_cond, $alias)}; - - while ( my($col, $value) = each %implied ) { - my $vref = ref $value; - if ( - $vref eq 'HASH' - and - keys(%$value) == 1 - and - (keys %$value)[0] eq '=' - ) { - $new_data{$col} = $value->{'='}; - } - elsif( !$vref or $vref eq 'SCALAR' or blessed($value) ) { - $new_data{$col} = $value; - } - } + my $eqs = $self->result_source->schema->storage->_extract_fixed_condition_columns($self->{cond}, 'consider_nulls'); + $implied_data = { map { + ( ($eqs->{$_}||'') eq UNRESOLVABLE_CONDITION ) ? () : ( $_ => $eqs->{$_} ) + } keys %$eqs }; } - %new_data = ( - %new_data, - %{ $self->_remove_alias($data, $alias) }, + return ( + { map + { %{ $self->_remove_alias($_, $alias) } } + # precedence must be given to passed values over values inherited from + # the cond, so the order here is important. + ( $implied_data||(), $data) + }, + \@cols_from_relations ); - - return (\%new_data, \@cols_from_relations); } # _has_resolved_attr @@ -2582,38 +2703,6 @@ sub _has_resolved_attr { return 0; } -# _collapse_cond -# -# Recursively collapse the condition. - -sub _collapse_cond { - my ($self, $cond, $collapsed) = @_; - - $collapsed ||= {}; - - if (ref $cond eq 'ARRAY') { - foreach my $subcond (@$cond) { - next unless ref $subcond; # -or - $collapsed = $self->_collapse_cond($subcond, $collapsed); - } - } - elsif (ref $cond eq 'HASH') { - if (keys %$cond and (keys %$cond)[0] eq '-and') { - foreach my $subcond (@{$cond->{-and}}) { - $collapsed = $self->_collapse_cond($subcond, $collapsed); - } - } - else { - foreach my $col (keys %$cond) { - my $value = $cond->{$col}; - $collapsed->{$col} = $value; - } - } - } - - return $collapsed; -} - # _remove_alias # # Remove the specified alias from the specified query hash. A copy is made so @@ -2794,10 +2883,9 @@ L. =cut sub create { - my ($self, $col_data) = @_; - $self->throw_exception( "create needs a hashref" ) - unless ref $col_data eq 'HASH'; - return $self->new_result($col_data)->insert; + #my ($self, $col_data) = @_; + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + return shift->new_result(shift)->insert; } =head2 find_or_create @@ -2879,7 +2967,7 @@ sub find_or_create { if (keys %$hash and my $row = $self->find($hash, $attrs) ) { return $row; } - return $self->create($hash); + return $self->new_result($hash)->insert; } =head2 update_or_create @@ -2949,7 +3037,7 @@ sub update_or_create { return $row; } - return $self->create($cond); + return $self->new_result($cond)->insert; } =head2 update_or_new @@ -3132,10 +3220,16 @@ Returns a related resultset for the supplied relationship name. =cut sub related_resultset { - my ($self, $rel) = @_; + $_[0]->throw_exception( + 'Extra arguments to $rs->related_resultset() were always quietly ' + . 'discarded without consideration, you need to switch to ' + . '...->related_resultset( $relname )->search_rs( $search, $args ) instead.' + ) if @_ > 2; - return $self->{related_resultsets}{$rel} - if defined $self->{related_resultsets}{$rel}; + return $_[0]->{related_resultsets}{$_[1]} + if defined $_[0]->{related_resultsets}{$_[1]}; + + my ($self, $rel) = @_; return $self->{related_resultsets}{$rel} = do { my $rsrc = $self->result_source; @@ -3148,22 +3242,25 @@ sub related_resultset { my $attrs = $self->_chain_relationship($rel); - my $join_count = $attrs->{seen_join}{$rel}; + my $storage = $rsrc->schema->storage; - my $alias = $self->result_source->storage - ->relname_to_table_alias($rel, $join_count); + # Previously this atribute was deleted (instead of being set as it is now) + # Doing so seems to be harmless in all available test permutations + # See also 01d59a6a6 and mst's comment below + # + $attrs->{alias} = $storage->relname_to_table_alias( + $rel, + $attrs->{seen_join}{$rel} + ); # since this is search_related, and we already slid the select window inwards # (the select/as attrs were deleted in the beginning), we need to flip all # left joins to inner, so we get the expected results # read the comment on top of the actual function to see what this does - $attrs->{from} = $rsrc->schema->storage->_inner_join_to_node ($attrs->{from}, $alias); - + $attrs->{from} = $storage->_inner_join_to_node( $attrs->{from}, $attrs->{alias} ); #XXX - temp fix for result_class bug. There likely is a more elegant fix -groditi - delete @{$attrs}{qw(result_class alias)}; - - my $rel_source = $rsrc->related_source($rel); + delete $attrs->{result_class}; my $new = do { @@ -3172,25 +3269,28 @@ sub related_resultset { # source you need to know what alias it's -going- to have for things # to work sanely (e.g. RestrictWithObject wants to be able to add # extra query restrictions, and these may need to be $alias.) - - my $rel_attrs = $rel_source->resultset_attributes; - local $rel_attrs->{alias} = $alias; - - $rel_source->resultset - ->search_rs( - undef, { - %$attrs, - where => $attrs->{where}, - }); + # -- mst ~ 2007 (01d59a6a6) + # + # FIXME - this seems to be no longer neccessary (perhaps due to the + # advances in relcond resolution. Testing DBIC::S::RWO and its only + # dependent (as of Jun 2015 ) does not yield any difference with or + # without this line. Nevertheless keep it as is for now, to minimize + # churn, there is enough potential for breakage in 0.0829xx as it is + # -- ribasushi Jun 2015 + # + my $rel_source = $rsrc->related_source($rel); + local $rel_source->resultset_attributes->{alias} = $attrs->{alias}; + + $rel_source->resultset->search_rs( undef, $attrs ); }; if (my $cache = $self->get_cache) { my @related_cache = map - { @{$_->related_resultset($rel)->get_cache||[]} } + { $_->related_resultset($rel)->get_cache || () } @$cache ; - $new->set_cache(\@related_cache) if @related_cache; + $new->set_cache([ map @$_, @related_cache ]) if @related_cache == @$cache; } $new; @@ -3232,6 +3332,9 @@ source alias of the current result set: }); } +The alias of L can be altered by the +L. + =cut sub current_source_alias { @@ -3422,7 +3525,7 @@ sub _resolved_attrs { return $self->{_attrs} if $self->{_attrs}; my $attrs = { %{ $self->{attrs} || {} } }; - my $source = $self->result_source; + my $source = $attrs->{result_source} = $self->result_source; my $alias = $attrs->{alias}; $self->throw_exception("Specifying distinct => 1 in conjunction with collapse => 1 is unsupported") @@ -3526,62 +3629,35 @@ sub _resolved_attrs { ]; } - if ( defined $attrs->{order_by} ) { - $attrs->{order_by} = ( - ref( $attrs->{order_by} ) eq 'ARRAY' - ? [ @{ $attrs->{order_by} } ] - : [ $attrs->{order_by} || () ] - ); - } - if ($attrs->{group_by} and ref $attrs->{group_by} ne 'ARRAY') { - $attrs->{group_by} = [ $attrs->{group_by} ]; - } + for my $attr (qw(order_by group_by)) { + if ( defined $attrs->{$attr} ) { + $attrs->{$attr} = ( + ref( $attrs->{$attr} ) eq 'ARRAY' + ? [ @{ $attrs->{$attr} } ] + : [ $attrs->{$attr} || () ] + ); - # generate selections based on the prefetch helper - my ($prefetch, @prefetch_select, @prefetch_as); - $prefetch = $self->_merge_joinpref_attr( {}, delete $attrs->{prefetch} ) - if defined $attrs->{prefetch}; - - if ($prefetch) { + delete $attrs->{$attr} unless @{$attrs->{$attr}}; + } + } - $self->throw_exception("Unable to prefetch, resultset contains an unnamed selector $attrs->{_dark_selector}{string}") - if $attrs->{_dark_selector}; + # set collapse default based on presence of prefetch + my $prefetch; + if ( + defined $attrs->{prefetch} + and + $prefetch = $self->_merge_joinpref_attr( {}, delete $attrs->{prefetch} ) + ) { $self->throw_exception("Specifying prefetch in conjunction with an explicit collapse => 0 is unsupported") if defined $attrs->{collapse} and ! $attrs->{collapse}; $attrs->{collapse} = 1; - - # this is a separate structure (we don't look in {from} directly) - # as the resolver needs to shift things off the lists to work - # properly (identical-prefetches on different branches) - my $join_map = {}; - if (ref $attrs->{from} eq 'ARRAY') { - - my $start_depth = $attrs->{seen_join}{-relation_chain_depth} || 0; - - for my $j ( @{$attrs->{from}}[1 .. $#{$attrs->{from}} ] ) { - next unless $j->[0]{-alias}; - next unless $j->[0]{-join_path}; - next if ($j->[0]{-relation_chain_depth} || 0) < $start_depth; - - my @jpath = map { keys %$_ } @{$j->[0]{-join_path}}; - - my $p = $join_map; - $p = $p->{$_} ||= {} for @jpath[ ($start_depth/2) .. $#jpath]; #only even depths are actual jpath boundaries - push @{$p->{-join_aliases} }, $j->[0]{-alias}; - } - } - - my @prefetch = $source->_resolve_prefetch( $prefetch, $alias, $join_map ); - - # save these for after distinct resolution - @prefetch_select = map { $_->[0] } @prefetch; - @prefetch_as = map { $_->[1] } @prefetch; } + # run through the resulting joinstructure (starting from our current slot) # and unset collapse if proven unnecessary # @@ -3631,6 +3707,7 @@ sub _resolved_attrs { } } + # generate the distinct induced group_by before injecting the prefetched select/as parts if (delete $attrs->{distinct}) { if ($attrs->{group_by}) { @@ -3650,15 +3727,46 @@ sub _resolved_attrs { } } - # inject prefetch-bound selection (if any) - push @{$attrs->{select}}, @prefetch_select; - push @{$attrs->{as}}, @prefetch_as; - # whether we can get away with the dumbest (possibly DBI-internal) collapser - if ( List::Util::first { $_ =~ /\./ } @{$attrs->{as}} ) { - $attrs->{_related_results_construction} = 1; + # generate selections based on the prefetch helper + if ($prefetch) { + + $self->throw_exception("Unable to prefetch, resultset contains an unnamed selector $attrs->{_dark_selector}{string}") + if $attrs->{_dark_selector}; + + # this is a separate structure (we don't look in {from} directly) + # as the resolver needs to shift things off the lists to work + # properly (identical-prefetches on different branches) + my $joined_node_aliases_map = {}; + if (ref $attrs->{from} eq 'ARRAY') { + + my $start_depth = $attrs->{seen_join}{-relation_chain_depth} || 0; + + for my $j ( @{$attrs->{from}}[1 .. $#{$attrs->{from}} ] ) { + next unless $j->[0]{-alias}; + next unless $j->[0]{-join_path}; + next if ($j->[0]{-relation_chain_depth} || 0) < $start_depth; + + my @jpath = map { keys %$_ } @{$j->[0]{-join_path}}; + + my $p = $joined_node_aliases_map; + $p = $p->{$_} ||= {} for @jpath[ ($start_depth/2) .. $#jpath]; #only even depths are actual jpath boundaries + push @{$p->{-join_aliases} }, $j->[0]{-alias}; + } + } + + ( push @{$attrs->{select}}, $_->[0] ) and ( push @{$attrs->{as}}, $_->[1] ) + for $source->_resolve_selection_from_prefetch( $prefetch, $joined_node_aliases_map ); } + + $attrs->{_simple_passthrough_construction} = !( + $attrs->{collapse} + or + grep { $_ =~ /\./ } @{$attrs->{as}} + ); + + # if both page and offset are specified, produce a combined offset # even though it doesn't make much sense, this is what pre 081xx has # been doing @@ -3724,8 +3832,10 @@ sub _calculate_score { if (ref $b eq 'HASH') { my ($b_key) = keys %{$b}; + $b_key = '' if ! defined $b_key; if (ref $a eq 'HASH') { my ($a_key) = keys %{$a}; + $a_key = '' if ! defined $a_key; if ($a_key eq $b_key) { return (1 + $self->_calculate_score( $a->{$a_key}, $b->{$b_key} )); } else { @@ -3977,32 +4087,65 @@ syntax as outlined above. Shortcut to request a particular set of columns to be retrieved. Each column spec may be a string (a table column name), or a hash (in which case the key is the C value, and the value is used as the C from that, then auto-populates C from C and L. - columns => [ 'foo', { bar => 'baz' } ] + columns => [ 'some_column', { dbic_slot => 'another_column' } ] is the same as - select => [qw/foo baz/], - as => [qw/foo bar/] + select => [qw(some_column another_column)], + as => [qw(some_column dbic_slot)] + +If you want to individually retrieve related columns (in essence perform +manual L) you have to make sure to specify the correct inflation slot +chain such that it matches existing relationships: + + my $rs = $schema->resultset('Artist')->search({}, { + # required to tell DBIC to collapse has_many relationships + collapse => 1, + join => { cds => 'tracks' }, + '+columns' => { + 'cds.cdid' => 'cds.cdid', + 'cds.tracks.title' => 'tracks.title', + }, + }); + +Like elsewhere, literal SQL or literal values can be included by using a +scalar reference or a literal bind value, and these values will be available +in the result with C (see also +L): + + # equivalent SQL: SELECT 1, 'a string', IF(my_column,?,?) ... + # bind values: $true_value, $false_value + columns => [ + { + foo => \1, + bar => \q{'a string'}, + baz => \[ 'IF(my_column,?,?)', $true_value, $false_value ], + } + ] =head2 +columns +B You B explicitly quote C<'+columns'> when using this attribute. +Not doing so causes Perl to incorrectly interpret C<+columns> as a bareword +with a unary plus operator before it, which is the same as simply C. + =over 4 -=item Value: \@columns +=item Value: \@extra_columns =back Indicates additional columns to be selected from storage. Works the same as -L but adds columns to the selection. (You may also use the +L but adds columns to the current selection. (You may also use the C attribute, as in earlier versions of DBIC, but this is -deprecated). For example:- +deprecated) $schema->resultset('CD')->search(undef, { '+columns' => ['artist.name'], @@ -4014,20 +4157,6 @@ passed to object inflation. Note that the 'artist' is the name of the column (or relationship) accessor, and 'name' is the name of the column accessor in the related table. -B You need to explicitly quote '+columns' when defining the attribute. -Not doing so causes Perl to incorrectly interpret +columns as a bareword with a -unary plus operator before it. - -=head2 include_columns - -=over 4 - -=item Value: \@columns - -=back - -Deprecated. Acts as a synonym for L for backward compatibility. - =head2 select =over 4 @@ -4053,25 +4182,28 @@ names: B You will almost always need a corresponding L attribute when you use L, to instruct DBIx::Class how to store the result of the column. -Also note that the L attribute has nothing to do with the SQL-side 'AS' -identifier aliasing. You can however alias a function, so you can use it in -e.g. an C clause. This is done via the C<-as> B supplied as shown in the example above. =head2 +select +B You B explicitly quote C<'+select'> when using this attribute. +Not doing so causes Perl to incorrectly interpret C<+select> as a bareword +with a unary plus operator before it, which is the same as simply C but adds columns to the default selection, instead of specifying -an explicit list. +=item Value: \@extra_select_columns =back +Indicates additional columns to be selected from storage. Works the same as +L but adds columns to the current selection, instead of specifying +a new explicit list. + =head2 as =over 4 @@ -4080,12 +4212,14 @@ an explicit list. =back -Indicates column names for object inflation. That is L indicates the +Indicates DBIC-side names for object inflation. That is L indicates the slot name in which the column value will be stored within the L object. The value will then be accessible via this identifier by the C method (or via the object accessor B) as shown below. The L attribute has -B with the SQL-side C. See L for details. +with the same name already exists>) as shown below. + +The L attribute has B with the SQL-side identifier +aliasing C. See L for details. $rs = $schema->resultset('Employee')->search(undef, { select => [ @@ -4116,12 +4250,18 @@ L for details. =head2 +as +B You B explicitly quote C<'+as'> when using this attribute. +Not doing so causes Perl to incorrectly interpret C<+as> as a bareword +with a unary plus operator before it, which is the same as simply C. + =over 4 -Indicates additional column names for those added via L. See L. +=item Value: \@extra_inflation_names =back +Indicates additional inflation names for selectors added via L. See L. + =head2 join =over 4 @@ -4255,8 +4395,10 @@ For a more in-depth discussion, see L. This attribute is a shorthand for specifying a L spec, adding all columns from the joined related sources as L and setting -L to a true value. For example, the following two queries are -equivalent: +L to a true value. It can be thought of as a rough B +of the L attribute. + +For example, the following two queries are equivalent: my $rs = $schema->resultset('Artist')->search({}, { prefetch => { cds => ['genre', 'tracks' ] }, @@ -4433,15 +4575,20 @@ A arrayref of columns to group by. Can include columns of joined tables. =back -HAVING is a select statement attribute that is applied between GROUP BY and -ORDER BY. It is applied to the after the grouping calculations have been -done. +The HAVING operator specifies a B condition applied to the set +after the grouping calculations have been done. In other words it is a +constraint just like L (and accepting the same +L) applied to the data +as it exists after GROUP BY has taken place. Specifying L without +L is a logical mistake, and a fatal error on most RDBMS engines. + +E.g. having => { 'count_employee' => { '>=', 100 } } or with an in-place function in which case literal SQL is required: - having => \[ 'count(employee) >= ?', [ count => 100 ] ] + having => \[ 'count(employee) >= ?', 100 ] =head2 distinct @@ -4465,19 +4612,14 @@ setting is ignored and an appropriate warning is issued. =head2 where -=over 4 - -Adds to the WHERE clause. +Adds extra conditions to the resultset, combined with the preexisting C +conditions, same as the B argument to the L # only return rows WHERE deleted IS NULL for all searches __PACKAGE__->resultset_attributes({ where => { deleted => undef } }); -Can be overridden by passing C<< { where => undef } >> as an attribute -to a resultset. - -For more complicated where clauses see L. - -=back +Note that the above example is +L. =head2 cache @@ -4683,11 +4825,15 @@ supported: [ undef, $val ] === [ {}, $val ] $val === [ {}, $val ] -=head1 AUTHOR AND CONTRIBUTORS +=head1 FURTHER QUESTIONS? -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. +=cut diff --git a/lib/DBIx/Class/ResultSet/Pager.pm b/lib/DBIx/Class/ResultSet/Pager.pm index e8510c32a..e606f8a90 100644 --- a/lib/DBIx/Class/ResultSet/Pager.pm +++ b/lib/DBIx/Class/ResultSet/Pager.pm @@ -4,6 +4,9 @@ package # hide from pause use warnings; use strict; +# temporary, to load MRO::Compat, will be soon entirely rewritten anyway +use DBIx::Class::_Util; + use base 'Data::Page'; use mro 'c3'; diff --git a/lib/DBIx/Class/ResultSetColumn.pm b/lib/DBIx/Class/ResultSetColumn.pm index 1e2a0ebab..e26b6c2f3 100644 --- a/lib/DBIx/Class/ResultSetColumn.pm +++ b/lib/DBIx/Class/ResultSetColumn.pm @@ -406,7 +406,7 @@ sub func { my $cursor = $self->func_rs($function)->cursor; if( wantarray ) { - DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = fail_on_internal_wantarray($self); + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = fail_on_internal_wantarray; return map { $_->[ 0 ] } $cursor->all; } @@ -487,14 +487,14 @@ sub _resultset { unless( $cols{$select} ) { carp_unique( 'Use of distinct => 1 while selecting anything other than a column ' - . 'declared on the primary ResultSource is deprecated - please supply ' - . 'an explicit group_by instead' + . 'declared on the primary ResultSource is deprecated (you selected ' + . "'$self->{_as}') - please supply an explicit group_by instead" ); # collapse the selector to a literal so that it survives the distinct parse # if it turns out to be an aggregate - at least the user will get a proper exception # instead of silent drop of the group_by altogether - $select = \ $rsrc->storage->sql_maker->_recurse_fields($select); + $select = \[ $rsrc->storage->sql_maker->_recurse_fields($select) ]; } } @@ -504,14 +504,18 @@ sub _resultset { }; } -1; - -=head1 AUTHOR AND CONTRIBUTORS +=head1 FURTHER QUESTIONS? -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut + +1; + diff --git a/lib/DBIx/Class/ResultSetManager.pm b/lib/DBIx/Class/ResultSetManager.pm index d2746e58f..bb9f3bf06 100644 --- a/lib/DBIx/Class/ResultSetManager.pm +++ b/lib/DBIx/Class/ResultSetManager.pm @@ -88,4 +88,17 @@ sub _register_resultset_class { } } +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. + +=cut + 1; diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 3233e3ab4..12eccc1a6 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -9,16 +9,18 @@ use DBIx::Class::ResultSet; use DBIx::Class::ResultSourceHandle; use DBIx::Class::Carp; +use DBIx::Class::_Util 'UNRESOLVABLE_CONDITION'; +use SQL::Abstract 'is_literal_value'; use Devel::GlobalDestruction; use Try::Tiny; -use List::Util 'first'; use Scalar::Util qw/blessed weaken isweak/; use namespace::clean; __PACKAGE__->mk_group_accessors(simple => qw/ source_name name source_info - _ordered_columns _columns _primaries _unique_constraints + _ordered_columns _columns _primaries + _unique_constraints _unique_constraints_extra _relationships resultset_attributes column_info_from_storage /); @@ -75,7 +77,7 @@ More specifically, the L base class pulls in the L component, which defines the L method. When called, C
creates and stores an instance of -L. Luckily, to use tables as result +L. Luckily, to use tables as result sources, you don't need to remember any of this. Result sources representing select queries, or views, can also be @@ -84,7 +86,8 @@ created, see L for full details. =head2 Finding result source objects As mentioned above, a result source instance is created and stored for -you when you define a L. +you when you define a +L. You can retrieve the result source at runtime in the following ways: @@ -106,7 +109,13 @@ You can retrieve the result source at runtime in the following ways: =head1 METHODS -=pod +=head2 new + + $class->new(); + + $class->new({attribute_name => value}); + +Creates a new ResultSource object. Not normally called directly by end users. =cut @@ -141,6 +150,11 @@ sub new { $source->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...); + $source->add_columns( + 'col1' => { data_type => 'integer', is_nullable => 1, ... }, + 'col2' => { data_type => 'text', is_auto_increment => 1, ... }, + ); + Adds columns to the result source. If supplied colname => hashref pairs, uses the hashref as the L for that column. Repeated calls of this method will add more columns, not replace them. @@ -197,11 +211,17 @@ The length of your column, if it is a column type that can have a size restriction. This is currently only used to create tables from your schema, see L. + { size => [ 9, 6 ] } + +For decimal or float values you can specify an ArrayRef in order to +control precision, assuming your database's +L supports it. + =item is_nullable { is_nullable => 1 } -Set this to a true value for a columns that is allowed to contain NULL +Set this to a true value for a column that is allowed to contain NULL values, default is false. This is currently only used to create tables from your schema, see L. @@ -456,12 +476,12 @@ sub columns_info { my $colinfo = $self->_columns; if ( - first { ! $_->{data_type} } values %$colinfo - and ! $self->{_columns_info_loaded} and $self->column_info_from_storage and + grep { ! $_->{data_type} } values %$colinfo + and my $stor = try { $self->storage } ) { $self->{_columns_info_loaded}++; @@ -575,7 +595,7 @@ sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB Defines one or more columns as primary key for this source. Must be called after L. -Additionally, defines a L +Additionally, defines a L named C. Note: you normally do want to define a primary key on your sources @@ -639,7 +659,7 @@ sub _pri_cols_or_die { } # same as above but mandating single-column PK (used by relationship condition -# inferrence) +# inference) sub _single_pri_col_or_die { my $self = shift; my ($pri, @too_many) = $self->_pri_cols_or_die; @@ -683,7 +703,7 @@ sub sequence { =over 4 -=item Arguments: $name?, \@colnames +=item Arguments: $name?, \@colnames, \%options? =item Return Value: not defined @@ -694,7 +714,8 @@ constraint. # For UNIQUE (column1, column2) __PACKAGE__->add_unique_constraint( - constraint_name => [ qw/column1 column2/ ], + constraint_name => [ qw/column1 column2/ ], + { deferrable => 1 } ); Alternatively, you can specify only the columns: @@ -705,6 +726,11 @@ This will result in a unique constraint named C, where C
is replaced with the table name. +The options hashref will be passed to +L; the intention being to +allow the C flag to be set, but you may find others +useful. Note that C, C, and C will be ignored. + Unique constraints are used, for example, when you pass the constraint name as the C attribute to L. Then only columns in the constraint are searched. @@ -717,14 +743,20 @@ the result source. sub add_unique_constraint { my $self = shift; - if (@_ > 2) { + if ((grep {ref $_ eq 'ARRAY'} @_) > 1) { $self->throw_exception( 'add_unique_constraint() does not accept multiple constraints, use ' . 'add_unique_constraints() instead' ); } + my $opts; my $cols = pop @_; + if (ref $cols eq 'HASH') { + $opts = $cols; + $cols = pop @_; + } + if (ref $cols ne 'ARRAY') { $self->throw_exception ( 'Expecting an arrayref of constraint columns, got ' . ($cols||'NOTHING') @@ -741,8 +773,11 @@ sub add_unique_constraint { } my %unique_constraints = $self->unique_constraints; + my %unique_constraints_extra = $self->unique_constraints_extra; $unique_constraints{$name} = $cols; + $unique_constraints_extra{$name} = $opts; $self->_unique_constraints(\%unique_constraints); + $self->_unique_constraints_extra(\%unique_constraints_extra); } =head2 add_unique_constraints @@ -783,7 +818,7 @@ sub add_unique_constraints { my $self = shift; my @constraints = @_; - if ( !(@constraints % 2) && first { ref $_ ne 'ARRAY' } @constraints ) { + if ( !(@constraints % 2) && grep { ref $_ ne 'ARRAY' } @constraints ) { # with constraint name while (my ($name, $constraint) = splice @constraints, 0, 2) { $self->add_unique_constraint($name => $constraint); @@ -829,6 +864,7 @@ sub name_unique_constraint { my $name = $self->name; $name = $$name if (ref $name eq 'SCALAR'); + $name =~ s/ ^ [^\.]+ \. //x; # strip possible schema qualifier return join '_', $name, @$cols; } @@ -857,6 +893,30 @@ sub unique_constraints { return %{shift->_unique_constraints||{}}; } +=head2 unique_constraints_extra + +=over 4 + +=item Arguments: none + +=item Return Value: Hash of unique constraint \%options + +=back + + my %uq_extras = $source->unique_constraints_extra(); + +Read-only accessor which returns a hash of the options provided to +unique constraints. + +The hash is keyed by constraint name, and the values are the options +hashrefs as provided to L. + +=cut + +sub unique_constraints_extra { + return %{shift->_unique_constraints_extra||{}}; +} + =head2 unique_constraint_names =over 4 @@ -1172,6 +1232,17 @@ clause contents. sub from { die 'Virtual method!' } +=head2 source_info + +Stores a hashref of per-source metadata. No specific key names +have yet been standardized, the examples below are purely hypothetical +and don't actually accomplish anything on their own: + + __PACKAGE__->source_info({ + "_tablespace" => 'fast_disk_array_3', + "_engine" => 'InnoDB', + }); + =head2 schema =over 4 @@ -1313,10 +1384,11 @@ sub add_relationship { # Check foreign and self are right in cond if ( (ref $cond ||'') eq 'HASH') { - for (keys %$cond) { - $self->throw_exception("Keys of condition should be of form 'foreign.col', not '$_'") - if /\./ && !/^foreign\./; - } + $_ =~ /^foreign\./ or $self->throw_exception("Malformed relationship condition key '$_': must be prefixed with 'foreign.'") + for keys %$cond; + + $_ =~ /^self\./ or $self->throw_exception("Malformed relationship condition value '$_': must be prefixed with 'self.'") + for values %$cond; } my %rels = %{ $self->_relationships }; @@ -1362,7 +1434,7 @@ sub add_relationship { =back - my @relnames = $source->relationships(); + my @rel_names = $source->relationships(); Returns all relationship names for this source. @@ -1545,6 +1617,67 @@ sub _identifying_column_set { return undef; } +sub _minimal_valueset_satisfying_constraint { + my $self = shift; + my $args = { ref $_[0] eq 'HASH' ? %{ $_[0] } : @_ }; + + $args->{columns_info} ||= $self->columns_info; + + my $vals = $self->storage->_extract_fixed_condition_columns( + $args->{values}, + ($args->{carp_on_nulls} ? 'consider_nulls' : undef ), + ); + + my $cols; + for my $col ($self->unique_constraint_columns($args->{constraint_name}) ) { + if( ! exists $vals->{$col} or ( $vals->{$col}||'' ) eq UNRESOLVABLE_CONDITION ) { + $cols->{missing}{$col} = undef; + } + elsif( ! defined $vals->{$col} ) { + $cols->{$args->{carp_on_nulls} ? 'undefined' : 'missing'}{$col} = undef; + } + else { + # we need to inject back the '=' as _extract_fixed_condition_columns + # will strip it from literals and values alike, resulting in an invalid + # condition in the end + $cols->{present}{$col} = { '=' => $vals->{$col} }; + } + + $cols->{fc}{$col} = 1 if ( + ( ! $cols->{missing} or ! exists $cols->{missing}{$col} ) + and + keys %{ $args->{columns_info}{$col}{_filter_info} || {} } + ); + } + + $self->throw_exception( sprintf ( "Unable to satisfy requested constraint '%s', missing values for column(s): %s", + $args->{constraint_name}, + join (', ', map { "'$_'" } sort keys %{$cols->{missing}} ), + ) ) if $cols->{missing}; + + $self->throw_exception( sprintf ( + "Unable to satisfy requested constraint '%s', FilterColumn values not usable for column(s): %s", + $args->{constraint_name}, + join (', ', map { "'$_'" } sort keys %{$cols->{fc}}), + )) if $cols->{fc}; + + if ( + $cols->{undefined} + and + !$ENV{DBIC_NULLABLE_KEY_NOWARN} + ) { + carp_unique ( sprintf ( + "NULL/undef values supplied for requested unique constraint '%s' (NULL " + . 'values in column(s): %s). This is almost certainly not what you wanted, ' + . 'though you can set DBIC_NULLABLE_KEY_NOWARN to disable this warning.', + $args->{constraint_name}, + join (', ', map { "'$_'" } sort keys %{$cols->{undefined}}), + )); + } + + return { map { %{ $cols->{$_}||{} } } qw(present undefined) }; +} + # Returns the {from} structure used to express JOIN conditions sub _resolve_join { my ($self, $join, $alias, $seen, $jpath, $parent_force_left) = @_; @@ -1614,14 +1747,20 @@ sub _resolve_join { , -join_path => [@$jpath, { $join => $as } ], -is_single => ( - (! $rel_info->{attrs}{accessor}) + ! $rel_info->{attrs}{accessor} + or + $rel_info->{attrs}{accessor} eq 'single' or - first { $rel_info->{attrs}{accessor} eq $_ } (qw/single filter/) + $rel_info->{attrs}{accessor} eq 'filter' ), -alias => $as, -relation_chain_depth => ( $seen->{-relation_chain_depth} || 0 ) + 1, }, - scalar $self->_resolve_condition($rel_info->{cond}, $as, $alias, $join) + $self->_resolve_relationship_condition( + rel_name => $join, + self_alias => $alias, + foreign_alias => $as, + )->{condition}, ]; } } @@ -1670,150 +1809,504 @@ sub _pk_depends_on { sub resolve_condition { carp 'resolve_condition is a private method, stop calling it'; - my $self = shift; - $self->_resolve_condition (@_); + shift->_resolve_condition (@_); } -our $UNRESOLVABLE_CONDITION = \ '1 = 0'; - -# Resolves the passed condition to a concrete query fragment and a flag -# indicating whether this is a cross-table condition. Also an optional -# list of non-trivial values (normally conditions) returned as a part -# of a joinfree condition hash sub _resolve_condition { - my ($self, $cond, $as, $for, $rel_name) = @_; +# carp_unique sprintf +# '_resolve_condition is a private method, and moreover is about to go ' +# . 'away. Please contact the development team at %s if you believe you ' +# . 'have a genuine use for this method, in order to discuss alternatives.', +# DBIx::Class::_ENV_::HELP_URL, +# ; + +####################### +### API Design? What's that...? (a backwards compatible shim, kill me now) + + my ($self, $cond, @res_args, $rel_name); + + # we *SIMPLY DON'T KNOW YET* which arg is which, yay + ($self, $cond, $res_args[0], $res_args[1], $rel_name) = @_; + + # assume that an undef is an object-like unset (set_from_related(undef)) + my @is_objlike = map { ! defined $_ or length ref $_ } (@res_args); + + # turn objlike into proper objects for saner code further down + for (0,1) { + next unless $is_objlike[$_]; + + if ( defined blessed $res_args[$_] ) { + + # but wait - there is more!!! WHAT THE FUCK?!?!?!?! + if ($res_args[$_]->isa('DBIx::Class::ResultSet')) { + carp('Passing a resultset for relationship resolution makes no sense - invoking __gremlins__'); + $is_objlike[$_] = 0; + $res_args[$_] = '__gremlins__'; + } + } + else { + $res_args[$_] ||= {}; + + # hate everywhere - have to pass in as a plain hash + # pretending to be an object at least for now + $self->throw_exception("Unsupported object-like structure encountered: $res_args[$_]") + unless ref $res_args[$_] eq 'HASH'; + } + } + + my $args = { + # where-is-waldo block guesses relname, then further down we override it if available + ( + $is_objlike[1] ? ( rel_name => $res_args[0], self_alias => $res_args[0], foreign_alias => 'me', self_result_object => $res_args[1] ) + : $is_objlike[0] ? ( rel_name => $res_args[1], self_alias => 'me', foreign_alias => $res_args[1], foreign_values => $res_args[0] ) + : ( rel_name => $res_args[0], self_alias => $res_args[1], foreign_alias => $res_args[0] ) + ), + + ( $rel_name ? ( rel_name => $rel_name ) : () ), + }; + + # Allowing passing relconds different than the relationshup itself is cute, + # but likely dangerous. Remove that from the (still unofficial) API of + # _resolve_relationship_condition, and instead make it "hard on purpose" + local $self->relationship_info( $args->{rel_name} )->{cond} = $cond if defined $cond; + +####################### + + # now it's fucking easy isn't it?! + my $rc = $self->_resolve_relationship_condition( $args ); + + my @res = ( + ( $rc->{join_free_condition} || $rc->{condition} ), + ! $rc->{join_free_condition}, + ); + + # _resolve_relationship_condition always returns qualified cols even in the + # case of join_free_condition, but nothing downstream expects this + if ($rc->{join_free_condition} and ref $res[0] eq 'HASH') { + $res[0] = { map + { ($_ =~ /\.(.+)/) => $res[0]{$_} } + keys %{$res[0]} + }; + } + + # and more legacy + return wantarray ? @res : $res[0]; +} + +# Keep this indefinitely. There is evidence of both CPAN and +# darkpan using it, and there isn't much harm in an extra var +# anyway. +our $UNRESOLVABLE_CONDITION = UNRESOLVABLE_CONDITION; +# YES I KNOW THIS IS EVIL +# it is there to save darkpan from themselves, since internally +# we are moving to a constant +Internals::SvREADONLY($UNRESOLVABLE_CONDITION => 1); + +# Resolves the passed condition to a concrete query fragment and extra +# metadata +# +## self-explanatory API, modeled on the custom cond coderef: +# rel_name => (scalar) +# foreign_alias => (scalar) +# foreign_values => (either not supplied, or a hashref, or a foreign ResultObject (to be ->get_columns()ed), or plain undef ) +# self_alias => (scalar) +# self_result_object => (either not supplied or a result object) +# require_join_free_condition => (boolean, throws on failure to construct a JF-cond) +# infer_values_based_on => (either not supplied or a hashref, implies require_join_free_condition) +# +## returns a hash +# condition => (a valid *likely fully qualified* sqla cond structure) +# identity_map => (a hashref of foreign-to-self *unqualified* column equality names) +# join_free_condition => (a valid *fully qualified* sqla cond structure, maybe unset) +# inferred_values => (in case of an available join_free condition, this is a hashref of +# *unqualified* column/value *EQUALITY* pairs, representing an amalgamation +# of the JF-cond parse and infer_values_based_on +# always either complete or unset) +# +sub _resolve_relationship_condition { + my $self = shift; + + my $args = { ref $_[0] eq 'HASH' ? %{ $_[0] } : @_ }; + + for ( qw( rel_name self_alias foreign_alias ) ) { + $self->throw_exception("Mandatory argument '$_' to _resolve_relationship_condition() is not a plain string") + if !defined $args->{$_} or length ref $args->{$_}; + } + + $self->throw_exception("Arguments 'self_alias' and 'foreign_alias' may not be identical") + if $args->{self_alias} eq $args->{foreign_alias}; + +# TEMP + my $exception_rel_id = "relationship '$args->{rel_name}' on source '@{[ $self->source_name ]}'"; + + my $rel_info = $self->relationship_info($args->{rel_name}) +# TEMP +# or $self->throw_exception( "No such $exception_rel_id" ); + or carp_unique("Requesting resolution on non-existent relationship '$args->{rel_name}' on source '@{[ $self->source_name ]}': fix your code *soon*, as it will break with the next major version"); + +# TEMP + $exception_rel_id = "relationship '$rel_info->{_original_name}' on source '@{[ $self->source_name ]}'" + if $rel_info and exists $rel_info->{_original_name}; + + $self->throw_exception("No practical way to resolve $exception_rel_id between two data structures") + if exists $args->{self_result_object} and exists $args->{foreign_values}; + + $self->throw_exception( "Argument to infer_values_based_on must be a hash" ) + if exists $args->{infer_values_based_on} and ref $args->{infer_values_based_on} ne 'HASH'; + + $args->{require_join_free_condition} ||= !!$args->{infer_values_based_on}; + + $self->throw_exception( "Argument 'self_result_object' must be an object inheriting from DBIx::Class::Row" ) + if ( + exists $args->{self_result_object} + and + ( ! defined blessed $args->{self_result_object} or ! $args->{self_result_object}->isa('DBIx::Class::Row') ) + ) + ; + + my $rel_rsrc = $self->related_source($args->{rel_name}); + my $storage = $self->schema->storage; + + if (exists $args->{foreign_values}) { + + if (! defined $args->{foreign_values} ) { + # fallback: undef => {} + $args->{foreign_values} = {}; + } + elsif (defined blessed $args->{foreign_values}) { + + $self->throw_exception( "Objects supplied as 'foreign_values' ($args->{foreign_values}) must inherit from DBIx::Class::Row" ) + unless $args->{foreign_values}->isa('DBIx::Class::Row'); + + carp_unique( + "Objects supplied as 'foreign_values' ($args->{foreign_values}) " + . "usually should inherit from the related ResultClass ('@{[ $rel_rsrc->result_class ]}'), " + . "perhaps you've made a mistake invoking the condition resolver?" + ) unless $args->{foreign_values}->isa($rel_rsrc->result_class); + + $args->{foreign_values} = { $args->{foreign_values}->get_columns }; + } + elsif ( ref $args->{foreign_values} eq 'HASH' ) { + + # re-build {foreign_values} excluding identically named rels + if( keys %{$args->{foreign_values}} ) { + + my ($col_idx, $rel_idx) = map + { { map { $_ => 1 } $rel_rsrc->$_ } } + qw( columns relationships ) + ; + + my $equivalencies = $storage->_extract_fixed_condition_columns( + $args->{foreign_values}, + 'consider nulls', + ); + + $args->{foreign_values} = { map { + # skip if relationship *and* a non-literal ref + # this means a multicreate stub was passed in + ( + $rel_idx->{$_} + and + length ref $args->{foreign_values}{$_} + and + ! is_literal_value($args->{foreign_values}{$_}) + ) + ? () + : ( $_ => ( + ! $col_idx->{$_} + ? $self->throw_exception( "Key '$_' supplied as 'foreign_values' is not a column on related source '@{[ $rel_rsrc->source_name ]}'" ) + : ( !exists $equivalencies->{$_} or ($equivalencies->{$_}||'') eq UNRESOLVABLE_CONDITION ) + ? $self->throw_exception( "Value supplied for '...{foreign_values}{$_}' is not a direct equivalence expression" ) + : $args->{foreign_values}{$_} + )) + } keys %{$args->{foreign_values}} }; + } + } + else { + $self->throw_exception( + "Argument 'foreign_values' must be either an object inheriting from '@{[ $rel_rsrc->result_class ]}', " + . "or a hash reference, or undef" + ); + } + } - my $obj_rel = defined blessed $for; + my $ret; - if (ref $cond eq 'CODE') { - my $relalias = $obj_rel ? 'me' : $as; + if (ref $rel_info->{cond} eq 'CODE') { - my ($crosstable_cond, $joinfree_cond) = $cond->({ - self_alias => $obj_rel ? $as : $for, - foreign_alias => $relalias, + my $cref_args = { + rel_name => $args->{rel_name}, self_resultsource => $self, - foreign_relname => $rel_name || ($obj_rel ? $as : $for), - self_rowobj => $obj_rel ? $for : undef - }); + self_alias => $args->{self_alias}, + foreign_alias => $args->{foreign_alias}, + ( map + { (exists $args->{$_}) ? ( $_ => $args->{$_} ) : () } + qw( self_result_object foreign_values ) + ), + }; + + # legacy - never remove these!!! + $cref_args->{foreign_relname} = $cref_args->{rel_name}; + + $cref_args->{self_rowobj} = $cref_args->{self_result_object} + if exists $cref_args->{self_result_object}; + + ($ret->{condition}, $ret->{join_free_condition}, my @extra) = $rel_info->{cond}->($cref_args); - my $cond_cols; - if ($joinfree_cond) { + # sanity check + $self->throw_exception("A custom condition coderef can return at most 2 conditions, but $exception_rel_id returned extra values: @extra") + if @extra; + + if (my $jfc = $ret->{join_free_condition}) { + + $self->throw_exception ( + "The join-free condition returned for $exception_rel_id must be a hash reference" + ) unless ref $jfc eq 'HASH'; + + my ($joinfree_alias, $joinfree_source); + if (defined $args->{self_result_object}) { + $joinfree_alias = $args->{foreign_alias}; + $joinfree_source = $rel_rsrc; + } + elsif (defined $args->{foreign_values}) { + $joinfree_alias = $args->{self_alias}; + $joinfree_source = $self; + } # FIXME sanity check until things stabilize, remove at some point $self->throw_exception ( - "A join-free condition returned for relationship '$rel_name' without a row-object to chain from" - ) unless $obj_rel; - - # FIXME another sanity check - if ( - ref $joinfree_cond ne 'HASH' - or - first { $_ !~ /^\Q$relalias.\E.+/ } keys %$joinfree_cond - ) { + "A join-free condition returned for $exception_rel_id without a result object to chain from" + ) unless $joinfree_alias; + + my $fq_col_list = { map + { ( "$joinfree_alias.$_" => 1 ) } + $joinfree_source->columns + }; + + exists $fq_col_list->{$_} or $self->throw_exception ( + "The join-free condition returned for $exception_rel_id may only " + . 'contain keys that are fully qualified column names of the corresponding source ' + . "'$joinfree_alias' (instead it returned '$_')" + ) for keys %$jfc; + + ( + length ref $_ + and + defined blessed($_) + and + $_->isa('DBIx::Class::Row') + and $self->throw_exception ( - "The join-free condition returned for relationship '$rel_name' must be a hash " - .'reference with all keys being valid columns on the related result source' - ); - } + "The join-free condition returned for $exception_rel_id may not " + . 'contain result objects as values - perhaps instead of invoking ' + . '->$something you meant to return ->get_column($something)' + ) + ) for values %$jfc; - # normalize - for (values %$joinfree_cond) { - $_ = $_->{'='} if ( - ref $_ eq 'HASH' - and - keys %$_ == 1 - and - exists $_->{'='} - ); - } + } + } + elsif (ref $rel_info->{cond} eq 'HASH') { - # see which parts of the joinfree cond are conditionals - my $relcol_list = { map { $_ => 1 } $self->related_source($rel_name)->columns }; + # the condition is static - use parallel arrays + # for a "pivot" depending on which side of the + # rel did we get as an object + my (@f_cols, @l_cols); + for my $fc (keys %{ $rel_info->{cond} }) { + my $lc = $rel_info->{cond}{$fc}; - for my $c (keys %$joinfree_cond) { - my ($colname) = $c =~ /^ (?: \Q$relalias.\E )? (.+)/x; + # FIXME STRICTMODE should probably check these are valid columns + $fc =~ s/^foreign\.// || + $self->throw_exception("Invalid rel cond key '$fc'"); - unless ($relcol_list->{$colname}) { - push @$cond_cols, $colname; - next; - } + $lc =~ s/^self\.// || + $self->throw_exception("Invalid rel cond val '$lc'"); - if ( - ref $joinfree_cond->{$c} - and - ref $joinfree_cond->{$c} ne 'SCALAR' - and - ref $joinfree_cond->{$c} ne 'REF' - ) { - push @$cond_cols, $colname; - next; + push @f_cols, $fc; + push @l_cols, $lc; + } + + # construct the crosstable condition and the identity map + for (0..$#f_cols) { + $ret->{condition}{"$args->{foreign_alias}.$f_cols[$_]"} = { -ident => "$args->{self_alias}.$l_cols[$_]" }; + $ret->{identity_map}{$l_cols[$_]} = $f_cols[$_]; + }; + + if ($args->{foreign_values}) { + $ret->{join_free_condition}{"$args->{self_alias}.$l_cols[$_]"} = $args->{foreign_values}{$f_cols[$_]} + for 0..$#f_cols; + } + elsif (defined $args->{self_result_object}) { + + for my $i (0..$#l_cols) { + if ( $args->{self_result_object}->has_column_loaded($l_cols[$i]) ) { + $ret->{join_free_condition}{"$args->{foreign_alias}.$f_cols[$i]"} = $args->{self_result_object}->get_column($l_cols[$i]); + } + else { + $self->throw_exception(sprintf + "Unable to resolve relationship '%s' from object '%s': column '%s' not " + . 'loaded from storage (or not passed to new() prior to insert()). You ' + . 'probably need to call ->discard_changes to get the server-side defaults ' + . 'from the database.', + $args->{rel_name}, + $args->{self_result_object}, + $l_cols[$i], + ) if $args->{self_result_object}->in_storage; + + # FIXME - temporarly force-override + delete $args->{require_join_free_condition}; + $ret->{join_free_condition} = UNRESOLVABLE_CONDITION; + last; } } - - return wantarray ? ($joinfree_cond, 0, $cond_cols) : $joinfree_cond; + } + } + elsif (ref $rel_info->{cond} eq 'ARRAY') { + if (@{ $rel_info->{cond} } == 0) { + $ret = { + condition => UNRESOLVABLE_CONDITION, + join_free_condition => UNRESOLVABLE_CONDITION, + }; } else { - return wantarray ? ($crosstable_cond, 1) : $crosstable_cond; + my @subconds = map { + local $rel_info->{cond} = $_; + $self->_resolve_relationship_condition( $args ); + } @{ $rel_info->{cond} }; + + if( @{ $rel_info->{cond} } == 1 ) { + $ret = $subconds[0]; + } + else { + # we are discarding inferred values here... likely incorrect... + # then again - the entire thing is an OR, so we *can't* use them anyway + for my $subcond ( @subconds ) { + $self->throw_exception('Either all or none of the OR-condition members must resolve to a join-free condition') + if ( $ret and ( $ret->{join_free_condition} xor $subcond->{join_free_condition} ) ); + + $subcond->{$_} and push @{$ret->{$_}}, $subcond->{$_} for (qw(condition join_free_condition)); + } + } } } - elsif (ref $cond eq 'HASH') { - my %ret; - foreach my $k (keys %{$cond}) { - my $v = $cond->{$k}; - # XXX should probably check these are valid columns - $k =~ s/^foreign\.// || - $self->throw_exception("Invalid rel cond key ${k}"); - $v =~ s/^self\.// || - $self->throw_exception("Invalid rel cond val ${v}"); - if (ref $for) { # Object - #warn "$self $k $for $v"; - unless ($for->has_column_loaded($v)) { - if ($for->in_storage) { - $self->throw_exception(sprintf - "Unable to resolve relationship '%s' from object %s: column '%s' not " - . 'loaded from storage (or not passed to new() prior to insert()). You ' - . 'probably need to call ->discard_changes to get the server-side defaults ' - . 'from the database.', - $as, - $for, - $v, - ); - } - return $UNRESOLVABLE_CONDITION; + else { + $self->throw_exception ("Can't handle condition $rel_info->{cond} for $exception_rel_id yet :("); + } + + if ( + $args->{require_join_free_condition} + and + ( ! $ret->{join_free_condition} or $ret->{join_free_condition} eq UNRESOLVABLE_CONDITION ) + ) { + $self->throw_exception( + ucfirst sprintf "$exception_rel_id does not resolve to a %sjoin-free condition fragment", + exists $args->{foreign_values} + ? "'foreign_values'-based reversed-" + : '' + ); + } + + # we got something back - sanity check and infer values if we can + my @nonvalues; + if ( + $ret->{join_free_condition} + and + $ret->{join_free_condition} ne UNRESOLVABLE_CONDITION + and + my $jfc = $storage->_collapse_cond( $ret->{join_free_condition} ) + ) { + + my $jfc_eqs = $storage->_extract_fixed_condition_columns($jfc, 'consider_nulls'); + + if (keys %$jfc_eqs) { + + for (keys %$jfc) { + # $jfc is fully qualified by definition + my ($col) = $_ =~ /\.(.+)/; + + if (exists $jfc_eqs->{$_} and ($jfc_eqs->{$_}||'') ne UNRESOLVABLE_CONDITION) { + $ret->{inferred_values}{$col} = $jfc_eqs->{$_}; + } + elsif ( !$args->{infer_values_based_on} or ! exists $args->{infer_values_based_on}{$col} ) { + push @nonvalues, $col; } - $ret{$k} = $for->get_column($v); - #$ret{$k} = $for->get_column($v) if $for->has_column_loaded($v); - #warn %ret; - } elsif (!defined $for) { # undef, i.e. "no object" - $ret{$k} = undef; - } elsif (ref $as eq 'HASH') { # reverse hashref - $ret{$v} = $as->{$k}; - } elsif (ref $as) { # reverse object - $ret{$v} = $as->get_column($k); - } elsif (!defined $as) { # undef, i.e. "no reverse object" - $ret{$v} = undef; - } else { - $ret{"${as}.${k}"} = { -ident => "${for}.${v}" }; } + + # all or nothing + delete $ret->{inferred_values} if @nonvalues; } + } - return wantarray - ? ( \%ret, ($obj_rel || !defined $as || ref $as) ? 0 : 1 ) - : \%ret - ; + # did the user explicitly ask + if ($args->{infer_values_based_on}) { + + $self->throw_exception(sprintf ( + "Unable to complete value inferrence - custom $exception_rel_id returns conditions instead of values for column(s): %s", + map { "'$_'" } @nonvalues + )) if @nonvalues; + + + $ret->{inferred_values} ||= {}; + + $ret->{inferred_values}{$_} = $args->{infer_values_based_on}{$_} + for keys %{$args->{infer_values_based_on}}; } - elsif (ref $cond eq 'ARRAY') { - my (@ret, $crosstable); - for (@$cond) { - my ($cond, $crosstab) = $self->_resolve_condition($_, $as, $for, $rel_name); - push @ret, $cond; - $crosstable ||= $crosstab; + + # add the identities based on the main condition + # (may already be there, since easy to calculate on the fly in the HASH case) + if ( ! $ret->{identity_map} ) { + + my $col_eqs = $storage->_extract_fixed_condition_columns($ret->{condition}); + + my $colinfos; + for my $lhs (keys %$col_eqs) { + + next if $col_eqs->{$lhs} eq UNRESOLVABLE_CONDITION; + + # there is no way to know who is right and who is left in a cref + # therefore a full blown resolution call, and figure out the + # direction a bit further below + $colinfos ||= $storage->_resolve_column_info([ + { -alias => $args->{self_alias}, -rsrc => $self }, + { -alias => $args->{foreign_alias}, -rsrc => $rel_rsrc }, + ]); + + next unless $colinfos->{$lhs}; # someone is engaging in witchcraft + + if ( my $rhs_ref = is_literal_value( $col_eqs->{$lhs} ) ) { + + if ( + $colinfos->{$rhs_ref->[0]} + and + $colinfos->{$lhs}{-source_alias} ne $colinfos->{$rhs_ref->[0]}{-source_alias} + ) { + ( $colinfos->{$lhs}{-source_alias} eq $args->{self_alias} ) + ? ( $ret->{identity_map}{$colinfos->{$lhs}{-colname}} = $colinfos->{$rhs_ref->[0]}{-colname} ) + : ( $ret->{identity_map}{$colinfos->{$rhs_ref->[0]}{-colname}} = $colinfos->{$lhs}{-colname} ) + ; + } + } + elsif ( + $col_eqs->{$lhs} =~ /^ ( \Q$args->{self_alias}\E \. .+ ) /x + and + ($colinfos->{$1}||{})->{-result_source} == $rel_rsrc + ) { + my ($lcol, $rcol) = map + { $colinfos->{$_}{-colname} } + ( $lhs, $1 ) + ; + carp_unique( + "The $exception_rel_id specifies equality of column '$lcol' and the " + . "*VALUE* '$rcol' (you did not use the { -ident => ... } operator)" + ); + } } - return wantarray ? (\@ret, $crosstable) : \@ret; - } - else { - $self->throw_exception ("Can't handle condition $cond for relationship '$rel_name' yet :("); } + + # FIXME - temporary, to fool the idiotic check in SQLMaker::_join_condition + $ret->{condition} = { -and => [ $ret->{condition} ] } + unless $ret->{condition} eq UNRESOLVABLE_CONDITION; + + $ret; } =head2 related_source @@ -1902,6 +2395,9 @@ sub handle { my $global_phase_destroy; sub DESTROY { + ### NO detected_reinvoked_destructor check + ### This code very much relies on being called multuple times + return if $global_phase_destroy ||= in_global_destruction; ###### @@ -1969,25 +2465,6 @@ sub throw_exception { ; } -=head2 source_info - -Stores a hashref of per-source metadata. No specific key names -have yet been standardized, the examples below are purely hypothetical -and don't actually accomplish anything on their own: - - __PACKAGE__->source_info({ - "_tablespace" => 'fast_disk_array_3', - "_engine" => 'InnoDB', - }); - -=head2 new - - $class->new(); - - $class->new({attribute_name => value}); - -Creates a new ResultSource object. Not normally called directly by end users. - =head2 column_info_from_storage =over @@ -2004,14 +2481,16 @@ Enables the on-demand automatic loading of the above column metadata from storage as necessary. This is *deprecated*, and should not be used. It will be removed before 1.0. +=head1 FURTHER QUESTIONS? -=head1 AUTHOR AND CONTRIBUTORS - -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut diff --git a/lib/DBIx/Class/ResultSource/RowParser.pm b/lib/DBIx/Class/ResultSource/RowParser.pm index 1c84b3ce6..83be406fc 100644 --- a/lib/DBIx/Class/ResultSource/RowParser.pm +++ b/lib/DBIx/Class/ResultSource/RowParser.pm @@ -14,32 +14,32 @@ use DBIx::Class::ResultSource::RowParser::Util qw( assemble_collapsing_parser ); +use DBIx::Class::Carp; + use namespace::clean; -# Accepts one or more relationships for the current source and returns an -# array of column names for each of those relationships. Column names are -# prefixed relative to the current source, in accordance with where they appear -# in the supplied relationships. -sub _resolve_prefetch { - my ($self, $pre, $alias, $alias_map, $order, $pref_path) = @_; +# Accepts a prefetch map (one or more relationships for the current source), +# returns a set of select/as pairs for each of those relationships. Columns +# are fully qualified inflation_slot names +sub _resolve_selection_from_prefetch { + my ($self, $pre, $alias_map, $pref_path) = @_; + + # internal recursion marker $pref_path ||= []; if (not defined $pre or not length $pre) { return (); } elsif( ref $pre eq 'ARRAY' ) { - return - map { $self->_resolve_prefetch( $_, $alias, $alias_map, $order, [ @$pref_path ] ) } - @$pre; + map { $self->_resolve_selection_from_prefetch( $_, $alias_map, [ @$pref_path ] ) } + @$pre; } elsif( ref $pre eq 'HASH' ) { - my @ret = map { - $self->_resolve_prefetch($_, $alias, $alias_map, $order, [ @$pref_path ] ), - $self->related_source($_)->_resolve_prefetch( - $pre->{$_}, "${alias}.$_", $alias_map, $order, [ @$pref_path, $_] ) + $self->_resolve_selection_from_prefetch($_, $alias_map, [ @$pref_path ] ), + $self->related_source($_)->_resolve_selection_from_prefetch( + $pre->{$_}, $alias_map, [ @$pref_path, $_] ) } keys %$pre; - return @ret; } elsif( ref $pre ) { $self->throw_exception( @@ -47,26 +47,40 @@ sub _resolve_prefetch { } else { my $p = $alias_map; - $p = $p->{$_} for (@$pref_path, $pre); + $p = $p->{$_} for @$pref_path, $pre; $self->throw_exception ( "Unable to resolve prefetch '$pre' - join alias map does not contain an entry for path: " . join (' -> ', @$pref_path, $pre) ) if (ref $p->{-join_aliases} ne 'ARRAY' or not @{$p->{-join_aliases}} ); - my $as = shift @{$p->{-join_aliases}}; - - my $rel_info = $self->relationship_info( $pre ); - $self->throw_exception( $self->source_name . " has no such relationship '$pre'" ) - unless $rel_info; + # this shift() is critical - it is what allows prefetch => [ (foo) x 2 ] to work + my $src_alias = shift @{$p->{-join_aliases}}; + + # ordered [select => as] pairs + map { [ + "${src_alias}.$_" => join ( '.', + @$pref_path, + $pre, + $_, + ) + ] } $self->related_source($pre)->columns; + } +} - my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : ''); +sub _resolve_prefetch { + carp_unique( + 'There is no good reason to call this internal deprecated method - ' + . 'please open a ticket detailing your usage, so that a better plan can ' + . 'be devised for your case. In either case _resolve_prefetch() is ' + . 'deprecated in favor of _resolve_selection_from_prefetch(), which has ' + . 'a greatly simplified arglist.' + ); - return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] } - $self->related_source($pre)->columns; - } + $_[0]->_resolve_selection_from_prefetch( $_[1], $_[3] ); } + # Takes an arrayref of {as} dbic column aliases and the collapse and select # attributes from the same $rs (the selector requirement is a temporary # workaround... I hope), and returns a coderef capable of: @@ -136,6 +150,9 @@ sub _mk_row_parser { }); }; + utf8::upgrade($src) + if DBIx::Class::_ENV_::STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE; + return ( $args->{eval} ? ( eval "sub $src" || die $@ ) : $src, $check_null_columns, @@ -180,26 +197,12 @@ sub _resolve_collapse { is_single => ( $inf->{attrs}{accessor} && $inf->{attrs}{accessor} ne 'multi' ), is_inner => ( ( $inf->{attrs}{join_type} || '' ) !~ /^left/i), rsrc => $self->related_source($rel), + fk_map => $self->_resolve_relationship_condition( + rel_name => $rel, + self_alias => "\xFE", # irrelevant + foreign_alias => "\xFF", # irrelevant + )->{identity_map}, }; - - # FIME - need to use _resolve_cond here instead - my $cond = $inf->{cond}; - - if ( - ref $cond eq 'HASH' - and - keys %$cond - and - ! defined first { $_ !~ /^foreign\./ } (keys %$cond) - and - ! defined first { $_ !~ /^self\./ } (values %$cond) - ) { - for my $f (keys %$cond) { - my $s = $cond->{$f}; - $_ =~ s/^ (?: foreign | self ) \.//x for ($f, $s); - $relinfo->{$rel}{fk_map}{$s} = $f; - } - } } # inject non-left fk-bridges from *INNER-JOINED* children (if any) diff --git a/lib/DBIx/Class/ResultSource/RowParser/Util.pm b/lib/DBIx/Class/ResultSource/RowParser/Util.pm index d1c1e3b71..a20d07cb9 100644 --- a/lib/DBIx/Class/ResultSource/RowParser/Util.pm +++ b/lib/DBIx/Class/ResultSource/RowParser/Util.pm @@ -5,9 +5,9 @@ use strict; use warnings; use List::Util 'first'; -use B 'perlstring'; +use DBIx::Class::_Util 'perlstring'; -use constant HAS_DOR => ( $] < 5.010 ? 0 : 1 ); +use constant HAS_DOR => ( "$]" < 5.010 ? 0 : 1 ); use base 'Exporter'; our @EXPORT_OK = qw( @@ -18,6 +18,10 @@ our @EXPORT_OK = qw( # working title - we are hoping to extract this eventually... our $null_branch_class = 'DBIx::ResultParser::RelatedNullBranch'; +sub __wrap_in_strictured_scope { + " { use strict; use warnings; use warnings FATAL => 'uninitialized';\n$_[0]\n }" +} + sub assemble_simple_parser { #my ($args) = @_; @@ -30,12 +34,11 @@ sub assemble_simple_parser { # the data structure, then to fetch the data do: # push @rows, dclone($row_data_struct) while ($sth->fetchrow); # - my $parser_src = sprintf('$_ = %s for @{$_[0]}', __visit_infmap_simple($_[0]) ); - # change the quoted placeholders to unquoted alias-references - $parser_src =~ s/ \' \xFF__VALPOS__(\d+)__\xFF \' /"\$_->[$1]"/gex; - - $parser_src = " { use strict; use warnings FATAL => 'all';\n$parser_src\n }"; + __wrap_in_strictured_scope( sprintf + '$_ = %s for @{$_[0]}', + __visit_infmap_simple( $_[0] ) + ); } # the simple non-collapsing nested structure recursor @@ -63,7 +66,7 @@ sub __visit_infmap_simple { if (keys %$my_cols) { my $branch_null_checks = join ' && ', map - { "( ! defined '\xFF__VALPOS__${_}__\xFF' )" } + { "( ! defined \$_->[$_] )" } sort { $a <=> $b } values %{$rel_cols->{$rel}} ; @@ -110,30 +113,27 @@ sub __visit_infmap_simple { sub assemble_collapsing_parser { my $args = shift; - # it may get unset further down - my $no_rowid_container = $args->{prune_null_branches}; - - my ($top_node_key, $top_node_key_assembler); + my ($top_node_key, $top_node_key_assembler, $variant_idcols); if (scalar @{$args->{collapse_map}{-identifying_columns}}) { $top_node_key = join ('', map - { "{'\xFF__IDVALPOS__${_}__\xFF'}" } + { "{ \$cur_row_ids{$_} }" } @{$args->{collapse_map}{-identifying_columns}} ); } elsif( my @variants = @{$args->{collapse_map}{-identifying_columns_variants}} ) { my @path_parts = map { sprintf - "( ( defined '\xFF__VALPOS__%d__\xFF' ) && (join qq(\xFF), '', %s, '') )", + "( ( defined \$cur_row_data->[%d] ) && (join qq(\xFF), '', %s, '') )", $_->[0], # checking just first is enough - one ID defined, all defined - ( join ', ', map { "'\xFF__VALPOS__${_}__\xFF'" } @$_ ), + ( join ', ', map { ++$variant_idcols->{$_} and " \$cur_row_ids{$_} " } @$_ ), } @variants; my $virtual_column_idx = (scalar keys %{$args->{val_index}} ) + 1; - $top_node_key = "{'\xFF__IDVALPOS__${virtual_column_idx}__\xFF'}"; + $top_node_key = "{ \$cur_row_ids{$virtual_column_idx} }"; - $top_node_key_assembler = sprintf "'\xFF__IDVALPOS__%d__\xFF' = (%s);", + $top_node_key_assembler = sprintf "( \$cur_row_ids{%d} = (%s) ),", $virtual_column_idx, "\n" . join( "\n or\n", @path_parts, qq{"\0\$rows_pos\0"} ) ; @@ -142,8 +142,6 @@ sub assemble_collapsing_parser { %{$args->{collapse_map}}, -custom_node_key => $top_node_key, }; - - $no_rowid_container = 0; } else { die('Unexpected collapse map contents'); @@ -151,20 +149,30 @@ sub assemble_collapsing_parser { my ($data_assemblers, $stats) = __visit_infmap_collapse ($args); - my @idcol_args = $no_rowid_container ? ('', '') : ( - ', %cur_row_ids', # only declare the variable if we'll use it - join ("\n", map { qq(\$cur_row_ids{$_} = ) . ( - # in case we prune - we will never hit these undefs - $args->{prune_null_branches} ? qq(\$cur_row_data->[$_];) - : HAS_DOR ? qq(\$cur_row_data->[$_] // "\0NULL\xFF\$rows_pos\xFF$_\0";) - : qq(defined(\$cur_row_data->[$_]) ? \$cur_row_data->[$_] : "\0NULL\xFF\$rows_pos\xFF$_\0";) - ) } sort { $a <=> $b } keys %{ $stats->{idcols_seen} } ), - ); - - my $parser_src = sprintf (<<'EOS', @idcol_args, $top_node_key_assembler||'', $top_node_key, join( "\n", @{$data_assemblers||[]} ) ); + # variants do not necessarily overlap with true idcols + my @row_ids = sort { $a <=> $b } keys %{ { + %{ $variant_idcols || {} }, + %{ $stats->{idcols_seen} }, + } }; + + my $row_id_defs = sprintf "( \@cur_row_ids{( %s )} = (\n%s\n ) ),", + join (', ', @row_ids ), + # in case we prune - we will never hit undefs/NULLs as pigeon-hole-criteria + ( $args->{prune_null_branches} + ? sprintf( '@{$cur_row_data}[( %s )]', join ', ', @row_ids ) + : join (",\n", map { + my $quoted_null_val = qq("\0NULL\xFF\${rows_pos}\xFF${_}\0"); + HAS_DOR + ? qq!( \$cur_row_data->[$_] // $quoted_null_val )! + : qq!( defined(\$cur_row_data->[$_]) ? \$cur_row_data->[$_] : $quoted_null_val )! + } @row_ids) + ) + ; + + my $parser_src = sprintf (<<'EOS', $row_id_defs, $top_node_key_assembler||'', $top_node_key, join( "\n", @{$data_assemblers||[]} ) ); ### BEGIN LITERAL STRING EVAL my $rows_pos = 0; - my ($result_pos, @collapse_idx, $cur_row_data %1$s); + my ($result_pos, @collapse_idx, $cur_row_data, %%cur_row_ids ); # this loop is a bit arcane - the rationale is that the passed in # $_[0] will either have only one row (->next) or will have all @@ -173,32 +181,47 @@ sub assemble_collapsing_parser { # array, since the collapsed prefetch is smaller by definition. # At the end we cut the leftovers away and move on. while ($cur_row_data = ( - ( $rows_pos >= 0 and $_[0][$rows_pos++] ) + ( + $rows_pos >= 0 + and + ( + $_[0][$rows_pos++] + or + # It may be tempting to drop the -1 and undef $rows_pos instead + # thus saving the >= comparison above as well + # However NULL-handlers and underdefined root markers both use + # $rows_pos as a last-resort-uniqueness marker (it either is + # monotonically increasing while we parse ->all, or is set at + # a steady -1 when we are dealing with a single root node). For + # the time being the complication of changing all callsites seems + # overkill, for what is going to be a very modest saving of ops + ( ($rows_pos = -1), undef ) + ) + ) or - ( $_[1] and $rows_pos = -1 and $_[1]->() ) + ( $_[1] and $_[1]->() ) ) ) { - # this code exists only when we are using a cur_row_ids - # furthermore the undef checks may or may not be there + # the undef checks may or may not be there # depending on whether we prune or not # # due to left joins some of the ids may be NULL/undef, and # won't play well when used as hash lookups # we also need to differentiate NULLs on per-row/per-col basis # (otherwise folding of optional 1:1s will be greatly confused -%2$s +%1$s # in the case of an underdefined root - calculate the virtual id (otherwise no code at all) -%3$s +%2$s # if we were supplied a coderef - we are collapsing lazily (the set # is ordered properly) # as long as we have a result already and the next result is new we # return the pre-read data and bail -$_[1] and $result_pos and ! $collapse_idx[0]%4$s and (unshift @{$_[2]}, $cur_row_data) and last; +( $_[1] and $result_pos and ! $collapse_idx[0]%3$s and (unshift @{$_[2]}, $cur_row_data) and last ), # the rel assemblers -%5$s +%4$s } @@ -206,16 +229,7 @@ $_[1] and $result_pos and ! $collapse_idx[0]%4$s and (unshift @{$_[2]}, $cur_row ### END LITERAL STRING EVAL EOS - # !!! note - different var than the one above - # change the quoted placeholders to unquoted alias-references - $parser_src =~ s/ \' \xFF__VALPOS__(\d+)__\xFF \' /"\$cur_row_data->[$1]"/gex; - $parser_src =~ s/ - \' \xFF__IDVALPOS__(\d+)__\xFF \' - / - $no_rowid_container ? "\$cur_row_data->[$1]" : "\$cur_row_ids{$1}" - /gex; - - $parser_src = " { use strict; use warnings FATAL => 'all';\n$parser_src\n }"; + __wrap_in_strictured_scope($parser_src); } @@ -241,14 +255,14 @@ sub __visit_infmap_collapse { } my $me_struct; - $me_struct = __result_struct_to_source($my_cols) if keys %$my_cols; + $me_struct = __result_struct_to_source($my_cols, 1) if keys %$my_cols; $me_struct = sprintf( '[ %s ]', $me_struct||'' ) unless $args->{hri_style}; my $node_key = $args->{collapse_map}->{-custom_node_key} || join ('', map - { "{'\xFF__IDVALPOS__${_}__\xFF'}" } + { "{ \$cur_row_ids{$_} }" } @{$args->{collapse_map}->{-identifying_columns}} ); my $node_idx_slot = sprintf '$collapse_idx[%d]%s', $cur_node_idx, $node_key; @@ -257,7 +271,7 @@ sub __visit_infmap_collapse { my @src; if ($cur_node_idx == 0) { - push @src, sprintf( '%s %s $_[0][$result_pos++] = %s;', + push @src, sprintf( '( %s %s $_[0][$result_pos++] = %s ),', $node_idx_slot, (HAS_DOR ? '//=' : '||='), $me_struct || '{}', @@ -267,11 +281,11 @@ sub __visit_infmap_collapse { my $parent_attach_slot = sprintf( '$collapse_idx[%d]%s%s{%s}', @{$args}{qw/-parent_node_idx -parent_node_key/}, $args->{hri_style} ? '' : '[1]', - perlstring($args->{-node_relname}), + perlstring($args->{-node_rel_name}), ); if ($args->{collapse_map}->{-is_single}) { - push @src, sprintf ( '%s %s %s%s;', + push @src, sprintf ( '( %s %s %s%s ),', $parent_attach_slot, (HAS_DOR ? '//=' : '||='), $node_idx_slot, @@ -279,7 +293,7 @@ sub __visit_infmap_collapse { ); } else { - push @src, sprintf('(! %s) and push @{%s}, %s%s;', + push @src, sprintf('( (! %s) and push @{%s}, %s%s ),', $node_idx_slot, $parent_attach_slot, $node_idx_slot, @@ -300,7 +314,7 @@ sub __visit_infmap_collapse { collapse_map => $relinfo, -parent_node_idx => $cur_node_idx, -parent_node_key => $node_key, - -node_relname => $rel, + -node_rel_name => $rel, }); my $rel_src_pos = $#src + 1; @@ -318,8 +332,8 @@ sub __visit_infmap_collapse { if ($args->{prune_null_branches}) { # start of wrap of the entire chain in a conditional - splice @src, $rel_src_pos, 0, sprintf "( ! defined %s )\n ? %s%s{%s} = %s\n : do {", - "'\xFF__VALPOS__${first_distinct_child_idcol}__\xFF'", + splice @src, $rel_src_pos, 0, sprintf "( ( ! defined %s )\n ? %s%s{%s} = %s\n : do {", + "\$cur_row_data->[$first_distinct_child_idcol]", $node_idx_slot, $args->{hri_style} ? '' : '[1]', perlstring($rel), @@ -327,12 +341,12 @@ sub __visit_infmap_collapse { ; # end of wrap - push @src, '};' + push @src, '} ),' } else { - splice @src, $rel_src_pos + 1, 0, sprintf ( '(defined %s) or bless (%s[1]{%s}, %s);', - "'\xFF__VALPOS__${first_distinct_child_idcol}__\xFF'", + splice @src, $rel_src_pos + 1, 0, sprintf ( '( (defined %s) or bless (%s[1]{%s}, %s) ),', + "\$cur_row_data->[$first_distinct_child_idcol]", $node_idx_slot, perlstring($rel), perlstring($null_branch_class), @@ -353,10 +367,19 @@ sub __visit_infmap_collapse { } sub __result_struct_to_source { - sprintf( '{ %s }', join (', ', map - { sprintf "%s => '\xFF__VALPOS__%d__\xFF'", perlstring($_), $_[0]{$_} } - sort keys %{$_[0]} - )); + my ($data, $is_collapsing) = @_; + + sprintf( '{ %s }', + join (', ', map { + sprintf ( "%s => %s", + perlstring($_), + $is_collapsing + ? "\$cur_row_data->[$data->{$_}]" + : "\$_->[ $data->{$_} ]" + ) + } sort keys %{$data} + ) + ); } 1; diff --git a/lib/DBIx/Class/ResultSource/Table.pm b/lib/DBIx/Class/ResultSource/Table.pm index 7c8dbe705..ac7d30886 100644 --- a/lib/DBIx/Class/ResultSource/Table.pm +++ b/lib/DBIx/Class/ResultSource/Table.pm @@ -28,15 +28,17 @@ Returns the FROM entry for the table (i.e. the table name) sub from { shift->name; } -1; - -=head1 AUTHOR AND CONTRIBUTORS +=head1 FURTHER QUESTIONS? -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut +1; diff --git a/lib/DBIx/Class/ResultSource/View.pm b/lib/DBIx/Class/ResultSource/View.pm index 232cc2f5d..4694c8787 100644 --- a/lib/DBIx/Class/ResultSource/View.pm +++ b/lib/DBIx/Class/ResultSource/View.pm @@ -66,12 +66,12 @@ case replaces the view name in a FROM clause in a subselect. Having created the MyApp::Schema::Year2000CDs schema as shown in the SYNOPSIS above, you can then: - $2000_cds = $schema->resultset('Year2000CDs') - ->search() - ->all(); - $count = $schema->resultset('Year2000CDs') - ->search() - ->count(); + $y2000_cds = $schema->resultset('Year2000CDs') + ->search() + ->all(); + $count = $schema->resultset('Year2000CDs') + ->search() + ->count(); If you modified the schema to include a placeholder @@ -85,12 +85,12 @@ and ensuring you have is_virtual set to true: You could now say: - $2001_cds = $schema->resultset('Year2000CDs') - ->search({}, { bind => [2001] }) - ->all(); - $count = $schema->resultset('Year2000CDs') - ->search({}, { bind => [2001] }) - ->count(); + $y2001_cds = $schema->resultset('Year2000CDs') + ->search({}, { bind => [2001] }) + ->all(); + $count = $schema->resultset('Year2000CDs') + ->search({}, { bind => [2001] }) + ->count(); =head1 SQL EXAMPLES @@ -171,15 +171,17 @@ sub new { return $new; } -1; - -=head1 AUTHORS +=head1 FURTHER QUESTIONS? -See L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut +1; diff --git a/lib/DBIx/Class/ResultSourceHandle.pm b/lib/DBIx/Class/ResultSourceHandle.pm index 733db837d..05be07d14 100644 --- a/lib/DBIx/Class/ResultSourceHandle.pm +++ b/lib/DBIx/Class/ResultSourceHandle.pm @@ -68,7 +68,7 @@ sub resolve { # vague error message as this is never supposed to happen "Unable to resolve moniker '%s' - please contact the dev team at %s", $_[0]->source_moniker, - 'http://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class.pm#GETTING_HELP/SUPPORT', + DBIx::Class::_ENV_::HELP_URL, ), 'full_stacktrace'); } @@ -128,9 +128,16 @@ sub STORABLE_thaw { } } -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -Ash Berlin C<< >> +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut diff --git a/lib/DBIx/Class/ResultSourceProxy.pm b/lib/DBIx/Class/ResultSourceProxy.pm index c3bef1511..1e1f307d3 100644 --- a/lib/DBIx/Class/ResultSourceProxy.pm +++ b/lib/DBIx/Class/ResultSourceProxy.pm @@ -4,9 +4,10 @@ package # hide from PAUSE use strict; use warnings; -use base qw/DBIx::Class/; -use Scalar::Util qw/blessed/; -use Sub::Name qw/subname/; +use base 'DBIx::Class'; + +use Scalar::Util 'blessed'; +use DBIx::Class::_Util 'quote_sub'; use namespace::clean; __PACKAGE__->mk_group_accessors('inherited_ro_instance' => 'source_name'); @@ -80,10 +81,11 @@ for my $method_to_proxy (qw/ relationship_info has_relationship /) { - no strict qw/refs/; - *{__PACKAGE__."::$method_to_proxy"} = subname $method_to_proxy => sub { - shift->result_source_instance->$method_to_proxy (@_); - }; + quote_sub __PACKAGE__."::$method_to_proxy", sprintf( <<'EOC', $method_to_proxy ); + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; + shift->result_source_instance->%s (@_); +EOC + } 1; diff --git a/lib/DBIx/Class/ResultSourceProxy/Table.pm b/lib/DBIx/Class/ResultSourceProxy/Table.pm index fe72d4d9b..647a4089c 100644 --- a/lib/DBIx/Class/ResultSourceProxy/Table.pm +++ b/lib/DBIx/Class/ResultSourceProxy/Table.pm @@ -110,16 +110,12 @@ sub table { Gets or sets the table class used for construction and validation. -=cut - =head2 has_column if ($obj->has_column($col)) { ... } Returns 1 if the class has a column of this name, 0 otherwise. -=cut - =head2 column_info my $info = $obj->column_info($col); @@ -128,23 +124,23 @@ Returns the column metadata hashref for a column. For a description of the various types of column data in this hashref, see L -=cut - =head2 columns my @column_names = $obj->columns; -=cut +=head1 FURTHER QUESTIONS? -1; +Check the list of L. -=head1 AUTHOR AND CONTRIBUTORS +=head1 COPYRIGHT AND LICENSE -See L and L in DBIx::Class +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. -=head1 LICENSE +=cut -You may distribute this code under the same terms as Perl itself. +1; -=cut diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index 000498ae6..5425fd80c 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -9,6 +9,7 @@ use Scalar::Util 'blessed'; use List::Util 'first'; use Try::Tiny; use DBIx::Class::Carp; +use SQL::Abstract qw( is_literal_value is_plain_value ); ### ### Internal method @@ -51,7 +52,7 @@ All "Row objects" derived from a Schema-attached L object (such as a typical C<< L-> L >> call) are actually Result instances, based on your application's -L. +L. L implements most of the row-based communication with the underlying storage, but a Result class B. @@ -125,26 +126,26 @@ with NULL as the default, and save yourself a SELECT. ## tests! sub __new_related_find_or_new_helper { - my ($self, $relname, $values) = @_; + my ($self, $rel_name, $values) = @_; my $rsrc = $self->result_source; # create a mock-object so all new/set_column component overrides will run: - my $rel_rs = $rsrc->related_source($relname)->resultset; + my $rel_rs = $rsrc->related_source($rel_name)->resultset; my $new_rel_obj = $rel_rs->new_result($values); my $proc_data = { $new_rel_obj->get_columns }; - if ($self->__their_pk_needs_us($relname)) { - MULTICREATE_DEBUG and print STDERR "MC $self constructing $relname via new_result\n"; + if ($self->__their_pk_needs_us($rel_name)) { + MULTICREATE_DEBUG and print STDERR "MC $self constructing $rel_name via new_result\n"; return $new_rel_obj; } - elsif ($rsrc->_pk_depends_on($relname, $proc_data )) { + elsif ($rsrc->_pk_depends_on($rel_name, $proc_data )) { if (! keys %$proc_data) { # there is nothing to search for - blind create - MULTICREATE_DEBUG and print STDERR "MC $self constructing default-insert $relname\n"; + MULTICREATE_DEBUG and print STDERR "MC $self constructing default-insert $rel_name\n"; } else { - MULTICREATE_DEBUG and print STDERR "MC $self constructing $relname via find_or_new\n"; + MULTICREATE_DEBUG and print STDERR "MC $self constructing $rel_name via find_or_new\n"; # this is not *really* find or new, as we don't want to double-new the # data (thus potentially double encoding or whatever) my $exists = $rel_rs->find ($proc_data); @@ -155,17 +156,17 @@ sub __new_related_find_or_new_helper { else { my $us = $rsrc->source_name; $self->throw_exception ( - "Unable to determine relationship '$relname' direction from '$us', " - . "possibly due to a missing reverse-relationship on '$relname' to '$us'." + "Unable to determine relationship '$rel_name' direction from '$us', " + . "possibly due to a missing reverse-relationship on '$rel_name' to '$us'." ); } } sub __their_pk_needs_us { # this should maybe be in resultsource. - my ($self, $relname) = @_; + my ($self, $rel_name) = @_; my $rsrc = $self->result_source; - my $reverse = $rsrc->reverse_relationship_info($relname); - my $rel_source = $rsrc->related_source($relname); + my $reverse = $rsrc->reverse_relationship_info($rel_name); + my $rel_source = $rsrc->related_source($rel_name); my $us = { $self->get_columns }; foreach my $key (keys %$reverse) { # if their primary key depends on us, then we have to @@ -199,7 +200,7 @@ sub new { my ($related,$inflated); foreach my $key (keys %$attrs) { - if (ref $attrs->{$key}) { + if (ref $attrs->{$key} and ! is_literal_value($attrs->{$key}) ) { ## Can we extract this lot to use with update(_or .. ) ? $new->throw_exception("Can't do multi-create without result source") unless $rsrc; @@ -256,14 +257,16 @@ sub new { } $inflated->{$key} = $rel_obj; next; - } elsif ($class->has_column($key) - && $class->column_info($key)->{_inflate_info}) { + } + elsif ( + $rsrc->has_column($key) + and + $rsrc->column_info($key)->{_inflate_info} + ) { $inflated->{$key} = $attrs->{$key}; next; } } - $new->throw_exception("No such column '$key' on $class") - unless $class->has_column($key); $new->store_column($key => $attrs->{$key}); } @@ -351,27 +354,27 @@ sub insert { # insert what needs to be inserted before us my %pre_insert; - for my $relname (keys %related_stuff) { - my $rel_obj = $related_stuff{$relname}; + for my $rel_name (keys %related_stuff) { + my $rel_obj = $related_stuff{$rel_name}; - if (! $self->{_rel_in_storage}{$relname}) { + if (! $self->{_rel_in_storage}{$rel_name}) { next unless (blessed $rel_obj && $rel_obj->isa('DBIx::Class::Row')); next unless $rsrc->_pk_depends_on( - $relname, { $rel_obj->get_columns } + $rel_name, { $rel_obj->get_columns } ); # The guard will save us if we blow out of this scope via die $rollback_guard ||= $storage->txn_scope_guard; - MULTICREATE_DEBUG and print STDERR "MC $self pre-reconstructing $relname $rel_obj\n"; + MULTICREATE_DEBUG and print STDERR "MC $self pre-reconstructing $rel_name $rel_obj\n"; my $them = { %{$rel_obj->{_relationship_data} || {} }, $rel_obj->get_columns }; my $existing; # if there are no keys - nothing to search for if (keys %$them and $existing = $self->result_source - ->related_source($relname) + ->related_source($rel_name) ->resultset ->find($them) ) { @@ -381,11 +384,11 @@ sub insert { $rel_obj->insert; } - $self->{_rel_in_storage}{$relname} = 1; + $self->{_rel_in_storage}{$rel_name} = 1; } - $self->set_from_related($relname, $rel_obj); - delete $related_stuff{$relname}; + $self->set_from_related($rel_name, $rel_obj); + delete $related_stuff{$rel_name}; } # start a transaction here if not started yet and there is more stuff @@ -426,25 +429,25 @@ sub insert { $self->{_dirty_columns} = {}; $self->{related_resultsets} = {}; - foreach my $relname (keys %related_stuff) { - next unless $rsrc->has_relationship ($relname); + foreach my $rel_name (keys %related_stuff) { + next unless $rsrc->has_relationship ($rel_name); - my @cands = ref $related_stuff{$relname} eq 'ARRAY' - ? @{$related_stuff{$relname}} - : $related_stuff{$relname} + my @cands = ref $related_stuff{$rel_name} eq 'ARRAY' + ? @{$related_stuff{$rel_name}} + : $related_stuff{$rel_name} ; if (@cands && blessed $cands[0] && $cands[0]->isa('DBIx::Class::Row') ) { - my $reverse = $rsrc->reverse_relationship_info($relname); + my $reverse = $rsrc->reverse_relationship_info($rel_name); foreach my $obj (@cands) { $obj->set_from_related($_, $self) for keys %$reverse; - if ($self->__their_pk_needs_us($relname)) { - if (exists $self->{_ignore_at_insert}{$relname}) { - MULTICREATE_DEBUG and print STDERR "MC $self skipping post-insert on $relname\n"; + if ($self->__their_pk_needs_us($rel_name)) { + if (exists $self->{_ignore_at_insert}{$rel_name}) { + MULTICREATE_DEBUG and print STDERR "MC $self skipping post-insert on $rel_name\n"; } else { - MULTICREATE_DEBUG and print STDERR "MC $self inserting $relname $obj\n"; + MULTICREATE_DEBUG and print STDERR "MC $self inserting $rel_name $obj\n"; $obj->insert; } } else { @@ -477,8 +480,8 @@ sub insert { Indicates whether the object exists as a row in the database or not. This is set to true when L, -L or L -are used. +L or L +are invoked. Creating a result object using L, or calling L on one, sets it to false. @@ -661,12 +664,20 @@ To retrieve all loaded column values as a hash, use L. sub get_column { my ($self, $column) = @_; $self->throw_exception( "Can't fetch data as class method" ) unless ref $self; - return $self->{_column_data}{$column} if exists $self->{_column_data}{$column}; + + return $self->{_column_data}{$column} + if exists $self->{_column_data}{$column}; + if (exists $self->{_inflated_column}{$column}) { - return $self->store_column($column, - $self->_deflated_column($column, $self->{_inflated_column}{$column})); + # deflate+return cycle + return $self->store_column($column, $self->_deflated_column( + $column, $self->{_inflated_column}{$column} + )); } - $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column); + + $self->throw_exception( "No such column '${column}' on " . ref $self ) + unless $self->result_source->has_column($column); + return undef; } @@ -692,8 +703,12 @@ database (or set locally). sub has_column_loaded { my ($self, $column) = @_; $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self; - return 1 if exists $self->{_inflated_column}{$column}; - return exists $self->{_column_data}{$column}; + + return ( + exists $self->{_inflated_column}{$column} + or + exists $self->{_column_data}{$column} + ) ? 1 : 0; } =head2 get_columns @@ -718,6 +733,7 @@ See L to get the inflated values. sub get_columns { my $self = shift; if (exists $self->{_inflated_column}) { + # deflate cycle for each inflation, including filter rels foreach my $col (keys %{$self->{_inflated_column}}) { unless (exists $self->{_column_data}{$col}) { @@ -787,8 +803,8 @@ really changed. sub make_column_dirty { my ($self, $column) = @_; - $self->throw_exception( "No such column '${column}'" ) - unless exists $self->{_column_data}{$column} || $self->has_column($column); + $self->throw_exception( "No such column '${column}' on " . ref $self ) + unless exists $self->{_column_data}{$column} || $self->result_source->has_column($column); # the entire clean/dirty code relies on exists, not on true/false return 1 if exists $self->{_dirty_columns}{$column}; @@ -830,9 +846,9 @@ See L for how to setup inflation. sub get_inflated_columns { my $self = shift; - my $loaded_colinfo = $self->columns_info ([ - grep { $self->has_column_loaded($_) } $self->columns - ]); + my $loaded_colinfo = $self->result_source->columns_info; + $self->has_column_loaded($_) or delete $loaded_colinfo->{$_} + for keys %$loaded_colinfo; my %cols_to_return = ( %{$self->{_column_data}}, %$loaded_colinfo ); @@ -874,8 +890,11 @@ sub get_inflated_columns { } sub _is_column_numeric { - my ($self, $column) = @_; - my $colinfo = $self->column_info ($column); + my ($self, $column) = @_; + + return undef unless $self->result_source->has_column($column); + + my $colinfo = $self->result_source->column_info ($column); # cache for speed (the object may *not* have a resultsource instance) if ( @@ -919,17 +938,17 @@ sub set_column { my ($self, $column, $new_value) = @_; my $had_value = $self->has_column_loaded($column); - my ($old_value, $in_storage) = ($self->get_column($column), $self->in_storage) - if $had_value; + my $old_value = $self->get_column($column); $new_value = $self->store_column($column, $new_value); my $dirty = $self->{_dirty_columns}{$column} || - $in_storage # no point tracking dirtyness on uninserted data + ( $self->in_storage # no point tracking dirtyness on uninserted data ? ! $self->_eq_column_values ($column, $old_value, $new_value) : 1 + ) ; if ($dirty) { @@ -940,20 +959,20 @@ sub set_column { # # FIXME - this is a quick *largely incorrect* hack, pending a more # serious rework during the merge of single and filter rels - my $relnames = $self->result_source->{_relationships}; - for my $relname (keys %$relnames) { + my $rel_names = $self->result_source->{_relationships}; + for my $rel_name (keys %$rel_names) { - my $acc = $relnames->{$relname}{attrs}{accessor} || ''; + my $acc = $rel_names->{$rel_name}{attrs}{accessor} || ''; - if ( $acc eq 'single' and $relnames->{$relname}{attrs}{fk_columns}{$column} ) { - delete $self->{related_resultsets}{$relname}; - delete $self->{_relationship_data}{$relname}; - #delete $self->{_inflated_column}{$relname}; + if ( $acc eq 'single' and $rel_names->{$rel_name}{attrs}{fk_columns}{$column} ) { + delete $self->{related_resultsets}{$rel_name}; + delete $self->{_relationship_data}{$rel_name}; + #delete $self->{_inflated_column}{$rel_name}; } - elsif ( $acc eq 'filter' and $relname eq $column) { - delete $self->{related_resultsets}{$relname}; - #delete $self->{_relationship_data}{$relname}; - delete $self->{_inflated_column}{$relname}; + elsif ( $acc eq 'filter' and $rel_name eq $column) { + delete $self->{related_resultsets}{$rel_name}; + #delete $self->{_relationship_data}{$rel_name}; + delete $self->{_inflated_column}{$rel_name}; } } @@ -962,7 +981,7 @@ sub set_column { $had_value and # no storage - no storage-value - $in_storage + $self->in_storage and # no value already stored (multiple changes before commit to storage) ! exists $self->{_column_data_in_storage}{$column} @@ -985,6 +1004,13 @@ sub _eq_column_values { elsif (not defined $old) { # both undef return 1; } + elsif ( + is_literal_value $old + or + is_literal_value $new + ) { + return 0; + } elsif ($old eq $new) { return 1; } @@ -1000,7 +1026,7 @@ sub _eq_column_values { # value tracked between column changes and commitment to storage sub _track_storage_value { my ($self, $col) = @_; - return defined first { $col eq $_ } ($self->primary_columns); + return defined first { $col eq $_ } ($self->result_source->primary_columns); } =head2 set_columns @@ -1029,7 +1055,7 @@ sub set_columns { =head2 set_inflated_columns - $result->set_inflated_columns({ $col => $val, $relname => $obj, ... }); + $result->set_inflated_columns({ $col => $val, $rel_name => $obj, ... }); =over @@ -1062,10 +1088,13 @@ See also L. sub set_inflated_columns { my ( $self, $upd ) = @_; + my $rsrc; foreach my $key (keys %$upd) { if (ref $upd->{$key}) { - my $info = $self->relationship_info($key); + $rsrc ||= $self->result_source; + my $info = $rsrc->relationship_info($key); my $acc_type = $info->{attrs}{accessor} || ''; + if ($acc_type eq 'single') { my $rel_obj = delete $upd->{$key}; $self->set_from_related($key => $rel_obj); @@ -1076,7 +1105,11 @@ sub set_inflated_columns { "Recursive update is not supported over relationships of type '$acc_type' ($key)" ); } - elsif ($self->has_column($key) && exists $self->column_info($key)->{_inflate_info}) { + elsif ( + $rsrc->has_column($key) + and + exists $rsrc->column_info($key)->{_inflate_info} + ) { $self->set_inflated_column($key, delete $upd->{$key}); } } @@ -1114,43 +1147,48 @@ is set by default on C relationships and unset on all others. sub copy { my ($self, $changes) = @_; $changes ||= {}; - my $col_data = { %{$self->{_column_data}} }; + my $col_data = { $self->get_columns }; - my $colinfo = $self->columns_info([ keys %$col_data ]); + my $rsrc = $self->result_source; + + my $colinfo = $rsrc->columns_info; foreach my $col (keys %$col_data) { delete $col_data->{$col} - if $colinfo->{$col}{is_auto_increment}; + if ( ! $colinfo->{$col} or $colinfo->{$col}{is_auto_increment} ); } my $new = { _column_data => $col_data }; bless $new, ref $self; - $new->result_source($self->result_source); + $new->result_source($rsrc); $new->set_inflated_columns($changes); $new->insert; # Its possible we'll have 2 relations to the same Source. We need to make # sure we don't try to insert the same row twice else we'll violate unique # constraints - my $relnames_copied = {}; + my $rel_names_copied = {}; - foreach my $relname ($self->result_source->relationships) { - my $rel_info = $self->result_source->relationship_info($relname); + foreach my $rel_name ($rsrc->relationships) { + my $rel_info = $rsrc->relationship_info($rel_name); next unless $rel_info->{attrs}{cascade_copy}; - my $resolved = $self->result_source->_resolve_condition( - $rel_info->{cond}, $relname, $new, $relname - ); + my $foreign_vals; + my $copied = $rel_names_copied->{ $rel_info->{source} } ||= {}; - my $copied = $relnames_copied->{ $rel_info->{source} } ||= {}; - foreach my $related ($self->search_related($relname)->all) { - my $id_str = join("\0", $related->id); - next if $copied->{$id_str}; - $copied->{$id_str} = 1; - my $rel_copy = $related->copy($resolved); - } + $copied->{$_->ID}++ or $_->copy( + $foreign_vals ||= $rsrc->_resolve_relationship_condition( + infer_values_based_on => {}, + rel_name => $rel_name, + self_result_object => $new, + + self_alias => "\xFE", # irrelevant + foreign_alias => "\xFF", # irrelevant, + )->{inferred_values} + + ) for $self->search_related($rel_name)->all; } return $new; } @@ -1178,11 +1216,17 @@ extend this method to catch all data setting methods. sub store_column { my ($self, $column, $value) = @_; - $self->throw_exception( "No such column '${column}'" ) - unless exists $self->{_column_data}{$column} || $self->has_column($column); + $self->throw_exception( "No such column '${column}' on " . ref $self ) + unless exists $self->{_column_data}{$column} || $self->result_source->has_column($column); $self->throw_exception( "set_column called for ${column} without value" ) if @_ < 3; - return $self->{_column_data}{$column} = $value; + + # stringify all refs explicitly, guards against overloaded objects + # with defined stringification AND fallback => 0 (ugh!) + $self->{_column_data}{$column} = ( length ref $value and is_plain_value( $value ) ) + ? "$value" + : $value + ; } =head2 inflate_result @@ -1220,61 +1264,59 @@ sub inflate_result { ; if ($prefetch) { - for my $relname ( keys %$prefetch ) { + for my $rel_name ( keys %$prefetch ) { - my $relinfo = $rsrc->relationship_info($relname) or do { + my $relinfo = $rsrc->relationship_info($rel_name) or do { my $err = sprintf "Inflation into non-existent relationship '%s' of '%s' requested", - $relname, + $rel_name, $rsrc->source_name, ; - if (my ($colname) = sort { length($a) <=> length ($b) } keys %{$prefetch->{$relname}[0] || {}} ) { + if (my ($colname) = sort { length($a) <=> length ($b) } keys %{$prefetch->{$rel_name}[0] || {}} ) { $err .= sprintf ", check the inflation specification (columns/as) ending in '...%s.%s'", - $relname, + $rel_name, $colname, } $rsrc->throw_exception($err); }; - $class->throw_exception("No accessor type declared for prefetched relationship '$relname'") + $class->throw_exception("No accessor type declared for prefetched relationship '$rel_name'") unless $relinfo->{attrs}{accessor}; + my $rel_rs = $new->related_resultset($rel_name); + my @rel_objects; if ( - $prefetch->{$relname} - and - @{$prefetch->{$relname}} + @{ $prefetch->{$rel_name} || [] } and - ref($prefetch->{$relname}) ne $DBIx::Class::ResultSource::RowParser::Util::null_branch_class + ref($prefetch->{$rel_name}) ne $DBIx::Class::ResultSource::RowParser::Util::null_branch_class ) { - my $rel_rs = $new->related_resultset($relname); - - if (ref $prefetch->{$relname}[0] eq 'ARRAY') { + if (ref $prefetch->{$rel_name}[0] eq 'ARRAY') { my $rel_rsrc = $rel_rs->result_source; my $rel_class = $rel_rs->result_class; my $rel_inflator = $rel_class->can('inflate_result'); @rel_objects = map { $rel_class->$rel_inflator ( $rel_rsrc, @$_ ) } - @{$prefetch->{$relname}} + @{$prefetch->{$rel_name}} ; } else { @rel_objects = $rel_rs->result_class->inflate_result( - $rel_rs->result_source, @{$prefetch->{$relname}} + $rel_rs->result_source, @{$prefetch->{$rel_name}} ); } } if ($relinfo->{attrs}{accessor} eq 'single') { - $new->{_relationship_data}{$relname} = $rel_objects[0]; + $new->{_relationship_data}{$rel_name} = $rel_objects[0]; } elsif ($relinfo->{attrs}{accessor} eq 'filter') { - $new->{_inflated_column}{$relname} = $rel_objects[0]; + $new->{_inflated_column}{$rel_name} = $rel_objects[0]; } - $new->related_resultset($relname)->set_cache(\@rel_objects); + $rel_rs->set_cache(\@rel_objects); } } @@ -1294,7 +1336,7 @@ sub inflate_result { =back -Ls the object if it's already in the database, according to +Ls the object if it's already in the database, according to L, else Ls it. =head2 insert_or_update @@ -1381,11 +1423,10 @@ sub result_source { # note this is a || not a ||=, the difference is important : $_[0]->{_result_source} || do { - my $class = ref $_[0]; $_[0]->can('result_source_instance') ? $_[0]->result_source_instance : $_[0]->throw_exception( - "No result source instance registered for $class, did you forget to call $class->table(...) ?" + "No result source instance registered for @{[ ref $_[0] ]}, did you forget to call @{[ ref $_[0] ]}->table(...) ?" ) } ; @@ -1492,11 +1533,12 @@ $attrs, if supplied, is expected to be a hashref of attributes suitable for pass second argument to C<< $resultset->search($cond, $attrs) >>; Note: If you are using L as your -storage, please kept in mind that if you L on a row that you -just updated or created, you should wrap the entire bit inside a transaction. -Otherwise you run the risk that you insert or update to the master database -but read from a replicant database that has not yet been updated from the -master. This will result in unexpected results. +storage, a default of +L<< C<< { force_pool => 'master' } >> +|DBIx::Class::Storage::DBI::Replicated/SYNOPSIS >> is automatically set for +you. Prior to C<< DBIx::Class 0.08109 >> (before 2010) one would have been +required to explicitly wrap the entire operation in a transaction to guarantee +that up-to-date results are read from the master database. =cut @@ -1533,8 +1575,8 @@ See L. sub throw_exception { my $self=shift; - if (ref $self && ref $self->result_source ) { - $self->result_source->throw_exception(@_) + if (ref $self && ref (my $rsrc = try { $self->result_source_instance } ) ) { + $rsrc->throw_exception(@_) } else { DBIx::Class::Exception->throw(@_); @@ -1556,13 +1598,16 @@ sub throw_exception { Returns the primary key(s) for a row. Can't be called as a class method. Actually implemented in L -=head1 AUTHOR AND CONTRIBUTORS +=head1 FURTHER QUESTIONS? -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut diff --git a/lib/DBIx/Class/SQLMaker.pm b/lib/DBIx/Class/SQLMaker.pm index e863a0ff6..25a0386ec 100644 --- a/lib/DBIx/Class/SQLMaker.pm +++ b/lib/DBIx/Class/SQLMaker.pm @@ -9,13 +9,13 @@ DBIx::Class::SQLMaker - An SQL::Abstract-based SQL maker class =head1 DESCRIPTION -This module is a subclass of L and includes a number of -DBIC-specific workarounds, not yet suitable for inclusion into the +This module is currently a subclass of L and includes a number of +DBIC-specific extensions/workarounds, not suitable for inclusion into the L core. It also provides all (and more than) the functionality of L, see L for more info. -Currently the enhancements to L are: +Currently the enhancements over L are: =over @@ -25,10 +25,102 @@ Currently the enhancements to L are: =item * C/C support (via extensions to the order_by parameter) +=item * A rudimentary multicolumn IN operator + =item * Support of C<...FOR UPDATE> type of select statement modifiers =back +=head1 ROADMAP + +Some maintainer musings on the current state of SQL generation within DBIC as +of Oct 2015 + +=head2 Folding of most (or all) of L into DBIC + +The rise of complex prefetch use, and the general streamlining of result +parsing within DBIC ended up pushing the actual SQL generation to the forefront +of many casual performance profiles. While the idea behind SQLA's API is sound, +the actual implementation is terribly inefficient (once again bumping into the +ridiculously high overhead of perl function calls). + +Given that SQLA has a B distinct life on its own, and is used within an +order of magnitude more projects compared to DBIC, it is prudent to B +disturb the current call chains within SQLA itself. Instead in the near future +an effort will be undertaken to seek a more thorough decoupling of DBIC SQL +generation from reliance on SQLA, possibly to a point where B at all. + +B library itself will continue being maintained> although +it is not likely to gain many extra features, notably dialect support, at least +not within the base C namespace. + +This work (if undertaken) will take into consideration the following +constraints: + +=over + +=item Main API compatibility + +The object returned by C<< $schema->storage->sqlmaker >> needs to be able to +satisfy most of the basic tests found in the current-at-the-time SQLA dist. +While things like L or L +or even worse L will definitely remain +unsupported, the rest of the tests should pass (within reason). + +=item Ability to plug back an SQL::Abstract (or derivative) + +During the initial work on L the test suite of DBIC turned out to +be an invaluable asset to iron out hard-to-reason-about corner cases. In +addition the test suite is much more vast and intricate than the tests of SQLA +itself. This state of affairs is way too valuable to sacrifice in order to gain +faster SQL generation. Thus a compile-time-ENV-check will be introduced along +with an extra CI configuration to ensure that DBIC is used with an off-the-CPAN +SQLA and that it continues to flawlessly run its entire test suite. While this +will undoubtedly complicate the implementation of the better performing SQL +generator, it will preserve both the usability of the test suite for external +projects and will keep L from regressions in the future. + +=back + +Aside from these constraints it is becoming more and more practical to simply +stop using SQLA in day-to-day production deployments of DBIC. The flexibility +of the internals is simply not worth the performance cost. + +=head2 Relationship to L + +When initial work on DQ was taking place, the tools in L<::Storage::DBIHacks +|http://github.com/dbsrgits/dbix-class/blob/current/blead/lib/DBIx/Class/Storage/DBIHacks.pm> +were only beginning to take shape, and it wasn't clear how important they will +become further down the road. In fact the I was +considered an ugly stop-gap, and even a couple of highly entertaining talks +were given to that effect. As the use-cases of DBIC were progressing, and +evidence for the importance of supporting arbitrary SQL was mounting, it became +clearer that DBIC itself would not really benefit in any way from an +integration with DQ, but on the contrary is likely to lose functionality while +the corners of the brand new DQ codebase are sanded off. + +The current status of DBIC/DQ integration is that the only benefit is for DQ by +having access to the very extensive "early adopter" test suite, in the same +manner as early DBIC benefitted tremendously from usurping the Class::DBI test +suite. As far as the DBIC user-base - there are no immediate practical upsides +to DQ integration, neither in terms of API nor in performance. + +So (as described higher up) the DBIC development effort will in the foreseable +future ignore the existence of DQ, and will continue optimizing the preexisting +SQLA-based solution, potentially "organically growing" its own compatible +implementation. Also (again, as described higher up) the ability to plug a +separate SQLA-compatible class providing the necessary surface API will remain +possible, and will be protected at all costs in order to continue providing DQ +access to the test cases of DBIC. + +In the short term, after one more pass over the ResultSet internals is +undertaken I, and before the SQLA/SQLMaker integration +takes place, the preexisting DQ-based branches will be pulled/modified/rebased +to get up-to-date with the current state of the codebase, which changed very +substantially since the last migration effort, especially in the SQL +classification meta-parsing codepath. + =cut use base qw/ @@ -44,8 +136,16 @@ use namespace::clean; __PACKAGE__->mk_group_accessors (simple => qw/quote_char name_sep limit_dialect/); +sub _quoting_enabled { + ( defined $_[0]->{quote_char} and length $_[0]->{quote_char} ) ? 1 : 0 +} + # for when I need a normalized l/r pair sub _quote_chars { + + # in case we are called in the old !!$sm->_quote_chars fashion + return () if !wantarray and ( ! defined $_[0]->{quote_char} or ! length $_[0]->{quote_char} ); + map { defined $_ ? $_ : '' } ( ref $_[0]->{quote_char} ? (@{$_[0]->{quote_char}}) : ( ($_[0]->{quote_char}) x 2 ) ) @@ -110,7 +210,7 @@ sub select { my ($self, $table, $fields, $where, $rs_attrs, $limit, $offset) = @_; - $fields = $self->_recurse_fields($fields); + ($fields, @{$self->{select_bind}}) = $self->_recurse_fields($fields); if (defined $offset) { $self->throw_exception('A supplied offset must be a non-negative integer') @@ -138,8 +238,9 @@ sub select { if( $limiter = $self->can ('emulate_limit') ) { carp_unique( 'Support for the legacy emulate_limit() mechanism inherited from ' - . 'SQL::Abstract::Limit has been deprecated, and will be removed when ' - . 'DBIC transitions to Data::Query. If your code uses this type of ' + . 'SQL::Abstract::Limit has been deprecated, and will be removed at ' + . 'some future point, as it gets in the way of architectural and/or ' + . 'performance advances within DBIC. If your code uses this type of ' . 'limit specification please file an RT and provide the source of ' . 'your emulate_limit() implementation, so an acceptable upgrade-path ' . 'can be devised' @@ -203,9 +304,9 @@ sub insert { # optimized due to hotttnesss # my ($self, $table, $data, $options) = @_; - # SQLA will emit INSERT INTO $table ( ) VALUES ( ) + # FIXME SQLA will emit INSERT INTO $table ( ) VALUES ( ) # which is sadly understood only by MySQL. Change default behavior here, - # until SQLA2 comes with proper dialect support + # until we fold the extra pieces into SQLMaker properly if (! $_[2] or (ref $_[2] eq 'HASH' and !keys %{$_[2]} ) ) { my @bind; my $sql = sprintf( @@ -231,42 +332,47 @@ sub _recurse_fields { return $$fields if $ref eq 'SCALAR'; if ($ref eq 'ARRAY') { - return join(', ', map { $self->_recurse_fields($_) } @$fields); + my (@select, @bind); + for my $field (@$fields) { + my ($select, @new_bind) = $self->_recurse_fields($field); + push @select, $select; + push @bind, @new_bind; + } + return (join(', ', @select), @bind); } elsif ($ref eq 'HASH') { my %hash = %$fields; # shallow copy my $as = delete $hash{-as}; # if supplied - my ($func, $args, @toomany) = %hash; + my ($func, $rhs, @toomany) = %hash; # there should be only one pair if (@toomany) { $self->throw_exception( "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ) ); } - if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) { + if (lc ($func) eq 'distinct' && ref $rhs eq 'ARRAY' && @$rhs > 1) { $self->throw_exception ( 'The select => { distinct => ... } syntax is not supported for multiple columns.' - .' Instead please use { group_by => [ qw/' . (join ' ', @$args) . '/ ] }' - .' or { select => [ qw/' . (join ' ', @$args) . '/ ], distinct => 1 }' + .' Instead please use { group_by => [ qw/' . (join ' ', @$rhs) . '/ ] }' + .' or { select => [ qw/' . (join ' ', @$rhs) . '/ ], distinct => 1 }' ); } + my ($rhs_sql, @rhs_bind) = $self->_recurse_fields($rhs); my $select = sprintf ('%s( %s )%s', $self->_sqlcase($func), - $self->_recurse_fields($args), + $rhs_sql, $as ? sprintf (' %s %s', $self->_sqlcase('as'), $self->_quote ($as) ) : '' ); - return $select; + return ($select, @rhs_bind); } - # Is the second check absolutely necessary? elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) { - push @{$self->{select_bind}}, @{$$fields}[1..$#$$fields]; - return $$fields->[0]; + return @{$$fields}; } else { $self->throw_exception( $ref . qq{ unexpected in _recurse_fields()} ); @@ -281,28 +387,36 @@ sub _recurse_fields { # things in the SQLA space need to have more info about the $rs they # create SQL for. The alternative would be to keep expanding the # signature of _select with more and more positional parameters, which -# is just gross. All hail SQLA2! +# is just gross. +# +# FIXME - this will have to transition out to a subclass when the effort +# of folding the SQLA machinery into SQLMaker takes place sub _parse_rs_attrs { my ($self, $arg) = @_; my $sql = ''; + my @sqlbind; - if ($arg->{group_by}) { - # horrible horrible, waiting for refactor - local $self->{select_bind}; - if (my $g = $self->_recurse_fields($arg->{group_by}) ) { - $sql .= $self->_sqlcase(' group by ') . $g; - push @{$self->{group_bind} ||= []}, @{$self->{select_bind}||[]}; - } + if ( + $arg->{group_by} + and + @sqlbind = $self->_recurse_fields($arg->{group_by}) + ) { + $sql .= $self->_sqlcase(' group by ') . shift @sqlbind; + push @{$self->{group_bind}}, @sqlbind; } - if (defined $arg->{having}) { - my ($frag, @bind) = $self->_recurse_where($arg->{having}); - push(@{$self->{having_bind}}, @bind); - $sql .= $self->_sqlcase(' having ') . $frag; + if ( + $arg->{having} + and + @sqlbind = $self->_recurse_where($arg->{having}) + ) { + $sql .= $self->_sqlcase(' having ') . shift @sqlbind; + push(@{$self->{having_bind}}, @sqlbind); } - if (defined $arg->{order_by}) { + if ($arg->{order_by}) { + # unlike the 2 above, _order_by injects into @{...bind...} for us $sql .= $self->_order_by ($arg->{order_by}); } @@ -313,14 +427,18 @@ sub _order_by { my ($self, $arg) = @_; # check that we are not called in legacy mode (order_by as 4th argument) - if (ref $arg eq 'HASH' and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) { - return $self->_parse_rs_attrs ($arg); - } - else { - my ($sql, @bind) = $self->next::method($arg); - push @{$self->{order_bind}}, @bind; - return $sql; - } + ( + ref $arg eq 'HASH' + and + not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg + ) + ? $self->_parse_rs_attrs ($arg) + : do { + my ($sql, @bind) = $self->next::method($arg); + push @{$self->{order_bind}}, @bind; + $sql; # RV + } + ; } sub _split_order_chunk { @@ -441,8 +559,6 @@ sub _join_condition { # Backcompat for the old days when a plain hashref # { 't1.col1' => 't2.col2' } meant ON t1.col1 = t2.col2 - # Once things settle we should start warning here so that - # folks unroll their hacks if ( ref $cond eq 'HASH' and @@ -452,6 +568,12 @@ sub _join_condition { and ! ref ( (values %$cond)[0] ) ) { + carp_unique( + "ResultSet {from} structures with conditions not conforming to the " + . "SQL::Abstract syntax are deprecated: you either need to stop abusing " + . "{from} altogether, or express the condition properly using the " + . "{ -ident => ... } operator" + ); $cond = { keys %$cond => { -ident => values %$cond } } } elsif ( ref $cond eq 'ARRAY' ) { @@ -469,9 +591,14 @@ sub _join_condition { return $self->_recurse_where($cond); } -# This is hideously ugly, but SQLA does not understand multicol IN expressions -# FIXME TEMPORARY - DQ should have native syntax for this -# moved here to raise API questions +# !!! EXPERIMENTAL API !!! WILL CHANGE !!! +# +# This is rather odd, but vanilla SQLA does not have support for multicolumn IN +# expressions +# Currently has only one callsite in ResultSet, body moved into this subclass +# of SQLA to raise API questions like: +# - how do we convey a list of idents...? +# - can binds reside on lhs? # # !!! EXPERIMENTAL API !!! WILL CHANGE !!! sub _where_op_multicolumn_in { @@ -518,14 +645,17 @@ sub _where_op_multicolumn_in { \[ join( ' IN ', shift @$$lhs, shift @$$rhs ), @$$lhs, @$$rhs ]; } -1; - -=head1 AUTHORS +=head1 FURTHER QUESTIONS? -See L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut + +1; diff --git a/lib/DBIx/Class/SQLMaker/LimitDialects.pm b/lib/DBIx/Class/SQLMaker/LimitDialects.pm index ec9300aec..47027cb04 100644 --- a/lib/DBIx/Class/SQLMaker/LimitDialects.pm +++ b/lib/DBIx/Class/SQLMaker/LimitDialects.pm @@ -61,7 +61,7 @@ sub _LimitOffset { =head2 LimitXY - SELECT ... LIMIT $offset $limit + SELECT ... LIMIT $offset, $limit Supported by B and any L based DBD @@ -221,7 +221,7 @@ sub _FirstSkip { Depending on the resultset attributes one of: SELECT * FROM ( - SELECT *, ROWNUM rownum__index FROM ( + SELECT *, ROWNUM AS rownum__index FROM ( SELECT ... ) WHERE ROWNUM <= ($limit+$offset) ) WHERE rownum__index >= ($offset+1) @@ -229,7 +229,7 @@ Depending on the resultset attributes one of: or SELECT * FROM ( - SELECT *, ROWNUM rownum__index FROM ( + SELECT *, ROWNUM AS rownum__index FROM ( SELECT ... ) ) WHERE rownum__index BETWEEN ($offset+1) AND ($limit+$offset) @@ -273,12 +273,12 @@ EOS # method, and the slower BETWEEN query is used instead # # FIXME - this is quite expensive, and does not perform caching of any sort - # as soon as some of the DQ work becomes viable consider switching this - # over + # as soon as some of the SQLA-inlining work becomes viable consider adding + # some rudimentary caching support if ( $rs_attrs->{order_by} and - $rs_attrs->{_rsroot_rsrc}->storage->_order_by_is_stable( + $rs_attrs->{result_source}->storage->_order_by_is_stable( @{$rs_attrs}{qw/from order_by where/} ) ) { @@ -286,7 +286,7 @@ EOS return <{selection_outer} FROM ( - SELECT $sq_attrs->{selection_outer}, ROWNUM $idx_name FROM ( + SELECT $sq_attrs->{selection_outer}, ROWNUM AS $idx_name FROM ( SELECT $sq_attrs->{selection_inner} $sq_attrs->{query_leftover}${order_group_having} ) $qalias WHERE ROWNUM <= ? ) $qalias WHERE $idx_name >= ? @@ -297,7 +297,7 @@ EOS return <{selection_outer} FROM ( - SELECT $sq_attrs->{selection_outer}, ROWNUM $idx_name FROM ( + SELECT $sq_attrs->{selection_outer}, ROWNUM AS $idx_name FROM ( SELECT $sq_attrs->{selection_inner} $sq_attrs->{query_leftover}${order_group_having} ) $qalias ) $qalias WHERE $idx_name BETWEEN ? AND ? @@ -331,7 +331,7 @@ sub _prep_for_skimming_limit { if ($sq_attrs->{order_by_requested}) { $self->throw_exception ( 'Unable to safely perform "skimming type" limit with supplied unstable order criteria' - ) unless ($rs_attrs->{_rsroot_rsrc}->schema->storage->_order_by_is_stable( + ) unless ($rs_attrs->{result_source}->schema->storage->_order_by_is_stable( $rs_attrs->{from}, $requested_order, $rs_attrs->{where}, @@ -343,11 +343,11 @@ sub _prep_for_skimming_limit { $inner_order = [ map { "$rs_attrs->{alias}.$_" } ( @{ - $rs_attrs->{_rsroot_rsrc}->_identifying_column_set + $rs_attrs->{result_source}->_identifying_column_set || $self->throw_exception(sprintf( 'Unable to auto-construct stable order criteria for "skimming type" limit ' - . "dialect based on source '%s'", $rs_attrs->{_rsroot_rsrc}->name) ); + . "dialect based on source '%s'", $rs_attrs->{result_source}->name) ); } ) ]; } @@ -532,29 +532,37 @@ Currently used by B, due to lack of any other option. sub _GenericSubQ { my ($self, $sql, $rs_attrs, $rows, $offset) = @_; - my $root_rsrc = $rs_attrs->{_rsroot_rsrc}; + my $main_rsrc = $rs_attrs->{result_source}; # Explicitly require an order_by # GenSubQ is slow enough as it is, just emulating things # like in other cases is not wise - make the user work # to shoot their DBA in the foot - my $supplied_order = delete $rs_attrs->{order_by} or $self->throw_exception ( + $self->throw_exception ( 'Generic Subquery Limit does not work on resultsets without an order. Provide a stable, ' - . 'root-table-based order criteria.' + . 'main-table-based order criteria.' + ) unless $rs_attrs->{order_by}; + + my $usable_order_colinfo = $main_rsrc->storage->_extract_colinfo_of_stable_main_source_order_by_portion( + $rs_attrs ); - my $usable_order_ci = $root_rsrc->storage->_main_source_order_by_portion_is_stable( - $root_rsrc, - $supplied_order, - $rs_attrs->{where}, - ) or $self->throw_exception( - 'Generic Subquery Limit can not work with order criteria based on sources other than the current one' + $self->throw_exception( + 'Generic Subquery Limit can not work with order criteria based on sources other than the main one' + ) if ( + ! keys %{$usable_order_colinfo||{}} + or + grep + { $_->{-source_alias} ne $rs_attrs->{alias} } + (values %$usable_order_colinfo) ); ### ### ### we need to know the directions after we figured out the above - reextract *again* ### this is eyebleed - trying to get it to work at first + my $supplied_order = delete $rs_attrs->{order_by}; + my @order_bits = do { local $self->{quote_char}; local $self->{order_bind}; @@ -562,20 +570,20 @@ sub _GenericSubQ { }; # truncate to what we'll use - $#order_bits = ( (keys %$usable_order_ci) - 1 ); + $#order_bits = ( (keys %$usable_order_colinfo) - 1 ); # @order_bits likely will come back quoted (due to how the prefetch # rewriter operates # Hence supplement the column_info lookup table with quoted versions if ($self->quote_char) { - $usable_order_ci->{$self->_quote($_)} = $usable_order_ci->{$_} - for keys %$usable_order_ci; + $usable_order_colinfo->{$self->_quote($_)} = $usable_order_colinfo->{$_} + for keys %$usable_order_colinfo; } # calculate the condition my $count_tbl_alias = 'rownum__emulation'; - my $root_alias = $rs_attrs->{alias}; - my $root_tbl_name = $root_rsrc->name; + my $main_alias = $rs_attrs->{alias}; + my $main_tbl_name = $main_rsrc->name; my (@unqualified_names, @qualified_names, @is_desc, @new_order_by); @@ -584,17 +592,17 @@ sub _GenericSubQ { ($bit, my $is_desc) = $self->_split_order_chunk($bit); push @is_desc, $is_desc; - push @unqualified_names, $usable_order_ci->{$bit}{-colname}; - push @qualified_names, $usable_order_ci->{$bit}{-fq_colname}; + push @unqualified_names, $usable_order_colinfo->{$bit}{-colname}; + push @qualified_names, $usable_order_colinfo->{$bit}{-fq_colname}; - push @new_order_by, { ($is_desc ? '-desc' : '-asc') => $usable_order_ci->{$bit}{-fq_colname} }; + push @new_order_by, { ($is_desc ? '-desc' : '-asc') => $usable_order_colinfo->{$bit}{-fq_colname} }; }; my (@where_cond, @skip_colpair_stack); for my $i (0 .. $#order_bits) { - my $ci = $usable_order_ci->{$order_bits[$i]}; + my $ci = $usable_order_colinfo->{$order_bits[$i]}; - my ($subq_col, $main_col) = map { "$_.$ci->{-colname}" } ($count_tbl_alias, $root_alias); + my ($subq_col, $main_col) = map { "$_.$ci->{-colname}" } ($count_tbl_alias, $main_alias); my $cur_cond = { $subq_col => { ($is_desc[$i] ? '>' : '<') => { -ident => $main_col } } }; push @skip_colpair_stack, [ @@ -683,7 +691,7 @@ WHERE ( SELECT COUNT(*) FROM %s %s $counted_where ) $rownum_cond $inner_order_sql ", map { $self->_quote ($_) } ( $rs_attrs->{alias}, - $root_tbl_name, + $main_tbl_name, $count_tbl_alias, )); } @@ -693,7 +701,7 @@ $inner_order_sql # # Generates inner/outer select lists for various limit dialects # which result in one or more subqueries (e.g. RNO, Top, RowNum) -# Any non-root-table columns need to have their table qualifier +# Any non-main-table columns need to have their table qualifier # turned into a column alias (otherwise names in subqueries clash # and/or lose their source table) # @@ -725,23 +733,22 @@ sub _subqueried_limit_attrs { my ($re_sep, $re_alias) = map { quotemeta $_ } ( $self->{name_sep}, $rs_attrs->{alias} ); - # insulate from the multiple _recurse_fields calls below - local $self->{select_bind}; - # correlate select and as, build selection index my (@sel, $in_sel_index); for my $i (0 .. $#{$rs_attrs->{select}}) { my $s = $rs_attrs->{select}[$i]; - my $sql_sel = $self->_recurse_fields ($s); my $sql_alias = (ref $s) eq 'HASH' ? $s->{-as} : undef; + # we throw away the @bind here deliberately + my ($sql_sel) = $self->_recurse_fields ($s); + push @sel, { arg => $s, sql => $sql_sel, unquoted_sql => do { local $self->{quote_char}; - $self->_recurse_fields ($s); + ($self->_recurse_fields ($s))[0]; # ignore binds again }, as => $sql_alias @@ -822,14 +829,17 @@ sub _unqualify_colname { return $fqcn; } -1; - -=head1 AUTHORS +=head1 FURTHER QUESTIONS? -See L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut + +1; diff --git a/lib/DBIx/Class/SQLMaker/Oracle.pm b/lib/DBIx/Class/SQLMaker/Oracle.pm index d1ed9a2c5..b4c1584f7 100644 --- a/lib/DBIx/Class/SQLMaker/Oracle.pm +++ b/lib/DBIx/Class/SQLMaker/Oracle.pm @@ -4,14 +4,16 @@ package # Hide from PAUSE use warnings; use strict; -use base qw( DBIx::Class::SQLMaker ); - BEGIN { - use DBIx::Class::Optional::Dependencies; - die('The following extra modules are required for Oracle-based Storages ' . DBIx::Class::Optional::Dependencies->req_missing_for ('id_shortener') . "\n" ) - unless DBIx::Class::Optional::Dependencies->req_ok_for ('id_shortener'); + require DBIx::Class::Optional::Dependencies; + if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('id_shortener') ) { + die "The following extra modules are required for Oracle-based Storages: $missing\n"; + } + require Digest::MD5; } +use base 'DBIx::Class::SQLMaker'; + sub new { my $self = shift; my %opts = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_; @@ -144,9 +146,6 @@ sub _shorten_identifier { @keywords = $to_shorten unless @keywords; # get a base36 md5 of the identifier - require Digest::MD5; - require Math::BigInt; - require Math::Base36; my $b36sum = Math::Base36::encode_base36( Math::BigInt->from_hex ( '0x' . Digest::MD5::md5_hex ($to_shorten) diff --git a/lib/DBIx/Class/SQLMaker/OracleJoins.pm b/lib/DBIx/Class/SQLMaker/OracleJoins.pm index b95c56e88..0f50467ed 100644 --- a/lib/DBIx/Class/SQLMaker/OracleJoins.pm +++ b/lib/DBIx/Class/SQLMaker/OracleJoins.pm @@ -80,13 +80,35 @@ sub _recurse_oracle_joins { && $jt !~ /inner/i; } - # sadly SQLA treats where($scalar) as literal, so we need to jump some hoops - push @where, map { \sprintf ('%s%s = %s%s', - ref $_ ? $self->_recurse_where($_) : $self->_quote($_), - $left_join, - ref $on->{$_} ? $self->_recurse_where($on->{$_}) : $self->_quote($on->{$_}), - $right_join, - )} keys %$on; + # FIXME - the code below *UTTERLY* doesn't work with custom conds... sigh + # for the time being do not do any processing with the likes of _collapse_cond + # instead only unroll the -and hack if present + $on = $on->{-and}[0] if ( + ref $on eq 'HASH' + and + keys %$on == 1 + and + ref $on->{-and} eq 'ARRAY' + and + @{$on->{-and}} == 1 + ); + + + push @where, map { \do { + my ($sql) = $self->_recurse_where({ + # FIXME - more borkage, more or less a copy of the kludge in ::SQLMaker::_join_condition() + $_ => ( length ref $on->{$_} + ? $on->{$_} + : { -ident => $on->{$_} } + ) + }); + + $sql =~ s/\s*\=/$left_join =/ + if $left_join; + + "$sql$right_join"; + } + } sort keys %$on; } return { -and => \@where }; @@ -94,7 +116,7 @@ sub _recurse_oracle_joins { 1; -=pod +__END__ =head1 NAME @@ -152,17 +174,13 @@ Does not support full outer joins (however neither really does DBIC itself) =back -=head1 AUTHOR - -Justin Wheeler C<< >> - -=head1 CONTRIBUTORS - -David Jack Olrik C<< >> - -=head1 LICENSE +=head1 FURTHER QUESTIONS? -This module is licensed under the same terms as Perl itself. +Check the list of L. -=cut +=head1 COPYRIGHT AND LICENSE +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 4c3cce50e..36041bdaa 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -8,8 +8,7 @@ use base 'DBIx::Class'; use DBIx::Class::Carp; use Try::Tiny; use Scalar::Util qw/weaken blessed/; -use DBIx::Class::_Util 'refcount'; -use Sub::Name 'subname'; +use DBIx::Class::_Util qw(refcount quote_sub is_exception); use Devel::GlobalDestruction; use namespace::clean; @@ -109,11 +108,12 @@ are no matching Result classes like this: load_namespaces found ResultSet class $classname with no corresponding Result class -If a Result class is found to already have a ResultSet class set using -L to some other class, you will be warned like this: +If a ResultSource instance is found to already have a ResultSet class set +using L to some +other class, you will be warned like this: - We found ResultSet class '$rs_class' for '$result', but it seems - that you had already set '$result' to use '$rs_set' instead + We found ResultSet class '$rs_class' for '$result_class', but it seems + that you had already set '$result_class' to use '$rs_set' instead =head3 Examples @@ -897,7 +897,6 @@ sub compose_namespace { local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO; use warnings qw/redefine/; - no strict qw/refs/; foreach my $source_name ($self->sources) { my $orig_source = $self->source($source_name); @@ -919,11 +918,8 @@ sub compose_namespace { } } - foreach my $meth (qw/class source resultset/) { - no warnings 'redefine'; - *{"${target}::${meth}"} = subname "${target}::${meth}" => - sub { shift->schema->$meth(@_) }; - } + quote_sub "${target}::${_}" => "shift->schema->$_(\@_)" + for qw(class source resultset); } Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; @@ -1059,26 +1055,37 @@ default behavior will provide a detailed stack trace. =cut sub throw_exception { - my $self = shift; + my ($self, @args) = @_; if (my $act = $self->exception_action) { - if ($act->(@_)) { - DBIx::Class::Exception->throw( + try { + # if it throws - good, we'll go down to the catch + # if it doesn't - do different things depending on RV truthiness + if( $act->(@args) ) { + $args[0] = ( "Invocation of the exception_action handler installed on $self did *not*" .' result in an exception. DBIx::Class is unable to function without a reliable' .' exception mechanism, ensure that exception_action does not hide exceptions' - ." (original error: $_[0])" - ); - } + ." (original error: $args[0])" + ); + } + else { + carp_unique ( + "The exception_action handler installed on $self returned false instead" + .' of throwing an exception. This behavior has been deprecated, adjust your' + .' handler to always rethrow the supplied error.' + ); + } + } catch { + # We call this to get the necessary warnings emitted and disregard the RV + # as it's definitely an exception if we got as far as catch{} + is_exception($_); - carp_unique ( - "The exception_action handler installed on $self returned false instead" - .' of throwing an exception. This behavior has been deprecated, adjust your' - .' handler to always rethrow the supplied error.' - ); + die $_; + }; } - DBIx::Class::Exception->throw($_[0], $self->stacktrace); + DBIx::Class::Exception->throw( $args[0], $self->stacktrace ); } =head2 deploy @@ -1122,8 +1129,8 @@ sub deploy { A convenient shortcut to C<< $self->storage->deployment_statements($self, @args) >>. -Returns the SQL statements used by L and -L. +Returns the statements used by L and +L. =cut @@ -1217,19 +1224,17 @@ reference to any schema, so are rather useless. sub thaw { my ($self, $obj) = @_; local $DBIx::Class::ResultSourceHandle::thaw_schema = $self; - require Storable; return Storable::thaw($obj); } =head2 freeze -This doesn't actually do anything more than call L, it is just -provided here for symmetry. +This doesn't actually do anything beyond calling L, +it is just provided here for symmetry. =cut sub freeze { - require Storable; return Storable::nfreeze($_[1]); } @@ -1252,7 +1257,6 @@ objects so their references to the schema object sub dclone { my ($self, $obj) = @_; local $DBIx::Class::ResultSourceHandle::thaw_schema = $self; - require Storable; return Storable::dclone($obj); } @@ -1392,6 +1396,9 @@ sub _register_source { my $global_phase_destroy; sub DESTROY { + ### NO detected_reinvoked_destructor check + ### This code very much relies on being called multuple times + return if $global_phase_destroy ||= in_global_destruction; my $self = shift; @@ -1474,13 +1481,12 @@ sub compose_connection { carp_once "compose_connection deprecated as of 0.08000" unless $INC{"DBIx/Class/CDBICompat.pm"}; - my $base = 'DBIx::Class::ResultSetProxy'; try { - eval "require ${base};" + require DBIx::Class::ResultSetProxy; } catch { $self->throw_exception - ("No arguments to load_classes and couldn't load ${base} ($_)") + ("No arguments to load_classes and couldn't load DBIx::Class::ResultSetProxy ($_)") }; if ($self eq $target) { @@ -1488,7 +1494,7 @@ sub compose_connection { foreach my $source_name ($self->sources) { my $source = $self->source($source_name); my $class = $source->result_class; - $self->inject_base($class, $base); + $self->inject_base($class, 'DBIx::Class::ResultSetProxy'); $class->mk_classdata(resultset_instance => $source->resultset); $class->mk_classdata(class_resolver => $self); } @@ -1496,12 +1502,8 @@ sub compose_connection { return $self; } - my $schema = $self->compose_namespace($target, $base); - { - no strict 'refs'; - my $name = join '::', $target, 'schema'; - *$name = subname $name, sub { $schema }; - } + my $schema = $self->compose_namespace($target, 'DBIx::Class::ResultSetProxy'); + quote_sub "${target}::schema", '$s', { '$s' => \$schema }; $schema->connection(@info); foreach my $source_name ($schema->sources) { @@ -1515,14 +1517,17 @@ sub compose_connection { return $schema; } -1; - -=head1 AUTHOR AND CONTRIBUTORS +=head1 FURTHER QUESTIONS? -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut + +1; diff --git a/lib/DBIx/Class/Schema/Versioned.pm b/lib/DBIx/Class/Schema/Versioned.pm index 114064a10..ba3b44523 100644 --- a/lib/DBIx/Class/Schema/Versioned.pm +++ b/lib/DBIx/Class/Schema/Versioned.pm @@ -204,6 +204,7 @@ use base 'DBIx::Class::Schema'; use DBIx::Class::Carp; use Time::HiRes qw/gettimeofday/; use Try::Tiny; +use Scalar::Util 'weaken'; use namespace::clean; __PACKAGE__->mk_classdata('_filedata'); @@ -238,7 +239,7 @@ Call this to initialise a previously unversioned database. The table 'dbix_class Takes one argument which should be the version that the database is currently at. Defaults to the return value of L. -See L for more details. +See L for more details. =cut @@ -589,9 +590,10 @@ sub _on_connect { my ($self) = @_; - my $conn_info = $self->storage->connect_info; - $self->{vschema} = DBIx::Class::Version->connect(@$conn_info); - my $conn_attrs = $self->{vschema}->storage->_dbic_connect_attributes || {}; + weaken (my $w_self = $self ); + + $self->{vschema} = DBIx::Class::Version->connect(sub { $w_self->storage->dbh }); + my $conn_attrs = $self->storage->_dbic_connect_attributes || {}; my $vtable = $self->{vschema}->resultset('Table'); @@ -600,10 +602,10 @@ sub _on_connect # check for legacy versions table and move to new if exists unless ($self->_source_exists($vtable)) { - my $vtable_compat = DBIx::Class::VersionCompat->connect(@$conn_info)->resultset('TableCompat'); + my $vtable_compat = DBIx::Class::VersionCompat->connect(sub { $w_self->storage->dbh })->resultset('TableCompat'); if ($self->_source_exists($vtable_compat)) { $self->{vschema}->deploy; - map { $vtable->create({ installed => $_->Installed, version => $_->Version }) } $vtable_compat->all; + map { $vtable->new_result({ installed => $_->Installed, version => $_->Version })->insert } $vtable_compat->all; $self->storage->_get_dbh->do("DROP TABLE " . $vtable_compat->result_source->from); } } @@ -640,8 +642,8 @@ sub _create_db_to_schema_diff { return; } - unless (DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')) { - $self->throw_exception("Unable to proceed without " . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') ); + if ( my $missing = DBIx::Class::Optional::Dependencies->req_missing_for('deploy') ) { + $self->throw_exception("Unable to proceed without $missing"); } my $db_tr = SQL::Translator->new({ @@ -710,7 +712,7 @@ sub _set_db_version { # formatted by this new function will sort _after_ any existing 200... strings. my @tm = gettimeofday(); my @dt = gmtime ($tm[0]); - my $o = $vtable->create({ + my $o = $vtable->new_result({ version => $version, installed => sprintf("v%04d%02d%02d_%02d%02d%02d.%03.0f", $dt[5] + 1900, @@ -721,7 +723,7 @@ sub _set_db_version { $dt[0], int($tm[1] / 1000), # convert to millisecs ), - }); + })->insert; } sub _read_sql_file { @@ -754,13 +756,17 @@ sub _source_exists }; } -1; +=head1 FURTHER QUESTIONS? +Check the list of L. -=head1 AUTHOR AND CONTRIBUTORS +=head1 COPYRIGHT AND LICENSE -See L and L in DBIx::Class +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. -=head1 LICENSE +=cut -You may distribute this code under the same terms as Perl itself. +1; diff --git a/lib/DBIx/Class/Serialize/Storable.pm b/lib/DBIx/Class/Serialize/Storable.pm index 2a295d3ba..d0299cdf7 100644 --- a/lib/DBIx/Class/Serialize/Storable.pm +++ b/lib/DBIx/Class/Serialize/Storable.pm @@ -73,12 +73,13 @@ method. The deserializing hook called on the object during deserialization. -=head1 AUTHOR AND CONTRIBUTORS +=head1 FURTHER QUESTIONS? -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. - -=cut +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/StartupCheck.pm b/lib/DBIx/Class/StartupCheck.pm index 10b554aab..dff403bc3 100644 --- a/lib/DBIx/Class/StartupCheck.pm +++ b/lib/DBIx/Class/StartupCheck.pm @@ -3,6 +3,10 @@ package DBIx::Class::StartupCheck; use strict; use warnings; +1; + +__END__ + =head1 NAME DBIx::Class::StartupCheck - Run environment checks on startup @@ -30,22 +34,13 @@ warning message on startup sent to STDERR, explaining what to do about it and how to suppress the message. If you don't see any messages, you have nothing to worry about. -=head1 CONTRIBUTORS - -Nigel Metheringham - -Brandon Black +=head1 FURTHER QUESTIONS? -Matt S. Trout +Check the list of L. -=head1 AUTHOR +=head1 COPYRIGHT AND LICENSE -Jon Schutz - -=head1 LICENSE - -You may distribute this code under the same terms as Perl itself. - -=cut - -1; +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Storage.pm b/lib/DBIx/Class/Storage.pm index 1addeafb7..049230af6 100644 --- a/lib/DBIx/Class/Storage.pm +++ b/lib/DBIx/Class/Storage.pm @@ -227,6 +227,7 @@ sub txn_commit { $self->debugobj->txn_commit() if $self->debug; $self->_exec_txn_commit; $self->{transaction_depth}--; + $self->savepoints([]); } elsif($self->transaction_depth > 1) { $self->{transaction_depth}--; @@ -252,6 +253,7 @@ sub txn_rollback { $self->debugobj->txn_rollback() if $self->debug; $self->_exec_txn_rollback; $self->{transaction_depth}--; + $self->savepoints([]); } elsif ($self->transaction_depth > 1) { $self->{transaction_depth}--; @@ -434,10 +436,10 @@ shell environment. =head2 debugfh -Set or retrieve the filehandle used for trace/debug output. This should be -an IO::Handle compatible object (only the C method is used). Initially -set to be STDERR - although see information on the -L environment variable. +An opportunistic proxy to L<< ->debugobj->debugfh(@_) +|DBIx::Class::Storage::Statistics/debugfh >> +If the currently set L does not have a L method, caling +this is a no-op. =cut @@ -634,7 +636,6 @@ filename the file is read with L and the results are used as the configuration for tracing. See L for what that structure should look like. - =head2 DBIX_CLASS_STORAGE_DBI_DEBUG Old name for DBIC_TRACE @@ -644,13 +645,16 @@ Old name for DBIC_TRACE L - reference storage implementation using SQL::Abstract and DBI. -=head1 AUTHOR AND CONTRIBUTORS +=head1 FURTHER QUESTIONS? -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut diff --git a/lib/DBIx/Class/Storage/BlockRunner.pm b/lib/DBIx/Class/Storage/BlockRunner.pm index 8dae0c9be..be2970106 100644 --- a/lib/DBIx/Class/Storage/BlockRunner.pm +++ b/lib/DBIx/Class/Storage/BlockRunner.pm @@ -1,22 +1,16 @@ package # hide from pause until we figure it all out DBIx::Class::Storage::BlockRunner; +use warnings; use strict; use DBIx::Class::Exception; use DBIx::Class::Carp; use Context::Preserve 'preserve_context'; -use DBIx::Class::_Util 'is_exception'; +use DBIx::Class::_Util qw(is_exception qsub); use Scalar::Util qw(weaken blessed reftype); use Try::Tiny; - -# DO NOT edit away without talking to riba first, he will just put it back -BEGIN { - local $ENV{PERL_STRICTURES_EXTRA} = 0; - require Moo; Moo->import; - require Sub::Quote; Sub::Quote->import('quote_sub'); -} -use warnings NONFATAL => 'all'; +use Moo; use namespace::clean; =head1 NAME @@ -43,16 +37,16 @@ has wrap_txn => ( has retry_handler => ( is => 'ro', required => 1, - isa => quote_sub( q{ + isa => qsub q{ (Scalar::Util::reftype($_[0])||'') eq 'CODE' or DBIx::Class::Exception->throw('retry_handler must be a CODE reference') - }), + }, ); has retry_debug => ( is => 'rw', # use a sub - to be evaluated on the spot lazily - default => quote_sub( '$ENV{DBIC_STORAGE_RETRY_DEBUG}' ), + default => qsub '$ENV{DBIC_STORAGE_RETRY_DEBUG}', lazy => 1, ); @@ -67,19 +61,19 @@ has failed_attempt_count => ( writer => '_set_failed_attempt_count', default => 0, lazy => 1, - trigger => quote_sub(q{ + trigger => qsub q{ $_[0]->throw_exception( sprintf ( 'Reached max_attempts amount of %d, latest exception: %s', $_[0]->max_attempts, $_[0]->last_exception )) if $_[0]->max_attempts <= ($_[1]||0); - }), + }, ); has exception_stack => ( is => 'ro', init_arg => undef, clearer => '_reset_exception_stack', - default => quote_sub(q{ [] }), + default => qsub q{ [] }, lazy => 1, ); @@ -144,7 +138,7 @@ sub _run { my $storage = $self->storage; my $cur_depth = $storage->transaction_depth; - if (defined $txn_init_depth and $run_err eq '') { + if (defined $txn_init_depth and ! is_exception $run_err) { my $delta_txn = (1 + $txn_init_depth) - $cur_depth; if ($delta_txn) { @@ -219,13 +213,16 @@ sub _run { }; } -=head1 AUTHOR AND CONTRIBUTORS +=head1 FURTHER QUESTIONS? -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 9b5e3b03d..eb9bd8860 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -10,11 +10,10 @@ use mro 'c3'; use DBIx::Class::Carp; use Scalar::Util qw/refaddr weaken reftype blessed/; use List::Util qw/first/; -use Sub::Name 'subname'; use Context::Preserve 'preserve_context'; use Try::Tiny; -use overload (); -use Data::Compare (); # no imports!!! guard against insane architecture +use SQL::Abstract qw(is_plain_value is_literal_value); +use DBIx::Class::_Util qw(quote_sub perlstring serialize detected_reinvoked_destructor); use namespace::clean; # default cursor class, overridable in connect_info attributes @@ -101,12 +100,13 @@ for my $meth (keys %$storage_accessor_idx, qw( txn_begin insert - insert_bulk update delete select select_single + _insert_bulk + with_deferred_fk_checks get_use_dbms_capability @@ -119,10 +119,16 @@ for my $meth (keys %$storage_accessor_idx, qw( my $orig = __PACKAGE__->can ($meth) or die "$meth is not a ::Storage::DBI method!"; - no strict 'refs'; - no warnings 'redefine'; - *{__PACKAGE__ ."::$meth"} = subname $meth => sub { + my $possibly_a_setter = $storage_accessor_idx->{$meth} ? 1 : 0; + + quote_sub + __PACKAGE__ ."::$meth", sprintf( <<'EOC', $possibly_a_setter, perlstring $meth ), { '$orig' => \$orig }; + if ( + # if this is an actual *setter* - just set it, no need to connect + # and determine the driver + !( %1$s and @_ > 1 ) + and # only fire when invoked on an instance, a valid class-based invocation # would e.g. be setting a default for an inherited accessor ref $_[0] @@ -131,10 +137,6 @@ for my $meth (keys %$storage_accessor_idx, qw( and ! $_[0]->{_in_determine_driver} and - # if this is a known *setter* - just set it, no need to connect - # and determine the driver - ! ( $storage_accessor_idx->{$meth} and @_ > 1 ) - and # Only try to determine stuff if we have *something* that either is or can # provide a DSN. Allows for bare $schema's generated with a plain ->connect() # to still be marginally useful @@ -142,16 +144,15 @@ for my $meth (keys %$storage_accessor_idx, qw( ) { $_[0]->_determine_driver; - # This for some reason crashes and burns on perl 5.8.1 - # IFF the method ends up throwing an exception - #goto $_[0]->can ($meth); + # work around http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878 + goto $_[0]->can(%2$s) unless DBIx::Class::_ENV_::BROKEN_GOTO; - my $cref = $_[0]->can ($meth); + my $cref = $_[0]->can(%2$s); goto $cref; } goto $orig; - }; +EOC } =head1 NAME @@ -252,12 +253,12 @@ sub new { } sub DESTROY { - my $self = shift; + return if &detected_reinvoked_destructor; + $_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; # some databases spew warnings on implicit disconnect - $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; local $SIG{__WARN__} = sub {}; - $self->_dbh(undef); + $_[0]->_dbh(undef); # this op is necessary, since the very last perl runtime statement # triggers a global destruction shootout, and the $SIG localization @@ -268,14 +269,14 @@ sub DESTROY { # handle pid changes correctly - do not destroy parent's connection sub _verify_pid { - my $self = shift; - my $pid = $self->_conn_pid; - if( defined $pid and $pid != $$ and my $dbh = $self->_dbh ) { + my $pid = $_[0]->_conn_pid; + + if( defined $pid and $pid != $$ and my $dbh = $_[0]->_dbh ) { $dbh->{InactiveDestroy} = 1; - $self->_dbh(undef); - $self->transaction_depth(0); - $self->savepoints([]); + $_[0]->_dbh(undef); + $_[0]->transaction_depth(0); + $_[0]->savepoints([]); } return; @@ -869,22 +870,20 @@ database is not in C mode. =cut sub disconnect { - my ($self) = @_; - if( $self->_dbh ) { - my @actions; + if( my $dbh = $_[0]->_dbh ) { - push @actions, ( $self->on_disconnect_call || () ); - push @actions, $self->_parse_connect_do ('on_disconnect_do'); - - $self->_do_connection_actions(disconnect_call_ => $_) for @actions; + $_[0]->_do_connection_actions(disconnect_call_ => $_) for ( + ( $_[0]->on_disconnect_call || () ), + $_[0]->_parse_connect_do ('on_disconnect_do') + ); # stops the "implicit rollback on disconnect" warning - $self->_exec_txn_rollback unless $self->_dbh_autocommit; + $_[0]->_exec_txn_rollback unless $_[0]->_dbh_autocommit; - %{ $self->_dbh->{CachedKids} } = (); - $self->_dbh->disconnect; - $self->_dbh(undef); + %{ $dbh->{CachedKids} } = (); + $dbh->disconnect; + $_[0]->_dbh(undef); } } @@ -905,8 +904,8 @@ in MySQL's case disabled entirely. # Storage subclasses should override this sub with_deferred_fk_checks { - my ($self, $sub) = @_; - $sub->(); + #my ($self, $sub) = @_; + $_[1]->(); } =head2 connected @@ -926,40 +925,26 @@ answering, etc.) This method is used internally by L. =cut sub connected { - my $self = shift; - return 0 unless $self->_seems_connected; + return 0 unless $_[0]->_seems_connected; #be on the safe side - local $self->_dbh->{RaiseError} = 1; + local $_[0]->_dbh->{RaiseError} = 1; - return $self->_ping; + return $_[0]->_ping; } sub _seems_connected { - my $self = shift; - - $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; - - my $dbh = $self->_dbh - or return 0; + $_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; - return $dbh->FETCH('Active'); + ($_[0]->_dbh || return 0)->FETCH('Active'); } sub _ping { - my $self = shift; - - my $dbh = $self->_dbh or return 0; - - return $dbh->ping; + ($_[0]->_dbh || return 0)->ping; } sub ensure_connected { - my ($self) = @_; - - unless ($self->connected) { - $self->_populate_dbh; - } + $_[0]->connected || ( $_[0]->_populate_dbh && 1 ); } =head2 dbh @@ -973,26 +958,26 @@ instead. =cut sub dbh { - my ($self) = @_; - - if (not $self->_dbh) { - $self->_populate_dbh; - } else { - $self->ensure_connected; - } - return $self->_dbh; + # maybe save a ping call + $_[0]->_dbh + ? ( $_[0]->ensure_connected and $_[0]->_dbh ) + : $_[0]->_populate_dbh + ; } # this is the internal "get dbh or connect (don't check)" method sub _get_dbh { - my $self = shift; - $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; - $self->_populate_dbh unless $self->_dbh; - return $self->_dbh; + $_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; + $_[0]->_dbh || $_[0]->_populate_dbh; } +# *DELIBERATELY* not a setter (for the time being) +# Too intertwined with everything else for any kind of sanity sub sql_maker { - my ($self) = @_; + my $self = shift; + + $self->throw_exception('sql_maker() is not a setter method') if @_; + unless ($self->_sql_maker) { my $sql_maker_class = $self->sql_maker_class; @@ -1052,32 +1037,35 @@ sub _rebless {} sub _init {} sub _populate_dbh { - my ($self) = @_; - $self->_dbh(undef); # in case ->connected failed we might get sent here - $self->_dbh_details({}); # reset everything we know + $_[0]->_dbh(undef); # in case ->connected failed we might get sent here + + $_[0]->_dbh_details({}); # reset everything we know - $self->_dbh($self->_connect); + # FIXME - this needs reenabling with the proper "no reset on same DSN" check + #$_[0]->_sql_maker(undef); # this may also end up being different - $self->_conn_pid($$) unless DBIx::Class::_ENV_::BROKEN_FORK; # on win32 these are in fact threads + $_[0]->_dbh($_[0]->_connect); - $self->_determine_driver; + $_[0]->_conn_pid($$) unless DBIx::Class::_ENV_::BROKEN_FORK; # on win32 these are in fact threads + + $_[0]->_determine_driver; # Always set the transaction depth on connect, since # there is no transaction in progress by definition - $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1; + $_[0]->{transaction_depth} = $_[0]->_dbh_autocommit ? 0 : 1; + + $_[0]->_run_connection_actions unless $_[0]->{_in_determine_driver}; - $self->_run_connection_actions unless $self->{_in_determine_driver}; + $_[0]->_dbh; } sub _run_connection_actions { - my $self = shift; - my @actions; - - push @actions, ( $self->on_connect_call || () ); - push @actions, $self->_parse_connect_do ('on_connect_do'); - $self->_do_connection_actions(connect_call_ => $_) for @actions; + $_[0]->_do_connection_actions(connect_call_ => $_) for ( + ( $_[0]->on_connect_call || () ), + $_[0]->_parse_connect_do ('on_connect_do'), + ); } @@ -1122,10 +1110,16 @@ sub get_dbms_capability { sub _server_info { my $self = shift; - my $info; - unless ($info = $self->_dbh_details->{info}) { + # FIXME - ideally this needs to be an ||= assignment, and the final + # assignment at the end of this do{} should be gone entirely. However + # this confuses CXSA: https://rt.cpan.org/Ticket/Display.html?id=103296 + $self->_dbh_details->{info} || do { + + # this guarantees that problematic conninfo won't be hidden + # by the try{} below + $self->ensure_connected; - $info = {}; + my $info = {}; my $server_version = try { $self->_get_server_version @@ -1162,9 +1156,7 @@ sub _server_info { } $self->_dbh_details->{info} = $info; - } - - return $info; + }; } sub _get_server_version { @@ -1304,7 +1296,7 @@ sub _determine_driver { "Your storage subclass @{[ ref $self ]} provides (or inherits) the method " . 'source_bind_attributes() for which support has been removed as of Jan 2013. ' . 'If you are not sure how to proceed please contact the development team via ' - . 'http://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class.pm#GETTING_HELP/SUPPORT' + . DBIx::Class::_ENV_::HELP_URL ); } @@ -1343,7 +1335,7 @@ sub _extract_driver_from_connect_info { sub _determine_connector_driver { my ($self, $conn) = @_; - my $dbtype = $self->_dbh_get_info('SQL_DBMS_NAME'); + my $dbtype = $self->_get_rdbms_name; if (not $dbtype) { $self->_warn_undetermined_driver( @@ -1370,6 +1362,8 @@ sub _determine_connector_driver { } } +sub _get_rdbms_name { shift->_dbh_get_info('SQL_DBMS_NAME') } + sub _warn_undetermined_driver { my ($self, $msg) = @_; @@ -1383,24 +1377,40 @@ sub _warn_undetermined_driver { } sub _do_connection_actions { - my $self = shift; - my $method_prefix = shift; - my $call = shift; - - if (not ref($call)) { - my $method = $method_prefix . $call; - $self->$method(@_); - } elsif (ref($call) eq 'CODE') { - $self->$call(@_); - } elsif (ref($call) eq 'ARRAY') { - if (ref($call->[0]) ne 'ARRAY') { - $self->_do_connection_actions($method_prefix, $_) for @$call; - } else { - $self->_do_connection_actions($method_prefix, @$_) for @$call; + my ($self, $method_prefix, $call, @args) = @_; + + try { + if (not ref($call)) { + my $method = $method_prefix . $call; + $self->$method(@args); + } + elsif (ref($call) eq 'CODE') { + $self->$call(@args); + } + elsif (ref($call) eq 'ARRAY') { + if (ref($call->[0]) ne 'ARRAY') { + $self->_do_connection_actions($method_prefix, $_) for @$call; + } + else { + $self->_do_connection_actions($method_prefix, @$_) for @$call; + } + } + else { + $self->throw_exception (sprintf ("Don't know how to process conection actions of type '%s'", ref($call)) ); } - } else { - $self->throw_exception (sprintf ("Don't know how to process conection actions of type '%s'", ref($call)) ); } + catch { + if ( $method_prefix =~ /^connect/ ) { + # this is an on_connect cycle - we can't just throw while leaving + # a handle in an undefined state in our storage object + # kill it with fire and rethrow + $self->_dbh(undef); + $self->throw_exception( $_[0] ); + } + else { + carp "Disconnect action failed: $_[0]"; + } + }; return $self; } @@ -1415,7 +1425,19 @@ sub disconnect_call_do_sql { $self->_do_query(@_); } -# override in db-specific backend when necessary +=head2 connect_call_datetime_setup + +A no-op stub method, provided so that one can always safely supply the +L + + on_connect_call => 'datetime_setup' + +This way one does not need to know in advance whether the underlying +storage requires any sort of hand-holding when dealing with calendar +data. + +=cut + sub connect_call_datetime_setup { 1 } sub _do_query { @@ -1535,19 +1557,17 @@ sub _connect { } sub txn_begin { - my $self = shift; - # this means we have not yet connected and do not know the AC status # (e.g. coderef $dbh), need a full-fledged connection check - if (! defined $self->_dbh_autocommit) { - $self->ensure_connected; + if (! defined $_[0]->_dbh_autocommit) { + $_[0]->ensure_connected; } # Otherwise simply connect or re-connect on pid changes else { - $self->_get_dbh; + $_[0]->_get_dbh; } - $self->next::method(@_); + shift->next::method(@_); } sub _exec_txn_begin { @@ -1568,9 +1588,8 @@ sub _exec_txn_begin { sub txn_commit { my $self = shift; - $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; $self->throw_exception("Unable to txn_commit() on a disconnected storage") - unless $self->_dbh; + unless $self->_seems_connected; # esoteric case for folks using external $dbh handles if (! $self->transaction_depth and ! $self->_dbh->FETCH('AutoCommit') ) { @@ -1599,9 +1618,8 @@ sub _exec_txn_commit { sub txn_rollback { my $self = shift; - $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; $self->throw_exception("Unable to txn_rollback() on a disconnected storage") - unless $self->_dbh; + unless $self->_seems_connected; # esoteric case for folks using external $dbh handles if (! $self->transaction_depth and ! $self->_dbh->FETCH('AutoCommit') ) { @@ -1627,17 +1645,12 @@ sub _exec_txn_rollback { shift->_dbh->rollback; } -# generate some identical methods -for my $meth (qw/svp_begin svp_release svp_rollback/) { - no strict qw/refs/; - *{__PACKAGE__ ."::$meth"} = subname $meth => sub { - my $self = shift; - $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; - $self->throw_exception("Unable to $meth() on a disconnected storage") - unless $self->_dbh; - $self->next::method(@_); - }; -} +# generate the DBI-specific stubs, which then fallback to ::Storage proper +quote_sub __PACKAGE__ . "::$_" => sprintf (<<'EOS', $_) for qw(svp_begin svp_release svp_rollback); + $_[0]->throw_exception('Unable to %s() on a disconnected storage') + unless $_[0]->_seems_connected; + shift->next::method(@_); +EOS # This used to be the top-half of _execute. It was split out to make it # easier to override in NoBindVars without duping the rest. It takes up @@ -1678,8 +1691,8 @@ sub _gen_sql_bind { ) { carp_unique 'DateTime objects passed to search() are not supported ' . 'properly (InflateColumn::DateTime formats and settings are not ' - . 'respected.) See "Formatting DateTime objects in queries" in ' - . 'DBIx::Class::Manual::Cookbook. To disable this warning for good ' + . 'respected.) See ".. format a DateTime object for searching?" in ' + . 'DBIx::Class::Manual::FAQ. To disable this warning for good ' . 'set $ENV{DBIC_DT_SEARCH_OK} to true' } @@ -1689,13 +1702,10 @@ sub _gen_sql_bind { sub _resolve_bindattrs { my ($self, $ident, $bind, $colinfos) = @_; - $colinfos ||= {}; - my $resolve_bindinfo = sub { #my $infohash = shift; - %$colinfos = %{ $self->_resolve_column_info($ident) } - unless keys %$colinfos; + $colinfos ||= { %{ $self->_resolve_column_info($ident) } }; my $ret; if (my $col = $_[0]->{dbic_colname}) { @@ -1715,10 +1725,16 @@ sub _resolve_bindattrs { my $resolved = ( ref $_ ne 'ARRAY' or @$_ != 2 ) ? [ {}, $_ ] : ( ! defined $_->[0] ) ? [ {}, $_->[1] ] - : (ref $_->[0] eq 'HASH') ? [ (exists $_->[0]{dbd_attrs} or $_->[0]{sqlt_datatype}) - ? $_->[0] - : $resolve_bindinfo->($_->[0]) - , $_->[1] ] + : (ref $_->[0] eq 'HASH') ? [( + ! keys %{$_->[0]} + or + exists $_->[0]{dbd_attrs} + or + $_->[0]{sqlt_datatype} + ) ? $_->[0] + : $resolve_bindinfo->($_->[0]) + , $_->[1] + ] : (ref $_->[0] eq 'SCALAR') ? [ { sqlt_datatype => ${$_->[0]} }, $_->[1] ] : [ $resolve_bindinfo->( { dbic_colname => $_->[0] } @@ -1732,7 +1748,7 @@ sub _resolve_bindattrs { and length ref $resolved->[1] and - ! overload::Method($resolved->[1], '""') + ! is_plain_value $resolved->[1] ) { require Data::Dumper; local $Data::Dumper::Maxdepth = 1; @@ -1781,31 +1797,28 @@ sub _query_end { } sub _dbi_attrs_for_bind { - my ($self, $ident, $bind) = @_; + #my ($self, $ident, $bind) = @_; - my @attrs; + return [ map { - for (map { $_->[0] } @$bind) { - push @attrs, do { - if (exists $_->{dbd_attrs}) { - $_->{dbd_attrs} - } - elsif($_->{sqlt_datatype}) { - # cache the result in the dbh_details hash, as it can not change unless - # we connect to something else - my $cache = $self->_dbh_details->{_datatype_map_cache} ||= {}; - if (not exists $cache->{$_->{sqlt_datatype}}) { - $cache->{$_->{sqlt_datatype}} = $self->bind_attribute_by_data_type($_->{sqlt_datatype}) || undef; - } - $cache->{$_->{sqlt_datatype}}; - } - else { - undef; # always push something at this position - } - } - } + exists $_->{dbd_attrs} ? $_->{dbd_attrs} + + : ! $_->{sqlt_datatype} ? undef + + : do { + + # cache the result in the dbh_details hash, as it (usually) can not change + # unless we connect to something else + # FIXME: for the time being Oracle is an exception, pending a rewrite of + # the LOB storage + my $cache = $_[0]->_dbh_details->{_datatype_map_cache} ||= {}; + + $cache->{$_->{sqlt_datatype}} = $_[0]->bind_attribute_by_data_type($_->{sqlt_datatype}) + if ! exists $cache->{$_->{sqlt_datatype}}; - return \@attrs; + $cache->{$_->{sqlt_datatype}}; + + } } map { $_->[0] } @{$_[2]} ]; } sub _execute { @@ -1886,14 +1899,15 @@ sub _bind_sth_params { ); } else { - # FIXME SUBOPTIMAL - most likely this is not necessary at all - # confirm with dbi-dev whether explicit stringification is needed - my $v = ( length ref $bind->[$i][1] and overload::Method($bind->[$i][1], '""') ) + # FIXME SUBOPTIMAL - DBI needs fixing to always stringify regardless of DBD + my $v = ( length ref $bind->[$i][1] and is_plain_value $bind->[$i][1] ) ? "$bind->[$i][1]" : $bind->[$i][1] ; + $sth->bind_param( $i + 1, + # The temp-var is CRUCIAL - DO NOT REMOVE IT, breaks older DBD::SQLite RT#79576 $v, $bind_attrs->[$i], ); @@ -1914,9 +1928,7 @@ sub _prefetch_autovalues { ( ! exists $to_insert->{$col} or - ref $to_insert->{$col} eq 'SCALAR' - or - (ref $to_insert->{$col} eq 'REF' and ref ${$to_insert->{$col}} eq 'ARRAY') + is_literal_value($to_insert->{$col}) ) ) { $values{$col} = $self->_sequence_fetch( @@ -1953,11 +1965,9 @@ sub insert { } # nothing to retrieve when explicit values are supplied - next if (defined $to_insert->{$col} and ! ( - ref $to_insert->{$col} eq 'SCALAR' - or - (ref $to_insert->{$col} eq 'REF' and ref ${$to_insert->{$col}} eq 'ARRAY') - )); + next if ( + defined $to_insert->{$col} and ! is_literal_value($to_insert->{$col}) + ); # the 'scalar keys' is a trick to preserve the ->columns declaration order $retrieve_cols{$col} = scalar keys %retrieve_cols if ( @@ -2033,26 +2043,28 @@ sub insert { } sub insert_bulk { - my ($self, $source, $cols, $data) = @_; + carp_unique( + 'insert_bulk() should have never been exposed as a public method and ' + . 'calling it is depecated as of Aug 2014. If you believe having a genuine ' + . 'use for this method please contact the development team via ' + . DBIx::Class::_ENV_::HELP_URL + ); - my @col_range = (0..$#$cols); + return '0E0' unless @{$_[3]||[]}; - # FIXME SUBOPTIMAL - most likely this is not necessary at all - # confirm with dbi-dev whether explicit stringification is needed - # - # forcibly stringify whatever is stringifiable - # ResultSet::populate() hands us a copy - safe to mangle - for my $r (0 .. $#$data) { - for my $c (0 .. $#{$data->[$r]}) { - $data->[$r][$c] = "$data->[$r][$c]" - if ( length ref $data->[$r][$c] and overload::Method($data->[$r][$c], '""') ); - } - } + shift->_insert_bulk(@_); +} + +sub _insert_bulk { + my ($self, $source, $cols, $data) = @_; + + $self->throw_exception('Calling _insert_bulk without a dataset to process makes no sense') + unless @{$data||[]}; my $colinfos = $source->columns_info($cols); local $self->{_autoinc_supplied_for_op} = - (first { $_->{is_auto_increment} } values %$colinfos) + (grep { $_->{is_auto_increment} } values %$colinfos) ? 1 : 0 ; @@ -2078,17 +2090,17 @@ sub insert_bulk { # can't just hand SQLA a set of some known "values" (e.g. hashrefs that # can be later matched up by address), because we want to supply a real # value on which perhaps e.g. datatype checks will be performed - my ($proto_data, $value_type_by_col_idx); - for my $i (@col_range) { - my $colname = $cols->[$i]; - if (ref $data->[0][$i] eq 'SCALAR') { + my ($proto_data, $serialized_bind_type_by_col_idx); + for my $col_idx (0..$#$cols) { + my $colname = $cols->[$col_idx]; + if (ref $data->[0][$col_idx] eq 'SCALAR') { # no bind value at all - no type - $proto_data->{$colname} = $data->[0][$i]; + $proto_data->{$colname} = $data->[0][$col_idx]; } - elsif (ref $data->[0][$i] eq 'REF' and ref ${$data->[0][$i]} eq 'ARRAY' ) { + elsif (ref $data->[0][$col_idx] eq 'REF' and ref ${$data->[0][$col_idx]} eq 'ARRAY' ) { # repack, so we don't end up mangling the original \[] - my ($sql, @bind) = @${$data->[0][$i]}; + my ($sql, @bind) = @${$data->[0][$col_idx]}; # normalization of user supplied stuff my $resolved_bind = $self->_resolve_bindattrs( @@ -2097,23 +2109,23 @@ sub insert_bulk { # store value-less (attrs only) bind info - we will be comparing all # supplied binds against this for sanity - $value_type_by_col_idx->{$i} = [ map { $_->[0] } @$resolved_bind ]; + $serialized_bind_type_by_col_idx->{$col_idx} = serialize [ map { $_->[0] } @$resolved_bind ]; $proto_data->{$colname} = \[ $sql, map { [ # inject slice order to use for $proto_bind construction - { %{$resolved_bind->[$_][0]}, _bind_data_slice_idx => $i, _literal_bind_subindex => $_+1 } + { %{$resolved_bind->[$_][0]}, _bind_data_slice_idx => $col_idx, _literal_bind_subindex => $_+1 } => $resolved_bind->[$_][1] ] } (0 .. $#bind) ]; } else { - $value_type_by_col_idx->{$i} = undef; + $serialized_bind_type_by_col_idx->{$col_idx} = undef; $proto_data->{$colname} = \[ '?', [ - { dbic_colname => $colname, _bind_data_slice_idx => $i } + { dbic_colname => $colname, _bind_data_slice_idx => $col_idx } => - $data->[0][$i] + $data->[0][$col_idx] ] ]; } } @@ -2124,11 +2136,11 @@ sub insert_bulk { [ $proto_data ], ); - if (! @$proto_bind and keys %$value_type_by_col_idx) { + if (! @$proto_bind and keys %$serialized_bind_type_by_col_idx) { # if the bindlist is empty and we had some dynamic binds, this means the # storage ate them away (e.g. the NoBindVars component) and interpolated # them directly into the SQL. This obviously can't be good for multi-inserts - $self->throw_exception('Cannot insert_bulk without support for placeholders'); + $self->throw_exception('Unable to invoke fast-path insert without storage placeholder support'); } # sanity checks @@ -2146,19 +2158,19 @@ sub insert_bulk { Data::Dumper::Concise::Dumper ({ map { $cols->[$_] => $data->[$r_idx][$_] - } @col_range + } 0..$#$cols }), } ); }; - for my $col_idx (@col_range) { + for my $col_idx (0..$#$cols) { my $reference_val = $data->[0][$col_idx]; for my $row_idx (1..$#$data) { # we are comparing against what we got from [0] above, hence start from 1 my $val = $data->[$row_idx][$col_idx]; - if (! exists $value_type_by_col_idx->{$col_idx}) { # literal no binds + if (! exists $serialized_bind_type_by_col_idx->{$col_idx}) { # literal no binds if (ref $val ne 'SCALAR') { $bad_slice_report_cref->( "Incorrect value (expecting SCALAR-ref \\'$$reference_val')", @@ -2174,8 +2186,8 @@ sub insert_bulk { ); } } - elsif (! defined $value_type_by_col_idx->{$col_idx} ) { # regular non-literal value - if (ref $val eq 'SCALAR' or (ref $val eq 'REF' and ref $$val eq 'ARRAY') ) { + elsif (! defined $serialized_bind_type_by_col_idx->{$col_idx} ) { # regular non-literal value + if (is_literal_value($val)) { $bad_slice_report_cref->("Literal SQL found where a plain bind value is expected", $row_idx, $col_idx); } } @@ -2202,16 +2214,17 @@ sub insert_bulk { } # need to check the bind attrs - a bind will happen only once for # the entire dataset, so any changes further down will be ignored. - elsif (! Data::Compare::Compare( - $value_type_by_col_idx->{$col_idx}, - [ + elsif ( + $serialized_bind_type_by_col_idx->{$col_idx} + ne + serialize [ map { $_->[0] } @{$self->_resolve_bindattrs( $source, [ @{$$val}[1 .. $#$$val] ], $colinfos, )} - ], - )) { + ] + ) { $bad_slice_report_cref->( 'Differing bind attributes on literal/bind values not supported', $row_idx, @@ -2228,7 +2241,7 @@ sub insert_bulk { # scope guard my $guard = $self->txn_scope_guard; - $self->_query_start( $sql, @$proto_bind ? [[undef => '__BULK_INSERT__' ]] : () ); + $self->_query_start( $sql, @$proto_bind ? [[ {} => '__BULK_INSERT__' ]] : () ); my $sth = $self->_prepare_sth($self->_dbh, $sql); my $rv = do { if (@$proto_bind) { @@ -2242,7 +2255,7 @@ sub insert_bulk { } }; - $self->_query_end( $sql, @$proto_bind ? [[ undef => '__BULK_INSERT__' ]] : () ); + $self->_query_end( $sql, @$proto_bind ? [[ {} => '__BULK_INSERT__' ]] : () ); $guard->commit; @@ -2256,16 +2269,13 @@ sub insert_bulk { sub _dbh_execute_for_fetch { my ($self, $source, $sth, $proto_bind, $cols, $data) = @_; - my @idx_range = ( 0 .. $#$proto_bind ); - # If we have any bind attributes to take care of, we will bind the # proto-bind data (which will never be used by execute_for_fetch) # However since column bindtypes are "sticky", this is sufficient # to get the DBD to apply the bindtype to all values later on - my $bind_attrs = $self->_dbi_attrs_for_bind($source, $proto_bind); - for my $i (@idx_range) { + for my $i (0 .. $#$proto_bind) { $sth->bind_param ( $i+1, # DBI bind indexes are 1-based $proto_bind->[$i][1], @@ -2285,12 +2295,28 @@ sub _dbh_execute_for_fetch { my $fetch_tuple = sub { return undef if ++$fetch_row_idx > $#$data; - return [ map { defined $_->{_literal_bind_subindex} - ? ${ $data->[ $fetch_row_idx ]->[ $_->{_bind_data_slice_idx} ]} - ->[ $_->{_literal_bind_subindex} ] - ->[1] - : $data->[ $fetch_row_idx ]->[ $_->{_bind_data_slice_idx} ] - } map { $_->[0] } @$proto_bind]; + return [ map { + my $v = ! defined $_->{_literal_bind_subindex} + + ? $data->[ $fetch_row_idx ]->[ $_->{_bind_data_slice_idx} ] + + # There are no attributes to resolve here - we already did everything + # when we constructed proto_bind. However we still want to sanity-check + # what the user supplied, so pass stuff through to the resolver *anyway* + : $self->_resolve_bindattrs ( + undef, # a fake rsrc + [ ${ $data->[ $fetch_row_idx ]->[ $_->{_bind_data_slice_idx} ]}->[ $_->{_literal_bind_subindex} ] ], + {}, # a fake column_info bag + )->[0][1] + ; + + # FIXME SUBOPTIMAL - DBI needs fixing to always stringify regardless of DBD + # For the time being forcibly stringify whatever is stringifiable + (length ref $v and is_plain_value $v) + ? "$v" + : $v + ; + } map { $_->[0] } @$proto_bind ]; }; my $tuple_status = []; @@ -2417,20 +2443,12 @@ sub _select_args { #) if $orig_attrs->{!args_as_stored_at_the_end_of_this_method!}; my $sql_maker = $self->sql_maker; - my $alias2source = $self->_resolve_ident_sources ($ident); my $attrs = { %$orig_attrs, select => $select, from => $ident, where => $where, - - # limit dialects use this stuff - # yes, some CDBICompat crap does not supply an {alias} >.< - ( $orig_attrs->{alias} and $alias2source->{$orig_attrs->{alias}} ) - ? ( _rsroot_rsrc => $alias2source->{$orig_attrs->{alias}} ) - : () - , }; # Sanity check the attributes (SQLMaker does it too, but @@ -2467,7 +2485,7 @@ sub _select_args { # are happy (this includes MySQL in strict_mode) # If any of the other joined tables are referenced in the group_by # however - the user is on their own - ( $prefetch_needs_subquery or $attrs->{_related_results_construction} ) + ( $prefetch_needs_subquery or ! $attrs->{_simple_passthrough_construction} ) and $attrs->{group_by} and @@ -2521,6 +2539,8 @@ sub _select_args { $orig_attrs->{_last_sqlmaker_alias_map} = $attrs->{_aliastypes}; ### + # my $alias2source = $self->_resolve_ident_sources ($ident); + # # This would be the point to deflate anything found in $attrs->{where} # (and leave $attrs->{bind} intact). Problem is - inflators historically # expect a result object. And all we have is a resultsource (it is trivial @@ -2585,9 +2605,9 @@ see L. sub _dbh_columns_info_for { my ($self, $dbh, $table) = @_; - if ($dbh->can('column_info')) { - my %result; - my $caught; + my %result; + + if (! DBIx::Class::_ENV_::STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE and $dbh->can('column_info')) { try { my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table); my $sth = $dbh->column_info( undef,$schema, $tab, '%' ); @@ -2604,39 +2624,75 @@ sub _dbh_columns_info_for { $result{$col_name} = \%column_info; } } catch { - $caught = 1; + %result = (); }; - return \%result if !$caught && scalar keys %result; + + return \%result if keys %result; } - my %result; my $sth = $dbh->prepare($self->sql_maker->select($table, undef, \'1 = 0')); $sth->execute; - my @columns = @{$sth->{NAME_lc}}; - for my $i ( 0 .. $#columns ){ - my %column_info; - $column_info{data_type} = $sth->{TYPE}->[$i]; - $column_info{size} = $sth->{PRECISION}->[$i]; - $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0; - - if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) { - $column_info{data_type} = $1; - $column_info{size} = $2; + +### The acrobatics with lc names is necessary to support both the legacy +### API that used NAME_lc exclusively, *AND* at the same time work properly +### with column names differing in cas eonly (thanks pg!) + + my ($columns, $seen_lcs); + + ++$seen_lcs->{lc($_)} and $columns->{$_} = { + idx => scalar keys %$columns, + name => $_, + lc_name => lc($_), + } for @{$sth->{NAME}}; + + $seen_lcs->{$_->{lc_name}} == 1 + and + $_->{name} = $_->{lc_name} + for values %$columns; + + for ( values %$columns ) { + my $inf = { + data_type => $sth->{TYPE}->[$_->{idx}], + size => $sth->{PRECISION}->[$_->{idx}], + is_nullable => $sth->{NULLABLE}->[$_->{idx}] ? 1 : 0, + }; + + if ($inf->{data_type} =~ m/^(.*?)\((.*?)\)$/) { + @{$inf}{qw( data_type size)} = ($1, $2); } - $result{$columns[$i]} = \%column_info; + $result{$_->{name}} = $inf; } + $sth->finish; - foreach my $col (keys %result) { - my $colinfo = $result{$col}; - my $type_num = $colinfo->{data_type}; - my $type_name; - if(defined $type_num && $dbh->can('type_info')) { - my $type_info = $dbh->type_info($type_num); - $type_name = $type_info->{TYPE_NAME} if $type_info; - $colinfo->{data_type} = $type_name if $type_name; + if ($dbh->can('type_info')) { + for my $inf (values %result) { + next if ! defined $inf->{data_type}; + + $inf->{data_type} = ( + ( + ( + $dbh->type_info( $inf->{data_type} ) + || + next + ) + || + next + )->{TYPE_NAME} + || + next + ); + + # FIXME - this may be an artifact of the DBD::Pg implmentation alone + # needs more testing in the future... + $inf->{size} -= 4 if ( + ( $inf->{size}||0 > 4 ) + and + $inf->{data_type} =~ qr/^text$/i + ); } + } return \%result; @@ -2868,11 +2924,12 @@ sub create_ddl_dir { add_drop_table => 1, ignore_constraint_names => 1, ignore_index_names => 1, + quote_identifiers => $self->sql_maker->_quoting_enabled, %{$sqltargs || {}} }; - unless (DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')) { - $self->throw_exception("Can't create a ddl file without " . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') ); + if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('deploy')) { + $self->throw_exception("Can't create a ddl file without $missing"); } my $sqlt = SQL::Translator->new( $sqltargs ); @@ -2962,10 +3019,21 @@ sub create_ddl_dir { unless $dest_schema->name; } - my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db, - $dest_schema, $db, - $sqltargs - ); + my $diff = do { + # FIXME - this is a terrible workaround for + # https://github.com/dbsrgits/sql-translator/commit/2d23c1e + # Fixing it in this sloppy manner so that we don't hve to + # lockstep an SQLT release as well. Needs to be removed at + # some point, and SQLT dep bumped + local $SQL::Translator::Producer::SQLite::NO_QUOTES + if $SQL::Translator::Producer::SQLite::NO_QUOTES; + + SQL::Translator::Diff::schema_diff($source_schema, $db, + $dest_schema, $db, + $sqltargs + ); + }; + if(!open $file, ">$difffile") { $self->throw_exception("Can't write to $difffile ($!)"); next; @@ -2983,7 +3051,8 @@ sub create_ddl_dir { =back -Returns the statements used by L and L. +Returns the statements used by L +and L. The L (not L) database driver name can be explicitly provided in C<$type>, otherwise the result of L is used as default. @@ -3016,8 +3085,8 @@ sub deployment_statements { return join('', @rows); } - unless (DBIx::Class::Optional::Dependencies->req_ok_for ('deploy') ) { - $self->throw_exception("Can't deploy without a ddl_dir or " . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') ); + if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') ) { + $self->throw_exception("Can't deploy without a pregenerated 'ddl_dir' directory or $missing"); } # sources needs to be a parser arg, but for simplicity allow at top level @@ -3025,6 +3094,9 @@ sub deployment_statements { $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources} if exists $sqltargs->{sources}; + $sqltargs->{quote_identifiers} = $self->sql_maker->_quoting_enabled + unless exists $sqltargs->{quote_identifiers}; + my $tr = SQL::Translator->new( producer => "SQL::Translator::Producer::${type}", %$sqltargs, @@ -3257,13 +3329,13 @@ transactions. You're on your own for handling all sorts of exceptional cases if you choose the C<< AutoCommit => 0 >> path, just as you would be with raw DBI. +=head1 FURTHER QUESTIONS? -=head1 AUTHOR AND CONTRIBUTORS - -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. - -=cut +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Storage/DBI/ACCESS.pm b/lib/DBIx/Class/Storage/DBI/ACCESS.pm index 93841170b..7490d8951 100644 --- a/lib/DBIx/Class/Storage/DBI/ACCESS.pm +++ b/lib/DBIx/Class/Storage/DBI/ACCESS.pm @@ -122,15 +122,19 @@ sub _exec_svp_rollback { $self->_exec_txn_rollback; } -1; - -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -See L and L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut + +1; + # vim:sts=2 sw=2: diff --git a/lib/DBIx/Class/Storage/DBI/ADO.pm b/lib/DBIx/Class/Storage/DBI/ADO.pm index db8517dc3..4244aa787 100644 --- a/lib/DBIx/Class/Storage/DBI/ADO.pm +++ b/lib/DBIx/Class/Storage/DBI/ADO.pm @@ -75,15 +75,19 @@ sub _init { # $sth; #} -1; - -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -See L and L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut + +1; + # vim:sts=2 sw=2: diff --git a/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet.pm b/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet.pm index 8eb1719bc..c7cb5c3fe 100644 --- a/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet.pm +++ b/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet.pm @@ -141,15 +141,19 @@ sub format_datetime { return $datetime_parser->format_datetime(shift); } -1; - -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -See L and L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut + +1; + # vim:sts=2 sw=2: diff --git a/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet/Cursor.pm b/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet/Cursor.pm index 5c50ca334..8b1a78290 100644 --- a/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet/Cursor.pm +++ b/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet/Cursor.pm @@ -64,16 +64,19 @@ sub all { return @rows; } -1; - -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -See L and L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut +1; + # vim:sts=2 sw=2: diff --git a/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server.pm b/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server.pm index 09cbee649..ac42a1eeb 100644 --- a/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server.pm +++ b/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server.pm @@ -60,7 +60,7 @@ size of the bind sizes in the first prepare call: L -The C workaround is used (see L) with the +The C workaround is used (see L) with the approximate maximum size of the data_type of the bound column, or 8000 (maximum VARCHAR size) if the data_type is not available. @@ -182,16 +182,18 @@ sub _dbi_attrs_for_bind { my $attrs = $self->next::method(@_); - foreach my $attr (@$attrs) { - $attr->{ado_size} ||= 8000 if $attr; - } + # The next::method above caches the returned hashrefs in a _dbh related + # structure. It is safe for us to modify it in this manner, as the default + # does not really change (albeit the entire logic is insane and is pending + # a datatype-objects rewrite) + $_ and $_->{ado_size} ||= 8000 for @$attrs; return $attrs; } -# Can't edit all the binds in _dbi_attrs_for_bind for insert_bulk, so we take +# Can't edit all the binds in _dbi_attrs_for_bind for _insert_bulk, so we take # care of those GUIDs here. -sub insert_bulk { +sub _insert_bulk { my $self = shift; my ($source, $cols, $data) = @_; @@ -436,15 +438,19 @@ sub format_datetime { return $datetime_parser->format_datetime(shift); } -1; - -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -See L and L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut + +1; + # vim:sts=2 sw=2: diff --git a/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server/Cursor.pm b/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server/Cursor.pm index 1ada243ba..6253ee6a5 100644 --- a/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server/Cursor.pm +++ b/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server/Cursor.pm @@ -87,16 +87,19 @@ sub all { return @rows; } -1; - -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -See L and L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut +1; + # vim:sts=2 sw=2: diff --git a/lib/DBIx/Class/Storage/DBI/AutoCast.pm b/lib/DBIx/Class/Storage/DBI/AutoCast.pm index db9fb8b5e..37ed620b4 100644 --- a/lib/DBIx/Class/Storage/DBI/AutoCast.pm +++ b/lib/DBIx/Class/Storage/DBI/AutoCast.pm @@ -23,7 +23,8 @@ statements with values bound to columns or conditions that are not strings will throw implicit type conversion errors. As long as a column L is -defined and resolves to a base RDBMS native type via L as +defined and resolves to a base RDBMS native type via +L<_native_data_type|DBIx::Class::Storage::DBI/_native_data_type> as defined in your Storage driver, the placeholder for this column will be converted to: @@ -77,13 +78,16 @@ sub connect_call_set_auto_cast { $self->auto_cast(1); } -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -See L +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut diff --git a/lib/DBIx/Class/Storage/DBI/Cursor.pm b/lib/DBIx/Class/Storage/DBI/Cursor.pm index 6681d2354..6fdfdf9e4 100644 --- a/lib/DBIx/Class/Storage/DBI/Cursor.pm +++ b/lib/DBIx/Class/Storage/DBI/Cursor.pm @@ -3,10 +3,12 @@ package DBIx::Class::Storage::DBI::Cursor; use strict; use warnings; -use base qw/DBIx::Class::Cursor/; +use base 'DBIx::Class::Cursor'; use Try::Tiny; -use Scalar::Util qw/refaddr weaken/; +use Scalar::Util qw(refaddr weaken); +use List::Util 'shuffle'; +use DBIx::Class::_Util 'detected_reinvoked_destructor'; use namespace::clean; __PACKAGE__->mk_group_accessors('simple' => @@ -177,7 +179,14 @@ sub all { (undef, $sth) = $self->storage->_select( @{$self->{args}} ); - return @{$sth->fetchall_arrayref}; + return ( + DBIx::Class::_ENV_::SHUFFLE_UNORDERED_RESULTSETS + and + ! $self->{attrs}{order_by} + ) + ? shuffle @{$sth->fetchall_arrayref} + : @{$sth->fetchall_arrayref} + ; } sub sth { @@ -225,6 +234,8 @@ sub reset { sub DESTROY { + return if &detected_reinvoked_destructor; + $_[0]->__finish_sth if $_[0]->{sth}; } @@ -245,4 +256,17 @@ sub __finish_sth { ); } +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. + +=cut + 1; diff --git a/lib/DBIx/Class/Storage/DBI/DB2.pm b/lib/DBIx/Class/Storage/DBI/DB2.pm index 7634eb61f..c34e641cb 100644 --- a/lib/DBIx/Class/Storage/DBI/DB2.pm +++ b/lib/DBIx/Class/Storage/DBI/DB2.pm @@ -60,8 +60,6 @@ sub _dbh_last_insert_id { return @res ? $res[0] : undef; } -1; - =head1 NAME DBIx::Class::Storage::DBI::DB2 - IBM DB2 support for DBIx::Class @@ -73,13 +71,19 @@ RowNumberOver over FetchFirst depending on the availability of support for RowNumberOver, queries the server name_sep from L and sets the L parser to L. -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -See L and L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut + +1; + # vim:sts=2 sw=2: diff --git a/lib/DBIx/Class/Storage/DBI/Firebird.pm b/lib/DBIx/Class/Storage/DBI/Firebird.pm index f0178bd09..588dce6e1 100644 --- a/lib/DBIx/Class/Storage/DBI/Firebird.pm +++ b/lib/DBIx/Class/Storage/DBI/Firebird.pm @@ -8,9 +8,10 @@ use warnings; # in ::Storage::DBI::InterBase as opposed to inheriting # directly from ::Storage::DBI::Firebird::Common use base qw/DBIx::Class::Storage::DBI::InterBase/; - use mro 'c3'; +1; + =head1 NAME DBIx::Class::Storage::DBI::Firebird - Driver for the Firebird RDBMS via @@ -21,17 +22,13 @@ L This is an empty subclass of L for use with L, see that driver for details. -=cut - -1; - -=head1 AUTHOR - -See L and L. +=head1 FURTHER QUESTIONS? -=head1 LICENSE +Check the list of L. -You may distribute this code under the same terms as Perl itself. +=head1 COPYRIGHT AND LICENSE -=cut -# vim:sts=2 sw=2: +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Storage/DBI/Firebird/Common.pm b/lib/DBIx/Class/Storage/DBI/Firebird/Common.pm index 7e6b51846..6e61ca5cb 100644 --- a/lib/DBIx/Class/Storage/DBI/Firebird/Common.pm +++ b/lib/DBIx/Class/Storage/DBI/Firebird/Common.pm @@ -164,8 +164,6 @@ sub format_date { return $date_parser->format_datetime(shift); } -1; - =head1 CAVEATS =over 4 @@ -178,13 +176,19 @@ work with earlier versions. =back -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -See L and L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut + +1; + # vim:sts=2 sw=2: diff --git a/lib/DBIx/Class/Storage/DBI/IdentityInsert.pm b/lib/DBIx/Class/Storage/DBI/IdentityInsert.pm index 5483af4d3..8485e86fc 100644 --- a/lib/DBIx/Class/Storage/DBI/IdentityInsert.pm +++ b/lib/DBIx/Class/Storage/DBI/IdentityInsert.pm @@ -41,6 +41,11 @@ sub _prep_for_execute { my $table = $self->sql_maker->_quote($ident->name); $op = uc $op; + DBIx::Class::Exception->throw( + "Unexpected _autoinc_supplied_for_op flag in callstack - please file a bug including the stacktrace ( @{[ DBIx::Class::_ENV_::HELP_URL() ]} ):\n\n STACKTRACE STARTS", + 'stacktrace' + ) if $op ne 'INSERT' and $op ne 'UPDATE'; + my ($sql, $bind) = $self->next::method(@_); return (< and L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut diff --git a/lib/DBIx/Class/Storage/DBI/Informix.pm b/lib/DBIx/Class/Storage/DBI/Informix.pm index ca6bf55e4..e8c123d4c 100644 --- a/lib/DBIx/Class/Storage/DBI/Informix.pm +++ b/lib/DBIx/Class/Storage/DBI/Informix.pm @@ -169,14 +169,18 @@ sub format_date { return $date_parser->format_datetime(shift); } -1; - -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -See L and L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut + +1; + diff --git a/lib/DBIx/Class/Storage/DBI/InterBase.pm b/lib/DBIx/Class/Storage/DBI/InterBase.pm index cb6d8f9d6..0793a0f78 100644 --- a/lib/DBIx/Class/Storage/DBI/InterBase.pm +++ b/lib/DBIx/Class/Storage/DBI/InterBase.pm @@ -131,8 +131,6 @@ sub connect_call_datetime_setup { $self->_get_dbh->{ib_time_all} = 'ISO'; } -1; - =head1 CAVEATS =over 4 @@ -149,13 +147,19 @@ Alternately, use the L driver. =back -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -See L and L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut + +1; + # vim:sts=2 sw=2: diff --git a/lib/DBIx/Class/Storage/DBI/MSSQL.pm b/lib/DBIx/Class/Storage/DBI/MSSQL.pm index 34d3745d3..5b4c422b2 100644 --- a/lib/DBIx/Class/Storage/DBI/MSSQL.pm +++ b/lib/DBIx/Class/Storage/DBI/MSSQL.pm @@ -327,12 +327,13 @@ for this flag - you are urged to do so. If DBIC internals insist that an ordered subselect is necessary for an operation, and you believe there is a different/better way to get the same result - please file a bugreport. -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -See L and L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. - -=cut +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Storage/DBI/NoBindVars.pm b/lib/DBIx/Class/Storage/DBI/NoBindVars.pm index 85810cc04..281e67edf 100644 --- a/lib/DBIx/Class/Storage/DBI/NoBindVars.pm +++ b/lib/DBIx/Class/Storage/DBI/NoBindVars.pm @@ -119,13 +119,16 @@ sub _prep_interpolated_value { return $_[2]; } -=head1 AUTHORS +=head1 FURTHER QUESTIONS? -See L +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut diff --git a/lib/DBIx/Class/Storage/DBI/ODBC.pm b/lib/DBIx/Class/Storage/DBI/ODBC.pm index 1e8851b20..5a6d078c3 100644 --- a/lib/DBIx/Class/Storage/DBI/ODBC.pm +++ b/lib/DBIx/Class/Storage/DBI/ODBC.pm @@ -50,8 +50,6 @@ sub _disable_odbc_array_ops { } } -1; - =head1 NAME DBIx::Class::Storage::DBI::ODBC - Base class for ODBC drivers @@ -61,13 +59,19 @@ DBIx::Class::Storage::DBI::ODBC - Base class for ODBC drivers This class simply provides a mechanism for discovering and loading a sub-class for a specific ODBC backend. It should be transparent to the user. -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -See L and L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut + +1; + # vim:sts=2 sw=2: diff --git a/lib/DBIx/Class/Storage/DBI/ODBC/ACCESS.pm b/lib/DBIx/Class/Storage/DBI/ODBC/ACCESS.pm index e8cca9af6..69b3b9b78 100644 --- a/lib/DBIx/Class/Storage/DBI/ODBC/ACCESS.pm +++ b/lib/DBIx/Class/Storage/DBI/ODBC/ACCESS.pm @@ -143,15 +143,19 @@ sub format_datetime { return $datetime_parser->format_datetime(shift); } -1; - -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -See L and L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut + +1; + # vim:sts=2 sw=2: diff --git a/lib/DBIx/Class/Storage/DBI/ODBC/DB2_400_SQL.pm b/lib/DBIx/Class/Storage/DBI/ODBC/DB2_400_SQL.pm index e17715cec..8ff7d1f2a 100644 --- a/lib/DBIx/Class/Storage/DBI/ODBC/DB2_400_SQL.pm +++ b/lib/DBIx/Class/Storage/DBI/ODBC/DB2_400_SQL.pm @@ -20,13 +20,14 @@ over ODBC This is an empty subclass of L. -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -See L and L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. -=cut -# vim:sts=2 sw=2: diff --git a/lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm b/lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm index 095f41663..2b555baf9 100644 --- a/lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm +++ b/lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm @@ -59,13 +59,20 @@ sub _exec_svp_rollback { }; } -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -See L and L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. -You may distribute this code under the same terms as Perl itself. =cut + # vim:sts=2 sw=2: + +1; diff --git a/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm b/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm index 911ca48d3..171313888 100644 --- a/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm +++ b/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm @@ -308,15 +308,19 @@ sub connect_call_use_server_cursors { $self->_get_dbh->{odbc_SQL_ROWSET_SIZE} = $sql_rowset_size; } -1; - -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -See L and L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut + +1; + # vim:sw=2 sts=2 et diff --git a/lib/DBIx/Class/Storage/DBI/ODBC/SQL_Anywhere.pm b/lib/DBIx/Class/Storage/DBI/ODBC/SQL_Anywhere.pm index 0a6bd1aba..32b8984f8 100644 --- a/lib/DBIx/Class/Storage/DBI/ODBC/SQL_Anywhere.pm +++ b/lib/DBIx/Class/Storage/DBI/ODBC/SQL_Anywhere.pm @@ -32,12 +32,14 @@ fail with: B use the C type instead, it is more efficient anyway. -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -See L and L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. -=cut diff --git a/lib/DBIx/Class/Storage/DBI/Oracle.pm b/lib/DBIx/Class/Storage/DBI/Oracle.pm index b0184e8fc..6dd8b724e 100644 --- a/lib/DBIx/Class/Storage/DBI/Oracle.pm +++ b/lib/DBIx/Class/Storage/DBI/Oracle.pm @@ -40,12 +40,13 @@ no matter the database version, add to your Schema class. -=head1 AUTHOR AND CONTRIBUTORS +=head1 FURTHER QUESTIONS? -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. - -=cut +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm index d76395364..1780d512e 100644 --- a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm +++ b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm @@ -103,9 +103,6 @@ sub deployment_statements { my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_; $sqltargs ||= {}; - my $quote_char = $self->schema->storage->sql_maker->quote_char; - $sqltargs->{quote_table_names} = $quote_char ? 1 : 0; - $sqltargs->{quote_field_names} = $quote_char ? 1 : 0; if ( ! exists $sqltargs->{producer_args}{oracle_version} @@ -422,11 +419,18 @@ sub _dbi_attrs_for_bind { my $attrs = $self->next::method($ident, $bind); - for my $i (0 .. $#$attrs) { - if (keys %{$attrs->[$i]||{}} and my $col = $bind->[$i][0]{dbic_colname}) { - $attrs->[$i]{ora_field} = $col; - } - } + # Push the column name into all bind attrs, make sure to *NOT* write into + # the existing $attrs->[$idx]{..} hashref, as it is cached by the call to + # next::method above. + # FIXME - this code will go away when the LobWriter refactor lands + $attrs->[$_] + and + keys %{ $attrs->[$_] } + and + $bind->[$_][0]{dbic_colname} + and + $attrs->[$_] = { %{$attrs->[$_]}, ora_field => $bind->[$_][0]{dbic_colname} } + for 0 .. $#$attrs; $attrs; } @@ -638,7 +642,7 @@ Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so the L name is shortened and appended with half of an MD5 hash. -See L. +See L. =cut @@ -766,13 +770,16 @@ It uses the same syntax as L # ORDER SIBLINGS BY # firstname ASC -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -See L and L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut diff --git a/lib/DBIx/Class/Storage/DBI/Oracle/WhereJoins.pm b/lib/DBIx/Class/Storage/DBI/Oracle/WhereJoins.pm index c0b46e827..5dd6e2fa2 100644 --- a/lib/DBIx/Class/Storage/DBI/Oracle/WhereJoins.pm +++ b/lib/DBIx/Class/Storage/DBI/Oracle/WhereJoins.pm @@ -68,16 +68,13 @@ Probably lots more. =back -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -Justin Wheeler C<< >> +Check the list of L. -=head1 CONTRIBUTORS +=head1 COPYRIGHT AND LICENSE -David Jack Olrik C<< >> - -=head1 LICENSE - -This module is licensed under the same terms as Perl itself. - -=cut +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Storage/DBI/Pg.pm b/lib/DBIx/Class/Storage/DBI/Pg.pm index fcdab67b2..7c2033098 100644 --- a/lib/DBIx/Class/Storage/DBI/Pg.pm +++ b/lib/DBIx/Class/Storage/DBI/Pg.pm @@ -266,12 +266,13 @@ option to connect(), for example: }, ); -=head1 AUTHORS +=head1 FURTHER QUESTIONS? -See L +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. - -=cut +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Storage/DBI/Replicated.pm b/lib/DBIx/Class/Storage/DBI/Replicated.pm index 3c58716ed..92a0e175b 100644 --- a/lib/DBIx/Class/Storage/DBI/Replicated.pm +++ b/lib/DBIx/Class/Storage/DBI/Replicated.pm @@ -1,9 +1,13 @@ package DBIx::Class::Storage::DBI::Replicated; +use warnings; +use strict; + BEGIN { - use DBIx::Class; - die('The following modules are required for Replication ' . DBIx::Class::Optional::Dependencies->req_missing_for ('replicated') . "\n" ) - unless DBIx::Class::Optional::Dependencies->req_ok_for ('replicated'); + require DBIx::Class::Optional::Dependencies; + if ( my $missing = DBIx::Class::Optional::Dependencies->req_missing_for('replicated') ) { + die "The following modules are required for Replicated storage support: $missing\n"; + } } use Moose; @@ -20,8 +24,6 @@ use Try::Tiny; use namespace::clean -except => 'meta'; -=encoding utf8 - =head1 NAME DBIx::Class::Storage::DBI::Replicated - BETA Replicated database support @@ -265,7 +267,6 @@ my $method_dispatch = { build_datetime_parser last_insert_id insert - insert_bulk update delete dbh @@ -310,11 +311,14 @@ my $method_dispatch = { _parse_connect_do savepoints _sql_maker_opts + _use_multicolumn_in _conn_pid _dbh_autocommit _native_data_type _get_dbh sql_maker_class + insert_bulk + _insert_bulk _execute _do_query _dbh_execute @@ -336,6 +340,7 @@ my $method_dispatch = { set_dbms_capability _dbh_details _dbh_get_info + _get_rdbms_name _determine_connector_driver _extract_driver_from_connect_info @@ -364,7 +369,7 @@ my $method_dispatch = { # the capability framework # not sure if CMOP->initialize does evil things to DBIC::S::DBI, fix if a problem grep - { $_ =~ /^ _ (?: use | supports | determine_supports ) _ /x } + { $_ =~ /^ _ (?: use | supports | determine_supports ) _ /x and $_ ne '_use_multicolumn_in' } ( Class::MOP::Class->initialize('DBIx::Class::Storage::DBI')->get_all_method_names ) )], }; @@ -404,7 +409,7 @@ for my $method (@{$method_dispatch->{unimplemented}}) { =head2 read_handler -Defines an object that implements the read side of L. +Defines an object that implements the read side of L. =cut @@ -417,7 +422,7 @@ has 'read_handler' => ( =head2 write_handler -Defines an object that implements the write side of L, +Defines an object that implements the write side of L, as well as methods that don't write or read that can be called on only one storage, methods that return a C<$dbh>, and any methods that don't make sense to run on a replicant. @@ -589,7 +594,8 @@ sub _build_read_handler { =head2 around: connect_replicants All calls to connect_replicants needs to have an existing $schema tacked onto -top of the args, since L needs it, and any C +top of the args, since L needs it, and any +L options merged with the master, with replicant opts having higher priority. =cut @@ -1080,7 +1086,8 @@ sub _get_server_version { Due to the fact that replicants can lag behind a master, you must take care to make sure you use one of the methods to force read queries to a master should you need realtime data integrity. For example, if you insert a row, and then -immediately re-read it from the database (say, by doing $result->discard_changes) +immediately re-read it from the database (say, by doing +L<< $result->discard_changes|DBIx::Class::Row/discard_changes >>) or you insert a row and then immediately build a query that expects that row to be an item, you should force the master to handle reads. Otherwise, due to the lag, there is no certainty your data will be in the expected state. @@ -1112,18 +1119,16 @@ using the Schema clone method. ## $new_schema will use only the Master storage for all reads/writes while ## the $schema object will use replicated storage. -=head1 AUTHOR - - John Napiorkowski - -Based on code originated by: +=head1 FURTHER QUESTIONS? - Norbert Csongrádi - Peter Siklósi +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut diff --git a/lib/DBIx/Class/Storage/DBI/Replicated/Balancer.pm b/lib/DBIx/Class/Storage/DBI/Replicated/Balancer.pm index de9c2e923..26e35809f 100644 --- a/lib/DBIx/Class/Storage/DBI/Replicated/Balancer.pm +++ b/lib/DBIx/Class/Storage/DBI/Replicated/Balancer.pm @@ -97,7 +97,7 @@ This class defines the following methods. =head2 _build_current_replicant -Lazy builder for the L attribute. +Lazy builder for the L attribute. =cut @@ -243,13 +243,16 @@ sub _get_forced_pool { } } -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -John Napiorkowski +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut diff --git a/lib/DBIx/Class/Storage/DBI/Replicated/Balancer/First.pm b/lib/DBIx/Class/Storage/DBI/Replicated/Balancer/First.pm index 806a05f0b..c7a160eb5 100644 --- a/lib/DBIx/Class/Storage/DBI/Replicated/Balancer/First.pm +++ b/lib/DBIx/Class/Storage/DBI/Replicated/Balancer/First.pm @@ -39,13 +39,16 @@ sub next_storage { return (shift->pool->active_replicants)[0]; } -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -John Napiorkowski +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut diff --git a/lib/DBIx/Class/Storage/DBI/Replicated/Balancer/Random.pm b/lib/DBIx/Class/Storage/DBI/Replicated/Balancer/Random.pm index 1fc7b94e7..6b430f466 100644 --- a/lib/DBIx/Class/Storage/DBI/Replicated/Balancer/Random.pm +++ b/lib/DBIx/Class/Storage/DBI/Replicated/Balancer/Random.pm @@ -78,13 +78,16 @@ sub _random_number { rand($_[1]) } -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -John Napiorkowski +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut diff --git a/lib/DBIx/Class/Storage/DBI/Replicated/Introduction.pod b/lib/DBIx/Class/Storage/DBI/Replicated/Introduction.pod index 0b49b984f..a95f3cd2c 100644 --- a/lib/DBIx/Class/Storage/DBI/Replicated/Introduction.pod +++ b/lib/DBIx/Class/Storage/DBI/Replicated/Introduction.pod @@ -1,24 +1,22 @@ -package DBIx::Class::Storage::DBI::Replicated::Introduction; - =head1 NAME DBIx::Class::Storage::DBI::Replicated::Introduction - Minimum Need to Know =head1 SYNOPSIS -This is an introductory document for L. +This is an introductory document for L. This document is not an overview of what replication is or why you should be -using it. It is not a document explaining how to setup MySQL native replication -either. Copious external resources are available for both. This document +using it. It is not a document explaining how to setup MySQL native replication +either. Copious external resources are available for both. This document presumes you have the basics down. =head1 DESCRIPTION -L supports a framework for using database replication. This system +L supports a framework for using database replication. This system is integrated completely, which means once it's setup you should be able to automatically just start using a replication cluster without additional work or -changes to your code. Some caveats apply, primarily related to the proper use +changes to your code. Some caveats apply, primarily related to the proper use of transactions (you are wrapping all your database modifying statements inside a transaction, right ;) ) however in our experience properly written DBIC will work transparently with Replicated storage. @@ -137,7 +135,7 @@ will result in increased database loads, so choose a number with care. Our experience is that setting the number around 5 seconds results in a good performance / integrity balance. -'master_read_weight' is an option associated with the ::Random balancer. It +'master_read_weight' is an option associated with the ::Random balancer. It allows you to let the master be read from. I usually leave this off (default is off). @@ -171,14 +169,14 @@ will find L an easy way to set up a replication cluster. And now your $schema object is properly configured! Enjoy! -=head1 AUTHOR - -John Napiorkowski +=head1 FURTHER QUESTIONS? -=head1 LICENSE +Check the list of L. -You may distribute this code under the same terms as Perl itself. +=head1 COPYRIGHT AND LICENSE -=cut +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. -1; diff --git a/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm b/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm index 8b1501605..9980b4d21 100644 --- a/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm +++ b/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm @@ -410,13 +410,16 @@ sub validate_replicants { $self->_last_validated(time); } -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -John Napiorkowski +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut diff --git a/lib/DBIx/Class/Storage/DBI/Replicated/Replicant.pm b/lib/DBIx/Class/Storage/DBI/Replicated/Replicant.pm index a541e7df2..7c6084b14 100644 --- a/lib/DBIx/Class/Storage/DBI/Replicated/Replicant.pm +++ b/lib/DBIx/Class/Storage/DBI/Replicated/Replicant.pm @@ -38,7 +38,9 @@ when it gets too far behind the master, if it stops replicating, etc. This attribute DOES NOT reflect a replicant's internal status, i.e. if it is properly replicating from a master and has not fallen too many seconds behind a -reliability threshold. For that, use L and L. +reliability threshold. For that, use +L and +L. Since the implementation of those functions database specific (and not all DBIC supported DBs support replication) you should refer your database-specific storage driver for more information. @@ -85,13 +87,16 @@ sub debugobj { L, L -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -John Napiorkowski +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut diff --git a/lib/DBIx/Class/Storage/DBI/Replicated/Types.pm b/lib/DBIx/Class/Storage/DBI/Replicated/Types.pm index 0fcb9b221..0782a6eda 100644 --- a/lib/DBIx/Class/Storage/DBI/Replicated/Types.pm +++ b/lib/DBIx/Class/Storage/DBI/Replicated/Types.pm @@ -35,12 +35,4 @@ subtype Weight, where { $_ >= 0 }, message { 'weight must be a decimal greater than 0' }; -# AUTHOR -# -# John Napiorkowski -# -# LICENSE -# -# You may distribute this code under the same terms as Perl itself. - 1; diff --git a/lib/DBIx/Class/Storage/DBI/Replicated/WithDSN.pm b/lib/DBIx/Class/Storage/DBI/Replicated/WithDSN.pm index f26eb3c21..46b14301d 100644 --- a/lib/DBIx/Class/Storage/DBI/Replicated/WithDSN.pm +++ b/lib/DBIx/Class/Storage/DBI/Replicated/WithDSN.pm @@ -57,13 +57,16 @@ around '_query_start' => sub { L -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -John Napiorkowski +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut diff --git a/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm b/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm index b8309213d..9cdd038c8 100644 --- a/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm +++ b/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm @@ -139,15 +139,14 @@ sub select_single { sub build_datetime_parser { my $self = shift; - my $type = "DateTime::Format::Strptime"; try { - eval "require ${type}" + require DateTime::Format::Strptime; } catch { - $self->throw_exception("Couldn't load ${type}: $_"); + $self->throw_exception("Couldn't load DateTime::Format::Strptime: $_"); }; - return $type->new( pattern => '%Y-%m-%d %H:%M:%S.%6N' ); + return DateTime::Format::Strptime->new( pattern => '%Y-%m-%d %H:%M:%S.%6N' ); } =head2 connect_call_datetime_setup @@ -212,12 +211,13 @@ be turned off (or increased) by the DBA by executing: Highly recommended. -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -See L and L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. - -=cut +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Storage/DBI/SQLAnywhere/Cursor.pm b/lib/DBIx/Class/Storage/DBI/SQLAnywhere/Cursor.pm index 189562e86..a341b20f4 100644 --- a/lib/DBIx/Class/Storage/DBI/SQLAnywhere/Cursor.pm +++ b/lib/DBIx/Class/Storage/DBI/SQLAnywhere/Cursor.pm @@ -85,15 +85,19 @@ sub all { return @rows; } -1; - -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -See L and L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut + +1; + # vim:sts=2 sw=2: diff --git a/lib/DBIx/Class/Storage/DBI/SQLite.pm b/lib/DBIx/Class/Storage/DBI/SQLite.pm index 2e4e312c8..4311bdf7e 100644 --- a/lib/DBIx/Class/Storage/DBI/SQLite.pm +++ b/lib/DBIx/Class/Storage/DBI/SQLite.pm @@ -6,6 +6,7 @@ use warnings; use base qw/DBIx::Class::Storage::DBI/; use mro 'c3'; +use SQL::Abstract 'is_plain_value'; use DBIx::Class::_Util qw(modver_gt_or_eq sigwarn_silencer); use DBIx::Class::Carp; use Try::Tiny; @@ -60,14 +61,9 @@ stringifiable object. Even if you upgrade DBIx::Class (which works around the bug starting from version 0.08210) you may still have corrupted/incorrect data in your database. -DBIx::Class will currently detect when this condition (more than one -stringifiable object in one CRUD call) is encountered and will issue a warning -pointing to this section. This warning will be removed 2 years from now, -around April 2015, You can disable it after you've audited your data by -setting the C environment variable. Note - the warning -is emitted only once per callsite per process and only when the condition in -question is encountered. Thus it is very unlikely that your logsystem will be -flooded as a result of this. +DBIx::Class warned about this condition for several years, hoping to give +anyone affected sufficient notice of the potential issues. The warning was +removed in version 0.082900. =back @@ -126,11 +122,23 @@ sub _exec_svp_release { sub _exec_svp_rollback { my ($self, $name) = @_; - # For some reason this statement changes the value of $dbh->{AutoCommit}, so - # we localize it here to preserve the original value. - local $self->_dbh->{AutoCommit} = $self->_dbh->{AutoCommit}; + $self->_dbh->do("ROLLBACK TO SAVEPOINT $name"); +} + +# older SQLite has issues here too - both of these are in fact +# completely benign warnings (or at least so say the tests) +sub _exec_txn_rollback { + local $SIG{__WARN__} = sigwarn_silencer( qr/rollback ineffective/ ) + unless $DBD::SQLite::__DBIC_TXN_SYNC_SANE__; + + shift->next::method(@_); +} + +sub _exec_txn_commit { + local $SIG{__WARN__} = sigwarn_silencer( qr/commit ineffective/ ) + unless $DBD::SQLite::__DBIC_TXN_SYNC_SANE__; - $self->_dbh->do("ROLLBACK TRANSACTION TO SAVEPOINT $name"); + shift->next::method(@_); } sub _ping { @@ -232,10 +240,6 @@ sub deployment_statements { $sqltargs->{producer_args}{sqlite_version} = $dver; } - $sqltargs->{quote_identifiers} - = !!$self->sql_maker->_quote_chars - if ! exists $sqltargs->{quote_identifiers}; - $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest); } @@ -308,14 +312,7 @@ sub _dbi_attrs_for_bind { = modver_gt_or_eq('DBD::SQLite', '1.37') ? 1 : 0; } - # an attempt to detect former effects of RT#79576, bug itself present between - # 0.08191 and 0.08209 inclusive (fixed in 0.08210 and higher) - my $stringifiable = 0; - for my $i (0.. $#$bindattrs) { - - $stringifiable++ if ( length ref $bind->[$i][1] and overload::Method($bind->[$i][1], '""') ); - if ( defined $bindattrs->[$i] and @@ -358,14 +355,6 @@ sub _dbi_attrs_for_bind { } } - carp_unique( - 'POSSIBLE *PAST* DATA CORRUPTION detected - see ' - . 'DBIx::Class::Storage::DBI::SQLite/RT79576 or ' - . 'http://v.gd/DBIC_SQLite_RT79576 for further details or set ' - . '$ENV{DBIC_RT79576_NOWARN} to disable this warning. Trigger ' - . 'condition encountered' - ) if (!$ENV{DBIC_RT79576_NOWARN} and $stringifiable > 1); - return $bindattrs; } @@ -394,14 +383,17 @@ sub connect_call_use_foreign_keys { ); } -1; - -=head1 AUTHOR AND CONTRIBUTORS +=head1 FURTHER QUESTIONS? -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut + +1; diff --git a/lib/DBIx/Class/Storage/DBI/Sybase.pm b/lib/DBIx/Class/Storage/DBI/Sybase.pm index 79a449e06..628832537 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase.pm @@ -21,28 +21,25 @@ L =cut -sub _rebless { +sub _rebless { shift->_determine_connector_driver('Sybase') } + +sub _get_rdbms_name { my $self = shift; - my $dbtype; try { - $dbtype = @{$self->_get_dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2] - } catch { - $self->throw_exception("Unable to establish connection to determine database type: $_") - }; + my $name = $self->_get_dbh->selectrow_arrayref('sp_server_info @attribute_id=1')->[2]; - if ($dbtype) { - $dbtype =~ s/\W/_/gi; + if ($name) { + $name =~ s/\W/_/gi; - # saner class name - $dbtype = 'ASE' if $dbtype eq 'SQL_Server'; - - my $subclass = __PACKAGE__ . "::$dbtype"; - if ($self->load_optional_class($subclass)) { - bless $self, $subclass; - $self->_rebless; + # saner class name + $name = 'ASE' if $name eq 'SQL_Server'; } - } + + $name; # RV + } catch { + $self->throw_exception("Unable to establish connection to determine database type: $_") + }; } sub _init { @@ -131,14 +128,18 @@ sub _using_freetds_version { return $inf =~ /v([0-9\.]+)/ ? $1 : 0; } -1; - -=head1 AUTHORS +=head1 FURTHER QUESTIONS? -See L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut + +1; + diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm index 50a8f6b1c..c471bf8fb 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm @@ -179,7 +179,7 @@ sub disconnect { # Even though we call $sth->finish for uses off the bulk API, there's still an # "active statement" warning on disconnect, which we throw away here. -# This is due to the bug described in insert_bulk. +# This is due to the bug described in _insert_bulk. # Currently a noop because 'prepare' is used instead of 'prepare_cached'. local $SIG{__WARN__} = sigwarn_silencer(qr/active statement/i) if $self->_is_bulk_storage; @@ -233,7 +233,7 @@ Also sets the C value for blob write operations. The default is C<1>, but C<0> is better if your database is configured for it. See -L. +L. =cut @@ -256,23 +256,6 @@ sub _is_lob_column { sub _prep_for_execute { my ($self, $op, $ident, $args) = @_; - # -### This is commented out because all tests pass. However I am leaving it -### here as it may prove necessary (can't think through all combinations) -### BTW it doesn't currently work exactly - need better sensitivity to - # currently set value - # - #my ($op, $ident) = @_; - # - # inherit these from the parent for the duration of _prep_for_execute - # Don't know how to make a localizing loop with if's, otherwise I would - #local $self->{_autoinc_supplied_for_op} - # = $self->_parent_storage->_autoinc_supplied_for_op - #if ($op eq 'insert' or $op eq 'update') and $self->_parent_storage; - #local $self->{_perform_autoinc_retrieval} - # = $self->_parent_storage->_perform_autoinc_retrieval - #if ($op eq 'insert' or $op eq 'update') and $self->_parent_storage; - my $limit; # extract and use shortcut on limit without offset if ($op eq 'select' and ! $args->[4] and $limit = $args->[3]) { $args = [ @$args ]; @@ -353,10 +336,12 @@ sub insert { my $columns_info = $source->columns_info; - my $identity_col = - (first { $columns_info->{$_}{is_auto_increment} } - keys %$columns_info ) - || ''; + my ($identity_col) = grep + { $columns_info->{$_}{is_auto_increment} } + keys %$columns_info + ; + + $identity_col = '' if ! defined $identity_col; # FIXME - this is duplication from DBI.pm. When refactored towards # the LobWriter this can be folded back where it belongs. @@ -364,10 +349,10 @@ sub insert { ? 1 : 0 ; - local $self->{_perform_autoinc_retrieval} = - ($identity_col and ! exists $to_insert->{$identity_col}) - ? $identity_col - : undef + + local $self->{_perform_autoinc_retrieval} = $self->{_autoinc_supplied_for_op} + ? undef + : $identity_col ; # check for empty insert @@ -391,53 +376,42 @@ sub insert { my $blob_cols = $self->_remove_blob_cols($source, $to_insert); - # do we need the horrific SELECT MAX(COL) hack? - my $need_dumb_last_insert_id = ( - $self->_perform_autoinc_retrieval - && - ($self->_identity_method||'') ne '@@IDENTITY' - ); - - my $next = $self->next::can; - - # we are already in a transaction, or there are no blobs - # and we don't need the PK - just (try to) do it - if ($self->{transaction_depth} - || (!$blob_cols && !$need_dumb_last_insert_id) + # if a new txn is needed - it must happen on the _writer/new connection (for now) + my $guard; + if ( + ! $self->transaction_depth + and + ( + $blob_cols + or + # do we need the horrific SELECT MAX(COL) hack? + ( + $self->_perform_autoinc_retrieval + and + ( ($self->_identity_method||'') ne '@@IDENTITY' ) + ) + ) ) { - return $self->_insert ( - $next, $source, $to_insert, $blob_cols, $identity_col - ); + $self = $self->_writer_storage; + $guard = $self->txn_scope_guard; } - # otherwise use the _writer_storage to do the insert+transaction on another - # connection - my $guard = $self->_writer_storage->txn_scope_guard; - - my $updated_cols = $self->_writer_storage->_insert ( - $next, $source, $to_insert, $blob_cols, $identity_col - ); - - $self->_identity($self->_writer_storage->_identity); + my $updated_cols = $self->next::method ($source, $to_insert); - $guard->commit; - - return $updated_cols; -} - -sub _insert { - my ($self, $next, $source, $to_insert, $blob_cols, $identity_col) = @_; - - my $updated_cols = $self->$next ($source, $to_insert); - - my $final_row = { - ($identity_col ? - ($identity_col => $self->last_insert_id($source, $identity_col)) : ()), - %$to_insert, - %$updated_cols, - }; + $self->_insert_blobs ( + $source, + $blob_cols, + { + ( $identity_col + ? ( $identity_col => $self->last_insert_id($source, $identity_col) ) + : () + ), + %$to_insert, + %$updated_cols, + }, + ) if $blob_cols; - $self->_insert_blobs ($source, $blob_cols, $final_row) if $blob_cols; + $guard->commit if $guard; return $updated_cols; } @@ -501,7 +475,7 @@ sub update { } } -sub insert_bulk { +sub _insert_bulk { my $self = shift; my ($source, $cols, $data) = @_; @@ -535,10 +509,10 @@ sub insert_bulk { # next::method uses a txn anyway, but it ends too early in case we need to # select max(col) to get the identity for inserting blobs. - ($self, my $guard) = $self->{transaction_depth} == 0 ? - ($self->_writer_storage, $self->_writer_storage->txn_scope_guard) - : - ($self, undef); + ($self, my $guard) = $self->transaction_depth + ? ($self, undef) + : ($self->_writer_storage, $self->_writer_storage->txn_scope_guard) + ; $self->next::method(@_); @@ -607,7 +581,7 @@ sub insert_bulk { # This ignores any data conversion errors detected by the client side libs, as # they are usually harmless. my $orig_cslib_cb = DBD::Sybase::set_cslib_cb( - Sub::Name::subname insert_bulk => sub { + Sub::Name::subname _insert_bulk_cslib_errhandler => sub { my ($layer, $origin, $severity, $errno, $errmsg, $osmsg, $blkmsg) = @_; return 1 if $errno == 36; @@ -678,14 +652,14 @@ sub insert_bulk { if ($exception =~ /-Y option/) { my $w = 'Sybase bulk API operation failed due to character set incompatibility, ' - . 'reverting to regular array inserts. Try unsetting the LANG environment variable' + . 'reverting to regular array inserts. Try unsetting the LC_ALL environment variable' ; $w .= "\n$exception" if $self->debug; carp $w; $self->_bulk_storage(undef); unshift @_, $self; - goto \&insert_bulk; + goto \&_insert_bulk; } elsif ($exception) { # rollback makes the bulkLogin connection unusable @@ -717,7 +691,7 @@ sub _remove_blob_cols { return %blob_cols ? \%blob_cols : undef; } -# same for insert_bulk +# same for _insert_bulk sub _remove_blob_cols_array { my ($self, $source, $cols, $data) = @_; @@ -757,7 +731,7 @@ sub _update_blobs { if ( ref $where eq 'HASH' and - @primary_cols == grep { defined $where->{$_} } @primary_cols + ! grep { ! defined $where->{$_} } @primary_cols ) { my %row_to_update; @row_to_update{@primary_cols} = @{$where}{@primary_cols}; @@ -776,12 +750,10 @@ sub _update_blobs { } sub _insert_blobs { - my ($self, $source, $blob_cols, $row) = @_; - my $dbh = $self->_get_dbh; + my ($self, $source, $blob_cols, $row_data) = @_; my $table = $source->name; - my %row = %$row; my @primary_cols = try { $source->_pri_cols_or_die } catch { @@ -789,13 +761,18 @@ sub _insert_blobs { }; $self->throw_exception('Cannot update TEXT/IMAGE column(s) without primary key values') - if ((grep { defined $row{$_} } @primary_cols) != @primary_cols); + if grep { ! defined $row_data->{$_} } @primary_cols; + + # if we are 2-phase inserting a blob - there is nothing to retrieve anymore, + # regardless of the previous state of the flag + local $self->{_perform_autoinc_retrieval} + if $self->_perform_autoinc_retrieval; + + my %where = map {( $_ => $row_data->{$_} )} @primary_cols; for my $col (keys %$blob_cols) { my $blob = $blob_cols->{$col}; - my %where = map { ($_, $row{$_}) } @primary_cols; - my $cursor = $self->select ($source, [$col], \%where, {}); $cursor->next; my $sth = $cursor->sth; @@ -1082,15 +1059,15 @@ for L. =head1 LIMITED QUERIES -Because ASE does not have a good way to limit results in SQL that works for all -types of queries, the limit dialect is set to -L. +Because ASE does not have a good way to limit results in SQL that works for +all types of queries, the limit dialect is set to +L. Fortunately, ASE and L support cursors properly, so when -L is too slow you can use -the L -L attribute to simulate limited queries by skipping over -records. +L is too slow +you can use the L +L attribute to simulate limited queries by skipping +over records. =head1 TEXT/IMAGE COLUMNS @@ -1130,7 +1107,7 @@ L call, eg.: B the L calls in your C classes B list columns in database order for this -to work. Also, you may have to unset the C environment variable before +to work. Also, you may have to unset the C environment variable before loading your app, as C is not yet supported in DBD::Sybase . When inserting IMAGE columns using this method, you'll need to use @@ -1196,13 +1173,13 @@ bulk_insert using prepare_cached (see comments.) =back -=head1 AUTHOR +=head1 FURTHER QUESTIONS? -See L and L. +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. - -=cut -# vim:sts=2 sw=2: +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/ASE/NoBindVars.pm b/lib/DBIx/Class/Storage/DBI/Sybase/ASE/NoBindVars.pm index b5ade315f..ffd72c4be 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase/ASE/NoBindVars.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase/ASE/NoBindVars.pm @@ -81,8 +81,10 @@ You can also enable this driver explicitly using: $schema->storage_type('::DBI::Sybase::ASE::NoBindVars'); $schema->connect($dsn, $user, $pass, \%opts); -See the discussion in L<< DBD::Sybase/Using ? Placeholders & bind parameters to -$sth->execute >> for details on the pros and cons of using placeholders. +See the discussion in +L<< DBD::Sybase/Using ? Placeholders & bind parameters to $sth->execute >> +for details on the pros and cons of using placeholders with this particular +driver. One advantage of not using placeholders is that C